├── .github
└── workflows
│ └── haskell.yml
├── .gitignore
├── Makefile
├── README.md
├── RothwellMaryShelley.jpg
├── Setup.hs
├── TODO.md
├── config.php.sample
├── doc
└── BuildingAPage.md
├── emacs
├── emacs
└── shonkier.el
├── examples
├── anonymous.gold
├── anonymous.jsgold
├── anonymous.shonkier
├── append.gold
├── append.jsgold
├── append.shonkier
├── bipping.gold
├── bipping.jsgold
├── bipping.shonkier
├── bool.gold
├── bool.jsgold
├── bool.shonkier
├── brace-sections.gold
├── brace-sections.jsgold
├── brace-sections.shonkier
├── catch.gold
├── catch.jsgold
├── catch.shonkier
├── code-default.html
├── code-default.mary
├── comments.gold
├── comments.jsgold
├── comments.shonkier
├── commit.gold
├── commit.jsgold
├── commit.shonkier
├── dot.html
├── dot.mary
├── dot.sed
├── enum.gold
├── enum.html
├── enum.jsgold
├── enum.mary
├── enum.shonkier
├── explicit.gold
├── explicit.jsgold
├── explicit.shonkier
├── forms.html
├── forms.input
├── forms.mary
├── guards.gold
├── guards.jsgold
├── guards.shonkier
├── hello.html
├── hello.mary
├── highlighting.gold
├── highlighting.jsgold
├── highlighting.shonkier
├── hutton.html
├── hutton.mary
├── import-as.gold
├── import-as.jsgold
├── import-as.shonkier
├── import-hidden.gold
├── import-hidden.jsgold
├── import-hidden.shonkier
├── import-up.gold
├── import-up.jsgold
├── import-up.shonkier
├── imports.html
├── imports.mary
├── infix.gold
├── infix.jsgold
├── infix.shonkier
├── inlines.html
├── inlines.mary
├── k-eval.gold
├── k-eval.jsgold
├── k-eval.shonkier
├── length.gold
├── length.jsgold
├── length.shonkier
├── links.html
├── links.mary
├── list.gold
├── list.jsgold
├── list.shonkier
├── list2.gold
├── list2.jsgold
├── list2.shonkier
├── logic.gold
├── logic.jsgold
├── logic.shonkier
├── mary-apply.html
├── mary-apply.mary
├── masking.gold
├── masking.jsgold
├── masking.shonkier
├── mysource.gold
├── mysource.jsgold
├── mysource.shonkier
├── namespaces.gold
├── namespaces.jsgold
├── namespaces.shonkier
├── nested-scope.gold
├── nested-scope.jsgold
├── nested-scope.shonkier
├── parser.gold
├── parser.jsgold
├── parser.shonkier
├── pickle.gold
├── pickle.jsgold
├── pickle.marv
├── pickle.shonkier
├── primitives.gold
├── primitives.jsgold
├── primitives.shonkier
├── quick-exit.gold
├── quick-exit.jsgold
├── quick-exit.shonkier
├── reader.gold
├── reader.jsgold
├── reader.shonkier
├── semi.gold
├── semi.jsgold
├── semi.shonkier
├── serial-env.gold
├── serial-env.jsgold
├── serial-env.shonkier
├── splices.gold
├── splices.jsgold
├── splices.shonkier
├── store.mary
├── strings.gold
├── strings.jsgold
├── strings.shonkier
├── subdir
│ ├── import-down.gold
│ ├── import-down.jsgold
│ └── import-down.shonkier
├── tails.gold
├── tails.jsgold
├── tails.shonkier
├── template.html
├── template.mary
├── world.gold
├── world.jsgold
└── world.shonkier
├── index.php
├── mary.cabal
├── mary.hs
├── marypandoc.sh
├── src
├── Data
│ ├── Bwd.hs
│ └── Lisp.hs
├── Mary
│ ├── Find.hs
│ ├── Interpreter.hs
│ ├── Pandoc.hs
│ ├── ServePage.hs
│ └── Version.hs
├── Shonkier.hs
├── Shonkier
│ ├── Dot.hs
│ ├── Examples.hs
│ ├── FreeVars.hs
│ ├── Import.hs
│ ├── Pandoc.hs
│ ├── Parser.hs
│ ├── Parser
│ │ └── Examples.hs
│ ├── Pretty.hs
│ ├── Pretty
│ │ ├── Examples.hs
│ │ └── Render
│ │ │ └── Pandoc.hs
│ ├── Primitives.hs
│ ├── Scope.hs
│ ├── Semantics.hs
│ ├── Semantics.hs-boot
│ ├── Shonkier.html
│ ├── ShonkierJS.hs
│ ├── Syntax.hs
│ └── Value.hs
├── Utils
│ └── List.hs
└── data-dir
│ ├── Shonkier.js
│ └── shonkier.css
├── templates
└── mary.html5
└── test
└── Test
├── Main.hs
├── Mary.hs
├── Shonkier.hs
└── Utils.hs
/.github/workflows/haskell.yml:
--------------------------------------------------------------------------------
1 | name: Haskell CI
2 |
3 | on: [push]
4 |
5 | jobs:
6 | build:
7 |
8 | runs-on: ubuntu-latest
9 | strategy:
10 | fail-fast: true
11 | matrix:
12 | ghc: ['9.8', '9.6', '9.4', '9.2', '9.0', '8.10']
13 | include:
14 | - ghc: '9.8'
15 | cabal: '3.10'
16 | - ghc: '9.6'
17 | cabal: '3.10'
18 | - ghc: '9.4'
19 | cabal: '3.10'
20 | - ghc: '9.2'
21 | cabal: '3.10'
22 | - ghc: '9.0'
23 | cabal: '3.10'
24 | - ghc: '8.10'
25 | cabal: '3.10'
26 |
27 | steps:
28 | - uses: actions/checkout@v4
29 | name: Checkout Mary
30 |
31 | - uses: haskell-actions/setup@v2
32 | with:
33 | ghc-version: ${{ matrix.ghc }}
34 | cabal-version: ${{ matrix.cabal }}
35 |
36 | - uses: actions/cache@v3
37 | name: Cache ~/.cabal/
38 | with:
39 | path: |
40 | ~/.cabal/store
41 | key: ${{ runner.os }}-ghc-${{ matrix.ghc }}-cabal-${{ matrix.cabal }}-${{ hashFiles('**/mary.cabal') }}-${{ github.sha }}
42 | restore-keys: ${{ runner.os }}-ghc-${{ matrix.ghc }}-cabal-${{ matrix.cabal }}-${{ hashFiles('**/mary.cabal') }}
43 |
44 | - name: Cabal update
45 | run: cabal update
46 |
47 | - name: Configure mary
48 | run: cabal configure --enable-tests
49 |
50 | - name: New install dependencies
51 | run: cabal install --only-dependencies
52 |
53 | - name: Install pandoc
54 | uses: r-lib/actions/setup-pandoc@v2
55 | with:
56 | pandoc-version: '3.0'
57 |
58 | - name: Install graphviz
59 | run: sudo apt-get install graphviz
60 |
61 | - name: New build mary
62 | run: |
63 | cabal build --enable-tests
64 | cabal install --overwrite-policy=always
65 |
66 | - name: Run tests
67 | run: |
68 | cp ~/.cabal/bin/mary .
69 | cabal new-run mary-tests -- --regex-exclude "dot|store"
70 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | TAGS
2 | *~
3 | dist
4 | dist-*
5 | cabal-dev
6 | *.o
7 | *.hi
8 | *.hie
9 | *.chi
10 | *.chs.h
11 | *.dyn_o
12 | *.dyn_hi
13 | .hpc
14 | .hsenv
15 | .cabal-sandbox/
16 | cabal.sandbox.config
17 | *.prof
18 | *.aux
19 | *.hp
20 | *.eventlog
21 | .stack-work/
22 | cabal.project.local
23 | cabal.project.local~
24 | .HTF/
25 | .ghc.environment.*
26 | mary
27 | config.php
28 |
--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | SOURCE = $(shell find src -name '*.lhs' -o -name '*.hs')
2 |
3 | .PHONY: clean install-hasktags TAGS bash-completion
4 |
5 | # From https://stackoverflow.com/questions/18649427/using-a-makefile-with-cabal
6 | # If 'cabal install' fails in building or installing, the
7 | # timestamp on the build dir 'dist' may still be updated. So,
8 | # we set the timestamp on the build dir to a long time in the past
9 | # with 'touch --date "@0"' in case cabal fails.
10 | CABAL_INSTALL = \
11 | cabal install --overwrite-policy=always \
12 | || { touch --date "@0" dist ; \
13 | exit 42 ; }
14 |
15 | install: $(SOURCE)
16 | $(CABAL_INSTALL)
17 | ln -sf `which mary` .
18 | ifeq ("$(wildcard ./config.php)","")
19 | @echo "No config.php found, creating one from config.php.sample"
20 | cp ./config.php.sample ./config.php
21 | endif
22 |
23 | clean:
24 | rm -rf dist dist-newstyle TAGS
25 |
26 | install-hasktags:
27 | cabal update
28 | cabal install hasktags
29 |
30 | .PHONY: test-all test test-mary test-mary-all test-js test-shonkier
31 | test-all:
32 | cabal new-run mary-tests -- -i
33 |
34 | test:
35 | cabal new-run mary-tests -- -i --regex-exclude "dot|store"
36 |
37 | test-mary:
38 | cabal new-run mary-tests -- -i -p Mary --regex-exclude "dot|store"
39 |
40 | test-mary-all:
41 | cabal new-run mary-tests -- -i -p Mary
42 |
43 | test-shonkier:
44 | cabal new-run mary-tests -- -i -p '$$2 == "Shonkier"'
45 |
46 | test-js:
47 | cabal new-run mary-tests -- -i -p ShonkierJS
48 |
49 | TAGS:
50 | hasktags --etags .
51 |
52 | bash-completion:
53 | # Use as follows: source <(make bash-completion)
54 | mary --bash-completion-script `which mary`
55 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # Mary
2 | Mary is the successor of Marx, a content delivery and assessment engine based on markdown and git
3 |
--------------------------------------------------------------------------------
/RothwellMaryShelley.jpg:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/msp-strath/Mary/0b5e7e8704b0c19c127a83e488a35720cf0fd109/RothwellMaryShelley.jpg
--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/TODO.md:
--------------------------------------------------------------------------------
1 | [ ] a div :::{code-default="foo"} for default attributes of inline code (`x` rather than `x`{foo})
2 | [ ] let bindings
3 |
--------------------------------------------------------------------------------
/config.php.sample:
--------------------------------------------------------------------------------
1 |
7 |
--------------------------------------------------------------------------------
/doc/BuildingAPage.md:
--------------------------------------------------------------------------------
1 | Building a Mary site
2 | --------------------
3 |
4 | A Mary site is organised using the filesystem. Each page sits in
5 | its own subdirectory. For instance, the page `events/lectures/2020-01-20`
6 | is defined by the content of the directory `events/lectures/2020-01-20`.
7 | We expect:
8 |
9 | * A `blah.mary` file
10 | * (optional) a `pub/` directory for public content (images, pdfs, etc.) that
11 | can be embedded into `blah.mary`
12 |
13 |
14 | Administering a Mary page
15 | -------------------------
16 |
17 | From Mary's point of view, every page comes with extra information:
18 |
19 | * a `config` file spelling out what the access control policies are
20 | * a `log/` directory for user interactions
21 |
22 | The `log/` directory is also structured in a hierarchical manner:
23 | it contains a number of `sessionNNNN` subdirectory (one per session),
24 | each of which contains a number of `uid` subdirectories (one per user).
25 |
--------------------------------------------------------------------------------
/emacs/emacs:
--------------------------------------------------------------------------------
1 | ;; This should be inserted in your .emacs.
2 | ;; Be careful to replace PATH/TO/ with the path...
3 |
4 | ;; shonkier
5 | (autoload 'shonkier-mode "PATH/TO/emacs/shonkier.el" nil t)
6 | (add-to-list 'auto-mode-alist '("\\.shonkier\\'" . shonkier-mode))
7 |
8 | ;; To enable shonkier highlighting of mary code blocks in markdown
9 | ;; files, also add the following to your .emacs. You might need to
10 | ;; first install markdown-mode; see https://github.com/jrblevin/markdown-mode
11 | ;; for details on how to do that.
12 |
13 | (require 'markdown-mode)
14 | (setq markdown-fontify-code-blocks-natively t)
15 | (add-to-list 'markdown-code-lang-modes '("mary-def" . shonkier-mode))
16 | (add-to-list 'markdown-code-lang-modes '("mary" . shonkier-mode))
17 | (add-to-list 'auto-mode-alist '("\\.mary\\'" . markdown-mode))
18 |
--------------------------------------------------------------------------------
/emacs/shonkier.el:
--------------------------------------------------------------------------------
1 | ;; based on:
2 | ;; http://ergoemacs.org/emacs/elisp_syntax_coloring.html
3 | ;; https://github.com/bobatkey/sott/blob/master/emacs/sott.el
4 |
5 | ;; define several class of keywords
6 | (setq shonkier-keywords '("import" "as"))
7 | (setq shonkier-operators '("->" "@" ";" ":="))
8 | (setq shonkier-warnings '("TODO" "FIXME"))
9 |
10 | ;; create the regex string for each class of keywords
11 | (setq shonkier-keywords-regexp (regexp-opt shonkier-keywords 'words))
12 | (setq shonkier-operators-regexp (regexp-opt shonkier-operators))
13 | (setq shonkier-warnings-regexp (regexp-opt shonkier-warnings))
14 | (setq shonkier-numeric-regexp "[[:space:](,|>[{;/]\\([[:digit:]]+\\([\./][[:digit:]]+\\)?\\)")
15 | (setq shonkier-function-def-regexp "^\\([[:alpha:]][[:alnum:]]+\\)[[:space:]]*(")
16 | (setq shonkier-strings-regexp "\\(\\([[:alpha:]][[:alnum:]]*\\)?\\)\".*?\"\\1")
17 |
18 | ;; clear memory
19 | (setq shonkier-keywords nil)
20 | (setq shonkier-operators nil)
21 | (setq shonkier-warnings nil)
22 |
23 | ;; create the list for font-lock.
24 | ;; each class of keyword is given a particular face
25 | (setq shonkier-font-lock-keywords
26 | `(
27 | (,shonkier-keywords-regexp . font-lock-keyword-face)
28 | (,shonkier-operators-regexp . font-lock-builtin-face)
29 | ;; for warnings we override pre-existing colours (e.g. comment)
30 | (,shonkier-warnings-regexp 0 font-lock-warning-face t)
31 | (,"prim[[:alpha:]]+" . font-lock-builtin-face)
32 | (,"'[[:alnum:]]+" . font-lock-constant-face)
33 | (,shonkier-numeric-regexp . (1 font-lock-constant-face))
34 | (,shonkier-function-def-regexp . (1 font-lock-function-name-face))
35 | (,shonkier-strings-regexp 0 font-lock-string-face t)
36 | ))
37 |
38 | ;; syntax table
39 | (defvar shonkier-syntax-table nil "Syntax table for `shonkier-mode'.")
40 | (setq shonkier-syntax-table
41 | (let ((st (make-syntax-table)))
42 |
43 | ;; single line & nesting multiple lines
44 | (modify-syntax-entry ?/ ". 124b" st)
45 | (modify-syntax-entry ?* ". 23n" st)
46 | (modify-syntax-entry ?\n "> b" st)
47 |
48 | ;; strings are highlighted separately
49 | (modify-syntax-entry ?\" "." st)
50 |
51 | st))
52 |
53 | (defvar shonkier-mode-map
54 | (let ((map (make-sparse-keymap)))
55 | (define-key map "\C-c\C-l" 'shonkier-interpret)
56 | (define-key map "\C-c\C-c" 'shonkier-compile-js)
57 | map)
58 | "Keymap for shonkier mode.")
59 |
60 | (defun shonkier-interpret ()
61 | "Run shonkier interpreter"
62 | (interactive)
63 | (compile (concat "mary shonkier " buffer-file-name)))
64 |
65 | (defun shonkier-compile-js ()
66 | "Run shonkier to Javascript compiler"
67 | (interactive)
68 | (compile (concat "mary shonkierjs " buffer-file-name)))
69 |
70 |
71 | (easy-menu-define shonkier-mode-menu shonkier-mode-map
72 | "Menu used when shonkier mode is active."
73 | '("Shonkier"
74 | ["Interpret" shonkier-interpret
75 | :help "Run shonkier interpreter"]
76 | ["Compile to JS" shonkier-compile-js
77 | :help "Run compiler producing Javascript"]))
78 |
79 | ;; define the mode
80 | (define-derived-mode shonkier-mode prog-mode
81 | "SHONKIER mode"
82 | ;; handling comments
83 | :syntax-table shonkier-syntax-table
84 | ;; code for syntax highlighting
85 | ;; (setq font-lock-keywords-only t)
86 | (setq font-lock-defaults '((shonkier-font-lock-keywords)))
87 | (setq mode-name "shonkier")
88 | ;; add menu
89 | (easy-menu-add shonkier-mode-menu)
90 | ;; clear memory
91 | (setq shonkier-keywords-regexp nil)
92 | (setq shonkier-operators-regexp nil)
93 | (setq shonkier-warnings-regexp nil)
94 | (setq shonkier-numeric-regexp nil)
95 | )
96 |
97 | (provide 'shonkier-mode)
98 |
--------------------------------------------------------------------------------
/examples/anonymous.gold:
--------------------------------------------------------------------------------
1 | ['true
2 | 'false
3 | {[] -> 'true
4 | [_|_] -> 'false
5 | }
6 | {'true [x|xs] -> xs
7 | 'false [x|xs] -> [x]
8 | _ [] -> []
9 | }
10 | {'atom}
11 | x := 'hi; {y -> x}]
12 |
--------------------------------------------------------------------------------
/examples/anonymous.jsgold:
--------------------------------------------------------------------------------
1 | ['true 'false ]
2 |
--------------------------------------------------------------------------------
/examples/anonymous.shonkier:
--------------------------------------------------------------------------------
1 | main() ->
2 | [ {[] -> 'true [_|_] -> 'false}([])
3 | {[] -> 'true [_|_] -> 'false}(['boo])
4 | {[] -> 'true [_|_] -> 'false}
5 | { 'true [x|xs] -> xs
6 | 'false [x|xs] -> [x]
7 | _ [] -> []
8 | }
9 | {'atom}
10 | { x -> { y -> x }}('hi)
11 | ]
12 |
--------------------------------------------------------------------------------
/examples/append.gold:
--------------------------------------------------------------------------------
1 | [1 2 3 4]
2 |
--------------------------------------------------------------------------------
/examples/append.jsgold:
--------------------------------------------------------------------------------
1 | [1 2 3 4]
2 |
--------------------------------------------------------------------------------
/examples/append.shonkier:
--------------------------------------------------------------------------------
1 | append([] , ys) -> ys
2 | append([x|xs], ys) -> [x|append(xs, ys)]
3 |
4 | onetwo() -> [1 2]
5 | threefour() -> [3 4]
6 |
7 | main() -> append(onetwo(), threefour())
8 |
--------------------------------------------------------------------------------
/examples/bipping.gold:
--------------------------------------------------------------------------------
1 | ["hello world" [] ['bip] ['bip 'bip] ['bip 'bip 'bip]]
2 |
--------------------------------------------------------------------------------
/examples/bipping.jsgold:
--------------------------------------------------------------------------------
1 | ["hello world" [] ['bip] ['bip 'bip] ['bip 'bip 'bip]]
2 |
--------------------------------------------------------------------------------
/examples/bipping.shonkier:
--------------------------------------------------------------------------------
1 | pipe('send,'recv):
2 | pipe({'send(x) -> ks},{'recv() -> kr}) -> pipe(ks([]),kr(x))
3 | pipe({s},v) -> v
4 |
5 | runState(, 'get 'put):
6 | runState(s, v) -> v
7 | runState(s, {'get() -> k}) -> runState(s, k(s))
8 | runState(x, {'put(s) -> k}) -> runState(s, k([]))
9 |
10 | map(f,[]) -> []
11 | map(f,[x|xs]) -> [f(x)|map(f,xs)]
12 |
13 | bipper() -> 'send('get()); 'put(['bip|'get()]); bipper()
14 |
15 | main() -> [ primStringConcat(["hello" | foo" world"foo])
16 | | runState([],pipe(bipper(),map({x -> 'recv()},[[] [] [] []])))
17 | ]
18 |
--------------------------------------------------------------------------------
/examples/bool.gold:
--------------------------------------------------------------------------------
1 | [[['0 '1] ['1 '0]] [['0 '0] ['0 '1]] [['0 '1] ['1 '1]]]
2 |
--------------------------------------------------------------------------------
/examples/bool.jsgold:
--------------------------------------------------------------------------------
1 | [[['0 '1] ['1 '0]] [['0 '0] ['0 '1]] [['0 '1] ['1 '1]]]
2 |
--------------------------------------------------------------------------------
/examples/bool.shonkier:
--------------------------------------------------------------------------------
1 |
2 | and('0,y) -> '0
3 | and('1,y) -> y
4 |
5 | or('1,y) -> '1
6 | or('0,y) -> y
7 |
8 | not('0) -> '1
9 | not('1) -> '0
10 |
11 | xor(x,y) -> and(or(x,y), not(and(x,y)))
12 |
13 | enum(f) -> [f('0) f('1) ]
14 |
15 | main() -> [ enum({ x -> enum({ y -> xor(x, y) }) })
16 | enum({ x -> enum({ y -> and(x, y) }) })
17 | enum({ x -> enum({ y -> or(x, y) }) })
18 | ]
19 |
--------------------------------------------------------------------------------
/examples/brace-sections.gold:
--------------------------------------------------------------------------------
1 | ["Hello, World!" {_} 4 42 'phew]
2 |
--------------------------------------------------------------------------------
/examples/brace-sections.jsgold:
--------------------------------------------------------------------------------
1 | ["Hello, World!" 4 42 'phew]
2 |
--------------------------------------------------------------------------------
/examples/brace-sections.shonkier:
--------------------------------------------------------------------------------
1 | main() -> [
2 | {"`_`, `_`!"}("Hello", "World")
3 | {_}
4 | {_}(4)
5 | {3 * _ + 7 * _}(7, 3)
6 | {'0 -> _ '1 -> _}('boo, 'phew, '1)
7 | ]
8 |
--------------------------------------------------------------------------------
/examples/catch.gold:
--------------------------------------------------------------------------------
1 | []
2 |
--------------------------------------------------------------------------------
/examples/catch.jsgold:
--------------------------------------------------------------------------------
1 | []
2 |
--------------------------------------------------------------------------------
/examples/catch.shonkier:
--------------------------------------------------------------------------------
1 | catchInvalidNamespace('InvalidNamespace):
2 | catchInvalidNamespace({ 'InvalidNamespace(_) -> _ }, k) -> k()
3 | catchInvalidNamespace(v,_) -> v
4 |
5 | catchAmbiguousVar('AmbiguousVar):
6 | catchAmbiguousVar({ 'AmbiguousVar(_) -> _ }, k) -> k()
7 | catchAmbiguousVar(v,_) -> v
8 |
9 | catchOutOfScope('OutOfScope):
10 | catchOutOfScope({ 'OutOfScope(_) -> _ }, k) -> k()
11 | catchOutOfScope(v,_) -> v
12 |
13 | catchNotFuny('NotFuny):
14 | catchNotFuny({ 'NotFuny() -> _ }, k) -> k()
15 | catchNotFuny(v,_) -> v
16 |
17 | main() -> []
18 |
--------------------------------------------------------------------------------
/examples/code-default.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | Title TBA
8 |
9 |
12 |
13 |
55 |
63 |
64 |
65 |
66 |
69 |
70 |
71 |
--------------------------------------------------------------------------------
/examples/code-default.mary:
--------------------------------------------------------------------------------
1 | ```mary-def
2 | testBlock() -> ['Para "Hello" 'Space ['Strong "World"]]
3 | ```
4 |
5 | ::: {.code-default .mary-eval}
6 | ```
7 | testBlock()
8 | ```
9 | :::
10 |
--------------------------------------------------------------------------------
/examples/comments.gold:
--------------------------------------------------------------------------------
1 | [3 6 1]
2 |
--------------------------------------------------------------------------------
/examples/comments.jsgold:
--------------------------------------------------------------------------------
1 | [3 6 1]
2 |
--------------------------------------------------------------------------------
/examples/comments.shonkier:
--------------------------------------------------------------------------------
1 | import "examples/list.shonkier" // getting map, fold, ...
2 | as /* Keyword **/ List
3 |
4 | // Now the real work begins
5 |
6 | myList() -> [1 2 1/3 /* That's right, numerals are rationals! */]
7 | myFun(x) -> primInfixTimes(x,3)
8 |
9 | /* Note that you can.
10 | /* Nest comments.
11 | If you want to.
12 |
13 | */
14 |
15 | /*
16 | And that is totally fine.
17 | Just don't forget to close them all at the end!
18 | */*/
19 |
20 | main(/* Anywhere space may be */)/*so can */
21 | -> // a comment
22 | /* Isn't that great?
23 | */ map(/* myFun is the function */ myFun
24 | , myList() // and myList is the list
25 | )
26 |
27 | // /* This comment is not closed but it's commented out so WHO CARES?
28 |
--------------------------------------------------------------------------------
/examples/commit.gold:
--------------------------------------------------------------------------------
1 | [['Plus ['Plus 42 37] 5]
2 | ['Plus 42 ['Plus 37 5]]
3 | [[[] []] [[] []]]
4 | 'phew
5 | 2
6 | [2 1]]
7 |
--------------------------------------------------------------------------------
/examples/commit.jsgold:
--------------------------------------------------------------------------------
1 | [['Plus ['Plus 42 37] 5] ['Plus 42 ['Plus 37 5]] [[[] []] [[] []]] 'phew 2 [2 1]]
2 |
--------------------------------------------------------------------------------
/examples/commit.shonkier:
--------------------------------------------------------------------------------
1 | parse(cs, p) -> prefer(supply(cs, p()))
2 | parses(cs, p) -> collect(supply(cs, p()))
3 |
4 | supply(,'getChar):
5 | supply("`[c|cs]`", {'getChar() -> k}) -> supply(cs,k(c))
6 | supply("" , {'getChar() -> k}) -> k('abort())
7 | supply("", v) -> v
8 |
9 | prefer('choice):
10 | prefer({'choice(a, b) -> k}) -> prefer(k(a())) ?> prefer(k(b()))
11 | prefer(v) -> v
12 |
13 | append([], ys) -> ys
14 | append([x|xs], ys) -> [x|append(xs,ys)]
15 |
16 | collect('choice,'abort):
17 | collect({'choice(a, b) -> k}) -> append(collect(k(a())), collect(k(b())))
18 | collect({'abort() -> k}) -> []
19 | collect(v) -> [v]
20 |
21 | commit(p) -> 'abort ^ p()
22 |
23 | some(p) -> [p()|many(p)]
24 | many(p) -> 'choice({[p() | commit({many(p)})]},{[]})
25 |
26 | digit("0") -> 0
27 | digit("1") -> 1
28 | digit("2") -> 2
29 | digit("3") -> 3
30 | digit("4") -> 4
31 | digit("5") -> 5
32 | digit("6") -> 6
33 | digit("7") -> 7
34 | digit("8") -> 8
35 | digit("9") -> 9
36 |
37 | map(f,[]) -> []
38 | map(f,[x|xs]) -> [f(x)|map(f,xs)]
39 |
40 | unpack("") -> []
41 | unpack("`[c|cs]`") -> [c|unpack(cs)]
42 |
43 | eat(s) -> map({_ == 'getChar(); []}, unpack(s))
44 |
45 | number() -> convert(reverse(some({digit('getChar())})))
46 |
47 | grow(v, m) -> 'choice({grow(m(v),m)}, {v})
48 |
49 | parens(p) -> eat("("); x := p(); eat(")"); x
50 |
51 | wee() -> 'choice(number, {parens(addition)})
52 |
53 | addition() -> grow(wee(), {x -> eat("+"); commit({['Plus x wee()]})})
54 |
55 | reverse(xs) -> reverseAcc([],xs)
56 | reverseAcc(acc,[]) -> acc
57 | reverseAcc(acc,[x|xs]) -> reverseAcc([x|acc],xs)
58 |
59 | convert([]) -> 0
60 | convert([d|ds]) -> d + 10 * convert(ds)
61 |
62 | tree() -> 'choice({eat("N"); commit({[tree() tree()]})}, {eat("L"); []})
63 |
64 | main() -> [
65 | parse("42+37+5", addition)
66 | parse("42+(37+5)", addition)
67 | parse("NNLLNLL", tree)
68 | parse("NNLLNLX", tree) ?> 'phew
69 | parse("", {'choice('abort, {1}) ?> 2})
70 | parses("", {'choice('abort, {1}) ?> 2})
71 | ]
72 |
--------------------------------------------------------------------------------
/examples/dot.mary:
--------------------------------------------------------------------------------
1 | # Inline SVG
2 |
3 | Using the following program:
4 |
5 | ```{ .mary-def .keep }
6 | import "list.shonkier"
7 |
8 | toSVG(d) -> ['Div ["mary-svg" []|[]] ['RawBlock "html" 'dot(d) ]]
9 |
10 | renderTree(n,['Node nm a b]) ->
11 | append([ ['node n ["label" nm]]
12 | ['edge [n 'sw] "`n`0"]
13 | ['edge [n 'se] "`n`1"]
14 | ]
15 | ,append(renderTree("`n`0",a), renderTree("`n`1",b))
16 | )
17 | renderTree(n,['Leaf nm]) -> [['node n ["label" nm]]]
18 |
19 | prettyTree(t) -> ['digraph []|renderTree("ND",t)]
20 |
21 | dotTree(t) -> toSVG(prettyTree(t))
22 |
23 | testTree() -> dotTree(['Node "+" ['Node "*" ['Leaf "17"]
24 | ['Leaf "12"]]
25 | ['Leaf "3"]])
26 |
27 | renderList(n,[x|xs]) -> next := "`n`0";
28 | [['node n ["label" x]]
29 | ['edge n next]
30 | |renderList(next,xs)
31 | ]
32 | renderList(n,[]) -> [['node n ["label" "[]"]]]
33 |
34 | prettyList(xs) -> ['digraph []|renderList("ND",xs)]
35 |
36 | dotList(xs) -> toSVG(prettyList(xs))
37 |
38 | testList() -> dotList(["a" "b"])
39 | ```
40 |
41 | we can generate a list:
42 |
43 | ```mary
44 | testList()
45 | ```
46 |
47 | and we can generate a tree:
48 |
49 | ```mary
50 | testTree()
51 | ```
52 |
--------------------------------------------------------------------------------
/examples/dot.sed:
--------------------------------------------------------------------------------
1 | s/\(Generated by graphviz\)[^-]*$/\1/
2 |
--------------------------------------------------------------------------------
/examples/enum.gold:
--------------------------------------------------------------------------------
1 | ['Div
2 | "Enums"
3 | []
4 | []
5 | ['Plain "Abcd"]
6 | ['BulletList
7 | [['Plain "A"]]
8 | [['Plain "bcd"]
9 | ['BulletList
10 | [['Plain "bc"] ['BulletList [['Plain "b"]] [['Plain "c"]]]]
11 | [['Plain "d"]]]]]]
12 |
--------------------------------------------------------------------------------
/examples/enum.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | Recursively building content
8 |
9 |
12 |
13 |
61 |
69 |
70 |
71 |
72 |
118 |
119 |
120 |
--------------------------------------------------------------------------------
/examples/enum.jsgold:
--------------------------------------------------------------------------------
1 | ['Div "Enums" [] [] ['Plain "Abcd"] ['BulletList [['Plain "A"]] [['Plain "bcd"] ['BulletList [['Plain "bc"] ['BulletList [['Plain "b"]] [['Plain "c"]]]] [['Plain "d"]]]]]]
2 |
--------------------------------------------------------------------------------
/examples/enum.mary:
--------------------------------------------------------------------------------
1 | # Recursively building content
2 |
3 | This is a nested enumeration with concatenated sublists as
4 | intermediate items.
5 |
6 | ```mary-eval
7 | test()
8 | ```
9 |
10 | It was generated using the following code:
11 |
12 | ``` { .mary-def .keep }
13 | map(f, []) -> []
14 | map(f, [x|xs]) -> [f(x)|map(f, xs)]
15 |
16 | enum(xs@[_|_]) -> [['Plain primStringConcat(xs)] ['BulletList|map(enum,xs)]]
17 | enum(xs) -> [['Plain xs]]
18 |
19 | test() -> ['Div ["Enums" []|[]]|enum(["A" [["b" "c"] "d"]])]
20 | ```
21 |
--------------------------------------------------------------------------------
/examples/enum.shonkier:
--------------------------------------------------------------------------------
1 | map(f, []) -> []
2 | map(f, [x|xs]) -> [f(x)|map(f, xs)]
3 |
4 | enum(xs@[_|_]) -> [['Plain primStringConcat(xs)] ['BulletList|map(enum,xs)]]
5 | enum(xs) -> [['Plain xs]]
6 |
7 | main() -> ['Div "Enums" [] []|enum(["A" [["b" "c"] "d"]])]
8 |
--------------------------------------------------------------------------------
/examples/explicit.gold:
--------------------------------------------------------------------------------
1 | [5 ['foo 7] 7 'phew 'phew 'phew]
2 |
--------------------------------------------------------------------------------
/examples/explicit.jsgold:
--------------------------------------------------------------------------------
1 | [5 ['foo 7] 7 'phew 'phew 'phew]
2 |
--------------------------------------------------------------------------------
/examples/explicit.shonkier:
--------------------------------------------------------------------------------
1 | foo(x) -> ['foo x]
2 | catch('abort,):
3 | catch(v, _) -> v
4 | catch({'abort() -> k}, f) -> f()
5 |
6 | main() -> [ foo := 5; foo
7 | x := foo(7); x
8 | ['foo x] := foo(7); x
9 | catch(['goo x] := foo(7); x, {'phew})
10 | catch('0 ; 'boo, {'phew})
11 | catch('1 ; 'phew, {'boo})
12 | ]
13 |
--------------------------------------------------------------------------------
/examples/forms.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | Displaying Forms
8 |
9 |
12 |
13 |
66 |
78 |
79 |
80 |
81 |
98 |
99 |
100 |
--------------------------------------------------------------------------------
/examples/forms.input:
--------------------------------------------------------------------------------
1 | name=Eric&number=7&essay=Seven%20weeks%20of%20reading%20papers%0ASeven%20weeks%20of%20feeling%20guilty%0ASeven%20weeks%20of%20staying%20up%20all%20night
2 |
3 |
--------------------------------------------------------------------------------
/examples/forms.mary:
--------------------------------------------------------------------------------
1 | # Displaying Forms
2 |
3 |
4 | Name: `name`{.input type=text size=12}
5 |
6 | What number am I thinking of? `number`{.input}
7 |
8 | This is what I did during my summer holiday:
9 | ```{.input}
10 | essay
11 | ```
12 |
13 | `Submit answers and essay`{.input type=submit}
14 |
15 | Here is a form which is being submitted empty: `empty`{.input type=text size=1}
16 |
17 | ## Using the inputs
18 |
19 | ```mary-eval
20 | greet()
21 | ```
22 |
23 | ```mary-eval
24 | numberGame('POST(concat("num","ber")))
25 | ```
26 |
27 | ```mary-def
28 | concat(x, y) -> "`x``y`"
29 |
30 | greet() -> ['Para "Hello " 'POST("name") "! You are on page " 'GET("page")]
31 | numberGame(guess) ->
32 | ['Para "Wrong, the right number was "
33 | primNumToString(primStringToNum(guess) + 1)
34 | ". Better luck next time!"]
35 | ```
36 |
--------------------------------------------------------------------------------
/examples/guards.gold:
--------------------------------------------------------------------------------
1 | ['world 'nilly 1 'phew 1 'nope]
2 |
--------------------------------------------------------------------------------
/examples/guards.jsgold:
--------------------------------------------------------------------------------
1 | ['world 'nilly 1 'phew 1 'nope]
2 |
--------------------------------------------------------------------------------
/examples/guards.shonkier:
--------------------------------------------------------------------------------
1 | myfun() | '0 -> 'hello
2 | | '1 -> 'world
3 |
4 | mygun(x) | [] := x -> 'nilly
5 | | [y|ys] := x -> y
6 |
7 | myhun() | '1 -> 'abort()
8 | | '1 -> 'boo
9 |
10 | myiun(f, x) | y := f(x) -> y
11 | | -> 'nope
12 |
13 | head([x|xs]) -> x
14 |
15 | main() ->
16 | [ myfun()
17 | mygun([])
18 | mygun([1 2 3])
19 | myhun() ?> 'phew
20 | myiun(head, [1 2 3])
21 | myiun(head, [])
22 | ]
23 |
--------------------------------------------------------------------------------
/examples/hello.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | Embedding Programs as Fenced Code Blocks
8 |
9 |
12 |
13 |
55 |
63 |
64 |
65 |
66 |
71 |
72 |
73 |
--------------------------------------------------------------------------------
/examples/hello.mary:
--------------------------------------------------------------------------------
1 | # Embedding Programs as Fenced Code Blocks
2 |
3 | ```mary-def
4 | test() -> ['Para "Hello"]
5 | ```
6 |
7 | ```mary-eval
8 | test()
9 | ```
10 |
--------------------------------------------------------------------------------
/examples/highlighting.gold:
--------------------------------------------------------------------------------
1 | [foo" "fo"foo [2|1] 1/425 'atom]
2 |
--------------------------------------------------------------------------------
/examples/highlighting.jsgold:
--------------------------------------------------------------------------------
1 | [" "fo" [2|1] 1/425 'atom]
2 |
--------------------------------------------------------------------------------
/examples/highlighting.shonkier:
--------------------------------------------------------------------------------
1 | import "examples/list.shonkier" as List2344
2 |
3 | /* The purpose of this file is to test the emacs
4 | mode for Shonkier.
5 | /* So we have
6 | All the
7 | */*/
8 |
9 | // /* Bells and whistles
10 |
11 | id(x) -> x
12 | half() ->primInfixTimes(0.25,2)
13 |
14 | main() -> map(id,[foo" "fo"foo [2.0|1.0] 1/425 'atom])
15 |
16 | // TODO: nothing left to do!
17 |
--------------------------------------------------------------------------------
/examples/hutton.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | Hutton’s razor
8 |
9 |
12 |
13 |
124 |
132 |
133 |
134 |
135 |
186 |
187 |
188 |
--------------------------------------------------------------------------------
/examples/hutton.mary:
--------------------------------------------------------------------------------
1 | # Hutton's razor
2 |
3 | The following AST
4 |
5 | ```mary-eval
6 | main()
7 | ```
8 |
9 | is obtained by running the following program
10 |
11 | ```{ .mary-def .keep }
12 | main() -> ['Plain printTree(parse("31*(13+7*2)+24*42", hutton))]
13 | ```
14 |
15 | using the following auxiliary definitions.
16 |
17 | ``` { .mary-def .keep }
18 | import "examples/parser.shonkier"
19 |
20 | atom() -> 'choice(number,{parens(plus)})
21 | mult() -> chain(atom,{is("*"); 'Mult},atom)
22 | plus() -> chain(mult,{is("+"); 'Plus},mult)
23 |
24 | hutton() -> plus()
25 |
26 | printTree(['Plus s t]) -> "['Plus `printTree(s)` `printTree(t)`]"
27 | printTree(['Mult s t]) -> "['Mult `printTree(s)` `printTree(t)`]"
28 | printTree(n) -> primNumToString(n)
29 | ```
30 |
--------------------------------------------------------------------------------
/examples/import-as.gold:
--------------------------------------------------------------------------------
1 | [[[1 1] [2 2] [3 3] [4 4]] [3 4 "hello" "hello"]]
2 |
--------------------------------------------------------------------------------
/examples/import-as.jsgold:
--------------------------------------------------------------------------------
1 | [[[1 1] [2 2] [3 3] [4 4]] [3 4 "hello" "hello"]]
2 |
--------------------------------------------------------------------------------
/examples/import-as.shonkier:
--------------------------------------------------------------------------------
1 | import "examples/list.shonkier" as List
2 | import "examples/list2.shonkier" as List2
3 | import "examples/append.shonkier" as List3
4 | import "examples/tails.shonkier" as List
5 |
6 | dup(x) -> [x x]
7 |
8 | reverse(xs) -> reverseAcc([],xs)
9 | reverseAcc(acc,[]) -> acc
10 | reverseAcc(acc,[x|xs]) -> reverseAcc([x|acc],xs)
11 |
12 | main() -> [ List3.append( List2.map(dup,onetwo())
13 | , List.map(dup,threefour())
14 | )
15 |
16 | List.append( threefour()
17 | , dup("hello")
18 | )
19 | ]
20 |
--------------------------------------------------------------------------------
/examples/import-hidden.gold:
--------------------------------------------------------------------------------
1 | 3
2 |
--------------------------------------------------------------------------------
/examples/import-hidden.jsgold:
--------------------------------------------------------------------------------
1 | 3
2 |
--------------------------------------------------------------------------------
/examples/import-hidden.shonkier:
--------------------------------------------------------------------------------
1 | import "examples/length.shonkier"
2 | import "examples/list2.shonkier"
3 |
4 | id(x) -> x
5 | main() -> length(map(id,[1 2 3]))
--------------------------------------------------------------------------------
/examples/import-up.gold:
--------------------------------------------------------------------------------
1 | [2 3 4]
2 |
--------------------------------------------------------------------------------
/examples/import-up.jsgold:
--------------------------------------------------------------------------------
1 | [2 3 4]
2 |
--------------------------------------------------------------------------------
/examples/import-up.shonkier:
--------------------------------------------------------------------------------
1 | import "subdir/import-down.shonkier" as M
2 |
3 | main() -> M.main()
4 |
--------------------------------------------------------------------------------
/examples/imports.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | Importing Shonkier files
8 |
9 |
12 |
13 |
77 |
85 |
86 |
87 |
88 |
114 |
115 |
116 |
--------------------------------------------------------------------------------
/examples/imports.mary:
--------------------------------------------------------------------------------
1 | # Importing Shonkier files
2 |
3 | Let's run some code:
4 |
5 | ```mary-eval
6 | hello()
7 | ```
8 | arising from
9 |
10 | ``` { .mary-def .keep }
11 | import "subdir/import-down.shonkier" as foo
12 | import "list.shonkier"
13 |
14 | cat([x y]) -> "`x` `y`"
15 |
16 | hello() -> ['Para cat(map({x -> "`greeting()` `x`"},["there" "World"])) ]
17 | ```
18 |
--------------------------------------------------------------------------------
/examples/infix.gold:
--------------------------------------------------------------------------------
1 | [[{2 + 2} 4]
2 | [{7 - 2 + 4} 9]
3 | [{3 * 3 + 4 * 4} 25]
4 | [{60 / 5 / 3} 4]
5 | [{mathErr(10 / 0) ?> 'phew} 'phew]
6 | [{2 + 2 == 4} '1]
7 | [{5 < 3 \/ 7 >= 6 /\ 5 != 3} '1]
8 | [{! 12 == 13} '1]]
9 |
--------------------------------------------------------------------------------
/examples/infix.jsgold:
--------------------------------------------------------------------------------
1 | [[ 4] [ 9] [ 25] [ 4] [ 'phew] [ '1] [ '1] [ '1]]
2 |
--------------------------------------------------------------------------------
/examples/infix.shonkier:
--------------------------------------------------------------------------------
1 | mathErr('divByZero):
2 | mathErr(x) -> x
3 | mathErr({'divByZero() -> k}) -> 'abort()
4 |
5 | foo(k) -> [k k()]
6 |
7 | main() ->
8 | [ foo({2 + 2})
9 | foo({7 - 2 + 4})
10 | foo({3 * 3 + 4 * 4})
11 | foo({60 / 5 / 3})
12 | foo({mathErr(10 / 0) ?> 'phew})
13 | foo({2 + 2 == 4})
14 | foo({5 < 3 \/ 7 >= 6 /\ 5 != 3})
15 | foo({! 12 == 13})
16 | ]
17 |
18 |
--------------------------------------------------------------------------------
/examples/inlines.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | Embedding Programs as Fenced Code Blocks
8 |
9 |
12 |
13 |
58 |
66 |
67 |
68 |
69 |
77 |
78 |
79 |
--------------------------------------------------------------------------------
/examples/inlines.mary:
--------------------------------------------------------------------------------
1 | # Embedding Programs as Fenced Code Blocks
2 |
3 | ```mary-def
4 | testBlock() -> ['Para "Hello" 'Space ['Strong "World"]]
5 | testInline() -> ['Emph "blether"]
6 | ```
7 |
8 | ``{=html}
9 |
10 | ```mary-eval
11 | testBlock()
12 | ```
13 |
14 | Perhaps this will achieve some `testInline()`{.mary-eval}.
15 |
16 | ``{=html}
17 |
--------------------------------------------------------------------------------
/examples/k-eval.gold:
--------------------------------------------------------------------------------
1 | [12 13]
2 |
--------------------------------------------------------------------------------
/examples/k-eval.jsgold:
--------------------------------------------------------------------------------
1 | [12 13]
2 |
--------------------------------------------------------------------------------
/examples/k-eval.shonkier:
--------------------------------------------------------------------------------
1 | // mungo provides the service 'mungo which offers to look up things but might fail
2 | // mungo knows moo is 5
3 | // if mungo doesn't know what the thing is, it sends an 'abort to its continuation
4 | mungo('mungo):
5 | mungo({'mungo("moo") -> k}) -> mungo(k(5))
6 | mungo({'mungo(_) -> k}) -> mungo(k('abort()))
7 | mungo(x) -> x
8 |
9 | // bungo provides the service 'bungo which offers to look up things but might fail
10 | // bungo knows boo is 7
11 | // bungo also sends aborts
12 | bungo('bungo):
13 | bungo({'bungo("boo") -> k}) -> bungo(k(7))
14 | bungo({'bungo(_) -> k}) -> bungo(k('abort()))
15 | bungo(x) -> x
16 |
17 | // gamma handles the eval-generated 'OutOfScope effect by asking mungo then bungo:
18 | // under k-eval semantics, gamma's ?> will handle any 'abort received by 'mungo's
19 | // continuation
20 | gamma('OutOfScope):
21 | gamma({'OutOfScope(x) -> k}) -> gamma(k('mungo(x) ?> 'bungo(x)))
22 | gamma(x) -> x
23 |
24 | // under k-use, this aborts
25 | // under k-eval, this gives [12 13]
26 | main() -> [ mungo(bungo(gamma(moo + boo ?> 13)))
27 | mungo(bungo(gamma(moo + foo ?> 13)))
28 | ]
29 |
--------------------------------------------------------------------------------
/examples/length.gold:
--------------------------------------------------------------------------------
1 | [2|2]
2 |
--------------------------------------------------------------------------------
/examples/length.jsgold:
--------------------------------------------------------------------------------
1 | [2|2]
2 |
--------------------------------------------------------------------------------
/examples/length.shonkier:
--------------------------------------------------------------------------------
1 | import "examples/list.shonkier"
2 | import "examples/append.shonkier"
3 |
4 | suc(_,x) -> primInfixPlus(1,x)
5 | length(xs) -> fold(suc,0,xs)
6 |
7 | const(_) -> '1
8 |
9 | main() -> [ length(onetwo())
10 | | length(map(const,onetwo()))
11 | ]
12 |
--------------------------------------------------------------------------------
/examples/links.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | Links
8 |
9 |
12 |
13 |
52 |
60 |
61 |
62 |
63 |
89 |
90 |
91 |
--------------------------------------------------------------------------------
/examples/links.mary:
--------------------------------------------------------------------------------
1 | # Links
2 |
3 | Here is an [absolute link](https://twitter.com/TheMERL/status/983341970318938112). This one is [all relative](hello.mary), you know? And these ones are [complicated](subfolder/../enum.mary) [for no](~/examples/enum.mary) [good reason](.././examples/./enum.mary).
4 |
5 | And here are some images:
6 |
7 | 
8 |
9 | 
10 |
--------------------------------------------------------------------------------
/examples/list.gold:
--------------------------------------------------------------------------------
1 | []
2 |
--------------------------------------------------------------------------------
/examples/list.jsgold:
--------------------------------------------------------------------------------
1 | []
2 |
--------------------------------------------------------------------------------
/examples/list.shonkier:
--------------------------------------------------------------------------------
1 | map(f,[]) -> []
2 | map(f,[x|xs]) -> [f(x)|map(f,xs)]
3 |
4 | fold(c,n,[]) -> n
5 | fold(c,n,[x|xs]) -> c(x,fold(c,n,xs))
6 |
7 | append([],ys) -> ys
8 | append([x|xs],ys) -> [x|append(xs,ys)]
9 |
10 | main() -> []
11 |
--------------------------------------------------------------------------------
/examples/list2.gold:
--------------------------------------------------------------------------------
1 | []
2 |
--------------------------------------------------------------------------------
/examples/list2.jsgold:
--------------------------------------------------------------------------------
1 | []
2 |
--------------------------------------------------------------------------------
/examples/list2.shonkier:
--------------------------------------------------------------------------------
1 | map(f,[]) -> []
2 | map(f,[x|xs]) -> [f(x)|map(f,xs)]
3 |
4 | main() -> []
--------------------------------------------------------------------------------
/examples/logic.gold:
--------------------------------------------------------------------------------
1 | ['0 '0 '0 '1 '0 '1 '1 '1]
2 |
--------------------------------------------------------------------------------
/examples/logic.jsgold:
--------------------------------------------------------------------------------
1 | ['0 '0 '0 '1 '0 '1 '1 '1]
2 |
--------------------------------------------------------------------------------
/examples/logic.shonkier:
--------------------------------------------------------------------------------
1 | andLazy(e1,e2) -> e1(); e2() ?> '0
2 | orLazy(e1,e2) -> e1(); '1 ?> e2()
3 |
4 | main() ->
5 | [ andLazy({'0},{'0})
6 | andLazy({'0},{'1})
7 | andLazy({'1},{'0})
8 | andLazy({'1},{'1})
9 | orLazy({'0},{'0})
10 | orLazy({'0},{'1})
11 | orLazy({'1},{'0})
12 | orLazy({'1},{'1})
13 | ]
14 |
--------------------------------------------------------------------------------
/examples/mary-apply.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | Title TBA
8 |
9 |
12 |
13 |
52 |
60 |
61 |
62 |
63 |
77 |
78 |
79 |
--------------------------------------------------------------------------------
/examples/mary-apply.mary:
--------------------------------------------------------------------------------
1 | :::{.code-default .mary-eval}
2 | :::{style="color: white" mary-apply="{ txt -> ['Para txt] }"}
3 | :::{mary-apply="{ n -> primNumToString(n) }" style="background-color:blue"}
4 | :::{mary-apply="{ n -> 2 + n }"}
5 | ```
6 | 0-1
7 | ```
8 | :::{style="background-color:red"}
9 | ```
10 | 0
11 | ```
12 | ```
13 | 1
14 | ```
15 | :::
16 | :::
17 | ```
18 | 4
19 | ```
20 | :::
21 | :::{}
22 | ```
23 | "5"
24 | ```
25 | :::
26 | :::
27 | ```
28 | ['Para "6"]
29 | ```
30 | :::
--------------------------------------------------------------------------------
/examples/masking.gold:
--------------------------------------------------------------------------------
1 | ['inner 'outer]
2 |
--------------------------------------------------------------------------------
/examples/masking.jsgold:
--------------------------------------------------------------------------------
1 | ['inner 'outer]
2 |
--------------------------------------------------------------------------------
/examples/masking.shonkier:
--------------------------------------------------------------------------------
1 | main() ->
2 | [ ('abort() ?> 'inner) ?> 'outer
3 | ('abort ^ 'abort() ?> 'inner) ?> 'outer
4 | ]
5 |
--------------------------------------------------------------------------------
/examples/mysource.gold:
--------------------------------------------------------------------------------
1 | quo"main() -> 'read(["examples" "mysource.shonkier"])
2 | "quo
3 |
--------------------------------------------------------------------------------
/examples/mysource.jsgold:
--------------------------------------------------------------------------------
1 | read
2 |
--------------------------------------------------------------------------------
/examples/mysource.shonkier:
--------------------------------------------------------------------------------
1 | main() -> 'read(["examples" "mysource.shonkier"])
2 |
--------------------------------------------------------------------------------
/examples/namespaces.gold:
--------------------------------------------------------------------------------
1 | [[0 1 2] [3 4 5] [] []]
2 |
--------------------------------------------------------------------------------
/examples/namespaces.jsgold:
--------------------------------------------------------------------------------
1 | [[0 1 2] [3 4 5] [] []]
2 |
--------------------------------------------------------------------------------
/examples/namespaces.shonkier:
--------------------------------------------------------------------------------
1 | import "examples/list.shonkier" as List
2 | import "examples/list2.shonkier" as List2
3 | import "examples/catch.shonkier"
4 |
5 | pred(n) -> primInfixMinus(n,1)
6 |
7 | main() -> [ List.map(pred,[1 2 3])
8 | List2.map(pred,[4 5 6])
9 | catchAmbiguousVar(map(pred,[7 8 9]),{[]})
10 | catchInvalidNamespace(LIST.map(pred,[10 11 12]),{[]})
11 | ]
12 |
--------------------------------------------------------------------------------
/examples/nested-scope.gold:
--------------------------------------------------------------------------------
1 | 'one
2 |
--------------------------------------------------------------------------------
/examples/nested-scope.jsgold:
--------------------------------------------------------------------------------
1 | 'one
2 |
--------------------------------------------------------------------------------
/examples/nested-scope.shonkier:
--------------------------------------------------------------------------------
1 | test(x) -> { y -> x }
2 |
3 | main() -> test('one)('two)
4 |
--------------------------------------------------------------------------------
/examples/parser.gold:
--------------------------------------------------------------------------------
1 | [1 [1 23 75]]
2 |
--------------------------------------------------------------------------------
/examples/parser.jsgold:
--------------------------------------------------------------------------------
1 | [1 [1 23 75]]
2 |
--------------------------------------------------------------------------------
/examples/parser.shonkier:
--------------------------------------------------------------------------------
1 | parse(cs,p) -> [v ""] := runParser(cs,p()); v
2 |
3 | catchAbort('abort,):
4 | catchAbort({'abort() -> _}, _, k) -> k()
5 | catchAbort([a cs], k, _) -> runParser(cs,k(a))
6 |
7 | runParser(,'abort 'getChar 'choice):
8 | runParser("`[c|cs]`", {'getChar() -> k}) -> runParser(cs,k(c))
9 | runParser("" , {'getChar() -> k}) -> k('abort())
10 | runParser(cs , {'choice(a,b) -> k})
11 | -> catchAbort(runParser(cs,a()), k, {catchAbort(runParser(cs,b()),k,'abort)})
12 | runParser(cs , v) -> [v cs]
13 |
14 | satisfy(p) -> p('getChar())
15 | is(c) -> satisfy({ d -> c == d })
16 |
17 | // Lists of parsed values
18 | some(p) -> [p()|many(p)]
19 | many(p) -> 'choice({some(p)},{[]})
20 |
21 | // Digits
22 | isDigit("0") -> 0
23 | isDigit("1") -> 1
24 | isDigit("2") -> 2
25 | isDigit("3") -> 3
26 | isDigit("4") -> 4
27 | isDigit("5") -> 5
28 | isDigit("6") -> 6
29 | isDigit("7") -> 7
30 | isDigit("8") -> 8
31 | isDigit("9") -> 9
32 |
33 | digit() -> satisfy(isDigit)
34 | number() -> convert(reverse(some(digit)))
35 |
36 | reverse(xs) -> reverseAcc([],xs)
37 | reverseAcc(acc,[]) -> acc
38 | reverseAcc(acc,[x|xs]) -> reverseAcc([x|acc],xs)
39 |
40 | convert([]) -> 0
41 | convert([d|ds]) -> d + 10 * convert(ds)
42 |
43 | parens(p) -> { ['1 v '1] -> v }([is("(") p() is(")")])
44 |
45 | chain(i,c,a) -> reduce(i(),many({[c() a()]}))
46 |
47 | reduce(v,[]) -> v
48 | reduce(v,[[c a]|xs]) -> [c v reduce(a,xs)]
49 |
50 | main() -> [ parse("", {'choice('abort,{1}) ?> 2})
51 | parse("1,23,75", {[number()|many({is(",");number()})]})
52 | ]
53 |
--------------------------------------------------------------------------------
/examples/pickle.gold:
--------------------------------------------------------------------------------
1 | ["[Fun [[]] [] [] [[[[Bind _0]] [[App [Var [primInfixPlus ''.''|#0]] 2 [Var _0]]]]]]"
2 | 4
3 | []
4 | 35]
5 |
--------------------------------------------------------------------------------
/examples/pickle.jsgold:
--------------------------------------------------------------------------------
1 | NoPrim
2 |
--------------------------------------------------------------------------------
/examples/pickle.marv:
--------------------------------------------------------------------------------
1 | [Cell [Env [[foo Fun [[]] [[x|'1'[Fun [[]] [] [] [[[[Bind _0]] [[App [Var [primInfixPlus ''.''|#0]] 2 [Var _0]]]]]]'1']] [] [[[[Bind _0]] [[App [Var [primInfixTimes ''.''|#0]] 5 [Var _0]]]]]]]] [Cell [Env [[moo|7]]] []]]
--------------------------------------------------------------------------------
/examples/pickle.shonkier:
--------------------------------------------------------------------------------
1 | readV(f) -> primUnpickle('read(f))
2 |
3 | writeV(f,v) -> 'write(f,primPickle(v))
4 |
5 | main() -> x := primPickle({2 + _});
6 | [ x
7 | primUnpickle(x)(2)
8 | writeV(["examples" "pickle.marv"],[foo := {5 * _}, moo := 7])
9 | readV(["examples" "pickle.marv"]); foo(moo)
10 | ]
11 |
--------------------------------------------------------------------------------
/examples/primitives.gold:
--------------------------------------------------------------------------------
1 | ["hello world!" 6 this"a test of "th"this 17 "17" 2.5 "2.5" 1 "1" 2/3 "2/3"]
2 |
--------------------------------------------------------------------------------
/examples/primitives.jsgold:
--------------------------------------------------------------------------------
1 | ["hello world!" 6 "a test of "th" 17 "17" 2.5 "2.5" 1 "1" 2/3 "2/3"]
2 |
--------------------------------------------------------------------------------
/examples/primitives.shonkier:
--------------------------------------------------------------------------------
1 | main() -> [ primStringConcat([ "hello" | space" "space], the"world"the, "!")
2 | primInfixPlus(2.4, 3.6)
3 | this"a test of "th"this
4 | tofrom(17) fromto("17")
5 | tofrom(2.5) fromto("2.5")
6 | tofrom(1.0) fromto("1.0")
7 | tofrom(2/3) fromto("2/3")
8 | ]
9 |
10 | tofrom(x) -> primStringToNum(primNumToString(x))
11 | fromto(y) -> primNumToString(primStringToNum(y))
12 |
--------------------------------------------------------------------------------
/examples/quick-exit.gold:
--------------------------------------------------------------------------------
1 | 0
2 |
--------------------------------------------------------------------------------
/examples/quick-exit.jsgold:
--------------------------------------------------------------------------------
1 | 0
2 |
--------------------------------------------------------------------------------
/examples/quick-exit.shonkier:
--------------------------------------------------------------------------------
1 | runExit('exit):
2 | runExit({'exit() -> _}) -> 0
3 | runExit(v) -> v
4 |
5 | product([0|ns]) -> 'exit()
6 | product([n|ns]) -> primInfixTimes(n,product(ns))
7 | product([]) -> 1
8 |
9 | longlist(0) -> []
10 | longlist(n) -> [n|longlist(primInfixMinus(n,1))]
11 |
12 | main() -> runExit(product([0|longlist(100000)]))
13 |
--------------------------------------------------------------------------------
/examples/reader.gold:
--------------------------------------------------------------------------------
1 | [1 2 1 2]
2 |
--------------------------------------------------------------------------------
/examples/reader.jsgold:
--------------------------------------------------------------------------------
1 | [1 2 1 2]
2 |
--------------------------------------------------------------------------------
/examples/reader.shonkier:
--------------------------------------------------------------------------------
1 | runReader(, 'ask):
2 | runReader(_, val) -> val
3 | runReader(r, {'ask() -> k}) -> runReader(r, k(r))
4 |
5 | append([] , ys) -> ys
6 | append([x|xs], ys) -> [x|append(xs, ys)]
7 |
8 | onetwo() -> [1 2]
9 |
10 | main() -> runReader(onetwo(), append('ask(), 'ask()))
11 |
--------------------------------------------------------------------------------
/examples/semi.gold:
--------------------------------------------------------------------------------
1 | [1 "hello" "world" "!"]
2 |
--------------------------------------------------------------------------------
/examples/semi.jsgold:
--------------------------------------------------------------------------------
1 | [1 "hello" "world" "!"]
2 |
--------------------------------------------------------------------------------
/examples/semi.shonkier:
--------------------------------------------------------------------------------
1 | catchLeft('left):
2 | catchLeft({ 'left() -> _ }, k) -> k()
3 | catchLeft(v, _) -> v
4 |
5 | main() -> [ catchLeft('left(); 'right(),{1})
6 | "world"; "hello"
7 | _ := 'nested; 1.0; "world"
8 | catchLeft(1; 'left(), {"!"})
9 | ]
10 |
--------------------------------------------------------------------------------
/examples/serial-env.gold:
--------------------------------------------------------------------------------
1 | [[x := 1, y := 3, z := 2]
2 | [1 2 3]
3 | [[x := 1] [y := 3] [z := 2]]
4 | x := 'hi; z := 'bye; {y -> [x y z]}]
5 |
--------------------------------------------------------------------------------
/examples/serial-env.jsgold:
--------------------------------------------------------------------------------
1 | [[['y|3] ['z|2] ['x|1]] [1 2 3] [[['x|1]] [['y|3]] [['z|2]]] ]
2 |
--------------------------------------------------------------------------------
/examples/serial-env.shonkier:
--------------------------------------------------------------------------------
1 | main() ->
2 | [ [x z y] := [1 2 3]
3 | [1 2 3]
4 | [x := 1, y := 3, z := 2]
5 | {x, z -> {y -> [x y z]}}('hi, 'bye)
6 | ]
7 |
--------------------------------------------------------------------------------
/examples/splices.gold:
--------------------------------------------------------------------------------
1 | [[["world" ["i"] "h"] "\o/"] {"he`[x|xs]`llo" -> xs}]
2 |
--------------------------------------------------------------------------------
/examples/splices.jsgold:
--------------------------------------------------------------------------------
1 | [[["world" ["i"] "h"] "\o/"] ]
2 |
--------------------------------------------------------------------------------
/examples/splices.shonkier:
--------------------------------------------------------------------------------
1 | import "list.shonkier"
2 |
3 | test("`"`[x|xs]`"`foo`ys`") -> [ys [x] xs]
4 | test(foo"hifoo`[x y |zs]`foogoo"foo) -> primStringConcat([y x |zs])
5 |
6 | main() -> [ map(test, ["ihfooworld" "hio\/goo"])
7 | { "he`[x|xs]`llo" -> xs }
8 | ]
9 |
--------------------------------------------------------------------------------
/examples/store.mary:
--------------------------------------------------------------------------------
1 | # An example of using the data store
2 |
3 | ```mary-data
4 | test4 <-> "`session`/`user`/`page`"
5 | scores1 <- "`repo`/scores" ['csv "," ['username 'test1score]]
6 | scores23 <- "`repo`/scores" ['csv "," ['username 'test2score 'test3score]]
7 | ```
8 |
9 | ## Today's test
10 |
11 | :::{mary-store=test4}
12 | Question 1: `q1`{.input type=text size=12}
13 |
14 | What number am I thinking of? `q2`{.input}
15 |
16 | TODO: radio boxes
17 |
18 | This is what I did during my summer holiday:
19 | ```{.input}
20 | essay
21 | ```
22 |
23 | `Submit answers and essay`{.input type=submit}
24 | :::
25 |
26 | ## Your scores, and the class averages, so far
27 |
28 | Assume we have a library function `first`, which takes two
29 | arguments: a list of environments, and a suspended Boolean. It
30 | returns the first environment in the list for which the suspended
31 | Boolean is true.
32 |
33 |
34 | :::{mary-apply="first(scores1, {username == user})"}
35 | :::{mary-apply="first(scores23, {username == user})"}
36 | :::{code-default=".mary-eval"}
37 | | | *Test 1* | *Test 2* | *Test 3* |
38 | | You | `test1score` | `test2score` | `test3score` |
39 | | Average | `average(map({env -> env(test1score)}, scores1))` | `average(map({env -> env(test2score)}, scores23))` | `average(map({env -> env(test3score)}, scores23))` |
40 | :::
41 | :::
42 | :::
43 |
--------------------------------------------------------------------------------
/examples/strings.gold:
--------------------------------------------------------------------------------
1 | ["I'm Julian and this is my friend Sandy."
2 | ["Vada" "lallies!"]
3 | "foofoo0 no match"
4 | ["f" "oo" ""]
5 | ["Pugh" " Pugh" " Barney McGrew" " Cuthbert" " Dibble" " and Grubb"]]
6 |
--------------------------------------------------------------------------------
/examples/strings.jsgold:
--------------------------------------------------------------------------------
1 | ["I'm Julian and this is my friend Sandy." ["Vada" "lallies!"] "foofoo0 no match" ["f" "oo" ""] ["Pugh" " Pugh" " Barney McGrew" " Cuthbert" " Dibble" " and Grubb"]]
2 |
--------------------------------------------------------------------------------
/examples/strings.shonkier:
--------------------------------------------------------------------------------
1 | splicer(xs,ys) -> "I'm `xs` and this is my friend `ys`."
2 | matcher("`xs` the `ys`") -> [xs ys]
3 | matcher(_) -> "matcher no match"
4 |
5 | foofoo0("`"`[x|xs]`"`foo`ys`") -> [x xs ys]
6 | foofoo0(_) -> "foofoo0 no match"
7 |
8 | foofoo1("`[x|xs]`foo`ys`") -> [x xs ys]
9 | foofoo1(_) -> "foofoo1 no match"
10 |
11 | csep("`xs`,`ys`") -> [xs | csep(ys)]
12 | csep(xs) -> [xs]
13 |
14 | main() ->
15 | [ splicer("Julian", "Sandy")
16 | matcher("Vada the lallies!")
17 | foofoo0("foofoo")
18 | foofoo1("foofoo")
19 | csep("Pugh, Pugh, Barney McGrew, Cuthbert, Dibble, and Grubb")
20 | ]
21 |
--------------------------------------------------------------------------------
/examples/subdir/import-down.gold:
--------------------------------------------------------------------------------
1 | [2 3 4]
2 |
--------------------------------------------------------------------------------
/examples/subdir/import-down.jsgold:
--------------------------------------------------------------------------------
1 | [2 3 4]
2 |
--------------------------------------------------------------------------------
/examples/subdir/import-down.shonkier:
--------------------------------------------------------------------------------
1 | import "examples/list.shonkier"
2 | import "list.shonkier" // it's okay to import the same file again
3 |
4 | main() -> map({x -> x + 1},[1 2 3])
5 |
6 | greeting() -> fold({x y -> "`x``y`"}, "", ["H" "e" "l" "l" "o"])
7 |
--------------------------------------------------------------------------------
/examples/tails.gold:
--------------------------------------------------------------------------------
1 | [[1 2 3] [2 3] [3] []]
2 |
--------------------------------------------------------------------------------
/examples/tails.jsgold:
--------------------------------------------------------------------------------
1 | [[1 2 3] [2 3] [3] []]
2 |
--------------------------------------------------------------------------------
/examples/tails.shonkier:
--------------------------------------------------------------------------------
1 | tails(xs@[_|tl]) -> [xs|tails(tl)]
2 | tails([]) -> [[]]
3 |
4 | main() -> tails([1 2 3])
5 |
--------------------------------------------------------------------------------
/examples/template.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | Title TBA
8 |
9 |
12 |
13 |
58 |
66 |
67 |
68 |
69 |
93 |
94 |
95 |
--------------------------------------------------------------------------------
/examples/template.mary:
--------------------------------------------------------------------------------
1 | ::: {mary-template="foo(x)"}
2 | This is a paragraph which uses `x`{.mary}.
3 | :::
4 |
5 | ```{.mary-eval}
6 | foo("a template")
7 | ```
8 |
9 | And the following is generated by *recursively* printing
10 | a list `["Hello" "World"]` as an itemised list.
11 |
12 | ::: {mary-template="printList([x|xs])"}
13 | * `x`{.mary}
14 | ```{.mary}
15 | printList(xs)
16 | ```
17 | :::
18 |
19 | ::: {mary-template="printList([])"}
20 | :::
21 |
22 | ```{.mary-eval}
23 | printList(["Hello" "World"])
24 | ```
25 |
--------------------------------------------------------------------------------
/examples/world.gold:
--------------------------------------------------------------------------------
1 | [["Hello" "Moon"] ""]
2 |
--------------------------------------------------------------------------------
/examples/world.jsgold:
--------------------------------------------------------------------------------
1 | [["Hello" "Moon"] ""]
2 |
--------------------------------------------------------------------------------
/examples/world.shonkier:
--------------------------------------------------------------------------------
1 | // we can handle effects before they get to the world
2 | catchPOST('POST):
3 | catchPOST({'POST(f) -> k}) -> catchPOST(k("Moon"))
4 | catchPOST(x) -> x
5 |
6 | // recovering from unknown inputs
7 | failGracefully('UnknownInput):
8 | failGracefully({'UnknownInput(n) -> _}) -> ""
9 | failGracefully(v) -> v
10 |
11 | main() -> [ catchPOST(["Hello" 'POST("World")])
12 | failGracefully('GET("fieldDoesNotExist"))
13 | ]
14 |
--------------------------------------------------------------------------------
/index.php:
--------------------------------------------------------------------------------
1 | array("pipe", "r"), // stdin is a pipe that the child will read from
19 | 1 => array("pipe", "w"), // stdout is a pipe that the child will write to
20 | 2 => array("file", "/tmp/error-output.txt", "a") // stderr is a file to write to
21 | );
22 |
23 | $cmd = "mary find $userarg $site_root $base_URL $page_id | pandoc --data-dir=data --standalone -f markdown --filter=marypandoc.sh -t html --template templates/mary.html5 2>&1";
24 |
25 | $cwd = NULL;
26 | $env = array('PATH' => '.');
27 |
28 | $process = proc_open($cmd, $descriptorspec, $pipes, $cwd, $env);
29 |
30 | if (is_resource($process)) {
31 | // $pipes now looks like this:
32 | // 0 => writeable handle connected to child stdin
33 | // 1 => readable handle connected to child stdout
34 | // Any error output will be appended to /tmp/error-output.txt
35 |
36 | fwrite($pipes[0], serialize($_POST));
37 | fwrite($pipes[0], serialize($_GET));
38 | fclose($pipes[0]);
39 |
40 | echo stream_get_contents($pipes[1]);
41 | fclose($pipes[1]);
42 |
43 | // It is important that you close any pipes before calling
44 | // proc_close in order to avoid a deadlock
45 | $return_value = proc_close($process);
46 | }
47 | }
48 | elseif (isset($_GET["pub"])) {
49 | $pub_id = filter_input(INPUT_GET, 'pub', FILTER_SANITIZE_SPECIAL_CHARS);
50 | $target = realpath($site_root . "/" . $pub_id);
51 | if (!$target) {
52 | // realpath returns false if the target does not exist.
53 | trigger_error("Specified file does not exist.", E_USER_ERROR);
54 | }
55 | elseif (strpos($target, "/pub/") === FALSE) {
56 | // The user asked for a file not in a pub directory; we cannot
57 | // allow this! We use the same error message here as above in
58 | // order to not leak information.
59 | trigger_error("Specified file does not exist.", E_USER_ERROR);
60 | }
61 | elseif (!(strpos($target, realpath($site_root)) === 0)) {
62 | // The user is trying to access a file outside the site root!
63 | trigger_error("Specified file does not exist.", E_USER_ERROR);
64 | }
65 | else {
66 | // We are good, ship the file!
67 | $mime_type = mime_content_type($target);
68 | header('Content-Type: '.$mime_type);
69 | readfile($target);
70 | }
71 | }
72 | else {
73 | trigger_error("No page or pub given", E_USER_ERROR);
74 | }
75 | ?>
76 |
--------------------------------------------------------------------------------
/mary.cabal:
--------------------------------------------------------------------------------
1 | -- Initial mary.cabal generated by cabal init. For further documentation,
2 | -- see http://haskell.org/cabal/users-guide/
3 |
4 | -- The name of the package.
5 | name: mary
6 |
7 | -- The package version. See the Haskell package versioning policy (PVP)
8 | -- for standards guiding when and how versions should be incremented.
9 | -- https://wiki.haskell.org/Package_versioning_policy
10 | -- PVP summary: +-+------- breaking API changes
11 | -- | | +----- non-breaking API additions
12 | -- | | | +--- code changes with no API change
13 | version: 0.1.0.0
14 |
15 | -- A short (one-line) description of the package.
16 | synopsis: Content delivery system for CIS
17 |
18 | -- A longer description of the package.
19 | -- description:
20 |
21 | tested-with: GHC == 8.10
22 | GHC == 9.0
23 | GHC == 9.2
24 | GHC == 9.4
25 | GHC == 9.6
26 | GHC == 9.8
27 |
28 | -- URL for the project homepage or repository.
29 | homepage: https://github.com/msp-strath/Mary
30 |
31 | -- The license under which the package is released.
32 | -- license:
33 |
34 | -- The file containing the license text.
35 | -- license-file: LICENSE
36 |
37 | -- The package author(s).
38 | author: Conor McBride, Guillaume Allais, and Fredrik Nordvall Forsberg
39 |
40 | -- An email address to which users can send suggestions, bug reports, and
41 | -- patches.
42 | maintainer: conor.mcbride@strath.ac.uk
43 |
44 | -- A copyright notice.
45 | -- copyright:
46 |
47 | -- category:
48 |
49 | build-type: Simple
50 |
51 | -- Extra files to be distributed with the package, such as examples or a
52 | -- README.
53 | extra-source-files: README.md
54 | -- , ChangeLog.md
55 |
56 | data-files: src/data-dir/Shonkier.js
57 |
58 | -- Constraint on the version of Cabal needed to build this package.
59 | cabal-version: >=1.10
60 |
61 | library
62 | hs-source-dirs: src
63 | build-depends: attoparsec >=0.13 && <0.15
64 | , base >=4.14 && <4.20
65 | , bytestring >=0.10 && < 0.12
66 | , containers >=0.6 && <0.7
67 | , directory >=1.3.3.0 && <1.4
68 | , dot >=0.2 && <0.4
69 | , filepath >=1.4 && <1.6
70 | , gitrev >=1.0 && <1.4
71 | , hs-php-session >=0.0 && <0.1
72 | , mtl >=2 && <3
73 | , newtype >=0.2 && <0.3
74 | , pandoc-types >=1.23 && <1.24
75 | , prettyprinter >=1.7 && <1.8
76 | , process >=1.6 && <1.7
77 | , uri-encode >=1.5 && <1.6
78 | , text >=1.2 && <2.2
79 | , yaml >=0.11 && < 0.12
80 | , aeson >= 2.0
81 |
82 | -- Modules included in this executable, other than Main.
83 | exposed-modules: Data.Bwd
84 | , Data.Lisp
85 | , Mary.Pandoc
86 | , Mary.Interpreter
87 | , Mary.ServePage
88 | , Mary.Find
89 | , Mary.Version
90 | , Shonkier
91 | , Shonkier.Dot
92 | , Shonkier.Examples
93 | , Shonkier.FreeVars
94 | , Shonkier.Import
95 | , Shonkier.Pandoc
96 | , Shonkier.Parser
97 | , Shonkier.Parser.Examples
98 | , Shonkier.Pretty
99 | , Shonkier.Pretty.Examples
100 | , Shonkier.Pretty.Render.Pandoc
101 | , Shonkier.Primitives
102 | , Shonkier.Scope
103 | , Shonkier.Semantics
104 | , Shonkier.ShonkierJS
105 | , Shonkier.Syntax
106 | , Shonkier.Value
107 | , Utils.List
108 |
109 | other-modules: Paths_mary
110 |
111 | -- LANGUAGE extensions used by modules in this package.
112 | -- other-extensions:
113 |
114 | -- Base language which the package is written in.
115 | default-language: Haskell2010
116 |
117 | -- LANGUAGE extensions used by modules in this package.
118 | default-extensions: DefaultSignatures
119 | , DeriveTraversable
120 | , FlexibleContexts
121 | , FlexibleInstances
122 | , FunctionalDependencies
123 | , GADTs
124 | , GeneralizedNewtypeDeriving
125 | , LambdaCase
126 | , MultiParamTypeClasses
127 | , MultiWayIf
128 | , OverloadedStrings
129 | , PatternSynonyms
130 | , RecordWildCards
131 | , ScopedTypeVariables
132 | , TupleSections
133 | , TypeOperators
134 | , TypeSynonymInstances
135 |
136 |
137 | ghc-options: -Wincomplete-patterns
138 | -Wmissing-signatures
139 | -Woverlapping-patterns
140 | -Wtabs
141 | -fwarn-unused-imports
142 |
143 | executable mary
144 | hs-source-dirs: .
145 | main-is: mary.hs
146 | other-modules: Paths_mary
147 | build-depends: attoparsec >=0.13 && <0.15
148 | , base >=4.14 && <4.20
149 | , mary
150 | , mtl >=2 && <3
151 | , optparse-applicative >= 0.13 && < 0.18
152 | , pandoc-types >=1.23 && <1.24
153 | , prettyprinter >=1.7 && <1.8
154 | , text >=1.2 && <2.2
155 |
156 | -- LANGUAGE extensions used by modules in this package.
157 | -- other-extensions:
158 |
159 | -- Base language which the package is written in.
160 | default-language: Haskell2010
161 |
162 | -- LANGUAGE extensions used by modules in this package.
163 | default-extensions: LambdaCase
164 | , OverloadedStrings
165 | , RecordWildCards
166 |
167 | ghc-options: -Wincomplete-patterns
168 | -Wmissing-signatures
169 | -Woverlapping-patterns
170 | -Wtabs
171 | -fwarn-unused-imports
172 |
173 | test-suite mary-tests
174 | type: exitcode-stdio-1.0
175 | hs-source-dirs: test/
176 | main-is: Test/Main.hs
177 | other-modules: Test.Mary
178 | , Test.Shonkier
179 | , Test.Utils
180 |
181 | build-depends: base >=4.14 && <4.20
182 | , directory >=1.3 && <1.4
183 | , filepath >=1.4 && <1.5
184 | , mary
185 | , process >=1.6 && <1.7
186 | , tasty >=1.0 && <2.0
187 | , tasty-silver >=3.0 && <4
188 | , text >=1.2 && <2.2
189 |
190 | default-extensions: RecordWildCards
191 |
192 | -- Base language which the package is written in.
193 | default-language: Haskell2010
194 |
--------------------------------------------------------------------------------
/mary.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Control.Exception as E
4 |
5 | import Data.Maybe
6 | import Data.Semigroup ((<>))
7 | import Data.Text
8 | import qualified Data.Text.IO as TIO
9 |
10 | import Text.Pandoc.JSON (toJSONFilter)
11 |
12 | import System.IO as SIO
13 | import System.Environment
14 |
15 | import Options.Applicative
16 |
17 | import Shonkier
18 |
19 | import Mary.Interpreter
20 | import Mary.ServePage
21 | import Mary.Find
22 | import Mary.Version
23 |
24 | import Paths_mary (getDataFileName)
25 |
26 | defaultUser :: IO String
27 | defaultUser = do
28 | u <- lookupEnv "LOGNAME"
29 | pure $ fromMaybe "Shelley" u
30 |
31 | main :: IO ()
32 | main = customExecParser pp opts >>= \ o -> E.handle h $ case o of
33 | Pandoc -> toJSONFilter process
34 | Version -> putStrLn version
35 | Shonkier filename -> interpretShonkier filename
36 | Shonkierjs filename -> do
37 | shonkierjs <- getDataFileName "src/data-dir/Shonkier.js"
38 | compileShonkier shonkierjs filename >>= TIO.putStrLn
39 | Page filename postString getString siteRoot baseURL user -> do
40 | let postArray = parseRequests (pack postString)
41 | let getArray' = parseRequests (pack getString)
42 | -- make sure there is a page
43 | let getArray = case lookup "page" getArray' of
44 | Just _ -> getArray'
45 | Nothing -> ("page", pack filename):getArray'
46 | let mary = "mary"
47 | let pandoc = "pandoc"
48 | servePage Config{..} postArray getArray filename >>= TIO.putStrLn
49 | Find{..} -> maryFind sitesRoot baseURL user page
50 | where
51 | pp = prefs showHelpOnEmpty
52 | opts = info (optsParser <**> helper)
53 | ( fullDesc <> header "Mary - a content delivery and assessment engine")
54 | h :: SomeException -> IO ()
55 | h e = SIO.hPutStrLn stderr $ "mary ERROR " ++ displayException e
56 |
57 | data Options
58 | = Pandoc
59 | | Version
60 | | Shonkier { filename :: String }
61 | | Shonkierjs { filename :: String }
62 | | Page { filename :: String
63 | , baseURL :: String
64 | , postArray :: String
65 | , getArray :: String
66 | , siteRoot :: String
67 | , user :: Maybe String
68 | }
69 | | Find { user :: Maybe String
70 | , sitesRoot :: String
71 | , baseURL :: String
72 | , page :: String
73 | }
74 |
75 | optsParser :: Parser Options
76 | optsParser = subparser
77 | ( command' "pandoc"
78 | (pure Pandoc)
79 | "Act as a Pandoc filter"
80 | <> command' "version"
81 | (pure Version)
82 | "Print version and exit"
83 | <> command' "shonkier"
84 | (Shonkier <$> strArgument
85 | (metavar "FILE" <> action "file" <> help "Input Shonkier program."))
86 | "Interpret shonkier program"
87 | <> command' "shonkierjs"
88 | (Shonkierjs <$> strArgument
89 | (metavar "FILE" <> action "file" <> help "Source Shonkier program."))
90 | "Compile shonkier program to javascript"
91 | <> command' "page"
92 | (Page <$> strArgument (metavar "FILE" <> action "file" <> help "Input Mary file")
93 | <*> strArgument (metavar "URL" <> help "Base URL")
94 | <*> option str (long "post" <> value ""
95 | <> metavar "STRING" <> help "POST input string (&-separated)")
96 | <*> option str (long "get" <> value ""
97 | <> metavar "STRING" <> help "GET input string (&-separated)")
98 | <*> option str (long "siteRoot" <> value "."
99 | <> metavar "STRING" <> action "directory" <> help "Site root.")
100 | <*> optional (strOption (long "user"
101 | <> metavar "STRING" <> action "user" <> help "Username")))
102 | "Generate HTML from Mary file"
103 | <> command' "find"
104 | (Find <$> optional (strOption (long "user"
105 | <> metavar "STRING" <> action "user" <> help "Username."))
106 | <*> strArgument (metavar "ROOT" <> action "directory" <> help "Path to site root.")
107 | <*> strArgument (metavar "URL" <> help "Base URL.")
108 | <*> strArgument (metavar "PAGE" <> action "file" <> help "Page to serve."))
109 | "Find webpage and output markdown")
110 | where
111 | command' :: String -> Parser a -> String -> Mod CommandFields a
112 | command' label parser description =
113 | command label (info parser (progDesc description))
114 |
--------------------------------------------------------------------------------
/marypandoc.sh:
--------------------------------------------------------------------------------
1 | #! /bin/sh
2 | ./mary pandoc
3 |
--------------------------------------------------------------------------------
/src/Data/Bwd.hs:
--------------------------------------------------------------------------------
1 | module Data.Bwd where
2 |
3 | data Bwd a
4 | = B0
5 | | Bwd a :< a
6 | deriving (Show, Functor, Foldable, Traversable)
7 |
8 | (<>>) :: Bwd a -> [a] -> [a]
9 | B0 <>> as = as
10 | (az :< a) <>> as = az <>> (a : as)
11 |
12 | (<><) :: Bwd a -> [a] -> Bwd a
13 | az <>< [] = az
14 | az <>< (a : as) = (az :< a) <>< as
15 |
16 | instance Monoid (Bwd a) where
17 | mempty = B0
18 | mappend = (<>)
19 |
20 | instance Semigroup (Bwd a) where
21 | xz <> B0 = xz
22 | xz <> (yz :< y) = (xz <> yz) :< y
23 |
--------------------------------------------------------------------------------
/src/Data/Lisp.hs:
--------------------------------------------------------------------------------
1 | module Data.Lisp (LISP(..), LISPY(..), (-:), spil, lispText, textLisp, lispJS) where
2 |
3 | import Data.Text (Text)
4 | import qualified Data.Text as T
5 | import Data.Char
6 | import Data.Ratio
7 |
8 | import Data.Bwd
9 |
10 | data LISP
11 | = ATOM String
12 | | CONS LISP LISP
13 | | NIL
14 | | RAT Rational
15 | | STR Text
16 | | BOO Bool
17 |
18 | class LISPY t where
19 | toLISP :: t -> LISP
20 | fromLISP :: LISP -> Maybe t
21 |
22 | (-:) :: String -> [LISP] -> LISP
23 | c -: ts = CONS (ATOM c) (foldr CONS NIL ts)
24 |
25 | spil :: LISP -> Maybe (String, [LISP])
26 | spil (CONS (ATOM c) d) = (c,) <$> go d where
27 | go NIL = pure []
28 | go (CONS a d) = (a :) <$> go d
29 | go _ = Nothing
30 | spil _ = Nothing
31 |
32 | instance LISPY LISP where
33 | toLISP = id
34 | fromLISP = Just
35 |
36 | instance LISPY Text where
37 | toLISP = STR
38 | fromLISP (STR t) = Just t
39 | fromLISP _ = Nothing
40 |
41 | instance LISPY Rational where
42 | toLISP = RAT
43 | fromLISP (RAT r) = Just r
44 | fromLISP _ = Nothing
45 |
46 | instance LISPY Bool where
47 | toLISP = BOO
48 | fromLISP (BOO b) = Just b
49 | fromLISP _ = Nothing
50 |
51 | instance (LISPY s, LISPY t) => LISPY (Either s t) where
52 | toLISP (Left s) = "Left" -: [toLISP s]
53 | toLISP (Right t) = "Right" -: [toLISP t]
54 | fromLISP t = spil t >>= \case
55 | ("Left", [s]) -> Left <$> fromLISP s
56 | ("Right", [t]) -> Right <$> fromLISP t
57 | _ -> Nothing
58 |
59 | instance (LISPY s, LISPY t) => LISPY (s, t) where
60 | toLISP (s, t) = CONS (toLISP s) (toLISP t)
61 | fromLISP (CONS s t) = (,) <$> fromLISP s <*> fromLISP t
62 | fromLISP _ = Nothing
63 |
64 | instance (LISPY s, LISPY t, LISPY u) => LISPY (s, t, u) where
65 | toLISP (s, t, u) = CONS (toLISP s) (CONS (toLISP t) (toLISP u))
66 | fromLISP (CONS s (CONS t u)) = (,,) <$> fromLISP s <*> fromLISP t <*> fromLISP u
67 | fromLISP _ = Nothing
68 |
69 |
70 | instance LISPY x => LISPY [x] where
71 | toLISP = foldr (CONS . toLISP) NIL
72 | fromLISP NIL = pure []
73 | fromLISP (CONS x xs) = (:) <$> fromLISP x <*> fromLISP xs
74 | fromLISP _ = Nothing
75 |
76 | instance LISPY x => LISPY (Maybe x) where
77 | toLISP = maybe NIL ((`CONS` NIL) . toLISP)
78 | fromLISP NIL = pure Nothing
79 | fromLISP (CONS x NIL) = Just <$> fromLISP x
80 | fromLISP _ = Nothing
81 |
82 | instance LISPY x => LISPY (Bwd x) where
83 | -- keeping the near end near means reversing or ugliness
84 | -- choosing reversing for the now
85 | toLISP B0 = NIL
86 | toLISP (xz :< x) = CONS (toLISP x) (toLISP xz)
87 | fromLISP NIL = pure B0
88 | fromLISP (CONS x xz) = (:<) <$> fromLISP xz <*> fromLISP x
89 | fromLISP _ = Nothing
90 |
91 | num :: Integer -> Text
92 | num = T.pack . show
93 |
94 | blat :: LISP -> [Text] -> [Text]
95 | blat (ATOM x) = (T.pack x :)
96 | blat (CONS a d) = ("[" :) . blat a . bcdr d . ("]" :) where
97 | bcdr NIL = id
98 | bcdr (CONS a d) = (" " :) . blat a . bcdr d
99 | bcdr x = ("|" :) . blat x
100 | blat NIL = ("[]" :)
101 | blat (RAT r) = (num (numerator r) :) .
102 | case denominator r of
103 | 1 -> id
104 | d -> ("/" :) . (num d :)
105 | blat (STR s) = quo . (s :) . quo
106 | where
107 | quo = ("'" :) . (foo :). ("'" :)
108 | foo = case [n | n <- T.splitOn "'" s, T.all isDigit n] of
109 | [] -> ""
110 | ns -> num (maximum (negate 1 : map (read . ('0' :) . T.unpack) ns) + 1)
111 | blat (BOO False) = ("#0" :)
112 | blat (BOO True) = ("#1" :)
113 |
114 | lispText :: LISP -> Text
115 | lispText x = T.concat (blat x [])
116 |
117 | jsBlat :: LISP -> [Text] -> [Text]
118 | jsBlat NIL = ("[]" :)
119 | jsBlat (CONS a d) = ("[" :) . jsBlat a . ("," :) . jsBlat d . ("]" :)
120 | jsBlat (ATOM x) = ("'" :) . (T.pack x :) . ("'" :)
121 | jsBlat (RAT r) = ("{num:" :) . (T.pack (show (numerator r)) :)
122 | . (", den:" :) . (T.pack (show (denominator r)) :)
123 | . ("}" :)
124 | jsBlat (STR s) = ("{str:" :) . (T.pack (show s) :)
125 | . ("}" :)
126 | jsBlat (BOO False) = ("false" :)
127 | jsBlat (BOO True) = ("true" :)
128 |
129 | lispJS :: LISP -> Text
130 | lispJS x = T.concat (jsBlat x [])
131 |
132 | instance Show LISP where show = T.unpack . lispText
133 |
134 | textLisp :: Text -> Maybe LISP
135 | textLisp t = case lispMunch t of
136 | Right (v, r) | T.all isSpace r -> Just v
137 | _ -> Nothing
138 |
139 | lispMunch :: Text -> Either Text (LISP, Text)
140 | lispMunch t = case T.uncons t of
141 | Just (c, u)
142 | | isSpace c -> lispMunch u
143 | | isAlpha c || c == '_' -> let (x, v) = T.span isAlphaNum u in
144 | Right (ATOM (c : T.unpack x), v)
145 | | isDigit c -> let (n, v) = numFrom c u in
146 | case T.uncons v of
147 | Just ('/', w) -> case T.uncons w of
148 | Just (c, w) | isDigit c -> let (d, x) = numFrom c w in
149 | Right (RAT (n % d), x)
150 | _ -> Right (RAT (n % 1), v)
151 | -- 1/foo is 1 followed by garbage
152 | _ -> Right (RAT (n % 1), v)
153 | | c == '-' -> case lispMunch u of
154 | Right (RAT r, u) -> Right (RAT (negate r), u)
155 | _ -> Left t
156 | | c == '#' -> case T.uncons u of
157 | Just ('0', v) -> Right (BOO False, v)
158 | Just ('1', v) -> Right (BOO True, v)
159 | _ -> Left t
160 | | c == '[' -> listMunch u
161 | | c == '\'' -> case T.span (/= '\'') u of
162 | (n, u) | T.all isDigit n -> case T.uncons u of
163 | Just (_, u) -> -- the span ensures that _ is '\''
164 | let quo = T.concat ["'", n, "'"]
165 | (s, v) = T.breakOn quo u
166 | in case T.stripPrefix quo v of
167 | Just v -> Right (STR s, v)
168 | _ -> Left t
169 | _ -> Left t
170 | _ -> Left t
171 | _ -> Left t
172 | where
173 | numFrom :: Char {-digit-} -> Text -> (Integer, Text)
174 | numFrom d x = (read (d : T.unpack ds), y)
175 | where
176 | (ds, y) = T.span isDigit x
177 | listMunch u = case T.uncons u of
178 | Just (c, v)
179 | | isSpace c -> listMunch v
180 | | c == ']' -> Right (NIL, v)
181 | | c == '|' -> do
182 | (d, v) <- lispMunch v
183 | let (_, w) = T.span isSpace v
184 | case T.uncons w of
185 | Just (']', w) -> Right (d, w)
186 | _ -> Left t
187 | | otherwise -> do
188 | (a, u) <- lispMunch u
189 | (d, u) <- listMunch u
190 | return (CONS a d, u)
191 | _ -> Left u
192 |
--------------------------------------------------------------------------------
/src/Mary/Find.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
2 |
3 | module Mary.Find
4 | ( maryFind
5 | ) where
6 |
7 | import Data.PHPSession
8 | import Data.ByteString.Lazy as B (getContents, toStrict)
9 | import Data.List as L
10 | import Data.Yaml as Y
11 | import Data.Text as T
12 | import Data.Text.IO as TIO
13 | import Data.Text.Encoding
14 |
15 | import Data.Aeson.Key
16 | import Data.Aeson.KeyMap as KM
17 |
18 | import Network.URI.Encode as URI
19 |
20 | import System.FilePath
21 | import System.Directory
22 | import System.Process
23 |
24 | postText :: Text -> PHPSessionValue -> Y.Value
25 | postText prefix (PHPSessionValueArray kvs) = object
26 | [ (key .= value)
27 | | (PHPSessionValueString k, PHPSessionValueString v) <- kvs
28 | , let key = fromText $ prefix <> "_" <> decodeUtf8 (B.toStrict k)
29 | , let value = "`" <> (URI.encodeText $ decodeUtf8 $ B.toStrict v) <> "`{=html}"
30 | ]
31 | postText _ _ = Y.Null
32 |
33 | outputMeta :: Value -> IO ()
34 | outputMeta d@(Y.Object o) | not (KM.null o) = TIO.putStr (decodeUtf8 (Y.encode d))
35 | outputMeta _ = return ()
36 |
37 | maryFind :: FilePath -- what is the site root?
38 | -> String -- what is the base URL?
39 | -> Maybe String -- username
40 | -> FilePath -- page
41 | -> IO () -- PHP $POST $GET -[mary find user site page>- --- YAML ... markdown
42 | maryFind sitesRoot baseURL user page = do
43 | pbs <- B.getContents
44 | -- the inputs are serialised PHP objects representing post and get data, respectively
45 | let mpost = L.unfoldr decodePartialPHPSessionValue pbs
46 | let (postData, getData) = case mpost of
47 | (p : g : _) -> (postText "POST" p, postText "GET" g)
48 | _ -> (Y.Null, Y.Null)
49 | -- now we have made them YAML objects
50 | case splitDirectories page of
51 | (site : _) -> do
52 | dirEx <- doesDirectoryExist (sitesRoot site)
53 | if not dirEx || not (isValid page)
54 | then error $ L.concat ["Mary cannot find site ", site, "!"]
55 | else do
56 | -- have we been asked to update the site? if so, git pull!
57 | case parseMaybe (withObject "get data" $ \ x -> x .:? "GET_pull") getData of
58 | Just (Just (_ :: Text)) -> callProcess (sitesRoot "gitpullsite") [site]
59 | _ -> return ()
60 | -- now let us serve up (for pandoc) the YAML data, then the markdown page
61 | let sitePage = sitesRoot page
62 | fileEx <- doesFileExist sitePage
63 | if not fileEx then do
64 | error $ L.concat ["Mary cannot find page ", page, "!"]
65 | else do
66 | -- serve the metadata
67 | TIO.putStrLn "---"
68 | case user of
69 | Nothing -> pure ()
70 | Just u -> TIO.putStr (decodeUtf8 (Y.encode (object ["user" .= T.pack u])))
71 | TIO.putStr (decodeUtf8 (Y.encode (object ["baseURL" .= T.pack baseURL])))
72 | TIO.putStr (decodeUtf8 (Y.encode (object ["sitesRoot" .= T.pack sitesRoot])))
73 |
74 | outputMeta postData
75 | outputMeta getData
76 | TIO.putStrLn "..."
77 | TIO.putStrLn ""
78 | -- serve the markdown page
79 | TIO.readFile sitePage >>= TIO.putStr
80 | _ -> error "Mary does not know which page you want!"
81 |
--------------------------------------------------------------------------------
/src/Mary/Pandoc.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Mary.Pandoc where
3 |
4 | import Control.Monad.Trans (MonadIO)
5 | import Control.Monad.Writer (Writer, runWriter, tell)
6 | import Control.Monad.Reader (MonadReader, runReaderT, asks)
7 | import Control.Newtype
8 |
9 | import Data.Attoparsec.Text
10 | import Data.Foldable
11 | import Data.List as L
12 | import Data.Map (Map)
13 | import qualified Data.Map as M
14 | import Data.Maybe
15 | import Data.Monoid (First(..))
16 | import Data.Text as T
17 |
18 | import Network.URI.Encode as URI
19 |
20 | import Text.Pandoc.Builder
21 | import Text.Pandoc.Walk
22 |
23 | import System.Directory
24 | import System.FilePath
25 |
26 | import Shonkier.Import
27 | import Shonkier.Parser as SP
28 | import Shonkier.Pretty
29 | import Shonkier.Pretty.Render.Pandoc
30 | import Shonkier.Semantics
31 | import Shonkier.ShonkierJS
32 | import Shonkier.Syntax
33 | import Shonkier.Value
34 | import Shonkier.Pandoc()
35 |
36 | -- TODO: is this the best way to do it?
37 | nullBlock :: Block
38 | nullBlock = Plain []
39 |
40 | process :: Pandoc -> IO Pandoc
41 | process doc0@(Pandoc meta docs) = do
42 | let (doc1, defns) = runWriter (walkM snarfMaryDef doc0)
43 | let rm@(is, ps) = fold [ (is, p)
44 | | ds <- defns
45 | , let (is, p) = maryDefinitionToModule ds
46 | ]
47 |
48 | let inputs = metaToInputValues meta
49 | -- we assume that certain metadata exists, put there by mary find
50 | let page = errorOnFail (getGET inputs) "page"
51 | let sitesRoot = errorOnFail (`M.lookup` inputs) "sitesRoot"
52 | let baseURL = errorOnFail (`M.lookup` inputs) "baseURL"
53 | let user = M.lookup "user" inputs
54 |
55 | fp <- makeAbsolute (T.unpack sitesRoot T.unpack page)
56 | (_, env, lcp) <- loadToplevelModule fp rm
57 | let envdata = EnvData is (stripPrefixButDot lcp fp) lcp (env, inputs) baseURL page user
58 | doc2 <- runReaderT (walkM evalMaryBlock doc1) envdata
59 | doc3 <- runReaderT (walkM evalMaryInline doc2) envdata
60 | pure $ setTitle (fromMaybe "Title TBA" (ala' First query h1 doc0))
61 | . setMeta "jsGlobalEnv" (fromList $ Str <$> jsGlobalEnv env)
62 | . setMeta "jsInputs" (fromList $ Str <$> jsInputs inputs)
63 | $ doc3
64 |
65 | where
66 | h1 :: Block -> Maybe Inlines
67 | h1 (Header 1 _ is) = Just (fromList is)
68 | h1 _ = Nothing
69 | errorOnFail f x = fromMaybe (error "Meta data '" <> x <> "' missing!") (f x)
70 |
71 | metaToInputValues :: Meta -> Map Text Text
72 | metaToInputValues (Meta m) = M.map extract m where
73 | extract (MetaInlines xs) = T.concat $ L.map inlineToString xs
74 | extract x = error $
75 | "IMPOSSIBLE non-string meta value " ++ show x
76 |
77 | inlineToString (RawInline (Format "html") s) = URI.decodeText s
78 | inlineToString (Str s) = s
79 | inlineToString x = error $
80 | "IMPOSSIBLE non-string inline " ++ show x
81 |
82 | {-
83 | extract (MetaBlocks xs) = T.concat $ L.map blockToString xs
84 | extract (MetaString s) = s
85 |
86 | inlineToString Space = " "
87 | inlineToString SoftBreak = "\n"
88 | inlineToString LineBreak = "\n"
89 |
90 | blockToString (Plain xs) = T.concat $ L.map inlineToString xs
91 | blockToString (Para xs) = T.concat $ L.map inlineToString xs
92 | blockToString (LineBlock xss) = T.concat $ L.concatMap (L.map inlineToString) xss
93 | blockToString x = error $ "IMPOSSIBLE non-string block " ++ show x
94 | -}
95 |
96 | getGET :: Map Text Text -> Text -> Maybe Text
97 | getGET inputs x = M.lookup ("GET_" <> x) inputs
98 |
99 | getPOST :: Map Text Text -> Text -> Maybe Text
100 | getPOST inputs x = M.lookup ("POST_" <> x) inputs
101 |
102 | data MaryDefinition
103 | = Module RawModule
104 | | DivTemplate Text Attr [Block]
105 |
106 | maryDefinitionToModule :: MaryDefinition -> RawModule
107 | maryDefinitionToModule = \case
108 | Module mod -> mod
109 | DivTemplate decl attr div ->
110 | let funDecl = (,) <$> identifier <*> argTuple pcomputation
111 | Right (nm, ps) = parseOnly funDecl decl
112 | in ([], [(nm, Right (ps :-> [Nothing :?> toRawTerm (Div attr div)]))])
113 |
114 | snarfMaryDef :: Block -> Writer [MaryDefinition] Block
115 | snarfMaryDef c@(CodeBlock (_, cs, _) p)
116 | | "mary-def" `L.elem` cs
117 | = do let mod = getMeAModule p
118 | let out = if "keep" `notElem` cs then nullBlock else render (pretty mod)
119 | out <$ tell [Module mod]
120 | snarfMaryDef c@(Div (a , b, kvs) p)
121 | | Just decl <- lookup "mary" kvs
122 | = let attr = (a, b, L.filter (("mary" /=) . fst) kvs) in
123 | nullBlock <$ tell [DivTemplate decl attr p]
124 | snarfMaryDef b = return b
125 |
126 | data EnvData = EnvData { imps :: [Import]
127 | , filename :: FilePath
128 | , prefix :: String
129 | , environment :: Env
130 | , baseURL :: Text
131 | , page :: Text
132 | , user :: Maybe Text
133 | }
134 |
135 | readImports :: MonadReader EnvData m => m [Import]
136 | readImports = asks imps
137 |
138 | readEnv :: MonadReader EnvData m => m Env
139 | readEnv = asks environment
140 |
141 | readBaseURL :: MonadReader EnvData m => m Text
142 | readBaseURL = asks baseURL
143 |
144 | readPage :: MonadReader EnvData m => m Text
145 | readPage = asks page
146 |
147 | readFilename :: MonadReader EnvData m => m FilePath
148 | readFilename = asks filename
149 |
150 | readPrefixToStrip :: MonadReader EnvData m => m FilePath
151 | readPrefixToStrip = asks prefix
152 |
153 |
154 | evalMary :: (MonadReader EnvData m, MonadIO m, FromValue b) => Text -> m b
155 | evalMary e =
156 | case parseOnly (topTerm <* endOfInput) e of
157 | Left err -> error err
158 | Right t -> do
159 | is <- readImports
160 | fp <- readFilename
161 | env@(gl,_) <- readEnv
162 | -- we need to strip off the common var prefix from our term
163 | lcp <- readPrefixToStrip
164 | let t' = fmap (stripVarPrefix lcp) t
165 | go env (rawShonkier is fp gl t')
166 | where
167 | go :: (Monad m, MonadIO m, FromValue b) => Env -> Computation -> m b
168 | go _ (Value v) = case fromValue v of
169 | Right p -> pure p
170 | Left foc -> error $ L.unlines
171 | [ "Invalid value: " ++ show foc
172 | , "in result:"
173 | , toString v
174 | ]
175 | go gamma (Request r@(a, vs) k)
176 | | a `L.elem` ["POST", "GET", "meta"] = handleInputs (go gamma) gamma r k
177 | | a `L.elem` ["dot"] = handleDot (go gamma) gamma r k
178 | go _ r@Request{} = error (show r)
179 |
180 | stripVarPrefix :: String -> RawVariable -> RawVariable
181 | stripVarPrefix lcp (p :.: x) = (stripPrefixButDot lcp <$> p) :.: x
182 |
183 | evalMaryBlock :: (MonadIO m, MonadReader EnvData m) => Block -> m Block
184 | evalMaryBlock (CodeBlock (_, cs, _) e) | "mary" `L.elem` cs = evalMary e
185 | evalMaryBlock (CodeBlock a@(_, cs, as) t) | "input" `L.elem` cs
186 | -- we consider codeblocks (compared to inline code) to be
187 | -- textareas, unless they explicitly have a type set
188 | = let textarea = "type" `notElem` L.map fst as in
189 | RawBlock (Format "html") <$> makeInputForm textarea a t
190 | evalMaryBlock b = pure b
191 |
192 | evalMaryInline :: (MonadIO m, MonadReader EnvData m) => Inline -> m Inline
193 | evalMaryInline (Code (_, cs, _) e) | "mary" `L.elem` cs = evalMary e
194 | evalMaryInline (Code a@(_, cs, _) t) | "input" `L.elem` cs =
195 | RawInline (Format "html") <$> makeInputForm False a t
196 | evalMaryInline (Link attrs is target) = Link attrs is <$> makeAbsRef target
197 | evalMaryInline (Image attrs is target) = Image attrs is <$> makeAbsRef target
198 | evalMaryInline b = pure b
199 |
200 |
201 | makeInputForm :: MonadReader EnvData m => Bool -> Attr -> Text -> m Text
202 | makeInputForm _ (_, _, as) p | ("type", "submit") `L.elem` as
203 | = pure $ (T.intercalate " " $
204 | [" ">"
206 | makeInputForm textarea a@(i, cs, as) p = do
207 | (_,inputs) <- readEnv
208 | let nameparser = SP.skipSpace *> identifier <* SP.skipSpace
209 | pure $ case parseOnly nameparser p of
210 | Left _ -> ""
211 | Right n -> let name = T.pack n
212 | mval = getPOST inputs name in (T.intercalate " " $
213 | [ if textarea then "
216 | T.concat (if textarea then [">", fromMaybe "" mval , ""]
217 | else [ T.concat [" value=\"", fromJust mval, "\""] | isJust mval] ++ [">"])
218 |
219 | makeAbsRef :: MonadReader EnvData m => Target -> m Target
220 | makeAbsRef (url, title) = do
221 | absUrl <- if isAbsolute url then pure url -- keep it as is
222 | else do
223 | baseURL <- readBaseURL
224 | page <- readPage
225 | let thing = if isPub url then "?pub" else "?page"
226 | -- if current page is eg repo/lectures/bonus/two.md and requested
227 | -- URL is eg ../../basic/notes.pdf, new URL is repo/basic/notes.pdf
228 | let newUrl = joinPathT $ normalise (L.init (splitOn "/" page))
229 | (L.filter (/= ".") (splitOn "/" url))
230 | pure $ T.concat [baseURL, thing, "=", newUrl]
231 | pure (absUrl, title)
232 | where
233 | isAbsolute t = or (fmap (`T.isPrefixOf` t)
234 | ["https://", "http://", "ftp://", "//", "mailto:", "tel:"]) -- TODO: make more generic?
235 | isPub t = ("pub/" `T.isPrefixOf` t || "/pub/" `T.isInfixOf` t)
236 | && (not $ "pub/" `T.isSuffixOf` t)
237 |
238 | normalise :: [Text] -> [Text] -> [Text]
239 | normalise (site:_) ("~":us) = normalise [site] us -- '~' => "from site root"
240 | normalise (site:ps) us = site:go (L.reverse ps) us -- keep site root always
241 | where
242 | go sp [] = L.reverse sp
243 | go (_:sp) ("..":us) = go sp us
244 | go [] ("..":us) = go [] us -- allowing overshooting
245 | go sp (p:us) = go (p:sp) us
246 | normalise [] _ = error "IMPOSSIBLE: empty page"
247 |
248 | joinPathT = T.pack . joinPath . fmap T.unpack
249 |
--------------------------------------------------------------------------------
/src/Mary/ServePage.hs:
--------------------------------------------------------------------------------
1 | -- | Hello!
2 |
3 | module Mary.ServePage where
4 |
5 | import Control.Arrow
6 |
7 | import Data.List as L
8 |
9 | import qualified Data.ByteString.Lazy as B
10 | import Data.Text
11 | import Data.Text.Encoding (encodeUtf8)
12 | import Data.Text.IO as TIO
13 |
14 | import Data.PHPSession
15 |
16 | import Network.URI.Encode as URI
17 |
18 | import System.Process
19 | import System.IO
20 |
21 | data Config = Config
22 | { mary :: FilePath
23 | , pandoc :: FilePath
24 | , user :: Maybe String
25 | , siteRoot :: String
26 | , baseURL :: String
27 | }
28 |
29 | servePage :: Config
30 | -> [(Text, Text)] -- POST data (URL-encoded)
31 | -> [(Text, Text)] -- GET data (URL-encoded)
32 | -> FilePath -- input file
33 | -> IO Text
34 | servePage Config{..} post get file = do
35 | let userarg = maybe [] (\ u -> ["--user", u]) user
36 | withCreateProcess ((proc mary $ ["find"] ++ userarg ++ [siteRoot, baseURL, file])
37 | { std_in = CreatePipe
38 | , std_out = CreatePipe
39 | }) $ \ (Just hin) (Just hmaryfind) _ _ -> do
40 | B.hPut hin $ phpify post
41 | B.hPut hin $ phpify get
42 | hClose hin
43 | withCreateProcess ((proc pandoc ["--data-dir=data"
44 | , "--standalone"
45 | , "-f" , "markdown"
46 | , "--filter", "marypandoc.sh"
47 | , "-t", "html"
48 | , "--template", "templates/mary.html5"
49 | ])
50 | { std_in = UseHandle hmaryfind
51 | , std_out = CreatePipe
52 | }) $ \ _ (Just hpandoc) _ _ ->
53 | TIO.hGetContents hpandoc
54 | where
55 | encString = PHPSessionValueString . B.fromStrict . encodeUtf8 . URI.decodeText
56 | phpify a = encodePHPSessionValue $ PHPSessionValueArray $
57 | fmap (encString *** encString) a
58 |
59 | parseRequests :: Text -> [(Text, Text)]
60 | parseRequests x = L.concatMap pairs $ splitOn "&" x
61 | where pairs s = case splitOn "=" s of
62 | [a,b] -> [(a, b)]
63 | [a] -> [(a, "")]
64 | _ -> []
65 |
--------------------------------------------------------------------------------
/src/Mary/Version.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TemplateHaskell #-}
2 |
3 | module Mary.Version where
4 |
5 | import Control.Monad (guard)
6 |
7 | import Data.Version (showVersion)
8 | import Development.GitRev
9 | import qualified Paths_mary as Mary
10 |
11 | version :: String
12 | version = showVersion Mary.version ++ maybe "" ('-':) commit
13 |
14 | commit :: Maybe String
15 | commit = do
16 | let hash = $(gitHash)
17 | guard (hash /= "UNKNOWN")
18 | pure $ take 7 hash
19 |
--------------------------------------------------------------------------------
/src/Shonkier.hs:
--------------------------------------------------------------------------------
1 | module Shonkier where
2 |
3 | import System.FilePath
4 | import System.IO.Error
5 | import Data.Text (Text)
6 | import qualified Data.Text as T
7 | import qualified Data.Text.IO as TIO
8 | import Prettyprinter (line, layoutPretty, defaultLayoutOptions)
9 | import Prettyprinter.Render.Text
10 |
11 | import Shonkier.Pretty
12 | import Shonkier.Value
13 | import Shonkier.Import
14 | import Shonkier.Semantics
15 | import Shonkier.ShonkierJS
16 | import Shonkier.Syntax
17 |
18 | onShonkierModule :: (Module -> Env -> Term -> IO a)
19 | -> FilePath -> IO a
20 | onShonkierModule action filename = do
21 | (mod@(is, ps), gl) <- importToplevelModule filename
22 | case [ m | ("main", Right m) <- ps ] of
23 | [([] :-> [Nothing :?> body])] -> action mod (gl, mempty) body
24 | _ -> error "not exactly one simple main function"
25 |
26 | interpretShonkier :: FilePath -> IO ()
27 | interpretShonkier = onShonkierModule $ \ _ gamma@(gl,_) body -> go gamma (shonkier gl body) where
28 | go :: Env -> Computation -> IO ()
29 | go _ (Value v) = putDoc $ pretty v <> line
30 | go gamma@(gl,inp) (Request ("read", [f]) k) = case value2path f of
31 | Nothing -> go gamma (resumeShonkier gl k abort)
32 | Just f -> do
33 | tryIOError (TIO.readFile f) >>= \case
34 | Right t -> go gamma (resumeShonkier gl k (use (VString "" t)))
35 | Left _ -> go gamma (resumeShonkier gl k abort)
36 | go gamma@(gl,inp) (Request ("write", [f,VString _ t]) k) = case value2path f of
37 | Nothing -> go gamma (resumeShonkier gl k abort)
38 | Just f -> do
39 | tryIOError (TIO.writeFile f t) >>= \case
40 | Right _ -> go gamma (resumeShonkier gl k (use VNil))
41 | Left _ -> go gamma (resumeShonkier gl k abort)
42 | go gamma@(gl,inp) (Request r@(a, vs) k)
43 | | a `elem` ["POST", "GET", "meta"] = handleInputs (go gamma) gamma r k
44 | | a `elem` ["dot"] = handleDot (go gamma) gamma r k
45 | go _ r@Request{} = do
46 | let r' = renderStrict $ layoutPretty defaultLayoutOptions $ pretty r
47 | error $ "unhandled request " ++ T.unpack r'
48 |
49 | value2path :: Value -> Maybe FilePath
50 | value2path v = makeValid <$> go v where
51 | go (VString _ t) = pure (T.unpack t)
52 | go VNil = pure ""
53 | go (VCell s t) = () <$> go s <*> go t
54 | go _ = Nothing
55 |
56 | -- no support for imports here yet!
57 | compileShonkier :: FilePath -> FilePath -> IO Text
58 | compileShonkier shonkierjs fp = (`onShonkierModule` fp) $ \ _ (env,inputs) body -> do
59 | -- Couldn't figure how to import in node so I just concat the
60 | -- whole interpreter defined 'Shonkier.js' on top
61 | interpreter <- TIO.readFile shonkierjs
62 | let header txt = T.concat ["\n/***** "
63 | , txt
64 | , " "
65 | , T.pack (replicate (72 - 10 - T.length txt) '*')
66 | , "*/\n\n"]
67 | pure $ T.concat $ [interpreter]
68 | ++ (header "Global env"):(jsGlobalEnv env)
69 | ++ (header "Form data"):(jsInputs inputs)
70 | ++ (header "Main"):(jsRun body)
71 |
--------------------------------------------------------------------------------
/src/Shonkier/Dot.hs:
--------------------------------------------------------------------------------
1 | module Shonkier.Dot where
2 |
3 | import qualified Data.Text as T
4 | import Dot.Types
5 |
6 | import Shonkier.Syntax
7 | import Shonkier.Value
8 |
9 | instance FromValue DotGraph where
10 | fromValue v = case v of
11 | VCell (VAtom "strict") b -> fromAfter2Listy (DotGraph Strict) b
12 | v -> fromAfter2Listy (DotGraph NonStrict) v
13 |
14 | instance FromValue Directionality where
15 | fromValue v@(VAtom tag) = case tag of
16 | "graph" -> pure Undirected
17 | "digraph" -> pure Directed
18 | _ -> Left v
19 | fromValue v = Left v
20 |
21 | instance FromValue Id where
22 | fromValue (VString _ str) = pure (Id str)
23 | fromValue v = Left v
24 |
25 | instance FromValue CardinalDirection where
26 | fromValue v@(VAtom tag) = case tag of
27 | "n" -> pure North
28 | "e" -> pure East
29 | "w" -> pure West
30 | "s" -> pure South
31 | "ne" -> pure Northeast
32 | "nw" -> pure Northwest
33 | "se" -> pure Southeast
34 | "sw" -> pure Southwest
35 | _ -> Left v
36 | fromValue v = Left v
37 |
38 | instance FromValue NodeId where
39 | fromValue (VCell a (VCell b (VCell c VNil))) =
40 | NodeId <$> fromValue a
41 | <*> fmap Just (Port <$> fromValue b
42 | <*> fmap Just (fromValue c))
43 | fromValue (VCell a (VCell b@(VAtom (MkAtom tag)) VNil)) = do
44 | a <- fromValue a
45 | -- hack due to https://github.com/andrewthad/dot/issues/3
46 | b <- fromValue b :: Either Value CardinalDirection
47 | pure $ NodeId a $ Just (Port (Id (T.pack tag)) Nothing)
48 | fromValue v = NodeId <$> fromValue v <*> pure Nothing
49 |
50 | instance FromValue Statement where
51 | fromValue (VCell v@(VAtom tag) b) = case tag of
52 | "edge" -> StatementEdge <$> fromValue b
53 | "node" -> StatementNode <$> fromValue b
54 | _ -> Left v
55 | fromValue v = Left v
56 |
57 | instance FromValue EdgeElement where
58 | fromValue v = EdgeNode <$> fromValue v
59 |
60 | instance FromValue EdgeStatement where
61 | fromValue v = fromValue v >>= \case
62 | (a:b:cs) -> pure $ EdgeStatement (ListTwo a b cs) []
63 | _ -> Left v
64 |
65 | instance FromValue NodeStatement where
66 | fromValue v@(VString _ str) = NodeStatement <$> fromValue v <*> pure []
67 | fromValue v = fromAfter1Listy NodeStatement v
68 |
69 | instance FromValue Attribute where
70 | fromValue = fromTakes2 Attribute
71 |
--------------------------------------------------------------------------------
/src/Shonkier/Examples.hs:
--------------------------------------------------------------------------------
1 | module Shonkier.Examples where
2 |
3 | {-
4 | import Data.Map (singleton)
5 | import Data.Semigroup ((<>)) -- needed for ghc versions <= 8.2.2
6 |
7 | import Shonkier.Syntax
8 | import Shonkier.Semantics
9 |
10 | appendEnv :: GlobalEnv
11 | appendEnv = singleton "append" $ singleton "." $ VFun mempty [] mempty []
12 | [ ( PValue <$> [ PCell (PBind "x") (PBind "xs")
13 | , PBind "ys"
14 | ]
15 | , Cell (Var "x") (App (Var "append") [Var "xs", Var "ys"])
16 | )
17 | , ( PValue <$> [ PAtom ""
18 | , PBind "ys"
19 | ]
20 | , Var "ys"
21 | )
22 | ]
23 |
24 | onetwo :: Term
25 | onetwo = Cell (Atom "1") (Cell (Atom "2") (Atom ""))
26 |
27 | threefour :: Term
28 | threefour = Cell (Atom "3") (Cell (Atom "4") (Atom ""))
29 |
30 | onetwothreefour :: Term
31 | onetwothreefour = App (Var "append") [onetwo, threefour]
32 |
33 | appendTest :: Computation
34 | appendTest = shonkier appendEnv onetwothreefour
35 |
36 |
37 | readerEnv :: GlobalEnv
38 | readerEnv = singleton "runReader" $ singleton "." $
39 | VFun mempty [] mempty [[],["ask"]]
40 | [ ( PValue <$> [PBind "_", PBind "val"]
41 | , Var "val"
42 | )
43 | , ( [PValue (PBind "r"), PRequest ("ask", []) (Just "k")]
44 | , App (Var "runReader") [ Var "r"
45 | , App (Var "k") [Var "r"]
46 | ]
47 | )
48 | ]
49 |
50 | onetwoSquared :: Term
51 | onetwoSquared = App (Var "runReader")
52 | [ onetwo
53 | , App (Var "append") [ask, ask]
54 | ] where ask = App (Atom "ask") []
55 |
56 |
57 | askTest :: Computation
58 | askTest = shonkier (appendEnv <> readerEnv) onetwoSquared
59 |
60 |
61 | stateEnv :: GlobalEnv
62 | stateEnv = singleton "runState" $ singleton "." $
63 | VFun mempty [] mempty [[],["get", "put"]]
64 | [ ( PValue <$> [PBind "_", PBind "val"]
65 | , Var "val"
66 | )
67 | , ( [ PValue (PBind "s"), PRequest ("get", []) (Just "k")]
68 | , App (Var "runState") [ Var "s"
69 | , App (Var "k") [Var "s"]
70 | ]
71 | )
72 | , ( [ PValue (PBind "_"), PRequest ("put", [PBind "s"]) (Just "k")]
73 | , App (Var "runState") [ Var "s"
74 | , App (Var "k") [Atom ""]
75 | ]
76 | )
77 | ]
78 |
79 | mapEnv :: GlobalEnv
80 | mapEnv = singleton "map" $ singleton "." $ VFun mempty [] mempty []
81 | [ ( PValue <$> [ PBind "f", PAtom "" ]
82 | , Atom ""
83 | )
84 | , ( PValue <$> [ PBind "f", PCell (PBind "x") (PBind "xs") ]
85 | , Cell (App (Var "f") [Var "x"]) (App (Var "map") (Var <$> ["f", "xs"]))
86 | )
87 | ]
88 |
89 | lam :: Variable -> (Term -> Term) -> Term
90 | lam x b = Fun [] [ ( [ PValue (PBind x)]
91 | , b (Var x)
92 | )
93 | ]
94 |
95 | inc :: Term
96 | inc = App f [ App (Atom "get") []
97 | , App (Atom "put") [ Cell (Atom "bip") (App (Atom "get") []) ]
98 | ] where
99 |
100 | f = Fun [] [ ( PValue . PBind <$> ["v", "_"]
101 | , Var "v"
102 | )
103 | ]
104 |
105 | bipping :: Term
106 | bipping = App (Var "runState")
107 | [ Atom ""
108 | , App (Var "map") [ lam "_" (\ _ -> inc)
109 | , onetwothreefour
110 | ]
111 | ]
112 |
113 | stateTest :: Computation
114 | stateTest = shonkier (mapEnv <> stateEnv <> appendEnv) bipping
115 |
116 | mkPrim :: String -> [Literal] -> Computation
117 | mkPrim p ls = shonkier primEnv $ App (Var p) (Lit <$> ls)
118 |
119 | strConcat :: [Literal] -> Computation
120 | strConcat = mkPrim "primStringConcat"
121 |
122 | helloworld :: Computation
123 | helloworld = strConcat $ String "foo" <$> ["hello ", "world", "!"]
124 |
125 | helloworld' :: Computation
126 | helloworld' = strConcat $ String "" <$> ["hello ", "world", "!"]
127 |
128 | foogoo :: Computation
129 | foogoo = strConcat [String "foo" "fo", String "goo" "\"foo", String "" " oof!"]
130 |
131 | listConcat :: Computation
132 | listConcat = shonkier primEnv $ App (Var "primStringConcat") [str] where
133 | str = Cell (Cell (TString "" "hello")
134 | (Cell (TString "" " ") (TString "" "world")))
135 | (Cell (TString "" "!") (TString "" "\n"))
136 |
137 | numAdd :: [Literal] -> Computation
138 | numAdd = mkPrim "primNumAdd"
139 |
140 | three :: Computation
141 | three = numAdd (Num <$> [1, 2])
142 | -}
143 |
--------------------------------------------------------------------------------
/src/Shonkier/FreeVars.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE GADTs #-}
2 |
3 | module Shonkier.FreeVars where
4 |
5 | import Data.Map (Map)
6 | import Data.Set (Set)
7 | import qualified Data.Set as Set
8 |
9 | import Shonkier.Syntax
10 | import Shonkier.Value
11 |
12 | class FreeVars t where
13 | freeVars :: t -> Set Variable
14 |
15 | default freeVars :: (t ~ f a, Foldable f, FreeVars a) => t -> Set Variable
16 | freeVars = foldMap freeVars
17 |
18 | instance FreeVars t => FreeVars [t]
19 | instance FreeVars t => FreeVars (Maybe t)
20 | instance FreeVars t => FreeVars (Map k t)
21 |
22 | instance FreeVars RawVariable where
23 | freeVars (mns :.: x) = maybe Set.empty Set.singleton (x <$ mns)
24 |
25 | instance FreeVars ScopedVariable where
26 | freeVars (scope :.: x) = case scope of
27 | LocalVar -> Set.singleton x
28 | GlobalVar{} -> Set.empty
29 | AmbiguousVar{} -> Set.empty
30 | InvalidNamespace{} -> Set.empty
31 | OutOfScope{} -> Set.empty
32 |
33 | instance FreeVars v => FreeVars (Term' a v) where
34 | freeVars = \case
35 | Atom{} -> Set.empty
36 | Lit{} -> Set.empty
37 | Nil{} -> Set.empty
38 | Blank -> Set.empty
39 | String _ tes _ -> foldMap (freeVars . snd) tes
40 | Var v -> freeVars v
41 | Cell a b -> freeVars [a, b]
42 | App f ts -> freeVars (f:ts)
43 | -- To be exact we would need to subtract the variables bound in `f`
44 | -- if it is a `Match`. At the moment we generate an over-approximation.
45 | Semi a b -> freeVars [a, b]
46 | Prio a b -> freeVars [a, b]
47 | Fun _ cls -> freeVars cls
48 | Match p e -> freeVars e
49 | Mask a t -> freeVars t
50 |
51 | instance FreeVars (PValue' a) where
52 | freeVars = \case
53 | PAtom{} -> Set.empty
54 | PLit{} -> Set.empty
55 | PWild{} -> Set.empty
56 | PNil{} -> Set.empty
57 | PBind v -> Set.singleton v
58 | PString _ tps _ -> foldMap (freeVars . snd) tps
59 | PAs v p -> Set.insert v (freeVars p)
60 | PCell a b -> freeVars [a, b]
61 |
62 | instance FreeVars (PComputation' a) where
63 | freeVars = \case
64 | PValue v -> freeVars v
65 | PRequest (_, ps) mk -> Set.union (freeVars ps) (maybe Set.empty Set.singleton mk)
66 | PThunk k -> Set.singleton k
67 |
68 | instance FreeVars v => FreeVars (Clause' a v) where
69 | freeVars (ps :-> t) = Set.difference (freeVars t) (freeVars ps)
70 |
71 | instance FreeVars v => FreeVars (Rhs' a v) where
72 | freeVars (gd :?> tm) = Set.union (freeVars gd) (freeVars tm)
73 |
74 | instance FreeVars v => FreeVars (Value' a v) where
75 | freeVars = \case
76 | VAtom{} -> Set.empty
77 | VLit{} -> Set.empty
78 | VNil{} -> Set.empty
79 | VString{} -> Set.empty
80 | VPrim{} -> Set.empty
81 | VCell a b -> freeVars [a, b]
82 | VFun _ rho _ cls -> Set.union (freeVars rho) (freeVars cls)
83 | VThunk c -> freeVars c
84 | VEnv rho -> freeVars rho
85 |
86 | instance FreeVars v => FreeVars (Computation' a v) where
87 | freeVars = \case
88 | Value v -> freeVars v
89 | Request (_, vs) _ -> freeVars vs
90 |
--------------------------------------------------------------------------------
/src/Shonkier/Import.hs:
--------------------------------------------------------------------------------
1 | module Shonkier.Import where
2 |
3 | import Control.Arrow
4 | import Control.Monad.State
5 |
6 | import Data.Either (isRight)
7 | import Data.Foldable (fold)
8 | import Data.Function (on)
9 | import Data.List (nub, groupBy, sortBy, stripPrefix)
10 | import qualified Data.Map as Map
11 | import Data.Set (Set)
12 | import qualified Data.Set as Set
13 | import qualified Data.Text.IO as TIO
14 |
15 | import System.Directory
16 | import System.FilePath
17 |
18 | import Shonkier.Syntax
19 | import Shonkier.Parser
20 | import Shonkier.Scope
21 | import Shonkier.Value
22 | import Shonkier.Primitives
23 |
24 | import Utils.List
25 |
26 | data ImportState = ImportState
27 | { visited :: Set FilePath
28 | -- ^ Set of visited modules. The import DAG could have a lot
29 | -- of shared nodes and we only need to load them once.
30 | , globals :: GlobalEnv
31 | -- ^ Global environment of accumulated definitions collected
32 | -- from the visited nodes.
33 | } deriving (Show)
34 |
35 | emptyImportState :: ImportState
36 | emptyImportState = ImportState
37 | { visited = Set.empty
38 | , globals = primEnv
39 | }
40 |
41 | newtype ImportT m a = ImportT { getImportT :: StateT ImportState m a }
42 | deriving ( Functor, Applicative, Monad
43 | , MonadState ImportState, MonadIO)
44 |
45 | runImportT :: Monad m
46 | => ImportT m a -> ImportState -> m (a, ImportState)
47 | runImportT m s = (`runStateT` s) $ getImportT m
48 |
49 | evalImportT :: Monad m => ImportT m a -> ImportState -> m a
50 | evalImportT m s = fst <$> runImportT m s
51 |
52 | execImportT :: Monad m => ImportT m a -> ImportState -> m ImportState
53 | execImportT m s = snd <$> runImportT m s
54 |
55 | forceReadModule :: FilePath -> IO RawModule
56 | forceReadModule fp = getMeAModule <$> TIO.readFile fp
57 |
58 | forceImportModule :: [FilePath] -> FilePath -> ImportT IO Module
59 | forceImportModule base fp = do
60 | let file = joinPath base fp
61 | rm <- liftIO $ forceReadModule file
62 | loadModule base file rm
63 |
64 | -- Returns the path where the module was found, and maybe the module
65 | -- itself if we haven't visited it already.
66 | importModule :: [FilePath] -> FilePath -> ImportT IO (FilePath, Maybe Module)
67 | importModule base fp = do
68 | let file = joinPath base fp
69 | cached <- gets (Set.member file . visited)
70 | if cached
71 | -- we've seen it before!
72 | then pure (file, Nothing)
73 | else do
74 | exists <- liftIO $ doesFileExist file
75 | if exists
76 | -- we found it!
77 | then do
78 | m <- forceImportModule base file
79 | pure (file, Just m)
80 | else case base of
81 | -- we've hit (filesystem) rock bottom
82 | [] -> error $ "import does not exist: " ++ fp
83 | -- otherwise try again moving closer to the root
84 | _ -> importModule (init base) fp
85 |
86 | -- The filepath @fp@ is the import asked for, so joining it to base we
87 | -- get an absolute path to our current attempt at importing.
88 | -- File references returned are absolute.
89 | loadModule :: [FilePath] -> FilePath -> RawModule -> ImportT IO Module
90 | loadModule base fp (is, ls) = do
91 | let file = joinPath base fp
92 | is' <- mapM updateModule is
93 | scope <- gets (fmap Map.keysSet . globals)
94 | let ps = checkRaw file is' scope ls
95 | let env = mkGlobalEnv file ps
96 | modify (\ r -> r { globals = Map.unionWith (<>) (globals r) env
97 | , visited = Set.insert file (visited r)
98 | })
99 | pure (is, ps)
100 | where
101 | updateModule (i, mn) = do
102 | (i', _) <- importModule base i
103 | pure (i' , mn)
104 |
105 | -- Apart from loading the top level module, also simplifies the
106 | -- returned module and global env by stripping out the longest common
107 | -- prefix from all paths therein. Hence if all imported files are in
108 | -- the directory /home/biffo/shonkier-projects/, this prefix will be
109 | -- stripped out in the interest of read- and port-ability.
110 | loadToplevelModule :: FilePath -> RawModule -> IO (Module, GlobalEnv, String)
111 | loadToplevelModule fp rm = do
112 | base <- takeDirectory <$> makeAbsolute fp
113 | (m, st) <- runImportT (loadModule (splitPath base) (takeFileName fp) rm) emptyImportState
114 | -- strip common prefix from global env
115 | let (lcp, gl) = simplifyGlobalEnv $ globals st
116 | -- strip common prefix from all programs
117 | let m' = second (fmap (fmap (fmap (simplifyTerm lcp)))) m
118 | pure (m', gl, lcp)
119 |
120 | importToplevelModule :: FilePath -> IO (Module, GlobalEnv)
121 | importToplevelModule fp = do
122 | (m, e, lcp) <- forceReadModule fp >>= loadToplevelModule fp
123 | pure (m, e)
124 |
125 | mkGlobalEnv :: FilePath -> Program -> GlobalEnv
126 | mkGlobalEnv fp ls = fold
127 | [ Map.singleton f $ Map.singleton fp
128 | $ VFun CnNil mempty
129 | (map nub (foldr padCat [] [hs | (_, Left hs) <- grp]))
130 | [cl | (_, Right cl) <- grp]
131 | | grp@((f, _) : _) <- groupBy ((==) `on` fst) $
132 | -- Note: sortBy is stable
133 | sortBy (compare `on` (id *** isRight)) $
134 | ls
135 | ]
136 |
137 | -- Returns the longest common prefix of all filepaths occurring in its
138 | -- argument, together with a simplified global env where this prefix
139 | -- has been stripped everywhere
140 | simplifyGlobalEnv :: GlobalEnv -> (String, GlobalEnv)
141 | simplifyGlobalEnv gl = (lcp, gl') where
142 | lcp = longestCommonPrefix $ filter (/= ".")
143 | $ concatMap Map.keys $ Map.elems gl
144 | gl' = Map.map (Map.map (simplifyTerm lcp))
145 | $ Map.map (Map.mapKeys $ stripPrefixButDot lcp) gl
146 |
147 | simplifyTerm :: Functor f => String -> f ScopedVariable -> f ScopedVariable
148 | simplifyTerm lcp = fmap simp
149 | where
150 | simp :: ScopedVariable -> ScopedVariable
151 | simp (GlobalVar b fp :.: x) = GlobalVar b (stripPrefixButDot lcp fp) :.: x
152 | simp y = y
153 |
154 | stripPrefixButDot :: String -> String -> String
155 | stripPrefixButDot prf "." = "."
156 | stripPrefixButDot prf x = case stripPrefix prf x of
157 | Just "" -> "."
158 | Just x -> x
159 | Nothing -> error $ "IMPOSSIBLE claimed common prefix actually not a prefix. Prefix: " ++ show prf ++ " x: " ++ show x
160 |
161 | stripVarPrefix :: String -> RawVariable -> RawVariable
162 | stripVarPrefix lcp (p :.: x) = (stripPrefixButDot lcp <$> p) :.: x
163 |
--------------------------------------------------------------------------------
/src/Shonkier/Pandoc.hs:
--------------------------------------------------------------------------------
1 | module Shonkier.Pandoc where
2 |
3 | import Data.Text (Text)
4 | import Data.Attoparsec.Text
5 | import Text.Pandoc.Definition (Inline(..), Block(..), ListNumberStyle(..), ListNumberDelim(..), Format(..))
6 |
7 | import Shonkier.Parser
8 | import Shonkier.Syntax
9 | import Shonkier.Value
10 |
11 | ---------------------------------------------------------------------------
12 | -- TORAWTERM
13 | ---------------------------------------------------------------------------
14 |
15 | instance ToRawTerm RawTerm where
16 | toRawTerm = id
17 |
18 | instance ToRawTerm t => ToRawTerm [t] where
19 | toRawTerm = foldr (Cell . toRawTerm) Nil
20 |
21 | instance (ToRawTerm a, ToRawTerm b) => ToRawTerm (a, b) where
22 | toRawTerm (a, b) = Cell (toRawTerm a) (toRawTerm b)
23 |
24 | instance (ToRawTerm a, ToRawTerm b, ToRawTerm c) => ToRawTerm (a, b, c) where
25 | toRawTerm (a, b, c) = Cell (toRawTerm a) (toRawTerm (b, c))
26 |
27 | toListy :: ToRawTerm a => Atom -> [a] -> RawTerm
28 | toListy at = Cell (Atom at) . toRawTerm
29 |
30 | toTakes1 :: ToRawTerm a => Atom -> a -> RawTerm
31 | toTakes1 at = Cell (Atom at) . toRawTerm
32 |
33 | toTakes2 :: (ToRawTerm a, ToRawTerm b) => Atom -> a -> b -> RawTerm
34 | toTakes2 at a b = Cell (Atom at) (toRawTerm (a, b))
35 |
36 | toTakes3 :: (ToRawTerm a, ToRawTerm b, ToRawTerm c)
37 | => Atom -> a -> b -> c -> RawTerm
38 | toTakes3 at a b c = Cell (Atom at) (toRawTerm (a, b, c))
39 |
40 | toAfter1Listy :: (ToRawTerm a, ToRawTerm b) => Atom -> a -> [b] -> RawTerm
41 | toAfter1Listy at a b = Cell (Atom at) (Cell (toRawTerm a) (toRawTerm b))
42 |
43 | toAfter2Listy :: (ToRawTerm a, ToRawTerm b, ToRawTerm c)
44 | => Atom -> a -> b -> [c] -> RawTerm
45 | toAfter2Listy at a b c =
46 | Cell (Atom at) (Cell (toRawTerm a) (Cell (toRawTerm b) (toRawTerm c)))
47 |
48 |
49 | instance ToRawTerm Int where
50 | toRawTerm = TNum . fromIntegral
51 |
52 | instance ToRawTerm Text where
53 | toRawTerm = String "" []
54 |
55 | instance ToRawTerm Format where
56 | toRawTerm (Format f) = toRawTerm f
57 |
58 | instance ToRawTerm ListNumberDelim where
59 | toRawTerm = Atom . MkAtom . show
60 |
61 | instance ToRawTerm ListNumberStyle where
62 | toRawTerm = Atom . MkAtom . show
63 |
64 | instance ToRawTerm Block where
65 | toRawTerm = \case
66 | -- Null -> Atom "Null"
67 | Plain ps -> toListy "Plain" ps
68 | Para ps -> toListy "Para" ps
69 | LineBlock ps -> toListy "LineBlock" ps
70 | CodeBlock a@(b, cs, d) e
71 | | "mary" `elem` cs
72 | , Right t <- parseOnly topTerm e
73 | -> toAfter1Listy "Div" (b, filter ("mary" /=) cs, d) [t]
74 | | otherwise
75 | -> toTakes2 "Code" a e
76 | RawBlock a b -> toTakes2 "RawBlock" a b
77 | BlockQuote a -> toListy "BlockQuote" a
78 | OrderedList a b -> toAfter1Listy "OrderedList" a b
79 | BulletList as -> toListy "BulletList" as
80 | DefinitionList ds -> toListy "DefinitionList" ds
81 | Header a b c -> toAfter2Listy "Header" a b c
82 | HorizontalRule -> Atom "HorizontalRule"
83 | Div a b -> toAfter1Listy "Div" a b
84 |
85 | instance ToRawTerm Inline where
86 | toRawTerm = \case
87 | Str t -> String "" [] t
88 | Emph is -> toListy "Emph" is
89 | Strong is -> toListy "Strong" is
90 | Strikeout is -> toListy "Strikeout" is
91 | Superscript is -> toListy "Superscript" is
92 | Subscript is -> toListy "Superscript" is
93 | SmallCaps is -> toListy "SmallCaps" is
94 | Underline is -> toListy "Underline" is
95 | Code a@(b, cs, d) e
96 | | "mary" `elem` cs
97 | , Right t <- parseOnly topTerm e
98 | -> toAfter1Listy "Span" (b, filter ("mary" /=) cs, d) [t]
99 | | otherwise
100 | -> toTakes2 "Code" a e
101 | SoftBreak -> Atom "SoftBreak"
102 | LineBreak -> Atom "LineBreak"
103 | RawInline a b -> toTakes2 "RawInline" a b
104 | Link a b c -> toTakes3 "Link" a b c
105 | Image a b c -> toTakes3 "Image" a b c
106 | Note as -> toListy "Note" as
107 | Span a b -> toAfter1Listy "Span" a b
108 | Space -> Atom "Space"
109 |
110 | ---------------------------------------------------------------------------
111 | -- FROMVALUE
112 | ---------------------------------------------------------------------------
113 |
114 | instance FromValue Format where
115 | fromValue = fmap Format . fromValue
116 |
117 | instance FromValue ListNumberDelim where
118 | fromValue v@(VAtom tag) = case tag of
119 | "DefaultDelim" -> pure DefaultDelim
120 | "Period" -> pure Period
121 | "OneParen" -> pure OneParen
122 | "TwoParens" -> pure TwoParens
123 | _ -> Left v
124 | fromValue v = Left v
125 |
126 | instance FromValue ListNumberStyle where
127 | fromValue v@(VAtom tag) = case tag of
128 | "DefaultStyle" -> pure DefaultStyle
129 | "Example" -> pure Example
130 | "Decimal" -> pure Decimal
131 | "LowerRoman" -> pure LowerRoman
132 | "UpperRoman" -> pure UpperRoman
133 | "LowerAlpha" -> pure LowerAlpha
134 | "UpperAlpha" -> pure UpperAlpha
135 | _ -> Left v
136 | fromValue v = Left v
137 |
138 | instance FromValue Block where
139 | fromValue (VCell v@(VAtom tag) is) = ($ is) $ case tag of
140 | "Plain" -> fromListy Plain
141 | "Para" -> fromListy Para
142 | "LineBlock" -> fromListy LineBlock
143 | "CodeBlock" -> fromTakes2 CodeBlock
144 | "RawBlock" -> fromTakes2 RawBlock
145 | "BlockQuote" -> fromListy BlockQuote
146 | "OrderedList" -> fromAfter1Listy OrderedList
147 | "BulletList" -> fromListy BulletList
148 | "DefinitionList" -> fromListy DefinitionList
149 | "Header" -> fromAfter2Listy Header
150 | -- TODO: Table, Figure
151 | "Div" -> fromAfter1Listy Div
152 | _ -> const (Left v)
153 | fromValue v@(VAtom tag) = case tag of
154 | "HorizontalRule" -> pure HorizontalRule
155 | -- "Null" -> pure Null
156 | _ -> Left v
157 | fromValue v = Left v
158 |
159 | instance FromValue Inline where
160 | fromValue (VString _ t) = pure (Str t)
161 | fromValue (VCell v@(VAtom tag) is) = ($ is) $ case tag of
162 | "Emph" -> fromListy Emph
163 | "Strong" -> fromListy Strong
164 | "StrikeOut" -> fromListy Strikeout
165 | "Superscript" -> fromListy Superscript
166 | "Subscript" -> fromListy Subscript
167 | "SmallCaps" -> fromListy SmallCaps
168 | "Underline" -> fromListy Underline
169 | -- TODO: Quoted
170 | -- TODO: Cite
171 | "Code" -> fromTakes2 Code
172 | -- TODO: Math
173 | "RawInline" -> fromTakes2 RawInline
174 | "Link" -> fromTakes3 Link
175 | "Image" -> fromTakes3 Image
176 | "Note" -> fromListy Note
177 | "Span" -> fromAfter1Listy Span
178 | _ -> const (Left v)
179 | fromValue v@(VAtom tag) = case tag of
180 | "Space" -> pure Space
181 | "SoftBreak" -> pure SoftBreak
182 | "LineBreak" -> pure LineBreak
183 | _ -> Left v
184 | fromValue v = Left v
185 |
--------------------------------------------------------------------------------
/src/Shonkier/Parser.hs:
--------------------------------------------------------------------------------
1 | module Shonkier.Parser where
2 |
3 | import Control.Applicative
4 | import Control.Arrow (first)
5 | import Control.Monad
6 |
7 | import Data.Attoparsec.Text hiding (skipSpace)
8 | import qualified Data.Attoparsec.Text as Atto
9 | import Data.Char
10 | import Data.Ratio
11 | import Data.Text(Text)
12 | import qualified Data.Text as T
13 |
14 | import Shonkier.Syntax
15 |
16 | -- We can insert comments anywhere we may insert space
17 | skipSpace :: Parser ()
18 | skipSpace = comments
19 |
20 | module_ :: Parser RawModule
21 | module_ = (,) <$> many (import_ <* skipSpace) <*> program
22 |
23 | import_ :: Parser Import
24 | import_ = do
25 | () <$ string "import"
26 | skipSpace
27 | (_, [], fp) <- spliceOf (choice [])
28 | skipSpace
29 | alias <- choice [ Just <$ string "as" <* skipSpace <*> identifier
30 | , pure Nothing
31 | ]
32 | pure (T.unpack fp, alias)
33 |
34 | program :: Parser RawProgram
35 | program = id <$ skipSpace
36 | <*> many ((,) <$> identifier <*> (Left <$> decl <|> Right <$> defn) <* skipSpace)
37 | <* endOfInput
38 |
39 | data Comment = Line | Nested deriving (Eq, Show)
40 |
41 | comments :: Parser ()
42 | comments = do
43 | Atto.skipSpace
44 | -- we may have many space-separated comments
45 | void $ many $ do
46 | () <$ char '/' <* choice [ char '/' <* match Line
47 | , char '*' <* match Nested
48 | ]
49 | Atto.skipSpace
50 | where
51 |
52 | -- kickstarting the process: scanning the file until we have closed
53 | -- the comment delimiter @style@ and all potentially nested comments.
54 | match style = scan ([style], init) (uncurry delim)
55 |
56 | -- delimiters
57 | init = ("//", "/*", "*/")
58 |
59 | -- eating a character
60 | eats c (s, t, u) = let (p, q, r) = init in (eat p c s, eat q c t, eat r c u)
61 |
62 | -- @eat reset c state@ tries to eat the character @c@ from the @state@.
63 | -- If it cannot, we had a mismatch & need to restart matching with @reset@.
64 | eat reset@(e : es) c (d : ds)
65 | -- success
66 | | c == d = ds
67 | -- surprise: we failed but could make progress along @reset@!
68 | -- See e.g. that the string "**/" is a valid end of comment despite
69 | -- "**" not being one. We fail finding the end-of-comment delimiter
70 | -- on the second '*' but still make enough progress to succeed after
71 | -- only reading one additional '/'.
72 | -- We can afford to only have this check because all of our delimiters
73 | -- have length 2. Otherwise we would need a more complex DFA to perform
74 | -- this kind of backtracking.
75 | | c == e = es
76 | -- catchall: hard fail, start from the very beginning
77 | | otherwise = reset
78 | -- If the @state@ is empty we should have been done already.
79 | -- None of the potential @reset@ are empty so this last case
80 | -- can never happen.
81 | eat _ _ _ = error "The IMPOSSIBLE happened while parsing a comment!"
82 |
83 | -- @delim stk state c@ checks whether eating @c@ in the state @state@
84 | -- is enough to have closed all of the opened delimiters stored in the
85 | -- stack @stk@.
86 | -- The state, a triple of strings, is obscure enough that I have declared
87 | -- pattern synonyms to clarify what the different configuations mean. They
88 | -- are below because we may only declare pattern synonyms at the top-level.
89 |
90 | -- if the stack has just been emptied, we're done!
91 | delim :: [Comment] -> (String, String, String) -> Char ->
92 | Maybe ([Comment], (String, String, String))
93 | delim [] _ c = Nothing
94 | -- line comments: eat everything up until the end of line
95 | delim (Line : stk) _ '\n' = Just (stk, init)
96 | delim stk@(Line : _) st c = Just (stk, eats c st)
97 | delim stk NewLine{} c = Just (Line : stk, eats c init)
98 | -- nested comments: succeed only once you've closed the last one
99 | delim stk NewNested{} c = Just (Nested : stk, eats c init)
100 | delim [Nested] EndNested{} c = Nothing
101 | delim (Nested : stk) EndNested{} c = Just (stk, eats c init)
102 | -- default: haven't seen anything interesting so keep munching
103 | delim stk st c = Just (stk, eats c st)
104 |
105 | -- ghc only wants invertible patterns...
106 | pattern NewLine :: String -> String -> (String, String, String)
107 | pattern NewLine b c = ("", b, c)
108 | pattern NewNested :: String -> String -> (String, String, String)
109 | pattern NewNested a c = (a, "", c)
110 | pattern EndNested :: String -> String -> (String, String, String)
111 | pattern EndNested a b = (a, b, "")
112 |
113 |
114 | someSp :: Parser a -> Parser [a]
115 | someSp p = (:) <$> p <*> many (id <$ skipSpace <*> p)
116 |
117 | decl :: Parser [[Atom]]
118 | decl = argTuple (sep skipSpace atom) <* skipSpace <* char ':'
119 |
120 | defn :: Parser RawClause
121 | defn = (:->) <$> argTuple pcomputation <*> rhs
122 |
123 | punc :: String -> Parser ()
124 | punc c = () <$ skipSpace <* traverse char c <* skipSpace
125 |
126 | sep :: Parser () -> Parser x -> Parser [x]
127 | sep s p = (:) <$> p <*> many (id <$ s <*> p) <|> pure []
128 |
129 | topTerm :: Parser RawTerm
130 | topTerm = spaceTerm
131 |
132 | spaceTerm :: Parser RawTerm
133 | spaceTerm = id <$ skipSpace <*> term <* skipSpace
134 |
135 | ------------------------------------------------------------------------------
136 | -- NOTA BENE --
137 | -- --
138 | -- parsers for terms/patterns must forbid leading/trailing space --
139 | -- --
140 | ------------------------------------------------------------------------------
141 |
142 | opok :: OpFax -> WhereAmI -> Parser ()
143 | opok o w = () <$ guard (not (needParens o w))
144 |
145 | term :: Parser RawTerm
146 | term = termBut Utopia
147 |
148 | termBut :: WhereAmI -> Parser RawTerm
149 | termBut w = weeTerm w >>= moreTerm w
150 |
151 | weeTerm :: WhereAmI -> Parser RawTerm
152 | weeTerm w = choice
153 | [ Match <$ opok pamaFax w
154 | <*> pvalue <* skipSpace <* char ':' <* char '=' <* skipSpace
155 | <*> termBut (RightOf :^: pamaFax)
156 | , Atom <$> atom
157 | , Lit <$> literal
158 | , (\ (k, t, es) -> String k t es) <$> spliceOf spaceTerm
159 | , Var <$> variable
160 | , Blank <$ char '_'
161 | , uncurry (flip $ foldr Cell) <$> listOf term Nil
162 | , Fun [] <$ char '{' <* skipSpace
163 | <*> sep skipSpace clause <* skipSpace <* char '}'
164 | , id <$ char '(' <*> spaceTerm <* char ')'
165 | , opCand >>= prefixApp w
166 | ]
167 |
168 | moreTerm :: WhereAmI -> RawTerm -> Parser RawTerm
169 | moreTerm w t = choice
170 | [ App t <$ opok applFax w <*> argTuple term >>= moreTerm w
171 | , Mask <$> tmAtom t <* opok maskFax w <* punc "^"
172 | <*> termBut (RightOf :^: maskFax) >>= moreTerm w
173 | , Semi t <$ opok semiFax w <* punc ";"
174 | <*> termBut (RightOf :^: semiFax) >>= moreTerm w
175 | , Prio t <$ opok prioFax w <* punc "?>"
176 | <*> termBut (RightOf :^: prioFax) >>= moreTerm w
177 | , (skipSpace *> opCand) >>= infixApp w t >>= moreTerm w
178 | , pure t
179 | ] where
180 | tmAtom (Atom a) = pure a
181 | tmAtom _ = empty
182 |
183 | prefixApp :: WhereAmI -> String -> Parser RawTerm
184 | prefixApp w p = case lookup p prefixOpFax of
185 | Nothing -> empty
186 | Just x -> App (Var (Nothing :.: ("primPrefix" ++ spell x))) . (:[])
187 | <$ opok x w
188 | <* skipSpace
189 | <*> termBut (RightOf :^: x)
190 |
191 | infixApp :: WhereAmI -> RawTerm -> String -> Parser RawTerm
192 | infixApp w l i = case lookup i infixOpFax of
193 | Nothing -> empty
194 | Just x -> App (Var (Nothing :.: ("primInfix" ++ spell x))) . (l :) . (:[])
195 | <$ opok x w
196 | <* skipSpace
197 | <*> termBut (RightOf :^: x)
198 |
199 | atom :: Parser Atom
200 | atom = MkAtom <$ char '\'' <*> identifier
201 |
202 | identifier :: Parser String
203 | identifier = (:) <$> satisfy isAlpha <*> many (satisfy isAlphaNum)
204 |
205 | opCand :: Parser String
206 | opCand = (:) <$> satisfy oppy
207 | <*> (T.unpack <$> Atto.takeWhile oppy)
208 | where oppy = inClass opChars
209 |
210 | arrow :: Parser ()
211 | arrow = () <$ char '-' <* char '>'
212 |
213 | literal :: Parser Literal
214 | literal = boolit <|> numlit
215 |
216 | spliceOf :: Parser a -> Parser (Keyword, [(Text, a)], Text)
217 | spliceOf p = do
218 | fence <- option "" identifier <* char '"'
219 | (txt, atxts) <- munchSplice fence
220 | let (ps, end) = rotate txt atxts
221 | pure (fence, ps, end)
222 |
223 | where
224 | rotate txt [] = ([], txt)
225 | rotate txt ((a, txt') : rest) = first ((txt, a):) $ rotate txt' rest
226 |
227 | munchSplice fence = do
228 | let endStr = '"':fence
229 | let startSpl = fence ++ "`"
230 | let nextEndStr [] c = Nothing
231 | nextEndStr (d : ds) c
232 | | c == d = Just ds
233 | | c == '"' = Just fence
234 | | otherwise = Just endStr
235 | let nextStartSpl es c
236 | | [] `elem` es = Nothing
237 | | otherwise = Just [ ds | (d : ds) <- startSpl : es, c == d ]
238 | let delim (a, b) c = (,) <$> nextEndStr a c <*> nextStartSpl b c
239 | txt <- scan (endStr, []) delim
240 | if | Just txt' <- T.stripSuffix (T.pack startSpl) txt -> do
241 | a <- p
242 | string (T.pack $ '`':fence)
243 | mrest <- choice [ Just <$> munchSplice fence
244 | , pure Nothing
245 | ]
246 | pure $ case mrest of
247 | Just (lit, rest) -> (txt', (a, lit):rest)
248 | Nothing -> (txt', [(a, "")])
249 | | Just txt' <- T.stripSuffix (T.pack endStr) txt ->
250 | pure (txt', [])
251 | | otherwise -> choice []
252 |
253 | boolit :: Parser Literal
254 | boolit = Boolean <$ char '\'' <*> (False <$ char '0' <|> True <$ char '1')
255 |
256 | data NumExtension
257 | = Dot String
258 | | Slash String
259 | | None
260 |
261 | numlit :: Parser Literal
262 | numlit = do
263 | n <- read <$> some (satisfy isDigit)
264 | ext <- choice [ Dot <$ char '.' <*> some (satisfy isDigit)
265 | , Slash <$ char '/' <*> some (satisfy isDigit)
266 | , pure None
267 | ]
268 | pure $ Num $ case ext of
269 | Dot rs -> (n % 1) + (read rs % read ('1' : ('0' <$ rs)))
270 | Slash rs -> n % read rs
271 | None -> n % 1
272 |
273 | listOf :: Parser a -> a -> Parser ([a], a)
274 | listOf p nil = (,) <$ char '['
275 | <*> many (spaceMaybeComma *> p) <* spaceMaybeComma
276 | <*> (id <$ char '|' <* skipSpace <*> p <|> pure nil)
277 | <* skipSpace <* char ']'
278 |
279 | ------------------------------------------------------------------------------
280 | -- NOTA BENE --
281 | -- --
282 | -- no whitespace before or after an argtuple! --
283 | --
284 | argTuple :: Parser a -> Parser [a] --
285 | argTuple p = --
286 | id <$ char '(' <* skipSpace --
287 | <*> sep (punc ",") p --
288 | <* skipSpace <* char ')' --
289 | --
290 | -- --
291 | ------------------------------------------------------------------------------
292 |
293 | variable :: Parser RawVariable
294 | variable = do
295 | start <- identifier
296 | next <- choice [ Just <$ char '.' <*> identifier
297 | , pure Nothing ]
298 | pure $ case next of
299 | Nothing -> (Nothing :.: start)
300 | Just end -> (Just start :.: end)
301 |
302 | spaceMaybeComma :: Parser ()
303 | spaceMaybeComma =
304 | () <$ skipSpace <* (() <$ char ',' <* skipSpace <|> pure ())
305 |
306 |
307 | clause :: Parser RawClause
308 | clause = (:->) <$> sep spaceMaybeComma pcomputation <*> rhs
309 | <|> ([] :->) <$> ((:[]) . (Nothing :?>) <$> term)
310 |
311 | rhs :: Parser [RawRhs]
312 | rhs = (:[]) . (Nothing :?>) <$ punc "->" <*> term
313 | <|> someSp ((:?>) <$ punc "|" <*> (Just <$> term <|> pure Nothing)
314 | <* punc "->" <*> term)
315 |
316 | pcomputation :: Parser PComputation
317 | pcomputation
318 | = PValue <$> pvalue
319 | <|> id <$ char '{' <* skipSpace <*>
320 | ( PThunk <$> identifier
321 | <|> PRequest <$> ((,) <$> atom <*> argTuple pvalue) <* skipSpace
322 | <* arrow <* skipSpace <*> (Just <$> identifier <|> Nothing <$ char '_')
323 | ) <* skipSpace <* char '}'
324 |
325 | pvar :: Parser PValue
326 | pvar = do
327 | var <- identifier
328 | choice [ PAs var <$ char '@' <*> pvalue
329 | , pure (PBind var)
330 | ]
331 |
332 | pvalue :: Parser PValue
333 | pvalue = choice
334 | [ PLit <$> literal
335 | , (\ (kw, ps, lit) -> PString kw ps lit) <$> spliceOf pvalue
336 | , PAtom <$> atom
337 | , pvar
338 | , PWild <$ char '_'
339 | , uncurry (flip $ foldr PCell) <$> listOf pvalue PNil
340 | ]
341 |
342 | getMeA :: Parser a -> Text -> a
343 | getMeA p txt = case parseOnly p txt of
344 | Left err -> error err
345 | Right t -> t
346 |
347 | getMeAModule :: Text -> RawModule
348 | getMeAModule = getMeA module_
349 |
350 | getMeAProgram :: Text -> RawProgram
351 | getMeAProgram = getMeA program
352 |
353 | getMeATerm :: Text -> RawTerm
354 | getMeATerm = getMeA (spaceTerm <* endOfInput)
355 |
--------------------------------------------------------------------------------
/src/Shonkier/Parser/Examples.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 |
3 | module Shonkier.Parser.Examples where
4 |
5 | {-
6 | import Shonkier.Parser
7 | import Shonkier.Syntax
8 | import Shonkier.Semantics
9 |
10 | import Data.Foldable
11 |
12 | mapT :: RawTerm
13 | mapT = getMeATerm
14 | "{ f, [] -> [] \
15 | \ f, [x|xs] -> [f(x)|map(f, xs)] \
16 | \ }"
17 |
18 | runReaderT :: RawTerm
19 | runReaderT = getMeATerm
20 | "{ r, v -> v \
21 | \ r, {'ask() -> k} -> runReaderT(r, k(r)) \
22 | \ }"
23 |
24 | appendP :: Program
25 | appendP = getMeAProgram
26 | "append([], ys) -> ys \
27 | \append([x|xs], ys) -> [x|append(xs, ys)]"
28 |
29 | mapP :: Program
30 | mapP = getMeAProgram
31 | "map(f,[]) -> [] \
32 | \map(f,[x|xs]) -> [f(x)|map(f,xs)]"
33 |
34 | runReaderP :: Program
35 | runReaderP = getMeAProgram
36 | "runReader(,'ask): \
37 | \runReader(r,v) -> v \
38 | \runReader(r,{'ask() -> k}) -> runReader(r,k(r))"
39 |
40 | pipeP :: Program
41 | pipeP = getMeAProgram
42 | "pipe('send,'recv): \
43 | \pipe({'send(x) -> ks},{'recv() -> kr}) -> pipe(ks([]),kr(x)) \
44 | \pipe({s},v) -> v \
45 | \pipe(v,{r}) -> 'abort() "
46 |
47 |
48 | test0 :: Computation
49 | test0 =
50 | let env = mkGlobalEnv "." mempty $ fold [runReaderP, appendP]
51 | in shonkier env $ getMeATerm
52 | "runReader(['1 '2],append('ask(),'ask()))"
53 |
54 | runStateP :: Program
55 | runStateP = getMeAProgram
56 | "runState(, 'get 'put): \
57 | \runState(s, v) -> v \
58 | \runState(s, {'get() -> k}) -> runState(s, k(s)) \
59 | \runState(x, {'put(s) -> k}) -> runState(s, k([])) "
60 |
61 | semiP :: Program
62 | semiP = getMeAProgram
63 | "semi(x,y) -> y \
64 | \imes(x,y) -> x "
65 |
66 | bipperP :: Program
67 | bipperP = getMeAProgram
68 | "bipper() -> semi('send('get()),semi('put(['bip|'get()]),bipper()))"
69 |
70 | test1 :: Computation
71 | test1 =
72 | let env = mkGlobalEnv "." mempty $ fold [runStateP, pipeP, semiP, bipperP, mapP]
73 | in shonkier env $ getMeATerm
74 | "runState([],pipe(bipper(),map({x -> 'recv()},[[] [] [] []])))"
75 |
76 | string :: RawTerm
77 | string = getMeATerm "f(foo\"oulala\"foo, g(\"oula\", goo\"ou\"la\"la\"goo))"
78 |
79 | string2 :: RawTerm
80 | string2 = getMeATerm "\" \
81 | \hallo \n\
82 | \ wolrd\n\""
83 |
84 | num :: RawTerm
85 | num = getMeATerm "foo(3.4,6.75,8.25,2/3,1/4,18.000,6/4,3.400,3)"
86 | -}
87 |
--------------------------------------------------------------------------------
/src/Shonkier/Pretty/Examples.hs:
--------------------------------------------------------------------------------
1 | module Shonkier.Pretty.Examples where
2 |
3 | {-
4 | import Shonkier.Examples
5 | import Shonkier.Pretty ()
6 |
7 | import Data.Text.Prettyprint.Doc
8 | import Data.Text.Prettyprint.Doc.Render.Text
9 |
10 | import qualified Data.Text as T
11 | import qualified Data.Text.IO as TIO
12 |
13 | test :: IO ()
14 | test = TIO.putStr
15 | $ T.unlines
16 | $ fmap (renderStrict . layoutSmart defaultLayoutOptions . pretty)
17 | [ appendTest
18 | , askTest
19 | , stateTest
20 | ]
21 | -}
22 |
--------------------------------------------------------------------------------
/src/Shonkier/Pretty/Render/Pandoc.hs:
--------------------------------------------------------------------------------
1 | module Shonkier.Pretty.Render.Pandoc where
2 |
3 | import Prettyprinter hiding (Doc)
4 | import Prettyprinter.Render.Util.SimpleDocTree
5 | import Text.Pandoc.Builder
6 | import Data.Text (Text)
7 | import qualified Data.Text as T
8 |
9 | import Shonkier.Pretty
10 |
11 |
12 | class FromDoc a where
13 | render :: Doc -> a
14 |
15 | instance FromDoc Inline where
16 | render = Span ("", ["shonkier-pretty"], []) . render
17 |
18 | instance FromDoc Block where
19 | render = Div ("", ["shonkier-pretty"], []) . pure . Plain . render
20 |
21 | instance FromDoc [Inline] where
22 | render = renderTree . treeForm . layoutPretty defaultLayoutOptions
23 |
24 | renderTree :: SimpleDocTree Annotation -> [Inline]
25 | renderTree = \case
26 | STEmpty -> mempty
27 | STChar c -> pure $ Str (T.singleton c)
28 | STText _ t -> pure $ Str t
29 | STLine i -> pure LineBreak
30 | STAnn ann content -> pure $ Span ("", [renderAnn ann], []) $ renderTree content
31 | STConcat contents -> foldMap renderTree contents
32 |
33 | renderAnn :: Annotation -> Text
34 | renderAnn ann = "shonkier-" <> case ann of
35 | AnnAtom -> "atom"
36 | AnnBoolean -> "boolean"
37 | AnnError -> "error"
38 | AnnFunction -> "function"
39 | AnnKeyword -> "keyword"
40 | AnnNumeric -> "numeric"
41 | AnnOperator -> "operator"
42 | AnnPrimitive -> "primitive"
43 | AnnSplice -> "splice"
44 | AnnString -> "string"
45 |
--------------------------------------------------------------------------------
/src/Shonkier/Primitives.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ScopedTypeVariables #-}
2 |
3 | module Shonkier.Primitives where
4 |
5 | import Control.Applicative
6 |
7 | import Data.Attoparsec.Text (parseOnly)
8 |
9 | import Data.Map (singleton)
10 | import Data.Maybe (fromMaybe)
11 | import Data.Text (Text)
12 | import qualified Data.Text as T
13 |
14 | import Data.Lisp
15 | import Shonkier.Syntax
16 | import Shonkier.Value
17 | import {-# SOURCE #-} Shonkier.Semantics
18 | import Shonkier.Parser (numlit)
19 | import Shonkier.Pretty (ppRational)
20 |
21 | ---------------------------------------------------------------------------
22 | -- /!\ Do not forget to also implement the primitive in the js interpreter!
23 | ---------------------------------------------------------------------------
24 |
25 | primEnv :: GlobalEnv
26 | primEnv = foldMap toVal primitives where
27 | toVal (str, _) = singleton str $ singleton "." $ VPrim str []
28 |
29 | type PRIMITIVE = [Computation] -> Shonkier Computation
30 |
31 | prim :: Primitive -> PRIMITIVE
32 | prim nm vs = case lookup nm primitives of
33 | Nothing -> complain "NoPrim" [VPrim nm []]
34 | Just f -> f vs
35 |
36 | primitives :: [(Primitive, PRIMITIVE)]
37 | primitives =
38 | [ ("primStringConcat" , primStringConcat)
39 | , ("primPrefixNot" , primPrefixNot)
40 | , ("primInfixAnd" , primInfixAnd)
41 | , ("primInfixOr" , primInfixOr)
42 | , ("primInfixEquals" , primInfixEquals)
43 | , ("primInfixUnequal" , primInfixUnequal)
44 | , ("primInfixLessEq" , primInfixLessEq)
45 | , ("primInfixGreaterEq" , primInfixGreaterEq)
46 | , ("primInfixLess" , primInfixLess)
47 | , ("primInfixGreater" , primInfixGreater)
48 | , ("primInfixPlus" , primInfixPlus)
49 | , ("primInfixMinus" , primInfixMinus)
50 | , ("primInfixTimes" , primInfixTimes)
51 | , ("primInfixOver" , primInfixOver)
52 | , ("primNumToString" , primNumToString)
53 | , ("primStringToNum" , primStringToNum)
54 | , ("primPickle" , primPickle)
55 | , ("primUnpickle" , primUnpickle)
56 | ]
57 |
58 |
59 | ---------------------------------------------------------------------------
60 | -- EQUALS OR NOT
61 |
62 | primInfixEquals, primInfixUnequal :: PRIMITIVE
63 | primInfixEquals [Value x, Value y] = case valueEqHuh x y of
64 | Nothing -> complain "higherOrderEqTest" []
65 | Just b -> use (VBoolean b)
66 | primInfixEquals _ = complain "Invalid_primInfixEquals_Arity" []
67 |
68 | primInfixUnequal [Value x, Value y] = case valueEqHuh x y of
69 | Nothing -> complain "higherOrderEqTest" []
70 | Just b -> use (VBoolean (not b))
71 | primInfixUnequal _ = complain "Invalid_primInfixUnequal_Arity" []
72 |
73 | ---------------------------------------------------------------------------
74 | -- NUM
75 |
76 | primNumBin :: String -> (Rational -> Rational -> Rational)
77 | -> PRIMITIVE
78 | primNumBin nm op = \case
79 | [CNum m, CNum n] -> use (VNum (op m n))
80 | [Value m, Value n] -> complaining "ArgType" [m, n]
81 | [_,_] -> complaining "ArgRequest" []
82 | _ -> complaining "Arity" []
83 | where complaining str = complain (MkAtom $ "Invalid_" ++ nm ++ "_" ++ str)
84 |
85 | primInfixPlus, primInfixMinus, primInfixTimes :: PRIMITIVE
86 | primInfixPlus = primNumBin "primInfixPlus" (+)
87 | primInfixMinus = primNumBin "primInfixMinus" (-)
88 | primInfixTimes = primNumBin "primInfixTimes" (*)
89 |
90 | primInfixOver :: PRIMITIVE
91 | primInfixOver [_, CNum 0] = complain "divByZero" []
92 | primInfixOver as = primNumBin "primInfixOver" (/) as
93 |
94 | primNumToString :: PRIMITIVE
95 | primNumToString = \case
96 | [CNum m] -> use (VString "" (ppRational Utopia m))
97 | [Value m] -> complaining "ArgType" [m]
98 | [_] -> complaining "ArgRequest" []
99 | _ -> complaining "Arity" []
100 | where complaining = complain . MkAtom . ("Invalid_primNumToString_" ++)
101 |
102 | primNumBoo :: String -> (Rational -> Rational -> Bool)
103 | -> PRIMITIVE
104 | primNumBoo nm op = \case
105 | [CNum m, CNum n] -> use (VBoolean (op m n))
106 | [Value m, Value n] -> complaining "ArgType" [m, n]
107 | [_,_] -> complaining "ArgRequest" []
108 | _ -> complaining "Arity" []
109 | where complaining str = complain (MkAtom $ "Invalid_" ++ nm ++ "_" ++ str)
110 |
111 | primInfixLessEq, primInfixGreaterEq, primInfixLess, primInfixGreater :: PRIMITIVE
112 | primInfixLessEq = primNumBoo "primInfixLessEq" (<=)
113 | primInfixGreaterEq = primNumBoo "primInfixGreaterEq" (>=)
114 | primInfixLess = primNumBoo "primInfixLess" (<)
115 | primInfixGreater = primNumBoo "primInfixGreater" (>)
116 |
117 |
118 | ---------------------------------------------------------------------------
119 | -- BOOLEAN
120 |
121 | primPrefixNot :: PRIMITIVE
122 | primPrefixNot = \case
123 | [CBoolean b] -> use (VBoolean (not b))
124 | [Value n] -> complaining "ArgType" [n]
125 | [_] -> complaining "ArgRequest" []
126 | _ -> complaining "Arity" []
127 | where complaining = complain . MkAtom . ("Invalid_primPrefixNot_" ++)
128 |
129 | primBooBin :: String -> (Bool -> Bool -> Bool)
130 | -> PRIMITIVE
131 | primBooBin nm op = \case
132 | [CBoolean m, CBoolean n] -> use (VBoolean (op m n))
133 | [Value m, Value n] -> complaining "ArgType" [m, n]
134 | [_,_] -> complaining "ArgRequest" []
135 | _ -> complaining "Arity" []
136 | where complaining str = complain (MkAtom $ "Invalid_" ++ nm ++ "_" ++ str)
137 |
138 | primInfixAnd, primInfixOr :: PRIMITIVE
139 | primInfixAnd = primBooBin "primInfixAnd" (&&)
140 | primInfixOr = primBooBin "primInfixOr" (||)
141 |
142 |
143 | ---------------------------------------------------------------------------
144 | -- STRING
145 |
146 | primStringToNum :: PRIMITIVE
147 | primStringToNum = \case
148 | [CString _ s] -> case parseOnly numlit s of
149 | Left err -> complain "Invalid_primStringToNum_ParseError" [VString "" (T.pack err)]
150 | Right (Num n) -> use (VNum n)
151 | Right (Boolean b) -> complain "Invalid_primStringToNum_ValueType" [VBoolean b]
152 | [Value m] -> complain "Invalid_primStringToNum_ArgType" [m]
153 | [_] -> complain "Invalid_primStringToNum_ArgRequest" []
154 | _ -> complain "Invalid_primStringToNum_Arity" []
155 |
156 | primStringConcat :: PRIMITIVE
157 | primStringConcat cs = go cs Nothing [] where
158 |
159 | go :: [Computation] -> Maybe Keyword -> [Text] -> Shonkier Computation
160 | go cs mk ts = case cs of
161 | [] -> let txt = T.concat $ reverse ts
162 | in use (VString (fromMaybe "" mk) txt)
163 | (CString k t : cs) -> go cs (mk <|> pure k) (t:ts)
164 | (CCell a b : cs) -> go (Value a : Value b : cs) mk ts
165 | (CAtom {} : cs) -> go cs mk ts
166 | (CNil : cs) -> go cs mk ts
167 | (Value v : cs) -> complain "Invalid_StringConcat_ArgType" [v]
168 | _ -> complain "Invalid_StringConcat_ArgRequest" []
169 |
170 |
171 | ---------------------------------------------------------------------------
172 | -- PICKLING
173 |
174 | primPickle :: PRIMITIVE
175 | primPickle = \case
176 | [Value v] -> use (VString "" (lispText (toLISP v)))
177 | _ -> complain "PickleAValue" []
178 |
179 | primUnpickle :: PRIMITIVE
180 | primUnpickle = \case
181 | [Value (VString _ t)] -> case textLisp t >>= fromLISP of
182 | Just v -> use v
183 | _ -> abort
184 | _ -> complain "UnpickleAString" []
185 |
--------------------------------------------------------------------------------
/src/Shonkier/Scope.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 | {-# LANGUAGE FunctionalDependencies #-}
3 | {-# LANGUAGE FlexibleInstances #-}
4 |
5 | module Shonkier.Scope
6 | {- ( GlobalScope
7 | , checkRaw
8 | ) -} where
9 |
10 | import Control.Monad
11 | import Control.Monad.State
12 |
13 | import Data.Foldable (fold)
14 | import Data.Map (Map)
15 | import qualified Data.Map as Map
16 | import Data.Maybe (fromMaybe)
17 | import Data.Set (Set)
18 | import qualified Data.Set as Set
19 |
20 | import Shonkier.Syntax
21 |
22 | type Namespaces = Map Namespace (Set FilePath)
23 |
24 | declareNamespaces :: [Import] -> Namespaces
25 | declareNamespaces = foldr cons Map.empty where
26 | cons (fp, mns) r = case mns of
27 | Nothing -> r
28 | Just nm -> Map.insertWith Set.union nm (Set.singleton fp) r
29 |
30 | data ScopeState = ScopeState
31 | { currentFile :: FilePath
32 | , imports :: Set FilePath
33 | , namespaces :: Namespaces
34 | , globalScope :: GlobalScope
35 | }
36 |
37 | type GlobalScope = Map Variable (Set FilePath)
38 | type LocalScope = Set Variable
39 |
40 | newtype ScopeM a = ScopeM { getScopeM :: State ScopeState a }
41 | deriving ( Functor, Applicative, Monad
42 | , MonadState ScopeState)
43 |
44 | class ScopeCheck t u | t -> u where
45 | scopeCheck :: LocalScope -> t -> ScopeM u
46 |
47 | declare :: Variable -> ScopeM ()
48 | declare v = do
49 | fp <- gets currentFile
50 | let addFP = Just . Set.insert fp . fromMaybe Set.empty
51 | modify $ \ r -> r { globalScope = Map.alter addFP v (globalScope r) }
52 |
53 | evalScopeM :: ScopeM a -> ScopeState -> a
54 | evalScopeM = evalState . getScopeM
55 |
56 | checkRaw :: ScopeCheck t u
57 | => FilePath -> [Import] -> GlobalScope -> t -> u
58 | checkRaw fp is gl p =
59 | let imported = Set.fromList $ [".", fp] ++ map fst is
60 | nmspaces = declareNamespaces is
61 | initState = ScopeState fp imported nmspaces gl
62 | in evalScopeM (scopeCheck Set.empty p) initState
63 |
64 | instance ScopeCheck RawProgram Program where
65 | scopeCheck local ps = do
66 | unless (Set.null local) $
67 | error $ "*** Error: Local environment should be empty"
68 | ++ "when scope-checking a program!"
69 | mapM_ (declare . fst) ps
70 | forM ps $ \case
71 | (nm, Left decl) -> pure (nm, Left decl)
72 | (nm, Right cl) -> (nm,) . Right <$> scopeCheck local cl
73 |
74 | instance ScopeCheck RawVariable ScopedVariable where
75 | scopeCheck local (mns :.: v) = case mns of
76 | Nothing | Set.member v local -> pure $ LocalVar :.: v
77 | Just nm -> get >>= \ st -> case namespaces st Map.!? nm of
78 | Nothing -> pure $ InvalidNamespace nm :.: v
79 | Just fps -> checkGlobal True fps v
80 | _ -> get >>= \ st -> checkGlobal False (imports st) v
81 |
82 | where
83 |
84 | checkGlobal :: Bool -> Set FilePath -> Variable -> ScopeM ScopedVariable
85 | checkGlobal b scp v = do
86 | candidates <- gets (\ st -> globalScope st Map.!? v)
87 | pure $ case Set.toList . Set.intersection scp <$> candidates of
88 | Just [fp] -> GlobalVar b fp :.: v
89 | Just fps@(_:_) -> AmbiguousVar fps :.: v
90 | _ -> OutOfScope :.: v
91 |
92 | instance ScopeCheck RawTerm Term where
93 | scopeCheck local = \case
94 | Atom a -> pure (Atom a)
95 | Lit l -> pure (Lit l)
96 | Var v -> Var <$> scopeCheck local v
97 | Blank -> pure Blank
98 | Nil -> pure Nil
99 | Cell a b -> Cell <$> scopeCheck local a <*> scopeCheck local b
100 | App f ts -> App <$> scopeCheck local f <*> mapM (scopeCheck local) ts
101 | Semi l r -> Semi <$> scopeCheck local l <*> scopeCheck local r
102 | Prio l r -> Prio <$> scopeCheck local l <*> scopeCheck local r
103 | Fun hs cs -> Fun hs <$> traverse (scopeCheck local) cs
104 | String k sts u ->
105 | String k
106 | <$> traverse (traverse (scopeCheck local)) sts
107 | <*> pure u
108 | Match p t -> Match p <$> scopeCheck local t -- for now
109 | Mask a t -> Mask a <$> scopeCheck local t
110 |
111 | instance ScopeCheck RawClause Clause where
112 | scopeCheck local (ps :-> rs) = do
113 | locals <- mapM (scopeCheck local) ps
114 | let new = fold (local : locals)
115 | (ps :->) <$> traverse (scopeCheck new) rs
116 |
117 | instance ScopeCheck RawRhs Rhs where
118 | scopeCheck local (mg :?> t) =
119 | (:?>) <$> traverse (scopeCheck local) mg <*> scopeCheck local t
120 |
121 | instance ScopeCheck PComputation LocalScope where
122 | scopeCheck local (PValue v) = scopeCheck local v
123 | scopeCheck local (PRequest (a, vs) mk) = do
124 | local1 <- fold <$> mapM (scopeCheck local) vs
125 | pure $ maybe id Set.insert mk local1
126 | scopeCheck local (PThunk k) = pure $ Set.singleton k
127 |
128 | instance ScopeCheck PValue LocalScope where
129 | scopeCheck local = \case
130 | PAtom{} -> pure Set.empty
131 | PLit{} -> pure Set.empty
132 | PNil -> pure Set.empty
133 | PBind x -> pure (Set.singleton x)
134 | PWild{} -> pure Set.empty
135 | PAs x p -> Set.insert x <$> scopeCheck local p
136 | PCell p q -> (<>) <$> scopeCheck local p <*> scopeCheck local q
137 | PString _ sps _ ->
138 | foldMap snd <$> traverse (traverse (scopeCheck local)) sps
139 |
--------------------------------------------------------------------------------
/src/Shonkier/Semantics.hs-boot:
--------------------------------------------------------------------------------
1 | module Shonkier.Semantics where
2 |
3 | import Shonkier.Syntax
4 | import Shonkier.Value
5 |
6 | use :: Value -> Shonkier Computation
7 | handle :: Request -> Continuation -> Shonkier Computation
8 | complain :: Atom -> [Value] -> Shonkier Computation
9 | abort :: Shonkier Computation
--------------------------------------------------------------------------------
/src/Shonkier/Shonkier.html:
--------------------------------------------------------------------------------
1 |
2 |
3 | Shonkier Tests
4 |
5 |
6 |
7 | ShonkierTests
8 |
9 |
10 |
11 |
12 |
16 |
17 |
18 | Last modified: Thu Mar 12 16:14:18 GMT 2020
19 |
20 |
--------------------------------------------------------------------------------
/src/Shonkier/ShonkierJS.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, LambdaCase #-}
2 |
3 | module Shonkier.ShonkierJS where
4 |
5 | import Data.Char
6 | import Data.Text (Text, pack)
7 | import qualified Data.Text as T
8 | import Data.List
9 | import Data.Ratio
10 | import Data.Map (Map, foldMapWithKey)
11 |
12 | import Shonkier.Syntax
13 | import Shonkier.Value
14 |
15 | class JSAtom a where
16 | jsAtom :: a -> Text
17 |
18 | instance JSAtom String where
19 | jsAtom a = T.concat ["\"",pack a,"\""]
20 |
21 | instance JSAtom Atom where
22 | jsAtom = jsAtom . getAtom
23 |
24 | class JS t where
25 | js :: t -> [Text]
26 |
27 | instance JS Text where
28 | js t = [t]
29 |
30 | instance JS a => JS [a] where
31 | js as = ["["] ++ Data.List.intercalate [","] (fmap js as) ++ ["]"]
32 |
33 | instance JS Scoping where
34 | js = \case
35 | LocalVar -> ["LocalVar()"]
36 | GlobalVar b fp -> ["GlobalVar("] ++ js b ++ [",", jsAtom fp, ")"]
37 | AmbiguousVar _ -> ["AmbiguousVar()"]
38 | OutOfScope -> ["OutOfScope()"]
39 | InvalidNamespace _ -> ["InvalidNamespace()"]
40 |
41 | instance JS ScopedVariable where
42 | js (sco :.: x) = ["Var("] ++ js sco ++ [",", jsAtom x, ")"]
43 |
44 | instance (JSAtom a, JS v, Atomy a, Vary v) => JS (Clause' a v) where
45 | js (qs :-> rs) = ["Clause("] ++ js qs ++ [","] ++ js (rhs2Term rs) ++ [")"] where
46 |
47 | instance (JSAtom a, JS v, Atomy a, Vary v) => JS (Term' a v) where
48 | js (Atom a) = ["Atom(", jsAtom a, ")"]
49 | js (Lit l) = ["Lit("] ++ js l ++ [")"]
50 | js (String _ ts u) = ["Stringy("] ++ jsStringy ts u ++ [")"] where
51 | js (Var x) = js x
52 | js Nil = ["Nil()"]
53 | js Blank = ["undefined"]
54 | js (Cell s t) = ["Cell("] ++ js s ++ [","] ++ js t ++ [")"]
55 | js (App f as) = ["App("] ++ js f ++ [","] ++ js as ++ [")"]
56 | js (Semi l r) = ["Semi("] ++ js l ++ [","] ++ js r ++ [")"]
57 | js (Prio l r) = ["Prio("] ++ js l ++ [","] ++ js r ++ [")"]
58 | js (Fun hs cs) = ["Fun("] ++ js (fmap (fmap jsAtom) hs) ++ [","]
59 | ++ js (braceFun cs)
60 | ++ [")"]
61 | js (Match p t) = ["Match("] ++ js p ++ [","] ++ js t ++ [")"]
62 | js (Mask a t) = ["Mask(", jsAtom a, ","] ++ js t ++ [")"]
63 |
64 | instance JS Literal where
65 | js (Num r) = [ "LitNum(",pack (show (numerator r))
66 | ,",", pack (show (denominator r)),")"
67 | ]
68 | js (Boolean b) = js b
69 |
70 | instance JS Bool where
71 | js True = ["true"]
72 | js False = ["false"]
73 |
74 | instance JSAtom a => JS (PComputation' a) where
75 | js (PValue p) = ["Value("] ++ js p ++ [")"]
76 | js (PRequest (a, ps) k) = ["Request(", jsAtom a]
77 | ++ [","] ++ js ps
78 | ++ [","] ++ ["\"", maybe "_" pack k, "\")"]
79 | js (PThunk x) = ["\"",pack x,"\""]
80 |
81 | instance JSAtom a => JS (PValue' a) where
82 | js (PAtom a) = ["Atom(", jsAtom a, ")"]
83 | js (PLit l) = ["Lit("] ++ js l ++ [")"]
84 | js (PString _ ts u) = ["Stringy("] ++ jsStringy ts u ++ [")"] where
85 | js (PBind x) = ["\"",pack x,"\""]
86 | js (PAs x p) = ["PAs("] ++ ["\"",pack x,"\""]
87 | ++ [","] ++ js p ++ [")"]
88 | js PNil = ["Nil()"]
89 | js (PCell s t) = ["Cell("] ++ js s ++ [","] ++ js t ++ [")"]
90 | js PWild = ["PWild"]
91 |
92 | jsText :: Text -> [Text]
93 | jsText t
94 | | T.any (\ z -> z `elem` ['"', '\\'] || isControl z) t = [T.pack (show t)]
95 | | otherwise = ["\"", t, "\""]
96 |
97 | jsStringy :: JS x => [(Text, x)] -> Text -> [Text]
98 | jsStringy [] u = jsText u
99 | jsStringy ((t, x) : txs) u =
100 | ["Strunk("] ++ jsText t ++ [","] ++ js x ++ [","] ++ jsStringy txs u ++ [")"]
101 |
102 | jsInputs :: Map Text Text -> [Text]
103 | jsInputs inp =
104 | "var inputs = {};\n" :
105 | ((`foldMapWithKey` inp) $ \ field val ->
106 | pure $ T.concat $ ["inputs["] ++
107 | jsText field ++
108 | ["] = "] ++
109 | jsText val ++
110 | [";\n"])
111 |
112 | jsGlobalEnv :: GlobalEnv -> [Text]
113 | jsGlobalEnv gl =
114 | "var globalEnv = {};\n" :
115 | ((`foldMapWithKey` gl) $ \ x loc ->
116 | ((T.concat [ "globalEnv[", jsAtom x, "] = {};\n"]) :) $
117 | flip foldMapWithKey loc $ \ fp -> \case
118 | VFun CnNil _ hs cs -> pure $ T.concat $
119 | ["globalEnv[", jsAtom x, "][", jsAtom fp ,"] = VFun(null,{},"]
120 | ++ js (fmap (fmap jsAtom) hs) ++ [","]
121 | ++ js cs
122 | ++ [");\n"]
123 | VPrim g hs -> pure $ T.concat $
124 | ["globalEnv[", jsAtom x, "][", jsAtom fp, "] = VPrim(", jsAtom g , ","]
125 | ++ js (fmap (fmap jsAtom) hs)
126 | ++ [");\n"]
127 | _ -> [])
128 |
129 | jsRun :: Term -> [Text]
130 | jsRun t = [ "console.log(render(shonkier(globalEnv,inputs,"] ++ js t ++ [")));"]
131 |
--------------------------------------------------------------------------------
/src/Utils/List.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ConstraintKinds #-}
2 |
3 | module Utils.List where
4 |
5 | import Control.Arrow
6 |
7 | padCat :: Eq a => [[a]] -> [[a]] -> [[a]]
8 | padCat [] hs = hs
9 | padCat hs [] = hs
10 | padCat (a : as) (b : bs) = (a ++ b) : padCat as bs
11 |
12 | mayZipWith :: (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c]
13 | mayZipWith f [] [] = pure []
14 | mayZipWith f (a : as) (b : bs) =
15 | (:) <$> f a b <*> mayZipWith f as bs
16 | mayZipWith _ _ _ = Nothing
17 |
18 | data ListView a la
19 | = ItsNil
20 | | ItsCons a la
21 | | ItsNot
22 |
23 | class HasListView a la where
24 |
25 | coalgebra :: la -> ListView a la
26 |
27 | listView :: la -> ([a], Maybe la)
28 | listView seed = case coalgebra seed of
29 | ItsNil -> ([], Nothing)
30 | ItsCons x xs -> first (x :) $ listView xs
31 | ItsNot -> ([], Just seed)
32 |
33 | type SelfListView la = HasListView la la
34 |
35 | longestCommonPrefix :: Eq a => [[a]] -> [a]
36 | longestCommonPrefix [] = []
37 | longestCommonPrefix lists = foldr1 commonPrefix lists
38 | where
39 | commonPrefix :: Eq a => [a] -> [a] -> [a]
40 | commonPrefix (x:xs) (y:ys) | x == y = x : commonPrefix xs ys
41 | commonPrefix _ _ = []
42 |
--------------------------------------------------------------------------------
/src/data-dir/shonkier.css:
--------------------------------------------------------------------------------
1 | .shonkier-pretty {
2 | display: block;
3 | font-family: monospace;
4 | white-space: nowrap;
5 | }
6 |
7 | /*
8 | We use the same color as the emacs mode.
9 | See http://www.raebear.net/computers/emacs-colors/ for a conversion table.
10 | */
11 |
12 | .shonkier-pretty .shonkier-atom {
13 | color: #008b8b;
14 | }
15 |
16 | .shonkier-pretty .shonkier-boolean {
17 | color: #008b8b;
18 | }
19 |
20 | .shonkier-pretty .shonkier-error {
21 | background-color: red;
22 | }
23 |
24 | .shonkier-pretty .shonkier-function {
25 | color: #0000ff;
26 | }
27 |
28 | .shonkier-pretty .shonkier-keyword {
29 | color: #a020f0;
30 | }
31 |
32 | .shonkier-pretty .shonkier-numeric {
33 | color: #008b8b;
34 | }
35 |
36 | .shonkier-pretty .shonkier-operator {
37 | color: #483d8b;
38 | }
39 |
40 | .shonkier-pretty .shonkier-primitive {
41 | color: #483d8b;
42 | }
43 |
44 | .shonkier-pretty .shonkier-splice {
45 | color: black;
46 | }
47 |
48 | .shonkier-pretty .shonkier-string {
49 | color: #8b2252;
50 | }
51 |
--------------------------------------------------------------------------------
/templates/mary.html5:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | $for(author-meta)$
8 |
9 | $endfor$
10 | $if(date-meta)$
11 |
12 | $endif$
13 | $if(keywords)$
14 |
15 | $endif$
16 | $if(title-prefix)$$title-prefix$ – $endif$$pagetitle$
17 |
18 | $for(css)$
19 |
20 | $endfor$
21 | $if(math)$
22 | $math$
23 | $endif$
24 |
27 | $for(header-includes)$
28 | $header-includes$
29 | $endfor$
30 |
31 | $if(jsGlobalEnv)$
32 |
35 | $endif$
36 | $if(jsInputs)$
37 |
40 | $endif$
41 |
42 |
43 |
44 |
61 |
62 |
63 |
--------------------------------------------------------------------------------
/test/Test/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Test.Mary
4 | import Test.Shonkier
5 |
6 | import Test.Tasty (testGroup)
7 | import Test.Tasty.Silver.Interactive
8 |
9 | main :: IO ()
10 | main = defaultMain . testGroup "Tests" =<< sequence
11 | [ shonkierTests
12 | , shonkierJSTests
13 | , maryTests
14 | ]
15 |
--------------------------------------------------------------------------------
/test/Test/Mary.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Test.Mary where
3 |
4 | import Data.List as L
5 | import Data.Text (Text)
6 | import qualified Data.Text as T
7 |
8 | import Data.Semigroup ((<>)) -- needed for ghc versions <= 8.2.2
9 |
10 | import Test.Utils
11 | import Test.Tasty (TestTree)
12 |
13 | import System.Directory
14 | import System.FilePath
15 |
16 | import Data.Text.IO as TIO
17 |
18 | import Mary.ServePage
19 |
20 | testConfig :: Config
21 | testConfig = Config
22 | { mary = "mary"
23 | , pandoc = "pandoc"
24 | , user = Just "testymctestyface"
25 | , baseURL = "https://personal.cis.strath.ac.uk/conor.mcbride/shib/Mary/"
26 | , siteRoot = "."
27 | }
28 |
29 | -- POST and GET data for test file FILE.mary can be supplied as
30 | -- url-encoded strings on the first two lines of FILE.input
31 |
32 | maryRunner :: FilePath -> IO Text
33 | maryRunner inp = do
34 | let page = case L.stripPrefix (siteRoot testConfig <> "/") inp of
35 | Just p -> T.pack p
36 | Nothing -> error "Trying to get page outside of siteRoot"
37 | let inputFile = replaceExtension inp ".input"
38 | inputExists <- doesFileExist inputFile
39 | (post:get:_) <- if inputExists then
40 | map parseRequests . T.lines <$> TIO.readFile inputFile
41 | else pure [[],[]]
42 | servePage testConfig post (("page", page):get) inp
43 |
44 | maryTests :: IO TestTree
45 | maryTests = do
46 | let name = "Mary"
47 | let extension = ".mary"
48 | let goldenExt = ".html"
49 | ioTests TestConfig{..} maryRunner
50 | -- excluded tests
51 | []
52 |
--------------------------------------------------------------------------------
/test/Test/Shonkier.hs:
--------------------------------------------------------------------------------
1 | module Test.Shonkier where
2 |
3 | import Data.Text (Text)
4 | import qualified Data.Text as T
5 | import qualified Data.Text.IO as TIO
6 |
7 | import System.Process
8 |
9 | import Test.Tasty (TestTree)
10 | import Test.Utils
11 |
12 | shonkier :: FilePath -> IO Text
13 | shonkier inp = T.pack <$> readProcess "mary" ["shonkier", inp] ""
14 |
15 | shonkierTests :: IO TestTree
16 | shonkierTests = do
17 | let name = "Shonkier"
18 | let extension = ".shonkier"
19 | let goldenExt = ".gold"
20 | ioTests TestConfig{..} shonkier
21 | -- excluded tests:
22 | []
23 |
24 | shonkierJS :: FilePath -> IO Text
25 | shonkierJS inp =
26 | withCreateProcess ((proc "mary" ["shonkierjs", inp])
27 | { std_out = CreatePipe
28 | }) $ \ _ (Just hmary) _ _ ->
29 | withCreateProcess ((proc "node" ["-"])
30 | { std_in = UseHandle hmary
31 | , std_out = CreatePipe
32 | }) $ \ _ (Just hout) _ _ ->
33 | TIO.hGetContents hout
34 |
35 | shonkierJSTests :: IO TestTree
36 | shonkierJSTests = do
37 | let name = "ShonkierJS"
38 | let extension = ".shonkier"
39 | let goldenExt = ".jsgold"
40 | ioTests TestConfig{..} shonkierJS $
41 | -- excluded tests:
42 | fmap (\ t -> "./examples/" ++ t ++ ".shonkier")
43 | []
44 |
--------------------------------------------------------------------------------
/test/Test/Utils.hs:
--------------------------------------------------------------------------------
1 | module Test.Utils where
2 |
3 | import Control.Monad
4 |
5 | import Data.List ((\\))
6 | import Data.Text (Text)
7 | import qualified Data.Text as T
8 | import qualified Data.Text.IO as TIO
9 |
10 | import System.Directory
11 | import System.FilePath
12 | import System.Process
13 |
14 | import Test.Tasty (TestTree, testGroup)
15 | import Test.Tasty.Silver
16 | import Test.Tasty.Silver.Advanced
17 |
18 | textDiff :: Text -> Text -> GDiff
19 | textDiff s t
20 | | s == t = Equal
21 | | otherwise = DiffText Nothing s t
22 |
23 | data TestConfig = TestConfig
24 | { name :: String
25 | , extension :: String
26 | , goldenExt :: String
27 | }
28 |
29 | ioTests :: TestConfig -> (FilePath -> IO Text) -> [FilePath] -> IO TestTree
30 | ioTests TestConfig{..} getVal excluded = testGroup name <$> do
31 | files <- findByExtension [extension] "."
32 | forM (files \\ excluded) $ \ file -> do
33 | let base = dropExtension file
34 | let name = takeBaseName file
35 | let sed = addExtension base ".sed"
36 | let gold = addExtension base goldenExt
37 | let getGolden = do
38 | exists <- doesFileExist gold
39 | if exists then Just <$> TIO.readFile gold
40 | else pure Nothing
41 | let runTest = do
42 | val <- getVal file
43 | exists <- doesFileExist sed
44 | if not exists then pure val else do
45 | ops <- lines <$> readFile sed
46 | T.pack <$> readProcess "sed" ops (T.unpack val)
47 | let updGolden = TIO.writeFile gold
48 | pure $ goldenTest1 name getGolden runTest textDiff ShowText updGolden
49 |
--------------------------------------------------------------------------------