├── .gitignore ├── LICENSE ├── README.md ├── ROADMAP.md ├── doc ├── constructions │ ├── ambient.fl │ ├── coproduct.fl │ ├── effects.fl │ ├── function.fl │ ├── mixfix.fl │ ├── module.fl │ ├── product.fl │ └── recursion.fl ├── examples │ ├── hello-world │ │ └── hw.fl │ └── ping-pong │ │ ├── distributed │ │ ├── behavior.fl │ │ ├── game.fl │ │ └── player.fl │ │ └── local │ │ ├── local-v1.fl │ │ └── local-v2.fl └── syntax.md ├── lang ├── algebra │ └── monoid.fl ├── category │ ├── applicative.fl │ ├── arrow.fl │ ├── category.fl │ ├── free │ │ ├── functor.fl │ │ └── spec.fl │ ├── freer │ │ ├── functor.fl │ │ └── spec.fl │ ├── functor.fl │ ├── kleisly.fl │ ├── monad.fl │ ├── profunctor.fl │ ├── transformer │ │ └── reader.fl │ └── traversable.fl ├── dsl │ ├── -match-.fl │ ├── begin-end.fl │ └── if-then-else-.fl ├── example │ └── data-type-a-la-carte.fl ├── parsec │ ├── atom.fl │ ├── control.fl │ ├── eval.fl │ ├── parser.fl │ ├── result.fl │ └── source.fl ├── prelude.fl ├── props │ ├── equality.fl │ └── leibnitz.fl └── std │ ├── bool.fl │ ├── bool_laws.fl │ ├── continuation.fl │ ├── core.fl │ ├── equals.fl │ ├── identity.fl │ ├── list.fl │ ├── nat.fl │ ├── option.fl │ ├── or.fl │ ├── unit.fl │ └── vector.fl └── stage └── v0 ├── .ocamlformat ├── README.md ├── dune-project ├── ephel.opam ├── lib ├── 1-parser │ ├── 1-source │ │ ├── dune │ │ ├── ephel_parser_source.mli │ │ ├── location.ml │ │ ├── location.mli │ │ ├── region.ml │ │ ├── region.mli │ │ ├── sources.ml │ │ ├── sources.mli │ │ ├── specs.mli │ │ └── utils.ml │ ├── 2-parsec │ │ ├── atomic.ml │ │ ├── atomic.mli │ │ ├── control.ml │ │ ├── control.mli │ │ ├── core.ml │ │ ├── core.mli │ │ ├── dune │ │ ├── ephel_parser_parsec.mli │ │ ├── eval.ml │ │ ├── eval.mli │ │ ├── expr.ml │ │ ├── expr.mli │ │ ├── flow.ml │ │ ├── flow.mli │ │ ├── literal.ml │ │ ├── literal.mli │ │ ├── localise.ml │ │ ├── localise.mli │ │ ├── occurrence.ml │ │ ├── occurrence.mli │ │ ├── operator.ml │ │ ├── operator.mli │ │ ├── parsers.ml │ │ ├── parsers.mli │ │ ├── response.ml │ │ ├── response.mli │ │ ├── specs.mli │ │ ├── syntax.ml │ │ └── syntax.mli │ ├── dune │ └── ephel_parser.mli ├── 2-compiler │ ├── 01-utils │ │ ├── dune │ │ └── render.ml │ ├── 02-token │ │ ├── dune │ │ ├── ephel_compiler_token.mli │ │ ├── render.ml │ │ ├── render.mli │ │ └── token.mli │ ├── 03-tokenizer │ │ ├── dune │ │ ├── ephel_compiler_tokenizer.mli │ │ ├── tokenizer.ml │ │ └── tokenizer.mli │ ├── 04-cst │ │ ├── cst.ml │ │ ├── cst.mli │ │ ├── dune │ │ ├── ephel_compiler_cst.mli │ │ ├── render.ml │ │ └── render.mli │ ├── 05-analyzer │ │ ├── SYNTAX.md │ │ ├── analyser.ml │ │ ├── analyser.mli │ │ ├── dune │ │ └── ephel_compiler_analyzer.mli │ ├── 06-ast │ │ ├── dune │ │ ├── free.ml │ │ ├── free.mli │ │ ├── normal.ml │ │ ├── normal.mli │ │ ├── render.ml │ │ ├── render.mli │ │ └── term.mli │ ├── 07-objcode │ │ ├── dune │ │ ├── objcode.mli │ │ ├── render.ml │ │ └── render.mli │ ├── 08-lifting │ │ ├── dune │ │ ├── lifting.ml │ │ └── lifting.mli │ ├── 09-transpiler │ │ ├── dune │ │ ├── stack.ml │ │ ├── stack.mli │ │ ├── transpiler.ml │ │ └── transpiler.mli │ ├── 10_expander │ │ ├── dune │ │ ├── expander.ml │ │ └── expander.mli │ ├── 11_optimiser │ │ ├── dune │ │ ├── objvalue.ml │ │ ├── optimiser.ml │ │ └── optimiser.mli │ ├── 12_normaliser │ │ ├── dune │ │ ├── normaliser.ml │ │ └── normaliser.mli │ ├── 13_simplifier │ │ ├── dune │ │ ├── simplifier.ml │ │ └── simplifier.mli │ ├── dune │ └── ephel_compiler.mli ├── 3-runtime │ ├── dune │ └── ephel_runtime.mli ├── dune └── ephel.mli └── test ├── 1-parser ├── common.ml ├── dune ├── t00_parser_tests.ml ├── t01_eval.ml ├── t02_operator.ml ├── t03_atomic.ml ├── t04_occurrence.ml ├── t05_literal.ml ├── t06_syntax.ml ├── t07_extra.ml ├── t08_examples.ml └── t99_laws.ml └── 2-compiler ├── 03-tokenizer ├── common.ml ├── dune ├── t00_tokenizer_tests.ml ├── t01_separators.ml ├── t02_keywords.ml ├── t03_literals.ml ├── t04_identifiers.ml └── t05_spaces.ml ├── 05-analyzer ├── common.ml ├── dune ├── t00_analyzer_tests.ml ├── t01_identifier.ml ├── t02_literal.ml ├── t03_functional.ml ├── t04_group.ml ├── t05_product.ml ├── t06_coproduct.ml └── t07_declaration.ml ├── 06-ast ├── common.ml ├── dune ├── t00_ast_tests.ml └── t01_free_vars.ml ├── 08-lifting ├── dune └── t00_lifting_tests.ml ├── 09-transpiler ├── dune ├── t00_transpiler_tests.ml ├── t01_basic.ml ├── t02_sum.ml ├── t03_pair.ml └── t04_lambda.ml ├── 10-expander ├── dune ├── t00_expander_tests.ml ├── t01_basic.ml ├── t02_sum.ml ├── t03_pair.ml └── t04_lambda.ml ├── 11-optimiser ├── dune ├── t00_optimiser_tests.ml ├── t01_basic.ml ├── t02_sum.ml ├── t03_pair.ml └── t04_lambda.ml ├── 12-normaliser ├── dune ├── t00_normaliser_tests.ml ├── t01_basic.ml ├── t02_sum.ml ├── t03_pair.ml └── t04_lambda.ml └── 13-simplifier ├── dune ├── t00_simplifier_tests.ml ├── t01_basic.ml ├── t02_sum.ml ├── t03_pair.ml └── t04_lambda.ml /.gitignore: -------------------------------------------------------------------------------- 1 | # Created by https://www.toptal.com/developers/gitignore/Api/intellij+all,intellij+iml,ocaml 2 | # Edit at https://www.toptal.com/developers/gitignore?templates=intellij+all,intellij+iml,ocaml 3 | 4 | ### Intellij+all ### 5 | # Covers JetBrains IDEs: IntelliJ, RubyMine, PhpStorm, AppCode, PyCharm, CLion, Android Studio, WebStorm and Rider 6 | # Reference: https://intellij-support.jetbrains.com/hc/en-us/articles/206544839 7 | 8 | # User-specific stuff 9 | .idea 10 | 11 | # File-based project format 12 | *.iws 13 | 14 | # IntelliJ 15 | out/ 16 | 17 | # mpeltonen/sbt-idea plugin 18 | .idea_modules/ 19 | 20 | # JIRA plugin 21 | atlassian-ide-plugin.xml 22 | 23 | # Cursive Clojure plugin 24 | .idea/replstate.xml 25 | 26 | # SonarLint plugin 27 | .idea/sonarlint/ 28 | 29 | # Crashlytics plugin (for Android Studio and IntelliJ) 30 | com_crashlytics_export_strings.xml 31 | crashlytics.properties 32 | crashlytics-build.properties 33 | fabric.properties 34 | 35 | # Editor-based Rest Client 36 | .idea/httpRequests 37 | 38 | # Android studio 3.1+ serialized cache file 39 | .idea/caches/build_file_checksums.ser 40 | 41 | ### Intellij+all Patch ### 42 | # Ignore everything but code style settings and run configurations 43 | # that are supposed to be shared within teams. 44 | 45 | .idea/* 46 | 47 | !.idea/codeStyles 48 | !.idea/runConfigurations 49 | 50 | ### Intellij+iml ### 51 | # Covers JetBrains IDEs: IntelliJ, RubyMine, PhpStorm, AppCode, PyCharm, CLion, Android Studio, WebStorm and Rider 52 | # Reference: https://intellij-support.jetbrains.com/hc/en-us/articles/206544839 53 | 54 | # User-specific stuff 55 | 56 | # AWS User-specific 57 | 58 | # Generated files 59 | 60 | # Sensitive or high-churn files 61 | 62 | # Gradle 63 | 64 | # Gradle and Maven with auto-import 65 | # When using Gradle or Maven with auto-import, you should exclude module files, 66 | # since they will be recreated, and may cause churn. Uncomment if using 67 | # auto-import. 68 | # .idea/artifacts 69 | # .idea/compiler.xml 70 | # .idea/jarRepositories.xml 71 | # .idea/modules.xml 72 | # .idea/*.iml 73 | # .idea/modules 74 | # *.iml 75 | # *.ipr 76 | 77 | # CMake 78 | 79 | # Mongo Explorer plugin 80 | 81 | # File-based project format 82 | 83 | # IntelliJ 84 | 85 | # mpeltonen/sbt-idea plugin 86 | 87 | # JIRA plugin 88 | 89 | # Cursive Clojure plugin 90 | 91 | # SonarLint plugin 92 | 93 | # Crashlytics plugin (for Android Studio and IntelliJ) 94 | 95 | # Editor-based Rest Client 96 | 97 | # Android studio 3.1+ serialized cache file 98 | 99 | ### Intellij+iml Patch ### 100 | # Reason: https://github.com/joeblau/gitignore.io/issues/186#issuecomment-249601023 101 | 102 | *.iml 103 | modules.xml 104 | .idea/misc.xml 105 | *.ipr 106 | 107 | ### OCaml ### 108 | *.annot 109 | *.cmo 110 | *.cma 111 | *.cmi 112 | *.a 113 | *.o 114 | *.cmx 115 | *.cmxs 116 | *.cmxa 117 | 118 | # ocamlbuild working directory 119 | _build/ 120 | 121 | # ocamlbuild targets 122 | *.byte 123 | *.native 124 | 125 | # oasis generated files 126 | setup.data 127 | setup.log 128 | 129 | # Merlin configuring file for Vim and Emacs 130 | .merlin 131 | 132 | # Dune generated files 133 | *.install 134 | 135 | # Local OPAM switch 136 | _opam/ 137 | 138 | # End of https://www.toptal.com/developers/gitignore/Api/intellij+all,intellij+iml,ocaml -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2024 Didier Plaindoux 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /ROADMAP.md: -------------------------------------------------------------------------------- 1 | # Ephel Roadmap 2 | 3 | ## Bootstrap 4 | 5 | ```mermaid 6 | flowchart TD 7 | Z[v0 - Ephel source code compiler in OCaml] --> Y{{OCaml Compiler}} 8 | Y .-> X{{v0 - Ephel source code compiler}} 9 | G[Ephel ObjCode Interpet in Ocaml] --> H{{OCaml Compiler}} 10 | H .-> I{{OCaml ObjCode Interpet}} 11 | A[V1 - Ephel source code compiler in Ephel] --> X 12 | X .-> C[v1 - Ephel source code compiler ObjCode] 13 | C --> I 14 | A --> I 15 | I .-> F[v2 - Ephel source code compiler ObjCode] 16 | ``` 17 | 18 | ### Stage 0: In Ocaml 19 | 20 | A first compiler of a subset of Ephel source code and a runtime dedicated to the interpretation 21 | are proposed 22 | 23 | ### Stage 1: Ephel Compiler 24 | 25 | This first compiler written in Ephel producing Ephel bytecode. Its compilation produces an 26 | Ephel source code compiler objcode 27 | 28 | ### Stage 2: Ephel Compiler once again 29 | 30 | We replay the compilation with the v1. 31 | 32 | ## Extensions 33 | 34 | ### Stage 1: Type checker 35 | 36 | ### Stage 2: Level language 37 | 38 | -------------------------------------------------------------------------------- /doc/constructions/ambient.fl: -------------------------------------------------------------------------------- 1 | -- Ambient calculus as first class citizen 2 | 3 | ```ebnf 4 | M := `id -- Ambient name 5 | C := 6 | in M -- Enter capability 7 | out M -- Exit capability 8 | open M -- Open capability 9 | C.C -- Capability chain 10 | P := 11 | new M in P -- Restriction 12 | z0 -- Inactivity 13 | P | P -- Composition 14 | M[ P ] -- Ambient 15 | C.P -- Action 16 | go (C).P -- Direct action 17 | -- Message 18 | .e -- Input action 19 | ``` 20 | -------------------------------------------------------------------------------- /doc/constructions/coproduct.fl: -------------------------------------------------------------------------------- 1 | -- CoProduct definition 2 | 3 | sig Unit : type 4 | val Unit = 5 | | () : Unit 6 | 7 | val Bool : type = 8 | | true : Bool 9 | | false : Bool 10 | 11 | -- Pattern matching 12 | 13 | val not : Bool -> Bool = 14 | | true => false 15 | | false => true 16 | 17 | -- DSL which mimics OCaml match with construction 18 | 19 | sig match_with_end : {A B:type} -> A -> (A -> B) -> B 20 | val match_with_end = a f => f a 21 | 22 | val not : Bool -> Bool = b => 23 | match b with 24 | | true -> false 25 | | false -> true 26 | end 27 | 28 | val _&&_ : Bool -> Bool -> Bool (infix 15) = 29 | | true => b => b 30 | | false => _ => false 31 | 32 | val _||_ : Bool -> Bool -> Bool (infix 15) = 33 | | true => _ => true 34 | | false => b => b 35 | 36 | val _==>_ : Bool -> Bool -> Bool (infix 20) = a b => not a or b 37 | 38 | -- Recursive CoProduct 39 | 40 | val Nat : type = 41 | | Zero : Nat 42 | | Succ : Nat -> Nat 43 | 44 | sig _+_ : Nat -> Nat -> Nat 45 | val _+_ = 46 | | Zero => Identity 47 | | Succ n => m => Succ (n + m) 48 | 49 | -- Parametric CoProduct definition 50 | 51 | sig List : type -> type 52 | val List = X => 53 | | [] : List X 54 | | _::_ : X -> List X -> List X 55 | 56 | sig size : List X -> Nat 57 | val size = 58 | | [] => Zero 59 | | _ :: l => Succ (size l) 60 | 61 | -- GADT using intentional type theory for the propositional equality 62 | -- This is not a short term target for the moment. 63 | 64 | val :=: : type -> type -> type = A _ => 65 | | Refl : A :=: A 66 | 67 | val Expr : type -> type = A => 68 | | Bool : Bool -> Expr Bool 69 | | Int : Int -> Expr Int 70 | | _+_ : Exp Int -> Expr Int -> Expr Int 71 | | If_Then_Else_ : Expr Bool -> Expr A -> Expr A -> Expr A 72 | 73 | -{ 74 | With such GADT we can write the following term: 75 | If Bool true Then Int 1 Else Int 2 76 | }- 77 | 78 | -- Absurd 79 | 80 | sig _|_ : type 81 | val _|_ = . -{ No possible construction }- -------------------------------------------------------------------------------- /doc/constructions/effects.fl: -------------------------------------------------------------------------------- 1 | -- Algebraic effects 2 | 3 | TODO -------------------------------------------------------------------------------- /doc/constructions/function.fl: -------------------------------------------------------------------------------- 1 | -- Parametric functional type 2 | 3 | sig Identity : {X:type} -> X -> X 4 | val Identity = x => x 5 | 6 | -- Infix capability / Only applied to explicit parameters 7 | 8 | sig _compose_ : {A B C:type} -> (B -> C) -> (A -> B) -> (A -> C) 9 | val _compose_ = f g => x => f (g x) 10 | 11 | sig _|>_ : {A B C:type} -> (A -> B) -> (B -> C) -> (A -> C) 12 | val _|>_ = f g => g compose f 13 | 14 | val main : Int = 15 | let increment : Int -> Int = add 1 in 16 | let toString : Int -> String = i => i toString in 17 | -{ increment (|> {Int String String}) toString 2 }- 18 | increment |> toString 2 19 | -------------------------------------------------------------------------------- /doc/constructions/mixfix.fl: -------------------------------------------------------------------------------- 1 | --{ 2 | The chosen approach is the same as the one adopted in Agda. 3 | The main advantage of such an approach is a simple and intuitive 4 | approach for the user. This approach is ideal for DSLs definition. 5 | 6 | The adopted approach is the same as the one chosen for Agda 7 | Cf. https://agda.readthedocs.io/en/latest/language/mixfix-operators.html 8 | }-- 9 | 10 | --{ 11 | Reversed application specifying mixfix everywhere 12 | }-- 13 | 14 | sig __+ : Int -> Int -> Int -- This kind of mixfix is prohibited in the first version (same for multi word) 15 | 16 | val main : Int = 1 2 + 17 | --{ 18 | Equivalent to `(1 (2 +))` and to `(+ 2 1)` without mixfix constructions. 19 | }-- 20 | 21 | -- Trivial and simplistic DSL using mixfix 22 | 23 | sig Defer : type -> type 24 | val Defer = A => Unit -> A 25 | 26 | sig if_then_else_ : {A:type} -> Bool -> Defer A -> Defer A -> A 27 | val if_then_else_ = b t f => 28 | case b (_ => t ()) (_ => f ()) 29 | 30 | val test : Bool -> Int = b => if b (_ => 1 ) else (_ => 2) 31 | 32 | -{ 33 | In addition a mixfix precedence and associativity capabilities can be proposed. 34 | }- 35 | 36 | sig _+_ : Int -> Int -> Int (mixfix 20) 37 | sig _*_ : Int -> Int -> Int (mixfix 15) 38 | 39 | val main : Int = 1 + 2 * 4 -{ equivalent to `1 + (2 * 4)` }- 40 | 41 | -{ 42 | Finally mixfix can be "deactivated" using mixfix marker i.e. underscore. Then 43 | applied to the if_then_else_ function we have the following variations: 44 | - if_then y else z x 45 | - if x then_else z y 46 | - if x then y else_ z 47 | - if x then_else_ y z 48 | - if_then y else_ x z 49 | - if_then_else z x y 50 | - if_then_else_ x y z 51 | }- 52 | 53 | -{ For comprehension }- 54 | 55 | val Return : type -> type = F => sig struct 56 | sig return : {A :type} -> A -> F A 57 | end 58 | 59 | val Bind : type -> type = F => sig struct 60 | sig _>>=_ : {A B:type} -> F A -> (A -> F B) -> F B 61 | end 62 | 63 | val Option : type -> type = A => 64 | | None : Option A 65 | | Some : A -> Option A 66 | 67 | val BindOption : Bind Option = val struct 68 | val _>>=_ = 69 | | None => _ => None 70 | | Some a => f => Some (f a) 71 | end 72 | 73 | val example : Option String = 74 | let use BindOption in 75 | Some 1 >>= 1 +_ >>= to-String 76 | 77 | -- Of course such mixfix prohibits by construction snake case naming convention. 78 | -- Nevertheless, the language accept kebab case as illustrated with the `to-string` function. 79 | 80 | -{ Variable identification }- 81 | 82 | -- Sometime we would like to change the order of the variables. 83 | -- This can be done thanks to a template where names are given 84 | -- and each name should be reflected in the type in ordert to 85 | -- find the right order when desugaring terms 86 | 87 | sig {a}_as_{A} : (A:type) -> (a:A) -> A (linfix 200) 88 | val _as_ = _ => id 89 | 90 | -- 1 as Int == _as_ Int 1 -------------------------------------------------------------------------------- /doc/constructions/module.fl: -------------------------------------------------------------------------------- 1 | val Monoid : type -> type = T => 2 | sig struct 3 | sig neutral : T 4 | sig _combine_ : T -> T -> T 5 | end 6 | 7 | val MonoidInt : Monoid Int = 8 | let open Int in 9 | val struct 10 | val neutral = 0 11 | val _combine_ = _+_ 12 | end 13 | 14 | val MonoidString : Monoid String = 15 | let open String in 16 | val struct 17 | val neutral = "" 18 | val _combine_ = _^_ 19 | end 20 | 21 | val main1 : Int = 22 | let open MonoidInt in 23 | 1 combine neutral 24 | 25 | val main2 : Int = 26 | 1 (MonoidInt.combine) (MonoidInt.neutral) 27 | 28 | -- Note: Each source file is a module 29 | 30 | -- Module type and combination capability 31 | 32 | val mf : sig struct f : int -> int end = 33 | val struct 34 | val f = i => i 35 | end 36 | 37 | val mg : sig struct g : int -> int end = 38 | val struct 39 | val g = i => i 40 | end 41 | 42 | val mfg : 43 | let open core in -- for $ 44 | sig struct 45 | open $ sig of mf 46 | open $ sig of mg 47 | end = 48 | val struct 49 | open mf 50 | open mg 51 | end 52 | -------------------------------------------------------------------------------- /doc/constructions/product.fl: -------------------------------------------------------------------------------- 1 | -- Product data type 2 | 3 | val Pair : type = (X:type) * X 4 | val pair : Pair = char, 'a' 5 | 6 | val first : type = fst pair 7 | val second : first = snd pair 8 | 9 | -- Pattern matching is translated using `fst` and `snd`. 10 | 11 | val snd : (type * char) -> char = | (_,c) => c 12 | -------------------------------------------------------------------------------- /doc/constructions/recursion.fl: -------------------------------------------------------------------------------- 1 | -{ 2 | Recursive types and values. 3 | 4 | Recursion imply internal rec type and Y term with 5 | additional fold/unfold for type checking. 6 | 7 | All these constructions are introduced implicitly by the compiler. For 8 | this purpose this construction are not available in the language. 9 | 10 | Question: Is it necessary to have a rec/nonrec capability (like Ocaml)? 11 | }- 12 | 13 | sig _$_ : {A B:type} -> (A -> B) -> A -> B (infixl 100) 14 | val _$_ = id 15 | 16 | sig Vector : type 17 | val Vector = sig struct 18 | sig x : int 19 | sig y : int 20 | sig _+_ : Vector -> Vector 21 | end 22 | 23 | sig vector : int -> int -> Vector 24 | val vector = x y => val struct 25 | sig x = x 26 | sig y = y 27 | sig _+_ = v => vector (v x + x) (v y + y) 28 | end 29 | 30 | sig Vector : type 31 | val Vector = sig struct 32 | sig t : type 33 | sig _x : t -> int 34 | sig _y : t -> int 35 | sig _+_ : t -> t -> t 36 | end 37 | 38 | sig vector : int -> int -> Vector 39 | val vector = val struct 40 | sig t = int * int 41 | sig _x = self => fst self 42 | sig _y = self => snd self 43 | sig _+_ = self v => self x + v x, self y + v y 44 | end 45 | -------------------------------------------------------------------------------- /doc/examples/hello-world/hw.fl: -------------------------------------------------------------------------------- 1 | sig Console : sig struct 2 | sig println : String -> Unit 3 | end 4 | 5 | sig () : Ambient Process -- Inactivity 6 | 7 | val println : String -> Ambient Process = s => 8 | let _ = Console println s in () 9 | 10 | val basic : Ambient Process = 11 | println "Hello World!" 12 | 13 | val withStringOutput : Ambient Process = 14 | <"Hello World!"> | 15 | .(println x) 16 | 17 | val withMessageOutput : Ambient Process = 18 | message[ <"Hello World!"> ] | 19 | open message..(println x) 20 | 21 | val withActionMessageOutput : Ambient Process = 22 | message[ in Console.<"Hello World!"> ] | 23 | Console[ open message..(println x) ] 24 | 25 | val withDirectActionMessageOutput : Ambient Process = 26 | go in Console.message[ <"Hello World!"> ] | 27 | Console[ open message..(println x) ] 28 | 29 | val withDirectActionStringOutput : Ambient Process = 30 | go in Console.<"Hello World!"> | 31 | Console[ .(println x) ] 32 | -------------------------------------------------------------------------------- /doc/examples/ping-pong/distributed/behavior.fl: -------------------------------------------------------------------------------- 1 | sig play : ambient name -> ambient name -> Nat -> ambient process 2 | val play = sender receiver => 3 | | Zero => go (out sender.in `printer). 4 | | Succ n => .(play sender receiver x) | go out sender.in receiver. 5 | -------------------------------------------------------------------------------- /doc/examples/ping-pong/distributed/game.fl: -------------------------------------------------------------------------------- 1 | open player 2 | 3 | --{ 4 | Solution 1: 5 | 6 | `ping@ and `pong@ should exist (i.e. non local agents) 7 | and are denoted by an ambient with the same name. 8 | 9 | Open problem: 10 | Some resources are already provisioned (How?) 11 | 12 | Once `ping@ is "incarnated" its content is: 13 | ``` 14 | `game@[ `ping[] | `pong@ | `printer@ ] 15 | ``` 16 | }-- 17 | 18 | val _ : ambient process = 19 | `game[ 20 | `ping@ | 21 | `pong@ | 22 | `printer[ .(println x) ] | 23 | go in `ping.<42> | 24 | --{ Additional process for players }-- 25 | go in `ping.(player `ping to `pong) | 26 | go in `pong.(player `pong to `p1ng) 27 | ] 28 | 29 | -- ======================================================================= 30 | 31 | --{ 32 | Solution 2: 33 | 34 | Spawn is a system operation for ambient incarnation. This 35 | solution uses the first one. It enables the capacity to 36 | dispatch process incarnation. 37 | 38 | ``` 39 | val spawn : ambient name -> ambient process -> ambient process 40 | val spawn = name p => name@ | go (in name).p 41 | ``` 42 | }-- 43 | 44 | val _ : ambient process = 45 | `game[ 46 | spawn `ping $ player `ping to `pong | 47 | spawn `pong $ player `pong to `ping | 48 | `printer[ (x:ambient name).(println x) ] | 49 | go in `ping.<42> 50 | ] 51 | -------------------------------------------------------------------------------- /doc/examples/ping-pong/distributed/player.fl: -------------------------------------------------------------------------------- 1 | open behavior 2 | 3 | sig _to_ : (ambient name -> ambient process) -> ambient name -> ambient process 4 | sig _to_ = f p => f p 5 | 6 | sig player : ambient name -> ambient name -> ambient process 7 | val player = sender receiver => 8 | sender[ .(play sender receiver x) ] -------------------------------------------------------------------------------- /doc/examples/ping-pong/local/local-v1.fl: -------------------------------------------------------------------------------- 1 | sig play : ambient name -> ambient name -> Nat -> ambient process 2 | val play = sender receiver => 3 | | Zero => go (out sender.in `printer). 4 | | Succ n => .(play sender receiver x) | go (out sender.in receiver). in 5 | 6 | sig _to_ : (ambient name -> ambient process) -> ambient name -> ambient process 7 | sig _to_ = f p => f p 8 | 9 | sig player : ambient name -> ambient name -> ambient process 10 | val player = sender receiver => 11 | sender[ .(play sender receiver x) ] 12 | 13 | val _ : ambient process = 14 | (player `ping to `pong) | 15 | (player `pong to `ping) | 16 | `printer[ (x:ambient name).(println x) ] | 17 | go in `ping.<42> 18 | -------------------------------------------------------------------------------- /doc/examples/ping-pong/local/local-v2.fl: -------------------------------------------------------------------------------- 1 | val ping : type = 2 | | Ping : nat -> ping 3 | val pong : type = 4 | | Pong : nat -> pong 5 | 6 | val ping_to_nat : ping -> nat = Ping n => n 7 | val pong_to_nat : pong -> nat = Pong n => n 8 | 9 | sig play : {A:type} -> string -> (nat -> A) -> (A -> nat) -> nat -> ambient process 10 | val play = {A} who to_a to_nat => 11 | | Zero => 12 | | Succ n => .(play who fa to_nat $ to_nat a) | 13 | 14 | val _ : ambient process = 15 | .(play "Bob" Ping pong_to_nat $ ping_to_nat n) | 16 | .(play "Alice" Pong ping_to_nat $ ping_to_nat n) | 17 | .(println x) | 18 | 19 | -------------------------------------------------------------------------------- /doc/syntax.md: -------------------------------------------------------------------------------- 1 | ## Syntax 2 | 3 | ``` 4 | declaration ::= 5 | signature 6 | value 7 | 8 | signature ::= 9 | 'sig' id ':' term infix? 10 | 11 | value ::= 12 | 'val' id (':' term infix?)? '=' term 13 | 14 | term ::= 15 | literal 16 | id 17 | functional 18 | product 19 | coproduct 20 | structural 21 | equality 22 | type 23 | ambient 24 | group 25 | 26 | group ::= 27 | '(' term ')' 28 | 29 | literal ::= 30 | NUMBER 31 | STRING 32 | CHARACTER 33 | 34 | functional_term ::= 35 | -- abstraction and PM 36 | (id | '{' id+ '}')+ '=>' term 37 | ('|' term => term)+ 38 | -- functional type 39 | '{' id+ ':' term '}' '->' term 40 | '(' id+ ':' term ')' '->' term 41 | term '->' term 42 | -- application 43 | term term 44 | term '{' term '}' 45 | -- let binding 46 | 'let' id (':' term)? = term 'in' term 47 | 'let' open 'in' term 48 | -- meta 49 | 'sig' 'of' term 50 | 51 | product ::= 52 | term ',' term 53 | term '*' term 54 | '(' id+ ':' term) '*' term 55 | 'fst' term 56 | 'snd' term 57 | 58 | coproduct ::= 59 | ('|' term ':' term infix?)+ 60 | 61 | structural ::= -- To be reconsidered ... 62 | 'sig' 'struct' (open | signature | value)* 'end' 63 | 'val' 'struct' (open | signature | value)* 'end' 64 | term '.' id 65 | 66 | open ::= 67 | 'open' term 68 | 69 | equality ::= 70 | 'refl' 71 | 'subst' term 'by' term 72 | term '=' term 73 | 74 | type ::= 75 | 'type' 76 | 77 | ambient ::= 78 | name 79 | capability 80 | process 81 | 82 | name ::= 83 | '`' id '@'? 84 | 85 | name_id ::= 86 | name 87 | id 88 | 89 | capability ::= 90 | 'nocap' 91 | 'in' name_id 92 | 'out' name_id 93 | 'open' name_id 94 | capability '.' capability 95 | name_id 96 | 97 | process ::= 98 | name_id '[' process ']' 99 | 'go' capability '.' process 100 | capability '.' process 101 | process '|' process 102 | .process 103 | 104 | term 105 | 106 | infix ::= 107 | '(' ('infixl'|'infixr') NAT ')' 108 | ``` -------------------------------------------------------------------------------- /lang/algebra/monoid.fl: -------------------------------------------------------------------------------- 1 | sig Neutral : type -> type 2 | val Neutral : A => 3 | sig struct 4 | sig neutral : A 5 | end 6 | 7 | sig SemiGroup : type -> type 8 | val SemiGroup : A => sig struct 9 | sig compose : A -> A -> A 10 | val _+_ : sig of compose = compose 11 | 12 | -- Laws 13 | sig Laws-SemiGroup : sig struct 14 | sig ''(a + b) + c = a + (b + c)'' : 15 | (a:A) 16 | -> {b c:A} 17 | --------------------------- 18 | -> (a + b) + c :=: a + (b + c) 19 | end 20 | end 21 | 22 | sig Monoid : type -> type 23 | val Monoid : A => sig struct 24 | open Neutral A 25 | open SemiGroup A 26 | 27 | -- Laws 28 | sig Laws-Monoid : sig struct 29 | sig ''a = neutral + a'' : 30 | (a:A) 31 | ----------------- 32 | -> a :=: neutral + a 33 | 34 | sig ''a = a + neutral'' : 35 | (a:A) 36 | ----------------- 37 | -> a :=: a + neutral 38 | end 39 | end 40 | 41 | sig Api : type 42 | val Api = Monoid -------------------------------------------------------------------------------- /lang/category/applicative.fl: -------------------------------------------------------------------------------- 1 | sig Pure : (type -> type) -> type 2 | val Pure = F => sig struct 3 | sig pure : {A:type} -> A -> F a 4 | end 5 | 6 | sig Product : (type -> type) -> type 7 | val Product = F => sig struct 8 | sig product : {A B:type} -> F A -> F B -> F (A * B) 9 | end 10 | 11 | sig Apply : (type -> type) -> type 12 | val Apply = F => sig struct 13 | sig apply : {A B:type} -> F (A -> B) -> F A -> F B 14 | sig _<*>_ : sig of apply = apply 15 | 16 | sig _<**>_ : {A B:type} -> F A -> F (A -> B) -> F B 17 | val _<**>_ = a f => f <*> a 18 | end 19 | 20 | sig Applicative : (type -> type) -> type 21 | val Applicative = F => let open std.core in sig struct 22 | open functor.Api F 23 | 24 | open Pure F 25 | open Product F 26 | open Apply F 27 | 28 | val _<*>_ = f a => (p => fst p $ snd p) <$> product f a 29 | 30 | sig Laws-Applicative = 31 | sig struct 32 | -- Laws are missing here 33 | end 34 | end 35 | 36 | val Api : sig of Applicative = Applicative 37 | -------------------------------------------------------------------------------- /lang/category/arrow.fl: -------------------------------------------------------------------------------- 1 | -{ Local mixfix to be considered here }- 2 | 3 | sig Arrow : (_~>_: type -> type -> type) -> type 4 | val Arrow = _~>_ => sig struct 5 | open category.Api _~>_ 6 | 7 | sig arrow : {A B:type} -> (A -> B) -> A ~> B 8 | sig _>>>_ : {A B C:type} -> A ~> B -> B ~> C -> A ~> C 9 | sig first : {A B C:type} -> A ~> B -> (A * C) ~> (B * C) 10 | end 11 | 12 | val Api : sig of Arrow = Arrow -------------------------------------------------------------------------------- /lang/category/category.fl: -------------------------------------------------------------------------------- 1 | -{ Local mixfix to be considered here }- 2 | 3 | sig Category : (_~>_: type -> type -> type (infix 200)) -> type 4 | val Category = _~>_ => sig struct 5 | sig id: {A:type} -> A ~> A 6 | sig compose : {A B C:type} -> B ~> C -> A ~> B -> A ~> C 7 | val _<|_ : sig of compose = compose 8 | 9 | sig Laws-Category = sig struct 10 | sig ''h <| (g <| f) = (h <| g) <| f'' = 11 | {A B C D:type} 12 | -> {f: A ~> B} 13 | -> {g: B ~> C} 14 | -> {h: C ~> D} 15 | -> (a:A) 16 | --------------------------------------- 17 | -> (h <| (g <| f)) a :=: ((h <| g) <| f) a 18 | 19 | sig ''idB <| f = f'' 20 | {A B:type} 21 | -> {f: A ~> B} 22 | -> (a:A) 23 | ----------------------- 24 | -> (id {B} <| f) a :=: f a 25 | 26 | sig ''f = f <| idA'' 27 | {A B:type} 28 | -> {f: A ~> B} 29 | -> (a:A) 30 | ----------------------- 31 | -> f a :=: (f <| id {A}) a 32 | end 33 | end 34 | 35 | val Api : sig of Category = Category 36 | -------------------------------------------------------------------------------- /lang/category/free/functor.fl: -------------------------------------------------------------------------------- 1 | open category 2 | open free.spec 3 | 4 | sig Functor : (T:type -> type) -> functor.Api T -> functor.Api (Free T) 5 | val Functor : T F => val struct 6 | open functor.Api (Free T) 7 | 8 | sig map = f => 9 | | Return v => Return (f v) 10 | | Bind f' => Bind (F.map (map f) f') 11 | end 12 | -------------------------------------------------------------------------------- /lang/category/free/spec.fl: -------------------------------------------------------------------------------- 1 | -{ Based on functions to constructors reification }- 2 | 3 | sig Free : (type -> type) -> type -> type 4 | val Free = T A => 5 | | Return : A -> Free T A 6 | | Bind : T (Free T A) -> Free T A 7 | -------------------------------------------------------------------------------- /lang/category/freer/functor.fl: -------------------------------------------------------------------------------- 1 | open std.core 2 | open category 3 | open freer.spec 4 | 5 | sig Functor : (T:type -> type) -> functor.Api T -> functor.Api (Free T) 6 | val Functor : T F => val struct 7 | open functor.Api (Free T) 8 | 9 | sig map = f => 10 | | Return v => Return (f v) 11 | | Bind {B} b g => Bind {B} b (map f <| g) 12 | end 13 | -------------------------------------------------------------------------------- /lang/category/freer/spec.fl: -------------------------------------------------------------------------------- 1 | -{ Based on functions to constructors reification }- 2 | 3 | sig Freer : (type -> type) -> type -> type 4 | val Freer = T A => 5 | | Return : A -> Free T A 6 | | Bind : {B:type} -> T B -> (B -> Freer T A) -> Free T A 7 | -------------------------------------------------------------------------------- /lang/category/functor.fl: -------------------------------------------------------------------------------- 1 | sig Map : (type -> type) -> type 2 | val Map = F => sig struct 3 | sig map : {A B:type} -> (A -> B) -> F A -> F B 4 | val _<$>_ : sig of map = map 5 | val let+_in_ : {A B:type} -> F A -> (A -> B) -> F B = ma f => map f ma 6 | end 7 | 8 | -{ 9 | For instance with options, this syntax simplifies expressiveness 10 | mimicking traditional let binding 11 | 12 | ``` 13 | let+ Some 1 in x => 14 | let+ Some 2 in y => 15 | 1 + 2 16 | ``` 17 | }- 18 | 19 | sig Functor : (type -> type) -> type 20 | val Functor = F => let open std.core in sig struct 21 | open Map F 22 | 23 | sig Laws-Functor : sig struct 24 | sig ''map id = id'' : 25 | {A:type} 26 | -> (a:F A) 27 | -------------- 28 | -> map id a :=: a 29 | 30 | sig ''map f <| map g = map (f <| g)'' : 31 | {A B C:type} 32 | -> {f:B -> C} -> {g:A -> B} 33 | -> (a:F A) 34 | ------------------------------------- 35 | -> (map f <| map g) a :=: map (f <| g) a 36 | end 37 | end 38 | 39 | val Api : sig of Functor = Functor 40 | -------------------------------------------------------------------------------- /lang/category/kleisly.fl: -------------------------------------------------------------------------------- 1 | sig Compose : (type -> type) -> type 2 | val Compose = F => sig struct 3 | open category.monad.Api F 4 | 5 | sig _>=>_ : {A B C:type} -> (A -> F B) -> (B -> F C) -> (A -> F C) 6 | val _>=>_ = 7 | let open std.core in 8 | fa fb => fa |> $ fb =<<_ 9 | end 10 | 11 | sig Kleisly : (type -> type) -> type 12 | val Kleisly = F => sig struct 13 | open Compose F 14 | 15 | sig Law-Kleisly = sig struct 16 | -- Laws are missing here 17 | end 18 | end 19 | 20 | val Api : sig of Kleisly = Kleisly 21 | -------------------------------------------------------------------------------- /lang/category/monad.fl: -------------------------------------------------------------------------------- 1 | sig Return : (type -> type) -> type 2 | val Return = F => sig struct 3 | open applicative.Pure F 4 | val return : sig of pure = pure 5 | end 6 | 7 | sig Bind : (type -> type) -> type = F => 8 | val Bind = F => sig struct 9 | sig bind : {A B:type} -> F A -> (A -> F B) -> F B 10 | val _>>=_ : sig of bind = bind 11 | val let*_in_ : sig of bind = bind 12 | end 13 | 14 | -{ 15 | For instance with options, this syntax simplifies expressiveness 16 | mimicking traditional let binding 17 | 18 | ``` 19 | let* Some 1 in x => 20 | let* Some 2 in y => 21 | Some (1 + 2) 22 | ``` 23 | }- 24 | 25 | sig Join : (type -> type) -> type 26 | val Join = F => sig struct 27 | sig join : {A:type} -> F (F A) -> F A 28 | end 29 | 30 | sig Monad : (type -> type) -> type 31 | val Monad = F => sig struct 32 | open category.applicative.Api F 33 | 34 | open Return F 35 | open Bind F 36 | open Join F 37 | 38 | val bind = a f => 39 | let open std.core in 40 | f <$> a |> join 41 | 42 | sig Laws-Monad = sig struct 43 | -- Laws are missing here 44 | end 45 | end 46 | 47 | val Api : sig of Monad = Monad 48 | -------------------------------------------------------------------------------- /lang/category/profunctor.fl: -------------------------------------------------------------------------------- 1 | -{ Local mixfix to be considered here }- 2 | 3 | sig Profunctor : (_~>_ : type -> type -> type) -> type 4 | val Profunctor = _~>_ => let open std.core in sig struct 5 | sig dimap : {A B C D:type} -> (A -> B) -> (C -> D) -> B ~> C -> A ~> D 6 | 7 | sig lmap : {A B C:type} -> (A -> B) -> B ~> C -> A ~> C -- aka contramap_fst 8 | val lmap = f => dimap f id 9 | 10 | sig rmap : {A B C:type} -> (B -> C) -> A ~> B -> A ~> C -- aka map_snd 11 | val rmap = dimap id 12 | 13 | sig Laws-Profunctor = sig struct 14 | sig ''dimap id id = id'' : 15 | {A B:type} 16 | -> {f:A -> B} 17 | -> (a:A) 18 | -------------------------- 19 | -> dimap id id f a :=: id f a 20 | 21 | sig ''lmap id = id'' : 22 | (a:A) 23 | ------------------ 24 | -> lmap id a :=: id a 25 | 26 | sig ''rmap id = id'' : 27 | (a:A) 28 | ------------------ 29 | -> rmap id a :=: id a 30 | 31 | sig ''dimap f g = lmap f <| rmap g'' : 32 | {A B C D:type} 33 | -> {f:B -> C} 34 | -> {g:A -> B} 35 | -> (a:A) 36 | -------------------------------------- 37 | -> (dimap f g) a :=: (lmap f <| rmap g) a 38 | 39 | sig ''dimap (f <| g) (h <| i) = dimap g h <| dimap f i'' : 40 | {A B C D E F:type} 41 | -> {f:B -> C} 42 | -> {g:A -> B} 43 | -> {h:E -> F} 44 | -> {i:D -> E} 45 | -> (a:A) 46 | -------------------------------------------------------- 47 | -> dimap (f <| g) (h <| i) a :=: (dimap g h <| dimap f i) a 48 | 49 | sig ''lmap (f <| g) = lmap g <| lmap f'' : 50 | {A B C:type} 51 | -> {f:B -> C} 52 | -> {g:A -> B} 53 | -> (a:A) 54 | ---------------------------------------- 55 | -> lmap (f <| g) a :=: (lmap g <| lmap f) a 56 | 57 | sig ''rmap (f <| g) = rmap f <| rmap g'' : 58 | {A B C:type} 59 | -> {f:B -> C} 60 | -> {g:A -> B} 61 | -> (a:A) 62 | ---------------------------------------- 63 | -> rmap (f <| g) a :=: (rmap f <| rmap g) a 64 | end 65 | end 66 | 67 | val Api : sig of Profunctor = Profunctor 68 | -------------------------------------------------------------------------------- /lang/category/transformer/reader.fl: -------------------------------------------------------------------------------- 1 | sig Reader : (type -> type) -> type -> type -> type 2 | val Reader = F e a => (e -> F a) -> Reader F e a 3 | 4 | sig reader : {F:type -> type} -> {e a:type} -> (e -> F a) -> Reader F e a 5 | val reader = std.core.id 6 | 7 | sig run : {F:type -> type} -> {e a:type} -> Reader F e a -> e -> F a 8 | val run = std.core.id 9 | 10 | sig FunctorT : 11 | let Functor = category.functor.Api in 12 | (F:type -> type) -> Functor F -> (e:type) -> Functor (Reader F e) 13 | 14 | val FunctorT = F inner e => 15 | let Functor = category.functor.Api in 16 | val struct 17 | open Functor (Reader F e) 18 | 19 | val map = 20 | let open inner in 21 | f ma => e => f <$> (ma e) 22 | end 23 | 24 | sig ApplicativeT : 25 | let Applicative = category.applicative.Api in 26 | (F:type -> type) -> (e:type) -> Applicative F -> Applicative (Reader F e) 27 | 28 | val ApplicativeT = F e inner => 29 | let Applicative = category.applicative.Api in 30 | val struct 31 | open Applicative (Reader F e) 32 | 33 | let pure = e => std.core.const (inner.pure x) 34 | let apply = 35 | let open inner in 36 | mf ma => e => mf e <*> ma e 37 | end 38 | 39 | sig MonadT : 40 | let Monad = category.monad.Api in 41 | (F:type -> type) -> (e:type) -> Monad F -> Monad (Reader F e) 42 | 43 | val MonadT = F e inner => 44 | let Monad = category.monad.Api in 45 | val struct 46 | open Monad (Reader F e) 47 | 48 | val bind = 49 | let open inner in 50 | let open std.core in 51 | ma f => e => ma e >>= switch f e 52 | 53 | val join = bind std.core.id 54 | end 55 | -------------------------------------------------------------------------------- /lang/category/traversable.fl: -------------------------------------------------------------------------------- 1 | sig Traverse : (type -> type) -> (type -> type) -> type 2 | val Traverse = T F => sig struct 3 | sig traverse : {A B:type} -> (A -> F B) -> T A -> F (T B) 4 | end 5 | 6 | sig Sequence : (type -> type) -> (type -> type) -> type 7 | val Sequence = T F => sig struct 8 | sig sequence : {A:type} -> T (F A) -> F (T A) 9 | end 10 | 11 | sig Traversable : (type -> type) -> (type -> type) -> type 12 | val Api = T F => sig struct 13 | open Traverse T F 14 | open Sequence T F 15 | end 16 | 17 | sig Api =: sig of Traversable = Traversable 18 | 19 | -{ Work in progress }- 20 | 21 | sig WithApplicative: (T:type -> type) -> (F:type -> type) -> category.applicative.Api F -> Api T F 22 | val WithApplicative = T F applicative => 23 | let open std.core in 24 | let open applicative in 25 | val struct 26 | val traverse = f => map f |> sequence 27 | val sequence = traverse id 28 | end 29 | 30 | sig WithMonad: (T:type -> type) -> (F:type -> type) -> category.monad.Api F -> Api T F 31 | val WithMonad = T F monad => 32 | let open std.core in 33 | let open monad in 34 | val struct 35 | val traverse = bind 36 | val sequence = traverse id 37 | end 38 | -------------------------------------------------------------------------------- /lang/dsl/-match-.fl: -------------------------------------------------------------------------------- 1 | sig _match_ : {A B:type} -> A -> (A -> B) -> B (infixl 1000) 2 | sig _match_ = std.core.id 3 | -------------------------------------------------------------------------------- /lang/dsl/begin-end.fl: -------------------------------------------------------------------------------- 1 | sig begin_end : {A:type} -> A -> A (infix 1000) 2 | sig begin_end = std.core.id 3 | -------------------------------------------------------------------------------- /lang/dsl/if-then-else-.fl: -------------------------------------------------------------------------------- 1 | open std.bool 2 | open std.unit 3 | 4 | sig if_then_else_ : {A:type} -> Bool -> (Unit -> A) -> (Unit -> A) -> A (infix 1000) 5 | val if_then_else_ = 6 | | True => t _ => t unit 7 | | False => _ f => f unit 8 | -------------------------------------------------------------------------------- /lang/example/data-type-a-la-carte.fl: -------------------------------------------------------------------------------- 1 | -{ 2 | https://www.cambridge.org/core/journals/journal-of-functional-programming/article/data-types-a-la-carte/14416CB20C4637164EA9F77097909409 3 | 4 | Paper Abstract 5 | "This paper describes a technique for assembling both data types and functions from isolated individual components. 6 | We also explore how the same technology can be used to combine free monads and, as a result, structure Haskell's 7 | monolithic IO monad." 8 | } - 9 | 10 | -{ 1. Data type for expressions }- 11 | 12 | val Expr : (type -> type) -> type = f => 13 | | In : f (Expr f) -> Expr f 14 | 15 | val Val : type -> type = _ => 16 | | IntVal : Int -> Val 17 | 18 | val IntExpr : type = Expr Val 19 | 20 | val Add : type -> type = e => 21 | | Plus : e -> e -> Add e 22 | 23 | val AddExpr : type = Expr Add 24 | 25 | val _:+:_ : (f g:type -> type) -> type -> type = f g e => 26 | | Inl : f e -> (f :+: g) e 27 | | Inr : g e -> (f :+: g) e 28 | 29 | -{ 2. Functors corner }- 30 | 31 | open category 32 | 33 | val FunctorVal : functor.Api Val = 34 | val struct 35 | val map = f => | IntVal x => IntVal x 36 | 37 | -- Laws should be provided here 38 | end 39 | 40 | val FunctorAdd : functor.Api Add = 41 | val struct 42 | val map = f => | Plus l r = Plus (f l) (f r) 43 | 44 | -- Laws should be provided here 45 | end 46 | 47 | sig Functor:+: : {f g:type -> type} 48 | -> functor.Api f -> functor.Api g -> functor.Api (f :+: g) 49 | val Functor:+: = F G => 50 | val struct 51 | val map = f => | Inl e => Inl (F.map f e) 52 | | Inr e => Inr (G.map f e) 53 | 54 | -- Laws should be provided here 55 | end 56 | 57 | -{ 3. Fold expression }- 58 | 59 | sig foldExpr : {f:type -> type} 60 | -> functor.Api f -> (f a -> a) -> Expr f -> a 61 | val foldExpr = F f => | In t => f (F.map (foldExpr F f) t) 62 | 63 | -{ 4. Eval algebra }- 64 | 65 | sig Eval : (f:type -> type) -> 66 | sig struct 67 | sig functor : functor.Api f 68 | sig evalAlgebra : f Int -> Int 69 | end 70 | 71 | val EvalVal : Eval Val = 72 | val struct 73 | val functor = FunctorVal 74 | val evalAlgebra = | Val x => x 75 | end 76 | 77 | val EvalAdd : Eval Add = 78 | val struct 79 | val functor = FunctorAdd 80 | val evalAlgebra = | Plus x y => x Int.+ y 81 | end 82 | 83 | sig Eval:+: : {f g:type -> type} -> Eval f -> Eval g -> Eval (f :+: g) 84 | val Eval:+: = F G => 85 | val struct 86 | val functor = Functor:+: {f g} F G 87 | val evalAlgebra = | Inl x => F.eval x 88 | | Inr y => G.eval y 89 | end 90 | 91 | sig eval : {f:type -> type} -> Eval f -> Expr f -> Int 92 | val eval = E => foldExpr E.functor E.evalAlgebra 93 | 94 | -{ 5. Injection }- 95 | 96 | sig _:<:_ : (sub sup:type -> type) -> type 97 | val _:<:_ = sub sup => 98 | sig struct 99 | sig inj : {a:type} -> sub a -> sup a 100 | end 101 | 102 | val Id:<: : {f : type -> type} -> (f :<: f) = 103 | val struct 104 | sig inj = std.core.id 105 | end 106 | 107 | val Inl:<: : (f g: type -> type) -> f :<: (f :+: g) = 108 | val struct 109 | sig inj = Inl 110 | end 111 | 112 | val Inr:<: : (f g h: type -> type) -> f :<: g -> f :<: (h :+: g) = f:<:g => 113 | val struct 114 | sig inj = Inr <| f:<:g.inj 115 | end 116 | 117 | sig inject : {f g: type -> type} -> g :<: f -> g (Expr f) -> Expr f 118 | val inject = g:<:f => Exp <| g:<:f.inj 119 | -------------------------------------------------------------------------------- /lang/parsec/atom.fl: -------------------------------------------------------------------------------- 1 | open parsec.parser 2 | 3 | sig Atom : (P : Parser) -> 4 | let e = P.source.e in sig struct 5 | sig any : P.t e 6 | val atom : e -> P.t e 7 | val not : {A:type} -> P.t A -> P.t e 8 | end 9 | 10 | val Atom = P => val struct 11 | val any = source => 12 | P.Source.next source match 13 | | Some e, s => Success e true s 14 | | None, s => Failure (Some "Empty stream") false s 15 | 16 | val atom = element => source => 17 | let open parsec.eval.Eval.Infix in 18 | any element =_ 19 | 20 | val not = parser => source => 21 | fold (parser source) 22 | (_ _ s => Failure None false s) 23 | (_ _ s => any s) 24 | end 25 | -------------------------------------------------------------------------------- /lang/parsec/control.fl: -------------------------------------------------------------------------------- 1 | -{ Prelude }- 2 | 3 | open std.core 4 | open std.bool 5 | open parsec.parser 6 | open dsl.begin-end 7 | open dsl.-match- 8 | 9 | -{ Functor, Applicative and Monad }- 10 | 11 | sig Functor : category.functor.Api Parser.t 12 | val Functor = val struct 13 | val map = f p => s => 14 | p s match 15 | | Success e c s => Success (f e) c s 16 | | Failure r c s => Failure r c s 17 | 18 | val Laws-Functor = val struct 19 | val ''map id = id'' = p => s => 20 | p s match 21 | | Success _ _ _ => ?? 22 | | Failure _ _ _ => ?? 23 | 24 | val ''map f <| map g = map (f <| g)'' = p => s => 25 | p s match 26 | | Success _ _ _ => ?? 27 | | Failure _ _ _ => ?? 28 | end 29 | end 30 | 31 | sig Applicative : category.applicative.Api Parser.t 32 | val Applicative = val struct 33 | open Functor 34 | 35 | val pure = some 36 | 37 | -{ Order is important here :/ }- 38 | val product = ca cb => s => 39 | ca s match 40 | | Success a ca s => 41 | begin cb s match 42 | | Success b cb s => Success (a,b) (ca && cb) s 43 | | Failure r cb s => Failure r (ca && cb) s 44 | end 45 | | Failure r c s => Failure r c s 46 | 47 | val Laws-Applicative = val struct end 48 | end 49 | 50 | sig Monad : category.monad.Api Parser.t 51 | val Monad = val struct 52 | open Applicative 53 | 54 | val join = p => s => 55 | p s match 56 | | Success a _ _ => a 57 | | Failure r c s => Failure r c s 58 | 59 | val Laws-Monad = val struct end 60 | end -------------------------------------------------------------------------------- /lang/parsec/eval.fl: -------------------------------------------------------------------------------- 1 | open std.unit 2 | open std.option 3 | open dsl.-if-then-else- 4 | open dsl.begin-end 5 | open parsec.result 6 | open parsec.parser 7 | 8 | sig Eval : (P:Parser) -> sig struct 9 | sig eos : P Unit 10 | sig return : {A:type} -> A -> P.t A 11 | sig fails : {A:type} -> String? -> P.t A 12 | sig satisfy : {A:type} -> P.t A -> (predicate:A -> Bool) -> P.t A 13 | sig lazy : {A:type} -> (Unit -> P.t A) -> P.t A 14 | sig try : {A:type} -> P.t A -> P.t A 15 | sig lookahead : {A:type} -> P.t A -> P.t A 16 | sig fix : {A:type} -> (P.t A -> P.t A) -> P.t A 17 | 18 | sig Infix : sig struct 19 | sig __ : sig of satisfy (infix 1000) 20 | val __ = satisfy 21 | end 22 | end 23 | 24 | val Eval = P => val struct 25 | val eos = source => 26 | begin P.Source.next source match 27 | | Some e, s => Failure none false source 28 | | None, s => Success unit false source 29 | end 30 | 31 | val return = result => Success result false 32 | 33 | val fails = reason => Failure reason false 34 | 35 | val satisfy = parser predicate => source => 36 | fold (parser source) 37 | (element consumed source => 38 | if predicate element 39 | then (_ => Success element consumed source) 40 | else (_ => Failure none false source) 41 | ) 42 | Failure 43 | 44 | val lazy = parser => source => parser unit source 45 | 46 | val try = parser => source => 47 | fold (parser source) 48 | Success 49 | (reason _ source => Failure reason false source) 50 | 51 | val lookahead = parser => source => 52 | fold (parser source) 53 | (element _ _ => Success element false source) 54 | (reason _ _ => Failure reason false source) 55 | 56 | val fix = f => source => f (fix f) source 57 | end 58 | 59 | -------------------------------------------------------------------------------- /lang/parsec/parser.fl: -------------------------------------------------------------------------------- 1 | open parser.result 2 | open parser.source 3 | 4 | sig Parser : type 5 | val Parser = sig struct 6 | sig source: Source 7 | sig t: type -> type 8 | val t: (A:type) -> source.t -> Result.t A source.t 9 | end 10 | -------------------------------------------------------------------------------- /lang/parsec/result.fl: -------------------------------------------------------------------------------- 1 | open std.bool 2 | open std.option 3 | 4 | sig Result : sig struct 5 | sig t : (element:type) -> (source:type) -> type 6 | sig fold : {E S B:type} 7 | -> (result:t E S) 8 | -> (onSuccess:E -> Bool -> S -> B) 9 | -> (onFailure:String? -> Bool -> S -> B) 10 | -> B 11 | end 12 | 13 | val Result = val struct 14 | val t = E S => 15 | | Success : (element:E) -> (consumed:Bool) -> (source:S) -> Result E S 16 | | Failure : (reason:String?) -> (consumed:Bool) -> (source:S) -> Result E S 17 | 18 | val fold = 19 | | Success e c s => onSuccess _ => onSuccess e c s 20 | | Failure r c s => _ onFailure => onFailure r c s 21 | end -------------------------------------------------------------------------------- /lang/parsec/source.fl: -------------------------------------------------------------------------------- 1 | open std.option 2 | open std.or 3 | 4 | sig Source : sig struct 5 | sig e : type 6 | sig t : type 7 | 8 | sig next : t -> e? * t 9 | end 10 | 11 | sig Construct : sig struct 12 | sig c : type 13 | sig create : (filename:String?) -> t -> (source:Source)*source.t Or String 14 | end 15 | -------------------------------------------------------------------------------- /lang/prelude.fl: -------------------------------------------------------------------------------- 1 | open std.unit 2 | open std.core 3 | open std.bool 4 | -------------------------------------------------------------------------------- /lang/props/equality.fl: -------------------------------------------------------------------------------- 1 | -{ Propositional equality }- 2 | 3 | sig reflexive : 4 | {A:type} 5 | -> {a:A} 6 | ------- 7 | -> a :=: a 8 | 9 | val reflexive = 10 | refl 11 | 12 | sig symmetric : 13 | {A:type} 14 | -> {a b:A} 15 | -> a :=: b 16 | ------- 17 | -> b :=: a 18 | 19 | val symmetric = a=b => 20 | subst refl by a=b 21 | 22 | sig transitivity : 23 | {A:type} 24 | -> {a b c:A} 25 | -> a :=: b 26 | -> b :=: c 27 | ------- 28 | -> a :=: c 29 | 30 | val transitivity = a=b b=c => 31 | subst (subst refl by a=b) by b=c 32 | 33 | sig congruent : 34 | {A B:type} 35 | -> (f:A -> B) 36 | -> {a b:A} 37 | -> a :=: b 38 | ----------- 39 | -> f a :=: f b 40 | 41 | val congruent = f a=b => 42 | subst refl by (a=b) 43 | 44 | sig congruent-2 : 45 | {A B C:type} 46 | -> (f:A -> B -> C) 47 | -> {a b:A} 48 | -> {c d:B} 49 | -> a :=: b 50 | -> c :=: d 51 | --------------- 52 | -> f a c :=: f b d 53 | 54 | val congruent-2 = f a=b c=d => 55 | subst (subst refl by a=b) by c=d 56 | 57 | sig congruent-app : 58 | {A B:type} 59 | -> (f g:A -> B) 60 | -> f :=: g 61 | -------------------- 62 | -> {a:A} -> f a :=: g a 63 | 64 | val congruent-app = f g f=g => 65 | subst refl by (f=g) 66 | 67 | sig substitution : 68 | {A:type} 69 | -> {x y:A} 70 | -> (P:A -> type) 71 | -> x :=: y 72 | ---------- 73 | -> P x -> P y 74 | 75 | val substitution = P x=y px => 76 | subst px by x=y 77 | 78 | sig Dsl : 79 | -{ Inspired by Agda Cf. https://plfa.github.io/Equality }- 80 | sig struct 81 | sig Proof_ : 82 | {A:type} 83 | -> {a b:A} 84 | -> a :=: b 85 | ------- 86 | -> b :=: a 87 | 88 | sig _=[]_ : 89 | {A:type} 90 | -> (a:A) 91 | -> {b:A} 92 | -> a :=: b 93 | ------- 94 | -> b :=: a 95 | 96 | sig _=[_]_ : 97 | {A:type} 98 | -> (a:A) 99 | -> {b c :A} 100 | -> a :=: b 101 | -> b :=: c 102 | ------- 103 | -> a :=: c 104 | 105 | sig _Qed : 106 | {A:type} 107 | -> (a:A) 108 | ------- 109 | -> a :=: a 110 | end 111 | 112 | val Dsl = 113 | val struct 114 | val Proof_ = symmetric 115 | val _=[]_ = {A} a => symmetric {A a} 116 | val _=[_]_ = {A} a => transitive {A a} 117 | val _Qed = {A} a => refl {A a} 118 | end 119 | 120 | -{ 121 | Example of proof term using the Dsl (Not a real case): 122 | ``` 123 | Proof 124 | a =[ congruent-+ ] a :=: b 125 | Qed 126 | ``` 127 | }- -------------------------------------------------------------------------------- /lang/props/leibnitz.fl: -------------------------------------------------------------------------------- 1 | -{ Cf. https://homepages.inf.ed.ac.uk/wadler/papers/leibniz/leibniz.pdf }- 2 | 3 | -{ Liebnitz type definition } 4 | 5 | sig _:==:_ : {A:type} -> A -> A -> type 6 | val _:==:_ = {A} a b => (P : A -> type) -> P a -> P b 7 | 8 | -{ Reflexivity, Transitivity and Symmetry laws }- 9 | 10 | sig reflexive : 11 | {A:type} 12 | -> {a:A} 13 | ---------- 14 | -> a _:==:_ a 15 | 16 | val reflexive = P Pa => 17 | Pa 18 | 19 | sig transitive : 20 | {A:type} 21 | -> {a b c:A} 22 | -> a _:==:_ b 23 | -> b _:==:_ c 24 | ---------- 25 | -> a _:==:_ c 26 | 27 | val transitive = a=b b=c P Pa => 28 | b=c P (a=b P Pa) 29 | 30 | sig symmetric : 31 | {A:type} 32 | -> {a b:A} 33 | -> a _:==:_ b 34 | ---------- 35 | -> b _:==:_ a 36 | 37 | val symmetric = {A a b} a=b P => 38 | let Q = A -> type in 39 | let Q = c => P c -> P a in 40 | let Qa : Q a = reflexive P in 41 | let Qb : Q b = a=b Q Qa in 42 | Qb 43 | -------------------------------------------------------------------------------- /lang/std/bool.fl: -------------------------------------------------------------------------------- 1 | sig Bool : type 2 | val Bool = 3 | | True : Bool 4 | | False : Bool 5 | 6 | val true : Bool = True 7 | val false : Bool = False 8 | 9 | sig _&&_ : Bool -> Bool -> Bool (infixl 100) 10 | val _&&_ = 11 | | True => b => b 12 | | False => _ => False 13 | 14 | sig _||_ : Bool -> Bool -> Bool (infixl 150) 15 | val _||_ = 16 | | True => _ => True 17 | | False => b => b 18 | 19 | sig ~ : Bool -> Bool 20 | val ~ = 21 | | True => False 22 | | False => True 23 | 24 | sig _==>_ : Bool -> Bool -> Bool (infixl 200) 25 | val _==>_ = a b => ~ a || b 26 | 27 | sig Equals : std.equals.Api Nat 28 | val Equals = let open std.bool in val struct 29 | val _==_ = 30 | | True => 31 | begin 32 | | True => true 33 | | False => false 34 | end 35 | | False => 36 | begin 37 | | True => false 38 | | False => true 39 | end 40 | end 41 | -------------------------------------------------------------------------------- /lang/std/bool_laws.fl: -------------------------------------------------------------------------------- 1 | open std.bool 2 | open dsl.begin-end 3 | open dsl.-match- 4 | 5 | val And-Laws : type = sig struct 6 | sig commute : 7 | {A B:Bool} 8 | ----------------- 9 | -> A && B :=: B && A 10 | 11 | val commute = {A B} => 12 | A match 13 | | True => 14 | begin B match 15 | | True => refl 16 | | False => refl 17 | end 18 | | False => 19 | begin B match 20 | | True => refl 21 | | False => refl 22 | end 23 | 24 | sig left : 25 | {A:Bool} 26 | -------------------- 27 | -> False && A :=: False 28 | 29 | val left = refl 30 | 31 | sig right : 32 | {A:Bool} 33 | -------------------- 34 | -> A && False :=: False 35 | 36 | val right = subst left by commute 37 | end 38 | 39 | val Or-Laws : type = sig struct 40 | sig commute : 41 | {A B:Bool} 42 | ----------------- 43 | -> A || B :=: B || A 44 | 45 | val commute = {A B} => 46 | A match 47 | | True => 48 | begin B match 49 | | True => refl 50 | | False => refl 51 | end 52 | | False => 53 | begin B match 54 | | True => refl 55 | | False => refl 56 | end 57 | 58 | sig left : 59 | {A:Bool} 60 | ------------------ 61 | -> True || A :=: True 62 | 63 | val left = refl 64 | 65 | sig right : 66 | {A:Bool} 67 | ------------------ 68 | -> A || True :=: True 69 | 70 | val right = subst left by commute 71 | end 72 | -------------------------------------------------------------------------------- /lang/std/continuation.fl: -------------------------------------------------------------------------------- 1 | -- Work in progress 2 | 3 | -{ Prelude }- 4 | 5 | open std.core 6 | 7 | -{ Continuation type definition } 8 | 9 | sig Continuation : type -> type 10 | val Continuation = A => {R:Type} -> (A -> R) -> R 11 | 12 | -{ Functor, Applicative and Monad }- 13 | 14 | sig Functor : category.functor.Api Continuation 15 | val Functor = val struct 16 | val map = f c => k => c (f |> k) 17 | 18 | val Laws-Functor = 19 | val struct 20 | val ''map id = id'' = ?? 21 | 22 | val ''map f <| map g = map (f <| g)'' = ?? 23 | end 24 | end 25 | 26 | sig Applicative : category.applicative.Api Continuation 27 | val Applicative = val struct 28 | open Functor 29 | 30 | val pure = c => k => k c 31 | val product = ca cb => k => ca (a => cb (b => k (a, b))) 32 | 33 | val Laws-Applicative = val struct end 34 | end 35 | 36 | sig Monad : category.monad.Api Continuation 37 | val Monad = val struct 38 | open Applicative 39 | 40 | val join = c => k => c (c' => c' k) 41 | 42 | val Laws-Monad = val struct end 43 | end -------------------------------------------------------------------------------- /lang/std/core.fl: -------------------------------------------------------------------------------- 1 | sig id : {A:type} -> A -> A 2 | val id = x => x 3 | 4 | sig _$_ : {A B:type} -> (A -> B) -> A -> B (infixl 1000) 5 | val _$_ = id 6 | 7 | sig _<|_ : {A B C:type} -> (B -> C) -> (A -> B) -> (A -> C) (infixr 200) 8 | val _<|_ = f g => x => f (g x) 9 | 10 | sig _|>_ : {A B C:type} -> (A -> B) -> (B -> C) -> (A -> C) (infixl 200) 11 | val _|>_ = f g => g <| f 12 | 13 | sig const : {A B:type} -> A -> B -> A 14 | val const = a _ => a 15 | 16 | sig switch : {A B C:type} -> (A -> B -> C) -> (B -> A -> C) 17 | val switch = f b a => f a b 18 | 19 | sig Defer : type -> type 20 | val Defer = let open unit in A => Unit -> A 21 | 22 | -{ Explicit variable in type annotation }- 23 | 24 | sig {a}_as_{A} : (A:type) -> (a:A) -> A (rinfix 200) 25 | val _as_ = _ => id 26 | 27 | -- Examples: 1 as Int, Int as Type, 1 as Int as Type 28 | -------------------------------------------------------------------------------- /lang/std/equals.fl: -------------------------------------------------------------------------------- 1 | sig Equals : type -> type 2 | val Equals = F => sig struct 3 | sig _==_ : F -> F -> std.bool.Bool 4 | end 5 | 6 | val Api : sig of Equals = Equals 7 | -------------------------------------------------------------------------------- /lang/std/identity.fl: -------------------------------------------------------------------------------- 1 | -{ Type definition }- 2 | 3 | sig Id : type -> type 4 | val Id = e => e 5 | 6 | -{ Functor, Applicative and Monad }- 7 | 8 | sig Functor : category.functor.Api Id 9 | val Functor = val struct 10 | val map = a f => f a 11 | 12 | val Laws-Functor = val struct 13 | val ''map id = id'' = 14 | refl 15 | 16 | val ''(map f) <| (map g) = map (f <| g)'' = 17 | refl 18 | end 19 | end 20 | 21 | sig Applicative : category.applicative.Api Id 22 | val Applicative = val struct 23 | open Functor 24 | 25 | val pure = std.core.id 26 | val product = f a => (f,a) 27 | 28 | val Laws-Applicative = val struct end 29 | end 30 | 31 | sig Monad : category.monad.Api Id 32 | val Monad = val struct 33 | open Applicative 34 | 35 | val join = std.core.id 36 | 37 | val Laws-Monad = val struct end 38 | end 39 | 40 | -------------------------------------------------------------------------------- /lang/std/list.fl: -------------------------------------------------------------------------------- 1 | -{ Prelude }- 2 | 3 | open std.code 4 | open std.bool 5 | 6 | -{ Type definition }- 7 | 8 | sig [_] : type -> type (infix 500) 9 | val [_] = A => 10 | | [] : [A] 11 | | _::_ : A -> [A] -> [A] (infixr 500) 12 | 13 | -- Example: 1::2::3::[] : [int] 14 | 15 | -{ Catamorphism }- 16 | 17 | sig fold : {A R:type} -> [A] -> (unit -> R) -> (A -> [A] -> R) -> R 18 | val fold = 19 | | [] => f _ => f unit 20 | | a :: l => _ f => f a l 21 | 22 | -{ Basic functions }- 23 | 24 | sig nonEmpty : [A] -> Bool 25 | val nonEmpty => 26 | | [] => false 27 | | _ => true 28 | 29 | sig head : (l:[A]) -> {_: nonEmpty l :=: true} -> A 30 | val head = 31 | | [] => . -- ex falso quolibet 32 | | h :: _ => a 33 | 34 | sig tail : (l:[A]) -> {_: nonEmpty l :=: true} -> [A] 35 | val tail = 36 | | [] => . -- ex falso quolibet 37 | | _ :: t => t 38 | 39 | sig size : [A] -> Int 40 | val size = 41 | let size : Int -> [A] -> Int = acc => 42 | | [] => acc 43 | | _ :: l => size (acc + 1) l 44 | in 45 | size 0 46 | 47 | -{ Functor, Applicative and Monad }- 48 | 49 | sig Functor : category.functor.Api [_] 50 | val Functor = val struct 51 | val map = f => 52 | | [] => [] 53 | | h :: t => f h :: map f t 54 | 55 | val Laws-Functor = val struct 56 | val ''map id = id'' = 57 | | [] => refl 58 | | h :: t => congruent (h ::_) (''map id = id'' t) 59 | 60 | val ''map f <| map g = map (f <| g)'' = 61 | | [] => refl 62 | | h :: t => congruent ((f <| g) h ::_) (''map f <| map g = map (f <| g)'' t) 63 | end 64 | end 65 | -------------------------------------------------------------------------------- /lang/std/nat.fl: -------------------------------------------------------------------------------- 1 | -{ Type definition }- 2 | 3 | sig Nat : type 4 | val Nat = 5 | | Zero 6 | | Succ : Nat -> Nat 7 | 8 | sig Equals : std.equals.Api Nat 9 | val Equals = 10 | let open std.bool in 11 | let open dsl.begin-end in 12 | val struct 13 | val _==_ = 14 | | Zero => 15 | begin 16 | | Zero => true 17 | | Succ _ => false 18 | end 19 | | Succ a => 20 | begin 21 | | Zero => false 22 | | Succ b => a == b 23 | end 24 | end 25 | 26 | -{ Monoid }- 27 | 28 | sig Monoid : algebra.monoid.Api 29 | val Monoid = val struct 30 | val neutral = Zero 31 | val combine = 32 | | Zero => std.core.id 33 | | Succ a => b => Succ (combine a b) 34 | 35 | val Laws-SemiGroup = val struct 36 | val ''(a + b) + c = a + (b + c)'' = 37 | | Zero => refl 38 | | Succ a' => {b c} => congruent Succ (''(a + b) + c = a + (b + c)'' a' {b c}) 39 | end 40 | 41 | val Laws-Monoid = val struct 42 | val ''a = neutral + a'' = 43 | refl 44 | 45 | val ''a = a + neutral'' = 46 | | Zero => refl 47 | | Succ a' => congruent Succ (''a = a + neutral'' a') 48 | end 49 | end 50 | -------------------------------------------------------------------------------- /lang/std/option.fl: -------------------------------------------------------------------------------- 1 | -{ Prelude }- 2 | 3 | open std.core 4 | 5 | -{ Type definition }- 6 | 7 | sig _? : type -> type (infix 200) 8 | val _? = A => 9 | | None : A? 10 | | Some : A -> A? 11 | 12 | -{ Constructors }- 13 | 14 | val none : {A:type} -> A? = None 15 | val some : {A:type} -> A -> A? = Some 16 | 17 | -{ Catamorphism }- 18 | 19 | sig fold : {A R:type} -> A? -> (unit -> R) -> (A -> R) -> A 20 | val fold = 21 | | None => l => _ => l unit 22 | | Some a => _ => r => r a 23 | 24 | val _?_:_ : sig of fold (infix 150) = fold 25 | 26 | -{ Functor, Applicative and Monad }- 27 | 28 | sig Functor : category.functor.Api _? 29 | val Functor = val struct 30 | val map = f => 31 | | None => None 32 | | Some a => Some $ f a 33 | 34 | val Laws-Functor = 35 | val struct 36 | val ''map id = id'' = 37 | | None => refl 38 | | Some _ => refl 39 | 40 | val ''map f <| map g = map (f <| g)'' = 41 | | None => refl 42 | | Some _ => refl 43 | end 44 | end 45 | 46 | sig Applicative : category.applicative.Api _? 47 | val Applicative = val struct 48 | open Functor 49 | 50 | val pure = some 51 | val product = 52 | let open dsl.begin-end in 53 | | None => _ => None 54 | | Some f => 55 | begin 56 | | None => None 57 | | Some a => Some (f,a) 58 | end 59 | 60 | val Laws-Applicative = val struct end 61 | end 62 | 63 | sig Monad : category.monad.Api _? 64 | val Monad = val struct 65 | open Applicative 66 | 67 | val join = 68 | | None => None 69 | | Some a => a 70 | 71 | val Laws-Monad = val struct end 72 | end 73 | -------------------------------------------------------------------------------- /lang/std/or.fl: -------------------------------------------------------------------------------- 1 | -{ Type definition }- 2 | 3 | -- AKA Either 4 | sig _Or_ : type -> type -> type (infixl 200) 5 | val _Or_ = E A => 6 | | Inl : E -> E Or A 7 | | Inr : A -> E Or A 8 | 9 | -{ Constructors }- 10 | 11 | val inl : {E A:type} -> E -> E Or A = Inl 12 | val inr : {E A:type} -> A -> E Or A = Inr 13 | 14 | -{ Catamorphism }- 15 | 16 | sig fold : {E A R:type} -> E Or A -> (E -> R) -> (A -> R) -> A 17 | val fold = 18 | | Inl e => l => _ => l e 19 | | Inr a => _ => r => r a 20 | 21 | -{ Functor, Applicative and Monad }- 22 | 23 | sig Functor : (E: type) -> category.functor.Api (E Or_) 24 | val Functor = val struct 25 | val map = f => 26 | | Inl e => Inl e 27 | | Inr a => Inr $ f a 28 | 29 | val Laws-Functor = val struct 30 | val ''map id = id'' = 31 | | Inl _ => refl 32 | | Inr _ => refl 33 | 34 | val ''(map f) <| (map g) = map (f <| g)'' = 35 | | Inl _ => refl 36 | | Inr _ => refl 37 | end 38 | end 39 | 40 | sig Applicative : (E: type) -> category.applicative.Api (E Or_) 41 | val Applicative = val struct 42 | open Functor 43 | 44 | val pure = inl 45 | val product = 46 | let open dsl.begin-end in 47 | | Inl l => _ => Inl l 48 | | Inr f => 49 | begin 50 | | Inl l => Inl l 51 | | Inr a => Inr (f,a) 52 | end 53 | 54 | val Laws-Applicative = val struct end 55 | end 56 | 57 | sig Monad : (E: type) -> category.monad.Api (E Or_) 58 | val Monad = val struct 59 | open Applicative 60 | 61 | val join = 62 | | Inl l => Inl l 63 | | Inr a => a 64 | 65 | val Laws-Monad = val struct end 66 | end 67 | -------------------------------------------------------------------------------- /lang/std/unit.fl: -------------------------------------------------------------------------------- 1 | sig Unit : type 2 | val Unit = 3 | | () : Unit -------------------------------------------------------------------------------- /lang/std/vector.fl: -------------------------------------------------------------------------------- 1 | open std.nat 2 | 3 | -{ Type definition }- 4 | 5 | sig Vec : Nat -> type -> type 6 | val Vec = size A => 7 | | VNil : Vec Zero A 8 | | VCons : A -> Vec size A -> Vec (Succ size) A 9 | 10 | -------------------------------------------------------------------------------- /stage/v0/.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.26.2 2 | margin = 100 3 | max-indent = 80 4 | 5 | assignment-operator = begin-line 6 | 7 | break-cases = fit 8 | break-fun-decl = wrap 9 | break-fun-sig = fit-or-vertical 10 | break-infix = fit-or-vertical 11 | break-infix-before-func = true 12 | break-separators = before 13 | break-sequences = true 14 | 15 | cases-exp-indent = 2 16 | cases-matching-exp-indent = normal 17 | 18 | 19 | doc-comments = after-when-possible 20 | doc-comments-padding = 2 21 | doc-comments-tag-only = default 22 | dock-collection-brackets = true 23 | 24 | exp-grouping = preserve 25 | 26 | field-space = loose 27 | 28 | if-then-else = keyword-first 29 | 30 | indicate-multiline-delimiters = space 31 | indicate-nested-or-patterns = unsafe-no 32 | 33 | infix-precedence = indent 34 | 35 | leading-nested-match-parens = false 36 | 37 | let-and = sparse 38 | let-module = compact 39 | 40 | parens-tuple = always 41 | 42 | parse-docstrings = true 43 | 44 | sequence-blank-line = preserve-one 45 | sequence-style = terminator 46 | single-case = sparse 47 | 48 | space-around-arrays = true 49 | space-around-lists = true 50 | space-around-records = true 51 | space-around-variants = true 52 | 53 | type-decl = sparse 54 | 55 | wrap-comments = false 56 | wrap-fun-args = true 57 | -------------------------------------------------------------------------------- /stage/v0/README.md: -------------------------------------------------------------------------------- 1 | # Stage 0 2 | 3 | This is the first minimal language to be compiled. It does not manage types and accept 4 | the code without any kind of verification. 5 | 6 | Source: 7 | 8 | ### Concrete Syntax 9 | 10 | ``` 11 | s0 ::= 12 | value* 13 | 14 | value ::= 15 | 'val' id '= term 16 | 17 | term ::= 18 | group 19 | literal 20 | id 21 | functional 22 | product 23 | coproduct 24 | 25 | group ::= 26 | '(' term ')' 27 | 28 | literal ::= 29 | NUMBER 30 | STRING 31 | CHARACTER 32 | 33 | functional_term ::= 34 | -- abstraction and PM 35 | (id)+ '=>' term 36 | -- application 37 | term term 38 | -- let binding 39 | 'let' id = term 'in' term 40 | 41 | product ::= 42 | term ',' term 43 | 'fst' term 44 | 'snd' term 45 | 46 | coproduct ::= 47 | 'case' id term term 48 | 'inl' term 49 | 'inr' term 50 | ``` 51 | 52 | ### Abstract Syntax Tree 53 | 54 | ```ocaml 55 | type lit = 56 | | Int of int 57 | | Char of char 58 | | String of string 59 | 60 | type Builtin = 61 | | Fst 62 | | Snd 63 | | Inl 64 | | Inr 65 | 66 | type t = 67 | -- Basic type, identifier and literals 68 | | Id of string * string option 69 | | Literal of lit 70 | -- Function and application 71 | | Lambda of string * t 72 | | Apply of t * t 73 | | Let of string * t * t 74 | -- Pair type and data 75 | | Pair of t * t 76 | -- Sum data 77 | | Case of t * t * t 78 | -- Builtin 79 | | BuiltIn of Builtin * t 80 | ``` 81 | 82 | ### Object Code 83 | 84 | The runtime executes the following object code 85 | 86 | ```ocaml 87 | type value = 88 | | INT of int 89 | | STRING of string 90 | | CHAR of char 91 | | UNIT 92 | 93 | type t = 94 | -- Stack operations 95 | | PUSH of value 96 | | SWAP 97 | | DROP of int * string 98 | -- Memory management 99 | | DIG of int * string 100 | | DUP of int * string 101 | -- Sums data 102 | | LEFT 103 | | RIGHT 104 | | IF_LEFT of t list * t list 105 | -- Products data 106 | | PAIR 107 | | CAR 108 | | CDR 109 | | UNPAIR 110 | -- Lambda and closure 111 | | EXEC 112 | | LAMBDA of string * t list 113 | | LAMBDA_REC of string * string * t list 114 | ``` 115 | 116 | ### Compilation 117 | 118 | Partial function compilation using APPLY (Michelson) 119 | Study of PUSH/GRAB instruction addition for closures (Zinc Abstract Machine) 120 | 121 | ``` 122 | ((x => y => add x y) 1) 2 123 | (1) ---- 124 | PUSH 2;PUSH 1;LAMBDA[UNPAIR;FFI 2 "add"];APPLY;EXEC {} 125 | PUSH 1;LAMBDA[UNPAIR;FFI 2 "add"];APPLY;EXEC {2} 126 | LAMBDA[UNPAIR;FFI 2 "add"];APPLY;EXEC {1,2} 127 | APPLY;EXEC {[UNPAIR;FFI 2 "add";DROP "(x,y)" 1],1,2} 128 | EXEC {[PUSH 1;PAIR;UNPAIR;FFI 2 "add";DROP "(x,y)" 1],2} 129 | (2) ---- 130 | PUSH 1;PAIR;UNPAIR;FFI 2 "add" {2} 131 | PAIR;UNPAIR;FFI 2 "add" {1,2} 132 | UNPAIR;FFI 2 "add" {(1,2)} 133 | FFI 2 "add" {1,2} 134 | 0 {3} 135 | =========================================================== 136 | (x => (zero x) (y => y) (y => add x y)) 1 2 137 | - ETA-EXPANSION expressed during compilation ... 138 | (x => (zero x) (y => y) ((x y => add x y) x)) 1 2 139 | ``` 140 | -------------------------------------------------------------------------------- /stage/v0/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.4) 2 | (name ephel) 3 | (version 0.1) 4 | (maintainers "d.plaindoux@free.fr") 5 | (generate_opam_files true) 6 | (package 7 | (name ephel) 8 | (synopsis "Compiler of extend lambda-calculus to STACK machine without GC") 9 | (description "Compiler of extend lambda-calculus to STACK machine without GC") 10 | (depends 11 | (alcotest :with-test) 12 | (preface (>= 1.0.0)))) -------------------------------------------------------------------------------- /stage/v0/ephel.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "Compiler of extend lambda-calculus to STACK machine without GC" 5 | description: "Compiler of extend lambda-calculus to STACK machine without GC" 6 | maintainer: ["d.plaindoux@free.fr"] 7 | depends: [ 8 | "dune" {>= "3.4"} 9 | "alcotest" {with-test} 10 | "preface" {>= "1.0.0"} 11 | "odoc" {with-doc} 12 | ] 13 | build: [ 14 | ["dune" "subst"] {dev} 15 | [ 16 | "dune" 17 | "build" 18 | "-p" 19 | name 20 | "-j" 21 | jobs 22 | "@install" 23 | "@runtest" {with-test} 24 | "@doc" {with-doc} 25 | ] 26 | ] 27 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/1-source/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_parser_source) 3 | (public_name ephel.parser.source) 4 | (libraries preface) 5 | (modules_without_implementation specs ephel_parser_source)) 6 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/1-source/ephel_parser_source.mli: -------------------------------------------------------------------------------- 1 | module Location = Location 2 | module Region = Region 3 | module FromList = Sources.FromList 4 | module FromChars = Sources.FromChars 5 | module Specs = Specs 6 | module Utils = Utils 7 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/1-source/location.ml: -------------------------------------------------------------------------------- 1 | type t = string option * int * int * int 2 | 3 | module Construct = struct 4 | let initial file = (file, 0, 0, 0) 5 | let create ~file ~position ~line ~column = (file, position, line, column) 6 | end 7 | 8 | module Access = struct 9 | let file (f, _, _, _) = f 10 | let position (_, p, _, _) = p 11 | let line (_, _, l, _) = l 12 | let column (_, _, _, c) = c 13 | end 14 | 15 | module Render = struct 16 | let render ppf (f, _, l, c) = 17 | let open Format in 18 | match f with None -> fprintf ppf "%d:%d" l c | Some f -> fprintf ppf "%s:%d:%d" f l c 19 | end 20 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/1-source/location.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | module Construct : sig 4 | val initial : string option -> t 5 | val create : file:string option -> position:int -> line:int -> column:int -> t 6 | end 7 | 8 | module Access : sig 9 | val file : t -> string option 10 | val position : t -> int 11 | val line : t -> int 12 | val column : t -> int 13 | end 14 | 15 | module Render : sig 16 | val render : Format.formatter -> t -> unit 17 | end 18 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/1-source/region.ml: -------------------------------------------------------------------------------- 1 | type t = Location.t * Location.t 2 | 3 | module Construct = struct 4 | let create ~first ~last = (first, last) 5 | let combine (first, _) (_, last) = (first, last) 6 | end 7 | 8 | module Access = struct 9 | let file (l, _) = Location.Access.file l 10 | let first (l, _) = l 11 | let last (_, l) = l 12 | end 13 | 14 | module Render = struct 15 | let render ppf region = 16 | let open Format in 17 | let open Location.Render in 18 | let file = Access.file region 19 | and first = Access.first region 20 | and last = Access.first region in 21 | match file with 22 | | Some file -> fprintf ppf "in %s from %a to %a" file render first render last 23 | | None -> fprintf ppf "from %a to %a" render first render last 24 | end 25 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/1-source/region.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | module Construct : sig 4 | val create : first:Location.t -> last:Location.t -> t 5 | val combine : t -> t -> t 6 | end 7 | 8 | module Access : sig 9 | val file : t -> string option 10 | val first : t -> Location.t 11 | val last : t -> Location.t 12 | end 13 | 14 | module Render : sig 15 | val render : Format.formatter -> t -> unit 16 | end 17 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/1-source/sources.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 'a list * Location.t 2 | 3 | module FromList (Locator : Specs.LOCATOR) = struct 4 | type e = Locator.e 5 | type nonrec t = e t 6 | 7 | module Construct = struct 8 | type c = e list 9 | 10 | let create ~file s = (s, Location.Construct.initial file) 11 | end 12 | 13 | module Access = struct 14 | let next = function [], l -> (None, ([], l)) | a :: s, l -> (Some a, (s, Locator.locate l a)) 15 | let eos (s, _) = s = [] 16 | let location (_, l) = l 17 | end 18 | end 19 | 20 | module FromChars = FromList (struct 21 | type e = char 22 | 23 | let locate l = 24 | let open Location.Construct in 25 | let open Location.Access in 26 | function 27 | | '\n' -> create ~file:(file l) ~position:(position l + 1) ~line:(line l + 1) ~column:1 28 | | _ -> create ~file:(file l) ~position:(position l + 1) ~line:(line l) ~column:(column l + 1) 29 | end) 30 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/1-source/sources.mli: -------------------------------------------------------------------------------- 1 | module FromList : functor (Locator : Specs.LOCATOR) -> 2 | Specs.SOURCE with type e = Locator.e and type Construct.c = Locator.e list 3 | 4 | module FromChars : Specs.SOURCE with type e = char and type Construct.c = char list 5 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/1-source/specs.mli: -------------------------------------------------------------------------------- 1 | module Locator : sig 2 | type e 3 | 4 | val locate : Location.t -> e -> Location.t 5 | end 6 | 7 | module type LOCATOR = module type of Locator 8 | 9 | module Source : sig 10 | type e 11 | type t 12 | 13 | module Construct : sig 14 | type c 15 | 16 | val create : file:string option -> c -> t 17 | end 18 | 19 | module Access : sig 20 | val next : t -> e option * t 21 | val eos : t -> bool 22 | val location : t -> Location.t 23 | end 24 | end 25 | 26 | module type SOURCE = module type of Source 27 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/1-source/utils.ml: -------------------------------------------------------------------------------- 1 | let chars_of_string s = List.init (String.length s) (String.get s) 2 | 3 | let string_of_chars chars = 4 | let buf = Buffer.create 13 in 5 | List.iter (Buffer.add_char buf) chars; 6 | Buffer.contents buf 7 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/atomic.ml: -------------------------------------------------------------------------------- 1 | module Atomic (P : Specs.PARSEC) = struct 2 | module Monad = Control.Monad (P) 3 | module Eval = Eval.Eval (P) 4 | module Operator = Operator.Operator (P) 5 | 6 | let any s = 7 | let open Response.Construct in 8 | let open P.Source.Access in 9 | match next s with 10 | | Some e, s' -> success (e, true, s') 11 | | None, s' -> failure (Some "stream consumed", false, s') 12 | 13 | let not p s = 14 | let open Response.Destruct in 15 | let open Response.Construct in 16 | fold 17 | ~success:(fun (_, _, s) -> failure (None, false, s)) 18 | ~failure:(fun (_, _, s) -> any s) 19 | (p s) 20 | 21 | let atom e = 22 | let open Operator in 23 | any fun e' -> e' = e 24 | 25 | let atom_in l = 26 | let open Operator in 27 | any fun e' -> List.mem e' l 28 | 29 | let atoms l = 30 | let open List in 31 | let open Monad in 32 | let open Eval in 33 | let open Operator in 34 | do_try (fold_left (fun p e -> p <+< atom e) (return ()) l <&> Stdlib.Fun.const l) 35 | end 36 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/atomic.mli: -------------------------------------------------------------------------------- 1 | module Atomic : functor (P : Specs.PARSEC) -> sig 2 | val any : P.Source.e P.t 3 | val atom : P.Source.e -> P.Source.e P.t 4 | val atom_in : P.Source.e list -> P.Source.e P.t 5 | val atoms : P.Source.e list -> P.Source.e list P.t 6 | val not : 'a P.t -> P.Source.e P.t 7 | end 8 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/control.ml: -------------------------------------------------------------------------------- 1 | module Functor (P : Specs.PARSEC) = Preface.Make.Functor.Via_map (struct 2 | type 'a t = 'a P.t 3 | 4 | let map f p s = 5 | let open Response.Destruct in 6 | let open Response.Construct in 7 | fold 8 | ~success:(fun (a, b, s) -> success (f a, b, s)) 9 | ~failure:(fun (m, b, s) -> failure (m, b, s)) 10 | (p s) 11 | end) 12 | 13 | module Monad (P : Specs.PARSEC) = Preface.Make.Monad.Via_return_and_bind (struct 14 | type 'a t = 'a P.t 15 | 16 | let return v s = 17 | let open Response.Construct in 18 | success (v, false, s) 19 | 20 | let bind f p s = 21 | let open Response.Destruct in 22 | let open Response.Construct in 23 | fold 24 | ~success:(fun (p, b1, s) -> 25 | fold 26 | ~success:(fun (a, b2, s) -> success (a, b1 || b2, s)) 27 | ~failure:(fun (m, b, s) -> failure (m, b, s)) 28 | (f p s) ) 29 | ~failure:(fun (m, b, s) -> failure (m, b, s)) 30 | (p s) 31 | end) 32 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/control.mli: -------------------------------------------------------------------------------- 1 | module Functor : functor (P : Specs.PARSEC) -> Preface.Specs.FUNCTOR with type 'a t = 'a P.t 2 | module Monad : functor (P : Specs.PARSEC) -> Preface.Specs.MONAD with type 'a t = 'a P.t 3 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/core.ml: -------------------------------------------------------------------------------- 1 | module Core (P : Specs.PARSEC) = struct 2 | include Control.Monad (P) 3 | include Eval.Eval (P) 4 | include Flow.Flow (P) 5 | include Operator.Operator (P) 6 | include Occurrence.Occurrence (P) 7 | include Atomic.Atomic (P) 8 | include Expr.Expr (P) 9 | end 10 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/core.mli: -------------------------------------------------------------------------------- 1 | module Core : functor (P : Specs.PARSEC) -> sig 2 | include module type of Control.Monad (P) 3 | include module type of Eval.Eval (P) 4 | include module type of Flow.Flow (P) 5 | include module type of Operator.Operator (P) 6 | include module type of Occurrence.Occurrence (P) 7 | include module type of Atomic.Atomic (P) 8 | include module type of Expr.Expr (P) 9 | end 10 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_parser_parsec) 3 | (public_name ephel.parser.parsec) 4 | (libraries preface ephel.parser.source) 5 | (modules_without_implementation specs ephel_parser_parsec)) 6 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/ephel_parser_parsec.mli: -------------------------------------------------------------------------------- 1 | module Response = Response 2 | module Specs = Specs 3 | module Control = Control 4 | module Atomic = Atomic.Atomic 5 | module Eval = Eval.Eval 6 | module Expr = Expr.Expr 7 | module Flow = Flow.Flow 8 | module Operator = Operator.Operator 9 | module Syntax = Syntax.Syntax 10 | module Literal = Literal.Literal 11 | module Occurrence = Occurrence.Occurrence 12 | module Localise = Localise.Localise 13 | module Parsec = Parsers.Parsec 14 | module Core = Core.Core 15 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/eval.ml: -------------------------------------------------------------------------------- 1 | module Eval (P : Specs.PARSEC) = struct 2 | module Monad = Control.Monad (P) 3 | 4 | let locate p s = 5 | let module Region = Ephel_parser_source.Region.Construct in 6 | let open Response.Destruct in 7 | let open Response.Construct in 8 | let open P.Source.Access in 9 | let l0 = location s in 10 | fold 11 | ~success:(fun (a, b, s) -> success ((a, Region.create ~first:l0 ~last:(location s)), b, s)) 12 | ~failure:(fun (m, _, _) -> failure (m, false, s)) 13 | (p s) 14 | 15 | let eos s = 16 | let open Response.Construct in 17 | let open P.Source.Access in 18 | match next s with 19 | | Some _, s' -> failure (Some "stream not consumed", false, s') 20 | | None, s' -> success ((), false, s') 21 | 22 | let return = Monad.return 23 | 24 | let fail ?(consumed = false) ?(message = None) s = 25 | let open Response.Construct in 26 | failure (message, consumed, s) 27 | 28 | let do_lazy p s = Lazy.force p s 29 | 30 | let do_try p s = 31 | let open Response.Destruct in 32 | let open Response.Construct in 33 | fold 34 | ~success:(fun (a, b, s) -> success (a, b, s)) 35 | ~failure:(fun (m, _, _) -> failure (m, false, s)) 36 | (p s) 37 | 38 | let lookahead p s = 39 | let open Response.Destruct in 40 | let open Response.Construct in 41 | fold 42 | ~success:(fun (a, _, _) -> success (a, false, s)) 43 | ~failure:(fun (m, _, _) -> failure (m, false, s)) 44 | (p s) 45 | 46 | let satisfy p f s = 47 | let open Response.Destruct in 48 | let open Response.Construct in 49 | fold 50 | ~success:(fun (a, b, s') -> if f a then success (a, b, s') else failure (None, false, s)) 51 | ~failure:(fun (m, c, s') -> failure (m, c, s')) 52 | (p s) 53 | 54 | let rec fix f s = f (fix f) s 55 | end 56 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/eval.mli: -------------------------------------------------------------------------------- 1 | module Eval : functor (P : Specs.PARSEC) -> sig 2 | val locate : 'a P.t -> ('a * Ephel_parser_source.Region.t) P.t 3 | val eos : unit P.t 4 | val return : 'a -> 'a P.t 5 | val fail : ?consumed:bool -> ?message:string option -> 'a P.t 6 | val do_lazy : 'a P.t Lazy.t -> 'a P.t 7 | val do_try : 'a P.t -> 'a P.t 8 | val lookahead : 'a P.t -> 'a P.t 9 | val satisfy : 'a P.t -> ('a -> bool) -> 'a P.t 10 | val fix : ('a P.t -> 'a P.t) -> 'a P.t 11 | end 12 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/expr.ml: -------------------------------------------------------------------------------- 1 | module Expr (P : Specs.PARSEC) = struct 2 | module Monad = Control.Monad (P) 3 | module Operator = Operator.Operator (P) 4 | 5 | let option x p = 6 | let open Monad in 7 | let open Operator in 8 | p <|> return x 9 | 10 | let term prefix t postfix = 11 | let open Stdlib.Fun in 12 | let open Monad in 13 | let open Monad.Syntax in 14 | let* pre = option id prefix in 15 | let* x = t in 16 | let* post = option id postfix in 17 | return @@ post @@ pre x 18 | 19 | let infixN op p x = 20 | let open Monad in 21 | let open Monad.Syntax in 22 | let* f = op in 23 | let* y = p in 24 | return @@ f x y 25 | 26 | let rec infixL op p x = 27 | let open Monad in 28 | let open Monad.Syntax in 29 | let open Operator in 30 | let* f = op in 31 | let* y = p in 32 | let r = f x y in 33 | infixL op p r <|> return r 34 | 35 | let rec infixR op p x = 36 | let open Monad in 37 | let open Monad.Syntax in 38 | let open Monad.Infix in 39 | let open Operator in 40 | let* f = op in 41 | let* y = p >>= fun r -> infixR op p r <|> return r in 42 | return @@ f x y 43 | end 44 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/expr.mli: -------------------------------------------------------------------------------- 1 | module Expr : functor (P : Specs.PARSEC) -> sig 2 | val term : ('a -> 'a) P.t -> 'a P.t -> ('a -> 'a) P.t -> 'a P.t 3 | val infixN : ('a -> 'a -> 'a) P.t -> 'a P.t -> 'a -> 'a P.t 4 | val infixL : ('a -> 'a -> 'a) P.t -> 'a P.t -> 'a -> 'a P.t 5 | val infixR : ('a -> 'a -> 'a) P.t -> 'a P.t -> 'a -> 'a P.t 6 | end 7 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/flow.ml: -------------------------------------------------------------------------------- 1 | module Flow (P : Specs.PARSEC) = struct 2 | module Functor = Control.Functor (P) 3 | 4 | let sequence p1 p2 s = 5 | let open Response.Destruct in 6 | let open Response.Construct in 7 | fold 8 | ~success:(fun (a1, b1, s1) -> 9 | fold 10 | ~success:(fun (a2, b2, s2) -> success ((a1, a2), b1 || b2, s2)) 11 | ~failure:(fun (m, b2, s2) -> failure (m, b1 || b2, s2)) 12 | (p2 s1) ) 13 | ~failure:(fun (m, b1, s1) -> failure (m, b1, s1)) 14 | (p1 s) 15 | 16 | let choice p1 p2 s = 17 | let open Response.Destruct in 18 | let open Response.Construct in 19 | let open Functor in 20 | fold 21 | ~success:(fun (a, b, s) -> success (a, b, s)) 22 | ~failure:(fun (m, b, s) -> if b then failure (m, b, s) else (p2 <&> fun e -> Either.Right e) s) 23 | ((p1 <&> fun e -> Either.Left e) s) 24 | 25 | let eager_choice p1 p2 s = 26 | let open Ephel_parser_source.Location.Access in 27 | let open P.Source.Access in 28 | let open Response.Destruct in 29 | let open Response.Construct in 30 | let open Functor in 31 | let r1 = (p1 <&> fun e -> Either.Left e) s in 32 | let r2 = (p2 <&> fun e -> Either.Right e) s in 33 | fold 34 | ~success:(fun (a, b, s) -> 35 | fold 36 | ~success:(fun (a', b', s') -> 37 | if position (location s) < position (location s') 38 | then success (a', b', s') 39 | else success (a, b, s) ) 40 | ~failure:(fun _ -> success (a, b, s)) 41 | r2 ) 42 | ~failure:(fun _ -> r2) 43 | r1 44 | 45 | let unify p = Functor.(p <&> function Either.Left a | Either.Right a -> a) 46 | end 47 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/flow.mli: -------------------------------------------------------------------------------- 1 | module Flow : functor (P : Specs.PARSEC) -> sig 2 | val sequence : 'a P.t -> 'b P.t -> ('a * 'b) P.t 3 | val choice : 'a P.t -> 'b P.t -> ('a, 'b) Either.t P.t 4 | val unify : ('a, 'a) Either.t P.t -> 'a P.t 5 | val eager_choice : 'a P.t -> 'b P.t -> ('a, 'b) Either.t P.t 6 | end 7 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/literal.ml: -------------------------------------------------------------------------------- 1 | module Literal (P : Specs.PARSEC with type Source.e = char) = struct 2 | module Monad = Control.Monad (P) 3 | module Atomic = Atomic.Atomic (P) 4 | module Eval = Eval.Eval (P) 5 | module Operator = Operator.Operator (P) 6 | module Occurrence = Occurrence.Occurrence (P) 7 | 8 | let char c = 9 | let open Operator in 10 | let open Atomic in 11 | any fun e' -> e' = c 12 | 13 | let char_in_ranges l = 14 | let open Operator in 15 | let open Atomic in 16 | any fun e' -> List.exists (fun (l, u) -> l <= e' && e' <= u) l 17 | 18 | let char_in_range r = char_in_ranges [ r ] 19 | 20 | let char_in_list l = 21 | let open Operator in 22 | let open Atomic in 23 | any fun e' -> List.mem e' l 24 | 25 | let char_in_string s = 26 | let open Ephel_parser_source.Utils in 27 | char_in_list (chars_of_string s) 28 | 29 | let digit = char_in_range ('0', '9') 30 | let alpha = char_in_ranges [ ('a', 'z'); ('A', 'Z') ] 31 | 32 | let natural = 33 | let open Monad in 34 | let open Occurrence in 35 | let open Ephel_parser_source.Utils in 36 | rep digit <&> string_of_chars <&> int_of_string 37 | 38 | let integer = 39 | let open Monad in 40 | let open Atomic in 41 | let open Operator in 42 | let open Occurrence in 43 | let negative = atom '-' >+> return (( * ) (-1)) 44 | and positive = opt (atom '+') >+> return Stdlib.Fun.id in 45 | negative <|> positive <+> natural <&> fun (f, i) -> f i 46 | 47 | let string s = 48 | let open Monad in 49 | let open Atomic in 50 | let open Ephel_parser_source.Utils in 51 | atoms (chars_of_string s) <&> Stdlib.Fun.const s 52 | 53 | let string_in_list l = 54 | let open List in 55 | let open Eval in 56 | let open Operator in 57 | fold_left (fun p e -> p <|> string e) fail l 58 | 59 | let sequence p = 60 | let open Monad in 61 | let open Occurrence in 62 | let open Ephel_parser_source.Utils in 63 | rep p <&> string_of_chars 64 | 65 | module Delimited = struct 66 | let string_delimited = 67 | let open Monad in 68 | let open Atomic in 69 | let open Operator in 70 | let open Occurrence in 71 | let open Ephel_parser_source.Utils in 72 | char '"' 73 | >+> opt_rep (char '\\' >+> char '"' <&> Stdlib.Fun.const '"' <|> not (char '"')) 74 | <+< char '"' 75 | <&> string_of_chars 76 | 77 | let char_delimited = 78 | let open Monad in 79 | let open Atomic in 80 | let open Operator in 81 | char '\'' >+> (string "\\\'" <&> Stdlib.Fun.const '\'' <|> not (char '\'')) <+< char '\'' 82 | 83 | let string = string_delimited 84 | let char = char_delimited 85 | end 86 | end 87 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/literal.mli: -------------------------------------------------------------------------------- 1 | module Literal : functor (P : Specs.PARSEC with type Source.e = char) -> sig 2 | val char : char -> char P.t 3 | val char_in_range : char * char -> char P.t 4 | val char_in_ranges : (char * char) list -> char P.t 5 | val char_in_list : char list -> char P.t 6 | val char_in_string : string -> char P.t 7 | val digit : char P.t 8 | val alpha : char P.t 9 | val natural : int P.t 10 | val integer : int P.t 11 | val string : string -> string P.t 12 | val string_in_list : string list -> string P.t 13 | val sequence : char P.t -> string P.t 14 | 15 | module Delimited : sig 16 | val string : string P.t 17 | val char : char P.t 18 | end 19 | end 20 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/localise.ml: -------------------------------------------------------------------------------- 1 | module Localise (Parsec : Specs.PARSEC) = struct 2 | let localise p s = 3 | let open Response.Destruct in 4 | let open Response.Construct in 5 | let open Ephel_parser_source.Region.Construct in 6 | let start = Parsec.Source.Access.location s in 7 | fold 8 | ~success:(fun (a, b, s) -> 9 | let finish = Parsec.Source.Access.location s in 10 | success ((a, create ~first:start ~last:finish), b, s) ) 11 | ~failure:(fun (a, b, s) -> failure (a, b, s)) 12 | (p s) 13 | end 14 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/localise.mli: -------------------------------------------------------------------------------- 1 | module Localise (P : Specs.PARSEC) : sig 2 | val localise : 'a P.t -> ('a * Ephel_parser_source.Region.t) P.t 3 | end 4 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/occurrence.ml: -------------------------------------------------------------------------------- 1 | module Occurrence (P : Specs.PARSEC) = struct 2 | module Monad = Control.Monad (P) 3 | module Eval = Eval.Eval (P) 4 | module Operator = Operator.Operator (P) 5 | 6 | let opt p s = 7 | let open Response.Destruct in 8 | let open Response.Construct in 9 | fold 10 | ~success:(fun (a, b, s) -> success (Some a, b, s)) 11 | ~failure:(fun (m, b, s) -> if b then failure (m, b, s) else success (None, b, s)) 12 | (p s) 13 | 14 | let sequence optional p s = 15 | (* sequence is tail recursive *) 16 | let open Response.Destruct in 17 | let open Response.Construct in 18 | let rec sequence s aux b = 19 | fold 20 | ~success:(fun (a, b', s') -> sequence s' (a :: aux) (b || b')) 21 | ~failure:(fun (m, b', s') -> 22 | if b' || (aux = [] && not optional) 23 | then failure (m, b || b', s') 24 | else success (List.rev aux, b || b', s) ) 25 | (p s) 26 | in 27 | sequence s [] false 28 | 29 | let rep p = sequence false p 30 | let opt_rep p = sequence true p 31 | end 32 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/occurrence.mli: -------------------------------------------------------------------------------- 1 | module Occurrence : functor (P : Specs.PARSEC) -> sig 2 | val opt : 'a P.t -> 'a option P.t 3 | val rep : 'a P.t -> 'a list P.t 4 | val opt_rep : 'a P.t -> 'a list P.t 5 | end 6 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/operator.ml: -------------------------------------------------------------------------------- 1 | module Operator (P : Specs.PARSEC) = struct 2 | module Functor = Control.Functor (P) 3 | module Eval = Eval.Eval (P) 4 | module Flow = Flow.Flow (P) 5 | 6 | let ( <+> ) p1 p2 = Flow.sequence p1 p2 7 | let ( <+< ) p1 p2 = Functor.(p1 <+> p2 <&> fst) 8 | let ( >+> ) p1 p2 = Functor.(p1 <+> p2 <&> snd) 9 | let ( ?= ) p = Flow.unify p 10 | let ( ) p f = Eval.satisfy p f 11 | let ( ?! ) p = Eval.do_try p 12 | let ( <||> ) p1 p2 = Flow.choice p1 p2 13 | let ( <|> ) p1 p2 = ?=(p1 <||> p2) 14 | let ( <|||> ) p1 p2 = Flow.eager_choice p1 p2 15 | end 16 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/operator.mli: -------------------------------------------------------------------------------- 1 | module Operator : functor (P : Specs.PARSEC) -> sig 2 | val ( <+> ) : 'a P.t -> 'b P.t -> ('a * 'b) P.t 3 | val ( <|> ) : 'a P.t -> 'a P.t -> 'a P.t 4 | val ( ) : 'a P.t -> ('a -> bool) -> 'a P.t 5 | val ( ?= ) : ('a, 'a) Either.t P.t -> 'a P.t 6 | val ( ?! ) : 'a P.t -> 'a P.t 7 | val ( <+< ) : 'a P.t -> 'b P.t -> 'a P.t 8 | val ( >+> ) : 'a P.t -> 'b P.t -> 'b P.t 9 | val ( <||> ) : 'a P.t -> 'b P.t -> ('a, 'b) Either.t P.t 10 | val ( <|||> ) : 'a P.t -> 'b P.t -> ('a, 'b) Either.t P.t 11 | end 12 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/parsers.ml: -------------------------------------------------------------------------------- 1 | module Parsec (Source : Ephel_parser_source.Specs.SOURCE) = struct 2 | module Source = Source 3 | 4 | type 'b t = Source.t -> ('b, Source.t) Response.t 5 | 6 | let source ?(file = None) c = Source.Construct.create ~file c 7 | end 8 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/parsers.mli: -------------------------------------------------------------------------------- 1 | module Parsec : functor (Source : Ephel_parser_source.Specs.SOURCE) -> 2 | Specs.PARSEC with module Source = Source 3 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/response.ml: -------------------------------------------------------------------------------- 1 | type ('a, 'b) t = (string option * bool * 'b, 'a * bool * 'b) Either.t 2 | 3 | module Construct = struct 4 | let success (a, c, b) = Either.Right (a, c, b) 5 | let failure (m, c, b) = Either.Left (m, c, b) 6 | end 7 | 8 | module Destruct = struct 9 | let fold ~success ~failure = function 10 | | Either.Right (a, c, b) -> success (a, c, b) 11 | | Either.Left (m, c, b) -> failure (m, c, b) 12 | 13 | let fold_opt = 14 | let none _ = None in 15 | fun ?(success = none) ?(failure = none) r -> fold ~success ~failure r 16 | end 17 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/response.mli: -------------------------------------------------------------------------------- 1 | type (_, _) t 2 | 3 | module Construct : sig 4 | val success : 'a * bool * 'b -> ('a, 'b) t 5 | val failure : string option * bool * 'b -> ('a, 'b) t 6 | end 7 | 8 | module Destruct : sig 9 | val fold : 10 | success:('a * bool * 'b -> 'c) -> failure:(string option * bool * 'b -> 'c) -> ('a, 'b) t -> 'c 11 | 12 | val fold_opt : 13 | ?success:('a * bool * 'b -> 'c option) 14 | -> ?failure:(string option * bool * 'b -> 'c option) 15 | -> ('a, 'b) t 16 | -> 'c option 17 | end 18 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/specs.mli: -------------------------------------------------------------------------------- 1 | module Parsec : sig 2 | module Source : Ephel_parser_source.Specs.SOURCE 3 | 4 | type 'a t = Source.t -> ('a, Source.t) Response.t 5 | 6 | val source : ?file:string option -> Source.Construct.c -> Source.t 7 | end 8 | 9 | module type PARSEC = module type of Parsec 10 | 11 | type ('a, 'b) parsec = (module PARSEC with type Source.t = 'a and type Source.e = 'b) 12 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/syntax.ml: -------------------------------------------------------------------------------- 1 | module Syntax (P : Specs.PARSEC) = struct 2 | module Operator = Operator.Operator (P) 3 | 4 | let ( and<+> ) a b = Operator.(a <+> b) 5 | end 6 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/2-parsec/syntax.mli: -------------------------------------------------------------------------------- 1 | module Syntax : functor (P : Specs.PARSEC) -> sig 2 | val ( and<+> ) : 'a P.t -> 'b P.t -> ('a * 'b) P.t 3 | end 4 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_parser) 3 | (public_name ephel.parser) 4 | (libraries ephel.parser.parsec ephel.parser.source) 5 | (modules_without_implementation ephel_parser)) 6 | -------------------------------------------------------------------------------- /stage/v0/lib/1-parser/ephel_parser.mli: -------------------------------------------------------------------------------- 1 | module Source = Ephel_parser_source 2 | module Parsec = Ephel_parser_parsec 3 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/01-utils/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_utils) 3 | (public_name ephel.compiler.utils)) 4 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/01-utils/render.ml: -------------------------------------------------------------------------------- 1 | let to_string r o = 2 | let buffer = Buffer.create 16 in 3 | let formatter = Format.formatter_of_buffer buffer in 4 | let () = r formatter o in 5 | let () = Format.pp_print_flush formatter () in 6 | Buffer.contents buffer 7 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/02-token/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_token) 3 | (public_name ephel.compiler.token) 4 | (libraries ephel.parser ephel.compiler.utils) 5 | (modules_without_implementation token ephel_compiler_token)) 6 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/02-token/ephel_compiler_token.mli: -------------------------------------------------------------------------------- 1 | module Token = Token 2 | module Render = Render 3 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/02-token/render.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_utils 2 | open Token 3 | 4 | let render ppf = 5 | let open Format in 6 | function 7 | | INL -> fprintf ppf "inl" 8 | | INR -> fprintf ppf "inr" 9 | | CASE -> fprintf ppf "case" 10 | | VAL -> fprintf ppf "val" 11 | | LET -> fprintf ppf "let" 12 | | IN -> fprintf ppf "in" 13 | | FST -> fprintf ppf "fst" 14 | | SND -> fprintf ppf "snd" 15 | | INT i -> fprintf ppf "%d" i 16 | | STRING s -> fprintf ppf "\"%s\"" s 17 | | IMPLY -> fprintf ppf "=>" 18 | | EQUAL -> fprintf ppf "=" 19 | | PRODUCT -> fprintf ppf "," 20 | | LPAR -> fprintf ppf "(" 21 | | RPAR -> fprintf ppf ")" 22 | | IDENT s -> fprintf ppf "%s" s 23 | 24 | let to_string o = Render.to_string render o 25 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/02-token/render.mli: -------------------------------------------------------------------------------- 1 | open Token 2 | 3 | val render : Format.formatter -> t -> unit 4 | val to_string : t -> string 5 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/02-token/token.mli: -------------------------------------------------------------------------------- 1 | open Ephel_parser_source 2 | 3 | type t = 4 | | INL 5 | | INR 6 | | CASE 7 | | VAL 8 | | LET 9 | | IN 10 | | FST 11 | | SND 12 | | INT of int 13 | | STRING of string 14 | | IMPLY 15 | | EQUAL 16 | | PRODUCT 17 | | LPAR 18 | | RPAR 19 | | IDENT of string 20 | 21 | type with_region = t * Region.t 22 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/03-tokenizer/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_tokenizer) 3 | (public_name ephel.compiler.tokenizer) 4 | (libraries preface ephel.parser ephel.compiler.utils ephel.compiler.token) 5 | (modules_without_implementation ephel_compiler_tokenizer)) 6 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/03-tokenizer/ephel_compiler_tokenizer.mli: -------------------------------------------------------------------------------- 1 | module Tokenizer = Tokenizer 2 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/03-tokenizer/tokenizer.ml: -------------------------------------------------------------------------------- 1 | module Tokens (Parsec : Ephel_parser_parsec.Specs.PARSEC with type Source.e = char) = struct 2 | open Ephel_parser_parsec.Core (Parsec) 3 | open Ephel_parser_parsec.Localise (Parsec) 4 | open Ephel_parser_parsec.Literal (Parsec) 5 | open Ephel_parser_source.Utils 6 | open Preface_core.Fun 7 | open Ephel_compiler_token.Token 8 | module StringMap = Map.Make (String) 9 | 10 | let keywords = 11 | StringMap.of_seq 12 | @@ List.to_seq 13 | [ 14 | ("inl", INL) 15 | ; ("inr", INR) 16 | ; ("case", CASE) 17 | ; ("fst", FST) 18 | ; ("snd", SND) 19 | ; ("val", VAL) 20 | ; ("let", LET) 21 | ; ("in", IN) 22 | ] 23 | 24 | let to_token s = match StringMap.find_opt s keywords with Some e -> e | None -> IDENT s 25 | 26 | (* skipped characters *) 27 | 28 | let spaces = opt_rep (char_in_string " \t\n\r") 29 | 30 | (* basic parsers *) 31 | 32 | let identifier = 33 | let operators = "^$+-*/%~@#&!-_?.:*¨°><=[]{}\\|" in 34 | let first_only = alpha <|> char_in_string operators in 35 | first_only <+> opt_rep (digit <|> first_only) <&> fun (c, l) -> string_of_chars (c :: l) 36 | 37 | (* tokens *) 38 | 39 | let _INTEGER_ = integer <&> fun s -> INT s 40 | let _STRING_ = Delimited.string <&> fun s -> STRING s 41 | let _IMPLY_ = string "=>" <&> const IMPLY 42 | let _EQUAL_ = char '=' <&> const EQUAL 43 | let _PRODUCT_ = char ',' <&> const PRODUCT 44 | let _LPAR_ = char '(' <&> const LPAR 45 | let _RPAR_ = char ')' <&> const RPAR 46 | let _IDENT_ = identifier <&> to_token 47 | 48 | (* Main entry *) 49 | 50 | let token = 51 | spaces 52 | >+> localise 53 | ( _INTEGER_ 54 | <|> _STRING_ 55 | <|> _IMPLY_ 56 | <|> _EQUAL_ 57 | <|> _PRODUCT_ 58 | <|> _LPAR_ 59 | <|> _RPAR_ 60 | <|> _IDENT_ ) 61 | <+< spaces 62 | end 63 | 64 | let tokenize (type a) 65 | (module P : Ephel_parser_parsec.Specs.PARSEC with type Source.t = a and type Source.e = char) = 66 | let module M = Tokens (P) in 67 | M.token 68 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/03-tokenizer/tokenizer.mli: -------------------------------------------------------------------------------- 1 | open Ephel_parser_parsec 2 | open Ephel_compiler_token 3 | 4 | module Tokens (Parsec : Specs.PARSEC with type Source.e = char) : sig 5 | val token : Token.with_region Parsec.t 6 | end 7 | 8 | val tokenize : 9 | 'a. 10 | (module Specs.PARSEC with type Source.t = 'a and type Source.e = char) 11 | -> 'a 12 | -> (Token.with_region, 'a) Response.t 13 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/04-cst/cst.ml: -------------------------------------------------------------------------------- 1 | open Ephel_parser_source 2 | 3 | type builtin = 4 | | Inl 5 | | Inr 6 | | Fst 7 | | Snd 8 | 9 | type literal = 10 | | Integer of int 11 | | String of string 12 | 13 | type t = 14 | | Unit of Region.t 15 | | Ident of string * Region.t 16 | | Literal of literal * Region.t 17 | | App of t * t * Region.t 18 | | Abs of string list * t * Region.t 19 | | Let of string * t * t * Region.t 20 | | Builtin of builtin * t * Region.t 21 | | Pair of t * t * Region.t 22 | | Case of string * t * t * Region.t 23 | 24 | let region = function 25 | | Unit r 26 | | Ident (_, r) 27 | | Literal (_, r) 28 | | App (_, _, r) 29 | | Abs (_, _, r) 30 | | Let (_, _, _, r) 31 | | Builtin (_, _, r) 32 | | Pair (_, _, r) 33 | | Case (_, _, _, r) -> 34 | r 35 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/04-cst/cst.mli: -------------------------------------------------------------------------------- 1 | open Ephel_parser_source 2 | 3 | type builtin = 4 | | Inl 5 | | Inr 6 | | Fst 7 | | Snd 8 | 9 | type literal = 10 | | Integer of int 11 | | String of string 12 | 13 | type t = 14 | | Unit of Region.t 15 | | Ident of string * Region.t 16 | | Literal of literal * Region.t 17 | | App of t * t * Region.t 18 | | Abs of string list * t * Region.t 19 | | Let of string * t * t * Region.t 20 | | Builtin of builtin * t * Region.t 21 | | Pair of t * t * Region.t 22 | | Case of string * t * t * Region.t 23 | 24 | val region : t -> Region.t 25 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/04-cst/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_cst) 3 | (public_name ephel.compiler.cst) 4 | (libraries ephel.parser ephel.compiler.utils) 5 | (modules_without_implementation ephel_compiler_cst)) 6 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/04-cst/ephel_compiler_cst.mli: -------------------------------------------------------------------------------- 1 | module Cst = Cst 2 | module Render = Render 3 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/04-cst/render.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_utils 2 | open Cst 3 | 4 | let rec render : Format.formatter -> t -> unit = 5 | fun ppf -> 6 | let open Format in 7 | function 8 | | Unit _ -> fprintf ppf "()" 9 | | Ident (s, _) -> fprintf ppf "%s" s 10 | | Literal (Integer i, _) -> fprintf ppf "%d" i 11 | | Literal (String s, _) -> fprintf ppf "%s" s 12 | | App (f, t, _) -> fprintf ppf "(%a %a)" render f render t 13 | | Abs (l, t, _) -> fprintf ppf "(%a=> %a)" render_arguments l render t 14 | | Let (s, t, b, _) -> fprintf ppf "let %s = %a in %a" s render t render b 15 | | Builtin (Inl, t, _) -> fprintf ppf "inl %a" render t 16 | | Builtin (Inr, t, _) -> fprintf ppf "inr %a" render t 17 | | Builtin (Fst, t, _) -> fprintf ppf "fst %a" render t 18 | | Builtin (Snd, t, _) -> fprintf ppf "snd %a" render t 19 | | Pair (l, r, _) -> fprintf ppf "(%a, %a)" render l render r 20 | | Case (s, l, r, _) -> fprintf ppf "case %s %a %a" s render l render r 21 | 22 | and render_arguments ppf = 23 | let open Format in 24 | function [] -> () | a :: l -> fprintf ppf "%s %a" a render_arguments l 25 | 26 | let to_string : t -> string = fun o -> Render.to_string render o 27 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/04-cst/render.mli: -------------------------------------------------------------------------------- 1 | open Cst 2 | 3 | val render : Format.formatter -> t -> unit 4 | val to_string : t -> string 5 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/05-analyzer/SYNTAX.md: -------------------------------------------------------------------------------- 1 | ```ebnf 2 | declaration ::= 3 | value 4 | 5 | value ::= 6 | 'val' id '=' term 7 | 8 | term ::= 9 | unit 10 | IDENT 11 | literal 12 | functional 13 | group 14 | product 15 | coproduct 16 | 17 | unit ::= 18 | '(' ')' 19 | 20 | literal ::= 21 | STRING | INTEGER 22 | 23 | functional ::= 24 | -- abstraction 25 | (ident)+ '=>' term 26 | -- application 27 | term term 28 | -- let binding 29 | 'let' ident = term 'in' term 30 | 31 | group ::= 32 | '(' term ')' 33 | 34 | product ::= 35 | term ',' term 36 | 'fst' term 37 | 'snd' term 38 | 39 | coproduct ::= 40 | 'case' term term term 41 | 'inl' term 42 | 'inr' term 43 | ``` -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/05-analyzer/analyser.mli: -------------------------------------------------------------------------------- 1 | open Ephel_parser_parsec 2 | open Ephel_compiler_token 3 | open Ephel_compiler_cst 4 | 5 | module Rules (Parsec : Specs.PARSEC with type Source.e = Token.with_region) : sig 6 | val term : Cst.t Parsec.t 7 | val declaration : (string * Cst.t) Parsec.t 8 | end 9 | 10 | val term : 11 | 'a. 12 | (module Specs.PARSEC with type Source.t = 'a and type Source.e = Token.with_region) 13 | -> 'a 14 | -> (Cst.t, 'a) Response.t 15 | 16 | val declaration : 17 | 'a. 18 | (module Specs.PARSEC with type Source.t = 'a and type Source.e = Token.with_region) 19 | -> 'a 20 | -> (string * Cst.t, 'a) Response.t 21 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/05-analyzer/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_analyzer) 3 | (public_name ephel.compiler.analyzer) 4 | (libraries 5 | preface 6 | ephel.parser 7 | ephel.compiler.utils 8 | ephel.compiler.token 9 | ephel.compiler.tokenizer 10 | ephel.compiler.cst) 11 | (modules_without_implementation ephel_compiler_analyzer)) 12 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/05-analyzer/ephel_compiler_analyzer.mli: -------------------------------------------------------------------------------- 1 | module Analyser = Analyser 2 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/06-ast/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_ast) 3 | (public_name ephel.compiler.ast) 4 | (libraries ephel.compiler.utils) 5 | (modules_without_implementation term)) 6 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/06-ast/free.ml: -------------------------------------------------------------------------------- 1 | open Term 2 | 3 | let rec free = 4 | let remove ln l = List.filter (fun v -> List.for_all (fun n -> n <> v) ln) l in 5 | function 6 | | Abs (ln, c) -> remove ln (free c) 7 | | App (l, r) -> free l @ free r 8 | | Var n -> [ n ] 9 | | Unit -> [] 10 | | Int _ -> [] 11 | | Inl c -> free c 12 | | Inr c -> free c 13 | | Case (c, l, r) -> free c @ free l @ free r 14 | | Pair (l, r) -> free l @ free r 15 | | Fst e -> free e 16 | | Snd e -> free e 17 | | Rec (ln, c) -> remove [ ln ] (free c) 18 | | Ffi _ -> [] 19 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/06-ast/free.mli: -------------------------------------------------------------------------------- 1 | open Term 2 | 3 | val free : 'a t -> string list 4 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/06-ast/normal.ml: -------------------------------------------------------------------------------- 1 | let rec normalise = 2 | let open Term in 3 | function 4 | | Abs (ln, Abs (lm, c)) -> normalise (Abs (ln @ lm, c)) 5 | | Abs (ln, c) -> Abs (ln, normalise c) 6 | | App (f, e) -> App (normalise f, normalise e) 7 | | Var n -> Var n 8 | | Unit -> Unit 9 | | Int i -> Int i 10 | | Inl e -> Inl (normalise e) 11 | | Inr e -> Inr (normalise e) 12 | | Case (c, l, r) -> Case (normalise c, normalise l, normalise r) 13 | | Pair (l, r) -> Pair (normalise l, normalise r) 14 | | Fst e -> Fst (normalise e) 15 | | Snd e -> Snd (normalise e) 16 | | Rec (n, c) -> Rec (n, normalise c) (* ? *) 17 | | Ffi (f, a) -> Ffi (f, a) 18 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/06-ast/normal.mli: -------------------------------------------------------------------------------- 1 | open Term 2 | 3 | val normalise : 'a t -> 'a t 4 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/06-ast/render.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_utils 2 | open Term 3 | 4 | let rec render : type a. Format.formatter -> a t -> unit = 5 | fun ppf -> 6 | let open Format in 7 | function 8 | | Abs (ln, c) -> fprintf ppf "%a => %a" render_arguments ln render c 9 | | App (l, r) -> fprintf ppf "%a (%a)" render l render r 10 | | Var n -> fprintf ppf "%s" n 11 | | Unit -> fprintf ppf "()" 12 | | Int i -> fprintf ppf "%d" i 13 | | Inl c -> fprintf ppf "inl (%a)" render c 14 | | Inr c -> fprintf ppf "inr (%a)" render c 15 | | Case (c, l, r) -> fprintf ppf "case (%a) (%a) (%a)" render c render l render r 16 | | Pair (l, r) -> fprintf ppf "(%a, %a)" render l render r 17 | | Fst e -> fprintf ppf "fst (%a)" render e 18 | | Snd e -> fprintf ppf "snd (%a)" render e 19 | | Rec (n, c) -> fprintf ppf "rec(%s).(%a)" n render c 20 | | Ffi (f, a) -> fprintf ppf "native %s %i" f a 21 | 22 | and render_arguments ppf = 23 | let open Format in 24 | function [] -> () | a :: l -> fprintf ppf "%s %a" a render_arguments l 25 | 26 | let to_string o = Render.to_string render o 27 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/06-ast/render.mli: -------------------------------------------------------------------------------- 1 | open Term 2 | 3 | val render : Format.formatter -> 'a t -> unit 4 | val to_string : 'a t -> string 5 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/06-ast/term.mli: -------------------------------------------------------------------------------- 1 | type _ t = 2 | | Unit : 'a t 3 | | Int : int -> 'a t 4 | (* Function *) 5 | | Abs : string list * 'a t -> 'a t 6 | | App : 'a t * 'a t -> 'a t 7 | | Var : string -> 'a t 8 | (* Sum *) 9 | | Inl : 'a t -> 'a t 10 | | Inr : 'a t -> 'a t 11 | | Case : 'a t * 'a t * 'a t -> 'a t 12 | (* Product *) 13 | | Pair : 'a t * 'a t -> 'a t 14 | | Fst : 'a t -> 'a t 15 | | Snd : 'a t -> 'a t 16 | (* Extension *) 17 | | Rec : string * 'a t -> 'a t 18 | (* FFI *) 19 | | Ffi : string * int -> 'a t 20 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/07-objcode/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_objcode) 3 | (public_name ephel.Compiler.Objcode) 4 | (libraries ephel.compiler.utils) 5 | (modules_without_implementation objcode)) 6 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/07-objcode/objcode.mli: -------------------------------------------------------------------------------- 1 | type value = 2 | | INT of int 3 | | UNIT 4 | 5 | type t = 6 | (* Lambda operation and terms "à la Michelson" *) 7 | | APPLY 8 | | EXEC 9 | | LAMBDA of string list * t list 10 | | LAMBDA_REC of string * string list * t list 11 | (* Sum operations *) 12 | | LEFT 13 | | RIGHT 14 | | CASE of t list * t list 15 | (* Product operations *) 16 | | PAIR 17 | | FST 18 | | SND 19 | | UNPAIR 20 | (* Basic stack operation *) 21 | | PUSH of value 22 | | DIG of int * string 23 | | DUP of int * string 24 | | DROP of int * string 25 | | SWAP 26 | (* Foreign Function Interface *) 27 | | FFI of string * int 28 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/07-objcode/render.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_utils 2 | open Objcode 3 | 4 | let render_value ppf = 5 | let open Format in 6 | function INT i -> fprintf ppf "INT %d" i | UNIT -> fprintf ppf "UNIT" 7 | 8 | let rec render ppf = 9 | let open Format in 10 | function [] -> () | [ a ] -> render_t ppf a | a :: l -> fprintf ppf "%a; %a" render_t a render l 11 | 12 | and render_string ppf s = 13 | let open Format in 14 | fprintf ppf {|"%s"|} s 15 | 16 | and render_t ppf = 17 | let open Format in 18 | function 19 | | PUSH v -> fprintf ppf "PUSH (%a)" render_value v 20 | | APPLY -> fprintf ppf "APPLY" 21 | | EXEC -> fprintf ppf "EXEC" 22 | | LAMBDA (ln, l) -> fprintf ppf "LAMBDA([ %a ], [ %a ])" render_arguments ln render l 23 | | DIG (i, n) -> fprintf ppf "DIG (%d, %a)" i render_string n 24 | | DUP (i, n) -> fprintf ppf "DUP (%d, %a)" i render_string n 25 | | DROP (i, n) -> fprintf ppf "DROP (%d, %a)" i render_string n 26 | | SWAP -> fprintf ppf "SWAP" 27 | | LEFT -> fprintf ppf "LEFT" 28 | | RIGHT -> fprintf ppf "RIGHT" 29 | | CASE (l, r) -> fprintf ppf "CASE ([ %a ], [ %a ])" render l render r 30 | | PAIR -> fprintf ppf "PAIR" 31 | | FST -> fprintf ppf "FST" 32 | | SND -> fprintf ppf "SND" 33 | | UNPAIR -> fprintf ppf "UNPAIR" 34 | | LAMBDA_REC (f, ln, l) -> 35 | fprintf ppf "LAMBDA_REC(%a, [ %a ], [ %a ])" render_string f render_arguments ln render l 36 | | FFI (f, a) -> fprintf ppf "FFI(%a, %d)" render_string f a 37 | 38 | and render_arguments ppf = 39 | let open Format in 40 | function [] -> () | a :: l -> fprintf ppf "%a; %a" render_string a render_arguments l 41 | 42 | let to_string o = Render.to_string render o 43 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/07-objcode/render.mli: -------------------------------------------------------------------------------- 1 | open Objcode 2 | 3 | val render_value : Format.formatter -> value -> unit 4 | val render : Format.formatter -> t list -> unit 5 | val to_string : t list -> string 6 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/08-lifting/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_lifting) 3 | (public_name ephel.compiler.lifting) 4 | (libraries preface ephel.compiler.ast ephel.Compiler.Objcode)) 5 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/08-lifting/lifting.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_ast 2 | 3 | let rec lift = 4 | let open Term in 5 | let open Free in 6 | function 7 | | Abs (ln, c) -> 8 | let vars = free (Abs (ln, c)) in 9 | List.fold_right (fun v t -> App (t, Var v)) vars (Abs (vars @ ln, c)) 10 | | App (f, e) -> App (lift f, lift e) 11 | | Var n -> Var n 12 | | Unit -> Unit 13 | | Int i -> Int i 14 | | Inl e -> Inl (lift e) 15 | | Inr e -> Inr (lift e) 16 | | Case (c, l, r) -> Case (lift c, lift l, lift r) 17 | | Pair (l, r) -> Pair (lift l, lift r) 18 | | Fst e -> Fst (lift e) 19 | | Snd e -> Snd (lift e) 20 | | Rec (n, c) -> Rec (n, lift c) 21 | | Ffi (f, a) -> Ffi (f, a) 22 | 23 | let run e = lift e 24 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/08-lifting/lifting.mli: -------------------------------------------------------------------------------- 1 | val run : 'a Ephel_compiler_ast.Term.t -> 'a Ephel_compiler_ast.Term.t 2 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/09-transpiler/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_transpiler) 3 | (public_name ephel.compiler.transpiler) 4 | (libraries preface ephel.compiler.ast ephel.Compiler.Objcode)) 5 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/09-transpiler/stack.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | VAL of string 3 | | VAR of string 4 | 5 | let fold ~value ~variable = function VAL s -> value s | VAR s -> variable s 6 | 7 | let rec remove n s = 8 | if n = 0 9 | then Ok s 10 | else match s with [] -> Error "Cannot remove from an empty stack" | _ :: s -> remove (n - 1) s 11 | 12 | let rec render_stack ppf = 13 | let open Format in 14 | function 15 | | [] -> fprintf ppf "" 16 | | VAL s :: l -> fprintf ppf "VAL(%s), %a" s render_stack l 17 | | VAR n :: l -> fprintf ppf "VAR(%s), %a" n render_stack l 18 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/09-transpiler/stack.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | | VAL of string 3 | | VAR of string 4 | 5 | val fold : value:(string -> 'b) -> variable:(string -> 'b) -> t -> 'b 6 | val remove : int -> t list -> (t list, string) result 7 | val render_stack : Format.formatter -> t list -> unit 8 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/09-transpiler/transpiler.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_objcode 2 | open Ephel_compiler_ast 3 | 4 | module Monad = Preface.Result.Monad (struct 5 | type t = string 6 | end) 7 | 8 | let consume n s = 9 | let rec consume i s = 10 | let open Monad in 11 | let open Objcode in 12 | let open Stack in 13 | match s with 14 | | [] -> Error ("Transpilation error: " ^ n ^ " not found!") 15 | | VAR m :: s' when n = m -> Ok ([ DUP (i, n) ], VAR m :: s') 16 | | v :: s -> 17 | let+ o, s = consume (i + 1) s in 18 | (o, v :: s) 19 | in 20 | consume 0 s 21 | 22 | let garbage n s = 23 | let rec garbage i s = 24 | let open Monad in 25 | let open Objcode in 26 | let open Stack in 27 | match s with 28 | | [] -> Error ("Transpilation Error: " ^ n ^ " not found!") 29 | | VAR m :: s when n = m -> Ok (DROP (i, n), s) 30 | | v :: s -> 31 | let+ o, s = garbage (i + 1) s in 32 | (o, v :: s) 33 | in 34 | garbage 0 s 35 | 36 | let rec compile_binding : 37 | type a. string -> a Term.t -> Stack.t list -> (Objcode.t list * Stack.t list, string) result = 38 | fun n e s -> 39 | let open Monad in 40 | let open Stack in 41 | let* o, s' = compile e (VAR n :: s) in 42 | let+ g_o, s' = garbage n s' in 43 | (o @ [ g_o ], s') 44 | 45 | and compile : type a. a Term.t -> Stack.t list -> (Objcode.t list * Stack.t list, string) result = 46 | fun e s -> 47 | let open Monad in 48 | let open Term in 49 | let open Objcode in 50 | let open Stack in 51 | match e with 52 | (* Atoms *) 53 | | Unit -> Ok ([ PUSH UNIT ], VAL "unit" :: s) 54 | | Int i -> Ok ([ PUSH (INT i) ], VAL "int" :: s) 55 | | Var n -> 56 | let+ o, s = consume n s in 57 | (o, VAL n :: s) 58 | (* Sum *) 59 | | Inl e -> 60 | let* o, s = compile e s in 61 | let+ s = remove 1 s in 62 | (o @ [ LEFT ], VAL "left" :: s) 63 | | Inr e -> 64 | let* o, s = compile e s in 65 | let+ s = remove 1 s in 66 | (o @ [ RIGHT ], VAL "right" :: s) 67 | | Case (e, Abs ([ n ], l), Abs ([ m ], r)) -> 68 | (* TODO(didier) *) 69 | let* e_o, s = compile e s in 70 | let* s = remove 1 s in 71 | let* l_o, _ = compile_binding n l s in 72 | let+ r_o, _ = compile_binding m r s in 73 | (e_o @ [ CASE (l_o, r_o) ], VAL "case" :: s) 74 | (* Product *) 75 | | Pair (l, r) -> 76 | let* r_o, _ = compile r s in 77 | let+ l_o, _ = compile l (VAL "cdr" :: s) in 78 | (r_o @ l_o @ [ PAIR ], VAL "pair" :: s) 79 | | Fst o -> 80 | let* l_o, s = compile o s in 81 | let+ s = remove 1 s in 82 | (l_o @ [ FST ], VAL "fst" :: s) 83 | | Snd o -> 84 | let* l_o, s = compile o s in 85 | let+ s = remove 1 s in 86 | (l_o @ [ SND ], VAL "snd" :: s) 87 | (* Abstraction and Application *) 88 | | Abs ([ n ], e) -> 89 | (* TODO(didier) *) 90 | let+ o, _ = compile_binding n e [] in 91 | ([ LAMBDA ([ n ], o) ], VAL "lambda" :: s) 92 | (* 93 | | Let (n, e, f) -> 94 | let* e_o, s = compile e s in 95 | let* s' = remove 1 s in 96 | let+ l_o, s = compile_binding n f s' in 97 | (e_o @ l_o, s) 98 | *) 99 | | App (l, r) -> 100 | (* TODO: Track partial applications *) 101 | let* o_l, s = compile l s in 102 | let* o_r, s = compile r s in 103 | let+ s = remove 2 s in 104 | (o_l @ o_r @ [ EXEC ], VAL "app" :: s) 105 | | Rec (f, Abs ([ n ], e)) -> 106 | (* TODO(didier) *) 107 | let* o, s = compile_binding n e [ VAR f ] in 108 | let+ g, _ = garbage f s in 109 | ([ LAMBDA_REC (f, [ n ], o @ [ g ]) ], VAL "lambda-rec" :: s) 110 | | Ffi (f, a) -> 111 | let+ s = remove a s in 112 | ([ FFI (f, a) ], VAR "ffi" :: s) 113 | | _ -> Error ("Cannot compile expression: " ^ Render.to_string e) 114 | 115 | let run : type a. a Term.t -> (Objcode.t list, string) result = 116 | fun e -> 117 | let open Monad in 118 | compile e [] <&> fst 119 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/09-transpiler/transpiler.mli: -------------------------------------------------------------------------------- 1 | val run : 'a Ephel_compiler_ast.Term.t -> (Ephel_compiler_objcode.Objcode.t list, string) result 2 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/10_expander/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_expander) 3 | (public_name ephel.compiler.expander) 4 | (libraries preface ephel.Compiler.Objcode)) 5 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/10_expander/expander.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_objcode 2 | 3 | let rec expand_sequence = 4 | let open Objcode in 5 | function 6 | | CASE (l, r) :: s when List.length s > 0 -> [ CASE (l @ s, r @ s) ] 7 | | a :: l -> expand_instruction a :: expand_sequence l 8 | | [] -> [] 9 | 10 | and expand_instruction = 11 | let open Objcode in 12 | function 13 | | LAMBDA (n, l) -> LAMBDA (n, expand_sequence l) 14 | | LAMBDA_REC (f, n, l) -> LAMBDA_REC (f, n, expand_sequence l) 15 | | CASE (l, r) -> CASE (expand_sequence l, expand_sequence r) 16 | | o -> o 17 | 18 | let rec expand o = 19 | let o' = expand_sequence o in 20 | if o' = o then o' else expand o' 21 | 22 | let run o = expand o 23 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/10_expander/expander.mli: -------------------------------------------------------------------------------- 1 | val run : Ephel_compiler_objcode.Objcode.t list -> Ephel_compiler_objcode.Objcode.t list 2 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/11_optimiser/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_optimiser) 3 | (public_name ephel.compiler.optimiser) 4 | (libraries preface ephel.Compiler.Objcode)) 5 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/11_optimiser/objvalue.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_objcode 2 | 3 | type t = 4 | | Var of string 5 | | Dup of string 6 | | Val of Objcode.value 7 | | Code of string list * Objcode.t list 8 | | RecCode of string * string list * Objcode.t list 9 | | Exec of t * t 10 | | Left of t 11 | | Right of t 12 | | Pair of t * t 13 | | Car of t 14 | | Cdr of t 15 | | IfLeft of t * Objcode.t list * Objcode.t list 16 | 17 | let rec render_value ppf = 18 | let open Format in 19 | function 20 | | Var n -> fprintf ppf "%s" n 21 | | Dup n -> fprintf ppf "copy(%s)" n 22 | | Val v -> Render.render_value ppf v 23 | | Code (ln, c) -> fprintf ppf "Lambda([ %a ],%a)" render_arguments ln Render.render c 24 | | RecCode (f, ln, c) -> fprintf ppf "Rec(%s,[ %a ],%a)" f render_arguments ln Render.render c 25 | | Exec (a, b) -> fprintf ppf "Exec(%a,%a)" render_value a render_value b 26 | | Car a -> fprintf ppf "Car(%a)" render_value a 27 | | Cdr a -> fprintf ppf "Cdr(%a)" render_value a 28 | | Pair (a, b) -> fprintf ppf "Pair(%a,%a)" render_value a render_value b 29 | | Left a -> fprintf ppf "Left(%a)" render_value a 30 | | Right a -> fprintf ppf "Right(%a)" render_value a 31 | | IfLeft (a, l, r) -> 32 | fprintf ppf "IfLeft(%a,%a,%a)" render_value a Render.render l Render.render r 33 | 34 | and render_arguments ppf = 35 | let open Format in 36 | function [] -> () | a :: l -> fprintf ppf "%s %a" a render_arguments l 37 | 38 | let rec render_values ppf = 39 | let open Format in 40 | function [] -> () | a :: s -> fprintf ppf "%a; %a" render_value a render_values s 41 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/11_optimiser/optimiser.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_objcode 2 | open Objvalue 3 | 4 | module Monad = Preface.Result.Monad (struct 5 | type t = string 6 | end) 7 | 8 | let rec get_index i n = function 9 | | Var m :: _ when n = m -> Ok i 10 | | _ :: s -> get_index (i + 1) n s 11 | | [] -> Error ("Variable not found: " ^ n) 12 | 13 | let generate (o, s) = 14 | let open Monad in 15 | let open Objcode in 16 | let push_in r a = a :: r in 17 | let rec generate s r = 18 | match s with 19 | | [] -> Ok r 20 | | [ Var _ ] -> Ok r 21 | | Var f :: a :: s -> SWAP |> push_in r |> generate (a :: Var f :: s) 22 | | Dup n :: s -> get_index 0 n s <&> (fun i -> DUP (i, n)) <&> push_in r >>= generate s 23 | | Val a :: s -> PUSH a |> push_in r |> generate s 24 | | Code (ln, a) :: s -> LAMBDA (ln, a) |> push_in r |> generate s 25 | | RecCode (f, ln, a) :: s -> LAMBDA_REC (f, ln, a) |> push_in r |> generate s 26 | | Exec (a, c) :: s -> EXEC |> push_in r |> generate (c :: a :: s) 27 | | Car a :: s -> FST |> push_in r |> generate (a :: s) 28 | | Cdr a :: s -> SND |> push_in r |> generate (a :: s) 29 | | Pair (pl, pr) :: s -> PAIR |> push_in r |> generate (pl :: pr :: s) 30 | | Left a :: s -> LEFT |> push_in r |> generate (a :: s) 31 | | Right a :: s -> RIGHT |> push_in r |> generate (a :: s) 32 | | IfLeft (a, pl, pr) :: s -> CASE (pl, pr) |> push_in r |> generate (a :: s) 33 | in 34 | generate s o 35 | 36 | let rec remove_at l i = 37 | if i = 0 38 | then (List.hd l, List.tl l) 39 | else 40 | let h, t = remove_at (List.tl l) (i - 1) in 41 | (h, List.hd l :: t) 42 | 43 | let rec optimise_instruction s = 44 | let open Monad in 45 | let open Objcode in 46 | function 47 | | PUSH v -> Ok ([], Val v :: s) 48 | | EXEC -> ( 49 | match s with 50 | | a :: Code (_, c) :: s -> optimise (a :: s) c 51 | | a :: c :: s -> Ok ([], Exec (c, a) :: s) 52 | | _ -> Ok ([ EXEC ], s) ) 53 | | LAMBDA (ln, a) -> 54 | let+ o = optimise (List.map (fun n -> Var n) ln) a >>= generate in 55 | ([], Code (ln, o) :: s) 56 | | LAMBDA_REC (f, ln, a) -> 57 | (* TODO *) 58 | let+ o = optimise [] a >>= generate in 59 | ([ LAMBDA_REC (f, ln, o) ], s) 60 | | DIG (i, n) -> Ok ([ DIG (i, n) ], s) 61 | | DUP (i, n) -> 62 | Ok 63 | ( match List.nth_opt s i with 64 | | None -> ([ DUP (i, n) ], s) 65 | | Some (Var f) -> ([], Dup f :: s) 66 | | Some a -> ([], a :: s) ) 67 | | DROP (i, n) -> 68 | Ok 69 | ( if List.length s <= i 70 | then ([ DROP (i, n) ], s) 71 | else 72 | (* Dropped effects should be prohibited *) 73 | match remove_at s i with Var _, _ -> ([ DROP (i, n) ], s) | _, s -> ([], s) ) 74 | | SWAP -> Ok (match s with a :: b :: s -> ([], b :: a :: s) | _ -> ([ SWAP ], s)) 75 | | LEFT -> Ok (match s with a :: s -> ([], Left a :: s) | [] -> ([ LEFT ], s)) 76 | | RIGHT -> Ok (match s with a :: s -> ([], Right a :: s) | [] -> ([ RIGHT ], s)) 77 | | CASE (l, r) -> ( 78 | match s with 79 | | Left v :: s -> optimise (v :: s) l 80 | | Right v :: s -> optimise (v :: s) r 81 | | _ -> 82 | (* Not optimal code right now! *) 83 | let* l = optimise [] l >>= generate in 84 | let+ r = optimise [] r >>= generate in 85 | if List.length s = 0 then ([ CASE (l, r) ], s) else ([], IfLeft (List.hd s, l, r) :: List.tl s) 86 | ) 87 | | FST -> 88 | Ok 89 | ( match s with 90 | | Pair (a, _) :: s -> ([], a :: s) 91 | | a :: s -> ([], Car a :: s) 92 | | [] -> ([ FST ], s) ) 93 | | SND -> 94 | Ok 95 | ( match s with 96 | | Pair (_, a) :: s -> ([], a :: s) 97 | | a :: s -> ([], Cdr a :: s) 98 | | [] -> ([ SND ], s) ) 99 | | PAIR -> Ok (match s with a :: b :: s -> ([], Pair (a, b) :: s) | _ -> ([ PAIR ], s)) 100 | | a -> Ok ([ a ], s) 101 | 102 | and optimise s = 103 | let open Monad in 104 | function 105 | | [] -> Ok ([], s) 106 | | a :: l -> 107 | let* o, s = optimise_instruction s a in 108 | (* review this part *) 109 | if o = [] then optimise s l else optimise [] l >>= generate <&> fun l -> (o @ l, s) 110 | 111 | let optimise o = 112 | let open Monad in 113 | optimise [] o >>= generate 114 | 115 | let run o = optimise o 116 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/11_optimiser/optimiser.mli: -------------------------------------------------------------------------------- 1 | val run : 2 | Ephel_compiler_objcode.Objcode.t list -> (Ephel_compiler_objcode.Objcode.t list, string) result 3 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/12_normaliser/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_normaliser) 3 | (public_name ephel.compiler.normaliser) 4 | (libraries preface ephel.Compiler.Objcode)) 5 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/12_normaliser/normaliser.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_objcode 2 | 3 | let rec last = 4 | let open Preface.Option.Functor.Infix in 5 | function [] -> None | [ a ] -> Some (a, []) | a :: l -> last l <&> fun (b, l) -> (b, a :: l) 6 | 7 | let rec normalise_sequence = 8 | let open Objcode in 9 | function 10 | | CASE (l, r) :: s -> ( 11 | match (last l, last r) with 12 | | Some (a, l), Some (a', r) when a = a' -> CASE (l, r) :: a :: s 13 | | _, _ -> normalise_instruction (CASE (l, r)) :: normalise_sequence s ) 14 | | a :: s -> normalise_instruction a :: normalise_sequence s 15 | | [] -> [] 16 | 17 | and normalise_instruction = 18 | let open Objcode in 19 | function 20 | | LAMBDA (n, l) -> LAMBDA (n, normalise_sequence l) 21 | | LAMBDA_REC (f, n, l) -> LAMBDA_REC (f, n, normalise_sequence l) 22 | | CASE (l, r) -> CASE (normalise_sequence l, normalise_sequence r) 23 | | o -> o 24 | 25 | let rec normalise o = 26 | let o' = normalise_sequence o in 27 | if o' = o then o' else normalise o' 28 | 29 | let run o = normalise o 30 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/12_normaliser/normaliser.mli: -------------------------------------------------------------------------------- 1 | val run : Ephel_compiler_objcode.Objcode.t list -> Ephel_compiler_objcode.Objcode.t list 2 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/13_simplifier/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler_simplifier) 3 | (public_name ephel.compiler.simplifier) 4 | (libraries ephel.Compiler.Objcode)) 5 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/13_simplifier/simplifier.ml: -------------------------------------------------------------------------------- 1 | open Ephel_compiler_objcode 2 | 3 | let rec simplify_sequence = 4 | let open Objcode in 5 | function 6 | | DIG (0, _) :: l -> l 7 | | DIG (1, _) :: l -> SWAP :: l 8 | | SWAP :: DROP (i, n) :: l when i > 1 -> DROP (i, n) :: SWAP :: l 9 | | EXEC :: DROP (i, n) :: l when i > 0 -> DROP (i + 1, n) :: EXEC :: l 10 | | PUSH a :: DROP (i, n) :: l when i > 0 -> DROP (i - 1, n) :: PUSH a :: l 11 | | ((FST | SND | LEFT | RIGHT) as a) :: DROP (i, n) :: l when i > 0 -> DROP (i, n) :: a :: l 12 | | DUP (i, n) :: DROP (j, _) :: l when j = i + 1 -> DIG (i, n) :: l 13 | | DUP (i, m) :: DROP (j, n) :: l when j > i -> DROP (j - 1, n) :: DUP (i, m) :: l 14 | | DUP (i, m) :: DROP (j, n) :: l when j > 0 -> DROP (j - 1, n) :: DUP (i - 1, m) :: l 15 | | DIG (i, m) :: DROP (j, n) :: l when j > 0 -> 16 | if j > i then DROP (j - 1, n) :: DIG (i, m) :: l else DROP (j - 1, n) :: DIG (i - 1, m) :: l 17 | | DUP (0, _) :: FST :: SWAP :: SND :: l -> UNPAIR :: SWAP :: l 18 | | DUP (0, _) :: SND :: SWAP :: FST :: l -> UNPAIR :: l 19 | | DUP (0, n) :: SND :: DUP (1, _) :: FST :: PAIR :: l -> DUP (0, n) :: l 20 | | SWAP :: SWAP :: l -> l 21 | | a :: s -> simplify_instruction a :: simplify_sequence s 22 | | [] -> [] 23 | 24 | and simplify_instruction = 25 | let open Objcode in 26 | function 27 | | LAMBDA (n, l) -> LAMBDA (n, simplify_sequence l) 28 | | LAMBDA_REC (f, n, l) -> LAMBDA_REC (f, n, simplify_sequence l) 29 | | CASE (l, r) -> CASE (simplify_sequence l, simplify_sequence r) 30 | | o -> o 31 | 32 | let rec simplify o = 33 | let o' = simplify_sequence o in 34 | if o' = o then o' else simplify o' 35 | 36 | let run o = simplify o 37 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/13_simplifier/simplifier.mli: -------------------------------------------------------------------------------- 1 | val run : Ephel_compiler_objcode.Objcode.t list -> Ephel_compiler_objcode.Objcode.t list 2 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel_compiler) 3 | (public_name ephel.compiler) 4 | (libraries 5 | ephel.compiler.tokenizer 6 | ephel.compiler.analyzer 7 | ephel.compiler.ast 8 | ephel.Compiler.Objcode 9 | ephel.compiler.lifting 10 | ephel.compiler.transpiler 11 | ephel.compiler.expander 12 | ephel.compiler.optimiser 13 | ephel.compiler.simplifier 14 | ephel.compiler.normaliser) 15 | (modules_without_implementation ephel_compiler)) 16 | -------------------------------------------------------------------------------- /stage/v0/lib/2-compiler/ephel_compiler.mli: -------------------------------------------------------------------------------- 1 | module Token = Ephel_compiler_token 2 | module Tokenizer = Ephel_compiler_tokenizer 3 | module Cst = Ephel_compiler_cst 4 | module Analyzer = Ephel_compiler_analyzer 5 | module Ast = Ephel_compiler_ast 6 | module Objcode = Ephel_compiler_objcode 7 | module Transpiler = Ephel_compiler_transpiler 8 | module Expander = Ephel_compiler_expander 9 | module Optimiser = Ephel_compiler_optimiser 10 | module Simplifier = Ephel_compiler_simplifier 11 | module Normaliser = Ephel_compiler_normaliser 12 | -------------------------------------------------------------------------------- /stage/v0/lib/3-runtime/dune: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ephel-lang/ephel/d6524ba398b4d8e3bde680c016db08b32387c2dd/stage/v0/lib/3-runtime/dune -------------------------------------------------------------------------------- /stage/v0/lib/3-runtime/ephel_runtime.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ephel-lang/ephel/d6524ba398b4d8e3bde680c016db08b32387c2dd/stage/v0/lib/3-runtime/ephel_runtime.mli -------------------------------------------------------------------------------- /stage/v0/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ephel) 3 | (public_name ephel) 4 | (libraries ephel.parser ephel.compiler) 5 | (modules_without_implementation ephel)) 6 | -------------------------------------------------------------------------------- /stage/v0/lib/ephel.mli: -------------------------------------------------------------------------------- 1 | module Parser = Ephel_parser 2 | module Compiler = Ephel_compiler 3 | (* module Runtime = Ephel_runtime *) 4 | -------------------------------------------------------------------------------- /stage/v0/test/1-parser/common.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Parser.Source 2 | open Ephel.Parser.Parsec 3 | 4 | let response r = 5 | let open Response.Destruct in 6 | fold ~success:(fun (a, b, _) -> (Some a, b)) ~failure:(fun (_, b, _) -> (None, b)) r 7 | 8 | module Parsec = Parsec (FromChars) 9 | -------------------------------------------------------------------------------- /stage/v0/test/1-parser/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t00_parser_tests) 3 | (libraries alcotest ephel)) 4 | -------------------------------------------------------------------------------- /stage/v0/test/1-parser/t00_parser_tests.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.( 3 | run "Parser Test" 4 | [ 5 | T01_eval.cases 6 | ; T02_operator.cases 7 | ; T03_atomic.cases 8 | ; T04_occurrence.cases 9 | ; T05_literal.cases 10 | ; T06_syntax.cases 11 | ; T07_extra.cases 12 | ; T08_examples.cases 13 | ; T99_laws.cases 14 | ] ) 15 | -------------------------------------------------------------------------------- /stage/v0/test/1-parser/t01_eval.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Parser.Parsec 2 | open Common 3 | 4 | let parser_eos () = 5 | let open Eval (Parsec) in 6 | let result = response @@ eos @@ Parsec.source [] 7 | and expected = (Some (), false) in 8 | Alcotest.(check (pair (option unit) bool)) "eos" expected result 9 | 10 | let parser_eos_fail () = 11 | let open Eval (Parsec) in 12 | let result = response @@ eos @@ Parsec.source [ 'a' ] 13 | and expected = (None, false) in 14 | Alcotest.(check (pair (option unit) bool)) "eos fail" expected result 15 | 16 | let parser_return () = 17 | let open Eval (Parsec) in 18 | let result = response @@ return 'a' @@ Parsec.source [] 19 | and expected = (Some 'a', false) in 20 | Alcotest.(check (pair (option char) bool)) "return" expected result 21 | 22 | let parser_fail () = 23 | let open Eval (Parsec) in 24 | let result = response @@ fail @@ Parsec.source [] 25 | and expected = (None, false) in 26 | Alcotest.(check (pair (option char) bool)) "fail" expected result 27 | 28 | let parser_fail_consumed () = 29 | let open Eval (Parsec) in 30 | let result = response @@ fail ~consumed:true @@ Parsec.source [] 31 | and expected = (None, true) in 32 | Alcotest.(check (pair (option char) bool)) "fail consumed" expected result 33 | 34 | let parser_do_lazy () = 35 | let open Eval (Parsec) in 36 | let result = response @@ do_lazy (lazy (return 'a')) @@ Parsec.source [] 37 | and expected = (Some 'a', false) in 38 | Alcotest.(check (pair (option char) bool)) "do_lazy" expected result 39 | 40 | let parser_do_try () = 41 | let open Eval (Parsec) in 42 | let result = response @@ do_try (fail ~consumed:true) @@ Parsec.source [] 43 | and expected = (None, false) in 44 | Alcotest.(check (pair (option char) bool)) "do_try" expected result 45 | 46 | let parser_lookahead () = 47 | let open Eval (Parsec) in 48 | let result = response @@ lookahead (fail ~consumed:true) @@ Parsec.source [] 49 | and expected = (None, false) in 50 | Alcotest.(check (pair (option char) bool)) "lookahead" expected result 51 | 52 | let parser_satisfy_true () = 53 | let open Eval (Parsec) in 54 | let result = response @@ satisfy (return 1) (( = ) 1) @@ Parsec.source [] 55 | and expected = (Some 1, false) in 56 | Alcotest.(check (pair (option int) bool)) "satisfy" expected result 57 | 58 | let parser_satisfy_false () = 59 | let open Eval (Parsec) in 60 | let result = response @@ satisfy (return 1) (( = ) 2) @@ Parsec.source [] 61 | and expected = (None, false) in 62 | Alcotest.(check (pair (option int) bool)) "satisfy false" expected result 63 | 64 | let parser_satisfy_fail () = 65 | let open Eval (Parsec) in 66 | let result = response @@ satisfy (fail ~consumed:true) (( = ) 2) @@ Parsec.source [] 67 | and expected = (None, true) in 68 | Alcotest.(check (pair (option int) bool)) "satisfy fail" expected result 69 | 70 | let cases = 71 | let open Alcotest in 72 | ( "Basic Parser" 73 | , [ 74 | test_case "eos" `Quick parser_eos 75 | ; test_case "eos fail" `Quick parser_eos_fail 76 | ; test_case "return" `Quick parser_return 77 | ; test_case "fail" `Quick parser_fail 78 | ; test_case "fail consumed" `Quick parser_fail_consumed 79 | ; test_case "do_lazy" `Quick parser_do_lazy 80 | ; test_case "do_try" `Quick parser_do_try 81 | ; test_case "lookahead" `Quick parser_lookahead 82 | ; test_case "satisfy" `Quick parser_satisfy_true 83 | ; test_case "satisfy false" `Quick parser_satisfy_false 84 | ; test_case "satisfy fail" `Quick parser_satisfy_fail 85 | ] ) 86 | -------------------------------------------------------------------------------- /stage/v0/test/1-parser/t03_atomic.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Parser.Parsec 2 | open Common 3 | 4 | let parser_any () = 5 | let open Atomic (Parsec) in 6 | let result = response @@ any @@ Parsec.source [ 'a' ] 7 | and expected = (Some 'a', true) in 8 | Alcotest.(check (pair (option char) bool)) "any" expected result 9 | 10 | let parser_atom () = 11 | let open Atomic (Parsec) in 12 | let result = response @@ atom 'a' @@ Parsec.source [ 'a' ] 13 | and expected = (Some 'a', true) in 14 | Alcotest.(check (pair (option char) bool)) "atom" expected result 15 | 16 | let parser_atom_fail () = 17 | let open Atomic (Parsec) in 18 | let result = response @@ atom 'a' @@ Parsec.source [ 'b' ] 19 | and expected = (None, false) in 20 | Alcotest.(check (pair (option char) bool)) "atom fail" expected result 21 | 22 | let parser_atom_in () = 23 | let open Atomic (Parsec) in 24 | let result = response @@ atom_in [ 'a'; 'b' ] @@ Parsec.source [ 'b' ] 25 | and expected = (Some 'b', true) in 26 | Alcotest.(check (pair (option char) bool)) "atom in" expected result 27 | 28 | let parser_atom_in_fail () = 29 | let open Atomic (Parsec) in 30 | let result = response @@ atom_in [ 'a'; 'b' ] @@ Parsec.source [ 'c' ] 31 | and expected = (None, false) in 32 | Alcotest.(check (pair (option char) bool)) "atom in fail" expected result 33 | 34 | let parser_atoms () = 35 | let open Atomic (Parsec) in 36 | let result = response @@ atoms [ 'a'; 'b' ] @@ Parsec.source [ 'a'; 'b' ] 37 | and expected = (Some [ 'a'; 'b' ], true) in 38 | Alcotest.(check (pair (option (list char)) bool)) "atoms" expected result 39 | 40 | let parser_atoms_fail () = 41 | let open Atomic (Parsec) in 42 | let result = response @@ atoms [ 'a'; 'b' ] @@ Parsec.source [ 'a'; 'c' ] 43 | and expected = (None, false) in 44 | Alcotest.(check (pair (option (list char)) bool)) "atoms fail" expected result 45 | 46 | let parser_not_atom () = 47 | let open Atomic (Parsec) in 48 | let result = response @@ (not (atom 'a')) @@ Parsec.source [ 'b' ] 49 | and expected = (Some 'b', true) in 50 | Alcotest.(check (pair (option char) bool)) "not atom" expected result 51 | 52 | let parser_not_atom_fail () = 53 | let open Atomic (Parsec) in 54 | let result = response @@ (not (atom 'a')) @@ Parsec.source [ 'a' ] 55 | and expected = (None, false) in 56 | Alcotest.(check (pair (option char) bool)) "not atom fail" expected result 57 | 58 | let cases = 59 | let open Alcotest in 60 | ( "Atom Parser" 61 | , [ 62 | test_case "any" `Quick parser_any 63 | ; test_case "atom" `Quick parser_atom 64 | ; test_case "atom fail" `Quick parser_atom_fail 65 | ; test_case "atom in" `Quick parser_atom_in 66 | ; test_case "atom in fail" `Quick parser_atom_in_fail 67 | ; test_case "atoms" `Quick parser_atoms 68 | ; test_case "atoms fail" `Quick parser_atoms_fail 69 | ; test_case "not atom" `Quick parser_not_atom 70 | ; test_case "not atom fail" `Quick parser_not_atom_fail 71 | ] ) 72 | -------------------------------------------------------------------------------- /stage/v0/test/1-parser/t04_occurrence.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Parser.Parsec 2 | open Common 3 | 4 | let parser_opt_some () = 5 | let open Atomic (Parsec) in 6 | let open Occurrence (Parsec) in 7 | let result = response @@ opt any @@ Parsec.source [ 'a' ] 8 | and expected = (Some (Some 'a'), true) in 9 | Alcotest.(check (pair (option (option char)) bool)) "opt some" expected result 10 | 11 | let parser_opt_none () = 12 | let open Atomic (Parsec) in 13 | let open Occurrence (Parsec) in 14 | let result = response @@ opt any @@ Parsec.source [] 15 | and expected = (Some None, false) in 16 | Alcotest.(check (pair (option (option char)) bool)) "opt none" expected result 17 | 18 | let parser_rep_one () = 19 | let open Atomic (Parsec) in 20 | let open Occurrence (Parsec) in 21 | let result = response @@ rep any @@ Parsec.source [ 'a' ] 22 | and expected = (Some [ 'a' ], true) in 23 | Alcotest.(check (pair (option (list char)) bool)) "rep two" expected result 24 | 25 | let parser_rep_two () = 26 | let open Atomic (Parsec) in 27 | let open Occurrence (Parsec) in 28 | let result = response @@ rep any @@ Parsec.source [ 'a'; 'b' ] 29 | and expected = (Some [ 'a'; 'b' ], true) in 30 | Alcotest.(check (pair (option (list char)) bool)) "rep two" expected result 31 | 32 | let parser_opt_rep_none () = 33 | let open Atomic (Parsec) in 34 | let open Occurrence (Parsec) in 35 | let result = response @@ opt_rep any @@ Parsec.source [] 36 | and expected = (Some [], false) in 37 | Alcotest.(check (pair (option (list char)) bool)) "opt rep none" expected result 38 | 39 | let parser_opt_rep_one () = 40 | let open Atomic (Parsec) in 41 | let open Occurrence (Parsec) in 42 | let result = response @@ opt_rep any @@ Parsec.source [ 'a' ] 43 | and expected = (Some [ 'a' ], true) in 44 | Alcotest.(check (pair (option (list char)) bool)) "opt rep one" expected result 45 | 46 | let parser_opt_rep_two () = 47 | let open Atomic (Parsec) in 48 | let open Occurrence (Parsec) in 49 | let result = response @@ opt_rep any @@ Parsec.source [ 'a'; 'b' ] 50 | and expected = (Some [ 'a'; 'b' ], true) in 51 | Alcotest.(check (pair (option (list char)) bool)) "opt rep two" expected result 52 | 53 | let cases = 54 | let open Alcotest in 55 | ( "Occurrence Parser" 56 | , [ 57 | test_case "opt some" `Quick parser_opt_some 58 | ; test_case "opt none" `Quick parser_opt_none 59 | ; test_case "rep one" `Quick parser_rep_one 60 | ; test_case "rep two" `Quick parser_rep_two 61 | ; test_case "opt rep empty" `Quick parser_opt_rep_none 62 | ; test_case "opt rep one" `Quick parser_opt_rep_one 63 | ; test_case "opt rep two" `Quick parser_opt_rep_two 64 | ] ) 65 | -------------------------------------------------------------------------------- /stage/v0/test/1-parser/t06_syntax.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Parser.Parsec 2 | open Common 3 | 4 | let parser_seq () = 5 | let open Syntax (Parsec) in 6 | let open Control.Monad (Parsec) in 7 | let p = 8 | let+ a = return 'a' 9 | and<+> b = return 1 in 10 | (a, b) 11 | in 12 | let result = response @@ p @@ Parsec.source [] 13 | and expected = (Some ('a', 1), false) in 14 | Alcotest.(check (pair (option (pair char int)) bool)) "sequence" expected result 15 | 16 | let parser_seq_left () = 17 | let open Syntax (Parsec) in 18 | let open Control.Monad (Parsec) in 19 | let p = 20 | let+ a = return 'a' 21 | and<+> _ = return 1 in 22 | a 23 | in 24 | let result = response @@ p @@ Parsec.source [] 25 | and expected = (Some 'a', false) in 26 | Alcotest.(check (pair (option char) bool)) "sequence left" expected result 27 | 28 | let parser_seq_right () = 29 | let open Syntax (Parsec) in 30 | let open Control.Monad (Parsec) in 31 | let p = 32 | let+ _ = return 'a' 33 | and<+> b = return 1 in 34 | b 35 | in 36 | let result = response @@ p @@ Parsec.source [] 37 | and expected = (Some 1, false) in 38 | Alcotest.(check (pair (option int) bool)) "sequence right" expected result 39 | 40 | let cases = 41 | let open Alcotest in 42 | ( "Syntax Parser" 43 | , [ 44 | test_case "sequence" `Quick parser_seq 45 | ; test_case "sequence left" `Quick parser_seq_left 46 | ; test_case "sequence right" `Quick parser_seq_right 47 | ] ) 48 | -------------------------------------------------------------------------------- /stage/v0/test/1-parser/t07_extra.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Parser.Parsec 2 | open Common 3 | 4 | let parser_eager_choice_left () = 5 | let open Control.Monad (Parsec) in 6 | let open Operator (Parsec) in 7 | let open Literal (Parsec) in 8 | let result = 9 | response 10 | @@ ?=(char 'a' <+> char 'b' <&> (fun _ -> 1) <|||> (char 'a' <+> char 'b' <&> fun _ -> 2)) 11 | @@ Parsec.source [ 'a'; 'b' ] 12 | and expected = (Some 1, true) in 13 | Alcotest.(check (pair (option int) bool)) "eager choice left" expected result 14 | 15 | let parser_eager_choice_right () = 16 | let open Control.Monad (Parsec) in 17 | let open Operator (Parsec) in 18 | let open Literal (Parsec) in 19 | let result = 20 | response 21 | @@ ?=(char 'a' <&> (fun _ -> 1) <|||> (char 'a' <+> char 'b' <&> fun _ -> 2)) 22 | @@ Parsec.source [ 'a'; 'b' ] 23 | and expected = (Some 2, true) in 24 | Alcotest.(check (pair (option int) bool)) "eager choice right" expected result 25 | 26 | let cases = 27 | let open Alcotest in 28 | ( "Extra Parser" 29 | , [ 30 | test_case "eager choice left" `Quick parser_eager_choice_left 31 | ; test_case "eager choice right" `Quick parser_eager_choice_right 32 | ] ) 33 | -------------------------------------------------------------------------------- /stage/v0/test/1-parser/t08_examples.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let parse_expr () = 4 | let open Ephel.Parser.Parsec.Core (Parsec) in 5 | let open Ephel.Parser.Parsec.Literal (Parsec) in 6 | let open Ephel.Parser.Source.Utils in 7 | (* 8 | expr ::= natural ((+|-) expr)? | "(" expr ")" 9 | *) 10 | let _OPERATOR_ = char_in_string "+-" 11 | and _LPAR_ = char '(' 12 | and _RPAR_ = char ')' in 13 | let operations expr = integer <+> opt (_OPERATOR_ <+> expr) >+> return () 14 | and parenthesis expr = _LPAR_ <+> expr <+> _RPAR_ >+> return () in 15 | let expr = fix (fun expr -> operations expr <|> parenthesis expr) in 16 | let result = response @@ expr @@ Parsec.source (chars_of_string "+1+(-2+-3)") 17 | and expected = (Some (), true) in 18 | Alcotest.(check (pair (option unit) bool)) "parse expression" expected result 19 | 20 | let cases = 21 | let open Alcotest in 22 | ("Examples Parser", [ test_case "expression parser" `Quick parse_expr ]) 23 | -------------------------------------------------------------------------------- /stage/v0/test/1-parser/t99_laws.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Parser.Parsec 2 | open Common 3 | 4 | (* Work in progress *) 5 | 6 | let functor_law1 t p = 7 | (* map id = id *) 8 | let open Control.Functor (Parsec) in 9 | let lhd = map (fun x -> x) 10 | and rhd x = x in 11 | let s = Parsec.source [] in 12 | let l = response @@ lhd p s 13 | and r = response @@ rhd p s in 14 | Alcotest.(check (pair (option t) bool)) "map id = id" l r 15 | 16 | let functor_law2 t f g p = 17 | (* map (f ° g) = (map f) ° (map g) *) 18 | let open Control.Functor (Parsec) in 19 | let lhd = map (fun x -> f (g x)) 20 | and rhd x = (map f) (map g x) in 21 | let s = Parsec.source [] in 22 | let l = response @@ lhd p s 23 | and r = response @@ rhd p s in 24 | Alcotest.(check (pair (option t) bool)) "map (f ° g) = (map f) ° (map g)" l r 25 | 26 | let monad_law1 t v p = 27 | (* return a >>= h = h a *) 28 | let open Control.Monad (Parsec) in 29 | let lhd = return v >>= p 30 | and rhd = p v in 31 | let s = Parsec.source [] in 32 | let l = response @@ lhd s 33 | and r = response @@ rhd s in 34 | Alcotest.(check (pair (option t) bool)) "return a >> h = h a" l r 35 | 36 | let monad_law2 t p = 37 | (* m >>= return = m *) 38 | let open Control.Monad (Parsec) in 39 | let lhd = p >>= return 40 | and rhd = p in 41 | let s = Parsec.source [] in 42 | let l = response @@ lhd s 43 | and r = response @@ rhd s in 44 | Alcotest.(check (pair (option t) bool)) "m >>= return = m" l r 45 | 46 | let monad_law3 t m g h = 47 | (* (m >>= g) >>= h = m >>= fun x -> g x >>= h *) 48 | let open Control.Monad (Parsec) in 49 | let lhd = m >>= g >>= h 50 | and rhd = m >>= fun x -> g x >>= h in 51 | let s = Parsec.source [] in 52 | let l = response @@ lhd s 53 | and r = response @@ rhd s in 54 | Alcotest.(check (pair (option t) bool)) "(m >>= g) >>= h = m >>= fun x -> g x >>= h" l r 55 | 56 | (* Quick check should be used here *) 57 | 58 | let cases = 59 | let open Alcotest in 60 | let open Eval (Parsec) in 61 | ( "Laws" 62 | , [ 63 | test_case "map id = id" `Quick (fun () -> functor_law1 int @@ return 1) 64 | ; test_case "map (f ° g) = (map f) ° (map g)" `Quick (fun () -> 65 | functor_law2 int (( + ) 1) int_of_string @@ return "1" ) 66 | ; test_case "return a >> h = h a" `Quick (fun () -> monad_law1 int 1 @@ fun v -> return v) 67 | ; test_case "m >> return = m" `Quick (fun () -> monad_law2 int @@ return 1) 68 | ; test_case "(m >>= g) >>= h = m >>= fun x -> g x >>= h" `Quick (fun () -> 69 | monad_law3 int (return "1") (fun v -> return @@ int_of_string v) return ) 70 | ] ) 71 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/03-tokenizer/common.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Parser.Parsec 2 | open Ephel.Parser.Source 3 | open Ephel.Compiler.Token 4 | open Ephel.Compiler.Tokenizer 5 | open Preface.Option.Monad 6 | 7 | let response r = 8 | let open Response.Destruct in 9 | fold ~success:(fun ((a, _), _, _) -> Some a) ~failure:(fun (_, _, _) -> None) r 10 | 11 | let test name input expected () = 12 | let module Parsec = Parsec (FromChars) in 13 | let open Eval (Parsec) in 14 | let result = Tokenizer.tokenize (module Parsec) @@ Parsec.source (Utils.chars_of_string input) 15 | and expected = Some expected in 16 | Alcotest.(check (option string)) 17 | name (expected <&> Render.to_string) 18 | (response result <&> Render.to_string) 19 | 20 | let test name input expected = Alcotest.(test_case name `Quick (test name input expected)) 21 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/03-tokenizer/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t00_tokenizer_tests) 3 | (libraries alcotest ephel)) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/03-tokenizer/t00_tokenizer_tests.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.( 3 | run "Tokenizer Test" 4 | [ 5 | T01_separators.cases 6 | ; T02_keywords.cases 7 | ; T03_literals.cases 8 | ; T04_identifiers.cases 9 | ; T05_spaces.cases 10 | ] ) 11 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/03-tokenizer/t01_separators.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Token 2 | open Common 3 | 4 | let cases = 5 | ( "Separators" 6 | , [ 7 | test "lpar" "(" Token.LPAR 8 | ; test "rpar" ")" Token.RPAR 9 | ; test "equal" "=" Token.EQUAL 10 | ; test "imply" "=>" Token.IMPLY 11 | ; test "product" "," Token.PRODUCT 12 | ] ) 13 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/03-tokenizer/t02_keywords.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Token 2 | open Common 3 | 4 | let cases = 5 | ( "Keywords" 6 | , [ 7 | test "inl" "inl" Token.INL 8 | ; test "inr" "inr" Token.INR 9 | ; test "case" "case" Token.CASE 10 | ; test "let" "let" Token.LET 11 | ; test "in" "in" Token.IN 12 | ; test "fst" "fst" Token.FST 13 | ; test "snd" "snd" Token.SND 14 | ; test "val" "val" Token.VAL 15 | ] ) 16 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/03-tokenizer/t03_literals.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Token 2 | open Common 3 | 4 | let cases = 5 | ( "Literals" 6 | , [ 7 | test "123" "123" (Token.INT 123); test "\"a string\"" "\"a string\"" (Token.STRING "a string") 8 | ] ) 9 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/03-tokenizer/t04_identifiers.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Token 2 | open Common 3 | 4 | let cases = 5 | ( "Identifiers" 6 | , [ 7 | test "identifier" "identifier" (Token.IDENT "identifier") 8 | ; test "is-empty?" "is-empty?" (Token.IDENT "is-empty?") 9 | ] ) 10 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/03-tokenizer/t05_spaces.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Token 2 | open Common 3 | 4 | let cases = 5 | ( "Identifiers with Spaces" 6 | , [ 7 | test "identifier" " identifier " (Token.IDENT "identifier") 8 | ; test "is-empty?" " is-empty? " (Token.IDENT "is-empty?") 9 | ] ) 10 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/05-analyzer/common.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Parser.Parsec 2 | open Ephel.Parser.Source 3 | open Ephel.Compiler.Token 4 | open Ephel.Compiler.Cst 5 | open Ephel.Compiler.Analyzer 6 | open Preface.Option.Monad 7 | 8 | let location = Location.Construct.create ~file:None ~position:0 ~line:0 ~column:0 9 | let region = Region.Construct.create ~first:location ~last:location 10 | 11 | module FromTokensWithRegion = FromList (struct 12 | type e = Token.with_region 13 | 14 | let locate l = function _ -> l 15 | end) 16 | 17 | let response r = 18 | let open Response.Destruct in 19 | fold ~success:(fun (a, _, _) -> Some a) ~failure:(fun (_, _, _) -> None) r 20 | 21 | let test_expr name input expected () = 22 | let module Parsec = Parsec (FromTokensWithRegion) in 23 | let module Core = Core (Parsec) in 24 | let result = 25 | Core.(Analyser.term (module Parsec) <+< eos) 26 | @@ Parsec.source 27 | @@ List.map (fun e -> (e, region)) input 28 | and expected = Some expected in 29 | Alcotest.(check (option string)) 30 | name (expected <&> Render.to_string) 31 | (response result <&> Render.to_string) 32 | 33 | let test_decl name input expected () = 34 | let module Parsec = Parsec (FromTokensWithRegion) in 35 | let module Core = Core (Parsec) in 36 | let result = 37 | Core.(Analyser.declaration (module Parsec) <+< eos) 38 | @@ Parsec.source 39 | @@ List.map (fun e -> (e, region)) input 40 | and expected = Some expected in 41 | Alcotest.(check (option string)) 42 | name 43 | (expected <&> fun (n, t) -> n ^ ":" ^ Render.to_string t) 44 | (response result <&> fun (n, t) -> n ^ ":" ^ Render.to_string t) 45 | 46 | let test_expr name input expected = Alcotest.(test_case name `Quick (test_expr name input expected)) 47 | let test_decl name input expected = Alcotest.(test_case name `Quick (test_decl name input expected)) 48 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/05-analyzer/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t00_analyzer_tests) 3 | (libraries alcotest ephel)) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/05-analyzer/t00_analyzer_tests.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.( 3 | run "Analyzer Test" 4 | [ 5 | T01_identifier.cases 6 | ; T02_literal.cases 7 | ; T03_functional.cases 8 | ; T04_group.cases 9 | ; T05_product.cases 10 | ; T06_coproduct.cases 11 | ; T07_declaration.cases 12 | ] ) 13 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/05-analyzer/t01_identifier.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let cases = 4 | ("Identifier", [ test_expr "identifier" [ IDENT "identifier" ] (Ident ("identifier", region)) ]) 5 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/05-analyzer/t02_literal.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let cases = 4 | ( "Literals" 5 | , [ 6 | test_expr "123" [ INT 123 ] (Literal (Integer 123, region)) 7 | ; test_expr "\"a string\"" [ STRING "a string" ] (Literal (String "a string", region)) 8 | ] ) 9 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/05-analyzer/t03_functional.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let cases = 4 | ( "Functional" 5 | , [ 6 | test_expr "x => x" [ IDENT "x"; IMPLY; IDENT "x" ] (Abs ([ "x" ], Ident ("x", region), region)) 7 | ; test_expr "f x => f" 8 | [ IDENT "f"; IDENT "x"; IMPLY; IDENT "f" ] 9 | (Abs ([ "f"; "x" ], Ident ("f", region), region)) 10 | ; test_expr "f x" [ IDENT "f"; IDENT "x" ] 11 | (App (Ident ("f", region), Ident ("x", region), region)) 12 | ; test_expr "f x y" 13 | [ IDENT "f"; IDENT "x"; IDENT "y" ] 14 | (App (App (Ident ("f", region), Ident ("x", region), region), Ident ("y", region), region)) 15 | ; test_expr "x f => f x" 16 | [ IDENT "x"; IDENT "f"; IMPLY; IDENT "f"; IDENT "x" ] 17 | (Abs ([ "x"; "f" ], App (Ident ("f", region), Ident ("x", region), region), region)) 18 | ; test_expr "let x = f in g" 19 | [ LET; IDENT "x"; EQUAL; IDENT "f"; IN; IDENT "g" ] 20 | (Let ("x", Ident ("f", region), Ident ("g", region), region)) 21 | ; test_expr "let x = f y in g" 22 | [ LET; IDENT "x"; EQUAL; IDENT "f"; IDENT "y"; IN; IDENT "g" ] 23 | (Let 24 | ("x", App (Ident ("f", region), Ident ("y", region), region), Ident ("g", region), region) 25 | ) 26 | ; test_expr "let x = f y in g x" 27 | [ LET; IDENT "x"; EQUAL; IDENT "f"; IDENT "y"; IN; IDENT "g"; IDENT "x" ] 28 | (Let 29 | ( "x" 30 | , App (Ident ("f", region), Ident ("y", region), region) 31 | , App (Ident ("g", region), Ident ("x", region), region) 32 | , region ) ) 33 | ] ) 34 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/05-analyzer/t04_group.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let cases = 4 | ( "Groups" 5 | , [ 6 | test_expr "()" [ LPAR; RPAR ] (Unit region) 7 | ; test_expr "(123)" [ LPAR; INT 123; RPAR ] (Literal (Integer 123, region)) 8 | ; test_expr "x (y z)" 9 | [ IDENT "x"; LPAR; IDENT "y"; IDENT "z"; RPAR ] 10 | (App (Ident ("x", region), App (Ident ("y", region), Ident ("z", region), region), region)) 11 | ; test_expr "(x => y) z" 12 | [ LPAR; IDENT "x"; IMPLY; IDENT "y"; RPAR; IDENT "z" ] 13 | (App (Abs ([ "x" ], Ident ("y", region), region), Ident ("z", region), region)) 14 | ] ) 15 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/05-analyzer/t05_product.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let cases = 4 | ( "Products" 5 | , [ 6 | test_expr "42,24" [ INT 42; PRODUCT; INT 24 ] 7 | (Pair (Literal (Integer 42, region), Literal (Integer 24, region), region)) 8 | ; test_expr "x => y,24" 9 | [ IDENT "x"; IMPLY; IDENT "y"; PRODUCT; INT 24 ] 10 | (Abs ([ "x" ], Pair (Ident ("y", region), Literal (Integer 24, region), region), region)) 11 | ; test_expr "(x => y),24" 12 | [ LPAR; IDENT "x"; IMPLY; IDENT "y"; RPAR; PRODUCT; INT 24 ] 13 | (Pair (Abs ([ "x" ], Ident ("y", region), region), Literal (Integer 24, region), region)) 14 | ; test_expr "fst x" [ FST; IDENT "x" ] (Builtin (Fst, Ident ("x", region), region)) 15 | ; test_expr "snd x" [ SND; IDENT "x" ] (Builtin (Snd, Ident ("x", region), region)) 16 | ] ) 17 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/05-analyzer/t06_coproduct.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let cases = 4 | ( "Coproducts" 5 | , [ 6 | test_expr "case identifier 21 32" 7 | [ CASE; IDENT "identifier"; INT 21; INT 32 ] 8 | (Case ("identifier", Literal (Integer 21, region), Literal (Integer 32, region), region)) 9 | ; test_expr "inl x" [ INL; IDENT "x" ] (Builtin (Inl, Ident ("x", region), region)) 10 | ; test_expr "inr x" [ INR; IDENT "x" ] (Builtin (Inr, Ident ("x", region), region)) 11 | ] ) 12 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/05-analyzer/t07_declaration.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let cases = 4 | ( "Declarations" 5 | , [ 6 | test_decl "val one = 1" [ VAL; IDENT "one"; EQUAL; INT 1 ] ("one", Literal (Integer 1, region)) 7 | ; test_decl "val one = x => x" 8 | [ VAL; IDENT "one"; EQUAL; IDENT "x"; IMPLY; IDENT "x" ] 9 | ("one", Abs ([ "x" ], Ident ("x", region), region)) 10 | ; test_decl "val one = x y => y x" 11 | [ VAL; IDENT "one"; EQUAL; IDENT "x"; IDENT "y"; IMPLY; IDENT "y"; IDENT "x" ] 12 | ("one", Abs ([ "x"; "y" ], App (Ident ("y", region), Ident ("x", region), region), region)) 13 | ] ) 14 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/06-ast/common.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Free 2 | 3 | let test name input expected () = Alcotest.(check (list string)) name (free input) expected 4 | let test name input expected = Alcotest.(test_case name `Quick (test name input expected)) 5 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/06-ast/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t00_ast_tests) 3 | (libraries alcotest ephel)) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/06-ast/t00_ast_tests.ml: -------------------------------------------------------------------------------- 1 | let () = Alcotest.(run "Ast Test" [ T01_free_vars.cases ]) 2 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/06-ast/t01_free_vars.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Common 3 | 4 | let cases = 5 | ( "Free variables" 6 | , [ 7 | test "n => n" (Abs ([ "n" ], Var "n")) [] 8 | ; test "n => v" (Abs ([ "n" ], Var "v")) [ "v" ] 9 | ; test "v 1" (App (Var "v", Int 1)) [ "v" ] 10 | ; test "()" Unit [] 11 | ; test "1" (Int 1) [] 12 | ; test "(1, n => n)" (Pair (Int 1, Abs ([ "n" ], Var "n"))) [] 13 | ; test "(1, n => v)" (Pair (Int 1, Abs ([ "n" ], Var "v"))) [ "v" ] 14 | ; test "(n => n, 1)" (Pair (Abs ([ "n" ], Var "n"), Int 1)) [] 15 | ; test "(n => v, 1)" (Pair (Abs ([ "n" ], Var "v"), Int 1)) [ "v" ] 16 | ; test "fst v" (Fst (Var "v")) [ "v" ] 17 | ; test "snd v" (Snd (Var "v")) [ "v" ] 18 | ; test "inl v" (Inl (Var "v")) [ "v" ] 19 | ; test "inr v" (Inr (Var "v")) [ "v" ] 20 | ; test "case v n t" (Case (Var "v", Var "n", Var "t")) [ "v"; "n"; "t" ] 21 | ] ) 22 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/08-lifting/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t00_lifting_tests) 3 | (libraries alcotest ephel)) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/08-lifting/t00_lifting_tests.ml: -------------------------------------------------------------------------------- 1 | let () = Alcotest.(run "Lifting Test" []) 2 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/09-transpiler/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t00_transpiler_tests) 3 | (libraries alcotest ephel)) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/09-transpiler/t00_transpiler_tests.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.( 3 | run "Transpiler Test" [ T01_basic.cases; T02_sum.cases; T03_pair.cases; T04_lambda.cases ] ) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/09-transpiler/t01_basic.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | 6 | open Preface.Result.Monad (struct 7 | type t = string 8 | end) 9 | 10 | let compile s = return s >>= Transpiler.run 11 | 12 | let compile_01 () = 13 | let result = compile (Int 1) 14 | and expected = [ PUSH (INT 1) ] in 15 | Alcotest.(check (result string string)) 16 | "compile 1" 17 | (return expected <&> to_string) 18 | (result <&> to_string) 19 | 20 | let compile_02 () = 21 | let result = compile (Abs ([ "x" ], Var "x")) 22 | and expected = [ LAMBDA ([ "x" ], [ DUP (0, "x"); DROP (1, "x") ]) ] in 23 | Alcotest.(check (result string string)) 24 | "compile fun x -> x" 25 | (return expected <&> to_string) 26 | (result <&> to_string) 27 | 28 | let compile_03 () = 29 | let result = compile (Abs ([ "x" ], Unit)) 30 | and expected = [ LAMBDA ([ "x" ], [ PUSH UNIT; DROP (1, "x") ]) ] in 31 | Alcotest.(check (result string string)) 32 | "compile fun x -> unit" 33 | (return expected <&> to_string) 34 | (result <&> to_string) 35 | 36 | let compile_04 () = 37 | let result = compile (App (Abs ([ "x" ], Var "x"), Int 1)) 38 | and expected = [ LAMBDA ([ "x" ], [ DUP (0, "x"); DROP (1, "x") ]); PUSH (INT 1); EXEC ] in 39 | Alcotest.(check (result string string)) 40 | "compile (fun x -> x) 1" 41 | (return expected <&> to_string) 42 | (result <&> to_string) 43 | 44 | let compile_05 () = 45 | let result = compile (App (Abs ([ "x" ], Unit), Int 1)) 46 | and expected = [ LAMBDA ([ "x" ], [ PUSH UNIT; DROP (1, "x") ]); PUSH (INT 1); EXEC ] in 47 | Alcotest.(check (result string string)) 48 | "compile (fun x -> unit) 1" 49 | (return expected <&> to_string) 50 | (result <&> to_string) 51 | 52 | let compile_06 () = 53 | let result = compile (App (App (Abs ([ "x"; "y" ], Var "y"), Int 1), Int 2)) 54 | and expected = 55 | [ 56 | LAMBDA ([ "x"; "y" ], [ DUP (0, "y"); DROP (1, "y"); DROP (1, "x") ]) 57 | ; PUSH (INT 1) 58 | ; EXEC 59 | ; PUSH (INT 2) 60 | ; EXEC 61 | ] 62 | in 63 | Alcotest.(check (result string string)) 64 | "compile (fun x y -> y) 1 2" 65 | (return expected <&> to_string) 66 | (result <&> to_string) 67 | 68 | let compile_07 () = 69 | (* PARTIAL APPLICATION *) 70 | let result = compile (App (App (Abs ([ "x"; "y" ], Var "x"), Int 1), Int 2)) 71 | and expected = [ PUSH (INT 1) ] in 72 | Alcotest.(check (result string string)) 73 | "compile (fun x y -> x) 1 2" 74 | (return expected <&> to_string) 75 | (result <&> to_string) 76 | 77 | (* 78 | let compile_08 () = 79 | let result = compile (Let ("x", Int 1, Var "x")) 80 | and expected = [ PUSH (INT 1); DUP (0, "x"); DROP (1, "x") ] in 81 | Alcotest.(check (result string string)) 82 | "compile let x = 1 in x" 83 | (return expected <&> to_string) 84 | (result <&> to_string) 85 | *) 86 | let compile_09 () = 87 | let result = compile (Abs ([ "f"; "x" ], App (Var "f", Var "x"))) 88 | and expected = [ LAMBDA ([ "f"; "x" ], [ DIG (1, "f"); EXEC ]) ] in 89 | Alcotest.(check (result string string)) 90 | "compile (fun f x -> f x)" 91 | (return expected <&> to_string) 92 | (result <&> to_string) 93 | 94 | (* 95 | let compile_10 () = 96 | let result = compile (Abs ([ "f" ], Let ("x", Int 1, App (Var "f", Var "x")))) 97 | and expected = 98 | [ 99 | LAMBDA 100 | ([ "f" ], [ PUSH (INT 1); DUP (1, "f"); DUP (1, "x"); EXEC; DROP (1, "x"); DROP (1, "f") ]) 101 | ] 102 | in 103 | Alcotest.(check (result string string)) 104 | "compile (fun f -> let x = 1 in f x)" 105 | (return expected <&> to_string) 106 | (result <&> to_string) 107 | *) 108 | let cases = 109 | let open Alcotest in 110 | ( "Basic Compilation" 111 | , [ 112 | test_case "compile O1" `Quick compile_01 113 | ; test_case "compile O2" `Quick compile_02 114 | ; test_case "compile O3" `Quick compile_03 115 | ; test_case "compile O4" `Quick compile_04 116 | ; test_case "compile O5" `Quick compile_05 117 | (* ; test_case "compile O6" `Quick compile_06 118 | ; test_case "compile O7" `Quick compile_07 ; test_case "compile O8" `Quick compile_08 119 | ; test_case "compile O9" `Quick compile_09 ; test_case "compile 10" `Quick compile_10 *) 120 | ] ) 121 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/09-transpiler/t03_pair.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | 6 | open Preface.Result.Monad (struct 7 | type t = string 8 | end) 9 | 10 | let compile s = return s >>= Transpiler.run 11 | 12 | let compile_01 () = 13 | let result = compile (Pair (Int 1, Int 2)) 14 | and expected = [ PUSH (INT 2); PUSH (INT 1); PAIR ] in 15 | Alcotest.(check (result string string)) 16 | "compile (1,2)" 17 | (return expected <&> to_string) 18 | (result <&> to_string) 19 | 20 | let compile_02 () = 21 | let result = compile (Fst (Pair (Int 1, Int 2))) 22 | and expected = [ PUSH (INT 2); PUSH (INT 1); PAIR; FST ] in 23 | Alcotest.(check (result string string)) 24 | "compile fst (1,2)" 25 | (return expected <&> to_string) 26 | (result <&> to_string) 27 | 28 | let compile_03 () = 29 | let result = compile (Snd (Pair (Int 1, Int 2))) 30 | and expected = [ PUSH (INT 2); PUSH (INT 1); PAIR; SND ] in 31 | Alcotest.(check (result string string)) 32 | "compile snd (1,2)" 33 | (return expected <&> to_string) 34 | (result <&> to_string) 35 | 36 | let compile_04 () = 37 | let result = compile (Abs ([ "p" ], Fst (Var "p"))) 38 | and expected = [ LAMBDA ([ "p" ], [ DUP (0, "p"); FST; DROP (1, "p") ]) ] in 39 | Alcotest.(check (result string string)) 40 | "compile (fun p -> fst p)" 41 | (return expected <&> to_string) 42 | (result <&> to_string) 43 | 44 | let compile_05 () = 45 | let result = compile (Abs ([ "p" ], App (Fst (Var "p"), Snd (Var "p")))) 46 | and expected = 47 | [ LAMBDA ([ "p" ], [ DUP (0, "p"); FST; DUP (1, "p"); SND; EXEC; DROP (1, "p") ]) ] 48 | in 49 | Alcotest.(check (result string string)) 50 | "compile (fun p -> (fst p) (snd p))" 51 | (return expected <&> to_string) 52 | (result <&> to_string) 53 | 54 | let compile_06 () = 55 | let result = compile (Abs ([ "p" ], App (Snd (Var "p"), Fst (Var "p")))) 56 | and expected = 57 | [ LAMBDA ([ "p" ], [ DUP (0, "p"); SND; DUP (1, "p"); FST; EXEC; DROP (1, "p") ]) ] 58 | in 59 | Alcotest.(check (result string string)) 60 | "compile (fun p -> (snd p) (fst p))" 61 | (return expected <&> to_string) 62 | (result <&> to_string) 63 | 64 | let compile_07 () = 65 | let result = compile (Abs ([ "p" ], Pair (Fst (Var "p"), Snd (Var "p")))) 66 | and expected = 67 | [ LAMBDA ([ "p" ], [ DUP (0, "p"); SND; DUP (1, "p"); FST; PAIR; DROP (1, "p") ]) ] 68 | in 69 | Alcotest.(check (result string string)) 70 | "compile (fun p -> (fst p, snd p))" 71 | (return expected <&> to_string) 72 | (result <&> to_string) 73 | 74 | let cases = 75 | let open Alcotest in 76 | ( "Pair Compilation" 77 | , [ 78 | test_case "compile O1" `Quick compile_01 79 | ; test_case "compile 02" `Quick compile_02 80 | ; test_case "compile 03" `Quick compile_03 81 | ; test_case "compile 04" `Quick compile_04 82 | ; test_case "compile 05" `Quick compile_05 83 | ; test_case "compile 06" `Quick compile_06 84 | ; test_case "compile 07" `Quick compile_07 85 | ] ) 86 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/09-transpiler/t04_lambda.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | 6 | open Preface.Result.Monad (struct 7 | type t = string 8 | end) 9 | 10 | let compile s = return s >>= Transpiler.run 11 | 12 | let compile_01 () = 13 | let result = compile (Rec ("f", Abs ([ "x" ], App (Var "f", Var "x")))) 14 | and expected = 15 | [ 16 | LAMBDA_REC ("f", [ "x" ], [ DUP (1, "f"); DUP (1, "x"); EXEC; DROP (1, "x"); DROP (1, "f") ]) 17 | ] 18 | in 19 | Alcotest.(check (result string string)) 20 | "compile rec(f).(fun x -> f x)" 21 | (return expected <&> to_string) 22 | (result <&> to_string) 23 | 24 | let compile_02 () = 25 | let result = 26 | compile 27 | (Rec 28 | ( "f" 29 | , Abs 30 | ([ "x" ], Case (Var "x", Abs ([ "y" ], Var "y"), Abs ([ "y" ], App (Var "f", Var "y")))) 31 | ) ) 32 | and expected = 33 | [ 34 | LAMBDA_REC 35 | ( "f" 36 | , [ "x" ] 37 | , [ 38 | DUP (0, "x") 39 | ; CASE 40 | ([ DUP (0, "y"); DROP (1, "y") ], [ DUP (2, "f"); DUP (1, "y"); EXEC; DROP (1, "y") ]) 41 | ; DROP (1, "x") 42 | ; DROP (1, "f") 43 | ] ) 44 | ] 45 | in 46 | Alcotest.(check (result string string)) 47 | "compile rec(f).(fun x -> case x (fun y -> y) (fun y -> f y))" 48 | (return expected <&> to_string) 49 | (result <&> to_string) 50 | 51 | let cases = 52 | let open Alcotest in 53 | ( "Lambda Compilation" 54 | , [ test_case "compile O1" `Quick compile_01; test_case "compile O2" `Quick compile_02 ] ) 55 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/10-expander/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t00_expander_tests) 3 | (libraries alcotest ephel)) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/10-expander/t00_expander_tests.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.(run "Expander Test" [ T01_basic.cases; T02_sum.cases; T03_pair.cases; T04_lambda.cases ]) 3 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/10-expander/t01_basic.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | 7 | open Preface.Result.Monad (struct 8 | type t = string 9 | end) 10 | 11 | let compile s = return s >>= Transpiler.run <&> Expander.run 12 | 13 | let compile_01 () = 14 | let result = compile (Int 1) 15 | and expected = [ PUSH (INT 1) ] in 16 | Alcotest.(check (result string string)) 17 | "compile 1" 18 | (return expected <&> to_string) 19 | (result <&> to_string) 20 | 21 | let compile_02 () = 22 | let result = compile (Abs ([ "x" ], Var "x")) 23 | and expected = [ LAMBDA ([ "x" ], [ DUP (0, "x"); DROP (1, "x") ]) ] in 24 | Alcotest.(check (result string string)) 25 | "compile fun x -> x" 26 | (return expected <&> to_string) 27 | (result <&> to_string) 28 | 29 | let compile_03 () = 30 | let result = compile (Abs ([ "x" ], Unit)) 31 | and expected = [ LAMBDA ([ "x" ], [ PUSH UNIT; DROP (1, "x") ]) ] in 32 | Alcotest.(check (result string string)) 33 | "compile fun x -> unit" 34 | (return expected <&> to_string) 35 | (result <&> to_string) 36 | 37 | let compile_04 () = 38 | let result = compile (App (Abs ([ "x" ], Var "x"), Int 1)) 39 | and expected = [ LAMBDA ([ "x" ], [ DUP (0, "x"); DROP (1, "x") ]); PUSH (INT 1); EXEC ] in 40 | Alcotest.(check (result string string)) 41 | "compile (fun x -> x) 1" 42 | (return expected <&> to_string) 43 | (result <&> to_string) 44 | 45 | let compile_05 () = 46 | let result = compile (App (Abs ([ "x" ], Unit), Int 1)) 47 | and expected = [ LAMBDA ([ "x" ], [ PUSH UNIT; DROP (1, "x") ]); PUSH (INT 1); EXEC ] in 48 | Alcotest.(check (result string string)) 49 | "compile (fun x -> unit) 1" 50 | (return expected <&> to_string) 51 | (result <&> to_string) 52 | 53 | let compile_06 () = 54 | let result = compile (App (App (Abs ([ "x" ], Abs ([ "y" ], Var "y")), Int 1), Int 2)) 55 | and expected = 56 | [ 57 | LAMBDA ([ "x" ], [ LAMBDA ([ "y" ], [ DUP (0, "y"); DROP (1, "y") ]); DROP (1, "x") ]) 58 | ; PUSH (INT 1) 59 | ; EXEC 60 | ; PUSH (INT 2) 61 | ; EXEC 62 | ] 63 | in 64 | Alcotest.(check (result string string)) 65 | "compile (fun x y -> y) 1 2" 66 | (return expected <&> to_string) 67 | (result <&> to_string) 68 | 69 | let compile_07 () = 70 | (* PARTIAL APPLICATION *) 71 | let result = compile (App (App (Abs ([ "x" ], Abs ([ "y" ], Var "x")), Int 1), Int 2)) 72 | and expected = [ PUSH (INT 1) ] in 73 | Alcotest.(check (result string string)) 74 | "compile (fun x y -> x) 1 2" 75 | (return expected <&> to_string) 76 | (result <&> to_string) 77 | 78 | (* 79 | let compile_08 () = 80 | let result = compile (Let ("x", Int 1, Var "x")) 81 | and expected = [ PUSH (INT 1); DUP (0, "x"); DROP (1, "x") ] in 82 | Alcotest.(check (result string string)) 83 | "compile let x = 1 in x" 84 | (return expected <&> to_string) 85 | (result <&> to_string) 86 | *) 87 | let compile_09 () = 88 | (* PARTIAL APPLICATION *) 89 | let result = compile (Abs ([ "f" ], Abs ([ "x" ], App (Var "f", Var "x")))) 90 | and expected = [ LAMBDA ([ "f" ], [ LAMBDA ([ "x" ], [ DIG (1, "f"); EXEC ]) ]) ] in 91 | Alcotest.(check (result string string)) 92 | "compile (fun f x -> f x)" 93 | (return expected <&> to_string) 94 | (result <&> to_string) 95 | 96 | (* 97 | let compile_10 () = 98 | let result = compile (Abs ([ "f" ], Let ("x", Int 1, App (Var "f", Var "x")))) 99 | and expected = 100 | [ 101 | LAMBDA 102 | ([ "f" ], [ PUSH (INT 1); DUP (1, "f"); DUP (1, "x"); EXEC; DROP (1, "x"); DROP (1, "f") ]) 103 | ] 104 | in 105 | Alcotest.(check (result string string)) 106 | "compile (fun f -> let x = 1 in f x)" 107 | (return expected <&> to_string) 108 | (result <&> to_string) 109 | *) 110 | let cases = 111 | let open Alcotest in 112 | ( "Basic Compilation" 113 | , [ 114 | test_case "compile O1" `Quick compile_01 115 | ; test_case "compile O2" `Quick compile_02 116 | ; test_case "compile O3" `Quick compile_03 117 | ; test_case "compile O4" `Quick compile_04 118 | ; test_case "compile O5" `Quick compile_05 119 | ; test_case "compile O6" `Quick compile_06 120 | (*; test_case "compile O7" `Quick compile_07 121 | ; test_case "compile O8" `Quick compile_08 ; test_case "compile O9" `Quick compile_09 122 | ; test_case "compile 10" `Quick compile_10 *) 123 | ] ) 124 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/10-expander/t03_pair.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | 7 | open Preface.Result.Monad (struct 8 | type t = string 9 | end) 10 | 11 | let compile s = return s >>= Transpiler.run <&> Expander.run 12 | 13 | let compile_01 () = 14 | let result = compile (Pair (Int 1, Int 2)) 15 | and expected = [ PUSH (INT 2); PUSH (INT 1); PAIR ] in 16 | Alcotest.(check (result string string)) 17 | "compile (1,2)" 18 | (return expected <&> to_string) 19 | (result <&> to_string) 20 | 21 | let compile_02 () = 22 | let result = compile (Fst (Pair (Int 1, Int 2))) 23 | and expected = [ PUSH (INT 2); PUSH (INT 1); PAIR; FST ] in 24 | Alcotest.(check (result string string)) 25 | "compile fst (1,2)" 26 | (return expected <&> to_string) 27 | (result <&> to_string) 28 | 29 | let compile_03 () = 30 | let result = compile (Snd (Pair (Int 1, Int 2))) 31 | and expected = [ PUSH (INT 2); PUSH (INT 1); PAIR; SND ] in 32 | Alcotest.(check (result string string)) 33 | "compile snd (1,2)" 34 | (return expected <&> to_string) 35 | (result <&> to_string) 36 | 37 | let compile_04 () = 38 | let result = compile (Abs ([ "p" ], Fst (Var "p"))) 39 | and expected = [ LAMBDA ([ "p" ], [ DUP (0, "p"); FST; DROP (1, "p") ]) ] in 40 | Alcotest.(check (result string string)) 41 | "compile (fun p -> fst p)" 42 | (return expected <&> to_string) 43 | (result <&> to_string) 44 | 45 | let compile_05 () = 46 | let result = compile (Abs ([ "p" ], App (Fst (Var "p"), Snd (Var "p")))) 47 | and expected = 48 | [ LAMBDA ([ "p" ], [ DUP (0, "p"); FST; DUP (1, "p"); SND; EXEC; DROP (1, "p") ]) ] 49 | in 50 | Alcotest.(check (result string string)) 51 | "compile (fun p -> (fst p) (snd p))" 52 | (return expected <&> to_string) 53 | (result <&> to_string) 54 | 55 | let compile_06 () = 56 | let result = compile (Abs ([ "p" ], App (Snd (Var "p"), Fst (Var "p")))) 57 | and expected = 58 | [ LAMBDA ([ "p" ], [ DUP (0, "p"); SND; DUP (1, "p"); FST; EXEC; DROP (1, "p") ]) ] 59 | in 60 | Alcotest.(check (result string string)) 61 | "compile (fun p -> (snd p) (fst p))" 62 | (return expected <&> to_string) 63 | (result <&> to_string) 64 | 65 | let compile_07 () = 66 | let result = compile (Abs ([ "p" ], Pair (Fst (Var "p"), Snd (Var "p")))) 67 | and expected = 68 | [ LAMBDA ([ "p" ], [ DUP (0, "p"); SND; DUP (1, "p"); FST; PAIR; DROP (1, "p") ]) ] 69 | in 70 | Alcotest.(check (result string string)) 71 | "compile (fun p -> (fst p, snd p))" 72 | (return expected <&> to_string) 73 | (result <&> to_string) 74 | 75 | let cases = 76 | let open Alcotest in 77 | ( "Pair Compilation" 78 | , [ 79 | test_case "compile O1" `Quick compile_01 80 | ; test_case "compile 02" `Quick compile_02 81 | ; test_case "compile 03" `Quick compile_03 82 | ; test_case "compile 04" `Quick compile_04 83 | ; test_case "compile 05" `Quick compile_05 84 | ; test_case "compile 06" `Quick compile_06 85 | ; test_case "compile 07" `Quick compile_07 86 | ] ) 87 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/10-expander/t04_lambda.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | 7 | open Preface.Result.Monad (struct 8 | type t = string 9 | end) 10 | 11 | let compile s = return s >>= Transpiler.run <&> Expander.run 12 | 13 | let compile_01 () = 14 | let result = compile (Rec ("f", Abs ([ "x" ], App (Var "f", Var "x")))) 15 | and expected = 16 | [ 17 | LAMBDA_REC ("f", [ "x" ], [ DUP (1, "f"); DUP (1, "x"); EXEC; DROP (1, "x"); DROP (1, "f") ]) 18 | ] 19 | in 20 | Alcotest.(check (result string string)) 21 | "compile rec(f).(fun x -> f x)" 22 | (return expected <&> to_string) 23 | (result <&> to_string) 24 | 25 | let compile_02 () = 26 | let result = 27 | compile 28 | (Rec 29 | ( "f" 30 | , Abs 31 | ([ "x" ], Case (Var "x", Abs ([ "y" ], Var "y"), Abs ([ "y" ], App (Var "f", Var "y")))) 32 | ) ) 33 | and expected = 34 | [ 35 | LAMBDA_REC 36 | ( "f" 37 | , [ "x" ] 38 | , [ 39 | DUP (0, "x") 40 | ; CASE 41 | ( [ DUP (0, "y"); DROP (1, "y"); DROP (1, "x"); DROP (1, "f") ] 42 | , [ DUP (2, "f"); DUP (1, "y"); EXEC; DROP (1, "y"); DROP (1, "x"); DROP (1, "f") ] ) 43 | ] ) 44 | ] 45 | in 46 | Alcotest.(check (result string string)) 47 | "compile rec(f).(fun x -> case x (fun y -> y) (fun y -> f y))" 48 | (return expected <&> to_string) 49 | (result <&> to_string) 50 | 51 | let cases = 52 | let open Alcotest in 53 | ( "Lambda Compilation" 54 | , [ test_case "compile O1" `Quick compile_01; test_case "compile O2" `Quick compile_02 ] ) 55 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/11-optimiser/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t00_optimiser_tests) 3 | (libraries alcotest ephel)) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/11-optimiser/t00_optimiser_tests.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.( 3 | run "Optimiser Test" [ T01_basic.cases; T02_sum.cases; T03_pair.cases; T04_lambda.cases ] ) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/11-optimiser/t01_basic.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | open Ephel.Compiler.Optimiser 7 | 8 | open Preface.Result.Monad (struct 9 | type t = string 10 | end) 11 | 12 | let compile s = return s >>= Transpiler.run <&> Expander.run >>= Optimiser.run 13 | 14 | let compile_01 () = 15 | let result = compile (Int 1) 16 | and expected = [ PUSH (INT 1) ] in 17 | Alcotest.(check (result string string)) 18 | "compile 1" 19 | (return expected <&> to_string) 20 | (result <&> to_string) 21 | 22 | let compile_02 () = 23 | let result = compile (Abs ([ "x" ], Var "x")) 24 | and expected = [ LAMBDA ([ "x" ], [ DUP (0, "x"); DROP (1, "x") ]) ] in 25 | Alcotest.(check (result string string)) 26 | "compile fun x -> x" 27 | (return expected <&> to_string) 28 | (result <&> to_string) 29 | 30 | let compile_03 () = 31 | let result = compile (Abs ([ "x" ], Unit)) 32 | and expected = [ LAMBDA ([ "x" ], [ PUSH UNIT; DROP (1, "x") ]) ] in 33 | Alcotest.(check (result string string)) 34 | "compile fun x -> unit" 35 | (return expected <&> to_string) 36 | (result <&> to_string) 37 | 38 | let compile_04 () = 39 | let result = compile (App (Abs ([ "x" ], Var "x"), Int 1)) 40 | and expected = [ PUSH (INT 1) ] in 41 | Alcotest.(check (result string string)) 42 | "compile (fun x -> x) 1" 43 | (return expected <&> to_string) 44 | (result <&> to_string) 45 | 46 | let compile_05 () = 47 | let result = compile (App (Abs ([ "x" ], Unit), Int 1)) 48 | and expected = [ PUSH UNIT ] in 49 | Alcotest.(check (result string string)) 50 | "compile (fun x -> unit) 1" 51 | (return expected <&> to_string) 52 | (result <&> to_string) 53 | 54 | let compile_06 () = 55 | let result = compile (App (App (Abs ([ "x" ], Abs ([ "y" ], Var "y")), Int 1), Int 2)) 56 | and expected = [ PUSH (INT 2) ] in 57 | Alcotest.(check (result string string)) 58 | "compile (fun x y -> y) 1 2" 59 | (return expected <&> to_string) 60 | (result <&> to_string) 61 | 62 | let compile_07 () = 63 | (* PARTIAL APPLICATION *) 64 | let result = compile (App (App (Abs ([ "x" ], Abs ([ "y" ], Var "x")), Int 1), Int 2)) 65 | and expected = [ PUSH (INT 1) ] in 66 | Alcotest.(check (result string string)) 67 | "compile (fun x y -> x) 1 2" 68 | (return expected <&> to_string) 69 | (result <&> to_string) 70 | 71 | (* 72 | let compile_08 () = 73 | let result = compile (Let ("x", Int 1, Var "x")) 74 | and expected = [ PUSH (INT 1) ] in 75 | Alcotest.(check (result string string)) 76 | "compile let x = 1 in x" 77 | (return expected <&> to_string) 78 | (result <&> to_string) 79 | *) 80 | let compile_09 () = 81 | (* PARTIAL APPLICATION *) 82 | let result = compile (Abs ([ "f" ], Abs ([ "x" ], App (Var "f", Var "x")))) 83 | and expected = [ LAMBDA ([ "f" ], [ LAMBDA ([ "x" ], [ DIG (1, "f"); EXEC ]) ]) ] in 84 | Alcotest.(check (result string string)) 85 | "compile (fun f x -> f x)" 86 | (return expected <&> to_string) 87 | (result <&> to_string) 88 | 89 | (* 90 | let compile_10 () = 91 | let result = compile (Abs ([ "f" ], Let ("x", Int 1, App (Var "f", Var "x")))) 92 | and expected = [ LAMBDA ([ "f" ], [ DUP (0, "f"); PUSH (INT 1); EXEC; DROP (1, "f") ]) ] in 93 | Alcotest.(check (result string string)) 94 | "compile (fun f -> let x = 1 in f x)" 95 | (return expected <&> to_string) 96 | (result <&> to_string) 97 | *) 98 | let cases = 99 | let open Alcotest in 100 | ( "Basic Compilation" 101 | , [ 102 | test_case "compile O1" `Quick compile_01 103 | ; test_case "compile O2" `Quick compile_02 104 | ; test_case "compile O3" `Quick compile_03 105 | ; test_case "compile O4" `Quick compile_04 106 | ; test_case "compile O5" `Quick compile_05 107 | ; test_case "compile O6" `Quick compile_06 108 | (*; test_case "compile O7" `Quick compile_07 109 | ; test_case "compile O8" `Quick compile_08 ; test_case "compile O9" `Quick compile_09 110 | ; test_case "compile 10" `Quick compile_10 *) 111 | ] ) 112 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/11-optimiser/t03_pair.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | open Ephel.Compiler.Optimiser 7 | 8 | open Preface.Result.Monad (struct 9 | type t = string 10 | end) 11 | 12 | let compile s = return s >>= Transpiler.run <&> Expander.run >>= Optimiser.run 13 | 14 | let compile_01 () = 15 | let result = compile (Pair (Int 1, Int 2)) 16 | and expected = [ PUSH (INT 2); PUSH (INT 1); PAIR ] in 17 | Alcotest.(check (result string string)) 18 | "compile (1,2)" 19 | (return expected <&> to_string) 20 | (result <&> to_string) 21 | 22 | let compile_02 () = 23 | let result = compile (Fst (Pair (Int 1, Int 2))) 24 | and expected = [ PUSH (INT 1) ] in 25 | Alcotest.(check (result string string)) 26 | "compile fst (1,2)" 27 | (return expected <&> to_string) 28 | (result <&> to_string) 29 | 30 | let compile_03 () = 31 | let result = compile (Snd (Pair (Int 1, Int 2))) 32 | and expected = [ PUSH (INT 2) ] in 33 | Alcotest.(check (result string string)) 34 | "compile snd (1,2)" 35 | (return expected <&> to_string) 36 | (result <&> to_string) 37 | 38 | let compile_04 () = 39 | let result = compile (Abs ([ "p" ], Fst (Var "p"))) 40 | and expected = [ LAMBDA ([ "p" ], [ DUP (0, "p"); FST; DROP (1, "p") ]) ] in 41 | Alcotest.(check (result string string)) 42 | "compile (fun p -> fst p)" 43 | (return expected <&> to_string) 44 | (result <&> to_string) 45 | 46 | let compile_05 () = 47 | let result = compile (Abs ([ "p" ], App (Fst (Var "p"), Snd (Var "p")))) 48 | and expected = 49 | [ LAMBDA ([ "p" ], [ DUP (0, "p"); FST; DUP (1, "p"); SND; EXEC; DROP (1, "p") ]) ] 50 | in 51 | Alcotest.(check (result string string)) 52 | "compile (fun p -> (fst p) (snd p))" 53 | (return expected <&> to_string) 54 | (result <&> to_string) 55 | 56 | let compile_06 () = 57 | let result = compile (Abs ([ "p" ], App (Snd (Var "p"), Fst (Var "p")))) 58 | and expected = 59 | [ LAMBDA ([ "p" ], [ DUP (0, "p"); SND; DUP (1, "p"); FST; EXEC; DROP (1, "p") ]) ] 60 | in 61 | Alcotest.(check (result string string)) 62 | "compile (fun p -> (snd p) (fst p))" 63 | (return expected <&> to_string) 64 | (result <&> to_string) 65 | 66 | let compile_07 () = 67 | let result = compile (Abs ([ "p" ], Pair (Fst (Var "p"), Snd (Var "p")))) 68 | and expected = 69 | [ LAMBDA ([ "p" ], [ DUP (0, "p"); SND; DUP (1, "p"); FST; PAIR; DROP (1, "p") ]) ] 70 | in 71 | Alcotest.(check (result string string)) 72 | "compile (fun p -> (fst p, snd p))" 73 | (return expected <&> to_string) 74 | (result <&> to_string) 75 | 76 | let cases = 77 | let open Alcotest in 78 | ( "Pair Compilation" 79 | , [ 80 | test_case "compile O1" `Quick compile_01 81 | ; test_case "compile 02" `Quick compile_02 82 | ; test_case "compile 03" `Quick compile_03 83 | ; test_case "compile 04" `Quick compile_04 84 | ; test_case "compile 05" `Quick compile_05 85 | ; test_case "compile 06" `Quick compile_06 86 | ; test_case "compile 07" `Quick compile_07 87 | ] ) 88 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/11-optimiser/t04_lambda.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | open Ephel.Compiler.Optimiser 7 | 8 | open Preface.Result.Monad (struct 9 | type t = string 10 | end) 11 | 12 | let compile s = return s >>= Transpiler.run <&> Expander.run >>= Optimiser.run 13 | 14 | let compile_01 () = 15 | let result = compile (Rec ("f", Abs ([ "x" ], App (Var "f", Var "x")))) 16 | and expected = 17 | [ 18 | LAMBDA_REC ("f", [ "x" ], [ DUP (1, "f"); DUP (1, "x"); EXEC; DROP (1, "x"); DROP (1, "f") ]) 19 | ] 20 | in 21 | Alcotest.(check (result string string)) 22 | "compile rec(f).(fun x -> f x)" 23 | (return expected <&> to_string) 24 | (result <&> to_string) 25 | 26 | let compile_02 () = 27 | let result = 28 | compile 29 | (Rec 30 | ( "f" 31 | , Abs 32 | ([ "x" ], Case (Var "x", Abs ([ "y" ], Var "y"), Abs ([ "y" ], App (Var "f", Var "y")))) 33 | ) ) 34 | and expected = 35 | [ 36 | LAMBDA_REC 37 | ( "f" 38 | , [ "x" ] 39 | , [ 40 | DUP (0, "x") 41 | ; CASE 42 | ( [ DUP (0, "y"); DROP (1, "y"); DROP (1, "x"); DROP (1, "f") ] 43 | , [ DUP (2, "f"); DUP (1, "y"); EXEC; DROP (1, "y"); DROP (1, "x"); DROP (1, "f") ] ) 44 | ] ) 45 | ] 46 | in 47 | Alcotest.(check (result string string)) 48 | "compile rec(f).(fun x -> case x (fun y -> y) (fun y -> f y))" 49 | (return expected <&> to_string) 50 | (result <&> to_string) 51 | 52 | let cases = 53 | let open Alcotest in 54 | ( "Lambda Compilation" 55 | , [ test_case "compile O1" `Quick compile_01; test_case "compile O2" `Quick compile_02 ] ) 56 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/12-normaliser/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t00_normaliser_tests) 3 | (libraries alcotest ephel)) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/12-normaliser/t00_normaliser_tests.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.( 3 | run "Simplifier Test" [ T01_basic.cases; T02_sum.cases; T03_pair.cases; T04_lambda.cases ] ) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/12-normaliser/t01_basic.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | open Ephel.Compiler.Optimiser 7 | open Ephel.Compiler.Simplifier 8 | open Ephel.Compiler.Normaliser 9 | 10 | open Preface.Result.Monad (struct 11 | type t = string 12 | end) 13 | 14 | let compile s = 15 | return s 16 | >>= Transpiler.run 17 | <&> Expander.run 18 | >>= Optimiser.run 19 | <&> Simplifier.run 20 | <&> Normaliser.run 21 | 22 | let compile_01 () = 23 | let result = compile (Int 1) 24 | and expected = [ PUSH (INT 1) ] in 25 | Alcotest.(check (result string string)) 26 | "compile 1" 27 | (return expected <&> to_string) 28 | (result <&> to_string) 29 | 30 | let compile_02 () = 31 | let result = compile (Abs ([ "x" ], Var "x")) 32 | and expected = [ LAMBDA ([ "x" ], []) ] in 33 | Alcotest.(check (result string string)) 34 | "compile fun x -> x" 35 | (return expected <&> to_string) 36 | (result <&> to_string) 37 | 38 | let compile_03 () = 39 | let result = compile (Abs ([ "x" ], Unit)) 40 | and expected = [ LAMBDA ([ "x" ], [ DROP (0, "x"); PUSH UNIT ]) ] in 41 | Alcotest.(check (result string string)) 42 | "compile fun x -> unit" 43 | (return expected <&> to_string) 44 | (result <&> to_string) 45 | 46 | let compile_04 () = 47 | let result = compile (App (Abs ([ "x" ], Var "x"), Int 1)) 48 | and expected = [ PUSH (INT 1) ] in 49 | Alcotest.(check (result string string)) 50 | "compile (fun x -> x) 1" 51 | (return expected <&> to_string) 52 | (result <&> to_string) 53 | 54 | let compile_05 () = 55 | let result = compile (App (Abs ([ "x" ], Unit), Int 1)) 56 | and expected = [ PUSH UNIT ] in 57 | Alcotest.(check (result string string)) 58 | "compile (fun x -> unit) 1" 59 | (return expected <&> to_string) 60 | (result <&> to_string) 61 | 62 | let compile_06 () = 63 | let result = compile (App (App (Abs ([ "x" ], Abs ([ "y" ], Var "y")), Int 1), Int 2)) 64 | and expected = [ PUSH (INT 2) ] in 65 | Alcotest.(check (result string string)) 66 | "compile (fun x y -> y) 1 2" 67 | (return expected <&> to_string) 68 | (result <&> to_string) 69 | 70 | let compile_07 () = 71 | (* PARTIAL APPLICATION *) 72 | let result = compile (App (App (Abs ([ "x" ], Abs ([ "y" ], Var "x")), Int 1), Int 2)) 73 | and expected = [ PUSH (INT 1) ] in 74 | Alcotest.(check (result string string)) 75 | "compile (fun x y -> x) 1 2" 76 | (return expected <&> to_string) 77 | (result <&> to_string) 78 | 79 | (* 80 | let compile_08 () = 81 | let result = compile (Let ("x", Int 1, Var "x")) 82 | and expected = [ PUSH (INT 1) ] in 83 | Alcotest.(check (result string string)) 84 | "compile let x = 1 in x" 85 | (return expected <&> to_string) 86 | (result <&> to_string) 87 | *) 88 | let compile_09 () = 89 | (* PARTIAL APPLICATION *) 90 | let result = compile (Abs ([ "f" ], Abs ([ "x" ], App (Var "f", Var "x")))) 91 | and expected = [ LAMBDA ([ "f" ], [ LAMBDA ([ "x" ], [ DIG (1, "f"); EXEC ]) ]) ] in 92 | Alcotest.(check (result string string)) 93 | "compile (fun f x -> f x)" 94 | (return expected <&> to_string) 95 | (result <&> to_string) 96 | 97 | (* 98 | let compile_10 () = 99 | let result = compile (Abs ([ "f" ], Let ("x", Int 1, App (Var "f", Var "x")))) 100 | and expected = [ LAMBDA ([ "f" ], [ PUSH (INT 1); EXEC ]) ] in 101 | Alcotest.(check (result string string)) 102 | "compile (fun f -> let x = 1 in f x)" 103 | (return expected <&> to_string) 104 | (result <&> to_string) 105 | *) 106 | let cases = 107 | let open Alcotest in 108 | ( "Basic Compilation" 109 | , [ 110 | test_case "compile O1" `Quick compile_01 111 | ; test_case "compile O2" `Quick compile_02 112 | ; test_case "compile O3" `Quick compile_03 113 | ; test_case "compile O4" `Quick compile_04 114 | ; test_case "compile O5" `Quick compile_05 115 | ; test_case "compile O6" `Quick compile_06 116 | (*; test_case "compile O7" `Quick compile_07 117 | ; test_case "compile O8" `Quick compile_08 ; test_case "compile O9" `Quick compile_09 118 | ; test_case "compile 10" `Quick compile_10*) 119 | ] ) 120 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/12-normaliser/t03_pair.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | open Ephel.Compiler.Optimiser 7 | open Ephel.Compiler.Simplifier 8 | open Ephel.Compiler.Normaliser 9 | 10 | open Preface.Result.Monad (struct 11 | type t = string 12 | end) 13 | 14 | let compile s = 15 | return s 16 | >>= Transpiler.run 17 | <&> Expander.run 18 | >>= Optimiser.run 19 | <&> Simplifier.run 20 | <&> Normaliser.run 21 | 22 | let compile_01 () = 23 | let result = compile (Pair (Int 1, Int 2)) 24 | and expected = [ PUSH (INT 2); PUSH (INT 1); PAIR ] in 25 | Alcotest.(check (result string string)) 26 | "compile (1,2)" 27 | (return expected <&> to_string) 28 | (result <&> to_string) 29 | 30 | let compile_02 () = 31 | let result = compile (Fst (Pair (Int 1, Int 2))) 32 | and expected = [ PUSH (INT 1) ] in 33 | Alcotest.(check (result string string)) 34 | "compile fst (1,2)" 35 | (return expected <&> to_string) 36 | (result <&> to_string) 37 | 38 | let compile_03 () = 39 | let result = compile (Snd (Pair (Int 1, Int 2))) 40 | and expected = [ PUSH (INT 2) ] in 41 | Alcotest.(check (result string string)) 42 | "compile snd (1,2)" 43 | (return expected <&> to_string) 44 | (result <&> to_string) 45 | 46 | let compile_04 () = 47 | let result = compile (Abs ([ "p" ], Fst (Var "p"))) 48 | and expected = [ LAMBDA ([ "p" ], [ FST ]) ] in 49 | Alcotest.(check (result string string)) 50 | "compile (fun p -> fst p)" 51 | (return expected <&> to_string) 52 | (result <&> to_string) 53 | 54 | let compile_05 () = 55 | let result = compile (Abs ([ "p" ], App (Fst (Var "p"), Snd (Var "p")))) 56 | and expected = [ LAMBDA ([ "p" ], [ UNPAIR; SWAP; EXEC ]) ] in 57 | Alcotest.(check (result string string)) 58 | "compile (fun p -> (fst p) (snd p))" 59 | (return expected <&> to_string) 60 | (result <&> to_string) 61 | 62 | let compile_06 () = 63 | let result = compile (Abs ([ "p" ], App (Snd (Var "p"), Fst (Var "p")))) 64 | and expected = [ LAMBDA ([ "p" ], [ UNPAIR; EXEC ]) ] in 65 | Alcotest.(check (result string string)) 66 | "compile (fun p -> (snd p) (fst p))" 67 | (return expected <&> to_string) 68 | (result <&> to_string) 69 | 70 | let compile_07 () = 71 | let result = compile (Abs ([ "p" ], Pair (Fst (Var "p"), Snd (Var "p")))) 72 | and expected = [ LAMBDA ([ "p" ], []) ] in 73 | Alcotest.(check (result string string)) 74 | "compile (fun p -> (fst p, snd p))" 75 | (return expected <&> to_string) 76 | (result <&> to_string) 77 | 78 | let cases = 79 | let open Alcotest in 80 | ( "Pair Compilation" 81 | , [ 82 | test_case "compile O1" `Quick compile_01 83 | ; test_case "compile 02" `Quick compile_02 84 | ; test_case "compile 03" `Quick compile_03 85 | ; test_case "compile 04" `Quick compile_04 86 | ; test_case "compile 05" `Quick compile_05 87 | ; test_case "compile 06" `Quick compile_06 88 | ; test_case "compile 07" `Quick compile_07 89 | ] ) 90 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/12-normaliser/t04_lambda.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | open Ephel.Compiler.Optimiser 7 | open Ephel.Compiler.Simplifier 8 | open Ephel.Compiler.Normaliser 9 | 10 | open Preface.Result.Monad (struct 11 | type t = string 12 | end) 13 | 14 | let compile s = 15 | return s 16 | >>= Transpiler.run 17 | <&> Expander.run 18 | >>= Optimiser.run 19 | <&> Simplifier.run 20 | <&> Normaliser.run 21 | 22 | let compile_01 () = 23 | let result = compile (Rec ("f", Abs ([ "x" ], App (Var "f", Var "x")))) 24 | and expected = [ LAMBDA_REC ("f", [ "x" ], [ EXEC ]) ] in 25 | Alcotest.(check (result string string)) 26 | "compile rec(f).(fun x -> f x)" 27 | (return expected <&> to_string) 28 | (result <&> to_string) 29 | 30 | let compile_02 () = 31 | let result = 32 | compile 33 | (Rec 34 | ( "f" 35 | , Abs 36 | ([ "x" ], Case (Var "x", Abs ([ "y" ], Var "y"), Abs ([ "y" ], App (Var "f", Var "y")))) 37 | ) ) 38 | and expected = 39 | [ 40 | LAMBDA_REC 41 | ( "f" 42 | , [ "x" ] 43 | , [ DUP (0, "x"); CASE ([ DROP (1, "x"); DROP (1, "f") ], [ DROP (1, "x"); EXEC ]) ] ) 44 | ] 45 | in 46 | Alcotest.(check (result string string)) 47 | "compile rec(f).(fun x -> case x (fun y -> y) (fun y -> f y))" 48 | (return expected <&> to_string) 49 | (result <&> to_string) 50 | 51 | let cases = 52 | let open Alcotest in 53 | ( "Lambda Compilation" 54 | , [ test_case "compile O1" `Quick compile_01; test_case "compile O2" `Quick compile_02 ] ) 55 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/13-simplifier/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t00_simplifier_tests) 3 | (libraries alcotest ephel)) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/13-simplifier/t00_simplifier_tests.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.( 3 | run "Simplifier Test" [ T01_basic.cases; T02_sum.cases; T03_pair.cases; T04_lambda.cases ] ) 4 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/13-simplifier/t01_basic.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | open Ephel.Compiler.Optimiser 7 | open Ephel.Compiler.Simplifier 8 | 9 | open Preface.Result.Monad (struct 10 | type t = string 11 | end) 12 | 13 | let compile s = return s >>= Transpiler.run <&> Expander.run >>= Optimiser.run <&> Simplifier.run 14 | 15 | let compile_01 () = 16 | let result = compile (Int 1) 17 | and expected = [ PUSH (INT 1) ] in 18 | Alcotest.(check (result string string)) 19 | "compile 1" 20 | (return expected <&> to_string) 21 | (result <&> to_string) 22 | 23 | let compile_02 () = 24 | let result = compile (Abs ([ "x" ], Var "x")) 25 | and expected = [ LAMBDA ([ "x" ], []) ] in 26 | Alcotest.(check (result string string)) 27 | "compile fun x -> x" 28 | (return expected <&> to_string) 29 | (result <&> to_string) 30 | 31 | let compile_03 () = 32 | let result = compile (Abs ([ "x" ], Unit)) 33 | and expected = [ LAMBDA ([ "x" ], [ DROP (0, "x"); PUSH UNIT ]) ] in 34 | Alcotest.(check (result string string)) 35 | "compile fun x -> unit" 36 | (return expected <&> to_string) 37 | (result <&> to_string) 38 | 39 | let compile_04 () = 40 | let result = compile (App (Abs ([ "x" ], Var "x"), Int 1)) 41 | and expected = [ PUSH (INT 1) ] in 42 | Alcotest.(check (result string string)) 43 | "compile (fun x -> x) 1" 44 | (return expected <&> to_string) 45 | (result <&> to_string) 46 | 47 | let compile_05 () = 48 | let result = compile (App (Abs ([ "x" ], Unit), Int 1)) 49 | and expected = [ PUSH UNIT ] in 50 | Alcotest.(check (result string string)) 51 | "compile (fun x -> unit) 1" 52 | (return expected <&> to_string) 53 | (result <&> to_string) 54 | 55 | let compile_06 () = 56 | let result = compile (App (App (Abs ([ "x" ], Abs ([ "y" ], Var "y")), Int 1), Int 2)) 57 | and expected = [ PUSH (INT 2) ] in 58 | Alcotest.(check (result string string)) 59 | "compile (fun x y -> y) 1 2" 60 | (return expected <&> to_string) 61 | (result <&> to_string) 62 | 63 | let compile_07 () = 64 | (* PARTIAL APPLICATION *) 65 | let result = compile (App (App (Abs ([ "x" ], Abs ([ "y" ], Var "x")), Int 1), Int 2)) 66 | and expected = [ PUSH (INT 1) ] in 67 | Alcotest.(check (result string string)) 68 | "compile (fun x y -> x) 1 2" 69 | (return expected <&> to_string) 70 | (result <&> to_string) 71 | 72 | (* 73 | let compile_08 () = 74 | let result = compile (Let ("x", Int 1, Var "x")) 75 | and expected = [ PUSH (INT 1) ] in 76 | Alcotest.(check (result string string)) 77 | "compile let x = 1 in x" 78 | (return expected <&> to_string) 79 | (result <&> to_string) 80 | *) 81 | let compile_09 () = 82 | (* PARTIAL APPLICATION *) 83 | let result = compile (Abs ([ "f" ], Abs ([ "x" ], App (Var "f", Var "x")))) 84 | and expected = [ LAMBDA ([ "f" ], [ LAMBDA ([ "x" ], [ DIG (1, "f"); EXEC ]) ]) ] in 85 | Alcotest.(check (result string string)) 86 | "compile (fun f x -> f x)" 87 | (return expected <&> to_string) 88 | (result <&> to_string) 89 | 90 | (* 91 | let compile_10 () = 92 | let result = compile (Abs ([ "f" ], Let ("x", Int 1, App (Var "f", Var "x")))) 93 | and expected = [ LAMBDA ([ "f" ], [ PUSH (INT 1); EXEC ]) ] in 94 | Alcotest.(check (result string string)) 95 | "compile (fun f -> let x = 1 in f x)" 96 | (return expected <&> to_string) 97 | (result <&> to_string) 98 | *) 99 | let cases = 100 | let open Alcotest in 101 | ( "Basic Compilation" 102 | , [ 103 | test_case "compile O1" `Quick compile_01 104 | ; test_case "compile O2" `Quick compile_02 105 | ; test_case "compile O3" `Quick compile_03 106 | ; test_case "compile O4" `Quick compile_04 107 | ; test_case "compile O5" `Quick compile_05 108 | ; test_case "compile O6" `Quick compile_06 109 | (*; test_case "compile O7" `Quick compile_07 110 | ; test_case "compile O8" `Quick compile_08 ; test_case "compile O9" `Quick compile_09 111 | ; test_case "compile 10" `Quick compile_10 *) 112 | ] ) 113 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/13-simplifier/t03_pair.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | open Ephel.Compiler.Optimiser 7 | open Ephel.Compiler.Simplifier 8 | 9 | open Preface.Result.Monad (struct 10 | type t = string 11 | end) 12 | 13 | let compile s = return s >>= Transpiler.run <&> Expander.run >>= Optimiser.run <&> Simplifier.run 14 | 15 | let compile_01 () = 16 | let result = compile (Pair (Int 1, Int 2)) 17 | and expected = [ PUSH (INT 2); PUSH (INT 1); PAIR ] in 18 | Alcotest.(check (result string string)) 19 | "compile (1,2)" 20 | (return expected <&> to_string) 21 | (result <&> to_string) 22 | 23 | let compile_02 () = 24 | let result = compile (Fst (Pair (Int 1, Int 2))) 25 | and expected = [ PUSH (INT 1) ] in 26 | Alcotest.(check (result string string)) 27 | "compile fst (1,2)" 28 | (return expected <&> to_string) 29 | (result <&> to_string) 30 | 31 | let compile_03 () = 32 | let result = compile (Snd (Pair (Int 1, Int 2))) 33 | and expected = [ PUSH (INT 2) ] in 34 | Alcotest.(check (result string string)) 35 | "compile snd (1,2)" 36 | (return expected <&> to_string) 37 | (result <&> to_string) 38 | 39 | let compile_04 () = 40 | let result = compile (Abs ([ "p" ], Fst (Var "p"))) 41 | and expected = [ LAMBDA ([ "p" ], [ FST ]) ] in 42 | Alcotest.(check (result string string)) 43 | "compile (fun p -> fst p)" 44 | (return expected <&> to_string) 45 | (result <&> to_string) 46 | 47 | let compile_05 () = 48 | let result = compile (Abs ([ "p" ], App (Fst (Var "p"), Snd (Var "p")))) 49 | and expected = [ LAMBDA ([ "p" ], [ UNPAIR; SWAP; EXEC ]) ] in 50 | Alcotest.(check (result string string)) 51 | "compile (fun p -> (fst p) (snd p))" 52 | (return expected <&> to_string) 53 | (result <&> to_string) 54 | 55 | let compile_06 () = 56 | let result = compile (Abs ([ "p" ], App (Snd (Var "p"), Fst (Var "p")))) 57 | and expected = [ LAMBDA ([ "p" ], [ UNPAIR; EXEC ]) ] in 58 | Alcotest.(check (result string string)) 59 | "compile (fun p -> (snd p) (fst p))" 60 | (return expected <&> to_string) 61 | (result <&> to_string) 62 | 63 | let compile_07 () = 64 | let result = compile (Abs ([ "p" ], Pair (Fst (Var "p"), Snd (Var "p")))) 65 | and expected = [ LAMBDA ([ "p" ], []) ] in 66 | Alcotest.(check (result string string)) 67 | "compile (fun p -> (fst p, snd p))" 68 | (return expected <&> to_string) 69 | (result <&> to_string) 70 | 71 | let cases = 72 | let open Alcotest in 73 | ( "Pair Compilation" 74 | , [ 75 | test_case "compile O1" `Quick compile_01 76 | ; test_case "compile 02" `Quick compile_02 77 | ; test_case "compile 03" `Quick compile_03 78 | ; test_case "compile 04" `Quick compile_04 79 | ; test_case "compile 05" `Quick compile_05 80 | ; test_case "compile 06" `Quick compile_06 81 | ; test_case "compile 07" `Quick compile_07 82 | ] ) 83 | -------------------------------------------------------------------------------- /stage/v0/test/2-compiler/13-simplifier/t04_lambda.ml: -------------------------------------------------------------------------------- 1 | open Ephel.Compiler.Ast.Term 2 | open Ephel.Compiler.Objcode.Objcode 3 | open Ephel.Compiler.Objcode.Render 4 | open Ephel.Compiler.Transpiler 5 | open Ephel.Compiler.Expander 6 | open Ephel.Compiler.Optimiser 7 | open Ephel.Compiler.Simplifier 8 | 9 | open Preface.Result.Monad (struct 10 | type t = string 11 | end) 12 | 13 | let compile s = return s >>= Transpiler.run <&> Expander.run >>= Optimiser.run <&> Simplifier.run 14 | 15 | let compile_01 () = 16 | let result = compile (Rec ("f", Abs ([ "x" ], App (Var "f", Var "x")))) 17 | and expected = [ LAMBDA_REC ("f", [ "x" ], [ EXEC ]) ] in 18 | Alcotest.(check (result string string)) 19 | "compile rec(f).(fun x -> f x)" 20 | (return expected <&> to_string) 21 | (result <&> to_string) 22 | 23 | let compile_02 () = 24 | let result = 25 | compile 26 | (Rec 27 | ( "f" 28 | , Abs 29 | ([ "x" ], Case (Var "x", Abs ([ "y" ], Var "y"), Abs ([ "y" ], App (Var "f", Var "y")))) 30 | ) ) 31 | and expected = 32 | [ 33 | LAMBDA_REC 34 | ( "f" 35 | , [ "x" ] 36 | , [ DUP (0, "x"); CASE ([ DROP (1, "x"); DROP (1, "f") ], [ DROP (1, "x"); EXEC ]) ] ) 37 | ] 38 | in 39 | Alcotest.(check (result string string)) 40 | "compile rec(f).(fun x -> case x (fun y -> y) (fun y -> f y))" 41 | (return expected <&> to_string) 42 | (result <&> to_string) 43 | 44 | let cases = 45 | let open Alcotest in 46 | ( "Lambda Compilation" 47 | , [ test_case "compile O1" `Quick compile_01; test_case "compile O2" `Quick compile_02 ] ) 48 | --------------------------------------------------------------------------------