├── examples ├── list.fp ├── unbound-var.fp ├── intermediate-functions.fp ├── last.fp ├── IP.fp ├── bu.fp ├── mm.fp ├── const.fp ├── null.fp ├── id.fp ├── composition.fp ├── eq.fp ├── fact.fp ├── construction.fp ├── atom.fp ├── reverse.fp ├── condition.fp ├── while.fp ├── length.fp ├── applyToAll.fp ├── rotate.fp ├── dist.fp ├── nth.fp ├── and-or-not.fp ├── transpose.fp └── append.fp ├── tasty ├── data │ ├── construction-input.fp │ ├── primitives │ │ ├── and-input.fp │ │ ├── not-input.fp │ │ ├── and-output.fp │ │ ├── const-input.fp │ │ ├── not-output.fp │ │ ├── const-output.fp │ │ ├── id-input.fp │ │ ├── length-output.fp │ │ ├── rotate-input.fp │ │ ├── apndl-input.fp │ │ ├── apndl-output.fp │ │ ├── apndr-input.fp │ │ ├── apndr-output.fp │ │ ├── id-output.fp │ │ ├── or-output.fp │ │ ├── atom-input.fp │ │ ├── atom-output.fp │ │ ├── nth-output.fp │ │ ├── or-input.fp │ │ ├── rotate-output.fp │ │ ├── transpose-input.fp │ │ ├── distribution-input.fp │ │ ├── length-input.fp │ │ ├── transpose-output.fp │ │ ├── reverse-input.fp │ │ ├── reverse-output.fp │ │ ├── eq-output.fp │ │ ├── null-output.fp │ │ ├── distribution-output.fp │ │ ├── nth-input.fp │ │ ├── eq-input.fp │ │ └── null-input.fp │ ├── 2-combinators │ │ ├── composition-output.fp │ │ ├── bu-output.fp │ │ ├── bu-input.fp │ │ ├── composition-input.fp │ │ ├── while-output.fp │ │ └── while-input.fp │ ├── construction-output.fp │ ├── 1-combinators │ │ ├── applyToAll-input.fp │ │ └── applyToAll-output.fp │ ├── condition-output.fp │ └── condition-input.fp └── Main.hs ├── bin ├── repl ├── test ├── run └── hoogle ├── app └── Main.hs ├── shell.nix ├── doctest └── Main.hs ├── fourmolu.yaml ├── hie.yaml ├── .gitignore ├── garnix.yaml ├── treefmt.toml ├── src ├── Fp │ ├── Width.hs │ ├── Value.hs │ ├── Input.hs │ ├── Import.hs │ ├── Interpret.hs │ ├── Location.hs │ ├── Pretty.hs │ ├── REPL.hs │ ├── Lexer.hs │ ├── Normalize.hs │ ├── Syntax.hs │ └── Parser.hs └── Fp.hs ├── .github └── workflows │ ├── update-flake-lock.yaml │ ├── ci.yaml │ └── haskell.yml ├── LICENSE ├── flake.nix ├── package.yaml ├── fp.cabal ├── flake.lock └── README.md /examples/list.fp: -------------------------------------------------------------------------------- 1 | <1, 2, 3, 4, 5.2> -------------------------------------------------------------------------------- /tasty/data/construction-input.fp: -------------------------------------------------------------------------------- 1 | [+, *, ÷, eq]:<6, 3> -------------------------------------------------------------------------------- /tasty/data/primitives/and-input.fp: -------------------------------------------------------------------------------- 1 | ∧: 2 | ∧: -------------------------------------------------------------------------------- /tasty/data/primitives/not-input.fp: -------------------------------------------------------------------------------- 1 | ¬:T 2 | ¬:F 3 | -------------------------------------------------------------------------------- /tasty/data/2-combinators/composition-output.fp: -------------------------------------------------------------------------------- 1 | 65 2 | 3 | -------------------------------------------------------------------------------- /tasty/data/construction-output.fp: -------------------------------------------------------------------------------- 1 | < 9, 18, 2, F > 2 | 3 | -------------------------------------------------------------------------------- /tasty/data/primitives/and-output.fp: -------------------------------------------------------------------------------- 1 | T 2 | 3 | F 4 | 5 | -------------------------------------------------------------------------------- /tasty/data/primitives/const-input.fp: -------------------------------------------------------------------------------- 1 | _1:<1,2,3> 2 | _A:⌽ -------------------------------------------------------------------------------- /tasty/data/primitives/not-output.fp: -------------------------------------------------------------------------------- 1 | F 2 | 3 | T 4 | 5 | -------------------------------------------------------------------------------- /tasty/data/1-combinators/applyToAll-input.fp: -------------------------------------------------------------------------------- 1 | α+:<<1,2>, <3,4>> -------------------------------------------------------------------------------- /tasty/data/1-combinators/applyToAll-output.fp: -------------------------------------------------------------------------------- 1 | < 3, 7 > 2 | 3 | -------------------------------------------------------------------------------- /tasty/data/condition-output.fp: -------------------------------------------------------------------------------- 1 | 4 2 | 3 | < 1, 2 > 4 | 5 | -------------------------------------------------------------------------------- /tasty/data/primitives/const-output.fp: -------------------------------------------------------------------------------- 1 | 1 2 | 3 | A 4 | 5 | -------------------------------------------------------------------------------- /tasty/data/2-combinators/bu-output.fp: -------------------------------------------------------------------------------- 1 | 2 2 | 3 | < 1, 2, 3, 4 > 4 | 5 | -------------------------------------------------------------------------------- /tasty/data/condition-input.fp: -------------------------------------------------------------------------------- 1 | (eq → +; id):<2,2> 2 | 3 | eq → +; id:<1,2> -------------------------------------------------------------------------------- /tasty/data/primitives/id-input.fp: -------------------------------------------------------------------------------- 1 | id:<1,2,3> 2 | 3 | id:⌽ 4 | 5 | id:⊥ -------------------------------------------------------------------------------- /tasty/data/primitives/length-output.fp: -------------------------------------------------------------------------------- 1 | 3 2 | 3 | 0 4 | 5 | ⊥ 6 | 7 | -------------------------------------------------------------------------------- /tasty/data/primitives/rotate-input.fp: -------------------------------------------------------------------------------- 1 | rotl:<1,2,3> 2 | 3 | rotr:<1,2,3> -------------------------------------------------------------------------------- /examples/unbound-var.fp: -------------------------------------------------------------------------------- 1 | -- `fn` is not bound to anything! 2 | fn:<1,2,3> 3 | -------------------------------------------------------------------------------- /tasty/data/2-combinators/bu-input.fp: -------------------------------------------------------------------------------- 1 | (bu + 1):1 2 | 3 | (bu apndl 1):<2,3,4> -------------------------------------------------------------------------------- /tasty/data/primitives/apndl-input.fp: -------------------------------------------------------------------------------- 1 | apndl:<6, ⌽> 2 | apndl:<6, <1,2,3>> 3 | -------------------------------------------------------------------------------- /tasty/data/primitives/apndl-output.fp: -------------------------------------------------------------------------------- 1 | < 6 > 2 | 3 | < 6, 1, 2, 3 > 4 | 5 | -------------------------------------------------------------------------------- /tasty/data/primitives/apndr-input.fp: -------------------------------------------------------------------------------- 1 | apndr:<⌽, 6> 2 | apndr:<<1,2,3>, 6> 3 | -------------------------------------------------------------------------------- /tasty/data/primitives/apndr-output.fp: -------------------------------------------------------------------------------- 1 | < 6 > 2 | 3 | < 1, 2, 3, 6 > 4 | 5 | -------------------------------------------------------------------------------- /tasty/data/primitives/id-output.fp: -------------------------------------------------------------------------------- 1 | < 1, 2, 3 > 2 | 3 | ⌽ 4 | 5 | ⊥ 6 | 7 | -------------------------------------------------------------------------------- /tasty/data/primitives/or-output.fp: -------------------------------------------------------------------------------- 1 | T 2 | 3 | T 4 | 5 | T 6 | 7 | F 8 | 9 | -------------------------------------------------------------------------------- /tasty/data/2-combinators/composition-input.fp: -------------------------------------------------------------------------------- 1 | /+∘α(bu + 1):<1,2,3,4,5,6,7,8,9,10> -------------------------------------------------------------------------------- /tasty/data/primitives/atom-input.fp: -------------------------------------------------------------------------------- 1 | atom:A 2 | atom:+ 3 | atom:1 4 | atom:<1,2,3> -------------------------------------------------------------------------------- /tasty/data/primitives/atom-output.fp: -------------------------------------------------------------------------------- 1 | T 2 | 3 | F 4 | 5 | T 6 | 7 | F 8 | 9 | -------------------------------------------------------------------------------- /tasty/data/primitives/nth-output.fp: -------------------------------------------------------------------------------- 1 | 3 2 | 3 | ⊥ 4 | 5 | 3 6 | 7 | 2 8 | 9 | -------------------------------------------------------------------------------- /tasty/data/primitives/or-input.fp: -------------------------------------------------------------------------------- 1 | ∨: 2 | ∨: 3 | ∨: 4 | ∨: 5 | -------------------------------------------------------------------------------- /tasty/data/primitives/rotate-output.fp: -------------------------------------------------------------------------------- 1 | < 2, 3, 1 > 2 | 3 | < 3, 1, 2 > 4 | 5 | -------------------------------------------------------------------------------- /tasty/data/primitives/transpose-input.fp: -------------------------------------------------------------------------------- 1 | ⍉:< < 1, 2, 3 >, < 4, 5, 6 >, < 7, 8, 9 > > -------------------------------------------------------------------------------- /bin/repl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -xe 3 | 4 | exec nix develop -i -c cabal -- repl -------------------------------------------------------------------------------- /tasty/data/2-combinators/while-output.fp: -------------------------------------------------------------------------------- 1 | < 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 > 2 | 3 | -------------------------------------------------------------------------------- /tasty/data/primitives/distribution-input.fp: -------------------------------------------------------------------------------- 1 | distl:<1, <2, 2>> 2 | 3 | distr:<<2, 2>, 3> -------------------------------------------------------------------------------- /tasty/data/primitives/length-input.fp: -------------------------------------------------------------------------------- 1 | length:<1,2,3> 2 | 3 | length:⌽ 4 | 5 | length:⊥ -------------------------------------------------------------------------------- /examples/intermediate-functions.fp: -------------------------------------------------------------------------------- 1 | Def Plus = + 2 | 3 | Def Sum = /Plus 4 | 5 | Sum:<1,2,3> -------------------------------------------------------------------------------- /tasty/data/primitives/transpose-output.fp: -------------------------------------------------------------------------------- 1 | < < 1, 4, 7 >, < 2, 5, 8 >, < 3, 6, 9 > > 2 | 3 | -------------------------------------------------------------------------------- /tasty/data/primitives/reverse-input.fp: -------------------------------------------------------------------------------- 1 | reverse:<1,2> 2 | reverse:<3,4> 3 | reverse:<> 4 | reverse:⊥ -------------------------------------------------------------------------------- /tasty/data/primitives/reverse-output.fp: -------------------------------------------------------------------------------- 1 | < 2, 1 > 2 | 3 | < 4, 3 > 4 | 5 | ⌽ 6 | 7 | ⊥ 8 | 9 | -------------------------------------------------------------------------------- /tasty/data/primitives/eq-output.fp: -------------------------------------------------------------------------------- 1 | T 2 | 3 | T 4 | 5 | T 6 | 7 | F 8 | 9 | F 10 | 11 | -------------------------------------------------------------------------------- /tasty/data/primitives/null-output.fp: -------------------------------------------------------------------------------- 1 | T 2 | 3 | T 4 | 5 | F 6 | 7 | F 8 | 9 | ⊥ 10 | 11 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Fp 4 | 5 | main :: IO () 6 | main = Fp.main 7 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (builtins.getFlake ("git+file://" + toString ./.)).devShells.${builtins.currentSystem}.default 2 | -------------------------------------------------------------------------------- /tasty/data/primitives/distribution-output.fp: -------------------------------------------------------------------------------- 1 | < < 1, 2 >, < 1, 2 > > 2 | 3 | < < 2, 3 >, < 2, 3 > > 4 | 5 | -------------------------------------------------------------------------------- /tasty/data/primitives/nth-input.fp: -------------------------------------------------------------------------------- 1 | ~2:<1,2,3> 2 | 3 | ~5:<1,2,3> 4 | 5 | 0~:<1,2,3> 6 | 7 | 1~:<1,2,3> -------------------------------------------------------------------------------- /bin/test: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -xe 3 | 4 | exec nix develop -i -c ghcid -c "cabal repl test:tasty" -T :main -------------------------------------------------------------------------------- /tasty/data/primitives/eq-input.fp: -------------------------------------------------------------------------------- 1 | eq: 2 | eq:<1, 1> 3 | eq:<<1,2>,<1,2>> 4 | eq: 5 | eq:<<1,2>,<2,1>> -------------------------------------------------------------------------------- /examples/last.fp: -------------------------------------------------------------------------------- 1 | -- get the last element of a sequence. 2 | 3 | Def last ≡ ~0∘reverse 4 | 5 | last:<1,2,3> 6 | 7 | -------------------------------------------------------------------------------- /bin/run: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -xe 3 | 4 | exec nix develop -i -c ghcid -c "cabal repl exe:fp" --warnings -T :main -------------------------------------------------------------------------------- /doctest/Main.hs: -------------------------------------------------------------------------------- 1 | import qualified Test.DocTest 2 | 3 | main :: IO () 4 | main = Test.DocTest.doctest ["--fast", "src"] 5 | -------------------------------------------------------------------------------- /examples/IP.fp: -------------------------------------------------------------------------------- 1 | {- Implementation of 'inner product'. 2 | -} 3 | 4 | Def ip ≡ /+∘α*∘⍉ 5 | 6 | ip:<<1,2,3>,<6,5,4>> 7 | -------------------------------------------------------------------------------- /bin/hoogle: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -xe 3 | 4 | echo http://127.0.0.1:8888 5 | exec nix develop -i -c hoogle serve -p 8888 --local -------------------------------------------------------------------------------- /tasty/data/primitives/null-input.fp: -------------------------------------------------------------------------------- 1 | null:⌽ 2 | 3 | null:<> 4 | 5 | null:<1,2> 6 | 7 | null:A 8 | 9 | null:⊥ 10 | 11 | -------------------------------------------------------------------------------- /examples/bu.fp: -------------------------------------------------------------------------------- 1 | {- Binary to unary. 2 | 3 | rules: 4 | 5 | (bu f x):y ≡ f: 6 | 7 | examples: 8 | 9 | (bu + 1):1 -- 2 10 | -} 11 | 12 | (bu + 1):1 13 | 14 | -------------------------------------------------------------------------------- /tasty/data/2-combinators/while-input.fp: -------------------------------------------------------------------------------- 1 | Def eq0 ≡ eq ∘ [ id, _0 ] 2 | Def sub1 ≡ - ∘ [ id, _1 ] 3 | 4 | Def hd = (atom → id; ~0) 5 | 6 | Def iota = flatten ∘ while (not ∘ eq0 ∘ ~0) [sub1 . hd, id] 7 | 8 | iota:10 -------------------------------------------------------------------------------- /examples/mm.fp: -------------------------------------------------------------------------------- 1 | {- Implementation of 'matrix multiplication'. 2 | -} 3 | 4 | Def ip ≡ /+∘α*∘⍉ 5 | 6 | Def mm ≡ α(α ip) ∘ α distl ∘ distr ∘ [~0, ⍉∘~1] 7 | 8 | mm:< < <1,2>, <4,5> >, 9 | < <6,8>, <7,9>> > 10 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | comma-style: leading 3 | record-brace-space: true 4 | indent-wheres: true 5 | diff-friendly-import-export: true 6 | respectful: true 7 | haddock-style: multi-line 8 | newlines-between-decls: 1 -------------------------------------------------------------------------------- /examples/const.fp: -------------------------------------------------------------------------------- 1 | {- `const` is the constant function. 2 | 3 | rules: 4 | 5 | _x:y ≡ x; 6 | 7 | Examples: 8 | 9 | _1:<1,2,3> -- 1 10 | _A:⌽ -- A 11 | -} 12 | 13 | _1:<1,2,3> 14 | _A:⌽ 15 | 16 | -------------------------------------------------------------------------------- /examples/null.fp: -------------------------------------------------------------------------------- 1 | {- rules: 2 | 3 | null:x ≡ x = ⌽ -> T; x != ⊥ -> F; ⊥ 4 | 5 | Examples: 6 | 7 | null:⌽ -- T 8 | null:<> -- T 9 | null:<1,2> -- F 10 | null:A -- F 11 | null:⊥ -- ⊥ 12 | -} 13 | 14 | null:⌽ 15 | -------------------------------------------------------------------------------- /examples/id.fp: -------------------------------------------------------------------------------- 1 | {- `id` is the identity function. 2 | 3 | rules: 4 | 5 | id:x ≡ x 6 | 7 | Examples: 8 | 9 | id:<1,2,3> -- <1,2,3> 10 | id:⌽ -- ⌽ 11 | id:⊥ -- ⊥ 12 | -} 13 | 14 | id:<1,2,3> 15 | 16 | id:⌽ 17 | 18 | id:⊥ 19 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "app" 4 | component: "exe:fp" 5 | - path: "tasty" 6 | component: "test:tasty" 7 | - path: "doctest" 8 | component: "test:doctest" 9 | - path: "src" 10 | component: "lib:fp" 11 | -------------------------------------------------------------------------------- /examples/composition.fp: -------------------------------------------------------------------------------- 1 | {- function composition (∘) is an essential part of `fp`. 2 | It's by far the most used 'combining form'. 3 | 4 | Def ip ≡ /+∘α*∘⍉ 5 | 6 | rules: 7 | (g∘f):x ≡ g:(f:x) 8 | 9 | -} 10 | 11 | /+∘α(bu + 1):<1,2,3,4,5,6,7,8,9,10> 12 | -------------------------------------------------------------------------------- /examples/eq.fp: -------------------------------------------------------------------------------- 1 | {- rules: 2 | 3 | eq:x ≡ x= & y = z -> T; x= &y != z -> F; ⊥ 4 | 5 | Examples: 6 | 7 | eq: -- T 8 | eq:<1, 1> -- T 9 | eq:<<1,2>,<1,2>> -- T 10 | eq: -- F 11 | eq:<<1,2>,<2,1>> -- F 12 | -} 13 | 14 | eq:<1, 1> 15 | -------------------------------------------------------------------------------- /examples/fact.fp: -------------------------------------------------------------------------------- 1 | {- Here we calculate factorials. Yay! 2 | -} 3 | 4 | Def eq0 ≡ eq ∘ [ id, _0 ] 5 | Def sub1 ≡ - ∘ [ id, _1 ] 6 | Def hd ≡ (atom → id; ~0) 7 | Def iota ≡ flatten ∘ while (not ∘ eq0 ∘ ~0) [sub1 ∘ hd, id] 8 | 9 | Def fact ≡ /* ∘ tl ∘ iota 10 | 11 | fact:10 12 | 13 | -------------------------------------------------------------------------------- /examples/construction.fp: -------------------------------------------------------------------------------- 1 | {- rules: 2 | 3 | [f1, ..., fn]:x ≡ 4 | 5 | Examples: 6 | 7 | [+, *, ÷, eq]:<6, 3> -- <9, 18, 2, F> 8 | 9 | -- since... 10 | -- <(6 + 3 = 9), (6 * 3 = 18), (6 ÷ 3 = 2), (eq:<6,3> = F)> 11 | 12 | -} 13 | 14 | [+, *, ÷, eq]:<6, 3> 15 | -------------------------------------------------------------------------------- /examples/atom.fp: -------------------------------------------------------------------------------- 1 | {- `atom` is a primitive, which returns true (T), when 2 | givea any valid atom as an argument, otherwise will 3 | yield false (F). `atom` is bottom preserving. 4 | Eg. atom:⊥ = ⊥ 5 | 6 | rules: 7 | 8 | atom:x = x is an atom -> T; x != ⊥ -> F; ⊥ 9 | 10 | -} 11 | 12 | atom:A 13 | -------------------------------------------------------------------------------- /examples/reverse.fp: -------------------------------------------------------------------------------- 1 | {- rules: 2 | 3 | reverse:x ≡ x = ⌽ -> ⌽; 4 | x = -> 5 | ⊥ 6 | 7 | Examples: 8 | 9 | reverse:⌽ -- ⌽ 10 | reverse:<1,2> -- <2,1> 11 | -} 12 | 13 | -- for about `α` see `examples/applyToAll`. 14 | 15 | α reverse:<<1,2>,<3,4>> 16 | -------------------------------------------------------------------------------- /examples/condition.fp: -------------------------------------------------------------------------------- 1 | {- rules: 2 | 3 | (p → f; g):x ≡ (p:x) = T → f:x; 4 | (p:x) = F → g:x; 5 | ⊥; 6 | 7 | Examples: 8 | 9 | (eq → +; id):<2,2> -- 4 10 | -- since 11 | -- (eq:<2,2> = T) 12 | -- -> +:<2,2> 13 | -} 14 | 15 | (eq → +; id):<2,2> 16 | 17 | eq → +; id:<1,2> 18 | 19 | -------------------------------------------------------------------------------- /examples/while.fp: -------------------------------------------------------------------------------- 1 | {- `while` 2 | 3 | rules: 4 | 5 | (while p f):x ≡ p:x = T -> (while p f):(f:x); 6 | p:x = F -> x; 7 | ⊥; 8 | -} 9 | 10 | Def eq0 ≡ eq ∘ [ id, _0 ] 11 | Def sub1 ≡ - ∘ [ id, _1 ] 12 | 13 | Def hd = (atom → id; ~0) 14 | 15 | Def iota = flatten ∘ while (not ∘ eq0 ∘ ~0) [sub1 . hd, id] 16 | 17 | iota:10 18 | 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .ghc.environment.* 23 | website/js/all.min.js 24 | result 25 | .history 26 | -------------------------------------------------------------------------------- /garnix.yaml: -------------------------------------------------------------------------------- 1 | builds: 2 | include: 3 | - "packages.x86_64-linux.*" 4 | - "packages.aarch64-darwin.*" 5 | - "checks.x86_64-linux.*" 6 | - "checks.aarch64-darwin.*" 7 | - "devShells.x86_64-linux.default" 8 | - "devShells.aarch64-darwin.default" 9 | exclude: 10 | # https://github.com/srid/haskell-flake/issues/21 11 | - "checks.*.default-hls" 12 | - "packages.*.check" -------------------------------------------------------------------------------- /examples/length.fp: -------------------------------------------------------------------------------- 1 | {- `length` computes the lenght of a given sequence. 2 | It is bottom preserving. 3 | 4 | rules: 5 | 6 | distl:x ≡ x = ⌽ -> 0; 7 | x = -> n; 8 | ⊥; 9 | 10 | Examples: 11 | 12 | length:<1,2,3> -- 3 13 | length:⌽ -- 0 14 | length:⊥ -- ⊥ 15 | -} 16 | 17 | length:<1,2,3> 18 | 19 | length:⌽ 20 | 21 | length:⊥ 22 | -------------------------------------------------------------------------------- /examples/applyToAll.fp: -------------------------------------------------------------------------------- 1 | {- applyToAll (α) applies a function `f` to all elements in 2 | given a sequence. This functions is known as a `map` in 3 | many programming languages. 4 | 5 | rules: 6 | 7 | αf:x ≡ x = ⌽ -> ⌽; 8 | x = -> 9 | 10 | Examples: 11 | 12 | α+:<<1,2>, <3,4>> -- <3, 7> 13 | α+:⌽ -- ⌽ 14 | -} 15 | 16 | α+:<<1,2>, <3,4>> 17 | -------------------------------------------------------------------------------- /treefmt.toml: -------------------------------------------------------------------------------- 1 | [formatter.haskell] 2 | command = "fourmolu" 3 | options = [ 4 | "--ghc-opt", 5 | "-XTypeApplications", 6 | "--mode", 7 | "inplace", 8 | "--check-idempotence", 9 | ] 10 | includes = ["*.hs"] 11 | 12 | [formatter.nix] 13 | command = "nixpkgs-fmt" 14 | includes = ["*.nix"] 15 | 16 | [formatter.cabal] 17 | command = "cabal-fmt" 18 | options = ["--inplace"] 19 | includes = ["*.cabal"] 20 | -------------------------------------------------------------------------------- /examples/rotate.fp: -------------------------------------------------------------------------------- 1 | {- `rotl` and `rotr` 2 | 3 | rules: 4 | 5 | rotl:x ≡ x = ⌽ -> ⌽; 6 | x = -> ; 7 | ⊥; 8 | 9 | rotr:x ≡ x = ⌽ -> ⌽; 10 | x = -> ; 11 | ⊥; 12 | 13 | Examples: 14 | 15 | rotl:<1,2,3> -- <2,3,1> 16 | 17 | rotr:<1,2,3> -- <3,1,2> 18 | -} 19 | 20 | rotl:<1,2,3> 21 | 22 | rotr:<1,2,3> 23 | 24 | -------------------------------------------------------------------------------- /examples/dist.fp: -------------------------------------------------------------------------------- 1 | {- `distl` and `distr` 2 | 3 | rules: 4 | 5 | distl:x ≡ x = -> ⌽; 6 | x = > -> < .... , >; ⊥" 7 | 8 | distr:x ≡ x = <⌽,y> -> ⌽; 9 | x = <, z> -> < .... , >; ⊥" 10 | 11 | 12 | Examples: 13 | 14 | distl:<1, <2, 2>> -- <<1, 2>, <1, 2>> 15 | distr:<<2, 2>, 1> -- <<2, 1>, <2, 1>> 16 | -} 17 | 18 | distl:<1, <2, 2>> 19 | 20 | distr:<<2, 2>, 3> 21 | -------------------------------------------------------------------------------- /examples/nth.fp: -------------------------------------------------------------------------------- 1 | {- computes the nth element of a given sequence. 2 | It is bottom preserving. 3 | 4 | rules: 5 | 6 | ~n:x ≡ n > length:x -> ⊥; 7 | -> xn; 8 | ⊥; 9 | 10 | 0~:x ≡ x = -> xn-1; 11 | ⊥; 12 | 13 | Examples: 14 | 15 | ~2:<1,2,3> -- 3 16 | ~5:<1,2,3> -- ⊥ 17 | 18 | 0~:<1,2,3> -- 3 19 | 1~:<1,2,3> -- 2 20 | -} 21 | 22 | ~2:<1,2,3> 23 | 24 | ~5:<1,2,3> 25 | 26 | 0~:<1,2,3> 27 | 28 | 1~:<1,2,3> 29 | -------------------------------------------------------------------------------- /examples/and-or-not.fp: -------------------------------------------------------------------------------- 1 | {- `and`, `or` and `not` boolean algebra 2 | 3 | rules: 4 | 5 | Def ip ≡ /+∘α*∘⍉ 6 | 7 | ∧:x ≡ x = -> T; 8 | x = or -> F; 9 | ⊥ 10 | 11 | ∨:x ≡ x = or or -> T; 12 | x = -> F; 13 | ⊥ 14 | 15 | ¬:x ≡ x = T -> F; 16 | x = F -> T; 17 | ⊥ 18 | 19 | -} 20 | 21 | ∧: 22 | ∧: 23 | 24 | ∨: 25 | ∨: 26 | ∨: 27 | ∨: 28 | 29 | ¬:T 30 | ¬:F 31 | -------------------------------------------------------------------------------- /examples/transpose.fp: -------------------------------------------------------------------------------- 1 | {- transpose (⍉) swaps the given input matrices 2 | rows and columns. 3 | 4 | rules: 5 | 6 | trans:x ≡ x≡<<> ..... <>> -> <>; 7 | X≡ "-> ; j" 8 | 9 | where 10 | xi≡ 11 | yi≡, 1 <= i <= n, 12 | 1 <= j <= m. 13 | 14 | note: 15 | 16 | xs ≡ ⍉∘⍉:xs 17 | 18 | -} 19 | 20 | ⍉:< < 1, 2, 3 >, < 4, 5, 6 >, < 7, 8, 9 > > 21 | 22 | -- this will yield 23 | -- < < 1, 4, 7 >, < 2, 5, 8 >, < 3, 6, 9 > > 24 | -------------------------------------------------------------------------------- /src/Fp/Width.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | module Fp.Width ( 4 | -- * Width 5 | getWidth, 6 | defaultWidth, 7 | ) where 8 | 9 | import System.Console.Terminal.Size (Window (..)) 10 | 11 | import qualified System.Console.Terminal.Size as Size 12 | 13 | -- | Get the width of the terminal (in columns). 14 | getWidth :: IO Int 15 | getWidth = do 16 | maybeWindow <- Size.size 17 | pure $ case maybeWindow of 18 | Nothing -> defaultWidth 19 | Just Window {width} -> width 20 | 21 | -- | The default width to use 22 | defaultWidth :: Int 23 | defaultWidth = 80 24 | -------------------------------------------------------------------------------- /examples/append.fp: -------------------------------------------------------------------------------- 1 | {- `apndl` and `apndr` 2 | 3 | rules: 4 | 5 | apndl:x ≡ x = -> ; 6 | x = > -> ; 7 | ⊥; 8 | 9 | apndr:x ≡ x = <⌽,y> -> ; 10 | x = <, y> -> ; 11 | ⊥; 12 | 13 | Examples: 14 | 15 | apndl:<6, ⌽> -- <6> 16 | apndl:<6, <1,2,3>> -- <6,1,2,3> 17 | 18 | apndr:<⌽, 6> -- <6> 19 | apndr:<<1,2,3>, 6> -- <1,2,3,6> 20 | -} 21 | 22 | apndl:<6, ⌽> 23 | apndl:<6, <1,2,3>> 24 | 25 | apndr:<⌽, 6> 26 | apndr:<<1,2,3>, 6> 27 | 28 | -------------------------------------------------------------------------------- /.github/workflows/update-flake-lock.yaml: -------------------------------------------------------------------------------- 1 | name: update-flake-lock 2 | on: 3 | workflow_dispatch: # allows manual triggering 4 | schedule: 5 | - cron: '0 0 * * 0' # runs weekly on Sunday at 00:00 6 | 7 | jobs: 8 | lockfile: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - name: Checkout repository 12 | uses: actions/checkout@v2 13 | - name: Install Nix 14 | uses: cachix/install-nix-action@v17 15 | with: 16 | extra_nix_config: | 17 | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} 18 | - name: Update flake.lock 19 | uses: DeterminateSystems/update-flake-lock@v10 20 | with: 21 | pr-title: "Update flake.lock" # Title of PR to be created 22 | pr-labels: | # Labels to be set on the PR 23 | automated 24 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: "CI" 2 | on: 3 | # Run only when pushing to main branch, and making PRs 4 | push: 5 | branches: 6 | - main 7 | pull_request: 8 | jobs: 9 | build: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v2 13 | - uses: cachix/install-nix-action@v17 14 | with: 15 | extra_nix_config: | 16 | experimental-features = nix-command flakes 17 | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} 18 | - name: Cache Nix dependencies 19 | run: | 20 | nix develop -j 4 -c echo 21 | # - name: Flake checks 22 | # run: | 23 | # # Sandbox must be disabled due to HLS, 24 | # # https://github.com/haskell/haskell-language-server/issues/3128 25 | # nix --option sandbox false build .#check --no-link -L 26 | # TODO: Remove after https://github.com/srid/haskell-flake/issues/19 27 | - name: Hlint 28 | run: | 29 | nix develop -j auto -c hlint src 30 | - name: Build 31 | id: build 32 | run: | 33 | nix build -j auto -L 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Joona Piirainen 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. -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ "main" ] 6 | pull_request: 7 | branches: [ "main" ] 8 | 9 | permissions: 10 | contents: read 11 | 12 | jobs: 13 | build: 14 | 15 | runs-on: ubuntu-latest 16 | 17 | steps: 18 | - uses: actions/checkout@v3 19 | - uses: actions/setup-haskell@v1 20 | with: 21 | ghc-version: '8.10.3' 22 | cabal-version: '3.2' 23 | 24 | - name: Cache 25 | uses: actions/cache@v3 26 | env: 27 | cache-name: cache-cabal 28 | with: 29 | path: ~/.cabal 30 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 31 | restore-keys: | 32 | ${{ runner.os }}-build-${{ env.cache-name }}- 33 | ${{ runner.os }}-build- 34 | ${{ runner.os }}- 35 | 36 | - name: Install dependencies 37 | run: | 38 | cabal update 39 | cabal build --only-dependencies --enable-tests --enable-benchmarks 40 | - name: Build 41 | run: cabal build --enable-tests --enable-benchmarks all 42 | - name: Run tests 43 | run: cabal test all 44 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "japiirainen/fp: fp programming language"; 3 | inputs = { 4 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; 5 | flake-parts.url = "github:hercules-ci/flake-parts"; 6 | flake-parts.inputs.nixpkgs.follows = "nixpkgs"; 7 | haskell-flake.url = "github:srid/haskell-flake"; 8 | treefmt-flake.url = "github:srid/treefmt-flake"; 9 | check-flake.url = "github:srid/check-flake"; 10 | }; 11 | 12 | outputs = inputs@{ self, nixpkgs, flake-parts, ... }: 13 | flake-parts.lib.mkFlake { inherit self; } { 14 | systems = nixpkgs.lib.systems.flakeExposed; 15 | imports = [ 16 | inputs.haskell-flake.flakeModule 17 | inputs.treefmt-flake.flakeModule 18 | inputs.check-flake.flakeModule 19 | ]; 20 | perSystem = { self', config, pkgs, ... }: { 21 | haskellProjects.default = { 22 | root = ./.; 23 | name = "fp"; 24 | buildTools = hp: { 25 | inherit (pkgs) 26 | treefmt; 27 | } // config.treefmt.formatters; 28 | }; 29 | treefmt.formatters = { 30 | inherit (pkgs) 31 | nixpkgs-fmt; 32 | inherit (pkgs.haskellPackages) 33 | cabal-fmt 34 | fourmolu; 35 | }; 36 | }; 37 | }; 38 | } 39 | -------------------------------------------------------------------------------- /src/Fp/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | {- | This module contains the `Value` type used internally for efficient 5 | evaluation of expressions 6 | -} 7 | module Fp.Value ( 8 | -- * Value 9 | Value (..), 10 | 11 | -- * Helpers 12 | shouldShow, 13 | ) where 14 | 15 | import Data.Text (Text) 16 | import Fp.Syntax (Atom, Combinator1, Combinator2, Primitive) 17 | 18 | {- | This type represents a fully evaluated expression with no reducible 19 | sub-expressions 20 | There are two benefits to using a type separate from the surface syntax for 21 | this purpose: 22 | * To avoid wastefully reducing the same sub-expression multiple times 23 | * To use a more efficient representation for reduction purposes 24 | -} 25 | data Value 26 | = Variable Text 27 | | Application Value Value 28 | | List [Value] 29 | | Construction [Value] 30 | | Atom Atom 31 | | Bottom 32 | | Primitive Primitive 33 | | If Value Value Value 34 | | Combinator1 Combinator1 Value 35 | | Combinator2 Combinator2 Value Value 36 | deriving stock (Eq, Show) 37 | 38 | {- | determines weather or not we should show this 39 | `Value` to the user when the program is ran. 40 | -} 41 | shouldShow :: Value -> Bool 42 | shouldShow = \case 43 | Variable _ -> True 44 | List _ -> True 45 | Atom _ -> True 46 | Bottom -> True 47 | Construction _ -> False 48 | Application _ _ -> False 49 | Primitive _ -> False 50 | Combinator1 _ _ -> False 51 | If {} -> False 52 | Combinator2 {} -> False 53 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: fp 2 | version: 0.0.0 3 | description: fp language 4 | maintainer: Joona Piirainen 5 | github: japiirainen/fp 6 | 7 | ghc-options: 8 | - -Wall 9 | 10 | default-extensions: 11 | - TypeApplications 12 | - OverloadedStrings 13 | 14 | library: 15 | source-dirs: src 16 | exposed-modules: 17 | - Fp 18 | - Fp.Lexer 19 | - Fp.Parser 20 | - Fp.Location 21 | - Fp.Syntax 22 | - Fp.Input 23 | - Fp.Import 24 | - Fp.Normalize 25 | - Fp.Interpret 26 | - Fp.Value 27 | - Fp.REPL 28 | - Fp.Width 29 | - Fp.Pretty 30 | dependencies: 31 | - base 32 | - megaparsec 33 | - parser-combinators 34 | - text 35 | - mtl 36 | - microlens 37 | - microlens-th 38 | - containers 39 | - unordered-containers 40 | - modern-uri 41 | - safe-exceptions 42 | - scientific 43 | - Earley 44 | - filepath 45 | - prettyprinter 46 | - prettyprinter-ansi-terminal 47 | - optparse-applicative 48 | - haskeline 49 | - ansi-terminal 50 | - repline 51 | - terminal-size 52 | 53 | executable: 54 | main: Main.hs 55 | source-dirs: app 56 | dependencies: 57 | - base 58 | - fp 59 | 60 | tests: 61 | tasty: 62 | source-dirs: tasty 63 | main: Main.hs 64 | dependencies: 65 | - base 66 | - fp 67 | - directory 68 | - filepath 69 | - mtl 70 | - prettyprinter 71 | - safe-exceptions 72 | - tasty 73 | - tasty-hunit 74 | - tasty-silver 75 | - text 76 | doctest: 77 | main: Main.hs 78 | source-dirs: doctest 79 | dependencies: 80 | - base 81 | - fp 82 | - doctest 83 | -------------------------------------------------------------------------------- /src/Fp/Input.hs: -------------------------------------------------------------------------------- 1 | -- | This module contains the functions and types that power to URI-base imports 2 | module Fp.Input ( 3 | -- * InputInput(..) 4 | Input (..), 5 | ) where 6 | 7 | import Data.List.NonEmpty (NonEmpty (..)) 8 | import Data.Text (Text) 9 | import System.FilePath (()) 10 | 11 | import qualified Data.Text as Text 12 | import qualified System.FilePath as FilePath 13 | import qualified Text.URI as URI 14 | 15 | {- | Input to the interpreter. 16 | You should prefer to use `Path` if possible (for better error messages and 17 | correctly handling transitive imports). The `Code` constructor is intended 18 | for cases like interpreting code read from standard input. 19 | -} 20 | data Input 21 | = -- | The path to the code 22 | Path FilePath 23 | | -- | Source code: @Code name content@ 24 | Code String Text 25 | | URI URI.URI 26 | deriving (Eq, Show) 27 | 28 | instance Semigroup Input where 29 | _ <> URI uri = URI uri 30 | _ <> Code name code = Code name code 31 | Code _ _ <> Path child = Path child 32 | Path parent <> Path child = Path (FilePath.takeDirectory parent child) 33 | URI parent <> Path child 34 | | FilePath.isRelative child 35 | , Just uri <- URI.relativeTo childURI parent = 36 | URI uri 37 | | otherwise = 38 | Path child 39 | where 40 | uriPath = do 41 | c : cs <- traverse (URI.mkPathPiece . Text.pack) (FilePath.splitPath child) 42 | 43 | return (FilePath.hasTrailingPathSeparator child, c :| cs) 44 | 45 | childURI = 46 | URI.URI 47 | { URI.uriScheme = Nothing 48 | , URI.uriAuthority = Left False 49 | , URI.uriPath = uriPath 50 | , URI.uriQuery = [] 51 | , URI.uriFragment = Nothing 52 | } 53 | -------------------------------------------------------------------------------- /src/Fp/Import.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | This module contains the import resolution logic 6 | module Fp.Import ( 7 | -- * Import resolution 8 | resolve, 9 | 10 | -- * Exceptions 11 | ImportError (..), 12 | ) where 13 | 14 | import Control.Exception.Safe (Exception (..)) 15 | import Data.Bifunctor (first) 16 | import Data.Text (Text) 17 | import Fp.Input (Input (..)) 18 | import Fp.Location (Location (..)) 19 | import Fp.Syntax (Syntax) 20 | 21 | import qualified Control.Exception.Safe as Exception 22 | import qualified Data.Text as Text 23 | import qualified Data.Text.IO as Text.IO 24 | import qualified Fp.Parser as Parser 25 | import qualified Text.URI as URI 26 | 27 | -- | Resolve an `Input` by returning the source code that it represents 28 | resolve :: Input -> IO [Syntax Location Input] 29 | resolve input = case input of 30 | URI _ -> throw "URI import not implemented!" 31 | Path path -> readPath path 32 | Code name code -> do 33 | result <- case Parser.parse name code of 34 | Left e -> Exception.throw e 35 | Right result -> return result 36 | 37 | let locate offset = Location {..} 38 | 39 | return $ map (first locate) result 40 | where 41 | readPath path = do 42 | code <- Text.IO.readFile path 43 | result <- case Parser.parse path code of 44 | Left e -> Exception.throw e 45 | Right result -> return result 46 | let locate offset = Location {name = path, ..} 47 | return $ map (first locate) result 48 | 49 | throw e = Exception.throw (ImportError input e) 50 | 51 | -- | The base error for `ImportError` (without the @input@ information) 52 | 53 | -- | Errors related to import resolution 54 | data ImportError = ImportError 55 | { input :: Input 56 | , message :: Text 57 | } 58 | deriving stock (Show) 59 | 60 | instance Exception ImportError where 61 | displayException ImportError {..} = 62 | Text.unpack 63 | ( "Import resolution failed: " 64 | <> renderedInput 65 | <> "\n\ 66 | \\n\ 67 | \" 68 | <> message 69 | ) 70 | where 71 | renderedInput = case input of 72 | URI uri -> URI.render uri 73 | Path path -> Text.pack path 74 | Code _ _ -> "(input)" 75 | -------------------------------------------------------------------------------- /src/Fp/Interpret.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | 5 | -- | This module implements the main interpretation function 6 | module Fp.Interpret ( 7 | -- * Interpret 8 | Input (..), 9 | interpret, 10 | interpretWith, 11 | 12 | -- * Errors related to interpretation 13 | InterpretError (..), 14 | ) where 15 | 16 | import Control.Exception.Safe (Exception (..), Handler (..)) 17 | import Control.Monad.Except (MonadError (..)) 18 | import Control.Monad.IO.Class (MonadIO, liftIO) 19 | import Data.Map (Map) 20 | import Data.Text (Text) 21 | import Fp.Input (Input (..)) 22 | import Fp.Value (Value) 23 | 24 | import qualified Control.Exception.Safe as Exception 25 | import qualified Control.Monad.Except as Except 26 | import qualified Fp.Import as Import 27 | import qualified Fp.Lexer as Parser 28 | import qualified Fp.Normalize as Normalize 29 | 30 | {- | Interpret `fp` source code, return the inferred type and the evaluated 31 | result 32 | This is the top-level function for the `fp` interpreter 33 | -} 34 | interpret :: 35 | (MonadError InterpretError m, MonadIO m) => 36 | Input -> 37 | m ([Value], Map Text Value) 38 | interpret = interpretWith mempty 39 | 40 | -- | Like `interpret`, but accepts a custom `Map` of bindings 41 | interpretWith :: 42 | (MonadError InterpretError m, MonadIO m) => 43 | -- | Custom bindings (evaluation environment) 44 | Map Text Value -> 45 | -- | Input program 46 | Input -> 47 | m ([Value], Map Text Value) 48 | interpretWith bindings input = do 49 | eitherPartiallyResolved <- do 50 | liftIO 51 | ( Exception.catches 52 | (fmap Right (Import.resolve input)) 53 | [ Handler (return . Left . ParseError) 54 | , Handler (return . Left . ImportError) 55 | ] 56 | ) 57 | 58 | resolved <- case eitherPartiallyResolved of 59 | Left interpretError -> throwError interpretError 60 | Right resolved -> pure resolved 61 | 62 | case Normalize.evaluate bindings resolved of 63 | Left message -> Except.throwError (EvaluationError message) 64 | Right res -> pure res 65 | 66 | -- | Errors related to interpretation of an expression 67 | data InterpretError 68 | = ImportError Import.ImportError 69 | | ParseError Parser.ParseError 70 | | EvaluationError Normalize.EvaluationError 71 | deriving stock (Show) 72 | 73 | instance Exception InterpretError where 74 | displayException (ImportError e) = displayException e 75 | displayException (ParseError e) = displayException e 76 | displayException (EvaluationError e) = displayException e 77 | -------------------------------------------------------------------------------- /src/Fp/Location.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | {- | This module contains the `Location` type, which is used to for attaching 7 | source locations to error messages. 8 | -} 9 | module Fp.Location ( 10 | -- * Location 11 | Location (..), 12 | Offset (..), 13 | renderError, 14 | ) where 15 | 16 | import Data.Text (Text) 17 | import Text.Megaparsec (PosState (..), SourcePos (..)) 18 | 19 | import qualified Data.Text as Text 20 | import qualified Text.Megaparsec.Pos as Pos 21 | import qualified Text.Megaparsec.Stream as Stream 22 | 23 | -- | Offsets are stored in characters (0-indexed) 24 | newtype Offset = Offset {getOffset :: Int} 25 | deriving newtype (Eq, Num, Show) 26 | 27 | data Location = Location 28 | { name :: String 29 | -- ^ The file or name describing where the code came from 30 | , code :: Text 31 | -- ^ The original source code (the entire file) 32 | -- NOTE: 33 | -- This will not always be the same for each `Location` because 34 | -- different subexpressions might originate from different files if 35 | -- they were imported. 36 | , offset :: Offset 37 | -- ^ The offset within the code (in characters). 38 | } 39 | deriving stock (Eq, Show) 40 | 41 | -- | Render an error message, given a `Location` for the error. 42 | renderError :: Text -> Location -> Text 43 | renderError message Location {..} = prefix <> "\n" <> suffix 44 | where 45 | initialState = 46 | PosState 47 | { pstateInput = code 48 | , pstateOffset = 0 49 | , pstateSourcePos = Pos.initialPos name 50 | , pstateTabWidth = Pos.defaultTabWidth 51 | , pstateLinePrefix = "" 52 | } 53 | (h, state) = Stream.reachOffset (getOffset offset) initialState 54 | pos = pstateSourcePos state 55 | line = Pos.unPos (sourceLine pos) 56 | column = Pos.unPos (sourceColumn pos) 57 | suffix = 58 | case h of 59 | Just string -> 60 | let lineText = Text.pack (show line) 61 | inner = lineText <> " |" 62 | outer = Text.replicate (Text.length lineText) " " <> " |" 63 | caret = Text.replicate (column - 1) " " <> "↑" 64 | in outer 65 | <> "\n\ 66 | \" 67 | <> inner 68 | <> " " 69 | <> Text.pack string 70 | <> "\n\ 71 | \" 72 | <> outer 73 | <> " " 74 | <> caret 75 | Nothing -> "" 76 | prefix = 77 | Text.pack name 78 | <> ":" 79 | <> Text.pack (show line) 80 | <> ":" 81 | <> Text.pack (show column) 82 | <> ": " 83 | <> message 84 | -------------------------------------------------------------------------------- /fp.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.6. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: fp 8 | version: 0.0.0 9 | description: fp language 10 | homepage: https://github.com/japiirainen/fp#readme 11 | bug-reports: https://github.com/japiirainen/fp/issues 12 | maintainer: Joona Piirainen 13 | license: MIT 14 | license-file: LICENSE 15 | build-type: Simple 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/japiirainen/fp 20 | 21 | library 22 | exposed-modules: 23 | Fp 24 | Fp.Import 25 | Fp.Input 26 | Fp.Interpret 27 | Fp.Lexer 28 | Fp.Location 29 | Fp.Normalize 30 | Fp.Parser 31 | Fp.Pretty 32 | Fp.REPL 33 | Fp.Syntax 34 | Fp.Value 35 | Fp.Width 36 | 37 | other-modules: Paths_fp 38 | hs-source-dirs: src 39 | default-extensions: 40 | OverloadedStrings 41 | TypeApplications 42 | 43 | ghc-options: -Wall 44 | build-depends: 45 | ansi-terminal 46 | , base 47 | , containers 48 | , Earley 49 | , filepath 50 | , haskeline 51 | , megaparsec 52 | , microlens 53 | , microlens-th 54 | , modern-uri 55 | , mtl 56 | , optparse-applicative 57 | , parser-combinators 58 | , prettyprinter 59 | , prettyprinter-ansi-terminal 60 | , repline 61 | , safe-exceptions 62 | , scientific 63 | , terminal-size 64 | , text 65 | , unordered-containers 66 | 67 | default-language: Haskell2010 68 | 69 | executable fp 70 | main-is: Main.hs 71 | other-modules: Paths_fp 72 | hs-source-dirs: app 73 | default-extensions: 74 | OverloadedStrings 75 | TypeApplications 76 | 77 | ghc-options: -Wall 78 | build-depends: 79 | base 80 | , fp 81 | 82 | default-language: Haskell2010 83 | 84 | test-suite doctest 85 | type: exitcode-stdio-1.0 86 | main-is: Main.hs 87 | other-modules: Paths_fp 88 | hs-source-dirs: doctest 89 | default-extensions: 90 | OverloadedStrings 91 | TypeApplications 92 | 93 | ghc-options: -Wall 94 | build-depends: 95 | base 96 | , doctest 97 | , fp 98 | 99 | default-language: Haskell2010 100 | 101 | test-suite tasty 102 | type: exitcode-stdio-1.0 103 | main-is: Main.hs 104 | other-modules: Paths_fp 105 | hs-source-dirs: tasty 106 | default-extensions: 107 | OverloadedStrings 108 | TypeApplications 109 | 110 | ghc-options: -Wall 111 | build-depends: 112 | base 113 | , directory 114 | , filepath 115 | , fp 116 | , mtl 117 | , prettyprinter 118 | , safe-exceptions 119 | , tasty 120 | , tasty-hunit 121 | , tasty-silver 122 | , text 123 | 124 | default-language: Haskell2010 125 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "check-flake": { 4 | "locked": { 5 | "lastModified": 1662502605, 6 | "narHash": "sha256-jAT55UhabAxLAVGanxjnNdzH2/oX2ZjLsL4i2jPIP+g=", 7 | "owner": "srid", 8 | "repo": "check-flake", 9 | "rev": "48a17393ed4fcd523399d6602c283775b5127295", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "srid", 14 | "repo": "check-flake", 15 | "type": "github" 16 | } 17 | }, 18 | "flake-parts": { 19 | "inputs": { 20 | "nixpkgs-lib": "nixpkgs-lib" 21 | }, 22 | "locked": { 23 | "lastModified": 1666885127, 24 | "narHash": "sha256-uXA/3lhLhwOTBMn9a5zJODKqaRT+SuL5cpEmOz2ULoo=", 25 | "owner": "hercules-ci", 26 | "repo": "flake-parts", 27 | "rev": "0e101dbae756d35a376a5e1faea532608e4a4b9a", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "hercules-ci", 32 | "repo": "flake-parts", 33 | "type": "github" 34 | } 35 | }, 36 | "haskell-flake": { 37 | "locked": { 38 | "lastModified": 1666647145, 39 | "narHash": "sha256-Jzmm+BhUai/r8Qo2ZXYUnW3OIcy36OcMWNLPC7dF68E=", 40 | "owner": "srid", 41 | "repo": "haskell-flake", 42 | "rev": "2ef06a73fef2856fb5d0f5a8a7a4fef964e0d94f", 43 | "type": "github" 44 | }, 45 | "original": { 46 | "owner": "srid", 47 | "repo": "haskell-flake", 48 | "type": "github" 49 | } 50 | }, 51 | "nixpkgs": { 52 | "locked": { 53 | "lastModified": 1667639549, 54 | "narHash": "sha256-frqZKSG/933Ctwl9voSZnXDwo8CqddXcjQhnCzwNqaM=", 55 | "owner": "nixos", 56 | "repo": "nixpkgs", 57 | "rev": "cae3751e9f74eea29c573d6c2f14523f41c2821a", 58 | "type": "github" 59 | }, 60 | "original": { 61 | "owner": "nixos", 62 | "ref": "nixpkgs-unstable", 63 | "repo": "nixpkgs", 64 | "type": "github" 65 | } 66 | }, 67 | "nixpkgs-lib": { 68 | "locked": { 69 | "dir": "lib", 70 | "lastModified": 1665349835, 71 | "narHash": "sha256-UK4urM3iN80UXQ7EaOappDzcisYIuEURFRoGQ/yPkug=", 72 | "owner": "NixOS", 73 | "repo": "nixpkgs", 74 | "rev": "34c5293a71ffdb2fe054eb5288adc1882c1eb0b1", 75 | "type": "github" 76 | }, 77 | "original": { 78 | "dir": "lib", 79 | "owner": "NixOS", 80 | "ref": "nixos-unstable", 81 | "repo": "nixpkgs", 82 | "type": "github" 83 | } 84 | }, 85 | "root": { 86 | "inputs": { 87 | "check-flake": "check-flake", 88 | "flake-parts": "flake-parts", 89 | "haskell-flake": "haskell-flake", 90 | "nixpkgs": "nixpkgs", 91 | "treefmt-flake": "treefmt-flake" 92 | } 93 | }, 94 | "treefmt-flake": { 95 | "locked": { 96 | "lastModified": 1660850981, 97 | "narHash": "sha256-Y2rt0W0ZnfVgH5mnuAkU/5gJGSbjk5NbAwcuLDONHgI=", 98 | "owner": "srid", 99 | "repo": "treefmt-flake", 100 | "rev": "49306df9084ffbd73102e6002241e1f14812f0fe", 101 | "type": "github" 102 | }, 103 | "original": { 104 | "owner": "srid", 105 | "repo": "treefmt-flake", 106 | "type": "github" 107 | } 108 | } 109 | }, 110 | "root": "root", 111 | "version": 7 112 | } 113 | -------------------------------------------------------------------------------- /src/Fp/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module Fp.Pretty ( 4 | -- * Pretty printing 5 | renderStrict, 6 | renderIO, 7 | toText, 8 | Pretty (..), 9 | 10 | -- * Highlighting 11 | keyword, 12 | punctuation, 13 | label, 14 | scalar, 15 | builtin, 16 | operator, 17 | ) where 18 | 19 | import Data.Scientific (Scientific) 20 | import Data.Text (Text) 21 | import Data.Void (Void) 22 | import Numeric.Natural (Natural) 23 | import Prettyprinter (Doc, LayoutOptions (..), PageWidth (..)) 24 | import Prettyprinter.Render.Terminal (AnsiStyle) 25 | import System.IO (Handle) 26 | 27 | import qualified Prettyprinter as Pretty 28 | import qualified Prettyprinter.Render.Terminal as Pretty.Terminal 29 | import qualified Prettyprinter.Render.Text as Pretty.Text 30 | import qualified Text.URI as URI 31 | 32 | renderStrict :: 33 | Pretty a => 34 | -- | Whether highlighting is enabled or not 35 | Bool -> 36 | -- | Number of available columns 37 | Int -> 38 | a -> 39 | Text 40 | renderStrict highlight columns = 41 | render . Pretty.layoutSmart (layoutOptions columns) . pretty 42 | where 43 | render = if highlight then Pretty.Terminal.renderStrict else Pretty.Text.renderStrict 44 | 45 | renderIO :: 46 | Pretty a => 47 | -- | Whether highlighting is enabled or not 48 | Bool -> 49 | -- | Number of available columns 50 | Int -> 51 | Handle -> 52 | a -> 53 | IO () 54 | renderIO highlight columns handle = 55 | render handle . Pretty.layoutSmart (layoutOptions columns) . pretty 56 | where 57 | render = if highlight then Pretty.Terminal.renderIO else Pretty.Text.renderIO 58 | 59 | -- | Simple conversion of a `Doc` to `Text` 60 | toText :: Pretty a => a -> Text 61 | toText = Pretty.Text.renderStrict . Pretty.layoutCompact . pretty 62 | 63 | {- | This is like `Prettyprinter.Pretty`, except that 64 | this can return a `Doc` with `AnsiStyle` annotations. 65 | -} 66 | class Pretty a where 67 | pretty :: a -> Doc AnsiStyle 68 | 69 | instance Pretty Double where 70 | pretty = Pretty.pretty 71 | 72 | instance Pretty Scientific where 73 | pretty = Pretty.pretty . show 74 | 75 | instance Pretty Int where 76 | pretty = Pretty.pretty 77 | 78 | instance Pretty Integer where 79 | pretty = Pretty.pretty 80 | 81 | instance Pretty Natural where 82 | pretty = Pretty.pretty 83 | 84 | instance Pretty Text where 85 | pretty = Pretty.pretty 86 | 87 | instance Pretty () where 88 | pretty = Pretty.pretty 89 | 90 | instance Pretty Void where 91 | pretty = Pretty.pretty 92 | 93 | instance Pretty String where 94 | pretty = Pretty.pretty 95 | 96 | instance Pretty URI.URI where 97 | pretty = Pretty.pretty . URI.render 98 | 99 | instance Pretty (Doc AnsiStyle) where 100 | pretty = id 101 | 102 | layoutOptions :: 103 | -- | Available columns 104 | Int -> 105 | LayoutOptions 106 | layoutOptions columns = 107 | LayoutOptions {layoutPageWidth = AvailablePerLine columns 1} 108 | 109 | -- | Highlight a keyword (e.g. @Transpose@ or @Insert@) 110 | keyword :: Doc AnsiStyle -> Doc AnsiStyle 111 | keyword = 112 | Pretty.annotate 113 | ( Pretty.Terminal.bold 114 | <> Pretty.Terminal.colorDull Pretty.Terminal.Green 115 | ) 116 | 117 | -- | Highlight punctuation (e.g. @<@ or @,@) 118 | punctuation :: Doc AnsiStyle -> Doc AnsiStyle 119 | punctuation = 120 | Pretty.annotate 121 | ( Pretty.Terminal.bold 122 | <> Pretty.Terminal.colorDull Pretty.Terminal.Green 123 | ) 124 | 125 | -- | Highlight a label (e.g. @x@) 126 | label :: Doc AnsiStyle -> Doc AnsiStyle 127 | label = Pretty.annotate mempty 128 | 129 | -- | Highlight a scalar (e.g. @1@ or @\"abc\"@) 130 | scalar :: Doc AnsiStyle -> Doc AnsiStyle 131 | scalar = Pretty.annotate (Pretty.Terminal.colorDull Pretty.Terminal.Magenta) 132 | 133 | -- | Highlight a built-in (e.g. @List/length@) 134 | builtin :: Doc AnsiStyle -> Doc AnsiStyle 135 | builtin = Pretty.annotate Pretty.Terminal.underlined 136 | 137 | -- | Highlight an operator (e.g. @+@ or @&&@) 138 | operator :: Doc AnsiStyle -> Doc AnsiStyle 139 | operator = 140 | Pretty.annotate 141 | ( Pretty.Terminal.bold 142 | <> Pretty.Terminal.colorDull Pretty.Terminal.Green 143 | ) 144 | -------------------------------------------------------------------------------- /src/Fp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | {- | This module contains the top-level `main` function that implements the 7 | command-line API 8 | -} 9 | module Fp ( 10 | -- * Main 11 | main, 12 | ) where 13 | 14 | import Control.Exception.Safe (Exception (..)) 15 | import Fp.Input (Input (..)) 16 | import Options.Applicative (Alternative ((<|>)), Parser, ParserInfo) 17 | import Prettyprinter (Doc) 18 | import Prettyprinter.Render.Terminal (AnsiStyle) 19 | 20 | import qualified Control.Monad as Monad 21 | import qualified Control.Monad.Except as Except 22 | import qualified Data.Text as Text 23 | import qualified Data.Text.IO as Text.IO 24 | import qualified Fp.Interpret as Interpret 25 | import qualified Fp.Normalize as Normalize 26 | import qualified Fp.Pretty 27 | import qualified Fp.REPL as REPL 28 | import qualified Fp.Value as Value 29 | import qualified Fp.Width as Width 30 | import qualified Options.Applicative as Options 31 | import qualified Prettyprinter as Pretty 32 | import qualified System.Console.ANSI as ANSI 33 | import qualified System.Exit as Exit 34 | import qualified System.IO as IO 35 | 36 | data Highlight 37 | = -- | Force the use of ANSI color escape sequences to highlight source code 38 | Color 39 | | -- | Don't highlight source code 40 | Plain 41 | | -- | Auto-detect whether to highlight source code based on whether or not 42 | -- @stdout@ is a terminal 43 | Auto 44 | 45 | data Options 46 | = Interpret {file :: FilePath, highlight :: Highlight} 47 | | REPL {} 48 | 49 | parserInfo :: ParserInfo Options 50 | parserInfo = 51 | Options.info 52 | (Options.helper <*> parser) 53 | (Options.progDesc "Command-line utility for the `fp` programming language") 54 | 55 | parser :: Parser Options 56 | parser = do 57 | let interpret = do 58 | file <- 59 | Options.strArgument 60 | ( Options.help "File to interpret" 61 | <> Options.metavar "FILE" 62 | ) 63 | 64 | highlight <- parseHighlight 65 | 66 | return Interpret {..} 67 | 68 | let repl = do 69 | pure REPL {} 70 | 71 | Options.hsubparser 72 | ( Options.command 73 | "interpret" 74 | ( Options.info 75 | interpret 76 | (Options.progDesc "Interpret a `fp` file") 77 | ) 78 | <> Options.command 79 | "repl" 80 | ( Options.info 81 | repl 82 | (Options.progDesc "Enter a REPL for `fp`") 83 | ) 84 | ) 85 | where 86 | parseHighlight = 87 | Options.flag' 88 | Color 89 | ( Options.long "color" 90 | <> Options.help "Enable syntax highlighting" 91 | ) 92 | <|> Options.flag' 93 | Plain 94 | ( Options.long "plain" 95 | <> Options.help "Disable syntax highlighting" 96 | ) 97 | <|> pure Auto 98 | 99 | detectColor :: Highlight -> IO Bool 100 | detectColor Color = do return True 101 | detectColor Plain = do return False 102 | detectColor Auto = do ANSI.hSupportsANSI IO.stdout 103 | 104 | getRender :: Highlight -> IO (Doc AnsiStyle -> IO ()) 105 | getRender highlight = do 106 | color <- detectColor highlight 107 | width <- Width.getWidth 108 | 109 | return (Fp.Pretty.renderIO color width IO.stdout) 110 | 111 | throws :: Exception e => Either e a -> IO a 112 | throws (Left e) = do 113 | Text.IO.hPutStrLn IO.stderr (Text.pack (displayException e)) 114 | Exit.exitFailure 115 | throws (Right result) = do 116 | return result 117 | 118 | -- | Command-line entrypoint 119 | main :: IO () 120 | main = do 121 | options <- Options.execParser parserInfo 122 | 123 | case options of 124 | Interpret {..} -> do 125 | input <- case file of 126 | "-" -> do 127 | Code "(input)" <$> Text.IO.getContents 128 | _ -> do 129 | return (Path file) 130 | 131 | eitherResult <- do 132 | Except.runExceptT (Interpret.interpret input) 133 | (values, _) <- throws eitherResult 134 | 135 | Monad.forM_ values \value -> do 136 | Monad.when (Value.shouldShow value) 137 | $ do render <- getRender highlight 138 | let syntax = Normalize.quote [] value 139 | render (Fp.Pretty.pretty syntax <> Pretty.hardline) 140 | REPL {} -> do 141 | REPL.repl 142 | -------------------------------------------------------------------------------- /tasty/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module Main where 5 | 6 | import Control.Exception.Safe (Exception) 7 | import Data.Text (Text) 8 | import Fp.Interpret (Input (..), InterpretError) 9 | import Fp.Pretty (Pretty (..)) 10 | import System.FilePath (()) 11 | import Test.Tasty (TestTree) 12 | 13 | import qualified Control.Exception.Safe as Exception 14 | import qualified Control.Monad.Except as Except 15 | import qualified Data.Text as Text 16 | import qualified Fp.Interpret as Interpret 17 | import qualified Fp.Normalize as Normalize 18 | import qualified Fp.Pretty 19 | import qualified Fp.Syntax as Syntax 20 | import qualified Fp.Value as Value 21 | import qualified Fp.Width as Width 22 | import qualified Prettyprinter as Pretty 23 | import qualified System.Directory as Directory 24 | import qualified System.FilePath as FilePath 25 | import qualified Test.Tasty as Tasty 26 | import qualified Test.Tasty.HUnit as Tasty.HUnit 27 | import qualified Test.Tasty.Silver as Silver 28 | 29 | pretty_ :: Pretty a => a -> Text 30 | pretty_ x = 31 | Fp.Pretty.renderStrict 32 | False 33 | Width.defaultWidth 34 | (pretty x <> Pretty.hardline) 35 | 36 | interpret :: Input -> IO (Either InterpretError [Value.Value]) 37 | interpret = Except.runExceptT . fmap fst . Interpret.interpret 38 | 39 | throws :: Exception e => IO (Either e a) -> IO a 40 | throws io = 41 | io >>= \case 42 | Left e -> Exception.throw e 43 | Right a -> pure a 44 | 45 | fileToTestTree :: FilePath -> IO TestTree 46 | fileToTestTree prefix = do 47 | let input = prefix <> "-input.fp" 48 | let expectedOutputFile = prefix <> "-output.fp" 49 | let expectedStderrFile = prefix <> "-stderr.txt" 50 | 51 | let name = FilePath.takeBaseName input 52 | 53 | eitherResult <- interpret (Path input) 54 | 55 | case eitherResult of 56 | Left e -> do 57 | return 58 | ( Tasty.testGroup 59 | name 60 | [ Silver.goldenVsAction 61 | (name <> " - error") 62 | expectedStderrFile 63 | (return (Text.pack (Exception.displayException e))) 64 | id 65 | ] 66 | ) 67 | Right values -> do 68 | let generateOutputFile = 69 | pure @IO . Text.unlines . map (pretty_ . Normalize.quote []) . filter Value.shouldShow 70 | 71 | return 72 | ( Tasty.testGroup 73 | name 74 | [ Silver.goldenVsAction 75 | (name <> " - output") 76 | expectedOutputFile 77 | (generateOutputFile values) 78 | id 79 | ] 80 | ) 81 | 82 | inputFilePrefix :: FilePath -> Maybe FilePath 83 | inputFilePrefix = fmap Text.unpack . Text.stripSuffix "-input.fp" . Text.pack 84 | 85 | directoryToTestTree :: FilePath -> IO TestTree 86 | directoryToTestTree directory = do 87 | let name = FilePath.takeBaseName directory 88 | children <- Directory.listDirectory directory 89 | 90 | let process child = do 91 | let childPath = directory child 92 | isDirectory <- Directory.doesDirectoryExist childPath 93 | if isDirectory 94 | then do 95 | testTree <- directoryToTestTree childPath 96 | pure [testTree] 97 | else case inputFilePrefix childPath of 98 | Nothing -> pure [] 99 | Just prefix -> do 100 | testTree <- fileToTestTree prefix 101 | pure [testTree] 102 | 103 | testTrees <- traverse process children 104 | pure (Tasty.testGroup name (concat testTrees)) 105 | 106 | main :: IO () 107 | main = do 108 | autoGenerated <- directoryToTestTree "tasty/data" 109 | let manualTestTree = 110 | Tasty.testGroup 111 | "Manual tests" 112 | [ innerProduct 113 | , matrixMul 114 | ] 115 | let tests = Tasty.testGroup "Tests" [autoGenerated, manualTestTree] 116 | Tasty.defaultMain tests 117 | 118 | innerProduct :: TestTree 119 | innerProduct = Tasty.HUnit.testCase "inner product" do 120 | actualValue <- throws (interpret (Code "" "/+∘α*∘⍉:<<1,2,3>,<6,5,4>>")) 121 | 122 | let expectedValue = 123 | [Value.Atom (Syntax.Int 28)] 124 | 125 | Tasty.HUnit.assertEqual "" expectedValue actualValue 126 | 127 | matrixMul :: TestTree 128 | matrixMul = Tasty.HUnit.testCase "inner product" do 129 | let input = 130 | Text.unlines 131 | [ "Def ip ≡ /+∘α*∘⍉\n" 132 | , "Def mm ≡ α(α ip) ∘ α distl ∘ distr ∘ [~0, ⍉∘~1]\n" 133 | , "mm:< < <1,2>, <4,5> >, < <6,8>, <7,9>> >" 134 | ] 135 | actualValue <- last <$> throws (interpret (Code "" input)) 136 | 137 | let expectedValue = 138 | Value.List 139 | [ Value.List 140 | [ Value.Atom (Syntax.Int 20) 141 | , Value.Atom (Syntax.Int 26) 142 | ] 143 | , Value.List 144 | [ Value.Atom (Syntax.Int 59) 145 | , Value.Atom (Syntax.Int 77) 146 | ] 147 | ] 148 | 149 | Tasty.HUnit.assertEqual "" expectedValue actualValue 150 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Table of contents 2 | 3 | - [Table of contents](#table-of-contents) 4 | - [fp programming language](#fp-programming-language) 5 | - [Examples of `fp`](#examples-of-fp) 6 | - [Usage](#usage) 7 | - [Command line](#command-line) 8 | - [Interpret](#interpret) 9 | - [REPL](#repl) 10 | - [Documentation](#documentation) 11 | - [Development](#development) 12 | - [Nix support](#nix-support) 13 | - [Tips](#tips) 14 | - [Credits](#credits) 15 | 16 | ## fp programming language 17 | 18 | `fp` is a programming language heavily inspired by the language John Backus 19 | described in his 1977 Turing Award lecture. 20 | 21 | The paper can be found [here](https://dl.acm.org/doi/10.1145/359576.359579). 22 | 23 | ## Examples of `fp` 24 | 25 | ```haskell 26 | {- Matrix multiplication. 27 | -} 28 | 29 | Def ip ≡ /+∘α*∘⍉ 30 | 31 | Def mm ≡ α(α ip) ∘ α distl ∘ distr ∘ [~0, ⍉∘~1] 32 | 33 | mm:< < <1,2>, <4,5> >, 34 | < <6,8>, <7,9>> > 35 | ``` 36 | 37 | ## Usage 38 | 39 | This section will give a quick tour of many of the language features of `fp`. It 40 | will also cover the usage of the tools provided by `fp`. 41 | 42 | ### Command line 43 | 44 | `fp` can be used without explicitly installing it via nix! 45 | 46 | ``` 47 | nix run github:japiirainen/fp -- --help 48 | 49 | Up to date 50 | Usage: fp COMMAND 51 | 52 | Command-line utility for the `fp` programming language 53 | 54 | Available options: 55 | -h,--help Show this help text 56 | 57 | Available commands: 58 | interpret Interpret a `fp` file 59 | repl Enter a REPL for `fp` 60 | ``` 61 | 62 | ### Interpret 63 | 64 | The `interpret` command can be used to interpret `fp` files. 65 | 66 | ```haskell 67 | Def ip ≡ /+∘α*∘⍉ 68 | 69 | ip:<<1,2,3>,<6,5,4>> 70 | ``` 71 | 72 | This program lives in `examples/ip.fp` and can be interpreted like this. 73 | 74 | ```haskell 75 | cabal run fp -- interpret examples/ip.fp 76 | ``` 77 | 78 | Which will yield `28`. 79 | 80 | ### REPL 81 | 82 | you can enter the `fp` repl to get an interactive environment: 83 | 84 | ```sh 85 | fp repl 86 | ``` 87 | 88 | ```haskell 89 | λ +:<1,2> 90 | 3 91 | λ :let xs = <1,2,3> 92 | λ xs 93 | <1,2,3> 94 | ``` 95 | 96 | ## Documentation 97 | 98 | Currently the `examples` directory serves as the documentation! I will list some 99 | important topics below for reference. 100 | 101 | - [Conditionals](./examples/condition.fp) 102 | `Fp` has a condition expression. It is similar to ternary operator in many 103 | ordinary languages. 104 | 105 | - [While](./examples/while.fp) 106 | `while` provides a way to run a specific program many times, specifically 107 | until some condition is met. 108 | 109 | - [Binary to unary](./examples/bu.fp) 110 | `bu` gives a convenient way to turn binary (2 argument) functions 111 | into unary (1 argument) functions. This is kind of like partial 112 | application. 113 | 114 | - [Matrix multiplication](./examples/mm.fp) 115 | This example shows how to do matrix multiplication in `fp`. 116 | 117 | - [Factorials](./examples/fact.fp) 118 | A way to compute factorials in `fp`. 119 | 120 | Here's a bunch of primitive functions. 121 | 122 | - [boolean algebra](./examples/and-or-not.fp) 123 | - [append](./examples/append.fp) 124 | - [applyToAll](./examples/applyToAll.fp) 125 | - [atom](./examples/atom.fp) 126 | - [const](./examples/const.fp) 127 | - [construction](./examples/construction.fp) 128 | - [dist](./examples/dist.fp) 129 | - [eq](./examples/eq.fp) 130 | - [id](./examples/id.fp) 131 | - [length](./examples/length.fp) 132 | - [nth](./examples/nth.fp) 133 | - [null](./examples/null.fp) 134 | - [reverse](./examples/reverse.fp) 135 | - [transpose](./examples/transpose.fp) 136 | - [rotate](./examples/rotate.fp) 137 | 138 | - [Unbound variable error](./examples/fact.fp) 139 | `Fp` also has nice error messages. 140 | 141 | ## Development 142 | 143 | You can also run the test suite. 144 | 145 | ```sh 146 | cabal test tasty 147 | ``` 148 | 149 | ### Nix support 150 | 151 | You can alternatively use nix for dev environment and for building the project. 152 | 153 | Build: 154 | 155 | ```sh 156 | nix build . 157 | ``` 158 | 159 | Run: 160 | 161 | ```sh 162 | nix run . 163 | ``` 164 | 165 | Start Nix shell: 166 | 167 | ```sh 168 | nix-shell 169 | ``` 170 | 171 | ### Tips 172 | 173 | - Run `nix flake update` to update all flake inputs. 174 | - Run `./bin/hoogle` to start Hoogle with packages in your cabal file. 175 | - Run `treefmt` in nix shell to autoformat the project. This uses treefmt, which uses ./treefmt.toml (where fourmolu and nixpkgs-fmt are specified). 176 | - Run the application without installing: `nix run github:japiirainen/fp` (or `nix run .` from checkout) 177 | 178 | `fp` is a programming language heavily inspired by the language John Backus 179 | described in his 1977 Turing Award lecture. 180 | 181 | Currently, almost all features described in the paper are implemented. This is not implemented: 182 | 183 | - recursion (I'm not sure if I want to allow user defined recursion). 184 | 185 | ## Credits 186 | 187 | - Gabriella Gonzalez's (Gabriella439) [grace](https://github.com/Gabriella439/grace) was an invaluable resource for interpreter design in haskell. 188 | -------------------------------------------------------------------------------- /src/Fp/REPL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | -- | This module contains the implementation of the @fp repl@ subcommand 8 | module Fp.REPL ( 9 | -- * REPL 10 | repl, 11 | ) where 12 | 13 | import Control.Exception.Safe (displayException, throwIO) 14 | import Control.Monad.IO.Class (liftIO) 15 | import Control.Monad.State (MonadState (..)) 16 | import Data.Bifunctor (Bifunctor (bimap)) 17 | import Fp.Interpret (Input (..)) 18 | import System.Console.Haskeline (Interrupt (..)) 19 | import System.Console.Repline (CompleterStyle (..), MultiLine (..), ReplOpts (..)) 20 | import Prelude hiding (lex) 21 | 22 | import qualified Control.Monad as Monad 23 | import qualified Control.Monad.Except as Except 24 | import qualified Control.Monad.State as State 25 | import qualified Data.Text as Text 26 | import qualified Data.Text.IO as Text.IO 27 | import qualified Fp.Interpret as Interpret 28 | import qualified Fp.Lexer as Lexer 29 | import qualified Fp.Normalize as Normalize 30 | import qualified Fp.Parser as Parser 31 | import qualified Fp.Pretty as Pretty 32 | import qualified Fp.Value as Value 33 | import qualified Fp.Width as Width 34 | import qualified System.Console.Repline as Repline 35 | import qualified System.IO as IO 36 | 37 | -- | Entrypoint for the @fp repl@ subcommand 38 | repl :: IO () 39 | repl = do 40 | let interpret input = do 41 | context <- get 42 | 43 | Except.runExceptT (Interpret.interpretWith context input) 44 | 45 | let err e = 46 | liftIO (Text.IO.hPutStrLn IO.stderr (Text.pack (displayException e))) 47 | 48 | let lex input = do 49 | let eitherTokens = Lexer.lex "(input)" (Text.pack input) 50 | 51 | case eitherTokens of 52 | Left e -> do 53 | err e 54 | Right tokens -> do 55 | liftIO $ putStrLn "------RAW_TOKENS-----" 56 | liftIO (print tokens) 57 | liftIO $ putStrLn "------END_TOKENS-----" 58 | 59 | let parse input = do 60 | let eitherSyntax = Parser.parse "(input)" (Text.pack input) 61 | 62 | case eitherSyntax of 63 | Left e -> do 64 | err e 65 | Right syntax -> do 66 | width <- liftIO Width.getWidth 67 | liftIO $ putStrLn "------RAW_SYNTAX-----" 68 | liftIO (print syntax) 69 | liftIO $ putStrLn "----PRETTY_SYNTAX----" 70 | Monad.forM_ syntax \s -> do 71 | let ss = bimap (const ()) (const ()) s 72 | liftIO $ 73 | Pretty.renderIO True width IO.stdout (Pretty.pretty ss <> "\n") 74 | liftIO $ putStrLn "------END_SYNTAX-----" 75 | 76 | let command string = do 77 | let input = Code "(input)" (Text.pack string) 78 | 79 | eitherResult <- interpret input 80 | 81 | case eitherResult of 82 | Left e -> do 83 | err e 84 | Right (values, _) -> do 85 | Monad.forM_ values \value -> do 86 | Monad.when (Value.shouldShow value) do 87 | let syntax = Normalize.quote [] value 88 | width <- liftIO Width.getWidth 89 | liftIO (Pretty.renderIO True width IO.stdout (Pretty.pretty syntax <> "\n")) 90 | 91 | let help _string = do 92 | liftIO 93 | ( putStrLn 94 | "Type any expression to normalize it or use one of the following commands:\n\ 95 | \:help\n\ 96 | \ Print help text and describe options\n\ 97 | \:paste\n\ 98 | \ Start a multi-line input. Submit with \n\ 99 | \:let IDENTIFIER = EXPRESSION\n\ 100 | \ Assign an expression to a variable\n\ 101 | \:lex EXPRESSION\n\ 102 | \ Run the expression throught Lexer.lex\n\ 103 | \:parse EXPRESSION\n\ 104 | \ Run the expression throught Parser.parse\n\ 105 | \:quit\n\ 106 | \ Exit the REPL" 107 | ) 108 | 109 | let assign var expr = do 110 | let variable = Text.strip (Text.pack var) 111 | 112 | let input = 113 | Code 114 | "(input)" 115 | ("Def " <> variable <> " = " <> Text.pack expr) 116 | 117 | eitherResult <- interpret input 118 | 119 | case eitherResult of 120 | Left e -> do 121 | err e 122 | Right (_, bindings) -> do 123 | State.modify (bindings <>) 124 | 125 | let assignment string 126 | | (var, '=' : expr) <- break (== '=') string = assign var expr 127 | | (var, '≡' : expr) <- break (== '≡') string = assign var expr 128 | | otherwise = liftIO (putStrLn "usage: let = {expression}") 129 | 130 | let quit _ = 131 | liftIO (throwIO Interrupt) 132 | 133 | let options = 134 | [ ("help", Repline.dontCrash . help) 135 | , ("let", Repline.dontCrash . assignment) 136 | , ("lex", Repline.dontCrash . lex) 137 | , ("parse", Repline.dontCrash . parse) 138 | , -- `paste` is included here for auto-completion purposes only. 139 | -- `repline`'s `multilineCommand` logic overrides this no-op. 140 | ("paste", Repline.dontCrash . \_ -> return ()) 141 | , ("quit", quit) 142 | ] 143 | 144 | let banner MultiLine = return "... " 145 | banner SingleLine = return "λ " 146 | 147 | let prefix = Just ':' 148 | 149 | let multilineCommand = Just "paste" 150 | 151 | let initialiser = liftIO (putStrLn "\nWelcome to the fp REPL!") 152 | 153 | let finaliser = do 154 | liftIO (putStrLn "Until next time!") 155 | return Repline.Exit 156 | 157 | let tabComplete = Word0 (\_ -> pure []) 158 | 159 | let action = Repline.evalReplOpts ReplOpts {..} 160 | 161 | State.evalStateT action mempty 162 | -------------------------------------------------------------------------------- /src/Fp/Lexer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | -- | This module contains the logic for lexing `fp` programs. 7 | module Fp.Lexer ( 8 | -- * Lexer 9 | Token (..), 10 | LocatedToken (..), 11 | lex, 12 | reserved, 13 | 14 | -- * Errors related to parsing 15 | ParseError (..), 16 | ) where 17 | 18 | import Control.Applicative (Alternative (..)) 19 | import Control.Exception.Safe (Exception (..)) 20 | import Control.Monad.Combinators (manyTill) 21 | import Data.HashSet (HashSet) 22 | import Data.List.NonEmpty (NonEmpty (..)) 23 | import Data.Scientific (Scientific) 24 | import Data.Text (Text) 25 | import Data.Void (Void) 26 | import Fp.Location (Location (..), Offset (..)) 27 | import Text.Megaparsec (ParseErrorBundle (..), try, ()) 28 | import Prelude hiding (const, lex) 29 | 30 | import qualified Control.Monad as Monad 31 | import qualified Control.Monad.Combinators as Combinators 32 | import qualified Data.Char as Char 33 | import qualified Data.HashSet as HashSet 34 | import qualified Data.Scientific as Scientific 35 | import qualified Data.Text as Text 36 | import qualified Fp.Location as Location 37 | import qualified Text.Megaparsec as Error 38 | import qualified Text.Megaparsec as Megaparsec 39 | import qualified Text.Megaparsec.Char as Megaparsec.Char 40 | import qualified Text.Megaparsec.Char.Lexer as Lexer 41 | 42 | type Parser = Megaparsec.Parsec Void Text 43 | 44 | space :: Parser () 45 | space = Lexer.space Megaparsec.Char.space1 (Lexer.skipLineComment "--") (Lexer.skipBlockComment "{-" "-}") 46 | 47 | symbol :: Text -> Parser Text 48 | symbol = Lexer.symbol space 49 | 50 | lexeme :: Parser a -> Parser a 51 | lexeme = Lexer.lexeme space 52 | 53 | parseToken :: Parser Token 54 | parseToken = 55 | Combinators.choice 56 | [ label 57 | , Combinators.choice 58 | [ Def <$ symbol "Def" 59 | , Equals <$ (symbol "=" <|> symbol "≡") 60 | ] 61 | "keyword" 62 | , Combinators.choice 63 | [ Plus <$ symbol "+" 64 | , Times <$ symbol "*" 65 | , Divide <$ symbol "÷" 66 | , Transpose <$ (symbol "transpose" <|> symbol "⍉") 67 | , Atom <$ symbol "atom" 68 | , Eq <$ symbol "eq" 69 | , Null <$ symbol "null" 70 | , Reverse <$ symbol "reverse" 71 | , Distl <$ symbol "distl" 72 | , Distr <$ symbol "distr" 73 | , Length <$ symbol "length" 74 | , Id <$ symbol "id" 75 | , Not <$ (symbol "not" <|> symbol "¬") 76 | , And <$ (symbol "and" <|> symbol "∧") 77 | , Or <$ (symbol "or" <|> symbol "∨") 78 | , AppendLeft <$ symbol "apndl" 79 | , AppendRight <$ symbol "apndr" 80 | , Flatten <$ symbol "flatten" 81 | , Tail <$ (symbol "tail" <|> symbol "tl") 82 | , RotateLeft <$ symbol "rotl" 83 | , RotateRight <$ symbol "rotr" 84 | ] 85 | "primitive function" 86 | , Combinators.choice 87 | [ Comp <$ (symbol "." <|> symbol "∘") 88 | , ApplyToAll <$ (symbol "applyToAll" <|> symbol "α") 89 | , Insert <$ (symbol "insert" <|> symbol "/") 90 | , While <$ symbol "while" 91 | , Bu <$ symbol "bu" 92 | ] 93 | "functional form" 94 | , Combinators.choice 95 | [ Bottom <$ symbol "⊥" 96 | , T <$ symbol "T" 97 | , F <$ symbol "F" 98 | ] 99 | "built-in value" 100 | , OpenBracket <$ symbol "[" 101 | , CloseBracket <$ symbol "]" 102 | , OpenParen <$ symbol "(" 103 | , CloseParen <$ symbol ")" 104 | , OpenAngle <$ symbol "<" 105 | , CloseAngle <$ symbol ">" 106 | , EmptySeq <$ symbol "⌽" 107 | , Arrow <$ (symbol "→" <|> symbol "->") 108 | , Comma <$ symbol "," 109 | , Dash <$ symbol "-" 110 | , UnderScore <$ symbol "_" 111 | , Colon <$ symbol ":" 112 | , SemiColon <$ symbol ";" 113 | , AtSign <$ symbol "@" 114 | , nth 115 | , nthBack 116 | , number 117 | ] 118 | 119 | nth :: Parser Token 120 | nth = (try . lexeme) $ Nth <$> (symbol "~" *> Lexer.decimal) 121 | 122 | nthBack :: Parser Token 123 | nthBack = (try . lexeme) $ NthBack <$> (Lexer.decimal <* symbol "~") 124 | 125 | isLabel0 :: Char -> Bool 126 | isLabel0 = Char.isAlpha 127 | 128 | isLabel :: Char -> Bool 129 | isLabel c = Char.isAlphaNum c || c == '-' || c == '/' 130 | 131 | reserved :: HashSet Text 132 | reserved = 133 | HashSet.fromList 134 | [ "T" 135 | , "F" 136 | , "Def" 137 | , "transpose" 138 | , "applyToAll" 139 | , "insert" 140 | , "atom" 141 | , "eq" 142 | , "null" 143 | , "reverse" 144 | , "distl" 145 | , "distr" 146 | , "length" 147 | , "id" 148 | , "and" 149 | , "or" 150 | , "not" 151 | , "apndl" 152 | , "apndr" 153 | , "while" 154 | , "flatten" 155 | , "tl" 156 | , "tail" 157 | , "bu" 158 | , "rotl" 159 | , "rotr" 160 | , "." 161 | , "α" 162 | , "+" 163 | , "*" 164 | ] 165 | 166 | label :: Parser Token 167 | label = (lexeme . try) do 168 | c0 <- Megaparsec.satisfy isLabel0 "label character" 169 | cs <- Megaparsec.takeWhileP (Just "label character") isLabel 170 | let result = Text.cons c0 cs 171 | Monad.guard (not (HashSet.member result reserved)) 172 | if Text.toUpper result == result 173 | then return (ObjectLabel result) 174 | else return (Label result) 175 | 176 | parseLocatedToken :: Parser LocatedToken 177 | parseLocatedToken = do 178 | start <- Offset <$> Megaparsec.getOffset 179 | token <- parseToken 180 | return LocatedToken {..} 181 | 182 | parseLocatedTokens :: Parser [LocatedToken] 183 | parseLocatedTokens = space >> manyTill parseLocatedToken Megaparsec.eof 184 | 185 | -- | Lex a complete expression 186 | lex :: 187 | String -> 188 | Text -> 189 | Either ParseError [LocatedToken] 190 | lex name code = 191 | case Megaparsec.parse parseLocatedTokens name code of 192 | Left ParseErrorBundle {..} -> do 193 | let bundleError :| _ = bundleErrors 194 | offset = Offset (Error.errorOffset bundleError) 195 | Left (LexingFailed (Location {..})) 196 | Right tokens -> return tokens 197 | 198 | number :: Parser Token 199 | number = do 200 | scientific <- lexeme Lexer.scientific 201 | 202 | case Scientific.toBoundedInteger scientific of 203 | Nothing -> return (RealLiteral scientific) 204 | Just int -> return (Int int) 205 | 206 | -- | Tokens produced by lexing 207 | data Token 208 | = Equals 209 | | Comp 210 | | Transpose 211 | | ApplyToAll 212 | | Insert 213 | | Atom 214 | | Eq 215 | | Null 216 | | Distl 217 | | Distr 218 | | Reverse 219 | | Length 220 | | Id 221 | | Plus 222 | | Times 223 | | Divide 224 | | Not 225 | | And 226 | | Or 227 | | AppendLeft 228 | | AppendRight 229 | | RotateLeft 230 | | RotateRight 231 | | While 232 | | Bu 233 | | Flatten 234 | | Tail 235 | | OpenBracket 236 | | CloseBracket 237 | | OpenParen 238 | | CloseParen 239 | | OpenAngle 240 | | CloseAngle 241 | | EmptySeq 242 | | Dash 243 | | UnderScore 244 | | Colon 245 | | SemiColon 246 | | RealLiteral Scientific 247 | | Int Int 248 | | Nth Int 249 | | NthBack Int 250 | | Def 251 | | Comma 252 | | Bottom 253 | | Arrow 254 | | AtSign 255 | | T 256 | | F 257 | | -- | Object label is a label that consists 258 | -- of only upper-case letters excluding 'T' and 'F'. 259 | ObjectLabel Text 260 | | -- | Label is a label that consists of lower and upper-case 261 | -- letters. 262 | Label Text 263 | deriving stock (Eq, Show) 264 | 265 | {- | A token with offset information attached, 266 | used for reporting line and column numbers in error messages 267 | -} 268 | data LocatedToken = LocatedToken {token :: Token, start :: Offset} 269 | deriving stock (Show) 270 | 271 | -- | Errors related to lexing and parsing 272 | data ParseError 273 | = LexingFailed Location 274 | | ParsingFailed Location 275 | deriving stock (Eq, Show) 276 | 277 | instance Exception ParseError where 278 | displayException (LexingFailed location) = 279 | Text.unpack 280 | (Location.renderError "Invalid input - Lexing failed" location) 281 | displayException (ParsingFailed location) = 282 | Text.unpack 283 | (Location.renderError "Invalid input - Parsing failed" location) 284 | -------------------------------------------------------------------------------- /src/Fp/Normalize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module Fp.Normalize ( 8 | -- * Normalization 9 | evaluate, 10 | quote, 11 | 12 | -- * Errors related to normalization 13 | EvaluationError (..), 14 | ) where 15 | 16 | import Control.Exception (Exception (displayException)) 17 | import Control.Monad.Except (MonadError (throwError)) 18 | import Control.Monad.State (MonadState) 19 | import Data.List (transpose) 20 | import Data.Map (Map) 21 | import Data.Text (Text) 22 | import Data.Void (Void) 23 | import Fp.Input (Input) 24 | import Fp.Location (Location) 25 | import Fp.Pretty (Pretty) 26 | import Fp.Syntax (Atom (..), Combinator1 (..), Combinator2 (..), Primitive (..), Syntax) 27 | import Fp.Value (Value (..)) 28 | import Prelude hiding (succ) 29 | 30 | import qualified Control.Monad.State as State 31 | import qualified Data.Map as Map 32 | import qualified Data.Text as Text 33 | import qualified Fp.Location as Location 34 | import qualified Fp.Pretty as Pretty 35 | import qualified Fp.Syntax as Syntax 36 | import qualified Fp.Value as Value 37 | import qualified Fp.Width as Width 38 | 39 | {- | Lookup a variable from an ordered environment of name-value pairs using the 40 | variable's name 41 | -} 42 | lookupVariable :: 43 | -- | Symbol name 44 | Text -> 45 | -- | Evaluation environment 46 | Map Text Value -> 47 | Maybe Value 48 | lookupVariable = Map.lookup 49 | 50 | evaluate :: 51 | -- | Evaluation environment 52 | Map Text Value -> 53 | -- | Surface syntax 54 | [Syntax Location Input] -> 55 | -- | result, free of reducible sub-expressions 56 | Either EvaluationError ([Value], Map Text Value) 57 | evaluate bindings es = State.runStateT (mapM evalSingle es) bindings 58 | 59 | evalSingle :: 60 | (MonadState (Map Text Value) m, MonadError EvaluationError m) => 61 | Syntax Location Input -> 62 | m Value 63 | evalSingle = \case 64 | Syntax.Variable {..} -> 65 | State.gets (lookupVariable name) >>= \case 66 | Just value -> pure value 67 | Nothing -> throwError (UnboundVariable location name) 68 | Syntax.Definition {..} -> do 69 | v <- evalSingle body 70 | State.modify (Map.insert name v) 71 | pure v 72 | Syntax.Application {..} -> do 73 | function' <- evalSingle function 74 | argument' <- evalSingle argument 75 | pure (apply function' argument') 76 | Syntax.Combinator1 {..} -> do 77 | argument' <- evalSingle argument 78 | pure $ Combinator1 c1 argument' 79 | Syntax.Combinator2 {..} -> do 80 | argument1' <- evalSingle argument1 81 | argument2' <- evalSingle argument2 82 | pure $ Combinator2 c2 argument1' argument2' 83 | Syntax.If {..} -> do 84 | condition <- evalSingle predicate 85 | Value.If condition <$> evalSingle ifTrue <*> evalSingle ifFalse 86 | Syntax.Atom {..} -> pure (Atom atom) 87 | Syntax.Primitive {..} -> pure (Primitive primitive) 88 | Syntax.List {..} -> do 89 | elements' <- mapM evalSingle elements 90 | if any (\case Syntax.Bottom {} -> True; _ -> False) elements 91 | then pure Bottom 92 | else pure $ List elements' 93 | Syntax.Construction {..} -> do 94 | functions' <- mapM evalSingle functions 95 | pure $ Construction functions' 96 | Syntax.Bottom _ -> pure Bottom 97 | 98 | {- | This is the function that implements function application, 99 | evaluating all built-in functions. 100 | -} 101 | apply :: Value -> Value -> Value 102 | -- primitives 103 | apply (Primitive AtomP) arg = case arg of 104 | Atom _ -> Atom (Bool True) 105 | Bottom -> Bottom 106 | _ -> Atom (Bool False) 107 | apply (Primitive Eq) (List vs) = case vs of 108 | [v1, v2] -> Atom (Bool (v1 == v2)) 109 | _ -> Bottom 110 | apply (Primitive Null) arg = case arg of 111 | List xs -> if null xs then Atom (Bool True) else Atom (Bool False) 112 | Bottom -> Bottom 113 | _ -> Atom (Bool False) 114 | apply (Primitive Plus) (List vs) = case vs of 115 | [Value.Atom (Int x), Atom (Int y)] -> Atom (Int (x + y)) 116 | _ -> Bottom 117 | apply (Primitive Plus) _ = Bottom 118 | apply (Primitive Times) (List vs) = case vs of 119 | [Atom (Int x), Atom (Int y)] -> Atom (Int (x * y)) 120 | _ -> Bottom 121 | apply (Primitive Times) _ = Bottom 122 | apply (Primitive Minus) (List vs) = case vs of 123 | [Atom (Int x), Atom (Int y)] -> Atom (Int (x - y)) 124 | _ -> Bottom 125 | apply (Primitive Minus) _ = Bottom 126 | apply (Primitive Divide) (List vs) = case vs of 127 | [Atom (Int x), Atom (Int y)] -> 128 | (if y == 0 then Bottom else Atom (Int (x `div` y))) 129 | _ -> Bottom 130 | apply (Primitive Divide) _ = Bottom 131 | apply (Primitive Transpose) (List vs) = 132 | let unwrap (List ys) = ys; unwrap _ = [] 133 | in List (List <$> transpose (unwrap <$> vs)) 134 | apply (Primitive Reverse) (List vs) = List (reverse vs) 135 | apply (Primitive Reverse) _ = Bottom 136 | apply (Primitive Distl) (List vs) = case vs of 137 | [a, List xs] -> List $ map (\x -> List [a, x]) xs 138 | _ -> Bottom 139 | apply (Primitive Distr) (List vs) = case vs of 140 | [List xs, a] -> List $ map (\x -> List [x, a]) xs 141 | _ -> Bottom 142 | apply (Primitive Length) v = case v of 143 | List xs -> Atom (Int (length xs)) 144 | _ -> Bottom 145 | apply (Primitive (Nth n)) (List vs) = 146 | if n < length vs then vs !! n else Bottom 147 | apply (Primitive (Nth _)) _ = Bottom 148 | apply (Primitive (NthBack n)) (List vs) = 149 | let len = length vs 150 | in if n < len then vs !! ((len - 1) - n) else Bottom 151 | apply (Primitive (NthBack _)) _ = Bottom 152 | apply (Primitive Id) v = v 153 | apply (Primitive And) (List vs) = case vs of 154 | [Atom (Bool x), Atom (Bool y)] -> Atom (Bool (x && y)) 155 | _ -> Bottom 156 | apply (Primitive And) _ = Bottom 157 | apply (Primitive Or) (List vs) = case vs of 158 | [Atom (Bool x), Atom (Bool y)] -> Atom (Bool (x || y)) 159 | _ -> Bottom 160 | apply (Primitive Or) _ = Bottom 161 | apply (Primitive Not) arg = case arg of 162 | Atom (Bool x) -> Atom (Bool (not x)) 163 | Bottom -> Bottom 164 | _ -> Bottom 165 | apply (Primitive IntoSeq) Bottom = Bottom 166 | apply (Primitive IntoSeq) arg = List [arg] 167 | apply (Primitive AppendLeft) (List vs) = case vs of 168 | [y, List xs] -> List (y : xs) 169 | _ -> Bottom 170 | apply (Primitive AppendLeft) _ = Bottom 171 | apply (Primitive AppendRight) (List vs) = case vs of 172 | [List xs, y] -> List (xs <> pure y) 173 | _ -> Bottom 174 | apply (Primitive AppendRight) _ = Bottom 175 | apply (Primitive Flatten) (List vs) = flatten vs 176 | where 177 | flatten :: [Value] -> Value 178 | flatten = \case 179 | [] -> List [] 180 | List xs : ys -> flatten (xs <> ys) 181 | x : ys -> case flatten ys of 182 | List xs -> List (x : xs) 183 | _ -> Bottom 184 | apply (Primitive Flatten) _ = Bottom 185 | apply (Primitive Tail) (List vs) = 186 | if length vs > 1 then List (tail vs) else Bottom 187 | apply (Primitive Tail) _ = Bottom 188 | apply (Primitive RotateLeft) (List vs) = List (rotateLeft vs) 189 | where 190 | rotateLeft = \case [] -> []; x : xs -> xs <> [x] 191 | apply (Primitive RotateLeft) _ = Bottom 192 | apply (Primitive RotateRight) (List vs) = List (rotateRight vs) 193 | where 194 | rotateRight = \case [] -> []; xs -> last xs : init xs 195 | apply (Primitive RotateRight) _ = Bottom 196 | -- combinators 197 | apply (Combinator1 Insert f) (Value.List vs) = 198 | foldl1 (\acc x -> apply f (List [acc, x])) vs 199 | apply (Combinator1 ApplyToAll f) (Value.List vs) = 200 | List $ map (apply f) vs 201 | apply (Combinator1 Const (Atom a)) _ = Atom a 202 | apply (Combinator1 Const (List xs)) _ = List xs 203 | apply (Combinator1 Const _) _ = Bottom 204 | apply (Combinator2 Composition f g) o = 205 | let o' = apply g o 206 | in apply f o' 207 | apply while@(Combinator2 While predicate f) o = 208 | let cond = apply predicate o 209 | in case cond of 210 | Atom (Bool True) -> apply while (apply f o) 211 | Atom (Bool False) -> o 212 | _ -> Bottom 213 | apply (Combinator2 Bu f x) o = apply f (List [x, o]) 214 | -- construction 215 | apply (Construction fns) arg = List (map (`apply` arg) fns) 216 | -- condition 217 | apply (If cond ifTrue ifFalse) arg = 218 | case apply cond arg of 219 | Atom (Bool True) -> apply ifTrue arg 220 | Atom (Bool False) -> apply ifFalse arg 221 | _ -> Bottom 222 | apply (Application f x) arg = apply f (apply x arg) 223 | apply function application = 224 | Value.Application function application 225 | 226 | -- | Convert a `Value` back into the surface `Syntax` 227 | quote :: 228 | -- | Variable names currently in scope (starting at @[]@ for a top-level 229 | -- expression) 230 | [Text] -> 231 | Value -> 232 | Syntax () Void 233 | quote names value = 234 | case value of 235 | Value.Variable name -> 236 | Syntax.Variable {..} 237 | Value.Bottom -> 238 | Syntax.Bottom () 239 | Value.Application function argument -> 240 | Syntax.Application 241 | { function = quote names function 242 | , argument = quote names argument 243 | , .. 244 | } 245 | Value.List elements -> 246 | Syntax.List {elements = fmap (quote names) elements, ..} 247 | Value.Construction functions -> 248 | Syntax.Construction {functions = fmap (quote names) functions, ..} 249 | Value.Atom atom -> 250 | Syntax.Atom {..} 251 | Value.Combinator1 c1 argument -> 252 | Syntax.Combinator1 253 | { argument = quote names argument 254 | , .. 255 | } 256 | Value.If predicate ifTrue ifFalse -> 257 | Syntax.If 258 | { predicate = quote names predicate 259 | , ifTrue = quote names ifTrue 260 | , ifFalse = quote names ifFalse 261 | , .. 262 | } 263 | Value.Combinator2 c2 argument1 argument2 -> 264 | Syntax.Combinator2 265 | { argument1 = quote names argument1 266 | , operatorLocation = () 267 | , argument2 = quote names argument2 268 | , .. 269 | } 270 | Value.Primitive primitive -> 271 | Syntax.Primitive {..} 272 | where 273 | location = () 274 | 275 | data EvaluationError 276 | = UnboundVariable Location Text 277 | deriving (Eq, Show) 278 | 279 | instance Exception EvaluationError where 280 | displayException (UnboundVariable location name) = 281 | "Unbound variable: " 282 | <> Text.unpack var 283 | <> "\n\ 284 | \\n\ 285 | \" 286 | <> Text.unpack (Location.renderError "" location) 287 | where 288 | var = prettyToText @(Syntax.Syntax () Void) Syntax.Variable {location = (), ..} 289 | 290 | prettyToText :: Pretty a => a -> Text 291 | prettyToText = Pretty.renderStrict False Width.defaultWidth 292 | -------------------------------------------------------------------------------- /src/Fp/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | 8 | module Fp.Syntax ( 9 | -- * Syntax 10 | Syntax (..), 11 | Atom (..), 12 | Primitive (..), 13 | Combinator1 (..), 14 | Combinator2 (..), 15 | ) where 16 | 17 | import Data.Bifunctor (Bifunctor (..)) 18 | import Data.Scientific (Scientific (..)) 19 | import Data.Text (Text) 20 | import Fp.Pretty (Pretty (..), keyword, label, punctuation) 21 | import Prettyprinter (Doc) 22 | import Prettyprinter.Render.Terminal (AnsiStyle) 23 | 24 | import Data.String (IsString (..)) 25 | import qualified Data.Text as Text 26 | import qualified Fp.Pretty as Pretty 27 | import qualified Prettyprinter as Pretty 28 | 29 | -- | The surface syntax of the language 30 | data Syntax s a 31 | = Variable {location :: s, name :: Text} 32 | | Application {location :: s, function :: Syntax s a, argument :: Syntax s a} 33 | | Definition {location :: s, name :: Text, body :: Syntax s a} 34 | | Bottom {location :: s} 35 | | Atom {location :: s, atom :: Atom} 36 | | List {location :: s, elements :: [Syntax s a]} 37 | | If {location :: s, predicate :: Syntax s a, ifTrue :: Syntax s a, ifFalse :: Syntax s a} 38 | | Construction {location :: s, functions :: [Syntax s a]} 39 | | Combinator1 {location :: s, c1 :: Combinator1, argument :: Syntax s a} 40 | | Combinator2 {location :: s, argument1 :: Syntax s a, operatorLocation :: s, c2 :: Combinator2, argument2 :: Syntax s a} 41 | | Primitive {location :: s, primitive :: Primitive} 42 | deriving stock (Eq, Show, Foldable, Functor, Traversable) 43 | 44 | instance Bifunctor Syntax where 45 | first f Variable {..} = 46 | Variable {location = f location, ..} 47 | first f Application {..} = 48 | Application {location = f location, function = first f function, argument = first f argument, ..} 49 | first f Definition {..} = 50 | Definition {location = f location, body = first f body, ..} 51 | first f List {..} = 52 | List {location = f location, elements = fmap (first f) elements, ..} 53 | first f Construction {..} = 54 | Construction {location = f location, functions = fmap (first f) functions, ..} 55 | first f Atom {..} = 56 | Atom {location = f location, ..} 57 | first f Bottom {..} = 58 | Bottom {location = f location, ..} 59 | first f If {..} = 60 | If 61 | { location = f location 62 | , predicate = first f predicate 63 | , ifTrue = first f ifTrue 64 | , ifFalse = first f ifFalse 65 | , .. 66 | } 67 | first f Combinator1 {..} = 68 | Combinator1 {location = f location, argument = first f argument, ..} 69 | first f Combinator2 {..} = 70 | Combinator2 {location = f location, argument1 = first f argument1, operatorLocation = f operatorLocation, argument2 = first f argument2, ..} 71 | first f Primitive {..} = 72 | Primitive {location = f location, ..} 73 | 74 | second = fmap 75 | 76 | instance IsString (Syntax () a) where 77 | fromString string = 78 | Variable {location = (), name = fromString string} 79 | 80 | instance Pretty a => Pretty (Syntax s a) where 81 | pretty = prettyExpression 82 | 83 | -- | A scalar value in `fp` language 84 | data Atom 85 | = Bool Bool 86 | | Int Int 87 | | Real Scientific 88 | | Symbol Text 89 | deriving stock (Eq, Show) 90 | 91 | instance Pretty Atom where 92 | pretty (Bool True) = Pretty.scalar "T" 93 | pretty (Bool False) = Pretty.scalar "F" 94 | pretty (Int n) = Pretty.scalar (pretty n) 95 | pretty (Real n) = Pretty.scalar (pretty n) 96 | pretty (Symbol name) = Pretty.scalar (pretty name) 97 | 98 | data Combinator1 99 | = ApplyToAll 100 | | Insert 101 | | Const 102 | deriving stock (Eq, Show) 103 | 104 | instance Pretty Combinator1 where 105 | pretty ApplyToAll = Pretty.operator "α" 106 | pretty Insert = Pretty.operator "/" 107 | pretty Const = Pretty.operator "_" 108 | 109 | data Combinator2 110 | = Composition 111 | | While 112 | | Bu 113 | deriving stock (Eq, Show) 114 | 115 | instance Pretty Combinator2 where 116 | pretty Composition = Pretty.operator "∘" 117 | pretty While = Pretty.operator "while" 118 | pretty Bu = Pretty.operator "bu" 119 | 120 | data Primitive 121 | = Transpose 122 | | Plus 123 | | Times 124 | | Minus 125 | | Divide 126 | | AtomP 127 | | Eq 128 | | Null 129 | | Reverse 130 | | Distl 131 | | Distr 132 | | Length 133 | | Id 134 | | Not 135 | | And 136 | | Or 137 | | IntoSeq 138 | | AppendLeft 139 | | AppendRight 140 | | Flatten 141 | | Tail 142 | | RotateLeft 143 | | RotateRight 144 | | Nth Int 145 | | NthBack Int 146 | deriving stock (Eq, Show) 147 | 148 | instance Pretty Primitive where 149 | pretty = \case 150 | Transpose -> Pretty.builtin "⍉" 151 | Plus -> Pretty.builtin "+" 152 | Times -> Pretty.builtin "*" 153 | Minus -> Pretty.builtin "-" 154 | Divide -> Pretty.builtin "÷" 155 | AtomP -> Pretty.builtin "atom" 156 | Eq -> Pretty.builtin "eq" 157 | Null -> Pretty.builtin "null" 158 | Reverse -> Pretty.builtin "reverse" 159 | Distl -> Pretty.builtin "distl" 160 | Distr -> Pretty.builtin "distr" 161 | Length -> Pretty.builtin "length" 162 | Id -> Pretty.builtin "id" 163 | Nth n -> Pretty.builtin "~" <> pretty n 164 | NthBack n -> Pretty.builtin (pretty n) <> "~" 165 | Not -> Pretty.builtin "¬" 166 | And -> Pretty.builtin "∧" 167 | Or -> Pretty.builtin "∨" 168 | IntoSeq -> Pretty.builtin "@<>" 169 | AppendLeft -> Pretty.builtin "apndl" 170 | AppendRight -> Pretty.builtin "apndr" 171 | RotateLeft -> Pretty.builtin "rotl" 172 | RotateRight -> Pretty.builtin "rotr" 173 | Flatten -> Pretty.builtin "flatten" 174 | Tail -> Pretty.builtin "tail" 175 | 176 | prettyExpression :: Pretty a => Syntax s a -> Doc AnsiStyle 177 | prettyExpression Variable {..} = label (pretty name) 178 | prettyExpression Primitive {..} = label (pretty primitive) 179 | prettyExpression Atom {..} = label (pretty atom) 180 | prettyExpression Bottom {} = label (Pretty.scalar "⊥") 181 | prettyExpression List {elements = []} = punctuation "⌽" 182 | prettyExpression List {elements = (element : elements)} = 183 | Pretty.group (Pretty.flatAlt long short) 184 | where 185 | short = 186 | punctuation "<" 187 | <> " " 188 | <> prettyExpression element 189 | <> foldMap (\e -> punctuation "," <> " " <> prettyExpression e) elements 190 | <> " " 191 | <> punctuation ">" 192 | 193 | long = 194 | Pretty.align 195 | ( "< " 196 | <> prettyLongElement element 197 | <> foldMap (\e -> punctuation "," <> " " <> prettyLongElement e) elements 198 | <> ">" 199 | ) 200 | prettyLongElement e = prettyExpression e <> Pretty.hardline 201 | prettyExpression Construction {functions = []} = 202 | punctuation "[" <> " " <> punctuation "]" 203 | prettyExpression Construction {functions = (fn : fns)} = 204 | Pretty.group (Pretty.flatAlt long short) 205 | where 206 | short = 207 | punctuation "[" 208 | <> " " 209 | <> prettyExpression fn 210 | <> foldMap (\e -> punctuation "," <> " " <> prettyExpression e) fns 211 | <> " " 212 | <> punctuation "]" 213 | 214 | long = 215 | Pretty.align 216 | ( "[ " 217 | <> prettyLongElement fn 218 | <> foldMap (\e -> punctuation "," <> " " <> prettyLongElement e) fns 219 | <> "]" 220 | ) 221 | prettyLongElement e = prettyExpression e <> Pretty.hardline 222 | prettyExpression Combinator1 {..} = prettyCombinator1 c1 argument 223 | prettyExpression Application {..} = prettyApplication function argument 224 | prettyExpression Definition {..} = Pretty.group (Pretty.flatAlt long short) 225 | where 226 | short = 227 | keyword "Def" 228 | <> " " 229 | <> pretty name 230 | <> " " 231 | <> keyword "≡" 232 | <> " " 233 | <> prettyExpression body 234 | 235 | long = 236 | Pretty.align 237 | ( keyword "Def" 238 | <> " " 239 | <> pretty name 240 | <> Pretty.hardline 241 | <> Pretty.hardline 242 | <> " " 243 | <> keyword "≡" 244 | <> " " 245 | <> prettyExpression body 246 | ) 247 | prettyExpression If {..} = 248 | Pretty.group (Pretty.flatAlt long short) 249 | where 250 | short = 251 | prettyExpression predicate 252 | <> keyword " → " 253 | <> prettyExpression ifTrue 254 | <> keyword ";" 255 | <> " " 256 | <> prettyExpression ifFalse 257 | 258 | long = 259 | Pretty.align 260 | ( prettyExpression predicate 261 | <> Pretty.hardline 262 | <> keyword " → " 263 | <> prettyExpression ifTrue 264 | <> Pretty.hardline 265 | <> keyword ":" 266 | <> " " 267 | <> prettyExpression ifFalse 268 | ) 269 | prettyExpression other = prettyComposition other 270 | 271 | prettyCombinator1 :: Pretty a => Combinator1 -> Syntax s a -> Doc AnsiStyle 272 | prettyCombinator1 c1 argument = Pretty.group (Pretty.flatAlt long short) 273 | where 274 | short = 275 | "(" 276 | <> pretty c1 277 | <> " " 278 | <> prettyExpression argument 279 | <> ")" 280 | 281 | long = 282 | Pretty.align 283 | ( "(" 284 | <> pretty c1 285 | <> " " 286 | <> Pretty.hardline 287 | <> Pretty.hardline 288 | <> prettyExpression argument 289 | <> ")" 290 | ) 291 | 292 | prettyApplication :: Pretty a => Syntax s a -> Syntax s a -> Doc AnsiStyle 293 | prettyApplication function argument = Pretty.group (Pretty.flatAlt long short) 294 | where 295 | short = 296 | pretty function 297 | <> " " 298 | <> Pretty.operator ":" 299 | <> " " 300 | <> prettyExpression argument 301 | 302 | long = 303 | Pretty.align 304 | ( pretty function 305 | <> " " 306 | <> Pretty.hardline 307 | <> Pretty.hardline 308 | <> Pretty.operator ":" 309 | <> " " 310 | <> prettyExpression argument 311 | ) 312 | 313 | prettyCombinator2 :: 314 | Pretty a => 315 | Combinator2 -> 316 | (Syntax s a -> Doc AnsiStyle) -> 317 | (Syntax s a -> Doc AnsiStyle) 318 | prettyCombinator2 operator0 prettyNext expression@Combinator2 {c2 = operator1} 319 | | operator0 == operator1 = Pretty.group (Pretty.flatAlt long short) 320 | where 321 | short = prettyShort expression 322 | 323 | long = Pretty.align (prettyLong expression) 324 | 325 | prettyShort Combinator2 {..} 326 | | operator0 == c2 = 327 | prettyShort argument1 328 | <> " " 329 | <> pretty c2 330 | <> " " 331 | <> prettyNext argument2 332 | prettyShort other = 333 | prettyNext other 334 | 335 | prettyLong Combinator2 {..} 336 | | operator0 == c2 = 337 | prettyLong argument1 338 | <> Pretty.hardline 339 | <> pretty c2 340 | <> pretty (Text.replicate spacing " ") 341 | <> prettyNext argument2 342 | prettyLong other = 343 | pretty (Text.replicate indent " ") 344 | <> prettyNext other 345 | 346 | operatorWidth = Text.length (Pretty.toText operator0) 347 | 348 | alignment = 2 349 | 350 | align n = ((n `div` alignment) + 1) * alignment 351 | 352 | indent = align operatorWidth 353 | 354 | spacing = indent - operatorWidth 355 | prettyCombinator2 _ prettyNext other = 356 | prettyNext other 357 | 358 | prettyComposition :: Pretty a => Syntax s a -> Doc AnsiStyle 359 | prettyComposition = prettyCombinator2 Composition prettyWhile 360 | 361 | prettyWhile :: Pretty a => Syntax s a -> Doc AnsiStyle 362 | prettyWhile = prettyCombinator2 While prettyBu 363 | 364 | prettyBu :: Pretty a => Syntax s a -> Doc AnsiStyle 365 | prettyBu = prettyCombinator2 Bu prettyExpression 366 | -------------------------------------------------------------------------------- /src/Fp/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE RecursiveDo #-} 9 | 10 | -- | This module contains the logic for parsing fp files using @Earley@. 11 | module Fp.Parser ( 12 | -- * Parsing 13 | parse, 14 | 15 | -- * Errors related to parsing 16 | ParseError (..), 17 | ) where 18 | 19 | import Control.Applicative (Alternative (many), optional, (<|>)) 20 | import Control.Applicative.Combinators (sepBy) 21 | import Data.Functor (void, ($>)) 22 | import Data.Scientific (Scientific) 23 | import Data.Text (Text) 24 | import Fp.Input (Input) 25 | import Fp.Lexer (LocatedToken (LocatedToken), ParseError (..), Token) 26 | import Fp.Location (Location (..), Offset (..)) 27 | import Fp.Syntax (Syntax) 28 | import Text.Earley (Grammar, Prod, Report (..), rule, ()) 29 | 30 | import qualified Data.Text as Text 31 | import qualified Fp.Lexer as Lexer 32 | import qualified Fp.Syntax as Syntax 33 | import qualified Text.Earley as Earley 34 | 35 | type Parser r = Prod r Text LocatedToken 36 | 37 | matchLabel :: Token -> Maybe Text 38 | matchLabel (Lexer.Label l) = Just l 39 | matchLabel _ = Nothing 40 | 41 | matchObjectLabel :: Token -> Maybe Text 42 | matchObjectLabel (Lexer.ObjectLabel l) = Just l 43 | matchObjectLabel _ = Nothing 44 | 45 | matchReal :: Token -> Maybe Scientific 46 | matchReal (Lexer.RealLiteral n) = Just n 47 | matchReal _ = Nothing 48 | 49 | matchInt :: Token -> Maybe Int 50 | matchInt (Lexer.Int n) = Just n 51 | matchInt _ = Nothing 52 | 53 | matchNth :: Token -> Maybe Int 54 | matchNth (Lexer.Nth n) = Just n 55 | matchNth _ = Nothing 56 | 57 | matchNthBack :: Token -> Maybe Int 58 | matchNthBack (Lexer.NthBack n) = Just n 59 | matchNthBack _ = Nothing 60 | 61 | terminal :: (Token -> Maybe a) -> Parser r a 62 | terminal match = Earley.terminal match' 63 | where 64 | match' locatedToken_ = match (Lexer.token locatedToken_) 65 | 66 | label :: Parser r Text 67 | label = terminal matchLabel 68 | 69 | token :: Token -> Parser r () 70 | token t = void (Earley.satisfy predicate render t) 71 | where 72 | predicate locatedToken_ = Lexer.token locatedToken_ == t 73 | 74 | locatedTerminal :: (Token -> Maybe a) -> Parser r (Offset, a) 75 | locatedTerminal match = Earley.terminal match' 76 | where 77 | match' locatedToken_@LocatedToken {start} = do 78 | a <- match (Lexer.token locatedToken_) 79 | return (start, a) 80 | 81 | locatedLabel :: Parser r (Offset, Text) 82 | locatedLabel = locatedTerminal matchLabel 83 | 84 | locatedObjectLabel :: Parser r (Offset, Text) 85 | locatedObjectLabel = locatedTerminal matchObjectLabel 86 | 87 | locatedReal :: Parser r (Offset, Scientific) 88 | locatedReal = locatedTerminal matchReal 89 | 90 | locatedInt :: Parser r (Offset, Int) 91 | locatedInt = locatedTerminal matchInt 92 | 93 | locatedNth :: Parser r (Offset, Int) 94 | locatedNth = locatedTerminal matchNth 95 | 96 | locatedNthBack :: Parser r (Offset, Int) 97 | locatedNthBack = locatedTerminal matchNthBack 98 | 99 | locatedToken :: Token -> Parser r Offset 100 | locatedToken expected = 101 | Earley.terminal capture render expected 102 | where 103 | capture LocatedToken {Lexer.token = actual, ..} 104 | | expected == actual = Just start 105 | | otherwise = Nothing 106 | 107 | render :: Token -> Text 108 | render = \case 109 | Lexer.F -> "F" 110 | Lexer.T -> "T" 111 | Lexer.Equals -> "=" 112 | Lexer.ApplyToAll -> "applyToALl" 113 | Lexer.Insert -> "insert" 114 | Lexer.Comp -> "comp" 115 | Lexer.Bottom -> "bottom" 116 | Lexer.Label _ -> "a label" 117 | Lexer.ObjectLabel _ -> "a object label" 118 | Lexer.Transpose -> "transpose" 119 | Lexer.Atom -> "atom" 120 | Lexer.Tail -> "tail" 121 | Lexer.Eq -> "eq" 122 | Lexer.Null -> "null" 123 | Lexer.Reverse -> "reverse" 124 | Lexer.Distl -> "distl" 125 | Lexer.Distr -> "distr" 126 | Lexer.Length -> "length" 127 | Lexer.While -> "while" 128 | Lexer.Bu -> "bu" 129 | Lexer.Flatten -> "flatten" 130 | Lexer.Id -> "id" 131 | Lexer.NthBack n -> Text.pack (show n) <> "~" 132 | Lexer.Nth n -> "~" <> Text.pack (show n) 133 | Lexer.CloseAngle -> ">" 134 | Lexer.OpenAngle -> "<" 135 | Lexer.CloseParen -> ")" 136 | Lexer.OpenParen -> "(" 137 | Lexer.CloseBracket -> "]" 138 | Lexer.OpenBracket -> "[" 139 | Lexer.Comma -> "," 140 | Lexer.Colon -> ":" 141 | Lexer.SemiColon -> ";" 142 | Lexer.Plus -> "+" 143 | Lexer.Times -> "*" 144 | Lexer.Divide -> "/" 145 | Lexer.Dash -> "-" 146 | Lexer.UnderScore -> "_" 147 | Lexer.RealLiteral _ -> "a real literal" 148 | Lexer.Int _ -> "an integer" 149 | Lexer.Def -> "Def" 150 | Lexer.EmptySeq -> "⌽" 151 | Lexer.Arrow -> "→" 152 | Lexer.And -> "∧" 153 | Lexer.Not -> "¬" 154 | Lexer.Or -> "∨" 155 | Lexer.AtSign -> "@" 156 | Lexer.AppendLeft -> "apndl" 157 | Lexer.AppendRight -> "apndr" 158 | Lexer.RotateLeft -> "rotl" 159 | Lexer.RotateRight -> "rotr" 160 | 161 | grammar :: Grammar r (Parser r [Syntax Offset Input]) 162 | grammar = mdo 163 | expression <- 164 | rule 165 | ( do 166 | location <- locatedToken Lexer.Def 167 | name <- label 168 | token Lexer.Equals 169 | body <- primitiveExpression <|> expression 170 | pure Syntax.Definition {..} 171 | <|> do 172 | predicate <- primitiveExpression <|> expression 173 | token Lexer.Arrow 174 | ifTrue <- primitiveExpression <|> expression 175 | token Lexer.SemiColon 176 | ifFalse <- primitiveExpression <|> expression 177 | pure Syntax.If {location = Syntax.location predicate, ..} 178 | <|> do 179 | function <- primitiveExpression <|> expression 180 | token Lexer.Colon 181 | argument <- primitiveExpression <|> expression 182 | pure Syntax.Application {location = Syntax.location function, ..} 183 | <|> compExpression 184 | <|> do 185 | token Lexer.OpenParen 186 | e <- expression <|> primitiveExpression 187 | token Lexer.CloseParen 188 | return e 189 | ) 190 | 191 | let comp token_ c2 subExpression = do 192 | let snoc argument1 (operatorLocation, argument2) = 193 | Syntax.Combinator2 {location = Syntax.location argument1, ..} 194 | 195 | e0 <- subExpression 196 | 197 | ses <- many do 198 | s <- locatedToken token_ 199 | e <- subExpression 200 | return (s, e) 201 | 202 | return (foldl snoc e0 ses) 203 | 204 | compExpression <- rule (comp Lexer.Comp Syntax.Composition primitiveExpression) 205 | 206 | primitiveExpression <- 207 | rule 208 | ( do 209 | location <- locatedToken Lexer.OpenAngle 210 | optional (token Lexer.Comma) 211 | elements <- primitiveExpression `sepBy` token Lexer.Comma 212 | optional (token Lexer.Comma) 213 | token Lexer.CloseAngle 214 | pure Syntax.List {..} 215 | <|> do 216 | location <- locatedToken Lexer.OpenBracket 217 | optional (token Lexer.Comma) 218 | functions <- 219 | (compExpression <|> primitiveExpression) 220 | `sepBy` token Lexer.Comma 221 | optional (token Lexer.Comma) 222 | token Lexer.CloseBracket 223 | pure Syntax.Construction {..} 224 | <|> do 225 | location <- locatedToken Lexer.EmptySeq 226 | pure Syntax.List {elements = [], ..} 227 | <|> do 228 | location <- locatedToken Lexer.T 229 | pure Syntax.Atom {atom = Syntax.Bool True, ..} 230 | <|> do 231 | location <- locatedToken Lexer.F 232 | pure Syntax.Atom {atom = Syntax.Bool False, ..} 233 | <|> do 234 | ~(location, name) <- locatedObjectLabel 235 | pure Syntax.Atom {atom = Syntax.Symbol name, ..} 236 | <|> do 237 | ~(location, name) <- locatedLabel 238 | pure Syntax.Variable {name = name, ..} 239 | <|> do 240 | sign <- (token Lexer.Dash $> negate) <|> pure id 241 | ~(location, n) <- locatedReal 242 | pure Syntax.Atom {atom = Syntax.Real (sign n), ..} 243 | <|> do 244 | token Lexer.Dash 245 | ~(location, n) <- locatedInt 246 | pure Syntax.Atom {atom = Syntax.Int (fromIntegral (negate n)), ..} 247 | <|> do 248 | ~(location, n) <- locatedInt 249 | pure Syntax.Atom {atom = Syntax.Int (fromIntegral n), ..} 250 | <|> do 251 | location <- locatedToken Lexer.Bottom 252 | pure Syntax.Bottom {..} 253 | <|> do 254 | location <- locatedToken Lexer.Transpose 255 | pure Syntax.Primitive {primitive = Syntax.Transpose, ..} 256 | <|> do 257 | location <- locatedToken Lexer.Atom 258 | pure Syntax.Primitive {primitive = Syntax.AtomP, ..} 259 | <|> do 260 | location <- locatedToken Lexer.Eq 261 | pure Syntax.Primitive {primitive = Syntax.Eq, ..} 262 | <|> do 263 | location <- locatedToken Lexer.Null 264 | pure Syntax.Primitive {primitive = Syntax.Null, ..} 265 | <|> do 266 | location <- locatedToken Lexer.Reverse 267 | pure Syntax.Primitive {primitive = Syntax.Reverse, ..} 268 | <|> do 269 | location <- locatedToken Lexer.Distl 270 | pure Syntax.Primitive {primitive = Syntax.Distl, ..} 271 | <|> do 272 | ~(location, n) <- locatedNth 273 | pure Syntax.Primitive {primitive = Syntax.Nth n, ..} 274 | <|> do 275 | ~(location, n) <- locatedNthBack 276 | pure Syntax.Primitive {primitive = Syntax.NthBack n, ..} 277 | <|> do 278 | location <- locatedToken Lexer.Distr 279 | pure Syntax.Primitive {primitive = Syntax.Distr, ..} 280 | <|> do 281 | location <- locatedToken Lexer.Length 282 | pure Syntax.Primitive {primitive = Syntax.Length, ..} 283 | <|> do 284 | location <- locatedToken Lexer.Id 285 | pure Syntax.Primitive {primitive = Syntax.Id, ..} 286 | <|> do 287 | location <- locatedToken Lexer.Plus 288 | pure Syntax.Primitive {primitive = Syntax.Plus, ..} 289 | <|> do 290 | location <- locatedToken Lexer.Times 291 | pure Syntax.Primitive {primitive = Syntax.Times, ..} 292 | <|> do 293 | location <- locatedToken Lexer.Dash 294 | pure Syntax.Primitive {primitive = Syntax.Minus, ..} 295 | <|> do 296 | location <- locatedToken Lexer.Divide 297 | pure Syntax.Primitive {primitive = Syntax.Divide, ..} 298 | <|> do 299 | location <- locatedToken Lexer.Not 300 | pure Syntax.Primitive {primitive = Syntax.Not, ..} 301 | <|> do 302 | location <- locatedToken Lexer.And 303 | pure Syntax.Primitive {primitive = Syntax.And, ..} 304 | <|> do 305 | location <- locatedToken Lexer.Or 306 | pure Syntax.Primitive {primitive = Syntax.Or, ..} 307 | <|> do 308 | location <- locatedToken Lexer.AppendLeft 309 | pure Syntax.Primitive {primitive = Syntax.AppendLeft, ..} 310 | <|> do 311 | location <- locatedToken Lexer.AppendRight 312 | pure Syntax.Primitive {primitive = Syntax.AppendRight, ..} 313 | <|> do 314 | location <- locatedToken Lexer.Flatten 315 | pure Syntax.Primitive {primitive = Syntax.Flatten, ..} 316 | <|> do 317 | location <- locatedToken Lexer.Tail 318 | pure Syntax.Primitive {primitive = Syntax.Tail, ..} 319 | <|> do 320 | location <- locatedToken Lexer.RotateLeft 321 | pure Syntax.Primitive {primitive = Syntax.RotateLeft, ..} 322 | <|> do 323 | location <- locatedToken Lexer.RotateRight 324 | pure Syntax.Primitive {primitive = Syntax.RotateRight, ..} 325 | <|> do 326 | location <- locatedToken Lexer.AtSign 327 | token Lexer.OpenAngle 328 | token Lexer.CloseAngle 329 | pure Syntax.Primitive {primitive = Syntax.IntoSeq, ..} 330 | <|> do 331 | location <- locatedToken Lexer.Insert 332 | argument <- primitiveExpression 333 | pure Syntax.Combinator1 {c1 = Syntax.Insert, ..} 334 | <|> do 335 | location <- locatedToken Lexer.ApplyToAll 336 | argument <- primitiveExpression 337 | pure Syntax.Combinator1 {c1 = Syntax.ApplyToAll, ..} 338 | <|> do 339 | location <- locatedToken Lexer.UnderScore 340 | argument <- primitiveExpression 341 | pure Syntax.Combinator1 {c1 = Syntax.Const, ..} 342 | <|> do 343 | location <- locatedToken Lexer.While 344 | argument1 <- expression 345 | argument2 <- expression 346 | pure 347 | Syntax.Combinator2 348 | { c2 = Syntax.While 349 | , operatorLocation = Syntax.location argument1 350 | , .. 351 | } 352 | <|> do 353 | location <- locatedToken Lexer.Bu 354 | argument1 <- expression 355 | argument2 <- expression 356 | pure 357 | Syntax.Combinator2 358 | { c2 = Syntax.Bu 359 | , operatorLocation = Syntax.location argument1 360 | , .. 361 | } 362 | <|> do 363 | token Lexer.OpenParen 364 | e <- primitiveExpression 365 | token Lexer.CloseParen 366 | return e 367 | ) 368 | 369 | return (many expression) 370 | 371 | parse :: 372 | -- | Name of the input (used for error messages) 373 | String -> 374 | -- | Source code 375 | Text -> 376 | Either ParseError [Syntax Offset Input] 377 | parse name code = do 378 | tokens <- Lexer.lex name code 379 | 380 | case Earley.fullParses (Earley.parser grammar) tokens of 381 | ([], Report {..}) -> do 382 | let offset = 383 | case unconsumed of 384 | [] -> Offset (Text.length code) 385 | locatedToken_ : _ -> Lexer.start locatedToken_ 386 | 387 | Left (ParsingFailed (Location {..})) 388 | (result : _, _) -> do 389 | return result 390 | --------------------------------------------------------------------------------