├── .gitignore ├── dune ├── dune-project ├── ex ├── basic │ ├── fac.prw │ ├── fac2.prw │ ├── fib.prw │ ├── fizz.prw │ └── hello.prw ├── elem │ ├── asop-2.prw │ ├── asop-3.prw │ ├── asop.prw │ ├── bin.prw │ ├── cli.prw │ ├── custom.prw │ ├── eithers.prw │ ├── fib-opt.prw │ ├── hof.prw │ ├── impl.prw │ ├── infix.prw │ ├── intersect.prw │ ├── let-fail.prw │ ├── let-open.prw │ ├── letop-2.prw │ ├── letop.prw │ ├── list-rev.prw │ ├── load-snoc.prw │ ├── mod-2.prw │ ├── mod.prw │ ├── multidef.prw │ ├── norm-sqr.prw │ ├── open-match.prw │ ├── open.prw │ ├── snoc.prw │ ├── stack-match.prw │ ├── stack.prw │ ├── test-2.prw │ ├── test-3.prw │ ├── test-4.prw │ ├── test-5.prw │ ├── test-6a.prw │ ├── test-6b.prw │ ├── test-6c.prw │ ├── test-7.prw │ ├── test-7b.prw │ ├── test-7c.prw │ ├── test-7d.prw │ ├── test-7e.prw │ └── test-7f.prw ├── inter │ ├── fizz.prw │ └── nfib.prw └── temp.prw ├── prowl.ml ├── prowl_test.ml ├── readme.md ├── src ├── build.ml ├── cli.ml ├── dune ├── parse │ ├── ast.ml │ ├── dune │ ├── gen.ml │ ├── lex.mll │ ├── lex_comb.mll │ ├── lex_proc.ml │ ├── parse.mly │ ├── parse_comb.mly │ └── parse_proc.ml ├── run │ ├── error.ml │ ├── eval.ml │ ├── interpret.ml │ └── state.ml └── util.ml ├── std └── stack.prw └── test ├── bindings ├── as1.prw ├── compose.prw ├── let-as.prw ├── let-func.prw ├── let-sect.prw ├── let1.prw ├── sect-full.prw ├── sect-left.prw ├── sect-right.prw └── sect1.prw ├── combinators ├── compound.prw └── simple.prw ├── data ├── cat-rev.prw ├── cat.prw ├── filter.prw ├── flatten.prw ├── map.prw └── rev.prw ├── flow ├── alt-cut-accepted.prw ├── alt-cut-handle.prw ├── alt-cut.prw ├── alt-greedy.prw ├── alt-handle.prw ├── alt-rejected.prw ├── alt.prw ├── atomic-accept.prw ├── atomic-reject.prw ├── case-cut.prw ├── case-rel.prw ├── case-rel2.prw ├── case.prw ├── cat.prw ├── intersect.prw ├── inversion-rejected.prw ├── inversion.prw ├── n-times.prw ├── noncap-accept.prw ├── noncap-reject.prw ├── opt-handle.prw ├── opt.prw ├── plus-reject.prw ├── plus.prw ├── star-cut.prw ├── star-greedy.prw ├── star-rel.prw └── star.prw ├── fundamentals ├── arith1.prw ├── arith2.prw └── lit1.prw ├── modules ├── access.prw ├── open.prw └── recursion.prw └── patterns ├── bin-func.prw ├── capture-direct.prw ├── capture-fun.prw ├── capture-indirect.prw ├── cat.prw ├── const-int-reject.prw ├── const-int.prw ├── const-str.prw ├── eith-func.prw ├── left.prw ├── long-pair.prw ├── nest-capture-pair.prw ├── nest-either-pair.prw ├── pair-func.prw ├── pair.prw ├── right.prw ├── stack-rejected-high.prw ├── stack-rejected-low.prw └── stack.prw /.gitignore: -------------------------------------------------------------------------------- 1 | _opam 2 | _build 3 | /_boot 4 | _perf 5 | *.install 6 | .merlin 7 | *.corrected 8 | 9 | # vim swap files 10 | *.swp 11 | *.swo 12 | 13 | # emacs lock files 14 | .#* 15 | 16 | .duneboot.* 17 | /boot/*.cm* 18 | dune.exe 19 | Makefile.dev 20 | src/dune/setup.ml 21 | 22 | .DS_Store 23 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name prowl) 3 | (modules prowl) 4 | (libraries lib batteries)) 5 | (executable 6 | (name prowl_test) 7 | (modules prowl_test) 8 | (libraries lib)) -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | (using menhir 2.1) -------------------------------------------------------------------------------- /ex/basic/fac.prw: -------------------------------------------------------------------------------- 1 | let fac-step a m = a * m & m - 1 2 | and fac n = 1 n fac-step{n} _ -> 3 | to-int fac 4 | -------------------------------------------------------------------------------- /ex/basic/fac2.prw: -------------------------------------------------------------------------------- 1 | mod 2 | def fac n = n (* (n > 0) (n - 1) fac)? 3 | end.fac 4 | -------------------------------------------------------------------------------- /ex/basic/fib.prw: -------------------------------------------------------------------------------- 1 | let fib-step m n = m + n & m -> 2 | let fib n = 1 0 fib-step{n - 1} _ | 0 -> 3 | to-int fib 4 | -------------------------------------------------------------------------------- /ex/basic/fizz.prw: -------------------------------------------------------------------------------- 1 | /* warning: this abuses dynamic typing in an unintended way :) */ 2 | 3 | let div n m = n / m * m == n -> 4 | let fizz = [ 5 | 15 div "fizzbuzz"; 6 | 3 div "fizz"; 7 | 5 div "buzz" 8 | ]? -> 9 | let rep = (as n m {f} -> (n <= m) n f (n + 1) m {f})* -> 10 | to-int 1 % {fizz} rep _ _ _ 11 | -------------------------------------------------------------------------------- /ex/basic/hello.prw: -------------------------------------------------------------------------------- 1 | "Hello, World" 2 | -------------------------------------------------------------------------------- /ex/elem/asop-2.prw: -------------------------------------------------------------------------------- 1 | let (as!) x = x + 1 -> 2 | 3 | 4 as! y -> y 4 | -------------------------------------------------------------------------------- /ex/elem/asop-3.prw: -------------------------------------------------------------------------------- 1 | /* let eith-map {f} = (as (;x) -> (;x f))? -> */ 2 | let eith-map (;x) {f} = (;x f) -> 3 | let double = (* 2) -> 4 | (;4) {double} eith-map 5 | as (;w) -> w 6 | -------------------------------------------------------------------------------- /ex/elem/asop.prw: -------------------------------------------------------------------------------- 1 | let eith-map {f} = (as (;x) -> (;x f))? -> 2 | let (as+) = eith-map -> 3 | (;4) (as+ y -> y * 2) 4 | as (;w) -> w 5 | -------------------------------------------------------------------------------- /ex/elem/bin.prw: -------------------------------------------------------------------------------- 1 | (1, 2) 2 | -------------------------------------------------------------------------------- /ex/elem/cli.prw: -------------------------------------------------------------------------------- 1 | to-int as n -> n + 1 2 | -------------------------------------------------------------------------------- /ex/elem/custom.prw: -------------------------------------------------------------------------------- 1 | let [@@] x = x + 1 -> 2 | 4 @@ 3 | -------------------------------------------------------------------------------- /ex/elem/eithers.prw: -------------------------------------------------------------------------------- 1 | (;5) as (;x) -> 2 | (7;) as (y;) -> 3 | x + y 4 | -------------------------------------------------------------------------------- /ex/elem/fib-opt.prw: -------------------------------------------------------------------------------- 1 | let fib-step n m = m & n + m -> 2 | let fib n = 0 1 (fib-step{n - 1} %)? _ -> 3 | to-int fib 4 | -------------------------------------------------------------------------------- /ex/elem/hof.prw: -------------------------------------------------------------------------------- 1 | let twice x {f} = x f f -> 2 | let s = (+ 1) -> 3 | 0 {{s} twice} twice 4 | -------------------------------------------------------------------------------- /ex/elem/impl.prw: -------------------------------------------------------------------------------- 1 | mod 2 | def impl m = mod def s (x : int) = x + 1 end 3 | def add-two = as (y : int) -> y q.s q.s 4 | 5 | def four = 0 add-two add-two 6 | end.four 7 | -------------------------------------------------------------------------------- /ex/elem/infix.prw: -------------------------------------------------------------------------------- 1 | let (|<>|) x y = x ** 2 + y ** 2 -> 2 | 3 |<>| 4 3 | -------------------------------------------------------------------------------- /ex/elem/intersect.prw: -------------------------------------------------------------------------------- 1 | 2 > 3 && 3 2 | -------------------------------------------------------------------------------- /ex/elem/let-fail.prw: -------------------------------------------------------------------------------- 1 | (5 as x -> ()) x 2 | -------------------------------------------------------------------------------- /ex/elem/let-open.prw: -------------------------------------------------------------------------------- 1 | let open = mod def five = 5 end -> 2 | five 3 | -------------------------------------------------------------------------------- /ex/elem/letop-2.prw: -------------------------------------------------------------------------------- 1 | let g {x} {f} = x (as (;x) -> (;x f))? -> 2 | {(;4)} {as y -> y * 2} g 3 | as (;w) -> w 4 | -------------------------------------------------------------------------------- /ex/elem/letop.prw: -------------------------------------------------------------------------------- 1 | let (let+) {x} {f} = x (as (;x) -> (;x f))? -> 2 | (let+ y = (;4) -> y * 2) 3 | as (;w) -> w 4 | -------------------------------------------------------------------------------- /ex/elem/list-rev.prw: -------------------------------------------------------------------------------- 1 | let m = mod 2 | 3 | def (>-) {t} {h} = (;t,h) 4 | def rev-step = as (t >- h) a -> t (a >- h) 5 | def rev = [] rev-step*+ _2 6 | 7 | end -> 8 | 9 | /* [1, 3, 5, 7, 9] m.rev */ 10 | [1, 3, 5] [] m.rev-step{2} 11 | -------------------------------------------------------------------------------- /ex/elem/load-snoc.prw: -------------------------------------------------------------------------------- 1 | list as open -> 2 | 3 | [] >- 4 4 | -------------------------------------------------------------------------------- /ex/elem/mod-2.prw: -------------------------------------------------------------------------------- 1 | let m = mod 2 | def z = 0 3 | end -> 4 | m.z 5 | -------------------------------------------------------------------------------- /ex/elem/mod.prw: -------------------------------------------------------------------------------- 1 | let m = mod 2 | def z = 0 3 | def s x = x + 1 4 | end -> 5 | m.z m.s{4} m.s{5} 6 | -------------------------------------------------------------------------------- /ex/elem/multidef.prw: -------------------------------------------------------------------------------- 1 | mod 2 | def zero = 0 3 | def one = zero + 1 4 | end.one 5 | -------------------------------------------------------------------------------- /ex/elem/norm-sqr.prw: -------------------------------------------------------------------------------- 1 | let norm-sqr x y = x ** 2 + y ** 2 -> 2 | 7 24 norm-sqr 3 | -------------------------------------------------------------------------------- /ex/elem/open-match.prw: -------------------------------------------------------------------------------- 1 | let m = mod 2 | def s x = x + 1 3 | end -> 4 | 5 | m 0 % as open -> s s s 6 | -------------------------------------------------------------------------------- /ex/elem/open.prw: -------------------------------------------------------------------------------- 1 | mod 2 | 3 | def m = mod def z = 0 end 4 | 5 | open m 6 | 7 | def z2 = z 8 | 9 | end.z2 10 | -------------------------------------------------------------------------------- /ex/elem/snoc.prw: -------------------------------------------------------------------------------- 1 | [1, 2, 3] as t >- h -> h 2 | -------------------------------------------------------------------------------- /ex/elem/stack-match.prw: -------------------------------------------------------------------------------- 1 | [3, 2, 1] as [h, j, k] -> k*100 + h*10 + j 2 | -------------------------------------------------------------------------------- /ex/elem/stack.prw: -------------------------------------------------------------------------------- 1 | [1, 2, 3] 2 | (;(;(;(<>;),1),2),3) 3 | -------------------------------------------------------------------------------- /ex/elem/test-2.prw: -------------------------------------------------------------------------------- 1 | [1] {as x -> x + 1} stack.map 2 | -------------------------------------------------------------------------------- /ex/elem/test-3.prw: -------------------------------------------------------------------------------- 1 | mod 2 | 3 | def (>-) t h = (;t,h) 4 | 5 | local def rev-step (t >- h) a = t (a >- h) 6 | def rev = [] rev-step*+ _2 7 | 8 | def map-rev {f} = 9 | let map-step (t >- h) a = t (a >- h f) -> 10 | [] map-step*+ _2 11 | 12 | def map = map-rev rev 13 | 14 | end as open -> 15 | 16 | [1] {as x -> x + 1} map 17 | -------------------------------------------------------------------------------- /ex/elem/test-4.prw: -------------------------------------------------------------------------------- 1 | mod 2 | 3 | def (>-) t h = (;t,h) 4 | 5 | local def rev-step (t >- h) a = t (a >- h) 6 | def rev = [] rev-step*+ _2 7 | 8 | def map-rev {f} = 9 | let map-step (t >- h) a = t (a >- h f) -> 10 | [] map-step*+ _2 11 | 12 | def map = map-rev rev 13 | 14 | end as open -> 15 | 16 | [1, 2, 3] rev 17 | -------------------------------------------------------------------------------- /ex/elem/test-5.prw: -------------------------------------------------------------------------------- 1 | let (>-) {f} {r} = (;f,r) -> 2 | [] >- 1 /* as t >- h -> h */ 3 | -------------------------------------------------------------------------------- /ex/elem/test-6a.prw: -------------------------------------------------------------------------------- 1 | let f x y = (x,y) -> 2 | 1 2 f as (a, b) -> b 3 | -------------------------------------------------------------------------------- /ex/elem/test-6b.prw: -------------------------------------------------------------------------------- 1 | let f x y = (;x,y) -> 2 | 1 2 f as (;a,b) -> b 3 | -------------------------------------------------------------------------------- /ex/elem/test-6c.prw: -------------------------------------------------------------------------------- 1 | let f x = (;x) -> 2 | 1 f as (;a) -> a 3 | -------------------------------------------------------------------------------- /ex/elem/test-7.prw: -------------------------------------------------------------------------------- 1 | [4, 5, 6] as t1 >- h1 -> 2 | t1 as t2 >- h2 -> 3 | h2 4 | -------------------------------------------------------------------------------- /ex/elem/test-7b.prw: -------------------------------------------------------------------------------- 1 | let (>-) {t} {h} = (;t,h) -> 2 | ([] >- 0) 3 | (;[],0) 4 | (;(<>;),0) 5 | [0] 6 | -------------------------------------------------------------------------------- /ex/elem/test-7c.prw: -------------------------------------------------------------------------------- 1 | let (>-) {t} {h} = (;t,h) -> 2 | ([] >- 0) as t >- h -> 3 | t 4 | -------------------------------------------------------------------------------- /ex/elem/test-7d.prw: -------------------------------------------------------------------------------- 1 | let (>-) {t} {h} = (;t,h) -> 2 | ([] >- 0) as (;t,h) -> 3 | t 4 | -------------------------------------------------------------------------------- /ex/elem/test-7e.prw: -------------------------------------------------------------------------------- 1 | let (>-) {t} {h} = (;t,h) -> 2 | let rev-step = as (t >- h) a -> t (a >- h) -> 3 | [1, 2] [] rev-step{2} 4 | -------------------------------------------------------------------------------- /ex/elem/test-7f.prw: -------------------------------------------------------------------------------- 1 | let (>-) {t} {h} = (;t,h) -> 2 | let rev-step = as (t >- h) a -> t (a >- h) -> 3 | let rev = [] rev-step*+ _2 -> 4 | 5 | [1, 3, 5, 7, 9] rev 6 | -------------------------------------------------------------------------------- /ex/inter/fizz.prw: -------------------------------------------------------------------------------- 1 | let rules = [ 2 | (3, "fizz"), 3 | (5, "buzz"), 4 | (7, "bizz") 5 | ] 6 | 7 | and fizzbuzz = 8 | (1 ..) as+ n -> 9 | rules n % div <&> snd 10 | & fold (null n to-str)? -> 11 | 12 | to-int fizzbuzz {put} iter 13 | -------------------------------------------------------------------------------- /ex/inter/nfib.prw: -------------------------------------------------------------------------------- 1 | let nfib n m = 2 | [0, 1] (^ m take sum push){n} hd -> 3 | 4 | to-int % to-int % nfib 5 | -------------------------------------------------------------------------------- /ex/temp.prw: -------------------------------------------------------------------------------- 1 | 5 mod 2 | def f = [ 3 | as 0 -> "hi"; 4 | as n -> n - 1 & f 5 | ] 6 | end.f 7 | -------------------------------------------------------------------------------- /prowl.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | module O = BatOptParse.Opt 3 | 4 | open Lib 5 | open Interpret 6 | module L = Eval.LazySearch 7 | module R = Run(L) 8 | open Cli 9 | 10 | open Gen 11 | open Ast 12 | 13 | let lex_out = flag "output lexemes" "lex" 14 | let ast_out = flag "output ast as ocaml ADTs" "ast" 15 | let span_out = flag "output code spans with ast" "span" 16 | let interpret = flags "interpret sources" "interpret" 'i' 17 | (* let no_std = flag "don't search for the std" "wstd" *) 18 | 19 | let compile file args = 20 | if O.get lex_out then File.open_in file |> lex; 21 | let ast = parse (File.open_in file) in 22 | begin if O.get ast_out then 23 | let () = if O.get span_out then span_flag := true in 24 | let str = show_program ast in 25 | String.nreplace ~str ~sub:"Ast." ~by:"" 26 | |> print_endline end; 27 | begin if O.get interpret then try 28 | Interpret.S.(restack args init) 29 | |> R.program (Build.endow "std" ast) 30 | |> L.unsafe_cut 31 | |> Interpret.S.s 32 | |> List.rev_map V.show 33 | |> List.iter print_endline with 34 | | L.Rejected -> print_endline "rejected" 35 | | Error.ProwlError (loc, msg) -> 36 | Error.show_err loc msg 37 | |> print_endline 38 | end 39 | 40 | let () = match P.parse_argv op with 41 | | [] -> P.usage op () 42 | | lst :: args -> compile lst (List.map (fun x -> V.VStr x) args) 43 | -------------------------------------------------------------------------------- /prowl_test.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Alcotest 3 | 4 | open Lib 5 | open Util 6 | 7 | let tests = [ 8 | "fundamentals", [ 9 | "lit1", "4\n5\nhi"; 10 | "arith1", "7"; 11 | "arith2", "5"; 12 | ]; 13 | "bindings", [ 14 | "as1", "11"; 15 | "let1", "6"; 16 | "let-func", "25"; 17 | "let-as", "2"; 18 | "let-sect", "4"; 19 | "compose", "3"; 20 | "sect1", "1"; 21 | "sect-full", "20"; 22 | "sect-left", "2"; 23 | "sect-right", "1"; 24 | ]; 25 | "patterns", [ 26 | "cat", "9"; 27 | "left", "13"; 28 | "right", "0"; 29 | "pair", "4"; 30 | "capture-direct", "7"; 31 | "capture-indirect", "7"; 32 | "capture-fun", "2"; 33 | "nest-capture-pair", "2"; 34 | "nest-either-pair", "1"; 35 | "long-pair", "5"; 36 | "const-int", "1"; 37 | "const-int-reject", "rejected"; 38 | "const-str", "0"; 39 | "pair-func", "2"; 40 | "eith-func", "1"; 41 | "bin-func", "2"; 42 | "stack", "3\n4\n5"; 43 | "stack-rejected-low", "rejected"; 44 | "stack-rejected-high", "rejected"; 45 | ]; 46 | "flow", [ 47 | "cat", "5"; 48 | "alt", "0"; 49 | "alt-handle", "1"; 50 | "alt-rejected", "rejected"; 51 | "alt-greedy", "0"; 52 | "case", "2"; 53 | "intersect", "2"; 54 | "n-times", "7\n23"; 55 | "opt", "3"; 56 | "opt-handle", "2"; 57 | "star", "6"; 58 | "star-greedy", "1"; 59 | "plus", "3"; 60 | "plus-reject", "rejected"; 61 | "alt-cut-accepted", "0"; 62 | "alt-cut", "rejected"; 63 | "alt-cut-handle", "1"; 64 | "case-rel", "8"; 65 | "case-rel2", "11"; 66 | "case-cut", "rejected"; 67 | "star-cut", "rejected"; 68 | "star-rel", "5"; 69 | "inversion", "6"; 70 | "inversion-rejected", "rejected"; 71 | "noncap-accept", "6"; 72 | "noncap-reject", "rejected"; 73 | "atomic-accept", "1"; 74 | "atomic-reject", "rejected"; 75 | ]; 76 | "combinators", [ 77 | "simple", "44"; 78 | "compound", "3"; 79 | ]; 80 | "modules", [ 81 | "access", "3"; 82 | "open", "7"; 83 | (* "recursion", "720"; *) 84 | ]; 85 | "data", [ 86 | "rev", "1\n3\n5\n7\n9"; 87 | "map", "2\n4\n6"; 88 | (* "filter", "2"; *) 89 | "cat", "1\n2\n3\n4"; 90 | "cat-rev", "1\n2\n4\n3"; 91 | (* "flatten", "1\n2\n3\n4"; *) (* head is getting elems *) 92 | ] 93 | ] 94 | 95 | open Interpret 96 | module L = Eval.LazySearch 97 | open Run(L) 98 | 99 | let run_file fname = 100 | File.open_in ("test/" ^ fname ^ ".prw") 101 | |> Gen.parse |> fun ast -> try 102 | Interpret.S.init 103 | |> program (Build.endow "std" ast) 104 | |> L.unsafe_cut 105 | |> Interpret.S.s 106 | |> List.rev_map V.show 107 | |> String.concat "\n" with 108 | | L.Rejected -> "rejected" 109 | 110 | let check_file group file output () = 111 | run_file (Printf.sprintf "%s/%s" group file) 112 | |> check string "outputs match" output 113 | 114 | let () = 115 | begin 116 | let+ group, lst = tests in 117 | group, let+ fn, out = lst in 118 | check_file group fn out 119 | |> test_case fn `Quick 120 | end 121 | |> run "Prowl Integration Tests" 122 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # Introduction 2 | 3 | The [Prowl Language](https://github.com/UberPyro/prowl) is a statically-typed stack-based programming language that draws from a wide range of inspirations, mainly functional, logic, and stack-based languages. However, the language is unique with its powerful program combinator system. Prowl exploits a homomorphism between string concatenation and [concatenative languages](https://concatenative.org/wiki/view/Concatenative%20language) that allows regex to be used as a computational and mental model for control flow. This model provides a rigid framework to solve combinatory and constraint problems (in addition to general purpose programming) yet retains performant translations into DFAs due to the regex base. With stacks for data and regex for control flow, Prowl provides a unique but ergonomic way to think about hard problems. 4 | 5 | Prowl has 3 major influences that you should know about: 6 | 7 | - [The Kitten Language](http://kittenlang.org/) 8 | - [The Vinegar Language](https://github.com/catseye/Vinegar) 9 | - [Oniguruma Regex](https://github.com/kkos/oniguruma/blob/master/doc/RE) 10 | 11 | Prowl mirrors Kitten’s ambition in modernizing the concatenative paradigm with syntactic and semantic ML features. Prowl sheds its concatenative purity and imports key quality of life features such as infix, lexically scoped variable bindings, anonymous functions, destructuring, and pattern matching to elevate the language’s productivity and expressivity. From OCaml, we borrow a lot of syntax, binding operators, ML modules and functors, and even the plan for modular implicits. Indeed, Prowl does not shy away from the deeper developments of other languages – we also borrow some of Haskell’s common abstractions such as monoids, functors, and monads, and plan to use the modular implicits feature to support them and their infix operators. We also take significant inspiration from Joy, importing it's closures, stack combinators, and recursive combinators – the latter modified to better accomodate Prowl's spin. 12 | 13 | Prowl also draws inspiration directly from Vinegar and Oniguruma Regex in its unique and powerful descriptions of control flow. It all starts with Vinegar’s key innovation: 14 | 15 | - All operators can fail 16 | 17 | While typical concatenative languages have functions of (in Haskell notation) `Stack -> Stack`, Vinegar has functions of `Stack -> Maybe Stack`. Every function can fail but can be handled with the alternation operator `|`, so that alternate branches can be tried if one fails. It’s an interesting novelty and variation of the paradigm, and it’s definitely worth checking out in its own right. However, Prowl takes things one step further by innovating that functions should be `Stack -> List Stack`, where the list is actually lazy in practice. This is to say that all functions produce some number of viable future stacks based off some past stack, and that we are guiding a search down these spaces, adding and pruning stacks as we move along.  We can then use concatenation to compose these functions, alternations to search down one list before the other, and then define quantifiers such as Kleene star in terms of the existing definitions of concatenation and alternation. Kleene stars and n-times quantifiers in regex are like while and for loops in imperative programming, and so it actually forms a nice basis to program in. And it’s efficient – regex control flow can target DFAs where edges are programs rather than characters, enabling some unique optimization opportunities, yet we retain Turing completeness with heap-allocated lists.   18 | 19 | Prowl is an ambitious language with a unique spin but aims to remain fully productive. If this sounds like it interests you, give the [tutorial](https://uberpyro.github.io/prowl/introduction.html) a look, as the parts are described in much greater detail. 20 | -------------------------------------------------------------------------------- /src/build.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | 3 | open Ast 4 | open Util 5 | 6 | type file = 7 | | File of string * string 8 | | Folder of string * file list 9 | 10 | let rec load_file ?(path="") fn = 11 | if Sys.is_directory (path ^ fn) 12 | then 13 | Sys.readdir (path ^ fn) 14 | |> Array.map (load_file ~path:(path ^ fn ^ "/")) 15 | |> Array.to_list 16 | |> fun x -> Folder (fn, x) 17 | else File (path, fn) 18 | 19 | let rec def_of_file = function 20 | | File (path, fn) -> 21 | File.open_in (path ^ fn) 22 | |> Gen.parse 23 | |> fun (am, (_, loc as e1)) -> 24 | Def (am, false, (PId (Filename.remove_extension fn), loc), e1, None) 25 | | Folder (sn, lst) -> 26 | lst 27 | |> List.map (fun fn -> def_of_file fn, dum) 28 | |> fun def_lst -> 29 | Def (Pub, false, (PId sn, dum), (Mod def_lst, dum), None) 30 | 31 | let endow lib (am, e) = 32 | lib 33 | |> load_file 34 | |> def_of_file 35 | |> function (Def (_, _, _, (_, loc as m), _)) -> am, ( 36 | Cat [ 37 | m; 38 | (* StackComb [Run 1, loc], loc; *) 39 | As ("", (POpen false, loc), e), loc 40 | ], loc 41 | ) | _ -> failwith "Did not retrieve definition" 42 | -------------------------------------------------------------------------------- /src/cli.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | 3 | module S = BatOptParse.StdOpt 4 | module O = BatOptParse.Opt 5 | module P = BatOptParse.OptParser 6 | 7 | let default_opt var const = O.{ 8 | option_metavars = []; 9 | option_defhelp = None; 10 | option_get = (fun _ -> !var); 11 | option_set_value = (fun x -> var := Some x); 12 | option_set = (fun _ _ -> var := Some const) 13 | } 14 | 15 | let op = 16 | P.make 17 | ~prog:"Prowl Compiler" 18 | () 19 | 20 | let flag help long_name = 21 | let st = default_opt (ref (Some false)) true in 22 | P.add op ~help ~long_name st; 23 | st 24 | 25 | let flags help long_name short_name = 26 | let st = default_opt (ref (Some false)) true in 27 | P.add op ~help ~long_name ~short_name st; 28 | st 29 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs unqualified) 2 | (library 3 | (name lib) 4 | (preprocess (pps ppx_deriving.show)) 5 | (libraries batteries alcotest)) -------------------------------------------------------------------------------- /src/parse/ast.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | open Lexing 3 | 4 | type 'a loc = 'a * (position * position) 5 | 6 | let span_flag = ref false 7 | let span_of_pos p = p.pos_lnum, p.pos_cnum - p.pos_bol 8 | let multispan_of_pos (p1, p2) = 9 | let x1, y1 = span_of_pos p1 in 10 | let x2, y2 = span_of_pos p2 in 11 | x1, y1, x2, y2 12 | 13 | let pp_loc c f (a, loc) = 14 | c f a; 15 | let x1, y1, x2, y2 = multispan_of_pos loc in 16 | begin 17 | if !span_flag 18 | then Printf.sprintf " [%d:%d => %d:%d]" x1 y1 x2 y2 19 | else "" 20 | end |> pp_print_string f 21 | 22 | type access_mod = Priv | Opaq | Pub [@@deriving show] 23 | 24 | and sp = sp_t loc [@@deriving show] 25 | and sp_t = 26 | | SDef of string * ty 27 | | STy of string * string list * ty option 28 | | SData of string * string list * data 29 | [@@deriving show] 30 | 31 | and ty = ty_t loc [@@deriving show] 32 | and ty_t = ty_term * ty_term [@@deriving show] 33 | and ty_term = ty_term_t loc [@@deriving show] 34 | and ty_term_t = 35 | | TId of string 36 | | TGen of string 37 | | TAccess of ty_term * string 38 | | TCat of ty_term list 39 | | TCapture of ty 40 | | TList of ty 41 | | TMap of ty_term * ty 42 | | TUnit 43 | | TVoid 44 | | TBin of ty list list 45 | | TSig of sp list 46 | | TMod of sp list 47 | | TImpl of string * ty 48 | [@@deriving show] 49 | 50 | and data = data_t loc [@@deriving show] 51 | and data_t = (ty_term list * string) list list [@@deriving show] 52 | 53 | and s = s_t loc [@@deriving show] 54 | and s_t = 55 | | Def of access_mod * implicit * p * e * ty option 56 | | Open of implicit * e 57 | | Mix of e 58 | | Ty of access_mod * string * string list * ty option 59 | | Data of access_mod * string * string list * data 60 | [@@deriving show] 61 | 62 | and implicit = bool 63 | 64 | and greed = Gre | Rel | Cut [@@deriving show] 65 | and quant = 66 | | Opt 67 | | Plus 68 | | Star 69 | | Num of e 70 | | Min of e 71 | | Max of e 72 | | Range of e * e 73 | [@@deriving show] 74 | 75 | and stack_comb = stack_comb_t loc [@@deriving show] 76 | and stack_comb_t = 77 | | Dup of int 78 | | Zap of int 79 | | Rot of int 80 | | Run of int 81 | [@@deriving show] 82 | 83 | and det_control = { 84 | d_try: bool; 85 | d_parallel: bool; 86 | det: det_control_core; 87 | } [@@deriving show] 88 | 89 | and det_control_core = 90 | | DNone 91 | | DOne 92 | | DCut 93 | | DScore 94 | | DMany 95 | [@@deriving show] 96 | 97 | and e = e_t loc [@@deriving show] 98 | and e_t = 99 | | Id of string 100 | | Access of e * string 101 | | Get of e * e 102 | (* Todo: Data & Tuple access *) 103 | 104 | | Int of int 105 | | Flo of float 106 | | Char of char 107 | | Str of string 108 | | Unit 109 | 110 | | List of e list 111 | | Map of (e * e) list 112 | | Pair of e * e 113 | | Left of e 114 | | Right of e 115 | | EData of string 116 | | Prod of e list 117 | | Mod of s list 118 | | Impl of e 119 | | Capture of e 120 | 121 | | Sect of string 122 | | SectLeft of string * e 123 | | SectRight of e * string 124 | 125 | | Cat of e list 126 | | Bop of e * string * e 127 | | StackComb of stack_comb list 128 | | Det of det_control 129 | 130 | | Let of (string * implicit * p * e) list * e 131 | | As of string * p * e 132 | 133 | | Quant of e * quant * greed 134 | | Case of (greed * e) list 135 | | Inv of e list 136 | | Span of e * e 137 | 138 | | Noncap of e 139 | | Cap of e 140 | | Atomic of e 141 | [@@deriving show] 142 | 143 | and p = p_t loc [@@deriving show] 144 | and p_t = 145 | | PId of string 146 | | PAccess of p * string 147 | | PBlank 148 | | PCat of p list 149 | | PAsc of p * ty 150 | | PImpl of p * ty 151 | | POpen of implicit 152 | | PUse 153 | 154 | | PInt of int 155 | | PFlo of float 156 | | PStr of string 157 | | PChar of char 158 | | PUnit 159 | 160 | | PList of p list 161 | | PMap of (e * p) list 162 | | PPair of p * p 163 | | PLeft of p 164 | | PRight of p 165 | | PData of string 166 | | PProd of p list 167 | | PCapture of p 168 | 169 | | PBop of p * string * p 170 | [@@deriving show] 171 | 172 | and program = access_mod * e [@@deriving show] 173 | -------------------------------------------------------------------------------- /src/parse/dune: -------------------------------------------------------------------------------- 1 | (ocamllex lex lex_comb) 2 | (menhir 3 | (modules parse parse_comb) 4 | (flags --explain --strict)) -------------------------------------------------------------------------------- /src/parse/gen.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Printf 3 | 4 | open Ast 5 | open Parse 6 | 7 | let parse ch = 8 | let lexbuf = Lexing.from_channel ch in 9 | try Parse.program Lex.token lexbuf with 10 | | _ -> 11 | let p = lexbuf.lex_curr_p in 12 | Printf.sprintf 13 | "Unexpected Token at [%d,%d]" 14 | p.pos_lnum (p.pos_cnum - p.pos_bol) 15 | |> failwith 16 | 17 | let string_of_quant = function 18 | | Opt -> "?" 19 | | Plus -> "+" 20 | | Star -> "*" 21 | | _ -> "not implemented" 22 | 23 | let string_of_greed = function 24 | | Gre -> "" 25 | | Rel -> "?" 26 | | Cut -> "+" 27 | 28 | let c_str s = function 29 | | 0 -> s 30 | | n -> sprintf "%s %d" s n 31 | 32 | let string_of_comb = function 33 | | StackComb lst -> 34 | List.map fst lst 35 | |> List.map begin function 36 | | Dup n -> c_str "DUP" n 37 | | Zap n -> c_str "ZAP" n 38 | | Rot n -> c_str "ROT" n 39 | | Run n -> c_str "RUN" n 40 | end |> String.concat "; " 41 | | _ -> failwith "Not a stack combinator" 42 | 43 | let string_of_bindop op = function 44 | | "" -> op 45 | | s -> sprintf "%sOP %s" op s 46 | 47 | let string_of_token = function 48 | | WIDE_ARROW -> "=>" 49 | | VOID -> "<;>" 50 | | UNIT -> "<>" 51 | | TYPE -> "TYPE" 52 | | TIMES_BRACK -> "{ (regex)" 53 | | TIMES -> "*" 54 | | TILDE -> "~" 55 | | SYMBOL s -> sprintf "SYMBOL %s" s 56 | | STR s -> sprintf "STRING %s" s 57 | | SNOC -> ">-" 58 | | SIG -> "SIG" 59 | | SEMICOLON g -> sprintf ";%s" (string_of_greed g) 60 | | RPAREN -> ")" 61 | | RBRACK -> "]" 62 | | RBRACE g -> sprintf "}%s" (string_of_greed g) 63 | | RANGE -> ".." 64 | | QUANT (q, g) -> 65 | sprintf "QUANT %s%s" (string_of_quant q) (string_of_greed g) 66 | | PRIV -> "PRIV" 67 | | PLUS -> "+" 68 | | OPEN -> "OPEN" 69 | | OPAQ -> "OPAQ" 70 | | NONCAP_BRACK -> "(?:" 71 | | NEQ -> "/=" 72 | | MOD -> "MOD" 73 | | MIX -> "MIX" 74 | | MINUS -> "-" 75 | | LT -> "<" 76 | | LPAREN -> "(" 77 | | LET s -> string_of_bindop "LET" s 78 | | LE -> "<=" 79 | | LBRACK -> "[" 80 | | LBRACE -> "{" 81 | | FISH -> ">=>" 82 | | INV_BRACK -> "[^" 83 | | INTERSECT -> "&&" 84 | | INT i -> sprintf "INTEGER %d" i 85 | | INFIX s -> sprintf "INFIX %s" s 86 | | IMPL -> "IMPL" 87 | | ID s -> sprintf "ID %s" s 88 | | GT -> ">" 89 | | GE -> ">=" 90 | | FLOAT f -> sprintf "FLOAT %f" f 91 | | EXP -> "**" 92 | | EQ -> "==" 93 | | EOF -> "EOF" 94 | | END -> "END" 95 | | EFFECT -> "--" 96 | | DOT -> "." 97 | | DO -> "DO" 98 | | DIVIDE -> "/" 99 | | DEF -> "DEF" 100 | | DATA -> "DATA" 101 | | CONS -> "-<" 102 | | COMMA -> "," 103 | | COMB e -> sprintf "COMB %s" (string_of_comb e) 104 | | COLON -> ":" 105 | | CHAR c -> sprintf "CHAR %c" c 106 | | CAT -> "&" 107 | | CAP s -> sprintf "CAP %s" s 108 | | BLANK -> "BLANK" 109 | | BIND -> ">>=" 110 | | BACKARROW -> "<-" 111 | | ATOM_BRACK -> "(?>" 112 | | ASSIGN -> "=" 113 | | AS s -> string_of_bindop "AS" s 114 | | ARROW -> "->" 115 | | APPEND -> "++" 116 | | AND s -> string_of_bindop "AND" s 117 | | ALT -> "|" 118 | | ALT_REL -> "|?" 119 | | ALT_CUT -> "|+" 120 | | IMPL_LBRACK -> "[<" 121 | | IMPL_RBRACK -> ">]" 122 | | SPEC -> "SPEC" 123 | | TRY -> "TRY" 124 | | PARALLEL -> "PARALLEL" 125 | | NONE -> "NONE" 126 | | ONE -> "ONE" 127 | | CUT -> "CUT" 128 | | SCORE -> "SCORE" 129 | | MANY -> "MANY" 130 | 131 | let lex ch = 132 | let lexbuf = Lexing.from_channel ch in 133 | while 134 | let l = string_of_token (Lex.token lexbuf) in 135 | print_endline l; 136 | l <> "EOF" do 137 | () 138 | done 139 | -------------------------------------------------------------------------------- /src/parse/lex.mll: -------------------------------------------------------------------------------- 1 | { open Batteries 2 | open Lexing 3 | 4 | open Lex_proc 5 | open Parse } 6 | 7 | let eol = ['\r' '\n'] | '\r' '\n' 8 | let whitespace = ' '+ 9 | 10 | let digit = ['0'-'9'] 11 | let sig_digits = ['1'-'9'] digit* 12 | 13 | let hex_digit = digit | ['A'-'F' 'a'-'f'] 14 | 15 | let hex = 16 | hex_digit 17 | | hex_digit hex_digit 18 | | hex_digit hex_digit hex_digit 19 | | hex_digit hex_digit hex_digit hex_digit 20 | 21 | let id_char = ['A'-'Z' 'a'-'z' '0'-'9' '_' '\''] 22 | let id_tail = ('-'? id_char)* 23 | let id = ['a'-'z'] id_tail 24 | let cap_id = ['A'-'Z'] id_tail 25 | 26 | let op_char = [ 27 | '~' '!' '@' '#' '$' '%' '^' '&' '*' '-' '=' '+' 28 | '.' '?' ':' '|' '/' '\\' 29 | ] 30 | 31 | let symbol = op_char+ 32 | let infix = (op_char | ['<' '>'])+ 33 | 34 | let integer = '0' | sig_digits 35 | let float = sig_digits '.' digit* | '.' digit+ 36 | 37 | let char_body = [^ '\''] 38 | let string_body = ([^ '"'] | "\\\"")* 39 | 40 | let comb = (['^' '_' '%' '$'] integer?)+ 41 | 42 | let suffix = ['?' '+' '*'] 43 | let greed = ['?' '+']? 44 | 45 | rule token = parse 46 | | "/*" {comment 0 lexbuf} 47 | | eof {EOF} 48 | | eol {new_line lexbuf; set_cat(); token lexbuf} 49 | | whitespace {set_cat(); token lexbuf} 50 | | '\t' {set_cat(); advance lexbuf; token lexbuf} 51 | 52 | | "as" (infix? as s) {AS s} 53 | | "let" (infix? as s) {LET s} 54 | | "and" (infix? as s) {AND s} 55 | 56 | | '_' ['A'-'Z' 'a'-'z'] id_tail {BLANK} 57 | | comb as s {set_regex(); COMB (parse_comb s)} (* modify to exclude _? *) 58 | | (((suffix as s) (greed as g)) as z) { 59 | if !mode == Cat then begin match z with 60 | | "*" -> TIMES 61 | | "+" -> PLUS 62 | | "++" -> APPEND 63 | | s -> SYMBOL s end 64 | else QUANT (parse_quant s g)} 65 | 66 | | "def" {DEF} 67 | | "spec" {SPEC} 68 | | "open" {OPEN} 69 | | "mix" {MIX} 70 | | "impl" {IMPL} 71 | | "priv" {PRIV} 72 | | "opaq" {OPAQ} 73 | | "type" {TYPE} 74 | | "sig" {SIG} 75 | | "data" {DATA} 76 | 77 | | "try" {TRY} 78 | | "parallel" {PARALLEL} 79 | | "none" {NONE} 80 | | "one" {ONE} 81 | | "cut" {CUT} 82 | | "score" {SCORE} 83 | | "many" {MANY} 84 | 85 | | "+" {PLUS} 86 | | "-" {MINUS} 87 | | "*" {TIMES} 88 | | "/" {DIVIDE} 89 | 90 | | "**" {EXP} 91 | | ".." {RANGE} 92 | | ">-" {SNOC} 93 | | "-<" {CONS} 94 | 95 | | "++" {APPEND} 96 | | ">>=" {BIND} 97 | | ">=>" {FISH} 98 | | "|" {ALT} 99 | | "|?" {ALT_REL} 100 | | "|+" {ALT_CUT} 101 | | "&" {CAT} 102 | | "&&" {INTERSECT} 103 | 104 | | "==" {EQ} 105 | | "/=" {NEQ} 106 | | "<" {LT} 107 | | "<=" {LE} 108 | | ">" {GT} 109 | | ">=" {GE} 110 | 111 | | ":" {COLON} 112 | | "=" {ASSIGN} 113 | | "--" {EFFECT} 114 | | "->" {ARROW} 115 | | "~" {TILDE} 116 | | "=>" {WIDE_ARROW} 117 | | "<-" {BACKARROW} 118 | | "." {DOT} 119 | | "," {set_cat(); COMMA} 120 | | ";" (greed as g) {set_cat(); SEMICOLON (parse_greed g)} 121 | 122 | | "(?:" {set_cat(); NONCAP_BRACK} 123 | | "(?>" {set_cat(); ATOM_BRACK} 124 | | "[^" {set_cat(); INV_BRACK} 125 | 126 | | "[<" {set_cat(); IMPL_LBRACK} 127 | | ">]" {IMPL_RBRACK} 128 | 129 | | "(" {set_cat(); LPAREN} 130 | | "[" {set_cat(); LBRACK} 131 | | "{" {if !mode == Cat then LBRACE else TIMES_BRACK} 132 | | ")" {set_regex(); RPAREN} 133 | | "]" {set_regex(); RBRACK} 134 | | "}" (greed as g) {set_regex(); RBRACE (parse_greed g)} 135 | | "do" {set_cat(); DO} 136 | | "mod" {set_cat(); MOD} 137 | | "end" {set_regex(); END} 138 | 139 | | (integer as i) {set_regex(); INT (int_of_string i)} 140 | | (float as f) {set_regex(); FLOAT (float_of_string f)} 141 | | '"' (string_body as s) '"' {set_regex(); STR (decode s)} 142 | | '\'' (char_body as s) '\'' {set_regex(); CHAR s} 143 | | '\'' ("\\x" hex) as s '\'' {set_regex(); CHAR (decode s).[0]} 144 | | '\'' '\\' (_ as c) '\'' {set_regex(); CHAR c} 145 | | "<>" {set_regex(); UNIT} 146 | | "<;>" {set_regex(); VOID} 147 | 148 | | id as s {set_regex(); ID s} 149 | | cap_id as s {CAP s} 150 | | symbol as s {SYMBOL s} 151 | | infix as s {INFIX s} 152 | 153 | and comment level = parse 154 | | "*/" {if level = 0 then token lexbuf 155 | else comment (level-1) lexbuf} 156 | | "/*" {comment (level+1) lexbuf} 157 | | _ {comment level lexbuf} 158 | -------------------------------------------------------------------------------- /src/parse/lex_comb.mll: -------------------------------------------------------------------------------- 1 | { open Batteries 2 | 3 | open Parse_comb } 4 | 5 | let num = '0' | ['1'-'9']['0'-'9']* 6 | 7 | (* Lexes the stack combinators *) 8 | rule token = parse 9 | | "^" (num as n) {DUP (int_of_string n)} 10 | | "_" (num as n) {ZAP (int_of_string n)} 11 | | "%" (num as n) {ROT (int_of_string n)} 12 | | "$" (num as n) {RUN (int_of_string n)} 13 | | "^" {DUP 1} 14 | | "_" {ZAP 1} 15 | | "%" {ROT 2} 16 | | "$" {RUN 1} 17 | | eof {EOF} 18 | -------------------------------------------------------------------------------- /src/parse/lex_proc.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Lexing 3 | 4 | open Util 5 | open Ast 6 | 7 | let tabsize = ref 2 8 | 9 | type mode = Cat | Regex 10 | let mode = ref Cat 11 | 12 | let advance lexbuf = 13 | let lcp = lexbuf.lex_curr_p in 14 | lexbuf.lex_curr_p <- 15 | {lcp with pos_cnum = lcp.pos_cnum + !tabsize - 1} 16 | 17 | let set_cat () = mode := Cat 18 | let set_regex () = mode := Regex 19 | 20 | let utf8encode s = 21 | let prefs = [|0x0; 0xc0; 0xe0|] in 22 | let s1 n = String.make 1 (Char.chr n) in 23 | 24 | let rec ienc k sofar resid = 25 | let bct = if k = 0 then 7 else 6 - k in 26 | if resid < 1 lsl bct then (s1 (prefs.(k) + resid)) ^ sofar 27 | else ienc (k + 1) (s1 (0x80 + resid mod 64) ^ sofar) (resid / 64) in 28 | 29 | ienc 0 "" (int_of_string ("0x" ^ s)) 30 | 31 | let decode s = 32 | let re = Str.regexp "\\\\u[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]" in 33 | let subst = function 34 | | Str.Delim u -> utf8encode (String.sub u 2 4) 35 | | Str.Text t -> t in 36 | String.concat "" (List.map subst (Str.full_split re s)) 37 | 38 | let decode_char = 39 | decode 40 | >> String.to_seq 41 | >> Seq.hd 42 | 43 | let parse_comb = 44 | from_string 45 | >> Parse_comb.parse Lex_comb.token 46 | 47 | let parse_quant q g = 48 | begin match q with 49 | | '?' -> Opt 50 | | '+' -> Plus 51 | | '*' -> Star 52 | | _ -> failwith (Printf.sprintf "Unknown quantifier %c" q) 53 | end, begin match g with 54 | | "" -> Gre 55 | | "?" -> Rel 56 | | "+" -> Cut 57 | | _ -> failwith (Printf.sprintf "Unknown greediness %s" g) 58 | end 59 | 60 | let parse_greed = function 61 | | "" -> Gre 62 | | "?" -> Rel 63 | | "+" -> Cut 64 | | g -> failwith (Printf.sprintf "Unknown greediness %s" g) 65 | -------------------------------------------------------------------------------- /src/parse/parse.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Batteries 3 | open Ast 4 | 5 | open Util 6 | open Parse_proc 7 | 8 | let e_t_of_lst : e list -> e_t = function 9 | | [h, _] -> h 10 | | lst -> Cat lst 11 | %} 12 | 13 | %token 14 | DEF OPEN MIX IMPL SIG END DO 15 | OPAQ TYPE DATA SPEC PRIV MOD 16 | 17 | TRY PARALLEL 18 | NONE ONE CUT SCORE MANY 19 | 20 | PLUS MINUS TIMES DIVIDE 21 | EXP RANGE SNOC CONS 22 | APPEND BIND FISH 23 | ALT ALT_REL ALT_CUT CAT 24 | 25 | EQ NEQ LT LE GT GE 26 | 27 | COLON TILDE ASSIGN ARROW 28 | WIDE_ARROW BACKARROW 29 | COMMA DOT INTERSECT 30 | 31 | BLANK EOF EFFECT 32 | 33 | LPAREN RPAREN 34 | LBRACK RBRACK 35 | LBRACE 36 | 37 | IMPL_LBRACK IMPL_RBRACK 38 | NONCAP_BRACK ATOM_BRACK 39 | INV_BRACK TIMES_BRACK 40 | UNIT VOID 41 | 42 | %token 43 | LET AND AS STR 44 | ID CAP SYMBOL INFIX 45 | 46 | %token INT 47 | %token FLOAT 48 | %token CHAR 49 | 50 | %token COMB 51 | %token QUANT 52 | %token SEMICOLON RBRACE 53 | 54 | %left CAT 55 | %left ALT ALT_REL ALT_CUT 56 | %left INTERSECT 57 | %left BIND 58 | %left FISH 59 | %left EQ NEQ 60 | %left LT GT LE GE 61 | %left RANGE 62 | %left SNOC 63 | %left APPEND 64 | %right CONS 65 | %left INFIX 66 | %left PLUS MINUS 67 | %left TIMES DIVIDE 68 | %right EXP 69 | %nonassoc TIMES_BRACK QUANT 70 | %left TILDE 71 | %left DOT 72 | 73 | %start program 74 | 75 | %% 76 | 77 | program: access e EOF {$1, $2} 78 | 79 | %inline access: 80 | | PRIV {Priv} 81 | | OPAQ {Opaq} 82 | | {Pub} 83 | 84 | sp: sp_t {$1, $loc} 85 | %inline sp_t: 86 | | SPEC ID ASSIGN ty {SDef ($2, $4)} 87 | | TYPE ID list(CAP) ioption(preceded(ASSIGN, ty)) {STy ($2, $3, $4)} 88 | | DATA ID list(CAP) ASSIGN data {SData ($2, $3, $5)} 89 | 90 | %inline data: data_t {$1, $loc} 91 | %inline data_t: 92 | | separated_nonempty_list(semi, constructor) {let+ x = $1 in [x]} 93 | | LBRACE separated_nonempty_list( 94 | semi, 95 | sep_pop_list_ge_2(COMMA, constructor) 96 | ) rbrace {$2} 97 | 98 | %inline constructor: 99 | | nonempty_list(ty_term) { 100 | match List.rev $1 with 101 | | (TGen s, _) :: t -> List.rev t, s 102 | | _ -> failwith "Rightmost term is not a constructor" 103 | } 104 | 105 | ty: ty_t {$1, $loc} 106 | ty_t: 107 | | ioption(ty_stack) EFFECT ioption(ty_stack) { 108 | let ty_conv = function 109 | | Some st -> st 110 | | None -> TCat [], $loc in 111 | ty_conv $1, 112 | ty_conv $3 113 | } 114 | | ty_stack {(TCat [], $loc), $1} 115 | 116 | %inline ty_stack: 117 | | ty_term {$1} 118 | | pop_list_ge_2(ty_term) {TCat $1, $loc} 119 | 120 | ty_term: ty_term_t {$1, $loc} 121 | %inline ty_term_t: 122 | | ID {TId $1} 123 | | CAP {TGen $1} 124 | | ty_term DOT ID {TAccess ($1, $3)} 125 | | LBRACE rbrace {TCapture (((TCat [], $loc), (TCat [], $loc)), $loc)} 126 | | LBRACE ty rbrace {TCapture $2} 127 | | LBRACK ty RBRACK {TList $2} 128 | | LBRACK ty_stack WIDE_ARROW ty RBRACK {TMap ($2, $4)} 129 | | UNIT {TUnit} 130 | | VOID {TVoid} 131 | | LPAREN separated_nonempty_list( 132 | semi, 133 | separated_nonempty_list(COMMA, ty) 134 | ) RPAREN {TBin $2} 135 | | MOD list(sp) END {TMod $2} 136 | | SIG list(sp) END {TSig $2} 137 | | LT ID COLON ty GT {TImpl ($2, $4)} 138 | 139 | %inline pop_list_ge_2(entry): 140 | | entry nonempty_list(entry) {$1 :: $2} 141 | 142 | %inline sep_pop_list_ge_2(sep, entry): 143 | | entry sep separated_nonempty_list(sep, entry) {$1 :: $3} 144 | 145 | s: s_t {$1, $loc} 146 | %inline s_t: 147 | | access s_kw p ioption(preceded(COLON, ty)) ASSIGN e 148 | {Def ($1, $2, $3, $6, $4)} 149 | | OPEN is_impl e {Open ($2, $3)} 150 | | MIX e {Mix $2} 151 | | access TYPE ID list(CAP) ioption(preceded(ASSIGN, ty)) 152 | {Ty ($1, $3, $4, $5)} 153 | | access DATA ID list(CAP) ASSIGN data 154 | {Data ($1, $3, $4, $6)} 155 | 156 | %inline s_kw: 157 | | DEF {false} 158 | | DEF IMPL {true} 159 | 160 | %inline is_impl: 161 | | IMPL {true} 162 | | {false} 163 | 164 | %inline det_control: 165 | | ioption(TRY) ioption(PARALLEL) det_control_t { 166 | Det { 167 | d_try = $1 <> None; 168 | d_parallel = $2 <> None; 169 | det = $3 170 | } 171 | } 172 | 173 | %inline det_control_t: 174 | | ONE {DOne} 175 | | NONE {DNone} 176 | | CUT {DCut} 177 | | SCORE {DScore} 178 | | MANY {DMany} 179 | 180 | e: e_t {$1, $loc} 181 | %inline e_t: 182 | | bop {Sect $1} 183 | | bop bexp {SectLeft ($1, $2)} 184 | | bexp bop {SectRight ($1, $2)} 185 | | bexp {let b, _ = $1 in b} 186 | | bind_e {let b, _ = $1 in b} 187 | | bexp bind_e {Cat [$1; $2]} 188 | | bexp bop bind_e {Bop ($1, $2, $3)} 189 | 190 | %inline bind_e: bind_e_t {$1, $loc} 191 | %inline bind_e_t: 192 | | let_body(LET) list(let_body(AND)) ARROW e {Let ($1 :: $2, $4)} 193 | | AS p ARROW e {As ($1, $2, $4)} 194 | 195 | %inline let_body(kw): 196 | | kw is_impl p ASSIGN e {$1, $2, $3, $5} 197 | 198 | bexp: bexp_t {$1, $loc} 199 | %inline bexp_t: 200 | | bexp bop bexp {Bop ($1, $2, $3)} 201 | | nonempty_list(term) {e_t_of_lst $1} 202 | 203 | term: term_t {$1, $loc} 204 | %inline term_t: 205 | | ID {Id $1} 206 | 207 | | term DOT ID {Access ($1, $3)} 208 | | term DOT LBRACK e RBRACK {Get ($1, $4)} 209 | | term TILDE term {Span ($1, $3)} 210 | 211 | | INT {Int $1} 212 | | FLOAT {Flo $1} 213 | | CHAR {Char $1} 214 | | STR {Str $1} 215 | | UNIT {Unit} 216 | 217 | | LPAREN RPAREN {Cat []} 218 | | DO e END {let (d, _) = $2 in d} 219 | | LPAREN semi RPAREN {Case []} 220 | | LBRACE rbrace {Capture (Cat [], $loc)} 221 | | LBRACE semi rbrace {Capture (Case [], $loc)} 222 | | LBRACK e nonempty_list(pair(SEMICOLON, e)) RBRACK {Case ((Gre, $2) :: $3)} 223 | | INV_BRACK separated_list(semi, e) RBRACK {Inv $2} 224 | 225 | | LBRACK separated_list(COMMA, e) RBRACK {List $2} 226 | | LBRACK separated_nonempty_list( 227 | COMMA, 228 | separated_pair(e, WIDE_ARROW, e) 229 | ) RBRACK {Map $2} 230 | | bin(e) { 231 | match $1 with 232 | | 0, [x], 0 -> Cap x 233 | | l, lst, r -> proc_ebin (l, lst, r) |> fst 234 | } 235 | 236 | | CAP {EData $1} 237 | | LBRACE sep_pop_list_ge_2(COMMA, e) rbrace {Prod $2} 238 | | MOD list(s) END {Mod $2} 239 | | IMPL_LBRACK e IMPL_RBRACK {Impl $2} 240 | | LBRACE e rbrace {Capture $2} 241 | | det_control {$1} 242 | 243 | | SYMBOL {Id $1} 244 | | COMB {$1} 245 | | term QUANT {Quant ($1, fst $2, snd $2)} 246 | | term TIMES_BRACK e RBRACE {Quant ($1, Num $3, $4)} 247 | | term TIMES_BRACK e COMMA RBRACE {Quant ($1, Min $3, $5)} 248 | | term TIMES_BRACK COMMA e RBRACE {Quant ($1, Max $4, $5)} 249 | | term TIMES_BRACK e COMMA e RBRACE {Quant ($1, Range ($3, $5), $6)} 250 | 251 | | NONCAP_BRACK e RPAREN {Noncap $2} 252 | | ATOM_BRACK e RPAREN {Atomic $2} 253 | 254 | %inline bop: 255 | | PLUS {"+"} | MINUS {"-"} | TIMES {"*"} | DIVIDE {"/"} 256 | | EXP {"**"} | RANGE {".."} | SNOC {">-"} | CONS {"-<"} 257 | | GT {">"} | GE {">="} | LT {"<"} | LE {"<="} | EQ {"=="} | NEQ {"/="} 258 | | APPEND {"++"} | BIND {">>="} | FISH {">=>"} 259 | | ALT {"|"} | ALT_REL {"|?"} | ALT_CUT {"|+"} | CAT {"&"} | INTERSECT {"&&"} 260 | | INFIX {$1} 261 | 262 | %inline semi: SEMICOLON {assert ($1 == Gre); ";"} 263 | %inline rbrace: RBRACE {assert ($1 == Gre)} 264 | 265 | bin(entry): 266 | | LPAREN list(semi) separated_nonempty_list(COMMA, entry) list(semi) RPAREN 267 | {List.length $2, $3, List.length $4} 268 | 269 | p: p_t {$1, $loc} 270 | %inline p_t: 271 | | p p_bop p {PBop ($1, $2, $3)} 272 | | nonempty_list(p_term) { 273 | match $1 with 274 | | [h, _] -> h 275 | | lst -> PCat lst 276 | } 277 | 278 | p_term: p_term_t {$1, $loc} 279 | %inline p_term_t: 280 | | ID {PId $1} 281 | | p_term DOT ID {PAccess ($1, $3)} 282 | | COMB { 283 | match $1 with 284 | | StackComb [Zap _, _] -> PBlank 285 | | _ -> failwith "Stack Combinator in Pattern" 286 | } 287 | | BLANK {PBlank} 288 | | OPEN is_impl {POpen $2} 289 | 290 | | INT {PInt $1} 291 | | FLOAT {PFlo $1} 292 | | STR {PStr $1} 293 | | CHAR {PChar $1} 294 | | UNIT {PUnit} 295 | 296 | | LBRACK separated_list(COMMA, p) RBRACK {PList $2} 297 | | LBRACK separated_nonempty_list( 298 | COMMA, 299 | separated_pair(p, BACKARROW, e) 300 | ) RBRACK {PMap (let+ x, y = $2 in y, x)} 301 | | bin(p) { 302 | match $1 with 303 | | 0, [x, _], 0 -> x 304 | | l, lst, r -> proc_pbin (l, lst, r) |> fst 305 | } 306 | 307 | | CAP {PData $1} 308 | | LBRACE sep_pop_list_ge_2(COMMA, p) RBRACE {PProd $2} 309 | | LPAREN list(semi) p COLON ty RPAREN 310 | {assert (List.length $2 == 0); PAsc ($3, $5)} 311 | | LT p COLON ty GT {PImpl ($2, $4)} 312 | | LBRACE p RBRACE {PCapture $2} 313 | 314 | | LBRACK SYMBOL RBRACK {PId $2} // consider condensing 315 | | LPAREN list(semi) ext_name RPAREN {PId $3} 316 | 317 | %inline p_bop: 318 | | PLUS {"+"} | TIMES {"*"} | CAT {"&"} 319 | | CONS {"-<"} | SNOC {">-"} 320 | 321 | %inline ext_name: 322 | | bop {$1} 323 | | LET {"let" ^ $1} 324 | | AND {"and" ^ $1} 325 | | AS {"as" ^ $1} 326 | -------------------------------------------------------------------------------- /src/parse/parse_comb.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Batteries 3 | 4 | open Ast 5 | %} 6 | 7 | %token DUP ZAP ROT RUN 8 | %token EOF 9 | 10 | %start parse 11 | 12 | %% 13 | 14 | %inline op: op_t {$1, $loc} 15 | %inline op_t: 16 | | DUP {Dup $1} 17 | | ZAP {Zap $1} 18 | | ROT {Rot $1} 19 | | RUN {Run $1} 20 | 21 | parse: nonempty_list(op) EOF {StackComb $1} 22 | -------------------------------------------------------------------------------- /src/parse/parse_proc.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | 3 | let rec process_bin (p, l, r as con) = function 4 | | (_, [], _) -> failwith "Empty" 5 | | (0, h1 :: h2 :: t, 0) -> process_bin con (0, p h1 h2 :: t, 0) 6 | | (0, [x], 0) -> x 7 | | (i, lst, 0) -> r (process_bin con (i - 1, lst, 0)) 8 | | (i, lst, j) -> l (process_bin con (i, lst, j - 1)) 9 | 10 | let proc_ebin = process_bin ( 11 | (fun (_, loc as e1) e2 -> Pair (e1, e2), loc), 12 | (fun (_, loc as e) -> Left e, loc), 13 | (fun (_, loc as e) -> Right e, loc) 14 | ) 15 | 16 | let proc_pbin = process_bin ( 17 | (fun (_, loc as p1) p2 -> PPair (p1, p2), loc), 18 | (fun (_, loc as p) -> PLeft p, loc), 19 | (fun (_, loc as p) -> PRight p, loc) 20 | ) 21 | -------------------------------------------------------------------------------- /src/run/error.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Lexing 3 | open Printf 4 | 5 | type span = Lexing.position * Lexing.position 6 | 7 | exception ProwlError of span * string 8 | 9 | let lincol_of_pos p = p.pos_lnum, (p.pos_cnum - p.pos_bol) 10 | let span_of_loc (p1, p2) = lincol_of_pos p1, lincol_of_pos p2 11 | let loc_err ((l1, c1), (l2, c2)) = 12 | if l1 = l2 then sprintf "line %d, characters %d-%d" l1 c1 c2 13 | else sprintf "lines %d-%d, characters %d-%d" l1 l2 c1 c2 14 | 15 | let show_err span msg = 16 | span |> span_of_loc |> loc_err |> fun x -> 17 | sprintf "%s\n%s" x msg 18 | 19 | let prowlfail span msg = 20 | raise (ProwlError (span, msg)) 21 | -------------------------------------------------------------------------------- /src/run/eval.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | 3 | open State 4 | 5 | type t 6 | exception Rejected 7 | 8 | val (<&>) : t -> (State.t -> State.t) -> t 9 | val (>>=) : t -> (State.t -> t) -> t 10 | val (>=>) : (State.t -> t) -> (State.t -> t) -> (State.t -> t) 11 | val pure : State.t -> t 12 | val (<|>) : (State.t -> t) -> (State.t -> t) -> (State.t -> t) 13 | val ( *> ) : (State.t -> t) -> (State.t -> t) -> (State.t -> t) 14 | val annihilate : 'a -> t 15 | val cut : t -> t 16 | val unsafe_cut : t -> State.t 17 | val is_null : t -> bool 18 | val null : t 19 | 20 | end 21 | 22 | module LazySearch : S = struct 23 | 24 | open Batteries 25 | open LazyList.Infix 26 | 27 | open State 28 | 29 | type t = State.t LazyList.t 30 | exception Rejected 31 | 32 | let (<&>) x f = LazyList.map f x 33 | let (>>=) x f = x <&> f |> LazyList.concat 34 | let (>=>) f g x = f x >>= g 35 | let pure a = LazyList.(cons a nil) 36 | let (<|>) f g x = f x ^@^ g x 37 | let ( *> ) x c y = x y >>= fun _ -> c y 38 | let annihilate _ = LazyList.nil 39 | let cut x = match LazyList.get x with 40 | | Some (h, _) -> pure h 41 | | None -> LazyList.nil 42 | let unsafe_cut x = match LazyList.get x with 43 | | Some (h, _) -> h 44 | | None -> raise Rejected 45 | let is_null = LazyList.is_empty 46 | let null = LazyList.nil 47 | 48 | end 49 | -------------------------------------------------------------------------------- /src/run/interpret.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Util 3 | 4 | open State 5 | open Error 6 | 7 | module V = Value 8 | module T = Type 9 | module M = Module 10 | module C = Capture 11 | module S = State 12 | 13 | module Run (E : Eval.S) = struct 14 | 15 | open Ast 16 | open V 17 | open S 18 | open S.Infix 19 | open E 20 | 21 | let sprintf = Printf.sprintf 22 | 23 | let encode_lst loc = List.fold_left begin fun a ex -> 24 | Right (Pair ((a, loc), ex), loc) 25 | end (Left (Unit, loc)) 26 | 27 | let encode_plst loc = List.fold_left begin fun a ex -> 28 | PRight (PPair ((a, loc), ex), loc) 29 | end (PLeft (PUnit, loc)) 30 | 31 | let lit v st = pure (push v st) 32 | 33 | let rec program (_, e1) = e e1 34 | 35 | and e (_, loc as e0) st = match fst e0 with 36 | | Int i -> lit (VInt i) st 37 | | Str s -> lit (VStr s) st 38 | | Unit -> lit VUnit st 39 | | Pair (e1, e2) -> lit (VPair (C.of_st e1 st, C.of_st e2 st)) st 40 | | Left e1 -> lit (VLeft (C.of_st e1 st)) st 41 | | Right e2 -> lit (VRight (C.of_st e2 st)) st 42 | | Capture ast -> lit (VCap (C.of_st ast st)) st 43 | | StackComb c -> comb st c 44 | | Cap e1 -> e e1 st 45 | 46 | | Bop (e1, s, e2) -> infix e1 s e2 st 47 | | SectLeft (s, e2) -> sect_left s e2 st 48 | | SectRight (e1, s) -> sect_right e1 s st 49 | | Sect s -> sect s st 50 | 51 | | Cat lst -> List.fold_left (fun a x -> a >=> e x) pure lst st 52 | | Case elst -> List.fold_left begin fun a -> function 53 | | Gre, x -> a <|> e x 54 | | Rel, x -> e x <|> a 55 | | Cut, x -> e x |> alt_cut a 56 | end annihilate elst st 57 | | Inv lst -> List.fold_left (fun a x -> a *> e x) pure lst st 58 | 59 | | List elst -> e (encode_lst loc elst, loc) st 60 | 61 | | Id s -> begin match st --> s with 62 | | VBuiltin "add" -> arith_builtin (+) st 63 | | VBuiltin "sub" -> arith_builtin (-) st 64 | | VBuiltin "mul" -> arith_builtin ( * ) st 65 | | VBuiltin "div" -> arith_builtin (/) st 66 | | VBuiltin "exp" -> arith_builtin Int.pow st 67 | 68 | | VBuiltin "eq" -> cmp_builtin (=) st 69 | | VBuiltin "ne" -> cmp_builtin (<>) st 70 | | VBuiltin "gt" -> cmp_builtin (>) st 71 | | VBuiltin "lt" -> cmp_builtin (<) st 72 | | VBuiltin "ge" -> cmp_builtin (>=) st 73 | | VBuiltin "le" -> cmp_builtin (<=) st 74 | 75 | | VBuiltin "cat" -> combinator (>=>) st 76 | | VBuiltin "alt" -> combinator (<|>) st 77 | | VBuiltin "alt-rel" -> combinator alt_rel st 78 | | VBuiltin "alt-cut" -> combinator alt_cut st 79 | | VBuiltin "intersect" -> combinator ( *> ) st 80 | 81 | | VBuiltin "str-to-int" -> 82 | let v, st1 = !: st in 83 | VInt (V.to_str v |> int_of_string) >: st1 |> pure 84 | 85 | | VBuiltin "int-to-str" -> 86 | let v, st1 = !: st in 87 | VStr (V.to_int v |> string_of_int) >: st1 |> pure 88 | 89 | | VCap c -> call c st 90 | | x -> lit x st 91 | | exception Not_found -> 92 | sprintf "Error: Unbound Id [%s]" s 93 | |> prowlfail loc 94 | end 95 | | Let (lst, e1) -> List.fold_left begin fun a -> function 96 | | "", false, (PId s, _), ex -> a <&> fun stx -> 97 | set s (VCap (C.of_st ex stx)) stx 98 | | "", false, (PCat ((PId s, z) :: t), y), ex -> a <&> fun stx -> 99 | set s (VCap (C.of_st (As ("", (PCat t, y), ex), z) stx)) stx 100 | | "", false, px, ex -> a >>= e ex >>= p px 101 | (* Note: broken *) 102 | | b, _, px, ex -> a >>= fun st' -> 103 | let l = VCap (C.of_st (As ("", px, e1), loc) st') in 104 | let r = VCap (C.of_st ex st') in 105 | e (Id ("let" ^ b), loc) ((l, r) >:: st') 106 | end (pure st) lst >>= e e1 <&> flip (<->) st 107 | 108 | | As ("", p1, e1) -> (p p1 st) >>= e e1 <&> flip (<->) st 109 | | As (s, p1, e1) -> 110 | e (Id ("as" ^ s), loc) (VCap (C.of_st (As ("", p1, e1), loc) st) >: st) 111 | 112 | | Quant (e1, Num e2, gr) -> 113 | eval_grab_int e2 st (fun i1 -> times_quant gr e1 i1 i1) 114 | 115 | | Quant (e1, Min e2, gr) -> 116 | eval_grab_int e2 st (fun i1 st1 -> times_quant_while gr e1 i1 st1) 117 | 118 | | Quant (e1, Max e2, gr) -> 119 | eval_grab_int e2 st (fun i1 st1 -> times_quant gr e1 0 i1 st1) 120 | 121 | | Quant (e1, Range (e2, e3), gr) -> 122 | eval_grab_int e2 st begin fun i1 st1 -> 123 | eval_grab_int e3 st1 (fun i2 st2 -> times_quant gr e1 i1 i2 st2) 124 | end 125 | 126 | | Quant (e1, Star, gr) -> times_quant_while gr e1 0 st 127 | | Quant (e1, Plus, gr) -> times_quant_while gr e1 1 st 128 | | Quant (e1, Opt, gr) -> times_quant gr e1 0 1 st 129 | 130 | | Mod lst -> 131 | List.fold_left begin fun a slst -> a >>= fun st1 -> 132 | let v, st2 = !: st1 in 133 | let m = to_mod v in match slst with 134 | | Def (access, false, (PId s, _), e1, _), _ -> 135 | def_access access s e1 m 136 | |> M.set s (VCap (C.of_mod e1 m)) 137 | |> fun m1 -> VMod m1 >: st2 |> pure 138 | | Def (access, false, (PCat ((PId s, z) :: t), y), e1, _), _ -> 139 | let e2 = As ("", (PCat t, y), e1), z in 140 | def_access access s e2 m 141 | |> M.set s (VCap (C.of_mod e2 m)) 142 | |> fun m1 -> VMod m1 >: st2 |> pure 143 | | Open (false, e1), _ -> 144 | e e1 (State.merge_mod m st2) >>= fun st3 -> 145 | Module.def_open (!: st2 |> fst |> to_mod) m 146 | |> fun m1 -> VMod m1 >: st3 |> pure 147 | 148 | | _ -> a 149 | end (VMod (M.make st) >: st |> pure) lst 150 | 151 | | Access (e1, s) -> 152 | e e1 st >>= fun st1 -> 153 | let v, _ = !: st1 in 154 | begin match v with 155 | | VMod m -> 156 | begin try e (Module.acc s m) (merge_mod m st) with 157 | | Not_found -> 158 | sprintf "Field [%s] not found in module" s 159 | |> prowlfail loc 160 | end 161 | 162 | | _ -> 163 | (s, show_call v) 164 | ||> sprintf "Type Error: Accessing field [%s] of a non-module (%s)" 165 | |> prowlfail loc 166 | end <&> fun st2 -> st2 <-> st 167 | 168 | | Noncap e1 -> (e e1 *> pure) st 169 | | Atomic (Cat lst, _) -> 170 | List.fold_left (fun a e1 -> a >>= e e1 |> cut) (pure st) lst 171 | | Atomic e1 -> e (Atomic (Cat [e1], loc), loc) st 172 | 173 | | _ -> 174 | show_e e0 175 | |> sprintf "Unimplemented Error: expression <<%s>>" 176 | |> prowlfail loc 177 | 178 | and arith_builtin o st = 179 | let v2, v1, st' = !:: st in 180 | let c2, c1 = V.(to_cap v2, to_cap v1) in 181 | call c2 st' >>= call c1 <&> fun st2 -> 182 | let v1, v2, st3 = !:: st2 in 183 | let v3 = VInt (o (V.to_int v1) (V.to_int v2)) in 184 | v3 >: st3 185 | 186 | and cmp_builtin o st = 187 | let v2, v1, st' = !:: st in 188 | let c2, c1 = V.(to_cap v2, to_cap v1) in 189 | call c2 st' >>= call c1 >>= fun st2 -> 190 | let v1, v2, st3 = !:: st2 in 191 | if o (V.to_int v1) (V.to_int v2) then pure st3 192 | else null 193 | 194 | and combinator o st = 195 | let v2, v1, st' = !:: st in 196 | let c2, c1 = V.(to_cap v2, to_cap v1) in 197 | o (call c1) (call c2) st' 198 | 199 | and infix (_, loc as e1) o e2 st = 200 | e (Id o, loc) (C.(VCap (of_st e2 st), VCap (of_st e1 st)) >:: st) 201 | 202 | and def_cap s v st = C.of_st (Id s, dum) (st <-- (s, v)) 203 | 204 | and sect_left o (_, loc as e2) st = 205 | let v2, st' = !: st in 206 | e (Id o, loc) (C.(VCap (of_st e2 st), VCap (def_cap "@2" v2 st)) >:: st') 207 | 208 | and sect_right (_, loc as e1) o st = 209 | let v1, st' = !: st in 210 | e (Id o, loc) (C.(VCap (def_cap "@1" v1 st), VCap (of_st e1 st)) >:: st') 211 | 212 | and sect o st = 213 | let v2, v1, st' = !:: st in 214 | e (Id o, dum) begin ( 215 | VCap (def_cap "@2" v2 st), 216 | VCap (def_cap "@1" v1 st) 217 | ) >:: st' 218 | end 219 | 220 | and comb st = 221 | List.fold_left begin fun m a -> m >>= fun st1 -> match a with 222 | | Dup i, _ -> List.at (S.s st1) (i-1) >: st1 |> pure 223 | | Zap i, _ -> restack (List.remove_at (i-1) (S.s st1)) st1 |> pure 224 | | Rot 2, _ -> 225 | let v2, v1, st2 = !:: st1 in 226 | (v1, v2) >:: st2 |> pure 227 | | Rot 3, _ -> 228 | let v3, v2, st2 = !:: st1 in 229 | let v1, st3 = !: st2 in 230 | v1 >: ((v3, v2) >:: st3) |> pure 231 | | Rot i, loc -> 232 | let msg = "ROT N only implemented for N = 2, 3." in 233 | sprintf "Unimplemented Error: ROT %d. %s" i msg 234 | |> prowlfail loc 235 | | Run i, _ -> 236 | restack (List.remove_at (i-1) (S.s st1)) st1 237 | |> call (to_cap (List.at (S.s st1) (i-1))) 238 | end (pure st) 239 | 240 | and alt_rel f g = g <|> f 241 | 242 | and alt_cut f g = (f <|> g) >> cut 243 | 244 | and eval_grab_int e1 st f = e e1 st >>= fun st1 -> 245 | let v, st1 = !: st1 in 246 | f (to_int v) st1 247 | 248 | and choose_alt = function 249 | | Gre -> (<|>) 250 | | Rel -> alt_rel 251 | | Cut -> alt_cut 252 | 253 | and choose_alt_flip gr = choose_alt gr |> flip 254 | 255 | and times_quant gr e1 qmin qmax st = match qmax - qmin with 256 | | qdiff when qmin < 0 || qdiff < 0 -> null 257 | | qdiff -> adv qmin e1 st >>= adv_alt gr qdiff e1 258 | 259 | and times_quant_while gr e1 qmin st = 260 | if qmin < 0 then null 261 | else adv qmin e1 st >>= adv_alt_while gr e1 262 | 263 | and adv n e1 st = 264 | List.fold_left (>=>) pure (List.make n (e e1)) st 265 | 266 | and adv_alt gr n e1 st = 267 | let () = choose_alt gr in 268 | apply_for n (fun st1 -> st1 >>= (e e1 pure)) (pure st) 269 | 270 | (* still inefficient - does things twice *) 271 | (* direct appending would be more efficient *) 272 | and adv_alt_while gr e1 st = 273 | let () = choose_alt gr in 274 | apply_while 275 | (fst >> is_null >> not) 276 | (fun (st1, st2) -> st1 >>= e e1, st2 >>= (e e1 pure)) 277 | (pure st, pure st) |> snd 278 | 279 | and call c st = e (Capture.ast c) (st <-| c) <&> flip (<->) st 280 | 281 | and def_access = function 282 | | Pub -> Module.def 283 | | Priv -> fun _ _ -> identity 284 | | Opaq -> fun s (_, loc) -> 285 | let msg = "Values cannot be opaque" in 286 | sprintf "Definition [%s] is opaque. %s" s msg 287 | |> prowlfail loc 288 | 289 | and p (_, loc as p0) st = match fst p0 with 290 | | PId s -> let v, st1 = !: st in pure (set s v st1) 291 | | PBlank -> let _, st1 = !: st in pure st1 292 | | PInt i1 -> 293 | let v, st1 = !: st in 294 | if i1 = to_int v then pure st1 295 | else null 296 | | PStr s1 -> 297 | let v, st1 = !: st in 298 | if s1 = to_str v then pure st1 299 | else null 300 | | PCat lst -> 301 | List.fold_left (fun a p1 -> a >>= (p p1)) (pure st) (List.rev lst) 302 | | PCapture (PId s, _) -> 303 | let v, st' = !: st in 304 | ignore (to_cap v); 305 | pure (set s v st') 306 | | PCapture px -> 307 | let v, st' = !: st in 308 | call (to_cap v) st' >>= p px 309 | | PAsc (p1, _) -> p p1 st 310 | | PPair ((PId s1, _), (PId s2, _)) -> 311 | let v, st' = !: st in 312 | let l, r = to_pair v in 313 | pure (set s2 (VCap r) (set s1 (VCap l) st')) 314 | | PPair (px1, (PId s2, _)) -> 315 | let v, st' = !: st in 316 | let l, r = to_pair v in 317 | call l st' >>= p px1 >>= (set s2 (VCap r) >> pure) 318 | | PPair ((PId s1, _), px2) -> 319 | let v, st' = !: st in 320 | let l, r = to_pair v in 321 | call r (set s1 (VCap l) st') >>= p px2 322 | | PPair (px1, px2) -> 323 | let v, st' = !: st in 324 | let l, r = to_pair v in 325 | call l st' >>= p px1 >>= call r >>= p px2 326 | | PLeft (PId s, _) -> begin match !: st with 327 | | VLeft l, st' -> pure (set s (VCap l) st') 328 | | VRight _, _ -> null 329 | | _ -> raise (ExpectedType "Either") 330 | end 331 | | PLeft px -> begin match !: st with 332 | | VLeft l, st' -> call l st' >>= p px 333 | | VRight _, _ -> null 334 | | _ -> raise (ExpectedType "Either") 335 | end 336 | | PRight (PId s, _) -> begin match !: st with 337 | | VRight r, st' -> pure (set s (VCap r) st') 338 | | VLeft _, _ -> null 339 | | _ -> raise (ExpectedType "Either") 340 | end 341 | | PRight px -> begin match !: st with 342 | | VRight r, st' -> call r st' >>= p px 343 | | VLeft _, _ -> null 344 | | _ -> raise (ExpectedType "Either") 345 | end 346 | | POpen false -> 347 | let v, st1 = !: st in 348 | update_mod (to_mod v) st1 |> pure 349 | | PBop (p1, ">-", p2) -> p (PRight (PPair (p1, p2), loc), loc) st 350 | | PList plst -> p (encode_plst loc plst, loc) st 351 | | PUnit -> let v, st1 = !: st in to_unit v; pure st1 352 | 353 | | _ -> 354 | show_p p0 355 | |> sprintf "Unimplemented Error: pattern <<%s>>" 356 | |> prowlfail loc 357 | 358 | and show_call v = show_eval (fun v1 -> call v1 >> unsafe_cut) v 359 | 360 | end 361 | -------------------------------------------------------------------------------- /src/run/state.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | 3 | open Util 4 | 5 | module StrKey = struct 6 | type t = string 7 | let compare = compare 8 | end 9 | 10 | module Dict = Map.Make(StrKey) 11 | 12 | module rec Value : sig 13 | 14 | exception ExpectedType of string 15 | 16 | type t = 17 | | VInt of int 18 | | VStr of string 19 | | VPair of Capture.t * Capture.t 20 | | VLeft of Capture.t 21 | | VRight of Capture.t 22 | | VCap of Capture.t 23 | | VUnit 24 | | VMod of Module.t 25 | | VImpl of Capture.t 26 | | VImplMod 27 | | VBuiltin of string 28 | 29 | val to_int : t -> int 30 | val to_str : t -> string 31 | val to_pair : t -> Capture.t * Capture.t 32 | val to_eith : t -> Capture.t 33 | val to_cap : t -> Capture.t 34 | val to_unit : t -> unit 35 | val to_mod : t -> Module.t 36 | 37 | val show : t -> string 38 | val show_eval : (Capture.t -> State.t -> State.t) -> Value.t -> string 39 | 40 | end = struct 41 | 42 | exception ExpectedType of string 43 | 44 | type t = 45 | | VInt of int 46 | | VStr of string 47 | | VPair of Capture.t * Capture.t 48 | | VLeft of Capture.t 49 | | VRight of Capture.t 50 | | VCap of Capture.t 51 | | VUnit 52 | | VMod of Module.t 53 | | VImpl of Capture.t 54 | | VImplMod 55 | | VBuiltin of string 56 | 57 | let to_int = function VInt i -> i | _ -> raise (ExpectedType "Int") 58 | let to_str = function VStr s -> s | _ -> raise (ExpectedType "Str") 59 | let to_pair = function VPair (c1, c2) -> c1, c2 | _ -> raise (ExpectedType "Pair") 60 | let to_eith = function VLeft c | VRight c -> c | _ -> raise (ExpectedType "Either") 61 | let to_cap = function VCap c -> c | _ -> raise (ExpectedType "Capture") 62 | let to_unit = function VUnit -> () | _ -> raise (ExpectedType "Unit") 63 | let to_mod = function VMod m -> m | _ -> raise (ExpectedType "Module") 64 | 65 | open Printf 66 | open State 67 | open Infix 68 | 69 | let enhanced_show_e = function 70 | | Ast.Int i, _ -> string_of_int i 71 | | Ast.Str s, _ -> s 72 | | ex -> Ast.show_e ex 73 | 74 | let show_c = Capture.ast >> enhanced_show_e 75 | 76 | let show = function 77 | | VInt i -> string_of_int i 78 | | VStr s -> s 79 | | VUnit -> "<>" 80 | | VPair (c1, c2) -> sprintf "(%s, %s)" (show_c c1) (show_c c2) 81 | | VLeft c -> sprintf "(%s;)" (show_c c) 82 | | VRight c -> sprintf "(;%s)" (show_c c) 83 | 84 | | VCap c -> sprintf "{%s}" (show_c c) 85 | | VMod m -> 86 | let d, _, _ = Module.body m in 87 | Dict.keys d |> List.of_enum |> String.concat " " 88 | |> sprintf "mod %s end" 89 | 90 | | VBuiltin b -> "$" ^ b 91 | | _ -> failwith "Unimplemented - show" 92 | 93 | let rec show_eval c = function 94 | | VPair (c1, c2) -> 95 | (show_call c c1, show_call c c2) 96 | ||> sprintf "(%s, %s)" 97 | | VLeft c2 -> show_call c c2 |> sprintf "(%s;)" 98 | | VRight c1 -> show_call c c1 |> sprintf "(;%s)" 99 | | VCap c1 -> show_call c c1 |> sprintf "{%s}" 100 | | v -> show v 101 | 102 | and show_call c c1 = 103 | try !: (c c1 init) |> fst |> show_eval c with 104 | | Underflow -> "" 105 | | _ -> show_c c1 106 | 107 | end 108 | 109 | and Type : sig 110 | type t 111 | end = struct 112 | type t 113 | end 114 | 115 | and Module : sig 116 | 117 | type t 118 | 119 | val make : State.t -> t 120 | val body : t -> Ast.e Dict.t * (string list * Ast.ty option) Dict.t * Ast.e Dict.t 121 | val c : t -> Context.t 122 | 123 | val def : string -> Ast.e -> t -> t 124 | val def_open : t -> t -> t 125 | val acc : string -> t -> Ast.e 126 | val deft : string -> string list * Ast.ty option -> t -> t 127 | val acct : string -> t -> string list * Ast.ty option 128 | val defi : string -> Ast.e -> t -> t 129 | val acci : string -> t -> Ast.e 130 | 131 | val set : string -> Value.t -> t -> t 132 | val get : string -> t -> Value.t 133 | val sett : string -> Type.t -> t -> t 134 | val gett : string -> t -> Type.t 135 | val ins : string -> Module.t -> t -> t 136 | val dump : string -> t -> Module.t list 137 | 138 | end = struct 139 | 140 | type t = { 141 | def : Ast.e Dict.t; 142 | ty : (string list * Ast.ty option) Dict.t; 143 | impl : Ast.e Dict.t; 144 | c : Context.t; 145 | } 146 | 147 | let make st = { 148 | def = Dict.empty; 149 | ty = Dict.empty; 150 | impl = Dict.empty; 151 | c = State.c st; 152 | } 153 | 154 | let body m = m.def, m.ty, m.impl 155 | let c m = m.c 156 | 157 | let def k v m = {m with def = Dict.add k v m.def} 158 | let acc k m = Dict.find k m.def 159 | 160 | let deft k v m = {m with ty = Dict.add k v m.ty} 161 | let acct k m = Dict.find k m.ty 162 | 163 | let defi k v m = {m with impl = Dict.add k v m.impl} 164 | let acci k m = Dict.find k m.impl 165 | 166 | let set k v m = {m with c = Context.set k v m.c} 167 | let get k m = Context.get k m.c 168 | 169 | let sett k t m = {m with c = Context.sett k t m.c} 170 | let gett k m = Context.gett k m.c 171 | 172 | let ins k i m = {m with c = Context.ins k i m.c} 173 | let dump k m = Context.dump k m.c 174 | 175 | let def_open mo m = { 176 | m with 177 | c = Context.update m.c (Context.of_mod mo) 178 | } 179 | 180 | end 181 | 182 | and Capture : sig 183 | 184 | type t 185 | 186 | val ast : t -> Ast.e 187 | val make : Ast.e -> Context.t -> t 188 | val of_st : Ast.e -> State.t -> t 189 | val of_mod : Ast.e -> Module.t -> t 190 | val c : t -> Context.t 191 | val init : Ast.e -> t 192 | 193 | val set : string -> Value.t -> t -> t 194 | val get : string -> t -> Value.t 195 | val sett : string -> Type.t -> t -> t 196 | val gett : string -> t -> Type.t 197 | val ins : string -> Module.t -> t -> t 198 | val dump : string -> t -> Module.t list 199 | 200 | end = struct 201 | 202 | type t = { 203 | e : Ast.e; 204 | c : Context.t; 205 | } 206 | 207 | let ast a = a.e 208 | let make e c = {e; c} 209 | let of_st e st = {e; c = State.c st} 210 | let of_mod e m = {e; c = Module.c m} 211 | let c st = st.c 212 | let init e = {e; c = Context.init} 213 | 214 | let set k v a = {a with c = Context.set k v a.c} 215 | let get k a = Context.get k a.c 216 | 217 | let sett k t a = {a with c = Context.sett k t a.c} 218 | let gett k a = Context.gett k a.c 219 | 220 | let ins k i a = {a with c = Context.ins k i a.c} 221 | let dump k a = Context.dump k a.c 222 | 223 | end 224 | 225 | and State : sig 226 | 227 | type t 228 | type stack = Value.t list 229 | 230 | exception Underflow 231 | 232 | val s : t -> stack 233 | val c : t -> Context.t 234 | val init : t 235 | val merge : Capture.t -> t -> t 236 | val merge_mod : Module.t -> t -> t 237 | val update : Capture.t -> t -> t 238 | val update_mod : Module.t -> t -> t 239 | val switch : t -> t -> t 240 | val restack : stack -> t -> t 241 | 242 | val pop : t -> Value.t * t 243 | val pop2 : t -> Value.t * Value.t * t 244 | val pop_opt : t -> (Value.t * t) option 245 | val pop2_opt : t -> (Value.t * Value.t * t) option 246 | val push : Value.t -> t -> t 247 | val push2 : Value.t -> Value.t -> t -> t 248 | 249 | val set : string -> Value.t -> t -> t 250 | val get : string -> t -> Value.t 251 | val sett : string -> Type.t -> t -> t 252 | val gett : string -> t -> Type.t 253 | val ins : string -> Module.t -> t -> t 254 | val dump : string -> t -> Module.t list 255 | 256 | module Infix : sig 257 | 258 | val (!:) : t -> Value.t * t 259 | val (!::) : t -> Value.t * Value.t * t 260 | val (!?) : t -> (Value.t * t) option 261 | val (!??) : t -> (Value.t * Value.t * t) option 262 | val (>:) : Value.t -> t -> t 263 | val (>::) : Value.t * Value.t -> t -> t 264 | 265 | val (<--) : t -> string * Value.t -> t 266 | val (-->) : t -> string -> Value.t 267 | val (<==) : t -> string * Type.t -> t 268 | val (==>) : t -> string -> Type.t 269 | val (<<-) : t -> string * Module.t -> t 270 | val (->>) : t -> string -> Module.t list 271 | 272 | val (<-|) : t -> Capture.t -> t 273 | val (<-<) : t -> Capture.t -> t 274 | val (<->) : t -> t -> t 275 | 276 | end 277 | 278 | end = struct 279 | 280 | type t = { 281 | s : stack; 282 | c : Context.t; 283 | } 284 | and stack = Value.t list 285 | 286 | exception Underflow 287 | 288 | let s st = st.s 289 | let c st = st.c 290 | let merge vi st = {st with c = Capture.c vi} 291 | let merge_mod m st = {st with c = Module.c m} 292 | let update vi st = {st with c = Context.update st.c (Capture.c vi)} 293 | let update_mod m st = {st with c = Context.update st.c (Context.of_mod m)} 294 | let switch st1 st2 = {st1 with c = st2.c} 295 | let empty = {s = []; c = Context.empty} 296 | let init = {empty with c = Context.init} 297 | let restack s st = {st with s} 298 | 299 | let pop = function 300 | | ({s = h :: s; _} as st) -> h, {st with s} 301 | | _ -> raise Underflow 302 | 303 | let pop2 = function 304 | | ({s = h1 :: h2 :: s; _} as st) -> h1, h2, {st with s} 305 | | _ -> raise Underflow 306 | 307 | let pop_opt = function 308 | | ({s = h :: s; _} as st) -> Some (h, {st with s}) 309 | | _ -> None 310 | 311 | let pop2_opt = function 312 | | ({s = h1 :: h2 :: s; _} as st) -> Some (h1, h2, {st with s}) 313 | | _ -> None 314 | 315 | let push v st = {st with s = v :: st.s} 316 | let push2 v1 v2 st = {st with s = v1 :: v2 :: st.s} 317 | 318 | let set k v st = {st with c = Context.set k v st.c} 319 | let get k st = Context.get k st.c 320 | 321 | let sett k t st = {st with c = Context.sett k t st.c} 322 | let gett k st = Context.gett k st.c 323 | 324 | let ins k i st = {st with c = Context.ins k i st.c} 325 | let dump k st = Context.dump k st.c 326 | 327 | module Infix = struct 328 | 329 | let (!:) = pop 330 | let (!::) = pop2 331 | let (!?) = pop_opt 332 | let (!??) = pop2_opt 333 | let (>:) = push 334 | let (>::) (v1, v2) = push2 v1 v2 335 | 336 | let (<--) st (k, v) = set k v st 337 | let (-->) st k = get k st 338 | let (<==) st (k, t) = sett k t st 339 | let (==>) st k = gett k st 340 | let (<<-) st (k, i) = ins k i st 341 | let (->>) st k = dump k st 342 | 343 | let (<-|) st c = merge c st 344 | let (<-<) st c = update c st 345 | let (<->) = switch 346 | 347 | end 348 | 349 | end 350 | 351 | and Context : sig 352 | 353 | type t = { 354 | v : Value.t Dict.t; (* Value Context *) 355 | t : Type.t Dict.t; (* Type Context *) 356 | i : Module.t list Dict.t; (* Implicits *) 357 | } 358 | 359 | val empty : t 360 | val init : t 361 | val of_mod : Module.t -> t 362 | val update : t -> t -> t 363 | 364 | val set : string -> Value.t -> t -> t 365 | val get : string -> t -> Value.t 366 | 367 | val sett : string -> Type.t -> t -> t 368 | val gett : string -> t -> Type.t 369 | 370 | val ins : string -> Module.t -> t -> t 371 | val dump : string -> t -> Module.t list 372 | 373 | end = struct 374 | 375 | type t = { 376 | v : Value.t Dict.t; 377 | t : Type.t Dict.t; 378 | i : Module.t list Dict.t; 379 | } 380 | 381 | let empty = { 382 | v = Dict.empty; 383 | t = Dict.empty; 384 | i = Dict.empty; 385 | } 386 | 387 | let of_mod m = 388 | let d, _, _ = Module.body m in { 389 | v = Dict.map (fun x -> Value.VCap (Capture.of_mod x m)) d 390 | |> Dict.union (fun _ _ c -> Some c) (Module.c m).v; 391 | t = Dict.empty; 392 | i = Dict.empty; 393 | } 394 | 395 | let set k v c = {c with v = Dict.add k v c.v} 396 | let get k c = Dict.find k c.v 397 | 398 | let sett k t c = {c with t = Dict.add k t c.t} 399 | let gett k c = Dict.find k c.t 400 | 401 | let ins k i c = 402 | Dict.find_opt k c.i 403 | |> Option.default [] 404 | |> List.cons i 405 | |> fun v -> {c with i = Dict.add k v c.i} 406 | 407 | let dump k c = Dict.find k c.i 408 | 409 | let upd y z = Dict.union (fun _ _ x -> Some x) y z 410 | let updi y z = Dict.union (fun _ x1 x2 -> Some (x1 @ x2)) y z 411 | let update c1 c2 = { 412 | v = upd c1.v c2.v; 413 | t = upd c1.t c2.t; 414 | i = updi c1.i c2.i; 415 | } 416 | 417 | let init_v = [ 418 | "+", "add"; 419 | "-", "sub"; 420 | "*", "mul"; 421 | "/", "div"; 422 | "**", "exp"; 423 | 424 | "==", "eq"; 425 | "/=", "ne"; 426 | ">", "gt"; 427 | "<", "lt"; 428 | ">=", "ge"; 429 | "<=", "le"; 430 | 431 | "&", "cat"; 432 | "|", "alt"; 433 | "|?", "alt-rel"; 434 | "|+", "alt-cut"; 435 | "&&", "intersect"; 436 | 437 | "to-str", "int-to-str"; 438 | "to-int", "str-to-int"; 439 | ] 440 | |> List.map (fun (a, b) -> a, Value.VBuiltin b) 441 | |> List.enum 442 | |> Dict.of_enum 443 | 444 | let init = {empty with v = init_v} 445 | 446 | end 447 | -------------------------------------------------------------------------------- /src/util.ml: -------------------------------------------------------------------------------- 1 | let (>>) f g x = x |> f |> g 2 | let (>>>) f g x = let y, z = f x in g y z 3 | let (>>>>) f g x = let y, z, w = f x in g y z w 4 | 5 | let (||>) (x, y) f = f x y 6 | let (|||>) (x, y, z) f = f x y z 7 | 8 | let (<|) f x = f x 9 | let (<||) f (x, y) = f x y 10 | let (<|||) f (x, y, z) = f x y z 11 | 12 | let (<&>) d f = List.map f d 13 | let (&>) d v = d <&> fun _ -> v 14 | let (>>=) m f = m <&> f |> List.flatten 15 | 16 | let (let*) = (>>=) 17 | let (let+) = (<&>) 18 | 19 | let (<@>) d f = let* x = d in let+ g = f in g x 20 | let (@>) d v = d <&> fun _ -> v 21 | let (>>:) = (@>) 22 | let (let@) = (<@>) 23 | 24 | module Either = struct 25 | 26 | type ('a, 'b) t = L of 'a | R of 'b 27 | 28 | let (<&>) d f = match d with 29 | | R r -> R (f r) 30 | | e -> e 31 | 32 | let (>>=) m f = match m with 33 | | R r -> f r 34 | | e -> e 35 | 36 | let either e f g = match e with 37 | | L l -> f l 38 | | R r -> g r 39 | 40 | let bimap e f g = match e with 41 | | L l -> L (f l) 42 | | R r -> R (g r) 43 | 44 | let (let*) = (>>=) 45 | let (let+) = (<&>) 46 | 47 | end 48 | 49 | type ('a, 'b) either = ('a, 'b) Either.t 50 | 51 | let dum = Lexing.(dummy_pos, dummy_pos) 52 | 53 | let rec apply_for n f x = 54 | if n > 0 then apply_for (n-1) f (f x) 55 | else x 56 | 57 | let rec apply_while c f x = 58 | if c x then apply_while c f (f x) 59 | else x 60 | 61 | let rec bind_while f x = 62 | match f x with 63 | | Some y -> bind_while f y 64 | | None -> x 65 | -------------------------------------------------------------------------------- /std/stack.prw: -------------------------------------------------------------------------------- 1 | mod 2 | 3 | def (>-) t h = (;t,h) 4 | def empty = [] 5 | 6 | local def rev-step (t >- h) a = t (a >- h) 7 | def rev = [] rev-step*+ _2 8 | 9 | def map-rev {f} = 10 | let map-step (t >- h) a = t (a >- h f) -> 11 | [] map-step*+ _2 12 | 13 | def map = map-rev rev 14 | def (<&>) {s} {f} = s {f} map 15 | def (as+) = map 16 | 17 | def cat-rev = % rev-step*+ _2 18 | def cat = rev cat-rev 19 | def (++) {s1} {s2} = s1 s2 cat 20 | 21 | def bind-rev {f} = 22 | let bind-step (t >- h) a = t (a ++ h f) -> 23 | [] bind-step*+ _2 24 | 25 | def bind = bind-rev rev 26 | def (>>=) {s} {f} = s {f} map 27 | def (as*) {f} = {f} map 28 | 29 | def fold-left i {r} = 30 | let fold-left-step (t >- h) a = t (a h r) -> 31 | i fold-left-step*+ _2 32 | 33 | def monoid m = mod 34 | def fold = m.empty {m.cat} fold-left 35 | end 36 | 37 | def filter-rev s {f} = 38 | let filter-step (t >- h) a = t a (h f (>- h))? -> 39 | [] filter-step*+ _2 40 | 41 | def filter = filter-rev rev 42 | def () {s} {f} = s {f} filter 43 | def (as?) = filter 44 | 45 | end 46 | -------------------------------------------------------------------------------- /test/bindings/as1.prw: -------------------------------------------------------------------------------- 1 | 10 as x -> x + 1 2 | -------------------------------------------------------------------------------- /test/bindings/compose.prw: -------------------------------------------------------------------------------- 1 | let s x = x + 1 -> 2 | 0 s s s 3 | -------------------------------------------------------------------------------- /test/bindings/let-as.prw: -------------------------------------------------------------------------------- 1 | let s = as x -> x + 1 -> 2 | 0 s s 3 | -------------------------------------------------------------------------------- /test/bindings/let-func.prw: -------------------------------------------------------------------------------- 1 | let norm-sqr x y = x ** 2 + y ** 2 -> 2 | 3 4 norm-sqr 3 | -------------------------------------------------------------------------------- /test/bindings/let-sect.prw: -------------------------------------------------------------------------------- 1 | let s = - 1 -> 2 | 5 s 3 | -------------------------------------------------------------------------------- /test/bindings/let1.prw: -------------------------------------------------------------------------------- 1 | let x = 5 -> x + 1 2 | -------------------------------------------------------------------------------- /test/bindings/sect-full.prw: -------------------------------------------------------------------------------- 1 | 4 5 (*) 2 | -------------------------------------------------------------------------------- /test/bindings/sect-left.prw: -------------------------------------------------------------------------------- 1 | 4 (+ 2) (/ 3) 2 | -------------------------------------------------------------------------------- /test/bindings/sect-right.prw: -------------------------------------------------------------------------------- 1 | 6 (4 -) (3 +) 2 | -------------------------------------------------------------------------------- /test/bindings/sect1.prw: -------------------------------------------------------------------------------- 1 | let s = (+ 1) -> 2 | 0 s 3 | -------------------------------------------------------------------------------- /test/combinators/compound.prw: -------------------------------------------------------------------------------- 1 | {2} 3 ^2$3%3 (+) %$ (-) 2 | -------------------------------------------------------------------------------- /test/combinators/simple.prw: -------------------------------------------------------------------------------- 1 | 4 {5} 6 %^$_$ (+) (*) 2 | -------------------------------------------------------------------------------- /test/data/cat-rev.prw: -------------------------------------------------------------------------------- 1 | stack as open -> 2 | 3 | [1, 2] [3, 4] cat-rev as [h4, h3, h2, h1] -> h4 h3 h2 h1 4 | -------------------------------------------------------------------------------- /test/data/cat.prw: -------------------------------------------------------------------------------- 1 | stack as open -> 2 | 3 | [1, 2] ++ [3, 4] as [h4, h3, h2, h1] -> h4 h3 h2 h1 4 | -------------------------------------------------------------------------------- /test/data/filter.prw: -------------------------------------------------------------------------------- 1 | stack as open -> 2 | 3 | [3, 4, 2, 6, 8] (< 3) & as _ >- h -> h 4 | -------------------------------------------------------------------------------- /test/data/flatten.prw: -------------------------------------------------------------------------------- 1 | stack as open -> 2 | 3 | [[1, 2], [3, 4]] >>= () & as _ >- h4 -> h4 4 | -------------------------------------------------------------------------------- /test/data/map.prw: -------------------------------------------------------------------------------- 1 | stack as open -> 2 | 3 | [1, 2, 3] <&> (* 2) & as [h3, h2, h1] -> h3 h2 h1 4 | -------------------------------------------------------------------------------- /test/data/rev.prw: -------------------------------------------------------------------------------- 1 | let (>-) {t} {h} = (;t,h) -> 2 | let rev-step (t >- h) a = t (a >- h) -> 3 | let rev = [] rev-step*+ _2 -> 4 | 5 | [1, 3, 5, 7, 9] rev 6 | 7 | as t1 >- h1 -> h1 8 | t1 as t2 >- h2 -> h2 9 | t2 as t3 >- h3 -> h3 10 | t3 as t4 >- h4 -> h4 11 | t4 as t5 >- h5 -> h5 12 | -------------------------------------------------------------------------------- /test/flow/alt-cut-accepted.prw: -------------------------------------------------------------------------------- 1 | 0 |+ 1 2 | -------------------------------------------------------------------------------- /test/flow/alt-cut-handle.prw: -------------------------------------------------------------------------------- 1 | (;) 0 |+ 1 2 | -------------------------------------------------------------------------------- /test/flow/alt-cut.prw: -------------------------------------------------------------------------------- 1 | (2 |+ 4) (== 4) 0 2 | -------------------------------------------------------------------------------- /test/flow/alt-greedy.prw: -------------------------------------------------------------------------------- 1 | (2 | 4) (== 4) 0 2 | -------------------------------------------------------------------------------- /test/flow/alt-handle.prw: -------------------------------------------------------------------------------- 1 | (;) 0 | 1 2 | -------------------------------------------------------------------------------- /test/flow/alt-rejected.prw: -------------------------------------------------------------------------------- 1 | (;) 0 | (;) 1 2 | -------------------------------------------------------------------------------- /test/flow/alt.prw: -------------------------------------------------------------------------------- 1 | 0 | 1 2 | -------------------------------------------------------------------------------- /test/flow/atomic-accept.prw: -------------------------------------------------------------------------------- 1 | (?> [1; 9]) (?: < 5) 2 | -------------------------------------------------------------------------------- /test/flow/atomic-reject.prw: -------------------------------------------------------------------------------- 1 | (?> [1; 9]) (?: > 5) 2 | -------------------------------------------------------------------------------- /test/flow/case-cut.prw: -------------------------------------------------------------------------------- 1 | [2;+ 4] (== 4) 0 2 | -------------------------------------------------------------------------------- /test/flow/case-rel.prw: -------------------------------------------------------------------------------- 1 | [4;? 7] ^ (?: < 5) (+) 2 | -------------------------------------------------------------------------------- /test/flow/case-rel2.prw: -------------------------------------------------------------------------------- 1 | [4;? 7] [4;? 7] (?: < 5) (+) 2 | -------------------------------------------------------------------------------- /test/flow/case.prw: -------------------------------------------------------------------------------- 1 | 1 [ 2 | (== 0) 0; 3 | (== 1) 2 4 | ] 5 | -------------------------------------------------------------------------------- /test/flow/cat.prw: -------------------------------------------------------------------------------- 1 | 3 + 4 & 2 & (-) 2 | -------------------------------------------------------------------------------- /test/flow/intersect.prw: -------------------------------------------------------------------------------- 1 | 4 & (> 3) && (- 2) 2 | -------------------------------------------------------------------------------- /test/flow/inversion-rejected.prw: -------------------------------------------------------------------------------- 1 | 5 [^ (> 2); (< 3); + 1] 2 | -------------------------------------------------------------------------------- /test/flow/inversion.prw: -------------------------------------------------------------------------------- 1 | 5 [^ (> 2); (> 3); + 1] 2 | -------------------------------------------------------------------------------- /test/flow/n-times.prw: -------------------------------------------------------------------------------- 1 | 5 (+ 1){2} 2 | 3 | let s = + 1 -> 4 | 5 (s{4} s{2}){3} 5 | -------------------------------------------------------------------------------- /test/flow/noncap-accept.prw: -------------------------------------------------------------------------------- 1 | (?:5) 6 2 | -------------------------------------------------------------------------------- /test/flow/noncap-reject.prw: -------------------------------------------------------------------------------- 1 | 5 (?: < 2) (+ 1) 2 | -------------------------------------------------------------------------------- /test/flow/opt-handle.prw: -------------------------------------------------------------------------------- 1 | 2 ((;) (+ 1))? 2 | -------------------------------------------------------------------------------- /test/flow/opt.prw: -------------------------------------------------------------------------------- 1 | 2 (+ 1)? 2 | -------------------------------------------------------------------------------- /test/flow/plus-reject.prw: -------------------------------------------------------------------------------- 1 | 3 ((< 3) && (+ 1))+ 2 | -------------------------------------------------------------------------------- /test/flow/plus.prw: -------------------------------------------------------------------------------- 1 | 0 ((< 3) && (+ 1))+ 2 | -------------------------------------------------------------------------------- /test/flow/star-cut.prw: -------------------------------------------------------------------------------- 1 | 0 ((< 3) && (+ 1))*+ (< 2) 2 | -------------------------------------------------------------------------------- /test/flow/star-greedy.prw: -------------------------------------------------------------------------------- 1 | 0 ((< 3) && (+ 1))* (?: < 2) 2 | -------------------------------------------------------------------------------- /test/flow/star-rel.prw: -------------------------------------------------------------------------------- 1 | 0 ((< 10) && (+ 1))*? (?: > 4) 2 | -------------------------------------------------------------------------------- /test/flow/star.prw: -------------------------------------------------------------------------------- 1 | 0 ((< 6) && (+ 1))* 2 | -------------------------------------------------------------------------------- /test/fundamentals/arith1.prw: -------------------------------------------------------------------------------- 1 | 3 + 4 2 | -------------------------------------------------------------------------------- /test/fundamentals/arith2.prw: -------------------------------------------------------------------------------- 1 | (3 ** 2 + 4 ** 2) / 5 2 | -------------------------------------------------------------------------------- /test/fundamentals/lit1.prw: -------------------------------------------------------------------------------- 1 | 4 5 "hi" 2 | -------------------------------------------------------------------------------- /test/modules/access.prw: -------------------------------------------------------------------------------- 1 | let m = mod 2 | def s x = x + 1 3 | def z = 0 4 | end -> 5 | m.z m.s{3} 6 | -------------------------------------------------------------------------------- /test/modules/open.prw: -------------------------------------------------------------------------------- 1 | mod 2 | def s x = x + 1 3 | def z = 0 4 | end as open -> 5 | z s{7} 6 | -------------------------------------------------------------------------------- /test/modules/recursion.prw: -------------------------------------------------------------------------------- 1 | 6 mod 2 | def fac n = n (* (n > 0) (n - 1) fac)? 3 | end.fac 4 | -------------------------------------------------------------------------------- /test/patterns/bin-func.prw: -------------------------------------------------------------------------------- 1 | let f x y = (;x,y) -> 2 | 1 2 f as (;a,b) -> b 3 | -------------------------------------------------------------------------------- /test/patterns/capture-direct.prw: -------------------------------------------------------------------------------- 1 | {9 2} as {f} -> f (-) 2 | -------------------------------------------------------------------------------- /test/patterns/capture-fun.prw: -------------------------------------------------------------------------------- 1 | {+ 1} as {s} -> 0 s s 2 | -------------------------------------------------------------------------------- /test/patterns/capture-indirect.prw: -------------------------------------------------------------------------------- 1 | {9 2} as {f g} -> f - g 2 | -------------------------------------------------------------------------------- /test/patterns/cat.prw: -------------------------------------------------------------------------------- 1 | 4 5 as x y -> x + y 2 | -------------------------------------------------------------------------------- /test/patterns/const-int-reject.prw: -------------------------------------------------------------------------------- 1 | 0 as 1 -> 8 2 | -------------------------------------------------------------------------------- /test/patterns/const-int.prw: -------------------------------------------------------------------------------- 1 | 0 as 0 -> 1 2 | -------------------------------------------------------------------------------- /test/patterns/const-str.prw: -------------------------------------------------------------------------------- 1 | "hi" as "hi" -> 0 2 | -------------------------------------------------------------------------------- /test/patterns/eith-func.prw: -------------------------------------------------------------------------------- 1 | let f x = (;x) -> 2 | 1 f as (;a) -> a 3 | -------------------------------------------------------------------------------- /test/patterns/left.prw: -------------------------------------------------------------------------------- 1 | (5;) as (x;) -> x + 8 2 | -------------------------------------------------------------------------------- /test/patterns/long-pair.prw: -------------------------------------------------------------------------------- 1 | (6, 5, 4) as (x, y, z) -> x - y + z 2 | -------------------------------------------------------------------------------- /test/patterns/nest-capture-pair.prw: -------------------------------------------------------------------------------- 1 | {(4, 2)} as {(u, v)} -> u / v 2 | -------------------------------------------------------------------------------- /test/patterns/nest-either-pair.prw: -------------------------------------------------------------------------------- 1 | (;4, 5) as (;x, y) -> y - x 2 | -------------------------------------------------------------------------------- /test/patterns/pair-func.prw: -------------------------------------------------------------------------------- 1 | let f x y = (x,y) -> 2 | 1 2 f as (a, b) -> b 3 | -------------------------------------------------------------------------------- /test/patterns/pair.prw: -------------------------------------------------------------------------------- 1 | (6, 12) as (x, y) -> x * y / (x + y) 2 | -------------------------------------------------------------------------------- /test/patterns/right.prw: -------------------------------------------------------------------------------- 1 | (;0) as (;x) -> x 2 | -------------------------------------------------------------------------------- /test/patterns/stack-rejected-high.prw: -------------------------------------------------------------------------------- 1 | [1, 2, 3] as [x1, x2, x3, x4] -> 0 2 | -------------------------------------------------------------------------------- /test/patterns/stack-rejected-low.prw: -------------------------------------------------------------------------------- 1 | [1, 2, 3] as [_, _] -> 0 2 | -------------------------------------------------------------------------------- /test/patterns/stack.prw: -------------------------------------------------------------------------------- 1 | [3, 4, 5] as [h1, h2, h3] -> h1 h2 h3 2 | --------------------------------------------------------------------------------