├── .github └── workflows │ └── gh-pages.yml ├── .gitignore ├── .ocamlformat ├── LICENSE.md ├── Makefile ├── README.md ├── dune-project ├── etc └── aeff-mode.el ├── examples ├── cancellableCall.aeff ├── cancellableCallFunPayload.aeff ├── feed.aeff ├── handleFirstThreeInterrupts.aeff ├── heapPure.aeff ├── heapRef.aeff ├── preemptive.aeff ├── processWith.aeff ├── remoteCall.aeff ├── remoteCallFunPayload.aeff ├── runner.aeff └── ticktock.aeff ├── src ├── aeff │ ├── aeff.ml │ └── dune ├── core │ ├── ast.ml │ ├── builtIn.ml │ ├── const.ml │ ├── desugarer.ml │ ├── dune │ ├── interpreter.ml │ ├── lexer.mll │ ├── loader.ml │ ├── parser.mly │ ├── stdlib.aeff │ ├── syntax.ml │ └── typechecker.ml ├── utils │ ├── dune │ ├── error.ml │ ├── list.ml │ ├── location.ml │ ├── option.ml │ ├── print.ml │ └── symbol.ml └── webInterface │ ├── dune │ ├── model.ml │ ├── redexSelectorTM.ml │ ├── view.ml │ └── webInterface.ml ├── tests ├── async.aeff ├── dune ├── run_tests.t ├── select.aeff ├── spawnProcess.aeff ├── spawnSimple.aeff └── theGoodTheBadAndTheUgly.aeff └── web └── index.html /.github/workflows/gh-pages.yml: -------------------------------------------------------------------------------- 1 | name: github pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | 8 | jobs: 9 | deploy: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v2 13 | 14 | - name: Setup OCaml 15 | uses: avsm/setup-ocaml@v1 16 | 17 | - name: Install Opam packages 18 | run: opam install menhir ocaml-vdom ocamlformat=0.25.1 19 | 20 | - name: Build 21 | run: opam exec -- make release 22 | 23 | - name: Deploy 24 | uses: peaceiris/actions-gh-pages@v3 25 | with: 26 | github_token: ${{ secrets.GITHUB_TOKEN }} 27 | publish_dir: ./web 28 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | _build 3 | aeff.exe 4 | .devcontainer 5 | .vscode 6 | .merlin 7 | web/webInterface.bc.js 8 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = default 2 | version = 0.25.1 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020-2021 Matija Pretnar and Danel Ahman 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 6 | 7 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 10 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | default: format 2 | dune build 3 | 4 | format: 5 | dune build @fmt --auto-promote 6 | 7 | release: format 8 | dune build --profile release 9 | 10 | clean: 11 | dune clean 12 | 13 | test: 14 | dune runtest 15 | 16 | .PHONY: default format release clean test 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Æff 2 | 3 | Install dependencies by 4 | 5 | opam install menhir ocaml-vdom ocamlformat 6 | 7 | and build Æff by running (requires OCaml >= 4.08.0) 8 | 9 | make 10 | 11 | and you can clean up by running 12 | 13 | make clean 14 | 15 | Æff gives you two options to run programs: 16 | 17 | - The first option is a web interface, 18 | accessible at `web/index.html`, which allows you to load one of the built-in 19 | examples or enter your own program, and then interactively click through all its 20 | (non-deterministic and asynchronous) reductions or introduce external interrupts. 21 | 22 | - The second option is a command line executable run as 23 | 24 | ./aeff.exe file1.aeff file2.aeff ... 25 | 26 | which loads all the commands in all the listed files and starts evaluating the 27 | given program, displaying all outgoing signals and the terminal configuration 28 | (if there is one). Non-deterministic reductions are chosen randomly and there is 29 | no option of introducing external interrupts. If you do not want to load the 30 | standard library, run Æff with the `--no-stdlib` option. 31 | 32 | ## Acknowledgements 33 | 34 | 35 | 36 | 37 |
This project has received funding from the European Union’s Horizon 2020 research and innovation programme under the Marie Skłodowska-Curie grant agreement No 834146.
This material is based upon work supported by the Air Force Office of Scientific Research under awards number FA9550-17-1-0326 and FA9550-21-1-0024.
38 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (using menhir 2.1) 3 | (cram enable) 4 | -------------------------------------------------------------------------------- /etc/aeff-mode.el: -------------------------------------------------------------------------------- 1 | ; Emacs mode for Æff, derived from OCaml tuareg-mode. 2 | ; 3 | ; This code could be much improved. 4 | ; 5 | ; To use the aeff-mode, put this file somewhere and add something like the following 6 | ; in your .emacs file: 7 | ; 8 | ; (autoload 'aeff-mode "/etc/aeff-mode" "Major mode for editing Æff files" t) 9 | ; (setq auto-mode-alist (cons '("\\.aeff$" . aeff-mode) auto-mode-alist)) 10 | 11 | (defvar aeff-keywords 12 | '( 13 | "and" 14 | "as" 15 | "await" 16 | "else" 17 | "end" 18 | "fun" 19 | "if" 20 | "in" 21 | "let" 22 | "match" 23 | "of" 24 | "operation" 25 | "promise" 26 | "rec" 27 | "return" 28 | "run" 29 | "send" 30 | "then" 31 | "to" 32 | "type" 33 | "until" 34 | "use" 35 | "using" 36 | "val" 37 | "when" 38 | "with" 39 | )) 40 | 41 | (defvar aeff-constants 42 | '( 43 | "false" 44 | "true" 45 | )) 46 | 47 | (defvar aeff-types 48 | '( 49 | "bool" 50 | "empty" 51 | "int" 52 | "list" 53 | "string" 54 | "unit" 55 | )) 56 | 57 | (defvar aeff-font-lock-defaults 58 | `(( 59 | ;; stuff between " 60 | ("\"\\.\\*\\?" . font-lock-string-face) 61 | ;; prefix and infix operators, can be improved 62 | ("+\\|,\\|;" . font-lock-keyword-face) 63 | ( ,(regexp-opt aeff-keywords 'symbols) . font-lock-keyword-face) 64 | ( ,(regexp-opt aeff-types 'symbols) . font-lock-type-face) 65 | ( ,(regexp-opt aeff-constants 'symbols) . font-lock-constant-face) 66 | ;; highlighting signal/interrupt/operation names, can be much improved 67 | ("operation[ ]+\\([a-zA-Z0-9]+?\\) :" . (1 font-lock-builtin-face)) 68 | ("promise[ ]+(\\([ ]*[a-zA-Z0-9]+?\\) " . (1 font-lock-builtin-face)) 69 | ("send[ ]+\\([a-zA-Z0-9]+?\\) " . (1 font-lock-builtin-face)) 70 | ))) 71 | 72 | (define-derived-mode aeff-mode 73 | tuareg-mode 74 | "Æff" 75 | "Major mode for Æff (rudimentary)." 76 | 77 | (setq font-lock-defaults aeff-font-lock-defaults) 78 | 79 | (setq prettify-symbols-alist '(("send" . ?↑) 80 | ("<<" . ?⟨) 81 | (">>" . ?⟩) 82 | ("->" . ?→) 83 | ("->" . ?→))) 84 | ) 85 | 86 | (provide 'aeff-mode) 87 | 88 | (add-hook 'aeff-mode-hook 'prettify-symbols-mode) -------------------------------------------------------------------------------- /examples/cancellableCall.aeff: -------------------------------------------------------------------------------- 1 | operation call : int * int 2 | operation result : int * int 3 | operation cancel : int 4 | operation impossible : empty 5 | 6 | let callWith callCounter = 7 | fun x -> 8 | let callNo = !callCounter in 9 | send call (x, callNo); 10 | callCounter := callNo + 1; 11 | let p = promise (result (y, callNo') when callNo = callNo' -> 12 | return <> 13 | ) in 14 | let valueThunk () = await p in 15 | let cancelThunk () = send cancel callNo in 16 | let changeMind x = cancelThunk (); send call (x, callNo) in 17 | return (valueThunk, cancelThunk, changeMind) 18 | 19 | let remote f = 20 | promise (call (x, callNo) r -> 21 | spawn ( 22 | promise (cancel callNo' impossibleR when callNo = callNo' -> 23 | let impossiblePromise = promise (impossible empty -> return <>) in 24 | await impossiblePromise; 25 | impossibleR () 26 | ); 27 | let y = (unbox f) x in 28 | send result (y, callNo) 29 | ); 30 | r () 31 | ) 32 | 33 | run 34 | let callCounter = ref 0 in 35 | let result1, cancel1, changeMind1 = callWith callCounter 1 in 36 | let result2, cancel2, changeMind2 = callWith callCounter 2 in 37 | cancel1 (); 38 | let result3, cancel3, changeMind3 = callWith callCounter 3 in 39 | changeMind3 (result2 ()); 40 | result3 () 41 | 42 | run 43 | remote [| fun x -> 4 * (5 * (6 * x)) |] 44 | -------------------------------------------------------------------------------- /examples/cancellableCallFunPayload.aeff: -------------------------------------------------------------------------------- 1 | operation call : [| unit -> unit |] 2 | operation result : int * int 3 | operation cancel : int 4 | operation impossible : empty 5 | 6 | let waitForCancel callNo = 7 | promise (cancel callNo' when callNo = callNo' -> 8 | let p = promise (impossible empty -> return <<()>>) in 9 | await p; 10 | return <<()>> 11 | ) 12 | 13 | let remoteCall callCounter f = 14 | let callNo = !callCounter in callCounter := !callCounter + 1; 15 | let task = [| fun _ -> waitForCancel callNo; 16 | let g = unbox f in 17 | let res = g () in 18 | send result (res, callNo) |] in 19 | send call task; 20 | let resultPromise = promise (result (y, callNo') when callNo = callNo' -> return <>) in 21 | let valueThunk () = await resultPromise in 22 | let cancelThunk () = send cancel callNo in 23 | (valueThunk, cancelThunk) 24 | 25 | let remote () = 26 | promise (call boxedTask r -> 27 | spawn ((unbox boxedTask) ()); 28 | r() 29 | ) 30 | 31 | run 32 | let callCounter = ref 0 in 33 | let xt, xc = remoteCall callCounter [| fun _ -> 1 * 2 * 3 |] in 34 | let yt, yc = remoteCall callCounter [| fun _ -> 4 * 5 * 6 |] in 35 | yc(); 36 | let zt, zc = remoteCall callCounter [| fun _ -> 7 * 8 * 9 |] in 37 | return xt () + zt () 38 | 39 | run 40 | remote () 41 | -------------------------------------------------------------------------------- /examples/feed.aeff: -------------------------------------------------------------------------------- 1 | operation request : int 2 | operation response : int list 3 | operation nextItem : unit 4 | operation display : string 5 | operation batchSizeRequest : unit 6 | operation batchSizeResponse : int 7 | 8 | 9 | let client () = 10 | let cachedData = ref [] in 11 | let requestInProgress = ref false in 12 | 13 | send batchSizeRequest (); 14 | let batchSizePromise = promise (batchSizeResponse batchSize -> return <>) in 15 | 16 | let requestNewData offset = 17 | requestInProgress := true; 18 | send request offset; 19 | promise (response newBatch -> 20 | cachedData := !cachedData @ newBatch; 21 | requestInProgress := false; 22 | return <<()>>); 23 | () 24 | in 25 | 26 | let clientLoop batchSize = 27 | promise (nextItem () r currentItem -> 28 | let cachedSize = length !cachedData in 29 | if (currentItem > cachedSize - batchSize / 2) && (not !requestInProgress) then 30 | requestNewData (cachedSize + 1); 31 | r currentItem 32 | else if (currentItem) < cachedSize then 33 | send display (toString (nth !cachedData currentItem)); 34 | r (currentItem + 1) 35 | else 36 | (send display "please wait a bit and try again"; r currentItem)) at 0 37 | in 38 | 39 | let batchSize = await batchSizePromise in 40 | clientLoop batchSize 41 | 42 | let server batchSize = 43 | promise (batchSizeRequest () r -> 44 | send batchSizeResponse batchSize; 45 | r ()); 46 | promise (request offset r -> 47 | let payload = map (fun x -> 10 * x) (range offset (offset + batchSize - 1)) in 48 | send response payload; 49 | r ()) 50 | 51 | 52 | let rec user n = 53 | if n > 0 then 54 | let rec wait n = 55 | if n = 0 then return () else wait (n - 1) 56 | in 57 | send nextItem (); 58 | wait 10; 59 | user (n - 1) 60 | else 61 | () 62 | 63 | 64 | run (server 42) 65 | run (client ()) 66 | run (user 42) 67 | -------------------------------------------------------------------------------- /examples/handleFirstThreeInterrupts.aeff: -------------------------------------------------------------------------------- 1 | operation request : int 2 | operation response : int 3 | 4 | run 5 | promise (request x r s -> 6 | if s > 0 then 7 | send response (x + 42); 8 | r (s - 1) 9 | else 10 | return <<()>> 11 | ) at 3 12 | 13 | run 14 | send request 1; 15 | send request 2; 16 | send request 3; 17 | send request 4; 18 | send request 5 19 | -------------------------------------------------------------------------------- /examples/heapPure.aeff: -------------------------------------------------------------------------------- 1 | type loc = int 2 | type val = int 3 | 4 | type payloadRec = 5 | | LookupReq of loc 6 | | UpdateReq of loc * int 7 | | AllocReq of val 8 | 9 | type payloadRes = 10 | | LookupRes of int 11 | | UpdateRes of unit 12 | | AllocRes of loc 13 | 14 | operation opReq : payloadRec * int 15 | operation opRes : payloadRes * int 16 | 17 | let empty = [] 18 | 19 | let rec lookupHeap ((l', v) :: heap') l = 20 | if l = l' then v else lookupHeap heap' l 21 | 22 | let rec updateHeap ((l', v') :: heap') l v = 23 | if l = l' then (l, v) :: heap' else (l', v') :: updateHeap heap' l v 24 | 25 | let allocHeap heap v = 26 | let l = length heap in 27 | (l, v) :: heap, l 28 | 29 | let heapRunner initialHeap = 30 | promise (opReq (reqPayload, callNo) r heap -> 31 | let heap', resPayload = 32 | match reqPayload with 33 | | LookupReq l -> 34 | let v = lookupHeap heap l in 35 | return (heap, LookupRes v) 36 | | UpdateReq (l, v) -> 37 | let heap' = updateHeap heap l v in 38 | return (heap', UpdateRes ()) 39 | | AllocReq v -> 40 | let heap', l = allocHeap heap v in 41 | return (heap', AllocRes l) 42 | in 43 | send opRes (resPayload, callNo); 44 | r heap' 45 | ) at initialHeap 46 | 47 | let callWith callCounter x = 48 | let callNo = !callCounter in 49 | send opReq (x, callNo); 50 | callCounter := callNo + 1; 51 | let p = promise (opRes (y, callNo') when callNo = callNo' -> 52 | return <> 53 | ) in await p 54 | 55 | let lookup callCounter l = 56 | match callWith callCounter (LookupReq l) with LookupRes v -> return v 57 | let update callCounter l v = 58 | match callWith callCounter (UpdateReq (l, v)) with UpdateRes () -> return () 59 | let alloc callCounter v = 60 | match callWith callCounter (AllocReq v) with AllocRes l -> return l 61 | 62 | run 63 | let callCounter = ref 0 in 64 | let l = alloc callCounter 0 in 65 | let l' = alloc callCounter 10 in 66 | update callCounter l 10; 67 | update callCounter l' (lookup callCounter l + 4); 68 | return (lookup callCounter l, lookup callCounter l') 69 | 70 | run 71 | heapRunner [] 72 | -------------------------------------------------------------------------------- /examples/heapRef.aeff: -------------------------------------------------------------------------------- 1 | type callId = int 2 | type loc = int 3 | type val = int 4 | 5 | operation lookupReq : loc * callId 6 | operation updateReq : loc * val * callId 7 | operation allocReq : val * callId 8 | 9 | operation lookupRes : val * callId 10 | operation updateRes : callId 11 | operation allocRes : loc * callId 12 | 13 | let empty = [] 14 | 15 | let rec lookupHeap ((l', v) :: heap') l = 16 | if l = l' then v else lookupHeap heap' l 17 | 18 | let rec updateHeap ((l', v') :: heap') l v = 19 | if l = l' then (l, v) :: heap' else (l', v') :: updateHeap heap' l v 20 | 21 | let allocHeap heap v = 22 | let l = length heap in 23 | (l, v) :: heap, l 24 | 25 | let heapRunner () = 26 | let heap = ref empty in 27 | let awaitLookup () = 28 | promise (lookupReq (l, callId) r -> 29 | let v = lookupHeap !heap l in 30 | send lookupRes (v, callId); 31 | r () 32 | ) 33 | in 34 | let awaitUpdate () = 35 | promise (updateReq (l, v, callId) r -> 36 | let heap' = updateHeap !heap l v in 37 | send updateRes callId; 38 | heap := heap'; 39 | r () 40 | ) 41 | in 42 | let awaitAlloc () = 43 | promise (allocReq (v, callId) r -> 44 | let heap', l = allocHeap !heap v in 45 | send allocRes (l, callId); 46 | heap := heap'; 47 | r () 48 | ) 49 | in 50 | awaitLookup (); 51 | awaitUpdate (); 52 | awaitAlloc () 53 | 54 | let lookup callCounter l = 55 | let callNo = !callCounter in 56 | send lookupReq (l, callNo); 57 | callCounter := callNo + 1; 58 | let p = promise (lookupRes (v, callNo') when callNo = callNo' -> 59 | return <> 60 | ) in await p 61 | 62 | let update callCounter l v = 63 | let callNo = !callCounter in 64 | send updateReq (l, v, callNo); 65 | callCounter := callNo + 1; 66 | let p = promise (updateRes (callNo') when callNo = callNo' -> 67 | return <<()>> 68 | ) in await p 69 | 70 | let alloc callCounter v = 71 | let callNo = !callCounter in 72 | send allocReq (v, callNo); 73 | callCounter := callNo + 1; 74 | let p = promise (allocRes (l, callNo') when callNo = callNo' -> 75 | return <> 76 | ) in await p 77 | 78 | run 79 | let callCounter = ref 0 in 80 | let l = alloc callCounter 0 in 81 | let l' = alloc callCounter 10 in 82 | update callCounter l 10; 83 | update callCounter l' (lookup callCounter l + 4); 84 | return (lookup callCounter l, lookup callCounter l') 85 | 86 | run 87 | heapRunner () 88 | -------------------------------------------------------------------------------- /examples/preemptive.aeff: -------------------------------------------------------------------------------- 1 | operation stop : int 2 | operation go : int 3 | 4 | let waitForStop threadID = 5 | promise (stop threadID' r when threadID = threadID' -> 6 | let p = promise (go threadID' when threadID = threadID' -> return <<()>>) in 7 | await p; 8 | r () 9 | ) 10 | 11 | run 12 | waitForStop 1; 1 + 1 + 1 + 1 + 1 13 | 14 | run 15 | waitForStop 2; 10 + 10 + 10 + 10 + 10 16 | -------------------------------------------------------------------------------- /examples/processWith.aeff: -------------------------------------------------------------------------------- 1 | operation listInterrupt : int list 2 | operation productSignal : int 3 | 4 | let processWith p comp cont = 5 | let q = promise (listInterrupt _ -> 6 | let x = await p in 7 | let y = comp x in 8 | return <>) in 9 | cont q 10 | 11 | run 12 | let p = promise (listInterrupt is -> return <>) in 13 | processWith p (filter (fun i -> i > 0)) (fun q -> 14 | processWith q (foldLeft (fun j j' -> j * j') 1) (fun r -> 15 | processWith r (fun k -> send productSignal k) (fun _ -> 16 | (fun _ -> return r) () 17 | ))) 18 | 19 | run 20 | send listInterrupt [-3;-2;-1;0;1;2;3] 21 | 22 | -------------------------------------------------------------------------------- /examples/remoteCall.aeff: -------------------------------------------------------------------------------- 1 | operation call : int * int 2 | operation result : int * int 3 | 4 | let naiveCallWith x = 5 | send call x; 6 | let p = promise (result y -> return <>) in 7 | fun () -> return await p 8 | 9 | let callWith callCounter = 10 | fun x -> 11 | let callNo = !callCounter in 12 | send call (x, callNo); 13 | callCounter := callNo + 1; 14 | let p = promise (result (y, callNo') when callNo = callNo' -> 15 | return <> 16 | ) in 17 | let valueThunk () = await p in 18 | return valueThunk 19 | 20 | let remote f = 21 | promise (call (x, callNo) r -> 22 | let y = f x in 23 | send result (y, callNo); 24 | r () 25 | ) 26 | 27 | run 28 | let callCounter = ref 0 in 29 | let yt = callWith callCounter 2 in 30 | let zt = callWith callCounter 3 in 31 | return ((yt () * yt ()) + (zt () * zt ())) 32 | 33 | run 34 | remote (fun x -> 4 * (5 * (6 * x))) 35 | -------------------------------------------------------------------------------- /examples/remoteCallFunPayload.aeff: -------------------------------------------------------------------------------- 1 | operation call : [| unit -> unit |] 2 | operation result : int * int 3 | 4 | let remoteCall callCounter f = 5 | let callNo = !callCounter in callCounter := !callCounter + 1; 6 | let task = [| fun _ -> let g = unbox f in 7 | let res = g () in 8 | send result (res, callNo) |] in 9 | send call task; 10 | let resultPromise = promise (result (y, callNo') when callNo = callNo' -> return <>) in 11 | let valueThunk () = await resultPromise in 12 | valueThunk 13 | 14 | let remote () = 15 | promise (call boxedTask r -> 16 | spawn ((unbox boxedTask) ()); 17 | r() 18 | ) 19 | 20 | run 21 | let callCounter = ref 0 in 22 | let xt = remoteCall callCounter [| fun _ -> 1 * 2 * 3 |] in 23 | let yt = remoteCall callCounter [| fun _ -> 4 * 5 * 6 |] in 24 | return xt () + yt () 25 | 26 | run 27 | remote () 28 | 29 | 30 | -------------------------------------------------------------------------------- /examples/runner.aeff: -------------------------------------------------------------------------------- 1 | operation randomReq : int 2 | operation randomRes : int * int 3 | 4 | let lcgRunner modulus a c initialSeed = 5 | promise (randomReq callNo r seed -> 6 | let seed' = (a * seed + c) mod modulus in 7 | send randomRes (callNo, seed); 8 | r seed' 9 | ) at initialSeed 10 | 11 | let randomDigit callCounter = 12 | let callNo = !callCounter in 13 | send randomReq callNo; 14 | callCounter := callNo + 1; 15 | let p = promise (randomRes (callNo', seed) when callNo = callNo' -> 16 | return <> 17 | ) in 18 | await p 19 | 20 | run 21 | lcgRunner 1234 567 89 1 22 | 23 | run 24 | let callCounter = ref 0 in 25 | (randomDigit callCounter, randomDigit callCounter, randomDigit callCounter, randomDigit callCounter) 26 | -------------------------------------------------------------------------------- /examples/ticktock.aeff: -------------------------------------------------------------------------------- 1 | operation tick : int 2 | operation tock : int 3 | 4 | let ticktock () = 5 | send tick 1; 6 | send tock 2 7 | 8 | run 9 | ticktock () 10 | -------------------------------------------------------------------------------- /src/aeff/aeff.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Ast = Core.Ast 3 | module Interpreter = Core.Interpreter 4 | module Loader = Core.Loader 5 | 6 | let make_top_step = function 7 | | Interpreter.TopSignal (op, expr, proc) -> 8 | Format.printf "↑ %t %t@." (Ast.OpSym.print op) (Ast.print_expression expr); 9 | proc 10 | | Interpreter.Step proc -> proc 11 | 12 | let rec run (state : Interpreter.state) proc = 13 | match Interpreter.top_steps state proc with 14 | | [] -> proc 15 | | steps -> 16 | let i = Random.int (List.length steps) in 17 | let _, top_step = List.nth steps i in 18 | let proc' = make_top_step top_step in 19 | run state proc' 20 | 21 | type config = { 22 | filenames : string list; 23 | load_stdlib : bool; 24 | fixed_random_seed : bool; 25 | } 26 | 27 | let parse_args_to_config () = 28 | let filenames = ref [] 29 | and load_stdlib = ref true 30 | and fixed_random_seed = ref false in 31 | let usage = "Run AEff as '" ^ Sys.argv.(0) ^ " [filename.aeff] ...'" 32 | and anonymous filename = filenames := filename :: !filenames 33 | and options = 34 | Arg.align 35 | [ 36 | ( "--no-stdlib", 37 | Arg.Clear load_stdlib, 38 | " Do not load the standard library" ); 39 | ( "--fixed-random-seed", 40 | Arg.Set fixed_random_seed, 41 | " Do not initialize the random seed" ); 42 | ] 43 | in 44 | Arg.parse options anonymous usage; 45 | { 46 | filenames = List.rev !filenames; 47 | load_stdlib = !load_stdlib; 48 | fixed_random_seed = !fixed_random_seed; 49 | } 50 | 51 | let main () = 52 | let config = parse_args_to_config () in 53 | try 54 | if not config.fixed_random_seed then Random.self_init (); 55 | let state = 56 | if config.load_stdlib then 57 | Loader.load_source Loader.initial_state Loader.stdlib_source 58 | else Loader.initial_state 59 | in 60 | let state = List.fold_left Loader.load_file state config.filenames in 61 | let proc = run state.interpreter (Loader.make_process state) in 62 | Format.printf "The process has terminated in the configuration:@.%t@." 63 | (Ast.print_process proc) 64 | with Error.Error error -> 65 | Error.print error; 66 | exit 1 67 | 68 | let _ = main () 69 | -------------------------------------------------------------------------------- /src/aeff/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name aeff) 3 | (libraries core) 4 | (promote 5 | (until-clean) 6 | (into ../..))) 7 | -------------------------------------------------------------------------------- /src/core/ast.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module TyName = Symbol.Make () 3 | 4 | type ty_name = TyName.t 5 | 6 | module TyNameMap = Map.Make (TyName) 7 | 8 | let bool_ty_name = TyName.fresh "bool" 9 | let int_ty_name = TyName.fresh "int" 10 | let unit_ty_name = TyName.fresh "unit" 11 | let string_ty_name = TyName.fresh "string" 12 | let float_ty_name = TyName.fresh "float" 13 | let list_ty_name = TyName.fresh "list" 14 | let empty_ty_name = TyName.fresh "empty" 15 | let ref_ty_name = TyName.fresh "ref" 16 | 17 | module TyParam = Symbol.Make () 18 | 19 | type ty_param = TyParam.t 20 | 21 | module TyParamMap = Map.Make (TyParam) 22 | module TyParamSet = Set.Make (TyParam) 23 | 24 | type ty = 25 | | TyConst of Const.ty 26 | | TyApply of ty_name * ty list (** [(ty1, ty2, ..., tyn) type_name] *) 27 | | TyParam of ty_param (** ['a] *) 28 | | TyArrow of ty * ty (** [ty1 -> ty2] *) 29 | | TyTuple of ty list (** [ty1 * ty2 * ... * tyn] *) 30 | | TyPromise of ty (** [<>] *) 31 | | TyReference of ty (** [ty ref] *) 32 | | TyBoxed of ty (** [[[ty]]] *) 33 | 34 | let rec print_ty ?max_level print_param p ppf = 35 | let print ?at_level = Print.print ?max_level ?at_level ppf in 36 | match p with 37 | | TyConst c -> print "%t" (Const.print_ty c) 38 | | TyApply (ty_name, []) -> print "%t" (TyName.print ty_name) 39 | | TyApply (ty_name, [ ty ]) -> 40 | print ~at_level:1 "%t %t" 41 | (print_ty ~max_level:1 print_param ty) 42 | (TyName.print ty_name) 43 | | TyApply (ty_name, tys) -> 44 | print ~at_level:1 "%t %t" 45 | (Print.print_tuple (print_ty print_param) tys) 46 | (TyName.print ty_name) 47 | | TyParam a -> print "%t" (print_param a) 48 | | TyArrow (ty1, ty2) -> 49 | print ~at_level:3 "%t → %t" 50 | (print_ty ~max_level:2 print_param ty1) 51 | (print_ty ~max_level:3 print_param ty2) 52 | | TyTuple [] -> print "unit" 53 | | TyTuple tys -> 54 | print ~at_level:2 "%t" 55 | (Print.print_sequence " × " (print_ty ~max_level:1 print_param) tys) 56 | | TyPromise ty -> print "⟨%t⟩" (print_ty print_param ty) 57 | | TyReference ty -> 58 | print ~at_level:1 "%t ref" (print_ty ~max_level:1 print_param ty) 59 | | TyBoxed ty -> 60 | print ~at_level:1 "[%t]" (print_ty ~max_level:1 print_param ty) 61 | 62 | let new_print_param () = 63 | let names = ref TyParamMap.empty in 64 | let counter = ref 0 in 65 | let print_param param ppf = 66 | let symbol = 67 | match TyParamMap.find_opt param !names with 68 | | Some symbol -> symbol 69 | | None -> 70 | let symbol = Symbol.type_symbol !counter in 71 | incr counter; 72 | names := TyParamMap.add param symbol !names; 73 | symbol 74 | in 75 | Print.print ppf "%s" symbol 76 | in 77 | print_param 78 | 79 | let print_ty_scheme (_params, ty) ppf = 80 | let print_param = new_print_param () in 81 | Print.print ppf "@[%t@]" (print_ty print_param ty) 82 | 83 | let rec substitute_ty subst = function 84 | | TyConst _ as ty -> ty 85 | | TyParam a as ty -> ( 86 | match TyParamMap.find_opt a subst with None -> ty | Some ty' -> ty') 87 | | TyApply (ty_name, tys) -> 88 | TyApply (ty_name, List.map (substitute_ty subst) tys) 89 | | TyTuple tys -> TyTuple (List.map (substitute_ty subst) tys) 90 | | TyArrow (ty1, ty2) -> 91 | TyArrow (substitute_ty subst ty1, substitute_ty subst ty2) 92 | | TyPromise ty -> TyPromise (substitute_ty subst ty) 93 | | TyReference ty -> TyReference (substitute_ty subst ty) 94 | | TyBoxed ty -> TyBoxed (substitute_ty subst ty) 95 | 96 | let rec free_vars = function 97 | | TyConst _ -> TyParamSet.empty 98 | | TyParam a -> TyParamSet.singleton a 99 | | TyApply (_, tys) -> 100 | List.fold_left 101 | (fun vars ty -> TyParamSet.union vars (free_vars ty)) 102 | TyParamSet.empty tys 103 | | TyTuple tys -> 104 | List.fold_left 105 | (fun vars ty -> TyParamSet.union vars (free_vars ty)) 106 | TyParamSet.empty tys 107 | | TyArrow (ty1, ty2) -> TyParamSet.union (free_vars ty1) (free_vars ty2) 108 | | TyPromise ty -> free_vars ty 109 | | TyReference ty -> free_vars ty 110 | | TyBoxed ty -> free_vars ty 111 | 112 | module Variable = Symbol.Make () 113 | module Label = Symbol.Make () 114 | module OpSym = Symbol.Make () 115 | 116 | type variable = Variable.t 117 | type label = Label.t 118 | type opsym = OpSym.t 119 | 120 | let nil_label = Label.fresh Syntax.nil_label 121 | let cons_label = Label.fresh Syntax.cons_label 122 | 123 | type pattern = 124 | | PVar of variable 125 | | PAnnotated of pattern * ty 126 | | PAs of pattern * variable 127 | | PTuple of pattern list 128 | | PVariant of label * pattern option 129 | | PConst of Const.t 130 | | PNonbinding 131 | 132 | type expression = 133 | | Var of variable 134 | | Const of Const.t 135 | | Annotated of expression * ty 136 | | Tuple of expression list 137 | | Variant of label * expression option 138 | | Lambda of abstraction 139 | | RecLambda of variable * abstraction 140 | | Fulfill of expression 141 | | Reference of expression ref 142 | | Boxed of expression 143 | 144 | and computation = 145 | | Return of expression 146 | | Do of computation * abstraction 147 | | Match of expression * abstraction list 148 | | Apply of expression * expression 149 | | Operation of operation * computation 150 | | Interrupt of opsym * expression * computation 151 | | Await of expression * abstraction 152 | | Unbox of expression * abstraction 153 | 154 | and operation = 155 | | Signal of opsym * expression 156 | | InterruptHandler of { 157 | operation : opsym; 158 | handler : handler_abstraction; 159 | state_value : expression; 160 | promise : variable; 161 | } 162 | | Spawn of computation 163 | 164 | and abstraction = pattern * computation 165 | 166 | and handler_abstraction = { 167 | payload_pattern : pattern; 168 | resumption_pattern : pattern; 169 | state_pattern : pattern; 170 | body : computation; 171 | } 172 | 173 | module VariableMap = Map.Make (Variable) 174 | module OpSymMap = Map.Make (OpSym) 175 | 176 | let rec remove_pattern_bound_variables subst = function 177 | | PVar x -> VariableMap.remove x subst 178 | | PAnnotated (pat, _) -> remove_pattern_bound_variables subst pat 179 | | PAs (pat, x) -> 180 | let subst = remove_pattern_bound_variables subst pat in 181 | VariableMap.remove x subst 182 | | PTuple pats -> List.fold_left remove_pattern_bound_variables subst pats 183 | | PVariant (_, None) -> subst 184 | | PVariant (_, Some pat) -> remove_pattern_bound_variables subst pat 185 | | PConst _ -> subst 186 | | PNonbinding -> subst 187 | 188 | let rec refresh_pattern = function 189 | | PVar x -> 190 | let x' = Variable.refresh x in 191 | (PVar x', [ (x, x') ]) 192 | | PAnnotated (pat, _) -> refresh_pattern pat 193 | | PAs (pat, x) -> 194 | let pat', vars = refresh_pattern pat in 195 | let x' = Variable.refresh x in 196 | (PAs (pat', x'), (x, x') :: vars) 197 | | PTuple pats -> 198 | let fold pat (pats', vars) = 199 | let pat', vars' = refresh_pattern pat in 200 | (pat' :: pats', vars' @ vars) 201 | in 202 | let pats', vars = List.fold_right fold pats ([], []) in 203 | (PTuple pats', vars) 204 | | PVariant (lbl, Some pat) -> 205 | let pat', vars = refresh_pattern pat in 206 | (PVariant (lbl, Some pat'), vars) 207 | | (PVariant (_, None) | PConst _ | PNonbinding) as pat -> (pat, []) 208 | 209 | let rec refresh_expression vars = function 210 | | Var x as expr -> ( 211 | match List.assoc_opt x vars with None -> expr | Some x' -> Var x') 212 | | Const _ as expr -> expr 213 | | Annotated (expr, ty) -> Annotated (refresh_expression vars expr, ty) 214 | | Tuple exprs -> Tuple (List.map (refresh_expression vars) exprs) 215 | | Variant (label, expr) -> 216 | Variant (label, Option.map (refresh_expression vars) expr) 217 | | Lambda abs -> Lambda (refresh_abstraction vars abs) 218 | | RecLambda (x, abs) -> 219 | let x' = Variable.refresh x in 220 | RecLambda (x', refresh_abstraction ((x, x') :: vars) abs) 221 | | Fulfill expr -> Fulfill (refresh_expression vars expr) 222 | | Reference ref -> Reference ref 223 | | Boxed expr -> Boxed (refresh_expression vars expr) 224 | 225 | and refresh_computation vars = function 226 | | Return expr -> Return (refresh_expression vars expr) 227 | | Do (comp, abs) -> 228 | Do (refresh_computation vars comp, refresh_abstraction vars abs) 229 | | Match (expr, cases) -> 230 | Match 231 | (refresh_expression vars expr, List.map (refresh_abstraction vars) cases) 232 | | Apply (expr1, expr2) -> 233 | Apply (refresh_expression vars expr1, refresh_expression vars expr2) 234 | | Operation (Signal (op, expr), comp) -> 235 | Operation 236 | ( Signal (op, refresh_expression vars expr), 237 | refresh_computation vars comp ) 238 | | Operation 239 | ( InterruptHandler 240 | { operation = op; handler; state_value = s; promise = p }, 241 | comp ) -> 242 | let p' = Variable.refresh p in 243 | Operation 244 | ( InterruptHandler 245 | { 246 | operation = op; 247 | handler = refresh_handler_abstraction vars handler; 248 | state_value = refresh_expression vars s; 249 | promise = p'; 250 | }, 251 | refresh_computation ((p, p') :: vars) comp ) 252 | | Operation (Spawn comp1, comp2) -> 253 | Operation 254 | (Spawn (refresh_computation vars comp1), refresh_computation vars comp2) 255 | | Interrupt (op, expr, comp) -> 256 | Interrupt (op, refresh_expression vars expr, refresh_computation vars comp) 257 | | Await (expr, abs) -> 258 | Await (refresh_expression vars expr, refresh_abstraction vars abs) 259 | | Unbox (expr, abs) -> 260 | Unbox (refresh_expression vars expr, refresh_abstraction vars abs) 261 | 262 | and refresh_abstraction vars (pat, comp) = 263 | let pat', vars' = refresh_pattern pat in 264 | (pat', refresh_computation (vars @ vars') comp) 265 | 266 | and refresh_handler_abstraction vars 267 | { payload_pattern; resumption_pattern; state_pattern; body } = 268 | let payload_pattern', vars1 = refresh_pattern payload_pattern in 269 | let resumption_pattern', vars2 = refresh_pattern resumption_pattern in 270 | let state_pattern', vars3 = refresh_pattern state_pattern in 271 | let body' = refresh_computation (vars1 @ vars2 @ vars3 @ vars) body in 272 | { 273 | payload_pattern = payload_pattern'; 274 | resumption_pattern = resumption_pattern'; 275 | state_pattern = state_pattern'; 276 | body = body'; 277 | } 278 | 279 | let rec substitute_expression subst = function 280 | | Var x as expr -> ( 281 | match VariableMap.find_opt x subst with None -> expr | Some expr -> expr) 282 | | Const _ as expr -> expr 283 | | Annotated (expr, ty) -> Annotated (substitute_expression subst expr, ty) 284 | | Tuple exprs -> Tuple (List.map (substitute_expression subst) exprs) 285 | | Variant (label, expr) -> 286 | Variant (label, Option.map (substitute_expression subst) expr) 287 | | Lambda abs -> Lambda (substitute_abstraction subst abs) 288 | | RecLambda (x, abs) -> RecLambda (x, substitute_abstraction subst abs) 289 | | Fulfill expr -> Fulfill (substitute_expression subst expr) 290 | | Reference ref -> Reference ref 291 | | Boxed expr -> Boxed (substitute_expression subst expr) 292 | 293 | and substitute_computation subst = function 294 | | Return expr -> Return (substitute_expression subst expr) 295 | | Do (comp, abs) -> 296 | Do (substitute_computation subst comp, substitute_abstraction subst abs) 297 | | Match (expr, cases) -> 298 | Match 299 | ( substitute_expression subst expr, 300 | List.map (substitute_abstraction subst) cases ) 301 | | Apply (expr1, expr2) -> 302 | Apply 303 | (substitute_expression subst expr1, substitute_expression subst expr2) 304 | | Operation (Signal (op, expr), comp) -> 305 | Operation 306 | ( Signal (op, substitute_expression subst expr), 307 | substitute_computation subst comp ) 308 | | Operation 309 | ( InterruptHandler 310 | { operation = op; handler; state_value = s; promise = p }, 311 | comp ) -> 312 | let subst' = remove_pattern_bound_variables subst (PVar p) in 313 | Operation 314 | ( InterruptHandler 315 | { 316 | operation = op; 317 | handler = substitute_handler_abstraction subst handler; 318 | state_value = substitute_expression subst s; 319 | promise = p; 320 | }, 321 | substitute_computation subst' comp ) 322 | | Operation (Spawn comp1, comp2) -> 323 | Operation 324 | ( Spawn (substitute_computation subst comp1), 325 | substitute_computation subst comp2 ) 326 | | Interrupt (op, expr, comp) -> 327 | Interrupt 328 | (op, substitute_expression subst expr, substitute_computation subst comp) 329 | | Await (expr, abs) -> 330 | Await (substitute_expression subst expr, substitute_abstraction subst abs) 331 | | Unbox (expr, abs) -> 332 | Unbox (substitute_expression subst expr, substitute_abstraction subst abs) 333 | 334 | and substitute_abstraction subst (pat, comp) = 335 | let subst' = remove_pattern_bound_variables subst pat in 336 | (pat, substitute_computation subst' comp) 337 | 338 | and substitute_handler_abstraction subst 339 | { payload_pattern; resumption_pattern; state_pattern; body } = 340 | let subst' = remove_pattern_bound_variables subst payload_pattern in 341 | let subst'' = remove_pattern_bound_variables subst' resumption_pattern in 342 | let subst''' = remove_pattern_bound_variables subst'' state_pattern in 343 | { 344 | payload_pattern; 345 | resumption_pattern; 346 | state_pattern; 347 | body = substitute_computation subst''' body; 348 | } 349 | 350 | type process = 351 | | Run of computation 352 | | Parallel of process * process 353 | | SignalProc of opsym * expression * process 354 | | InterruptProc of opsym * expression * process 355 | 356 | type ty_def = TySum of (label * ty option) list | TyInline of ty 357 | 358 | type command = 359 | | TyDef of (ty_param list * ty_name * ty_def) list 360 | | OpSymDef of opsym * ty 361 | | TopLet of variable * expression 362 | | TopDo of computation 363 | 364 | let rec print_pattern ?max_level p ppf = 365 | let print ?at_level = Print.print ?max_level ?at_level ppf in 366 | match p with 367 | | PVar x -> print "%t" (Variable.print x) 368 | | PAs (p, x) -> print "%t as %t" (print_pattern p) (Variable.print x) 369 | | PAnnotated (p, _ty) -> print_pattern ?max_level p ppf 370 | | PConst c -> Const.print c ppf 371 | | PTuple lst -> Print.print_tuple print_pattern lst ppf 372 | | PVariant (lbl, None) when lbl = nil_label -> print "[]" 373 | | PVariant (lbl, None) -> print "%t" (Label.print lbl) 374 | | PVariant (lbl, Some (PTuple [ v1; v2 ])) when lbl = cons_label -> 375 | print "%t::%t" (print_pattern v1) (print_pattern v2) 376 | | PVariant (lbl, Some p) -> 377 | print ~at_level:1 "%t @[%t@]" (Label.print lbl) (print_pattern p) 378 | | PNonbinding -> print "_" 379 | 380 | let rec print_expression ?max_level e ppf = 381 | let print ?at_level = Print.print ?max_level ?at_level ppf in 382 | match e with 383 | | Var x -> print "%t" (Variable.print x) 384 | | Const c -> print "%t" (Const.print c) 385 | | Annotated (t, _ty) -> print_expression ?max_level t ppf 386 | | Tuple lst -> Print.print_tuple print_expression lst ppf 387 | | Variant (lbl, None) when lbl = nil_label -> print "[]" 388 | | Variant (lbl, None) -> print "%t" (Label.print lbl) 389 | | Variant (lbl, Some (Tuple [ v1; v2 ])) when lbl = cons_label -> 390 | print ~at_level:1 "%t::%t" 391 | (print_expression ~max_level:0 v1) 392 | (print_expression ~max_level:1 v2) 393 | | Variant (lbl, Some e) -> 394 | print ~at_level:1 "%t @[%t@]" (Label.print lbl) 395 | (print_expression ~max_level:0 e) 396 | | Lambda a -> print ~at_level:2 "fun %t" (print_abstraction a) 397 | | RecLambda (f, _ty) -> print ~at_level:2 "rec %t ..." (Variable.print f) 398 | | Fulfill expr -> print "⟨%t⟩" (print_expression expr) 399 | | Reference r -> print "{ contents = %t }" (print_expression !r) 400 | | Boxed expr -> print "[%t]" (print_expression expr) 401 | 402 | and print_computation ?max_level c ppf = 403 | let print ?at_level = Print.print ?max_level ?at_level ppf in 404 | match c with 405 | | Return e -> print ~at_level:1 "return %t" (print_expression ~max_level:0 e) 406 | | Do (c1, (PNonbinding, c2)) -> 407 | print "@[%t;@ %t@]" (print_computation c1) (print_computation c2) 408 | | Do (c1, (pat, c2)) -> 409 | print "@[let@[@ %t =@ %t@] in@ %t@]" (print_pattern pat) 410 | (print_computation c1) (print_computation c2) 411 | | Match (e, lst) -> 412 | print "match %t with (@[%t@])" (print_expression e) 413 | (Print.print_sequence " | " case lst) 414 | | Apply (e1, e2) -> 415 | print ~at_level:1 "@[%t@ %t@]" 416 | (print_expression ~max_level:1 e1) 417 | (print_expression ~max_level:0 e2) 418 | | Interrupt (op, e, c) -> 419 | print "↓%t(@[%t,@ %t@])" (OpSym.print op) (print_expression e) 420 | (print_computation c) 421 | | Operation (Signal (op, e), c) -> 422 | print "↑%t(@[%t,@ %t@])" (OpSym.print op) (print_expression e) 423 | (print_computation c) 424 | | Operation 425 | ( InterruptHandler 426 | { 427 | operation = op; 428 | handler = 429 | { 430 | payload_pattern = p1; 431 | resumption_pattern = r; 432 | state_pattern = s; 433 | body = c1; 434 | }; 435 | state_value = v; 436 | promise = p2; 437 | }, 438 | c2 ) -> 439 | print "@[promise (@[%t %t %t %t ↦@ %t@])@ %@ %t as %t in@ %t@]" 440 | (OpSym.print op) (print_pattern p1) (print_pattern r) (print_pattern s) 441 | (print_computation c1) (print_expression v) (Variable.print p2) 442 | (print_computation c2) 443 | | Operation (Spawn comp1, comp2) -> 444 | print "Spawn (%t);%t\n" (print_computation comp1) 445 | (print_computation comp2) 446 | | Await (e, (p, c)) -> 447 | print "@[await @[%t until@ ⟨%t⟩@] in@ %t@]" (print_expression e) 448 | (print_pattern p) (print_computation c) 449 | | Unbox (e, (p, c)) -> 450 | print "Unbox %t as [%t] in %t" (print_expression e) (print_pattern p) 451 | (print_computation c) 452 | 453 | and print_abstraction (p, c) ppf = 454 | Format.fprintf ppf "%t ↦ %t" (print_pattern p) (print_computation c) 455 | 456 | and let_abstraction (p, c) ppf = 457 | Format.fprintf ppf "%t = %t" (print_pattern p) (print_computation c) 458 | 459 | and case a ppf = Format.fprintf ppf "%t" (print_abstraction a) 460 | 461 | let rec print_process ?max_level proc ppf = 462 | let print ?at_level = Print.print ?max_level ?at_level ppf in 463 | match proc with 464 | | Run comp -> print ~at_level:1 "run %t" (print_computation ~max_level:0 comp) 465 | | Parallel (proc1, proc2) -> 466 | print "@[%t@ || @ %t@]" (print_process proc1) (print_process proc2) 467 | | InterruptProc (op, expr, proc) -> 468 | print "↓%t(@[%t,@ %t@])" (OpSym.print op) (print_expression expr) 469 | (print_process proc) 470 | | SignalProc (op, expr, proc) -> 471 | print "↑%t(@[%t,@ %t@])" (OpSym.print op) (print_expression expr) 472 | (print_process proc) 473 | 474 | let string_of_operation op = 475 | OpSym.print op Format.str_formatter; 476 | Format.flush_str_formatter () 477 | 478 | let string_of_expression e = 479 | print_expression e Format.str_formatter; 480 | Format.flush_str_formatter () 481 | 482 | let string_of_computation c = 483 | print_computation c Format.str_formatter; 484 | Format.flush_str_formatter () 485 | 486 | let string_of_process proc = 487 | print_process proc Format.str_formatter; 488 | Format.flush_str_formatter () 489 | -------------------------------------------------------------------------------- /src/core/builtIn.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | let binary_function f = function 4 | | Ast.Tuple [ expr1; expr2 ] -> f expr1 expr2 5 | | expr -> Error.runtime "Pair expected but got %t" (Ast.print_expression expr) 6 | 7 | let get_int = function 8 | | Ast.Const (Const.Integer n) -> n 9 | | expr -> 10 | Error.runtime "Integer expected but got %t" (Ast.print_expression expr) 11 | 12 | let get_reference = function 13 | | Ast.Reference r -> r 14 | | expr -> 15 | Error.runtime "Reference expected but got %t" (Ast.print_expression expr) 16 | 17 | let int_to f expr = 18 | let n = get_int expr in 19 | f n 20 | 21 | let int_int_to f expr = 22 | binary_function 23 | (fun expr1 expr2 -> 24 | let n1 = get_int expr1 in 25 | let n2 = get_int expr2 in 26 | f n1 n2) 27 | expr 28 | 29 | let int_to_int name f = 30 | ( name, 31 | ([], Ast.TyArrow (Ast.TyConst Const.IntegerTy, Ast.TyConst Const.IntegerTy)), 32 | int_to (fun n -> Ast.Return (Ast.Const (Const.Integer (f n)))) ) 33 | 34 | let int_int_to_int name f = 35 | ( name, 36 | ( [], 37 | Ast.TyArrow 38 | ( Ast.TyTuple 39 | [ Ast.TyConst Const.IntegerTy; Ast.TyConst Const.IntegerTy ], 40 | Ast.TyConst Const.IntegerTy ) ), 41 | int_int_to (fun n1 n2 -> Ast.Return (Ast.Const (Const.Integer (f n1 n2)))) 42 | ) 43 | 44 | let poly_type ty = 45 | let a = Ast.TyParam.fresh "poly" in 46 | ([ a ], ty (Ast.TyParam a)) 47 | 48 | let poly_poly_to_bool name f = 49 | ( name, 50 | poly_type (fun a -> 51 | Ast.TyArrow (Ast.TyTuple [ a; a ], Ast.TyConst Const.BooleanTy)), 52 | binary_function (fun n1 n2 -> 53 | Ast.Return (Ast.Const (Const.Boolean (f n1 n2)))) ) 54 | 55 | let functions = 56 | [ 57 | poly_poly_to_bool "(=)" ( = ); 58 | poly_poly_to_bool "(<)" ( < ); 59 | poly_poly_to_bool "(>)" ( > ); 60 | poly_poly_to_bool "(<=)" ( <= ); 61 | poly_poly_to_bool "(>=)" ( >= ); 62 | poly_poly_to_bool "(<>)" ( <> ); 63 | int_to_int "(~-)" ( ~- ); 64 | int_int_to_int "(+)" ( + ); 65 | int_int_to_int "(*)" ( * ); 66 | int_int_to_int "(-)" ( - ); 67 | int_int_to_int "(mod)" ( mod ); 68 | int_int_to_int "(/)" ( / ); 69 | ( "ref", 70 | poly_type (fun a -> Ast.TyArrow (a, Ast.TyReference a)), 71 | fun v -> Ast.Return (Ast.Reference (ref v)) ); 72 | ( "(!)", 73 | poly_type (fun a -> Ast.TyArrow (Ast.TyReference a, a)), 74 | fun v -> 75 | let r = get_reference v in 76 | Ast.Return !r ); 77 | ( "(:=)", 78 | poly_type (fun a -> 79 | Ast.TyArrow (Ast.TyTuple [ Ast.TyReference a; a ], Ast.TyTuple [])), 80 | binary_function (fun v1 v2 -> 81 | let r = get_reference v1 in 82 | r := v2; 83 | Ast.Return (Ast.Tuple [])) ); 84 | ( "toString", 85 | poly_type (fun a -> Ast.TyArrow (a, Ast.TyConst Const.StringTy)), 86 | fun expr -> 87 | Ast.Return (Ast.Const (Const.String (Ast.string_of_expression expr))) ); 88 | ] 89 | -------------------------------------------------------------------------------- /src/core/const.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | type t = Integer of int | String of string | Boolean of bool | Float of float 4 | type ty = IntegerTy | StringTy | BooleanTy | FloatTy 5 | 6 | let of_integer n = Integer n 7 | let of_string s = String s 8 | let of_boolean b = Boolean b 9 | let of_float f = Float f 10 | let of_true = of_boolean true 11 | let of_false = of_boolean false 12 | 13 | let print c ppf = 14 | match c with 15 | | Integer k -> Format.fprintf ppf "%d" k 16 | | String s -> Format.fprintf ppf "%S" s 17 | | Boolean b -> Format.fprintf ppf "%B" b 18 | | Float f -> Format.fprintf ppf "%F" f 19 | 20 | let print_ty c ppf = 21 | match c with 22 | | IntegerTy -> Format.fprintf ppf "int" 23 | | StringTy -> Format.fprintf ppf "string" 24 | | BooleanTy -> Format.fprintf ppf "bool" 25 | | FloatTy -> Format.fprintf ppf "float" 26 | 27 | let infer_ty = function 28 | | Integer _ -> IntegerTy 29 | | String _ -> StringTy 30 | | Boolean _ -> BooleanTy 31 | | Float _ -> FloatTy 32 | 33 | type comparison = Less | Equal | Greater | Invalid 34 | 35 | let compare c1 c2 = 36 | let cmp x y = 37 | let r = Stdlib.compare x y in 38 | if r < 0 then Less else if r > 0 then Greater else Equal 39 | in 40 | match (c1, c2) with 41 | | Integer n1, Integer n2 -> cmp n1 n2 42 | | String s1, String s2 -> cmp s1 s2 43 | | Boolean b1, Boolean b2 -> cmp b1 b2 44 | | Float x1, Float x2 -> cmp x1 x2 45 | | _ -> Error.runtime "Incomparable constants %t and %t" (print c1) (print c2) 46 | 47 | let equal c1 c2 = compare c1 c2 = Equal 48 | -------------------------------------------------------------------------------- /src/core/desugarer.ml: -------------------------------------------------------------------------------- 1 | (** Desugaring of syntax into the core language. *) 2 | 3 | open Utils 4 | module S = Syntax 5 | module StringMap = Map.Make (String) 6 | 7 | type state = { 8 | ty_names : Ast.ty_name StringMap.t; 9 | ty_params : Ast.ty_param StringMap.t; 10 | variables : Ast.variable StringMap.t; 11 | operations : Ast.opsym StringMap.t; 12 | labels : Ast.label StringMap.t; 13 | } 14 | 15 | let initial_state = 16 | { 17 | ty_names = 18 | StringMap.empty 19 | |> StringMap.add Syntax.bool_ty_name Ast.bool_ty_name 20 | |> StringMap.add Syntax.int_ty_name Ast.int_ty_name 21 | |> StringMap.add Syntax.unit_ty_name Ast.unit_ty_name 22 | |> StringMap.add Syntax.string_ty_name Ast.string_ty_name 23 | |> StringMap.add Syntax.float_ty_name Ast.float_ty_name 24 | |> StringMap.add Syntax.empty_ty_name Ast.empty_ty_name 25 | |> StringMap.add Syntax.list_ty_name Ast.list_ty_name 26 | |> StringMap.add Syntax.ref_ty_name Ast.ref_ty_name; 27 | ty_params = StringMap.empty; 28 | variables = StringMap.empty; 29 | operations = StringMap.empty; 30 | labels = 31 | StringMap.empty 32 | |> StringMap.add Syntax.nil_label Ast.nil_label 33 | |> StringMap.add Syntax.cons_label Ast.cons_label; 34 | } 35 | 36 | let find_symbol ~loc map name = 37 | match StringMap.find_opt name map with 38 | | None -> Error.syntax ~loc "Unknown name --%s--" name 39 | | Some symbol -> symbol 40 | 41 | let lookup_ty_name ~loc state = find_symbol ~loc state.ty_names 42 | let lookup_ty_param ~loc state = find_symbol ~loc state.ty_params 43 | let lookup_variable ~loc state = find_symbol ~loc state.variables 44 | let lookup_operation ~loc state = find_symbol ~loc state.operations 45 | let lookup_label ~loc state = find_symbol ~loc state.labels 46 | 47 | let rec desugar_ty state { it = plain_ty; Location.at = loc } = 48 | desugar_plain_ty ~loc state plain_ty 49 | 50 | and desugar_plain_ty ~loc state = function 51 | | S.TyApply (ty_name, tys) -> 52 | let ty_name' = lookup_ty_name ~loc state ty_name in 53 | let tys' = List.map (desugar_ty state) tys in 54 | Ast.TyApply (ty_name', tys') 55 | | S.TyParam ty_param -> 56 | let ty_param' = lookup_ty_param ~loc state ty_param in 57 | Ast.TyParam ty_param' 58 | | S.TyArrow (ty1, ty2) -> 59 | let ty1' = desugar_ty state ty1 in 60 | let ty2' = desugar_ty state ty2 in 61 | Ast.TyArrow (ty1', ty2') 62 | | S.TyTuple tys -> 63 | let tys' = List.map (desugar_ty state) tys in 64 | Ast.TyTuple tys' 65 | | S.TyConst c -> Ast.TyConst c 66 | | S.TyReference ty -> Ast.TyReference (desugar_ty state ty) 67 | | S.TyPromise ty -> Ast.TyPromise (desugar_ty state ty) 68 | | S.TyBoxed ty -> Ast.TyBoxed (desugar_ty state ty) 69 | 70 | let rec desugar_pattern state { it = pat; Location.at = loc } = 71 | let vars, pat' = desugar_plain_pattern ~loc state pat in 72 | (vars, pat') 73 | 74 | and desugar_plain_pattern ~loc state = function 75 | | S.PVar x -> 76 | let x' = Ast.Variable.fresh x in 77 | ([ (x, x') ], Ast.PVar x') 78 | | S.PAnnotated (pat, ty) -> 79 | let vars, pat' = desugar_pattern state pat 80 | and ty' = desugar_ty state ty in 81 | (vars, Ast.PAnnotated (pat', ty')) 82 | | S.PAs (pat, x) -> 83 | let vars, pat' = desugar_pattern state pat in 84 | let x' = Ast.Variable.fresh x in 85 | ((x, x') :: vars, Ast.PAs (pat', x')) 86 | | S.PTuple ps -> 87 | let aux p (vars, ps') = 88 | let vars', p' = desugar_pattern state p in 89 | (vars' @ vars, p' :: ps') 90 | in 91 | let vars, ps' = List.fold_right aux ps ([], []) in 92 | (vars, Ast.PTuple ps') 93 | | S.PVariant (lbl, None) -> 94 | let lbl' = lookup_label ~loc state lbl in 95 | ([], Ast.PVariant (lbl', None)) 96 | | S.PVariant (lbl, Some pat) -> 97 | let lbl' = lookup_label ~loc state lbl in 98 | let vars, pat' = desugar_pattern state pat in 99 | (vars, Ast.PVariant (lbl', Some pat')) 100 | | S.PConst c -> ([], Ast.PConst c) 101 | | S.PNonbinding -> ([], Ast.PNonbinding) 102 | 103 | let add_fresh_variables state vars = 104 | let aux variables (x, x') = StringMap.add x x' variables in 105 | let variables' = List.fold_left aux state.variables vars in 106 | { state with variables = variables' } 107 | 108 | let add_operation state op = 109 | let op' = Ast.OpSym.fresh op in 110 | (op', { state with operations = StringMap.add op op' state.operations }) 111 | 112 | let trivial_abstraction x = 113 | let x' = Ast.Variable.fresh x in 114 | (Ast.PVar x', Ast.Return (Ast.Var x')) 115 | 116 | let rec desugar_expression state { it = term; Location.at = loc } = 117 | let binds, expr = desugar_plain_expression ~loc state term in 118 | (binds, expr) 119 | 120 | and desugar_plain_expression ~loc state = function 121 | | S.Var x -> 122 | let x' = lookup_variable ~loc state x in 123 | ([], Ast.Var x') 124 | | S.Const k -> ([], Ast.Const k) 125 | | S.Annotated (term, ty) -> 126 | let binds, expr = desugar_expression state term in 127 | let ty' = desugar_ty state ty in 128 | (binds, Ast.Annotated (expr, ty')) 129 | | S.Lambda a -> 130 | let a' = desugar_abstraction state a in 131 | ([], Ast.Lambda a') 132 | | S.Function cases -> 133 | let x = Ast.Variable.fresh "arg" in 134 | let cases' = List.map (desugar_abstraction state) cases in 135 | ([], Ast.Lambda (Ast.PVar x, Ast.Match (Ast.Var x, cases'))) 136 | | S.Tuple ts -> 137 | let binds, es = desugar_expressions state ts in 138 | (binds, Ast.Tuple es) 139 | | S.Variant (lbl, None) -> 140 | let lbl' = lookup_label ~loc state lbl in 141 | ([], Ast.Variant (lbl', None)) 142 | | S.Variant (lbl, Some term) -> 143 | let lbl' = lookup_label ~loc state lbl in 144 | let binds, expr = desugar_expression state term in 145 | (binds, Ast.Variant (lbl', Some expr)) 146 | | S.Fulfill term -> 147 | let binds, e = desugar_expression state term in 148 | (binds, Ast.Fulfill e) 149 | | S.Boxed term -> 150 | let binds, e = desugar_expression state term in 151 | (binds, Ast.Boxed e) 152 | | ( S.Apply _ | S.Match _ | S.Let _ | S.LetRec _ | S.Conditional _ 153 | | S.InterruptHandler _ | S.Await _ | S.Send _ | S.Unbox _ | Spawn _ ) as 154 | term -> 155 | let x = Ast.Variable.fresh "b" in 156 | let comp = desugar_computation state (Location.add_loc ~loc term) in 157 | let hoist = (Ast.PVar x, comp) in 158 | ([ hoist ], Ast.Var x) 159 | 160 | and desugar_computation state { it = term; at = loc } = 161 | let binds, comp = desugar_plain_computation ~loc state term in 162 | List.fold_right (fun (p, c1) c2 -> Ast.Do (c1, (p, c2))) binds comp 163 | 164 | and desugar_plain_computation ~loc state = 165 | let if_then_else e c1 c2 = 166 | let true_p = Ast.PConst Const.of_true in 167 | let false_p = Ast.PConst Const.of_false in 168 | Ast.Match (e, [ (true_p, c1); (false_p, c2) ]) 169 | in 170 | function 171 | | S.Apply ({ it = S.Var "(&&)"; _ }, { it = S.Tuple [ t1; t2 ]; _ }) -> 172 | let binds1, e1 = desugar_expression state t1 in 173 | let c1 = desugar_computation state t2 in 174 | let c2 = Ast.Return (Ast.Const (Const.Boolean false)) in 175 | (binds1, if_then_else e1 c1 c2) 176 | | S.Apply ({ it = S.Var "(||)"; _ }, { it = S.Tuple [ t1; t2 ]; _ }) -> 177 | let binds1, e1 = desugar_expression state t1 in 178 | let c1 = Ast.Return (Ast.Const (Const.Boolean true)) in 179 | let c2 = desugar_computation state t2 in 180 | (binds1, if_then_else e1 c1 c2) 181 | | S.Apply (t1, t2) -> 182 | let binds1, e1 = desugar_expression state t1 in 183 | let binds2, e2 = desugar_expression state t2 in 184 | (binds1 @ binds2, Ast.Apply (e1, e2)) 185 | | S.Match (t, cs) -> 186 | let binds, e = desugar_expression state t in 187 | let cs' = List.map (desugar_abstraction state) cs in 188 | (binds, Ast.Match (e, cs')) 189 | | S.Conditional (t, t1, t2) -> 190 | let binds, e = desugar_expression state t in 191 | let c1 = desugar_computation state t1 in 192 | let c2 = desugar_computation state t2 in 193 | (binds, if_then_else e c1 c2) 194 | | S.Let (pat, term1, term2) -> 195 | let c1 = desugar_computation state term1 in 196 | let c2 = desugar_abstraction state (pat, term2) in 197 | ([], Ast.Do (c1, c2)) 198 | | S.LetRec (x, term1, term2) -> 199 | let state', f, comp1 = desugar_let_rec_def state (x, term1) in 200 | let c = desugar_computation state' term2 in 201 | ([], Ast.Do (Ast.Return comp1, (Ast.PVar f, c))) 202 | | S.InterruptHandler 203 | { operation; kind; handler = payload_pattern, opt_guard, body } -> 204 | let vars, payload_pattern' = desugar_pattern state payload_pattern in 205 | let resumption_var', state_var', vars' = 206 | match (kind, opt_guard) with 207 | | Plain, None -> (None, None, vars) 208 | | Plain, Some _ -> (Some (Ast.Variable.fresh "r"), None, vars) 209 | | Reinstallable r, _ -> 210 | let r' = Ast.Variable.fresh r in 211 | (Some r', None, (r, r') :: vars) 212 | | Stateful (r, s, _), _ -> 213 | let r' = Ast.Variable.fresh r and s' = Ast.Variable.fresh r in 214 | (Some r', Some s', (r, r') :: (s, s') :: vars) 215 | in 216 | let resumption_pattern' = 217 | match resumption_var' with 218 | | None -> Ast.PNonbinding 219 | | Some r -> Ast.PVar r 220 | and state_pattern' = 221 | match state_var' with None -> Ast.PNonbinding | Some s -> Ast.PVar s 222 | in 223 | let body' = 224 | let state' = add_fresh_variables state vars' in 225 | let unguarded_body' = desugar_computation state' body in 226 | match opt_guard with 227 | | None -> unguarded_body' 228 | | Some guard -> 229 | let binds, guard' = desugar_expression state' guard in 230 | let r = 231 | match resumption_var' with Some r -> r | None -> assert false 232 | in 233 | 234 | let body'' = 235 | if_then_else guard' unguarded_body' 236 | (Ast.Apply (Ast.Var r, Ast.Tuple [])) 237 | in 238 | List.fold_right 239 | (fun (p, c1) c2 -> Ast.Do (c1, (p, c2))) 240 | binds body'' 241 | in 242 | 243 | let operation' = lookup_operation ~loc state operation in 244 | let handler' = 245 | Ast. 246 | { 247 | payload_pattern = payload_pattern'; 248 | resumption_pattern = resumption_pattern'; 249 | state_pattern = state_pattern'; 250 | body = body'; 251 | } 252 | in 253 | let binds, state_value' = 254 | match kind with 255 | | Plain | Reinstallable _ -> ([], Ast.Tuple []) 256 | | Stateful (_, _, state_value) -> desugar_expression state state_value 257 | in 258 | let promise' = Ast.Variable.fresh "p" in 259 | let cont' = Ast.Return (Ast.Var promise') in 260 | ( binds, 261 | Ast.Operation 262 | ( InterruptHandler 263 | { 264 | operation = operation'; 265 | handler = handler'; 266 | state_value = state_value'; 267 | promise = promise'; 268 | }, 269 | cont' ) ) 270 | | S.Await t -> 271 | let binds, e = desugar_expression state t in 272 | (binds, Ast.Await (e, trivial_abstraction "x")) 273 | | S.Send (op, t) -> 274 | let op' = lookup_operation ~loc state op in 275 | let binds, e = desugar_expression state t in 276 | (binds, Ast.Operation (Ast.Signal (op', e), Ast.Return (Ast.Tuple []))) 277 | | S.Unbox t -> 278 | let binds, e = desugar_expression state t in 279 | (binds, Ast.Unbox (e, trivial_abstraction "x")) 280 | | S.Spawn term -> 281 | let c = desugar_computation state term in 282 | ([], Ast.Operation (Ast.Spawn c, Ast.Return (Ast.Tuple []))) 283 | (* The remaining cases are expressions, which we list explicitly to catch any 284 | future changes. *) 285 | | ( S.Var _ | S.Const _ | S.Annotated _ | S.Tuple _ | S.Variant _ | S.Lambda _ 286 | | S.Function _ | S.Fulfill _ | S.Boxed _ ) as term -> 287 | let binds, expr = desugar_expression state { it = term; at = loc } in 288 | (binds, Ast.Return expr) 289 | 290 | and desugar_abstraction state (pat, term) = 291 | let vars, pat' = desugar_pattern state pat in 292 | let state' = add_fresh_variables state vars in 293 | let comp = desugar_computation state' term in 294 | (pat', comp) 295 | 296 | and desugar_let_rec_def state (f, { it = exp; at = loc }) = 297 | let f' = Ast.Variable.fresh f in 298 | let state' = add_fresh_variables state [ (f, f') ] in 299 | let abs' = 300 | match exp with 301 | | S.Lambda a -> desugar_abstraction state' a 302 | | S.Function cs -> 303 | let x = Ast.Variable.fresh "rf" in 304 | let cs = List.map (desugar_abstraction state') cs in 305 | let new_match = Ast.Match (Ast.Var x, cs) in 306 | (Ast.PVar x, new_match) 307 | | _ -> 308 | Error.syntax ~loc 309 | "This kind of expression is not allowed in a recursive definition" 310 | in 311 | let expr = Ast.RecLambda (f', abs') in 312 | (state', f', expr) 313 | 314 | and desugar_expressions state = function 315 | | [] -> ([], []) 316 | | t :: ts -> 317 | let binds, e = desugar_expression state t in 318 | let ws, es = desugar_expressions state ts in 319 | (binds @ ws, e :: es) 320 | 321 | let desugar_pure_expression state term = 322 | let binds, expr = desugar_expression state term in 323 | match binds with 324 | | [] -> expr 325 | | _ -> Error.syntax ~loc:term.at "Only pure expressions are allowed" 326 | 327 | let add_label state label label' = 328 | let labels' = StringMap.add label label' state.labels in 329 | { state with labels = labels' } 330 | 331 | let add_fresh_ty_names state vars = 332 | let aux ty_names (x, x') = StringMap.add x x' ty_names in 333 | let ty_names' = List.fold_left aux state.ty_names vars in 334 | { state with ty_names = ty_names' } 335 | 336 | let add_fresh_ty_params state vars = 337 | let aux ty_params (x, x') = StringMap.add x x' ty_params in 338 | let ty_params' = List.fold_left aux state.ty_params vars in 339 | { state with ty_params = ty_params' } 340 | 341 | let desugar_ty_def state = function 342 | | Syntax.TyInline ty -> (state, Ast.TyInline (desugar_ty state ty)) 343 | | Syntax.TySum variants -> 344 | let aux state (label, ty) = 345 | let label' = Ast.Label.fresh label in 346 | let ty' = Option.map (desugar_ty state) ty in 347 | let state' = add_label state label label' in 348 | (state', (label', ty')) 349 | in 350 | let state', variants' = List.fold_map aux state variants in 351 | (state', Ast.TySum variants') 352 | 353 | let desugar_command state = function 354 | | Syntax.TyDef defs -> 355 | let def_name (_, ty_name, _) = 356 | let ty_name' = Ast.TyName.fresh ty_name in 357 | (ty_name, ty_name') 358 | in 359 | let new_names = List.map def_name defs in 360 | let state' = add_fresh_ty_names state new_names in 361 | let aux (params, _, ty_def) (_, ty_name') (state', defs) = 362 | let params' = List.map (fun a -> (a, Ast.TyParam.fresh a)) params in 363 | let state'' = add_fresh_ty_params state' params' in 364 | let state''', ty_def' = desugar_ty_def state'' ty_def in 365 | (state''', (List.map snd params', ty_name', ty_def') :: defs) 366 | in 367 | let state'', defs' = List.fold_right2 aux defs new_names (state', []) in 368 | (state'', Ast.TyDef defs') 369 | | Syntax.TopLet (x, term) -> 370 | let x' = Ast.Variable.fresh x in 371 | let state' = add_fresh_variables state [ (x, x') ] in 372 | let expr = desugar_pure_expression state' term in 373 | (state', Ast.TopLet (x', expr)) 374 | | Syntax.TopDo term -> 375 | let comp = desugar_computation state term in 376 | (state, Ast.TopDo comp) 377 | | Syntax.TopLetRec (f, term) -> 378 | let state', f, expr = desugar_let_rec_def state (f, term) in 379 | (state', Ast.TopLet (f, expr)) 380 | | Syntax.Operation (op, ty) -> 381 | let op', state' = add_operation state op in 382 | let ty' = desugar_ty state ty in 383 | (state', Ast.OpSymDef (op', ty')) 384 | 385 | let add_external_variable x state = 386 | let x' = Ast.Variable.fresh x in 387 | (add_fresh_variables state [ (x, x') ], x') 388 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name core) 3 | (libraries utils)) 4 | 5 | (ocamllex lexer) 6 | 7 | (menhir 8 | (modules parser)) 9 | 10 | ;; This is a neat trick to include the standard library inside the binary, borrowed from 11 | ;; (https://gitlab.inria.fr/fpottier/menhir/-/blob/673f63e0f2c4ba7046ffae2504eb9ea29ad6d88c/src/dune) 12 | ;; We generate the file "stdlib_aeff.ml" which contains a string with the contents of "stdlib.aeff" 13 | 14 | (rule 15 | (with-stdout-to 16 | stdlib_aeff.ml 17 | (progn 18 | (echo "let contents = {|") 19 | (cat stdlib.aeff) 20 | (echo "|}")))) 21 | -------------------------------------------------------------------------------- /src/core/interpreter.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | type state = { 4 | variables : Ast.expression Ast.VariableMap.t; 5 | builtin_functions : (Ast.expression -> Ast.computation) Ast.VariableMap.t; 6 | } 7 | 8 | let initial_state = 9 | { 10 | variables = Ast.VariableMap.empty; 11 | builtin_functions = Ast.VariableMap.empty; 12 | } 13 | 14 | exception PatternMismatch 15 | 16 | type computation_redex = 17 | | PromiseSignal 18 | | InterruptReturn 19 | | InterruptSignal 20 | | InterruptPromise 21 | | InterruptPromise' 22 | | Match 23 | | ApplyFun 24 | | DoReturn 25 | | DoSignal 26 | | AwaitFulfill 27 | | Unbox 28 | | Spawn 29 | 30 | type computation_reduction = 31 | | InterruptCtx of computation_reduction 32 | | SignalCtx of computation_reduction 33 | | DoCtx of computation_reduction 34 | | ComputationRedex of computation_redex 35 | 36 | type process_redex = 37 | | RunSignal 38 | | RunSpawn 39 | | ParallelSignal1 40 | | ParallelSignal2 41 | | InterruptRun 42 | | InterruptParallel 43 | | InterruptSignal 44 | | TopSignal 45 | 46 | type process_reduction = 47 | | LeftCtx of process_reduction 48 | | RightCtx of process_reduction 49 | | InterruptProcCtx of process_reduction 50 | | SignalProcCtx of process_reduction 51 | | RunCtx of computation_reduction 52 | | ProcessRedex of process_redex 53 | 54 | let rec eval_tuple state = function 55 | | Ast.Tuple exprs -> exprs 56 | | Ast.Var x -> eval_tuple state (Ast.VariableMap.find x state.variables) 57 | | expr -> 58 | Error.runtime "Tuple expected but got %t" (Ast.print_expression expr) 59 | 60 | let rec eval_variant state = function 61 | | Ast.Variant (lbl, expr) -> (lbl, expr) 62 | | Ast.Var x -> eval_variant state (Ast.VariableMap.find x state.variables) 63 | | expr -> 64 | Error.runtime "Variant expected but got %t" (Ast.print_expression expr) 65 | 66 | let rec eval_const state = function 67 | | Ast.Const c -> c 68 | | Ast.Var x -> eval_const state (Ast.VariableMap.find x state.variables) 69 | | expr -> 70 | Error.runtime "Const expected but got %t" (Ast.print_expression expr) 71 | 72 | let rec match_pattern_with_expression state pat expr = 73 | match pat with 74 | | Ast.PVar x -> Ast.VariableMap.singleton x expr 75 | | Ast.PAnnotated (pat, _) -> match_pattern_with_expression state pat expr 76 | | Ast.PAs (pat, x) -> 77 | let subst = match_pattern_with_expression state pat expr in 78 | Ast.VariableMap.add x expr subst 79 | | Ast.PTuple pats -> 80 | let exprs = eval_tuple state expr in 81 | List.fold_left2 82 | (fun subst pat expr -> 83 | let subst' = match_pattern_with_expression state pat expr in 84 | Ast.VariableMap.union (fun _ _ _ -> assert false) subst subst') 85 | Ast.VariableMap.empty pats exprs 86 | | Ast.PVariant (label, pat) -> ( 87 | match (pat, eval_variant state expr) with 88 | | None, (label', None) when label = label' -> Ast.VariableMap.empty 89 | | Some pat, (label', Some expr) when label = label' -> 90 | match_pattern_with_expression state pat expr 91 | | _, _ -> raise PatternMismatch) 92 | | Ast.PConst c when Const.equal c (eval_const state expr) -> 93 | Ast.VariableMap.empty 94 | | Ast.PNonbinding -> Ast.VariableMap.empty 95 | | _ -> raise PatternMismatch 96 | 97 | let substitute subst comp = 98 | let subst = Ast.VariableMap.map (Ast.refresh_expression []) subst in 99 | Ast.substitute_computation subst comp 100 | 101 | let rec eval_function state = function 102 | | Ast.Lambda (pat, comp) -> 103 | fun arg -> 104 | let subst = match_pattern_with_expression state pat arg in 105 | substitute subst comp 106 | | Ast.RecLambda (f, (pat, comp)) as expr -> 107 | fun arg -> 108 | let subst = 109 | match_pattern_with_expression state pat arg 110 | |> Ast.VariableMap.add f expr 111 | in 112 | substitute subst comp 113 | | Ast.Var x -> ( 114 | match Ast.VariableMap.find_opt x state.variables with 115 | | Some expr -> eval_function state expr 116 | | None -> Ast.VariableMap.find x state.builtin_functions) 117 | | expr -> 118 | Error.runtime "Function expected but got %t" (Ast.print_expression expr) 119 | 120 | let step_in_context step state redCtx ctx term = 121 | let terms' = step state term in 122 | List.map (fun (red, term') -> (redCtx red, ctx term')) terms' 123 | 124 | let rec step_computation state = function 125 | | Ast.Return _ -> [] 126 | | Ast.Operation ((Ast.InterruptHandler h as out), comp) -> ( 127 | let comps' = 128 | step_in_context step_computation state 129 | (fun red -> SignalCtx red) 130 | (fun comp' -> Ast.Operation (out, comp')) 131 | comp 132 | in 133 | match comp with 134 | | Ast.Operation (Ast.InterruptHandler _, _) -> comps' 135 | | Ast.Operation (out, cont') -> 136 | ( ComputationRedex PromiseSignal, 137 | Ast.Operation (out, Ast.Operation (Ast.InterruptHandler h, cont')) 138 | ) 139 | :: comps' 140 | | _ -> comps') 141 | | Ast.Operation (out, comp) -> 142 | step_in_context step_computation state 143 | (fun red -> SignalCtx red) 144 | (fun comp' -> Ast.Operation (out, comp')) 145 | comp 146 | | Ast.Interrupt (op, expr, comp) -> ( 147 | let comps' = 148 | step_in_context step_computation state 149 | (fun red -> InterruptCtx red) 150 | (fun comp' -> Ast.Interrupt (op, expr, comp')) 151 | comp 152 | in 153 | match comp with 154 | | Ast.Return expr -> 155 | (ComputationRedex InterruptReturn, Ast.Return expr) :: comps' 156 | | Ast.Operation (out, comp) -> 157 | (ComputationRedex InterruptSignal, step_in_out state op expr comp out) 158 | :: comps' 159 | | _ -> comps') 160 | | Ast.Match (expr, cases) -> 161 | let rec find_case = function 162 | | (pat, comp) :: cases -> ( 163 | match match_pattern_with_expression state pat expr with 164 | | subst -> [ (ComputationRedex Match, substitute subst comp) ] 165 | | exception PatternMismatch -> find_case cases) 166 | | [] -> [] 167 | in 168 | find_case cases 169 | | Ast.Apply (expr1, expr2) -> 170 | let f = eval_function state expr1 in 171 | [ (ComputationRedex ApplyFun, f expr2) ] 172 | | Ast.Do (comp1, comp2) -> ( 173 | let comps1' = 174 | step_in_context step_computation state 175 | (fun red -> DoCtx red) 176 | (fun comp1' -> Ast.Do (comp1', comp2)) 177 | comp1 178 | in 179 | match comp1 with 180 | | Ast.Return expr -> 181 | let pat, comp2' = comp2 in 182 | let subst = match_pattern_with_expression state pat expr in 183 | (ComputationRedex DoReturn, substitute subst comp2') :: comps1' 184 | | Ast.Operation (out, comp1') -> 185 | ( ComputationRedex DoSignal, 186 | Ast.Operation (out, Ast.Do (comp1', comp2)) ) 187 | :: comps1' 188 | | _ -> comps1') 189 | | Ast.Await (expr, (pat, comp)) -> ( 190 | match expr with 191 | | Ast.Fulfill expr -> 192 | let subst = match_pattern_with_expression state pat expr in 193 | [ (ComputationRedex AwaitFulfill, substitute subst comp) ] 194 | | _ -> []) 195 | | Ast.Unbox (expr, (pat, comp)) -> ( 196 | match expr with 197 | | Ast.Boxed expr -> 198 | let subst = match_pattern_with_expression state pat expr in 199 | [ (ComputationRedex Unbox, substitute subst comp) ] 200 | | Ast.Var x -> 201 | let expr' = Ast.VariableMap.find x state.variables in 202 | [ (ComputationRedex Unbox, Ast.Unbox (expr', (pat, comp))) ] 203 | | _ -> 204 | Error.runtime "Expected boxed expresion but got %t instead." 205 | (Ast.print_expression expr)) 206 | 207 | and step_in_out state op expr cont = function 208 | | Ast.Signal (op', expr') -> 209 | Ast.Operation (Ast.Signal (op', expr'), Ast.Interrupt (op, expr, cont)) 210 | | Ast.InterruptHandler 211 | { 212 | operation = op'; 213 | handler = 214 | { payload_pattern; resumption_pattern; state_pattern; body } as h; 215 | state_value; 216 | promise; 217 | } 218 | when op = op' -> 219 | let resumption = 220 | let s = Ast.Variable.fresh "s'" in 221 | let p' = Ast.Variable.fresh "p'" in 222 | Ast.Lambda 223 | ( Ast.PVar s, 224 | Ast.Operation 225 | ( Ast.InterruptHandler 226 | { 227 | operation = op'; 228 | handler = h; 229 | state_value = Ast.Var s; 230 | promise = p'; 231 | }, 232 | Ast.Return (Ast.Var p') ) ) 233 | in 234 | let subst = 235 | match_pattern_with_expression state 236 | (Ast.PTuple [ payload_pattern; resumption_pattern; state_pattern ]) 237 | (Ast.Tuple [ expr; resumption; state_value ]) 238 | in 239 | let body' = substitute subst body in 240 | 241 | Ast.Do (body', (Ast.PVar promise, Ast.Interrupt (op, expr, cont))) 242 | | Ast.InterruptHandler h -> 243 | Ast.Operation (Ast.InterruptHandler h, Ast.Interrupt (op, expr, cont)) 244 | | Ast.Spawn comp -> 245 | Ast.Operation (Ast.Spawn comp, Ast.Interrupt (op, expr, cont)) 246 | 247 | let rec step_process state = function 248 | | Ast.Run comp -> ( 249 | let comps' = 250 | step_computation state comp 251 | |> List.map (fun (red, comp') -> (RunCtx red, Ast.Run comp')) 252 | in 253 | match comp with 254 | | Ast.Operation (Ast.Signal (op, expr), comp') -> 255 | (ProcessRedex RunSignal, Ast.SignalProc (op, expr, Ast.Run comp')) 256 | :: comps' 257 | | Ast.Operation (Ast.Spawn comp1, comp2) -> 258 | (ProcessRedex RunSpawn, Ast.Parallel (Ast.Run comp1, Ast.Run comp2)) 259 | :: (ProcessRedex RunSpawn, Ast.Parallel (Ast.Run comp2, Ast.Run comp1)) 260 | :: comps' 261 | | _ -> comps') 262 | | Ast.Parallel (proc1, proc2) -> 263 | let proc1_first = 264 | let procs' = 265 | step_in_context step_process state 266 | (fun red -> LeftCtx red) 267 | (fun proc1' -> Ast.Parallel (proc1', proc2)) 268 | proc1 269 | in 270 | match proc1 with 271 | | Ast.SignalProc (op, expr, proc1') -> 272 | ( ProcessRedex ParallelSignal1, 273 | Ast.SignalProc 274 | ( op, 275 | expr, 276 | Ast.Parallel (proc1', Ast.InterruptProc (op, expr, proc2)) ) 277 | ) 278 | :: procs' 279 | | _ -> procs' 280 | and proc2_first = 281 | let procs' = 282 | step_in_context step_process state 283 | (fun red -> RightCtx red) 284 | (fun proc2' -> Ast.Parallel (proc1, proc2')) 285 | proc2 286 | in 287 | match proc2 with 288 | | Ast.SignalProc (op, expr, proc2') -> 289 | ( ProcessRedex ParallelSignal2, 290 | Ast.SignalProc 291 | ( op, 292 | expr, 293 | Ast.Parallel (Ast.InterruptProc (op, expr, proc1), proc2') ) 294 | ) 295 | :: procs' 296 | | _ -> procs' 297 | in 298 | proc1_first @ proc2_first 299 | | Ast.InterruptProc (op, expr, proc) -> ( 300 | let procs' = 301 | step_in_context step_process state 302 | (fun red -> InterruptProcCtx red) 303 | (fun proc' -> Ast.InterruptProc (op, expr, proc')) 304 | proc 305 | in 306 | match proc with 307 | | Ast.Run comp -> 308 | (ProcessRedex InterruptRun, Ast.Run (Ast.Interrupt (op, expr, comp))) 309 | :: procs' 310 | | Ast.Parallel (proc1, proc2) -> 311 | ( ProcessRedex InterruptParallel, 312 | Ast.Parallel 313 | ( Ast.InterruptProc (op, expr, proc1), 314 | Ast.InterruptProc (op, expr, proc2) ) ) 315 | :: procs' 316 | | Ast.SignalProc (op', expr', proc') -> 317 | ( ProcessRedex InterruptSignal, 318 | Ast.SignalProc (op', expr', Ast.InterruptProc (op, expr, proc')) ) 319 | :: procs' 320 | | _ -> procs') 321 | | Ast.SignalProc (op, expr, proc) -> 322 | step_in_context step_process state 323 | (fun red -> SignalProcCtx red) 324 | (fun proc' -> Ast.SignalProc (op, expr, proc')) 325 | proc 326 | 327 | let incoming_operation proc op expr = Ast.InterruptProc (op, expr, proc) 328 | 329 | let eval_top_let state x expr = 330 | { state with variables = Ast.VariableMap.add x expr state.variables } 331 | 332 | let add_external_function x def state = 333 | { 334 | state with 335 | builtin_functions = Ast.VariableMap.add x def state.builtin_functions; 336 | } 337 | 338 | type top_step = 339 | | TopSignal of Ast.opsym * Ast.expression * Ast.process 340 | | Step of Ast.process 341 | 342 | let top_steps state proc = 343 | let steps = 344 | step_process state proc |> List.map (fun (red, proc) -> (red, Step proc)) 345 | in 346 | match proc with 347 | | Ast.SignalProc (op, expr, proc) -> 348 | (ProcessRedex TopSignal, TopSignal (op, expr, proc)) :: steps 349 | | _ -> steps 350 | -------------------------------------------------------------------------------- /src/core/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | open Utils 4 | 5 | let reserved = Desugarer.StringMap.of_seq @@ List.to_seq [ 6 | ("and", AND); 7 | ("at", AT); 8 | ("await", AWAIT); 9 | ("as", AS); 10 | ("asr", ASR); 11 | ("begin", BEGIN); 12 | ("else", ELSE); 13 | ("end", END); 14 | ("false", BOOL false); 15 | ("fun", FUN); 16 | ("function", FUNCTION); 17 | ("if", IF); 18 | ("in", IN); 19 | ("land", LAND); 20 | ("let", LET); 21 | ("lor", LOR); 22 | ("lsl", LSL); 23 | ("lsr", LSR); 24 | ("lxor", LXOR); 25 | ("match", MATCH); 26 | ("mod", MOD); 27 | ("of", OF); 28 | ("or", OR); 29 | ("operation", OPERATION); 30 | ("promise", PROMISE); 31 | ("rec", REC); 32 | ("run", RUN); 33 | ("send", SEND); 34 | ("spawn", SPAWN); 35 | ("then", THEN); 36 | ("true", BOOL true); 37 | ("type", TYPE); 38 | ("unbox", UNBOX); 39 | ("with", WITH); 40 | ("when", WHEN) 41 | ] 42 | 43 | let escaped_characters = [ 44 | ("\"", "\""); 45 | ("\\", "\\"); 46 | ("\'", "'"); 47 | ("n", "\n"); 48 | ("t", "\t"); 49 | ("b", "\b"); 50 | ("r", "\r"); 51 | (" ", " "); 52 | ] 53 | 54 | } 55 | 56 | let lname = ( ['a'-'z'] ['_' 'a'-'z' 'A'-'Z' '0'-'9' '\'']* 57 | | ['_' 'a'-'z'] ['_' 'a'-'z' 'A'-'Z' '0'-'9' '\'']+) 58 | 59 | let uname = ['A'-'Z'] ['_' 'a'-'z' 'A'-'Z' '0'-'9' '\'']* 60 | 61 | let hexdig = ['0'-'9' 'a'-'f' 'A'-'F'] 62 | 63 | let int = ['0'-'9'] ['0'-'9' '_']* 64 | 65 | let xxxint = 66 | ( ("0x" | "0X") hexdig (hexdig | '_')* 67 | | ("0o" | "0O") ['0'-'7'] ['0'-'7' '_']* 68 | | ("0b" | "0B") ['0' '1'] ['0' '1' '_']*) 69 | 70 | let float = 71 | '-'? ['0'-'9'] ['0'-'9' '_']* 72 | (('.' ['0'-'9' '_']*) (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? | 73 | ('.' ['0'-'9' '_']*)? (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)) 74 | 75 | let operatorchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '.' '<' '=' '>' '?' '@' '^' '|' '~'] 76 | 77 | let prefixop = ['~' '?' '!'] operatorchar* 78 | let infixop0 = ['=' '<' '>' '|' '&' '$'] operatorchar* 79 | let infixop1 = ['@' '^'] operatorchar* 80 | let infixop2 = ['+' '-'] operatorchar* 81 | let infixop3 = ['*' '/' '%'] operatorchar* 82 | let infixop4 = "**" operatorchar* 83 | 84 | rule token = parse 85 | | '\n' { Lexing.new_line lexbuf; token lexbuf } 86 | | [' ' '\r' '\t'] { token lexbuf } 87 | | "(*" { comment 0 lexbuf } 88 | | int { INT (int_of_string (Lexing.lexeme lexbuf)) } 89 | | xxxint { try 90 | INT (int_of_string (Lexing.lexeme lexbuf)) 91 | with Failure _ -> Error.syntax ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) "Invalid integer constant" 92 | } 93 | | float { FLOAT (float_of_string(Lexing.lexeme lexbuf)) } 94 | | '"' { STRING (string "" lexbuf) } 95 | | lname { let s = Lexing.lexeme lexbuf in 96 | match Desugarer.StringMap.find_opt s reserved with 97 | | Some t -> t 98 | | None -> LNAME s 99 | } 100 | | uname { UNAME (Lexing.lexeme lexbuf) } 101 | | '\'' lname { let str = Lexing.lexeme lexbuf in 102 | PARAM (String.sub str 1 (String.length str - 1)) } 103 | | '_' { UNDERSCORE } 104 | | '(' { LPAREN } 105 | | ')' { RPAREN } 106 | | '[' { LBRACK } 107 | | ']' { RBRACK } 108 | | "[|" { LBOXED } 109 | | "|]" { RBOXED } 110 | | "<<" { LPROMISE } 111 | | ">>" { RPROMISE } 112 | | "::" { CONS } 113 | | ':' { COLON } 114 | | ',' { COMMA } 115 | | '|' { BAR } 116 | | "||" { BARBAR } 117 | | ';' { SEMI } 118 | | "->" { ARROW } 119 | | '=' { EQUAL } 120 | | '*' { STAR } 121 | | '+' { PLUS } 122 | | '-' { MINUS } 123 | | "-." { MINUSDOT } 124 | | '&' { AMPER } 125 | | "&&" { AMPERAMPER } 126 | | prefixop { PREFIXOP(Lexing.lexeme lexbuf) } 127 | | ":=" { INFIXOP0(":=") } 128 | | infixop0 { INFIXOP0(Lexing.lexeme lexbuf) } 129 | | infixop1 { INFIXOP1(Lexing.lexeme lexbuf) } 130 | | infixop2 { INFIXOP2(Lexing.lexeme lexbuf) } 131 | (* infixop4 comes before infixop3 because ** would otherwise match infixop3 *) 132 | | infixop4 { INFIXOP4(Lexing.lexeme lexbuf) } 133 | | infixop3 { INFIXOP3(Lexing.lexeme lexbuf) } 134 | | eof { EOF } 135 | 136 | and comment n = parse 137 | | "*)" { if n = 0 then token lexbuf else comment (n - 1) lexbuf } 138 | | "(*" { comment (n + 1) lexbuf } 139 | | '\n' { Lexing.new_line lexbuf; comment n lexbuf } 140 | | _ { comment n lexbuf } 141 | | eof { Error.syntax ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) "Unterminated comment" } 142 | 143 | and string acc = parse 144 | | '"' { acc } 145 | | '\\' { let esc = escaped lexbuf in string (acc ^ esc) lexbuf } 146 | | [^'"' '\\']* { string (acc ^ (Lexing.lexeme lexbuf)) lexbuf } 147 | | eof { Error.syntax ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) "Unterminated string %s" acc} 148 | 149 | and escaped = parse 150 | | _ { let str = Lexing.lexeme lexbuf in 151 | try List.assoc str escaped_characters 152 | with Not_found -> Error.syntax ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) "Unknown escaped character %s" str 153 | } 154 | 155 | { 156 | let read_file parser fn = 157 | try 158 | let fh = open_in fn in 159 | let lex = Lexing.from_channel fh in 160 | lex.Lexing.lex_curr_p <- {lex.Lexing.lex_curr_p with Lexing.pos_fname = fn}; 161 | try 162 | let terms = parser lex in 163 | close_in fh; 164 | terms 165 | with 166 | (* Close the file in case of any parsing errors. *) 167 | Error.Error err -> close_in fh; raise (Error.Error err) 168 | with 169 | (* Any errors when opening or closing a file are fatal. *) 170 | Sys_error msg -> Error.fatal "%s" msg 171 | } 172 | -------------------------------------------------------------------------------- /src/core/loader.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | let parse_commands lexbuf = 4 | try Parser.commands Lexer.token lexbuf with 5 | | Parser.Error -> 6 | Error.syntax 7 | ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) 8 | "parser error" 9 | | Failure failmsg when failmsg = "lexing: empty token" -> 10 | Error.syntax 11 | ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) 12 | "unrecognised symbol." 13 | 14 | type state = { 15 | desugarer : Desugarer.state; 16 | interpreter : Interpreter.state; 17 | typechecker : Typechecker.state; 18 | top_computations : Ast.computation list; 19 | } 20 | 21 | let initial_state = 22 | let load_function state (x, ty_sch, def) = 23 | let desugarer_state', x' = 24 | Desugarer.add_external_variable x state.desugarer 25 | in 26 | let interpreter_state' = 27 | Interpreter.add_external_function x' def state.interpreter 28 | in 29 | let typechecker_state' = 30 | Typechecker.add_external_function x' ty_sch state.typechecker 31 | in 32 | { 33 | state with 34 | desugarer = desugarer_state'; 35 | interpreter = interpreter_state'; 36 | typechecker = typechecker_state'; 37 | } 38 | in 39 | { 40 | desugarer = Desugarer.initial_state; 41 | interpreter = Interpreter.initial_state; 42 | typechecker = Typechecker.initial_state; 43 | top_computations = []; 44 | } 45 | |> fun state -> List.fold load_function state BuiltIn.functions 46 | 47 | let execute_command state = function 48 | | Ast.TyDef ty_defs -> 49 | let typechecker_state' = 50 | Typechecker.add_type_definitions state.typechecker ty_defs 51 | in 52 | { state with typechecker = typechecker_state' } 53 | | Ast.TopLet (x, expr) -> 54 | let interpreter_state' = 55 | Interpreter.eval_top_let state.interpreter x expr 56 | in 57 | let typechecker_state' = 58 | Typechecker.add_top_definition state.typechecker x expr 59 | in 60 | { 61 | state with 62 | interpreter = interpreter_state'; 63 | typechecker = typechecker_state'; 64 | } 65 | | Ast.TopDo comp -> 66 | let _ = Typechecker.infer state.typechecker comp in 67 | { state with top_computations = comp :: state.top_computations } 68 | | Ast.OpSymDef (op, ty) -> 69 | let typechecker_state' = 70 | Typechecker.add_operation state.typechecker op ty 71 | in 72 | { state with typechecker = typechecker_state' } 73 | 74 | let load_commands state cmds = 75 | let desugarer_state', cmds' = 76 | List.fold_map Desugarer.desugar_command state.desugarer cmds 77 | in 78 | let state' = { state with desugarer = desugarer_state' } in 79 | List.fold_left execute_command state' cmds' 80 | 81 | let load_source state source = 82 | let lexbuf = Lexing.from_string source in 83 | let cmds = parse_commands lexbuf in 84 | load_commands state cmds 85 | 86 | let load_file state source = 87 | let cmds = Lexer.read_file parse_commands source in 88 | load_commands state cmds 89 | 90 | let parse_payload state op input = 91 | let lexbuf = Lexing.from_string input in 92 | let term = Parser.payload Lexer.token lexbuf in 93 | let expr' = Desugarer.desugar_pure_expression state.desugarer term in 94 | ignore (Typechecker.check_payload state.typechecker op expr'); 95 | expr' 96 | 97 | let make_process state = 98 | match state.top_computations with 99 | | [] -> Ast.Run (Ast.Return (Ast.Tuple [])) 100 | | comp :: comps -> 101 | List.fold_left 102 | (fun proc comp -> Ast.Parallel (proc, Ast.Run comp)) 103 | (Ast.Run comp) comps 104 | 105 | (** The module Stdlib_aeff is automatically generated from stdlib.aeff. Check the dune file for details. *) 106 | let stdlib_source = Stdlib_aeff.contents 107 | -------------------------------------------------------------------------------- /src/core/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Syntax 3 | open Utils 4 | open Utils.Location 5 | %} 6 | 7 | %token LPAREN RPAREN LBRACK RBRACK LPROMISE RPROMISE 8 | %token COLON COMMA SEMI EQUAL CONS 9 | %token BEGIN END 10 | %token LNAME 11 | %token UNDERSCORE AS 12 | %token INT 13 | %token STRING 14 | %token BOOL 15 | %token FLOAT 16 | %token UNAME 17 | %token PARAM 18 | %token TYPE ARROW OF 19 | %token MATCH WITH FUNCTION WHEN 20 | %token AWAIT PROMISE SEND UNBOX LBOXED RBOXED 21 | %token RUN LET REC AND IN OPERATION SPAWN 22 | %token FUN BAR BARBAR 23 | %token IF THEN ELSE 24 | %token PLUS STAR MINUS MINUSDOT 25 | %token LSL LSR ASR 26 | %token MOD OR 27 | %token AMPER AMPERAMPER 28 | %token LAND LOR LXOR 29 | %token PREFIXOP INFIXOP0 INFIXOP1 INFIXOP2 INFIXOP3 INFIXOP4 30 | %token AT 31 | %token EOF 32 | 33 | %nonassoc ARROW IN 34 | %right SEMI 35 | %nonassoc ELSE 36 | %right OR BARBAR 37 | %right AMPER AMPERAMPER 38 | %left INFIXOP0 EQUAL 39 | %right INFIXOP1 40 | %right CONS 41 | %left INFIXOP2 PLUS MINUS MINUSDOT 42 | %left INFIXOP3 STAR MOD LAND LOR LXOR 43 | %right INFIXOP4 LSL LSR ASR 44 | 45 | %start payload 46 | %start commands 47 | 48 | %% 49 | 50 | (* Toplevel syntax *) 51 | 52 | (* If you're going to "optimize" this, please of_lexeme sure we don't require;; at the 53 | end of the file. *) 54 | commands: 55 | | EOF 56 | { [] } 57 | | cmd = command cmds = commands 58 | { cmd :: cmds } 59 | 60 | (* Things that can be defined on toplevel. *) 61 | command: 62 | | TYPE defs = separated_nonempty_list(AND, ty_def) 63 | { TyDef defs } 64 | | LET x = ident t = lambdas0(EQUAL) 65 | { TopLet (x, t) } 66 | | LET REC def = let_rec_def 67 | { let (f, t) = def in TopLetRec (f, t) } 68 | | RUN trm = term 69 | { TopDo trm } 70 | | OPERATION op = operation COLON t = ty 71 | { Operation (op, t) } 72 | 73 | payload: 74 | | trm = term EOF 75 | { trm } 76 | 77 | (* Main syntax tree *) 78 | 79 | optparams: 80 | | 81 | { (None, None) } 82 | | r = ident 83 | { (Some r, None) } 84 | | r = ident s = ident 85 | { (Some r, Some s) } 86 | 87 | optstate: 88 | | 89 | { None } 90 | | AT t = simple_term 91 | { Some t} 92 | 93 | term: mark_position(plain_term) { $1 } 94 | plain_term: 95 | | MATCH t = term WITH cases = cases0(case) (* END *) 96 | { Match (t, cases) } 97 | | FUNCTION cases = cases(case) (* END *) 98 | { Function cases } 99 | | FUN t = lambdas1(ARROW) 100 | { t.it } 101 | | LET def = let_def IN t2 = term 102 | { let (p, t1) = def in Let (p, t1, t2) } 103 | | LET REC def = let_rec_def IN t2 = term 104 | { let (f, t1) = def in LetRec (f, t1, t2) } 105 | | PROMISE LPAREN op = operation p1 = pattern rs = optparams g = guard ARROW t1 = term RPAREN st = optstate 106 | { match rs, st with 107 | | (None, None), None -> InterruptHandler { operation = op; kind = Plain; handler = (p1, g, t1)} 108 | | (Some r, None), None -> InterruptHandler { operation = op; kind = Reinstallable r; handler = (p1, g, t1)} 109 | | (Some r, Some s), Some t2 -> InterruptHandler { operation = op; kind = Stateful (r, s, t2) ; handler = (p1, g, t1)} 110 | | _, _ -> failwith "Incorrect handler syntax" 111 | } 112 | | t1 = term SEMI t2 = term 113 | { Let ({it= PNonbinding; at= t1.at}, t1, t2) } 114 | | IF t_cond = comma_term THEN t_true = term ELSE t_false = term 115 | { Conditional (t_cond, t_true, t_false) } 116 | | t = plain_comma_term 117 | { t } 118 | 119 | comma_term: mark_position(plain_comma_term) { $1 } 120 | plain_comma_term: 121 | | t = binop_term COMMA ts = separated_list(COMMA, binop_term) 122 | { Tuple (t :: ts) } 123 | | t = plain_binop_term 124 | { t } 125 | 126 | binop_term: mark_position(plain_binop_term) { $1 } 127 | plain_binop_term: 128 | | t1 = binop_term op = binop t2 = binop_term 129 | { let tuple = {it= Tuple [t1; t2]; at= of_lexeme $startpos} in 130 | Apply ({it= Var op; at=of_lexeme $startpos}, tuple) } 131 | | t1 = binop_term CONS t2 = binop_term 132 | { let tuple = {it= Tuple [t1; t2]; at= of_lexeme $startpos} in 133 | Variant (cons_label, Some tuple) } 134 | | t = plain_uminus_term 135 | { t } 136 | 137 | uminus_term: mark_position(plain_uminus_term) { $1 } 138 | plain_uminus_term: 139 | | MINUS t = uminus_term 140 | { let op_loc = of_lexeme $startpos($1) in 141 | Apply ({it= Var "(~-)"; at= op_loc}, t) } 142 | | MINUSDOT t = uminus_term 143 | { let op_loc = of_lexeme $startpos($1) in 144 | Apply ({it= Var "(~-.)"; at= op_loc}, t) } 145 | | t = plain_app_term 146 | { t } 147 | 148 | plain_app_term: 149 | | t = prefix_term ts = prefix_term+ 150 | { 151 | match t.it, ts with 152 | | Variant (lbl, None), [t] -> Variant (lbl, Some t) 153 | | Variant (lbl, _), _ -> Error.syntax ~loc:(t.at) "Label %s applied to too many argument" lbl 154 | | _, _ -> 155 | let apply t1 t2 = {it= Apply(t1, t2); at= t1.at} in 156 | (List.fold_left apply t ts).it 157 | } 158 | | t = plain_prefix_term 159 | { t } 160 | 161 | prefix_term: mark_position(plain_prefix_term) { $1 } 162 | plain_prefix_term: 163 | | op = prefixop t = simple_term 164 | { 165 | let op_loc = of_lexeme $startpos(op) in 166 | Apply ({it= Var op; at= op_loc}, t) 167 | } 168 | | SEND op = operation t = simple_term 169 | { 170 | Send (op, t) 171 | } 172 | | SPAWN t = simple_term 173 | { Spawn t } 174 | | AWAIT t = simple_term 175 | { Await t } 176 | | UNBOX t = simple_term 177 | { Unbox t } 178 | | t = plain_simple_term 179 | { t } 180 | 181 | simple_term: mark_position(plain_simple_term) { $1 } 182 | plain_simple_term: 183 | | x = ident 184 | { Var x } 185 | | lbl = UNAME 186 | { Variant (lbl, None) } 187 | | cst = const 188 | { Const cst } 189 | | LBRACK ts = separated_list(SEMI, comma_term) RBRACK 190 | { 191 | let nil = {it= Variant (Syntax.nil_label, None); at= of_lexeme $endpos} in 192 | let cons t ts = 193 | let loc = t.at in 194 | let tuple = {it= Tuple [t; ts];at= loc} in 195 | {it= Variant (Syntax.cons_label, Some tuple); at= loc} 196 | in 197 | (List.fold_right cons ts nil).it 198 | } 199 | | LPAREN RPAREN 200 | { Tuple [] } 201 | | LPAREN t = term COLON ty = ty RPAREN 202 | { Annotated (t, ty) } 203 | | LPROMISE t = term RPROMISE 204 | { 205 | Fulfill t 206 | } 207 | | LBOXED t = term RBOXED 208 | { Boxed t } 209 | | LPAREN t = plain_term RPAREN 210 | { t } 211 | | BEGIN t = plain_term END 212 | { t } 213 | 214 | (* Auxilliary definitions *) 215 | 216 | const: 217 | | n = INT 218 | { Const.of_integer n } 219 | | str = STRING 220 | { Const.of_string str } 221 | | b = BOOL 222 | { Const.of_boolean b } 223 | | f = FLOAT 224 | { Const.of_float f } 225 | 226 | case: 227 | | p = pattern ARROW t = term 228 | { (p, t) } 229 | 230 | guard: 231 | | 232 | { None } 233 | | WHEN t = term 234 | { Some t} 235 | 236 | lambdas0(SEP): 237 | | SEP t = term 238 | { t } 239 | | p = simple_pattern t = lambdas0(SEP) 240 | { {it= Lambda (p, t); at= of_lexeme $startpos} } 241 | | COLON ty = ty SEP t = term 242 | { {it= Annotated (t, ty); at= of_lexeme $startpos} } 243 | 244 | lambdas1(SEP): 245 | | p = simple_pattern t = lambdas0(SEP) 246 | { {it= Lambda (p, t); at= of_lexeme $startpos} } 247 | 248 | let_def: 249 | | p = pattern EQUAL t = term 250 | { (p, t) } 251 | | p = pattern COLON ty= ty EQUAL t = term 252 | { (p, {it= Annotated(t, ty); at= of_lexeme $startpos}) } 253 | | x = mark_position(ident) t = lambdas1(EQUAL) 254 | { ({it= PVar x.it; at= x.at}, t) } 255 | 256 | let_rec_def: 257 | | f = ident t = lambdas0(EQUAL) 258 | { (f, t) } 259 | 260 | pattern: mark_position(plain_pattern) { $1 } 261 | plain_pattern: 262 | | p = comma_pattern 263 | { p.it } 264 | | p = pattern AS x = lname 265 | { PAs (p, x) } 266 | 267 | comma_pattern: mark_position(plain_comma_pattern) { $1 } 268 | plain_comma_pattern: 269 | | ps = separated_nonempty_list(COMMA, cons_pattern) 270 | { match ps with [p] -> p.it | ps -> PTuple ps } 271 | 272 | cons_pattern: mark_position(plain_cons_pattern) { $1 } 273 | plain_cons_pattern: 274 | | p = variant_pattern 275 | { p.it } 276 | | p1 = variant_pattern CONS p2 = cons_pattern 277 | { let ptuple = {it= PTuple [p1; p2]; at= of_lexeme $startpos} in 278 | PVariant (Syntax.cons_label, Some ptuple) } 279 | 280 | variant_pattern: mark_position(plain_variant_pattern) { $1 } 281 | plain_variant_pattern: 282 | | lbl = UNAME p = simple_pattern 283 | { PVariant (lbl, Some p) } 284 | | p = simple_pattern 285 | { p.it } 286 | 287 | simple_pattern: mark_position(plain_simple_pattern) { $1 } 288 | plain_simple_pattern: 289 | | x = ident 290 | { PVar x } 291 | | lbl = UNAME 292 | { PVariant (lbl, None) } 293 | | UNDERSCORE 294 | { PNonbinding } 295 | | cst = const 296 | { PConst cst } 297 | | LBRACK ts = separated_list(SEMI, pattern) RBRACK 298 | { 299 | let nil = {it= PVariant (Syntax.nil_label, None);at= of_lexeme $endpos} in 300 | let cons t ts = 301 | let loc = t.at in 302 | let tuple = {it= PTuple [t; ts]; at= loc} in 303 | {it= PVariant (Syntax.cons_label, Some tuple); at= loc} 304 | in 305 | (List.fold_right cons ts nil).it 306 | } 307 | | LPAREN RPAREN 308 | { PTuple [] } 309 | | LPAREN p = pattern COLON t = ty RPAREN 310 | { PAnnotated (p, t) } 311 | | LPAREN p = pattern RPAREN 312 | { p.it } 313 | 314 | lname: 315 | | x = LNAME 316 | { x } 317 | 318 | tyname: 319 | | t = lname 320 | { t } 321 | 322 | operation: 323 | | t = LNAME 324 | { t } 325 | 326 | ident: 327 | | x = lname 328 | { x } 329 | | LPAREN op = binop RPAREN 330 | { op } 331 | | LPAREN op = prefixop RPAREN 332 | { op } 333 | 334 | binop: 335 | | op = binop_symbol 336 | { "(" ^ op ^ ")" } 337 | 338 | %inline binop_symbol: 339 | | OR 340 | { "or" } 341 | | BARBAR 342 | { "||" } 343 | | AMPER 344 | { "&" } 345 | | AMPERAMPER 346 | { "&&" } 347 | | op = INFIXOP0 348 | { op } 349 | | op = INFIXOP1 350 | { op } 351 | | op = INFIXOP2 352 | { op } 353 | | PLUS 354 | { "+" } 355 | | MINUSDOT 356 | { "-." } 357 | | MINUS 358 | { "-" } 359 | | EQUAL 360 | { "=" } 361 | | op = INFIXOP3 362 | { op } 363 | | STAR 364 | { "*" } 365 | | op = INFIXOP4 366 | { op } 367 | | MOD 368 | { "mod" } 369 | | LAND 370 | { "land" } 371 | | LOR 372 | { "lor" } 373 | | LXOR 374 | { "lxor" } 375 | | LSL 376 | { "lsl" } 377 | | LSR 378 | { "lsr" } 379 | | ASR 380 | { "asr" } 381 | 382 | %inline prefixop: 383 | | op = PREFIXOP 384 | { "(" ^ op ^ ")" } 385 | 386 | cases0(case): 387 | | BAR? cs = separated_list(BAR, case) 388 | { cs } 389 | 390 | cases(case): 391 | | BAR? cs = separated_nonempty_list(BAR, case) 392 | { cs } 393 | 394 | mark_position(X): 395 | x = X 396 | { {it= x; at= of_lexeme $startpos}} 397 | 398 | params: 399 | | 400 | { [] } 401 | | p = PARAM 402 | { [p] } 403 | | LPAREN ps = separated_nonempty_list(COMMA, PARAM) RPAREN 404 | { ps } 405 | 406 | ty_def: 407 | | ps = params t = tyname EQUAL x = defined_ty 408 | { (ps, t, x) } 409 | 410 | defined_ty: 411 | | variants = cases(sum_case) 412 | { TySum variants } 413 | | t = ty 414 | { TyInline t } 415 | 416 | ty: mark_position(plain_ty) { $1 } 417 | plain_ty: 418 | | t1 = ty_apply ARROW t2 = ty 419 | { TyArrow (t1, t2) } 420 | | t = plain_prod_ty 421 | { t } 422 | 423 | plain_prod_ty: 424 | | ts = separated_nonempty_list(STAR, ty_apply) 425 | { 426 | match ts with 427 | | [] -> assert false 428 | | [t] -> t.it 429 | | _ -> TyTuple ts 430 | } 431 | 432 | ty_apply: mark_position(plain_ty_apply) { $1 } 433 | plain_ty_apply: 434 | | LPAREN t = ty COMMA ts = separated_nonempty_list(COMMA, ty) RPAREN t2 = tyname 435 | { TyApply (t2, (t :: ts)) } 436 | | t = ty_apply t2 = tyname 437 | { TyApply (t2, [t]) } 438 | | t = plain_simple_ty 439 | { t } 440 | 441 | plain_simple_ty: 442 | | t = tyname 443 | { TyApply (t, []) } 444 | | LPROMISE t = ty RPROMISE 445 | { TyPromise t } 446 | | LBOXED t = ty RBOXED 447 | { TyBoxed t } 448 | | t = PARAM 449 | { TyParam t } 450 | | LPAREN t = ty RPAREN 451 | { t.it } 452 | 453 | sum_case: 454 | | lbl = UNAME 455 | { (lbl, None) } 456 | | lbl = UNAME OF t = ty 457 | { (lbl, Some t) } 458 | 459 | %% 460 | -------------------------------------------------------------------------------- /src/core/stdlib.aeff: -------------------------------------------------------------------------------- 1 | let absurd void = (match void with) 2 | 3 | (* Booleans *) 4 | let not x = if x then false else true 5 | 6 | type 'a option = None | Some of 'a 7 | let rec assoc x = function 8 | | [] -> None 9 | | (key, v) :: lst -> if x = key then Some v else assoc x lst 10 | 11 | let rec range m n = 12 | if m > n then 13 | [] 14 | else 15 | m :: range (m + 1) n 16 | 17 | let reverse lst = 18 | let rec aux acc = function 19 | | [] -> acc 20 | | x :: xs -> aux (x :: acc) xs 21 | in 22 | aux [] lst 23 | 24 | let rec map f = function 25 | | [] -> [] 26 | | x :: xs -> 27 | let y = f x in 28 | let ys = map f xs in 29 | y :: ys 30 | 31 | let hd = function 32 | | x :: _ -> x 33 | 34 | let tl = function 35 | | x :: xs -> xs 36 | 37 | let take f k = 38 | let r = range 0 k in map f r 39 | 40 | let rec foldLeft f acc = function 41 | | [] -> acc 42 | | y :: ys -> 43 | let acc' = f acc y in 44 | foldLeft f acc' ys 45 | 46 | let rec foldRight f xs acc = 47 | match xs with 48 | | [] -> acc 49 | | x :: xs -> 50 | let acc' = foldRight f xs acc in 51 | f x acc' 52 | 53 | let rec iter f = function 54 | | [] -> () 55 | | x :: xs -> f x; iter f xs 56 | 57 | let rec forall p = function 58 | | [] -> true 59 | | x :: xs -> if p x then forall p xs else false 60 | 61 | let rec exists p = function 62 | | [] -> false 63 | | x :: xs -> if p x then true else exists p xs 64 | 65 | let mem x = exists (fun x' -> x = x') 66 | let rec filter p = function 67 | | [] -> [] 68 | | x :: xs -> 69 | if p x then (x :: filter p xs) else filter p xs 70 | 71 | let complement xs ys = filter (fun x -> not (mem x ys)) xs 72 | let intersection xs ys = filter (fun x -> mem x ys) xs 73 | let rec zip xs ys = 74 | match (xs, ys) with 75 | | ([], []) -> [] 76 | | (x :: xs, y :: ys) -> (x, y) :: (zip xs ys) 77 | 78 | let rec unzip = function 79 | | [] -> ([], []) 80 | | (x, y) :: xys -> 81 | let xs, ys = unzip xys in 82 | (x :: xs, y :: ys) 83 | 84 | let rec (@) (xs, ys) = 85 | match xs with 86 | | [] -> ys 87 | | x :: xs -> x :: (xs @ ys) 88 | 89 | let rec length = function 90 | | [] -> 0 91 | | x :: xs -> length xs + 1 92 | 93 | let rec nth (x::xs) n = 94 | if n = 0 then x else nth xs (n - 1) 95 | 96 | (* Basic functions *) 97 | let abs x = if x < 0 then -x else x 98 | let min x y = if x < y then x else y 99 | let max x y = if x < y then y else x 100 | let rec gcd m n = 101 | match n with 102 | | 0 -> m 103 | | _ -> let g = gcd n in g (m mod n) 104 | 105 | let rec lcm m n = 106 | let d = gcd m n in (m * n) / d 107 | 108 | let odd x = (x mod 2) = 1 109 | let even x = (x mod 2) = 0 110 | let id x = x 111 | let compose f g x = f (g x) 112 | let (|>) x f = f x 113 | let ignore _ = () 114 | let fst (x, _) = x 115 | let snd (_, y) = y 116 | 117 | let return x = x 118 | -------------------------------------------------------------------------------- /src/core/syntax.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | type ty_name = string 4 | 5 | let bool_ty_name = "bool" 6 | let int_ty_name = "int" 7 | let unit_ty_name = "unit" 8 | let string_ty_name = "string" 9 | let float_ty_name = "float" 10 | let list_ty_name = "list" 11 | let empty_ty_name = "empty" 12 | let ref_ty_name = "ref" 13 | 14 | type ty_param = string 15 | 16 | type ty = plain_ty Location.located 17 | 18 | and plain_ty = 19 | | TyConst of Const.ty 20 | | TyApply of ty_name * ty list (** [(ty1, ty2, ..., tyn) type_name] *) 21 | | TyParam of ty_param (** ['a] *) 22 | | TyArrow of ty * ty (** [ty1 -> ty2] *) 23 | | TyPromise of ty (** [<>] *) 24 | | TyReference of ty (** [ty ref] *) 25 | | TyTuple of ty list (** [ty1 * ty2 * ... * tyn] *) 26 | | TyBoxed of ty (** [[ty]] *) 27 | 28 | type variable = string 29 | type label = string 30 | type operation = string 31 | 32 | let nil_label = "$0nil" 33 | let cons_label = "$1cons" 34 | 35 | type pattern = plain_pattern Location.located 36 | 37 | and plain_pattern = 38 | | PVar of variable 39 | | PAnnotated of pattern * ty 40 | | PAs of pattern * variable 41 | | PTuple of pattern list 42 | | PVariant of label * pattern option 43 | | PConst of Const.t 44 | | PNonbinding 45 | 46 | type term = plain_term Location.located 47 | 48 | and plain_term = 49 | | Var of variable (** variables *) 50 | | Const of Const.t (** integers, strings, booleans, and floats *) 51 | | Annotated of term * ty 52 | | Tuple of term list (** [(t1, t2, ..., tn)] *) 53 | | Variant of label * term option (** [Label] or [Label t] *) 54 | | Lambda of abstraction (** [fun p1 p2 ... pn -> t] *) 55 | | Function of abstraction list (** [function p1 -> t1 | ... | pn -> tn] *) 56 | | Let of pattern * term * term (** [let p = t1 in t2] *) 57 | | LetRec of variable * term * term (** [let rec f = t1 in t2] *) 58 | | Match of term * abstraction list 59 | (** [match t with p1 -> t1 | ... | pn -> tn] *) 60 | | Conditional of term * term * term (** [if t then t1 else t2] *) 61 | | Apply of term * term (** [t1 t2] *) 62 | | InterruptHandler of { 63 | operation : operation; 64 | kind : handler_kind; 65 | handler : guarded_abstraction; 66 | } (** [with op (p1 k -> t1) as p2] *) 67 | | Await of term (** [await t] *) 68 | | Fulfill of term (** [<>] *) 69 | | Send of operation * term (** [send op t] *) 70 | | Boxed of term (** [[t]] *) 71 | | Unbox of term (** [unbox t] *) 72 | | Spawn of term (** [spawn t] *) 73 | 74 | and abstraction = pattern * term 75 | and guarded_abstraction = pattern * term option * term 76 | 77 | and handler_kind = 78 | | Plain 79 | | Reinstallable of variable 80 | | Stateful of variable * variable * term 81 | 82 | type ty_def = 83 | | TySum of (label * ty option) list 84 | (** [Label1 of ty1 | Label2 of ty2 | ... | Labeln of tyn | Label' | Label''] *) 85 | | TyInline of ty (** [ty] *) 86 | 87 | type command = 88 | | TyDef of (ty_param list * ty_name * ty_def) list 89 | (** [type ('a...1) t1 = def1 and ... and ('a...n) tn = defn] *) 90 | | Operation of operation * ty (** [operation op : ty] *) 91 | | TopLet of variable * term (** [let x = t] *) 92 | | TopLetRec of variable * term (** [let rec f = t] *) 93 | | TopDo of term (** [do t] *) 94 | -------------------------------------------------------------------------------- /src/core/typechecker.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | type ty_scheme = Ast.ty_param list * Ast.ty 4 | 5 | type state = { 6 | global_var : ty_scheme Ast.VariableMap.t; 7 | local_var : Ast.ty Ast.VariableMap.t list; 8 | operations : Ast.ty Ast.OpSymMap.t; 9 | type_definitions : (Ast.ty_param list * Ast.ty_def) Ast.TyNameMap.t; 10 | } 11 | 12 | type constraints = { 13 | equations : (Ast.ty * Ast.ty) list; 14 | mobile_types : Ast.ty list; 15 | } 16 | 17 | let initial_state = 18 | { 19 | global_var = Ast.VariableMap.empty; 20 | local_var = [ Ast.VariableMap.empty ]; 21 | operations = Ast.OpSymMap.empty; 22 | type_definitions = 23 | (Ast.TyNameMap.empty 24 | |> Ast.TyNameMap.add Ast.bool_ty_name 25 | ([], Ast.TyInline (Ast.TyConst Const.BooleanTy)) 26 | |> Ast.TyNameMap.add Ast.int_ty_name 27 | ([], Ast.TyInline (Ast.TyConst Const.IntegerTy)) 28 | |> Ast.TyNameMap.add Ast.unit_ty_name ([], Ast.TyInline (Ast.TyTuple [])) 29 | |> Ast.TyNameMap.add Ast.string_ty_name 30 | ([], Ast.TyInline (Ast.TyConst Const.StringTy)) 31 | |> Ast.TyNameMap.add Ast.float_ty_name 32 | ([], Ast.TyInline (Ast.TyConst Const.FloatTy)) 33 | |> (let a = Ast.TyParam.fresh "ref" in 34 | Ast.TyNameMap.add Ast.ref_ty_name 35 | ([ a ], Ast.TyInline (Ast.TyReference (Ast.TyParam a)))) 36 | |> Ast.TyNameMap.add Ast.empty_ty_name ([], Ast.TySum []) 37 | |> 38 | let a = Ast.TyParam.fresh "list" in 39 | Ast.TyNameMap.add Ast.list_ty_name 40 | ( [ a ], 41 | Ast.TySum 42 | [ 43 | (Ast.nil_label, None); 44 | ( Ast.cons_label, 45 | Some 46 | (Ast.TyTuple 47 | [ 48 | Ast.TyParam a; 49 | Ast.TyApply (Ast.list_ty_name, [ Ast.TyParam a ]); 50 | ]) ); 51 | ] )); 52 | } 53 | 54 | (* Previous versions would fail those two cases 55 | type foo 'a 'b = ['a] * 'b 56 | operation bar1 : int foo = [] * int // this one is mobile, even though previous implementation would say no 57 | operation bar2 : int foo = [int] * // ok this one should fail. And it does :) 58 | 59 | type mobile_list 'm = | empty | something of ['m] * 'm list 60 | operation tasks : (unit -> int) mobile_list 61 | *) 62 | 63 | let rec is_mobile state candidates (ty : Ast.ty) : bool = 64 | match ty with 65 | | Ast.TyConst _ -> true 66 | | Ast.TyApply (ty_name, tys) -> is_apply_mobile state candidates ty_name tys 67 | | Ast.TyParam _ -> false 68 | | Ast.TyArrow _ -> false 69 | | Ast.TyTuple tys -> List.for_all (is_mobile state candidates) tys 70 | | Ast.TyPromise _ -> false 71 | | Ast.TyReference _ -> false 72 | | Ast.TyBoxed _ -> true 73 | 74 | and is_apply_mobile state (candidates : (Ast.ty_name * bool list list) list) 75 | ty_name tys : bool = 76 | let are_tys_mobile = List.map (is_mobile state candidates) tys in 77 | (* int list is same as bool list. It doesnt matter which type exactly params becomes. only if its replaced by mobile or immobile type) *) 78 | let seen_before_and_ok = 79 | match List.assoc_opt ty_name candidates with 80 | | Some options -> 81 | let rec check previous = 82 | match previous with 83 | | [] -> false 84 | | h :: t -> 85 | if 86 | List.for_all2 87 | (fun p is_ty_mobile -> p = is_ty_mobile || is_ty_mobile) 88 | h are_tys_mobile 89 | then true 90 | else check t 91 | in 92 | check options 93 | (* kinda like induction??? When we had fist met type we had to explore it. 94 | But now we can use IP and just check that it is exactly as in IP ??? *) 95 | (* We should eventually finish since there is limited combinations mobile/immobile types *) 96 | | None -> false 97 | in 98 | if seen_before_and_ok then true 99 | else 100 | let rec insert = function 101 | | [] -> [ (ty_name, [ are_tys_mobile ]) ] 102 | | (t, o) :: l when t = ty_name -> (t, are_tys_mobile :: o) :: l 103 | | h :: l -> h :: insert l 104 | in 105 | let candidates' = insert candidates in 106 | let params, ty_def = Ast.TyNameMap.find ty_name state.type_definitions in 107 | let subst = 108 | Ast.substitute_ty 109 | (List.combine params tys |> List.to_seq |> Ast.TyParamMap.of_seq) 110 | in 111 | match ty_def with 112 | | Ast.TyInline ty -> is_mobile state candidates' (subst ty) 113 | | Ast.TySum tys' -> 114 | let tys'' = 115 | List.fold_left 116 | (fun todo_tys (_lbl, ty) -> 117 | match ty with None -> todo_tys | Some ty -> ty :: todo_tys) 118 | [] tys' 119 | in 120 | List.for_all (is_mobile state candidates') (List.map subst tys'') 121 | 122 | let fresh_ty () = 123 | let a = Ast.TyParam.fresh "ty" in 124 | Ast.TyParam a 125 | 126 | let extend_variables state vars = 127 | match state.local_var with 128 | | [] -> assert false 129 | | head :: tail -> 130 | let head' = 131 | List.fold_left 132 | (fun state (x, ty) -> Ast.VariableMap.add x ty state) 133 | head vars 134 | in 135 | { state with local_var = head' :: tail } 136 | 137 | let refreshing_subst params = 138 | List.fold_left 139 | (fun subst param -> 140 | let ty = fresh_ty () in 141 | Ast.TyParamMap.add param ty subst) 142 | Ast.TyParamMap.empty params 143 | 144 | let infer_variant state lbl = 145 | let rec find = function 146 | | [] -> assert false 147 | | (_, (_, Ast.TyInline _)) :: ty_defs -> find ty_defs 148 | | (ty_name, (params, Ast.TySum variants)) :: ty_defs -> ( 149 | match List.assoc_opt lbl variants with 150 | | None -> find ty_defs 151 | | Some ty -> (ty_name, params, ty)) 152 | in 153 | let ty_name, params, ty = 154 | find (Ast.TyNameMap.bindings state.type_definitions) 155 | in 156 | let subst = refreshing_subst params in 157 | let args = List.map (fun param -> Ast.TyParamMap.find param subst) params 158 | and ty' = Option.map (Ast.substitute_ty subst) ty in 159 | (ty', Ast.TyApply (ty_name, args)) 160 | 161 | let rec infer_pattern state = function 162 | | Ast.PVar x -> 163 | let ty = fresh_ty () in 164 | (ty, [ (x, ty) ], []) 165 | | Ast.PAs (pat, x) -> 166 | let ty, vars, eqs = infer_pattern state pat in 167 | (ty, (x, ty) :: vars, eqs) 168 | | Ast.PAnnotated (pat, ty) -> 169 | let ty', vars, eqs = infer_pattern state pat in 170 | (ty, vars, (ty, ty') :: eqs) 171 | | Ast.PConst c -> (Ast.TyConst (Const.infer_ty c), [], []) 172 | | Ast.PNonbinding -> 173 | let ty = fresh_ty () in 174 | (ty, [], []) 175 | | Ast.PTuple pats -> 176 | let fold pat (tys, vars, eqs) = 177 | let ty', vars', eqs' = infer_pattern state pat in 178 | (ty' :: tys, vars' @ vars, eqs' @ eqs) 179 | in 180 | let tys, vars, eqs = List.fold_right fold pats ([], [], []) in 181 | (Ast.TyTuple tys, vars, eqs) 182 | | Ast.PVariant (lbl, pat) -> ( 183 | let ty_in, ty_out = infer_variant state lbl in 184 | match (ty_in, pat) with 185 | | None, None -> (ty_out, [], []) 186 | | Some ty_in, Some pat -> 187 | let ty, vars, eqs = infer_pattern state pat in 188 | (ty_out, vars, (ty_in, ty) :: eqs) 189 | | None, Some _ | Some _, None -> 190 | Error.typing "Variant optional argument mismatch") 191 | 192 | let infer_variable state x : Ast.ty * Ast.ty list = 193 | match Ast.VariableMap.find_opt x state.global_var with 194 | | Some (params, ty) -> 195 | let subst = refreshing_subst params in 196 | (Ast.substitute_ty subst ty, []) 197 | | None -> ( 198 | match state.local_var with 199 | | [] -> assert false 200 | | head :: tail -> ( 201 | match Ast.VariableMap.find_opt x head with 202 | | Some ty -> (ty, []) 203 | | None -> 204 | let rec find_movable local_var = 205 | match local_var with 206 | | [] -> assert false 207 | | h :: t -> ( 208 | match Ast.VariableMap.find_opt x h with 209 | | Some ty -> ty 210 | | None -> find_movable t) 211 | in 212 | let ty = find_movable tail in 213 | (ty, [ ty ]))) 214 | 215 | let combine constraints1 constraints2 = 216 | { 217 | equations = constraints1.equations @ constraints2.equations; 218 | mobile_types = constraints1.mobile_types @ constraints2.mobile_types; 219 | } 220 | 221 | let add_eqs constraints eqs = 222 | { constraints with equations = eqs @ constraints.equations } 223 | 224 | let rec infer_expression state = function 225 | | Ast.Var x -> 226 | let ty, mobiles = infer_variable state x in 227 | (ty, { equations = []; mobile_types = mobiles }) 228 | | Ast.Const c -> 229 | (Ast.TyConst (Const.infer_ty c), { equations = []; mobile_types = [] }) 230 | | Ast.Annotated (expr, ty) -> 231 | let ty', constr = infer_expression state expr in 232 | (ty, add_eqs constr [ (ty, ty') ]) 233 | | Ast.Tuple exprs -> 234 | let fold expr (tys, constr) = 235 | let ty', constr' = infer_expression state expr in 236 | (ty' :: tys, combine constr constr') 237 | in 238 | let tys, constr = 239 | List.fold_right fold exprs ([], { equations = []; mobile_types = [] }) 240 | in 241 | (Ast.TyTuple tys, constr) 242 | | Ast.Lambda abs -> 243 | let ty, ty', constr = infer_abstraction state abs in 244 | (Ast.TyArrow (ty, ty'), constr) 245 | | Ast.RecLambda (f, abs) -> 246 | let f_ty = fresh_ty () in 247 | let state' = extend_variables state [ (f, f_ty) ] in 248 | let ty, ty', constr = infer_abstraction state' abs in 249 | let out_ty = Ast.TyArrow (ty, ty') in 250 | (out_ty, add_eqs constr [ (f_ty, out_ty) ]) 251 | | Ast.Fulfill expr -> 252 | let ty, constr = infer_expression state expr in 253 | (Ast.TyPromise ty, constr) 254 | | Ast.Reference expr_ref -> 255 | let ty, constr = infer_expression state !expr_ref in 256 | (Ast.TyReference ty, constr) 257 | | Ast.Variant (lbl, expr) -> ( 258 | let ty_in, ty_out = infer_variant state lbl in 259 | match (ty_in, expr) with 260 | | None, None -> (ty_out, { equations = []; mobile_types = [] }) 261 | | Some ty_in, Some expr -> 262 | let ty, constr = infer_expression state expr in 263 | (ty_out, add_eqs constr [ (ty_in, ty) ]) 264 | | None, Some _ | Some _, None -> 265 | Error.typing "Variant optional argument mismatch") 266 | | Ast.Boxed expr -> 267 | let state' = 268 | { state with local_var = Ast.VariableMap.empty :: state.local_var } 269 | in 270 | let ty, constr = infer_expression state' expr in 271 | (Ast.TyBoxed ty, constr) 272 | 273 | and infer_computation state = function 274 | | Ast.Return expr -> 275 | let ty, eqs = infer_expression state expr in 276 | (ty, eqs) 277 | | Ast.Do (comp1, comp2) -> 278 | let ty1, constr1 = infer_computation state comp1 in 279 | let ty1', ty2, constr2 = infer_abstraction state comp2 in 280 | (ty2, combine (add_eqs constr1 [ (ty1, ty1') ]) constr2) 281 | | Ast.Apply (e1, e2) -> 282 | let t1, constr1 = infer_expression state e1 283 | and t2, constr2 = infer_expression state e2 284 | and a = fresh_ty () in 285 | (a, combine (add_eqs constr1 [ (t1, Ast.TyArrow (t2, a)) ]) constr2) 286 | | Ast.Operation (Ast.Signal (op, expr), comp) | Ast.Interrupt (op, expr, comp) 287 | -> 288 | let ty1 = Ast.OpSymMap.find op state.operations 289 | and ty2, constr1 = infer_expression state expr 290 | and ty3, constr2 = infer_computation state comp in 291 | (ty3, combine (add_eqs constr1 [ (ty1, ty2) ]) constr2) 292 | | Ast.Await (e, abs) -> 293 | let pty1, constr1 = infer_expression state e 294 | and ty1, ty2, constr2 = infer_abstraction state abs in 295 | (ty2, combine (add_eqs constr1 [ (pty1, Ast.TyPromise ty1) ]) constr2) 296 | | Ast.Match (e, cases) -> 297 | let ty1, constr = infer_expression state e and ty2 = fresh_ty () in 298 | let fold constr abs = 299 | let ty1', ty2', constr' = infer_abstraction state abs in 300 | combine (add_eqs constr' [ (ty1, ty1'); (ty2, ty2') ]) constr 301 | in 302 | (ty2, List.fold_left fold constr cases) 303 | | Ast.Operation 304 | ( InterruptHandler 305 | { 306 | operation; 307 | handler = 308 | { payload_pattern; resumption_pattern; state_pattern; body }; 309 | state_value; 310 | promise; 311 | }, 312 | comp ) -> 313 | let ty_payload, vars_payload, eqs_payload = 314 | infer_pattern state payload_pattern 315 | in 316 | let ty_resumption, vars_resumption, eqs_resumption = 317 | infer_pattern state resumption_pattern 318 | in 319 | let ty_state, vars_state, eqs_state = infer_pattern state state_pattern in 320 | let ty_promise = Ast.TyPromise (fresh_ty ()) in 321 | 322 | let ty_payload' = Ast.OpSymMap.find operation state.operations in 323 | let ty_resumption' = Ast.TyArrow (ty_state, ty_promise) in 324 | let ty_state', constr_state_value = infer_expression state state_value in 325 | let ty_promise', constr_body = 326 | let state' = 327 | extend_variables state (vars_payload @ vars_resumption @ vars_state) 328 | in 329 | infer_computation state' body 330 | in 331 | 332 | let ty_cont, constr_cont = 333 | let state'' = extend_variables state [ (promise, ty_promise) ] in 334 | infer_computation state'' comp 335 | in 336 | 337 | let eqs = 338 | [ 339 | (ty_payload, ty_payload'); 340 | (ty_resumption, ty_resumption'); 341 | (ty_state, ty_state'); 342 | (ty_promise, ty_promise'); 343 | ] 344 | @ eqs_payload @ eqs_resumption @ eqs_state 345 | in 346 | 347 | let constr = 348 | combine 349 | (add_eqs constr_state_value eqs) 350 | (combine constr_body constr_cont) 351 | in 352 | 353 | (ty_cont, constr) 354 | | Ast.Unbox (expr, abs) -> 355 | let ty, constr1 = infer_expression state expr in 356 | let ty' = fresh_ty () in 357 | let ty_boxed' = Ast.TyBoxed ty' in 358 | let ty1, ty2, constr2 = infer_abstraction state abs in 359 | (ty2, combine (add_eqs constr1 [ (ty, ty_boxed'); (ty', ty1) ]) constr2) 360 | | Ast.Operation (Ast.Spawn comp1, comp2) -> 361 | let state' = 362 | { state with local_var = Ast.VariableMap.empty :: state.local_var } 363 | in 364 | let _ty1, constraints1 = infer_computation state' comp1 in 365 | let ty2, constraints2 = infer_computation state comp2 in 366 | (ty2, combine constraints1 constraints2) 367 | 368 | and infer_abstraction state (pat, comp) = 369 | let ty, vars, eqs = infer_pattern state pat in 370 | let state' = extend_variables state vars in 371 | let ty', constr = infer_computation state' comp in 372 | (ty, ty', add_eqs constr eqs) 373 | 374 | let subst_equations sbst = 375 | let subst_equation (t1, t2) = 376 | (Ast.substitute_ty sbst t1, Ast.substitute_ty sbst t2) 377 | in 378 | List.map subst_equation 379 | 380 | let add_subst a t sbst = Ast.TyParamMap.add a (Ast.substitute_ty sbst t) sbst 381 | 382 | let rec occurs a = function 383 | | Ast.TyParam a' -> a = a' 384 | | Ast.TyConst _ -> false 385 | | Ast.TyArrow (ty1, ty2) -> occurs a ty1 || occurs a ty2 386 | | Ast.TyApply (_, tys) -> List.exists (occurs a) tys 387 | | Ast.TyTuple tys -> List.exists (occurs a) tys 388 | | Ast.TyPromise ty -> occurs a ty 389 | | Ast.TyReference ty -> occurs a ty 390 | | Ast.TyBoxed ty -> occurs a ty 391 | 392 | let is_transparent_type state ty_name = 393 | match Ast.TyNameMap.find ty_name state.type_definitions with 394 | | _, Ast.TySum _ -> false 395 | | _, Ast.TyInline _ -> true 396 | 397 | let unfold state ty_name args = 398 | match Ast.TyNameMap.find ty_name state.type_definitions with 399 | | _, Ast.TySum _ -> assert false 400 | | params, Ast.TyInline ty -> 401 | let subst = 402 | List.combine params args |> List.to_seq |> Ast.TyParamMap.of_seq 403 | in 404 | Ast.substitute_ty subst ty 405 | 406 | let rec unify state = function 407 | | [] -> Ast.TyParamMap.empty 408 | | (t1, t2) :: eqs when t1 = t2 -> unify state eqs 409 | | (Ast.TyApply (ty_name1, args1), Ast.TyApply (ty_name2, args2)) :: eqs 410 | when ty_name1 = ty_name2 -> 411 | unify state (List.combine args1 args2 @ eqs) 412 | | (Ast.TyApply (ty_name, args), ty) :: eqs 413 | when is_transparent_type state ty_name -> 414 | unify state ((unfold state ty_name args, ty) :: eqs) 415 | | (ty, Ast.TyApply (ty_name, args)) :: eqs 416 | when is_transparent_type state ty_name -> 417 | unify state ((ty, unfold state ty_name args) :: eqs) 418 | | (Ast.TyTuple tys1, Ast.TyTuple tys2) :: eqs 419 | when List.length tys1 = List.length tys2 -> 420 | unify state (List.combine tys1 tys2 @ eqs) 421 | | (Ast.TyArrow (t1, t1'), Ast.TyArrow (t2, t2')) :: eqs -> 422 | unify state ((t1, t2) :: (t1', t2') :: eqs) 423 | | (Ast.TyPromise ty1, Ast.TyPromise ty2) :: eqs -> 424 | unify state ((ty1, ty2) :: eqs) 425 | | (Ast.TyReference ty1, Ast.TyReference ty2) :: eqs -> 426 | unify state ((ty1, ty2) :: eqs) 427 | | (Ast.TyBoxed ty1, Ast.TyBoxed ty2) :: eqs -> unify state ((ty1, ty2) :: eqs) 428 | | (Ast.TyParam a, t) :: eqs when not (occurs a t) -> 429 | add_subst a t 430 | (unify state (subst_equations (Ast.TyParamMap.singleton a t) eqs)) 431 | | (t, Ast.TyParam a) :: eqs when not (occurs a t) -> 432 | add_subst a t 433 | (unify state (subst_equations (Ast.TyParamMap.singleton a t) eqs)) 434 | | (t1, t2) :: _ -> 435 | let print_param = Ast.new_print_param () in 436 | Error.typing "Cannot unify %t = %t" 437 | (Ast.print_ty print_param t1) 438 | (Ast.print_ty print_param t2) 439 | 440 | let rec check_mobile state subst = function 441 | | [] -> () 442 | | ty :: tys -> 443 | let ty' = Ast.substitute_ty subst ty in 444 | if is_mobile state [] ty' then check_mobile state subst tys 445 | else 446 | let pp = Ast.new_print_param () in 447 | Error.typing "Expected %t (originaly %t) to be mobile." 448 | (Ast.print_ty pp ty') (Ast.print_ty pp ty) 449 | 450 | let infer state comp = 451 | let t, constr = infer_computation state comp in 452 | let sbst = unify state constr.equations in 453 | let t' = Ast.substitute_ty sbst t in 454 | check_mobile state sbst constr.mobile_types; 455 | t' 456 | 457 | let add_external_function x ty_sch state = 458 | Format.printf "@[val %t : %t@]@." (Ast.Variable.print x) 459 | (Ast.print_ty_scheme ty_sch); 460 | { state with global_var = Ast.VariableMap.add x ty_sch state.global_var } 461 | 462 | let add_operation state op ty = 463 | Format.printf "@[operation %t : %t@]@." (Ast.OpSym.print op) 464 | (Ast.print_ty_scheme ([], ty)); 465 | if is_mobile state [] ty then 466 | { state with operations = Ast.OpSymMap.add op ty state.operations } 467 | else Error.typing "Payload of an operation must be of a mobile type" 468 | 469 | let add_top_definition state x expr = 470 | let ty, constr = infer_expression state expr in 471 | let subst = unify state constr.equations in 472 | let ty' = Ast.substitute_ty subst ty in 473 | check_mobile state subst constr.mobile_types; 474 | let free_vars = Ast.free_vars ty' |> Ast.TyParamSet.elements in 475 | let ty_sch = (free_vars, ty') in 476 | add_external_function x ty_sch state 477 | 478 | let add_type_definitions state ty_defs = 479 | List.fold_left 480 | (fun state (params, ty_name, ty_def) -> 481 | Format.printf "@[type %t@]@." (Ast.TyName.print ty_name); 482 | { 483 | state with 484 | type_definitions = 485 | Ast.TyNameMap.add ty_name (params, ty_def) state.type_definitions; 486 | }) 487 | state ty_defs 488 | 489 | let check_payload state op expr = 490 | let ty1 = Ast.OpSymMap.find op state.operations 491 | and ty2, constr = infer_expression state expr in 492 | let subst = unify state (add_eqs constr [ (ty1, ty2) ]).equations in 493 | check_mobile state subst constr.mobile_types; 494 | subst 495 | -------------------------------------------------------------------------------- /src/utils/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name utils)) 3 | -------------------------------------------------------------------------------- /src/utils/error.ml: -------------------------------------------------------------------------------- 1 | (** Error reporting *) 2 | 3 | type t = Location.t option * string * string 4 | 5 | let print (loc, error_kind, msg) = Print.error ?loc error_kind "%s" msg 6 | 7 | exception Error of t 8 | 9 | (** [error ~loc error_kind fmt] raises an [Error] of kind [error_kind] with a 10 | message [fmt] at a location [loc]. The [kfprintf] magic allows us to 11 | construct the [fmt] using a format string before raising the exception. *) 12 | let error ?loc error_kind = 13 | let k _ = 14 | let msg = Format.flush_str_formatter () in 15 | raise (Error (loc, error_kind, msg)) 16 | in 17 | fun fmt -> Format.kfprintf k Format.str_formatter ("@[" ^^ fmt ^^ "@]") 18 | 19 | let fatal ?loc fmt = error ?loc "Fatal error" fmt 20 | let syntax ~loc fmt = error ~loc "Syntax error" fmt 21 | let typing ?loc fmt = error ?loc "Typing error" fmt 22 | let runtime ?loc fmt = error ?loc "Runtime error" fmt 23 | -------------------------------------------------------------------------------- /src/utils/list.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.List 2 | 3 | let fold = fold_left 4 | 5 | let fold_map f s xs = 6 | let aux (s, reversed_ys) x = 7 | let s', y = f s x in 8 | (s', y :: reversed_ys) 9 | in 10 | let s', reversed_ys = fold aux (s, []) xs in 11 | (s', rev reversed_ys) 12 | 13 | let rec left_to_right_map f = function 14 | | [] -> [] 15 | | x :: xs -> 16 | let y = f x in 17 | let ys = left_to_right_map f xs in 18 | y :: ys 19 | 20 | let concat_map f xs = concat (map f xs) 21 | 22 | let unique_elements lst = 23 | let rec unique_elements acc = function 24 | | [] -> rev acc 25 | | x :: xs -> 26 | if mem x acc then unique_elements acc xs 27 | else unique_elements (x :: acc) xs 28 | in 29 | unique_elements [] lst 30 | 31 | let no_duplicates lst = 32 | let rec check seen = function 33 | | [] -> true 34 | | x :: xs -> (not (mem x seen)) && check (x :: seen) xs 35 | in 36 | check [] lst 37 | 38 | let list_diff lst1 lst2 = filter (fun x -> not (mem x lst2)) lst1 39 | -------------------------------------------------------------------------------- /src/utils/location.ml: -------------------------------------------------------------------------------- 1 | (** Source code locations *) 2 | 3 | type t = { filename : string; line : int; column : int } 4 | 5 | let print { filename; line; column } ppf = 6 | if String.length filename != 0 then 7 | Format.fprintf ppf "file %S, line %d, char %d" filename line column 8 | else Format.fprintf ppf "line %d, char %d" (line - 1) column 9 | 10 | let of_lexeme position = 11 | let filename = position.Lexing.pos_fname 12 | and line = position.Lexing.pos_lnum 13 | and column = position.Lexing.pos_cnum - position.Lexing.pos_bol + 1 in 14 | { filename; line; column } 15 | 16 | type 'a located = { it : 'a; at : t } 17 | 18 | let add_loc ~loc it = { it; at = loc } 19 | -------------------------------------------------------------------------------- /src/utils/option.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.Option 2 | 3 | let map f = function None -> None | Some x -> Some (f x) 4 | let map_default f default = function None -> default | Some x -> f x 5 | -------------------------------------------------------------------------------- /src/utils/print.ml: -------------------------------------------------------------------------------- 1 | (** Pretty-printing functions *) 2 | 3 | let message ?loc ~header fmt = 4 | match loc with 5 | | Some loc -> 6 | Format.fprintf Format.err_formatter 7 | ("%s (%t):@," ^^ fmt ^^ "@.") 8 | header (Location.print loc) 9 | | _ -> Format.fprintf Format.err_formatter ("%s: " ^^ fmt ^^ "@.") header 10 | 11 | let error ?loc err_kind fmt = message ?loc ~header:err_kind fmt 12 | let check ?loc fmt = message ?loc ~header:"Check" fmt 13 | let warning ?loc fmt = message ?loc ~header:"Warning" fmt 14 | let debug ?loc fmt = message ?loc ~header:"Debug" fmt 15 | 16 | let print ?(at_level = min_int) ?(max_level = max_int) ppf = 17 | if at_level <= max_level then Format.fprintf ppf 18 | else fun fmt -> Format.fprintf ppf ("(" ^^ fmt ^^ ")") 19 | 20 | let rec print_sequence sep pp vs ppf = 21 | match vs with 22 | | [] -> () 23 | | [ v ] -> pp v ppf 24 | | v :: vs -> 25 | Format.fprintf ppf "%t%s@,%t" (pp v) sep (print_sequence sep pp vs) 26 | 27 | let rec print_cases pp vs ppf = 28 | match vs with 29 | | [] -> () 30 | | [ v ] -> pp v ppf 31 | | v :: vs -> Format.fprintf ppf "%t@,| %t" (pp v) (print_cases pp vs) 32 | 33 | let print_field fpp vpp (f, v) ppf = print ppf "%t = %t" (fpp f) (vpp v) 34 | 35 | let print_tuple pp lst ppf = 36 | match lst with 37 | | [] -> print ppf "()" 38 | | lst -> print ppf "(@[%t@])" (print_sequence ", " pp lst) 39 | 40 | let print_record fpp vpp assoc ppf = 41 | print ppf "{@[%t@]}" (print_sequence "; " (print_field fpp vpp) assoc) 42 | -------------------------------------------------------------------------------- /src/utils/symbol.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | 4 | val compare : t -> t -> int 5 | val fresh : string -> t 6 | val refresh : t -> t 7 | val print : t -> Format.formatter -> unit 8 | end 9 | 10 | module Make () : S = struct 11 | type t = int * string 12 | 13 | let compare (n1, _) (n2, _) = Int.compare n1 n2 14 | let count = ref (-1) 15 | 16 | let fresh ann = 17 | incr count; 18 | (!count, ann) 19 | 20 | let refresh (_, ann) = fresh ann 21 | let print (_n, ann) ppf = Format.fprintf ppf "%s" ann 22 | end 23 | 24 | let rec subscript i = 25 | let last = 26 | List.nth 27 | [ 28 | "\226\130\128"; 29 | "\226\130\129"; 30 | "\226\130\130"; 31 | "\226\130\131"; 32 | "\226\130\132"; 33 | "\226\130\133"; 34 | "\226\130\134"; 35 | "\226\130\135"; 36 | "\226\130\136"; 37 | "\226\130\137"; 38 | ] 39 | (i mod 10) 40 | in 41 | if i < 10 then last else subscript (i / 10) ^ last 42 | 43 | let greek_letters = 44 | [| 45 | "α"; 46 | "β"; 47 | "γ"; 48 | "δ"; 49 | "ε"; 50 | "ζ"; 51 | "η"; 52 | "θ"; 53 | "ι"; 54 | "κ"; 55 | "λ"; 56 | "μ"; 57 | "ν"; 58 | "ξ"; 59 | "ο"; 60 | "π"; 61 | "ρ"; 62 | "σ"; 63 | "τ"; 64 | |] 65 | 66 | let type_symbol n = 67 | if n < Array.length greek_letters then greek_letters.(n) 68 | else "τ" ^ subscript (n - Array.length greek_letters) 69 | -------------------------------------------------------------------------------- /src/webInterface/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name webInterface) 3 | (libraries ocaml-vdom core) 4 | (modes js) 5 | (link_flags -no-check-prims) 6 | (promote 7 | (until-clean) 8 | (into ../../web) 9 | (only webInterface.bc.js))) 10 | 11 | ;; This is an expanded form of the trick used in src/core/dune to generate the module 12 | ;; Examples_aeff with the examples to include in the web interface. 13 | 14 | (rule 15 | (with-stdout-to 16 | examples_aeff.ml 17 | (progn 18 | (echo "let examples = [") 19 | ;; We need to repeat the following three lines for each included example. 20 | ;; The first line gives the name of the example and the second gives its source. 21 | (echo "({|Client feed|}, {|") 22 | (cat ../../examples/feed.aeff) 23 | (echo "|});") 24 | (echo "({|Pure heap|}, {|") 25 | (cat ../../examples/heapPure.aeff) 26 | (echo "|});") 27 | (echo "({|Heap with references|}, {|") 28 | (cat ../../examples/heapRef.aeff) 29 | (echo "|});") 30 | (echo "({|Preemptive multi-threading|}, {|") 31 | (cat ../../examples/preemptive.aeff) 32 | (echo "|});") 33 | (echo "({|Post-processing|}, {|") 34 | (cat ../../examples/processWith.aeff) 35 | (echo "|});") 36 | (echo "({|Remote call|}, {|") 37 | (cat ../../examples/remoteCall.aeff) 38 | (echo "|});") 39 | (echo "({|Remote call (function payload)|}, {|") 40 | (cat ../../examples/remoteCallFunPayload.aeff) 41 | (echo "|});") 42 | (echo "({|Cancellable calls|}, {|") 43 | (cat ../../examples/cancellableCall.aeff) 44 | (echo "|});") 45 | (echo "({|Cancellable calls (function payload)|}, {|") 46 | (cat ../../examples/cancellableCallFunPayload.aeff) 47 | (echo "|});") 48 | (echo "({|Runners|}, {|") 49 | (cat ../../examples/runner.aeff) 50 | (echo "|});") 51 | (echo "({|Timer|}, {|") 52 | (cat ../../examples/ticktock.aeff) 53 | (echo "|});") 54 | (echo "({|Handle only first n interrupts|}, {|") 55 | (cat ../../examples/handleFirstThreeInterrupts.aeff) 56 | (echo "|});") 57 | (echo "]")))) 58 | -------------------------------------------------------------------------------- /src/webInterface/model.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Ast = Core.Ast 3 | module Interpreter = Core.Interpreter 4 | module Loader = Core.Loader 5 | 6 | type operation = 7 | | Interrupt of Ast.opsym * Ast.expression 8 | | Signal of Ast.opsym * Ast.expression 9 | 10 | type snapshot = { process : Ast.process; operations : operation list } 11 | 12 | type loaded_code = { 13 | snapshot : snapshot; 14 | history : snapshot list; 15 | interpreter_state : Interpreter.state; 16 | operations : Ast.ty Ast.OpSymMap.t; 17 | parse_payload : Ast.opsym -> string -> Ast.expression; 18 | } 19 | 20 | type model = { 21 | use_stdlib : bool; 22 | unparsed_code : string; 23 | loaded_code : (loaded_code, string) result; 24 | selected_reduction : int option; 25 | random_step_size : int; 26 | interrupt_operation : Ast.opsym option; 27 | unparsed_interrupt_payload : string; 28 | parsed_interrupt_payload : (Ast.expression, string) result; 29 | } 30 | 31 | type msg = 32 | | UseStdlib of bool 33 | | ChangeSource of string 34 | | LoadSource 35 | | EditSource 36 | | SelectReduction of int option 37 | | Step of Interpreter.top_step 38 | | RandomStep 39 | | ChangeRandomStepSize of int 40 | | ChangeInterruptOperation of Ast.opsym 41 | | ParseInterruptPayload of string 42 | | SendInterrupt 43 | | Back 44 | 45 | let init = 46 | { 47 | use_stdlib = true; 48 | unparsed_code = ""; 49 | loaded_code = Error ""; 50 | selected_reduction = None; 51 | random_step_size = 1; 52 | interrupt_operation = None; 53 | unparsed_interrupt_payload = ""; 54 | parsed_interrupt_payload = Error ""; 55 | } 56 | 57 | let step_snapshot snapshot = function 58 | | Interpreter.Step proc' -> { snapshot with process = proc' } 59 | | Interpreter.TopSignal (op, expr, proc') -> 60 | { process = proc'; operations = Signal (op, expr) :: snapshot.operations } 61 | 62 | let apply_to_code_if_loaded f model = 63 | match model.loaded_code with 64 | | Ok code -> { model with loaded_code = Ok (f code) } 65 | | Error _ -> model 66 | 67 | let steps code = 68 | Interpreter.top_steps code.interpreter_state code.snapshot.process 69 | 70 | let move_to_snapshot snapshot code = 71 | { code with snapshot; history = code.snapshot :: code.history } 72 | 73 | let step_code step code = 74 | move_to_snapshot (step_snapshot code.snapshot step) code 75 | 76 | let interrupt op expr code = 77 | let proc' = Interpreter.incoming_operation code.snapshot.process op expr in 78 | move_to_snapshot 79 | { 80 | process = proc'; 81 | operations = Interrupt (op, expr) :: code.snapshot.operations; 82 | } 83 | code 84 | 85 | let rec make_random_steps num_steps code = 86 | match (num_steps, steps code) with 87 | | 0, _ | _, [] -> code 88 | | _, steps -> 89 | let i = Random.int (List.length steps) in 90 | let _, top_step = List.nth steps i in 91 | let code' = step_code top_step code in 92 | make_random_steps (num_steps - 1) code' 93 | 94 | let parse_step_size input = 95 | input |> int_of_string_opt 96 | |> Option.to_result ~none:(input ^ " is not an integer") 97 | 98 | let parse_payload code op input = 99 | try Ok (code.parse_payload op input) with 100 | | Error.Error (_, kind, msg) -> Error (kind ^ ": " ^ msg) 101 | | _ -> Error "Parser error" 102 | 103 | let parse_source source = 104 | try 105 | let state = Loader.load_source Loader.initial_state source in 106 | let proc = Loader.make_process state in 107 | Ok 108 | { 109 | snapshot = { process = proc; operations = [] }; 110 | history = []; 111 | interpreter_state = state.interpreter; 112 | parse_payload = Loader.parse_payload state; 113 | operations = state.typechecker.operations; 114 | } 115 | with Error.Error (_, _, msg) -> Error msg 116 | 117 | let update model = function 118 | | UseStdlib use_stdlib -> { model with use_stdlib } 119 | | SelectReduction selected_reduction -> { model with selected_reduction } 120 | | Step top_step -> apply_to_code_if_loaded (step_code top_step) model 121 | | RandomStep -> 122 | apply_to_code_if_loaded (make_random_steps model.random_step_size) model 123 | | Back -> ( 124 | match model.loaded_code with 125 | | Ok ({ history = snapshot' :: history'; _ } as code) -> 126 | { 127 | model with 128 | loaded_code = 129 | Ok { code with snapshot = snapshot'; history = history' }; 130 | } 131 | | _ -> model) 132 | | ChangeSource input -> { model with unparsed_code = input } 133 | | LoadSource -> 134 | { 135 | model with 136 | loaded_code = 137 | parse_source 138 | ((if model.use_stdlib then Loader.stdlib_source else "") 139 | ^ "\n\n\n" ^ model.unparsed_code); 140 | } 141 | | EditSource -> { model with loaded_code = Error "" } 142 | | ChangeRandomStepSize random_step_size -> { model with random_step_size } 143 | | ChangeInterruptOperation operation -> 144 | { model with interrupt_operation = Some operation } 145 | | ParseInterruptPayload input -> ( 146 | match (model.interrupt_operation, model.loaded_code) with 147 | | Some op, Ok code -> 148 | let model = { model with unparsed_interrupt_payload = input } in 149 | { model with parsed_interrupt_payload = parse_payload code op input } 150 | | _, _ -> model) 151 | | SendInterrupt -> ( 152 | match (model.interrupt_operation, model.parsed_interrupt_payload) with 153 | | Some op, Ok expr -> apply_to_code_if_loaded (interrupt op expr) model 154 | | _, _ -> model) 155 | -------------------------------------------------------------------------------- /src/webInterface/redexSelectorTM.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Ast = Core.Ast 3 | module Interpreter = Core.Interpreter 4 | 5 | let tag_marker = "###" 6 | let print_mark ppf = Format.pp_print_as ppf 0 tag_marker 7 | 8 | let print_computation_redex ?max_level red c ppf = 9 | let print ?at_level = Print.print ?max_level ?at_level ppf in 10 | match (red, c) with 11 | | (Interpreter.DoReturn | Interpreter.DoSignal), Ast.Do (c1, (pat, c2)) -> 12 | print "@[%tlet@[@ %t =@ %t@]%t in@ %t@]" print_mark 13 | (Ast.print_pattern pat) (Ast.print_computation c1) print_mark 14 | (Ast.print_computation c2) 15 | | _, comp -> 16 | print "%t%t%t" print_mark 17 | (fun ppf -> Ast.print_computation ?max_level comp ppf) 18 | print_mark 19 | 20 | let rec print_computation_reduction ?max_level red c ppf = 21 | let print ?at_level = Print.print ?max_level ?at_level ppf in 22 | match (red, c) with 23 | | Interpreter.DoCtx red, Ast.Do (c1, (Ast.PNonbinding, c2)) -> 24 | print "@[%t;@ %t@]" 25 | (print_computation_reduction red c1) 26 | (Ast.print_computation c2) 27 | | Interpreter.DoCtx red, Ast.Do (c1, (pat, c2)) -> 28 | print "@[let@[@ %t =@ %t@] in@ %t@]" (Ast.print_pattern pat) 29 | (print_computation_reduction red c1) 30 | (Ast.print_computation c2) 31 | | Interpreter.InterruptCtx red, Ast.Interrupt (op, e, c) -> 32 | print "↓%t(@[%t,@ %t@])" (Ast.OpSym.print op) (Ast.print_expression e) 33 | (print_computation_reduction red c) 34 | | Interpreter.SignalCtx red, Ast.Operation (Ast.Signal (op, e), c) -> 35 | print "↑%t(@[%t,@ %t@])" (Ast.OpSym.print op) (Ast.print_expression e) 36 | (print_computation_reduction red c) 37 | | ( Interpreter.SignalCtx red, 38 | Ast.Operation 39 | ( InterruptHandler 40 | { 41 | operation = op; 42 | handler = 43 | { 44 | payload_pattern = p1; 45 | resumption_pattern = r; 46 | state_pattern = s; 47 | body = c1; 48 | }; 49 | state_value = v; 50 | promise = p2; 51 | }, 52 | c2 ) ) -> 53 | print "@[promise (@[%t %t %t %t ↦@ %t@])@ %@ %t as %t in@ %t@]" 54 | (Ast.OpSym.print op) (Ast.print_pattern p1) (Ast.print_pattern r) 55 | (Ast.print_pattern s) (Ast.print_computation c1) 56 | (Ast.print_expression v) (Ast.Variable.print p2) 57 | (print_computation_reduction red c2) 58 | | Interpreter.ComputationRedex redex, c -> 59 | print_computation_redex ?max_level redex c ppf 60 | | _, _ -> assert false 61 | 62 | let print_process_redex ?max_level _redex proc ppf = 63 | let print ?at_level = Print.print ?max_level ?at_level ppf in 64 | print "%t%t%t" print_mark (Ast.print_process ?max_level proc) print_mark 65 | 66 | let rec print_process_reduction ?max_level red proc ppf = 67 | let print ?at_level = Print.print ?max_level ?at_level ppf in 68 | match (red, proc) with 69 | | Interpreter.RunCtx red, Ast.Run comp -> 70 | print ~at_level:1 "run %t" 71 | (print_computation_reduction ~max_level:0 red comp) 72 | | Interpreter.LeftCtx red, Ast.Parallel (proc1, proc2) -> 73 | print "@[%t@ || @ %t@]" 74 | (print_process_reduction red proc1) 75 | (Ast.print_process proc2) 76 | | Interpreter.RightCtx red, Ast.Parallel (proc1, proc2) -> 77 | print "@[%t@ || @ %t@]" (Ast.print_process proc1) 78 | (print_process_reduction red proc2) 79 | | Interpreter.InterruptProcCtx red, Ast.InterruptProc (op, expr, proc) -> 80 | print "↓%t(@[%t,@ %t@])" (Ast.OpSym.print op) 81 | (Ast.print_expression expr) 82 | (print_process_reduction red proc) 83 | | Interpreter.SignalProcCtx red, Ast.SignalProc (op, expr, proc) -> 84 | print "↑%t(@[%t,@ %t@])" (Ast.OpSym.print op) 85 | (Ast.print_expression expr) 86 | (print_process_reduction red proc) 87 | | Interpreter.ProcessRedex redex, proc -> 88 | print_process_redex ?max_level redex proc ppf 89 | | _, _ -> assert false 90 | 91 | let split_string sep str = 92 | let sep_len = String.length sep and str_len = String.length str in 93 | let sub_start = ref 0 and sub_end = ref 0 and subs = ref [] in 94 | while !sub_end <= str_len - sep_len do 95 | if String.sub str !sub_end sep_len = sep then ( 96 | subs := String.sub str !sub_start (!sub_end - !sub_start) :: !subs; 97 | sub_start := !sub_end + sep_len; 98 | sub_end := !sub_start) 99 | else incr sub_end 100 | done; 101 | if !sub_start <= str_len then 102 | subs := String.sub str !sub_start (str_len - !sub_start) :: !subs; 103 | List.rev !subs 104 | 105 | let view_process_with_redexes red proc = 106 | (match red with 107 | | None -> Ast.print_process proc Format.str_formatter 108 | | Some red -> print_process_reduction red proc Format.str_formatter); 109 | match split_string tag_marker (Format.flush_str_formatter ()) with 110 | | [ code ] -> [ Vdom.text code ] 111 | | [ pre; redex; post ] -> 112 | [ 113 | Vdom.text pre; 114 | Vdom.elt "strong" ~a:[ Vdom.class_ "has-text-info" ] [ Vdom.text redex ]; 115 | Vdom.text post; 116 | ] 117 | | _ -> assert false 118 | -------------------------------------------------------------------------------- /src/webInterface/view.ml: -------------------------------------------------------------------------------- 1 | open Vdom 2 | module Ast = Core.Ast 3 | module Interpreter = Core.Interpreter 4 | 5 | let panel ?(a = []) heading blocks = 6 | div ~a:(class_ "panel" :: a) 7 | (elt "p" ~a:[ class_ "panel-heading" ] [ text heading ] :: blocks) 8 | 9 | let panel_block = div ~a:[ class_ "panel-block" ] 10 | 11 | let button txt msg = 12 | input [] ~a:[ onclick (fun _ -> msg); type_button; value txt ] 13 | 14 | let disabled_button txt = input [] ~a:[ type_button; value txt; disabled true ] 15 | 16 | let select ?(a = []) empty_description msg describe_choice selected choices = 17 | let view_choice choice = 18 | elt "option" 19 | ~a:[ bool_prop "selected" (selected choice) ] 20 | [ text (describe_choice choice) ] 21 | in 22 | div ~a 23 | [ 24 | elt "select" 25 | ~a:[ onchange_index (fun i -> msg (List.nth choices (i - 1))) ] 26 | (elt "option" 27 | ~a: 28 | [ 29 | disabled true; 30 | bool_prop "selected" 31 | (List.for_all (fun choice -> not (selected choice)) choices); 32 | ] 33 | [ text empty_description ] 34 | :: List.map view_choice choices); 35 | ] 36 | 37 | let nil = text "" 38 | 39 | let view_computation_redex = function 40 | | Interpreter.PromiseSignal -> "promiseSignal" 41 | | Interpreter.InterruptReturn -> "interruptReturn" 42 | | Interpreter.InterruptSignal -> "interruptSignal" 43 | | Interpreter.InterruptPromise -> "interruptPromise" 44 | | Interpreter.InterruptPromise' -> "interruptPromise" 45 | | Interpreter.Match -> "match" 46 | | Interpreter.ApplyFun -> "applyFun" 47 | | Interpreter.DoReturn -> "doReturn" 48 | | Interpreter.DoSignal -> "doSignal" 49 | | Interpreter.AwaitFulfill -> "awaitFulfill" 50 | | Interpreter.Unbox -> "unbox" 51 | | Interpreter.Spawn -> "spawn" 52 | 53 | let rec view_computation_reduction = function 54 | | Interpreter.InterruptCtx red -> view_computation_reduction red 55 | | Interpreter.SignalCtx red -> view_computation_reduction red 56 | | Interpreter.DoCtx red -> view_computation_reduction red 57 | | Interpreter.ComputationRedex redex -> view_computation_redex redex 58 | 59 | let view_process_redex = function 60 | | Interpreter.RunSignal -> "runSignal" 61 | | Interpreter.RunSpawn -> "runSpawn" 62 | | Interpreter.ParallelSignal1 -> "parallelSignal1" 63 | | Interpreter.ParallelSignal2 -> "parallelSignal2" 64 | | Interpreter.InterruptRun -> "interruptRun" 65 | | Interpreter.InterruptParallel -> "interruptParallel" 66 | | Interpreter.InterruptSignal -> "interruptSignal" 67 | | Interpreter.TopSignal -> "topSignal" 68 | 69 | let rec view_process_reduction = function 70 | | Interpreter.LeftCtx red -> view_process_reduction red 71 | | Interpreter.RightCtx red -> view_process_reduction red 72 | | Interpreter.InterruptProcCtx red -> view_process_reduction red 73 | | Interpreter.SignalProcCtx red -> view_process_reduction red 74 | | Interpreter.RunCtx red -> view_computation_reduction red 75 | | Interpreter.ProcessRedex redex -> view_process_redex redex 76 | 77 | let step_action (red, step) = 78 | elt "li" [ button (view_process_reduction red) (Model.Step step) ] 79 | 80 | (* let view_actions (model : Model.model) code = 81 | let _step_actions = List.map step_action (Model.steps code) in 82 | let random_action = 83 | valid_button 84 | ~input_placeholder:"Number of random steps to make" 85 | ~input_value:model.unparsed_step_size 86 | ~input_msg:(fun input -> Model.ChangeStepSize input) 87 | ~submit_msg:(fun _ -> Model.RandomStep) 88 | ~submit_value:"Step randomly" 89 | model.random_step_size 90 | and _back_action = 91 | match code.history with 92 | | [] -> disabled_button "back" 93 | | _ -> button "back" Model.Back 94 | and _interrupt_action = 95 | valid_button 96 | ~input_placeholder:"Interrupt, eg. \"op 10\"" 97 | ~input_value:model.unparsed_interrupt 98 | ~input_msg:(fun input -> Model.ParseInterrupt input) 99 | ~submit_msg:(fun _ -> Model.Interrupt) 100 | ~submit_value:"interrupt" 101 | model.parsed_interrupt 102 | in 103 | elt "nav" ~a:[class_ "level"] [ 104 | div ~a:[class_ "level-left"] [ 105 | div ~a:[class_ "level-item"] [ 106 | elt "button" ~a:[class_ "button is-danger"] [text "back"] 107 | ] 108 | ]; 109 | div ~a:[class_ "level-right"] [ 110 | random_action 111 | ] 112 | ] 113 | elt "ol" (back_action :: :: step_actions @ [interrupt_action]) *) 114 | 115 | let view_steps (model : Model.model) (code : Model.loaded_code) steps = 116 | let view_edit_source = 117 | panel_block 118 | [ 119 | elt "button" 120 | ~a: 121 | [ 122 | class_ "button is-outlined is-fullwidth is-small is-danger"; 123 | onclick (fun _ -> Model.EditSource); 124 | attr "title" 125 | "Re-editing source code will abort current evaluation"; 126 | ] 127 | [ text "Re-edit source code" ]; 128 | ] 129 | and view_undo_last_step = 130 | panel_block 131 | [ 132 | elt "button" 133 | ~a: 134 | [ 135 | class_ "button is-outlined is-fullwidth is-small"; 136 | onclick (fun _ -> Model.Back); 137 | disabled (code.history = []); 138 | ] 139 | [ text "Undo last step" ]; 140 | ] 141 | and view_step i (red, step) = 142 | panel_block 143 | [ 144 | elt "button" 145 | ~a: 146 | [ 147 | class_ "button is-outlined is-fullwidth"; 148 | onclick (fun _ -> Model.Step step); 149 | onmousemove (fun _ -> Model.SelectReduction (Some i)); 150 | ] 151 | [ text (view_process_reduction red) ]; 152 | ] 153 | and view_random_steps steps = 154 | div 155 | ~a:[ class_ "panel-block" ] 156 | [ 157 | div 158 | ~a:[ class_ "field has-addons" ] 159 | [ 160 | div 161 | ~a:[ class_ "control is-expanded" ] 162 | [ 163 | select 164 | ~a:[ class_ "select is-fullwidth is-info" ] 165 | "Step size" 166 | (fun step_size -> Model.ChangeRandomStepSize step_size) 167 | string_of_int 168 | (fun step_size -> step_size = model.random_step_size) 169 | [ 1; 2; 4; 8; 16; 32; 64; 128; 256; 512; 1024 ]; 170 | ]; 171 | div 172 | ~a:[ class_ "control" ] 173 | [ 174 | elt "button" 175 | ~a: 176 | [ 177 | class_ "button is-info"; 178 | onclick (fun _ -> Model.RandomStep); 179 | disabled (steps = []); 180 | ] 181 | [ text "random steps" ]; 182 | ]; 183 | ]; 184 | (if steps = [] then 185 | elt "p" 186 | ~a:[ class_ "help" ] 187 | [ 188 | text "Computation has terminated, no further steps are possible."; 189 | ] 190 | else text ""); 191 | ] 192 | in 193 | let send_interrupt = 194 | let warn_payload = 195 | model.unparsed_interrupt_payload <> "" 196 | && Result.is_error model.parsed_interrupt_payload 197 | in 198 | panel_block 199 | [ 200 | div 201 | ~a:[ class_ "field" ] 202 | [ 203 | div 204 | ~a:[ class_ "field has-addons" ] 205 | [ 206 | div 207 | ~a:[ class_ "control is-expanded" ] 208 | [ 209 | select 210 | ~a:[ class_ "select is-fullwidth" ] 211 | "Interrupt" 212 | (fun operation -> 213 | Model.ChangeInterruptOperation operation) 214 | Ast.string_of_operation 215 | (fun operation -> 216 | Some operation = model.interrupt_operation) 217 | (Ast.OpSymMap.bindings code.operations |> List.map fst); 218 | ]; 219 | elt "p" 220 | ~a:[ class_ "control" ] 221 | [ 222 | input 223 | ~a: 224 | [ 225 | class_ 226 | (if warn_payload then "input is-danger" else "input"); 227 | type_ "text"; 228 | oninput (fun input -> 229 | Model.ParseInterruptPayload input); 230 | str_prop "placeholder" "payload"; 231 | disabled (Option.is_none model.interrupt_operation); 232 | value model.unparsed_interrupt_payload; 233 | ] 234 | []; 235 | ]; 236 | div 237 | ~a:[ class_ "control" ] 238 | [ 239 | (let dis = 240 | Option.is_none model.interrupt_operation 241 | || Result.is_error model.parsed_interrupt_payload 242 | in 243 | elt "button" 244 | ~a: 245 | [ 246 | class_ "button is-info"; 247 | onclick (fun _ -> Model.SendInterrupt); 248 | disabled dis; 249 | ] 250 | [ text "↓" ]); 251 | ]; 252 | ]; 253 | (match model.parsed_interrupt_payload with 254 | | Error msg when warn_payload -> 255 | elt "p" ~a:[ class_ "help is-danger" ] [ text msg ] 256 | | _ -> nil); 257 | ]; 258 | ] 259 | in 260 | panel "Interaction" 261 | ~a:[ onmousemove (fun _ -> Model.SelectReduction None) ] 262 | (view_edit_source :: view_undo_last_step :: view_random_steps steps 263 | :: List.mapi view_step steps 264 | @ [ send_interrupt ]) 265 | 266 | let view_history ops = 267 | let view_operation op = 268 | (match op with 269 | | Model.Interrupt (op, expr) -> 270 | Format.fprintf Format.str_formatter "↓ %t %t" (Ast.OpSym.print op) 271 | (Ast.print_expression expr) 272 | | Model.Signal (op, expr) -> 273 | Format.fprintf Format.str_formatter "↑ %t %t" (Ast.OpSym.print op) 274 | (Ast.print_expression expr)); 275 | elt "a" ~a:[ class_ "panel-block" ] [ text (Format.flush_str_formatter ()) ] 276 | in 277 | panel "History" (List.map view_operation ops) 278 | 279 | let view_process steps proc = 280 | let process_tree = RedexSelectorTM.view_process_with_redexes steps proc in 281 | div ~a:[ class_ "box" ] [ elt "pre" process_tree ] 282 | 283 | let view_editor (model : Model.model) = 284 | div 285 | ~a:[ class_ "box" ] 286 | [ 287 | elt "textarea" 288 | ~a: 289 | [ 290 | class_ "textarea has-fixed-size"; 291 | oninput (fun input -> Model.ChangeSource input); 292 | int_prop "rows" 293 | (max 10 294 | (String.split_on_char '\n' model.unparsed_code |> List.length)); 295 | ] 296 | [ text model.unparsed_code ]; 297 | ] 298 | 299 | (* let _view (model : Model.model) = 300 | match model.loaded_code with 301 | | Ok code -> 302 | div 303 | [ 304 | input ~a:[type_ "range"; int_attr "min" 0; int_attr "max" 10; int_attr "step" 2; onmousedown (fun event -> Model.ParseInterrupt (string_of_int event.x))] []; 305 | (* elt "progress" ~a:[type_ "range"; value (string_of_int model.random_step_size); int_attr "max" 10; oninput (fun input -> Model.ChangeStepSize input)] []; *) 306 | editor model; 307 | actions model code; 308 | view_operations code.snapshot.operations; 309 | view_process code.snapshot.process; 310 | ] 311 | | Error msg -> div [ editor model; text msg ] *) 312 | 313 | let view_compiler (model : Model.model) = 314 | let use_stdlib = 315 | elt "label" 316 | ~a:[ class_ "panel-block" ] 317 | [ 318 | input 319 | ~a: 320 | [ 321 | type_ "checkbox"; 322 | onchange_checked (fun use_stdlib -> Model.UseStdlib use_stdlib); 323 | bool_prop "checked" model.use_stdlib; 324 | ] 325 | []; 326 | text "Load standard library"; 327 | ] 328 | in 329 | let load_example = 330 | div 331 | ~a:[ class_ "panel-block" ] 332 | [ 333 | div 334 | ~a:[ class_ "field" ] 335 | [ 336 | div 337 | ~a:[ class_ "control is-expanded" ] 338 | [ 339 | select 340 | ~a:[ class_ "select is-fullwidth" ] 341 | "Load example" 342 | (fun (_, source) -> Model.ChangeSource source) 343 | (fun (title, _) -> title) 344 | (fun _ -> false) 345 | (* The module Examples_aeff is semi-automatically generated from examples/*.aeff. Check the dune file for details. *) 346 | Examples_aeff.examples; 347 | ]; 348 | ]; 349 | ] 350 | and run_process = 351 | panel_block 352 | [ 353 | elt "button" 354 | ~a: 355 | [ 356 | class_ "button is-info is-fullwidth"; 357 | onclick (fun _ -> Model.LoadSource); 358 | (* disabled (Result.is_error model.loaded_code); *) 359 | ] 360 | [ text "Compile & run" ]; 361 | (match model.loaded_code with 362 | | Error msg -> elt "p" ~a:[ class_ "help is-danger" ] [ text msg ] 363 | | Ok _ -> nil); 364 | ] 365 | in 366 | panel "Code options" [ use_stdlib; load_example; run_process ] 367 | 368 | let view_contents main aside = 369 | div 370 | ~a:[ class_ "contents columns" ] 371 | [ 372 | div ~a:[ class_ "main column is-three-quarters" ] main; 373 | div ~a:[ class_ "aside column is-one-quarter" ] aside; 374 | ] 375 | 376 | let view_source model = 377 | view_contents [ view_editor model ] [ view_compiler model ] 378 | 379 | let view_code (model : Model.model) (code : Model.loaded_code) = 380 | let steps = Model.steps code in 381 | let selected_red = 382 | match model.selected_reduction with 383 | | None -> None 384 | | Some i -> List.nth_opt steps i |> Option.map fst 385 | in 386 | view_contents 387 | [ view_process selected_red code.snapshot.process ] 388 | [ view_steps model code steps; view_history code.snapshot.operations ] 389 | 390 | let view_navbar = 391 | let view_title = 392 | div 393 | ~a:[ class_ "navbar-brand" ] 394 | [ 395 | elt "a" 396 | ~a:[ class_ "navbar-item" ] 397 | [ elt "p" ~a:[ class_ "title" ] [ text "Æff" ] ]; 398 | ] 399 | in 400 | 401 | elt "navbar" ~a:[ class_ "navbar" ] [ view_title ] 402 | 403 | let view (model : Model.model) = 404 | div 405 | [ 406 | view_navbar; 407 | (match model.loaded_code with 408 | | Error _ -> view_source model 409 | | Ok code -> view_code model code); 410 | ] 411 | -------------------------------------------------------------------------------- /src/webInterface/webInterface.ml: -------------------------------------------------------------------------------- 1 | let app = 2 | Vdom.simple_app ~init:Model.init ~view:View.view ~update:Model.update () 3 | 4 | let run () = 5 | Vdom_blit.run app |> Vdom_blit.dom 6 | |> Js_browser.Element.append_child 7 | (match 8 | Js_browser.Document.get_element_by_id Js_browser.document "container" 9 | with 10 | | Some element -> element 11 | | None -> Js_browser.Document.document_element Js_browser.document) 12 | 13 | let () = Js_browser.Window.set_onload Js_browser.window run 14 | -------------------------------------------------------------------------------- /tests/async.aeff: -------------------------------------------------------------------------------- 1 | operation question : [|unit -> int|] 2 | operation answer : int 3 | 4 | let getAnswer f = 5 | let result = promise (answer x -> <>) in 6 | send question f; 7 | result 8 | 9 | run 10 | let r = getAnswer ([|fun () -> 3 + 3|]) in 11 | let y = 1 + 1 in 12 | let z = y + y in 13 | let w = y + z in 14 | let u = (w + 1) * (await r) in 15 | u 16 | 17 | run 18 | promise (question f -> 19 | let f' = unbox f in 20 | let y = f' () in 21 | send answer y; 22 | return <<()>> 23 | ) 24 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps 3 | ../aeff.exe 4 | (source_tree .) 5 | (source_tree ../examples))) 6 | -------------------------------------------------------------------------------- /tests/select.aeff: -------------------------------------------------------------------------------- 1 | operation op1 : int 2 | operation op2 : int 3 | 4 | let select f g k = 5 | let i = ref 0 in 6 | let v1 = ref None in 7 | let v2 = ref None in 8 | let p1 = promise (op1 x -> 9 | if !i = 0 10 | then (let q1 = f x in 11 | let y1 = await q1 in 12 | v1 := Some y1; 13 | i := 1; 14 | return <<()>>) 15 | else return <<()>>) in 16 | let p2 = promise (op2 x -> 17 | if !i = 0 18 | then (let q2 = g x in 19 | let y2 = await q2 in 20 | v2 := Some y2; 21 | i := 2; 22 | return <<()>>) 23 | else return <<()>>) in 24 | let rec waitForOp () = 25 | if !i = 0 then waitForOp () 26 | else if !i = 1 then (match !v1 with | Some v -> k <>) 27 | else (match !v2 with | Some v -> k <>) 28 | in 29 | waitForOp () 30 | 31 | 32 | run 33 | send op1 1 34 | 35 | run 36 | send op2 2 37 | 38 | run 39 | select 40 | (fun x -> return <>) 41 | (fun x -> return <>) 42 | (fun p -> let x = await p in return x * x) -------------------------------------------------------------------------------- /tests/spawnProcess.aeff: -------------------------------------------------------------------------------- 1 | operation task : int * [|int -> int|] 2 | operation result : int * int 3 | 4 | let boxedFunc = [|fun a -> a+a|] 5 | 6 | let parallelMap f seznam = 7 | map (fun p -> await p) ( 8 | map (fun e -> 9 | let result = promise (result (x,r) when x = e -> 10 | <> 11 | ) in 12 | spawn( 13 | let f' = unbox f in 14 | send result (e, (f' e)) 15 | ); 16 | result 17 | ) 18 | seznam 19 | ) 20 | 21 | 22 | run parallelMap boxedFunc [1;2;3;4;5] -------------------------------------------------------------------------------- /tests/spawnSimple.aeff: -------------------------------------------------------------------------------- 1 | operation stdOut : string 2 | 3 | run spawn ( 4 | send stdOut "Hello world"; 5 | let a = 15 in 6 | a * a; 7 | () 8 | ); 39 + 3 -------------------------------------------------------------------------------- /tests/theGoodTheBadAndTheUgly.aeff: -------------------------------------------------------------------------------- 1 | type 'm mobileList = 2 | | Empty 3 | | Something of [|'m|] * 'm mobileList 4 | operation theGood : (unit -> int) mobileList 5 | 6 | (* 7 | type 'm immobileList = 8 | | Empty 9 | | Something of <<'m>> * 'm immobileList 10 | operation theBad : (unit -> int) immobileList 11 | *) 12 | 13 | 14 | type 'm left1 = 15 | | One of [|'m|] 16 | | Two of [|'m|] * 'm right1 17 | and 'm right1 = 18 | | Three of [|'m|] 19 | | Four of [|'m|] * <<'m>> left1 20 | operation andTheUgly : int left1 21 | 22 | (* 23 | type 'm left2 = 24 | | One of [|'m|] 25 | | Two of [|'m|] * 'm right2 26 | and 'm right2 = 27 | | Three of 'm 28 | | Four of [|'m|] * <<'m>> left2 29 | operation badAndUgly : int left2 30 | *) 31 | 32 | 33 | 34 | type ('a, 'b) foo = [|'a|] * 'b 35 | operation bar1 : (<>, int) foo 36 | (* 37 | operation bar2 : (int, <>) foo 38 | *) -------------------------------------------------------------------------------- /web/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Æff 8 | 9 | 10 | 23 | 24 | 25 | 26 |
27 |
28 |
29 |
30 | 31 | 32 | --------------------------------------------------------------------------------