├── Setup.hs ├── ChangeLog.md ├── test ├── Unit.hs ├── data │ ├── nested_let.fab │ ├── factorial.fab │ ├── ack.fab │ ├── annotation.fab │ ├── multiple_names.fab │ ├── let_poly.fab │ ├── if_then_else.fab │ ├── let_in.fab │ ├── match_value.fab │ ├── church.fab │ ├── variant.fab │ ├── calc.fab │ ├── multiple_names_let.fab │ ├── match.fab │ └── list.fab ├── Main.hs ├── LazySpec.hs ├── DesugarSpec.hs ├── MatchSpec.hs ├── HoistSpec.hs ├── FlattenSpec.hs ├── Integration.hs ├── TypingSpec.hs ├── ClosureSpec.hs ├── NamelessSpec.hs └── ParseSpec.hs ├── src ├── Errors.hs ├── Operators.hs ├── Utils.hs ├── Compile.hs ├── Enum.hs ├── Match.hs ├── Hoist.hs ├── Closure.hs ├── Desugar.hs ├── Lazy.hs ├── Nameless.hs ├── Flatten.hs ├── Codegen.hs ├── Parse.hs └── Typing.hs ├── bin ├── fabrun └── fabc ├── app └── Main.hs ├── README.md ├── .travis.yml ├── Dockerfile ├── LICENSE ├── package.yaml ├── .gitignore ├── .dockerignore ├── stack.yaml └── .stylish-haskell.yaml /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for faber 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /test/Unit.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Unit #-} 2 | -------------------------------------------------------------------------------- /test/data/nested_let.fab: -------------------------------------------------------------------------------- 1 | name main = 2 | let a = 1 in 3 | let b = 2 in 4 | a + b -------------------------------------------------------------------------------- /test/data/factorial.fab: -------------------------------------------------------------------------------- 1 | name factorial n = 2 | if n == 0 3 | then 1 4 | else n * factorial (n - 1) 5 | 6 | name main = factorial 5 -------------------------------------------------------------------------------- /src/Errors.hs: -------------------------------------------------------------------------------- 1 | module Errors where 2 | 3 | data Error = MatchFail deriving (Show, Eq) 4 | 5 | message :: Error -> String 6 | message MatchFail = "pattern match failed." 7 | -------------------------------------------------------------------------------- /test/data/ack.fab: -------------------------------------------------------------------------------- 1 | name ack m n = 2 | match (m, n) with 3 | | (0, n) -> n + 1 4 | | (m, 0) -> ack (m - 1) 1 5 | | (m, n) -> ack (m - 1) (ack m (n - 1)) 6 | 7 | name main = ack 3 4 -------------------------------------------------------------------------------- /test/data/annotation.fab: -------------------------------------------------------------------------------- 1 | name g :: forall a. a -> Int 2 | name g x = 10 3 | 4 | name main :: Int 5 | name main = f g (\x => x) 6 | where 7 | - f :: forall a b. (a -> b) -> a -> b 8 | - f g x = g x -------------------------------------------------------------------------------- /test/data/multiple_names.fab: -------------------------------------------------------------------------------- 1 | name isEven n = 2 | if n == 0 3 | then 1 4 | else isOdd (n - 1) 5 | 6 | name isOdd n = 7 | if n == 0 8 | then 0 9 | else isEven (n - 1) 10 | 11 | name main = isEven 120 -------------------------------------------------------------------------------- /bin/fabrun: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -euo pipefail 4 | 5 | function main() { 6 | local input="$1" 7 | 8 | local exetmp="$(mktemp)" 9 | 10 | fabc "$input" "$exetmp" 11 | exec "$exetmp" 12 | } 13 | 14 | main "$@" -------------------------------------------------------------------------------- /test/data/let_poly.fab: -------------------------------------------------------------------------------- 1 | name id :: forall a. a -> a 2 | name id x = x 3 | 4 | name v = const id id 1 + const 2 1 5 | where 6 | const x = \a => x 7 | 8 | name main = (id succ) (id v) 9 | where 10 | succ x = x + 1 -------------------------------------------------------------------------------- /src/Operators.hs: -------------------------------------------------------------------------------- 1 | module Operators where 2 | 3 | data BinaryOp 4 | = Add 5 | | Mul 6 | | Sub 7 | | Eq 8 | deriving (Show, Eq) 9 | 10 | data SingleOp 11 | = Positive 12 | | Negative 13 | deriving (Show, Eq) 14 | -------------------------------------------------------------------------------- /test/data/if_then_else.fab: -------------------------------------------------------------------------------- 1 | name main = 2 | if a * 2 == 20 3 | then ( 4 | if a + 4 == (a - 3) * 2 5 | then 43 6 | else 0 7 | ) 8 | else ( 9 | if 1 == 2 10 | then 0 11 | else 1 12 | ) 13 | where 14 | a = 10 -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec.Runner 4 | 5 | import qualified Integration 6 | import qualified Unit 7 | 8 | main :: IO () 9 | main = hspecWith defaultConfig {configFormatter = Nothing} $ do 10 | Unit.spec 11 | Integration.spec 12 | -------------------------------------------------------------------------------- /test/data/let_in.fab: -------------------------------------------------------------------------------- 1 | name x = 2 | let 3 | - i = var 4 | - j x = x + 1 5 | in 6 | let 7 | - f g x = g (g x) 8 | - g x = x * 2 9 | in 10 | f g (j i) 11 | where 12 | var = 10 13 | 14 | name main = func x 15 | where 16 | - func y = 17 | let a = 1 in 18 | let b = 2 in 19 | a + b + y -------------------------------------------------------------------------------- /bin/fabc: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -euo pipefail 4 | 5 | function main() { 6 | local input="$1" 7 | local output="$2" 8 | 9 | local lltmp="$(mktemp)" 10 | local otmp="$(mktemp)" 11 | 12 | faber "$input" > "$lltmp" 13 | llc "$lltmp" -o "$otmp" -relocation-model=pic -filetype=obj 14 | gcc "$otmp" -o "$output" 15 | } 16 | 17 | main "$@" -------------------------------------------------------------------------------- /test/data/match_value.fab: -------------------------------------------------------------------------------- 1 | name f x = 2 | match x with 3 | | 0 -> 2 4 | | 1 -> 3 5 | | _ -> 0 6 | 7 | name g x = 8 | match x with 9 | | (3, 2) -> 3 10 | | (4, a) -> a + 1 11 | | (a, b) -> a + b 12 | 13 | name main = a + b + c + d + e 14 | where 15 | - a = f 0 16 | - b = f 9 17 | - c = g (4, 5) 18 | - d = g (3, 2) 19 | - e = g (9, 8) -------------------------------------------------------------------------------- /test/data/church.fab: -------------------------------------------------------------------------------- 1 | name zero f x = x 2 | name one f x = f x 3 | 4 | name plus m n f x = m f (n f x) 5 | name succ = plus one 6 | name mult m n f = m (n f) 7 | 8 | name eval n = n (\x => x + 1) 0 9 | 10 | name two = succ (succ zero) 11 | name three = plus two one 12 | name five = plus three two 13 | 14 | name main = eval n 15 | where 16 | - n = mult five three -------------------------------------------------------------------------------- /test/data/variant.fab: -------------------------------------------------------------------------------- 1 | type t1 = 2 | | A Int Int 3 | | B Int 4 | 5 | type t2 = 6 | | C t1 (Int, Int) 7 | | D 8 | 9 | name complexMatch x = 10 | match x with 11 | | #C (#A a b) (c, d) -> a + b + c + d 12 | | #C (#B i) (a, b) -> i + a * b 13 | | #D -> 10 14 | 15 | name main = a + b + c 16 | where 17 | - a = complexMatch (C (A 4 5) (6, 7)) 18 | - b = complexMatch (C (B 12) (3, 4)) 19 | - c = complexMatch D -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Compile 4 | 5 | import qualified Data.ByteString.Char8 as BS 6 | import System.Environment 7 | import System.IO 8 | 9 | main :: IO () 10 | main = do 11 | filename <- (!! 0) <$> getArgs 12 | content <- readFile filename 13 | case compileToModule filename content of 14 | Right e -> BS.putStrLn =<< moduleToLLVMAssembly e 15 | Left err -> hPrint stderr err 16 | -------------------------------------------------------------------------------- /test/data/calc.fab: -------------------------------------------------------------------------------- 1 | type t 2 | = N Int 3 | | Add t t 4 | | Mul t t 5 | | Sub t t 6 | 7 | name calc v = 8 | match v with 9 | | #N i -> i 10 | | #Add a b -> calc a + calc b 11 | | #Mul a b -> calc a * calc b 12 | | #Sub a b -> calc a - calc b 13 | 14 | name main = calc t1 + succ (calc t2) 15 | where 16 | - t1 = Mul (Add (N 3) (N 5)) (Mul (N 2) (N 4)) 17 | - t2 = Sub (N 5) (Mul (N 1) (N 2)) 18 | - succ x = calc (Add (N 1) (N x)) -------------------------------------------------------------------------------- /test/data/multiple_names_let.fab: -------------------------------------------------------------------------------- 1 | name main = 2 | let 3 | - isEven n = 4 | if n == 0 5 | then 1 6 | else isOdd (n - 1) 7 | - isOdd n = 8 | if n == 0 9 | then 0 10 | else isEven (n - 1) 11 | in 12 | let 13 | - f i x = 14 | if x == (isEven 3) 15 | then i 16 | else g (i + 1) (x - 1) 17 | - g i x = 18 | if x == (isOdd 2) 19 | then i 20 | else f (i + 1) (x - 1) 21 | in 22 | isEven (f 0 10) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # faber 2 | 3 | [![Build Status](https://travis-ci.com/faber-lang/faber.svg?branch=develop)](https://travis-ci.com/faber-lang/faber) 4 | [![Docker Cloud Automated build](https://img.shields.io/docker/cloud/automated/faberlang/faber.svg)](https://hub.docker.com/r/faberlang/faber) 5 | [![Docker Cloud Build Status](https://img.shields.io/docker/cloud/build/faberlang/faber.svg)](https://hub.docker.com/r/faberlang/faber) 6 | [![MicroBadger Image](https://images.microbadger.com/badges/image/faberlang/faber.svg)](https://microbadger.com/images/faberlang/faber) 7 | 8 | functional programming language and its compiler 9 | -------------------------------------------------------------------------------- /test/data/match.fab: -------------------------------------------------------------------------------- 1 | name fst3 :: forall a b c. (a, b, c) -> a 2 | name fst3 x = match x with (a, _, _) -> a 3 | 4 | name extract x = 5 | match f x with 6 | | ((1, 2, 3), (a, b, c, d)) -> a + b + c + d 7 | | (t1, t2) -> fst3 t1 + (match t2 with 8 | | (1, a, b, c) -> a * b * c 9 | | (a, b, c, d) -> a + b + c + d) 10 | where 11 | f x = match x with ((a, (b, c)), ((d, e), (f, g))) -> ((a, b, c), (d, e, f, g)) 12 | 13 | name main = extract t1 + extract t2 14 | where 15 | - t1 = ((1, (2, 3)), ((4, 5), (6, 7))) 16 | - t2 = ((4, (5, 6)), ((1, 2), (3, 4))) -------------------------------------------------------------------------------- /test/data/list.fab: -------------------------------------------------------------------------------- 1 | type List a = Nil | Cons a (List a) 2 | 3 | name iota :: List Int 4 | name iota = gen 1 5 | where 6 | gen i = Cons i (gen (i + 1)) 7 | 8 | name take :: forall a. Int -> List a -> List a 9 | name take n l = 10 | match (n, l) with 11 | | (0, _) -> Nil 12 | | (n, #Cons x xs) -> Cons x (take (n - 1) xs) 13 | 14 | name pow :: Int -> Int -> Int 15 | name pow i n = 16 | match n with 17 | | 0 -> 1 18 | | n -> i * pow i (n - 1) 19 | 20 | name printLint :: List Int -> Int -> Int 21 | name printList l i = 22 | match l with 23 | | #Nil -> 0 24 | | #Cons x xs -> (x * pow 10 i) + printList xs (i + 1) 25 | 26 | name main :: Int 27 | name main = printList (take 9 iota) 0 -------------------------------------------------------------------------------- /test/LazySpec.hs: -------------------------------------------------------------------------------- 1 | module LazySpec (spec) where 2 | 3 | import qualified Enum as E 4 | import Lazy 5 | import qualified Operators as Op 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = do 10 | describe "lazy to strict conversion" $ do 11 | it "converts simple expressions" $ do 12 | lazyExpr (E.Apply (E.Integer 1) (E.BinaryOp Op.Add (E.Integer 1) (E.Integer 1))) `shouldBe` Apply (Integer 1) (Ref (Tuple [Integer 0, Lambda $ NthOf 1 (Assign (ParamBound 0) (Tuple [Integer 1, BinaryOp Op.Add (Integer 1) (Integer 1)]))])) 13 | lazyExpr (E.ParamBound 0) `shouldBe` LocalLet (Deref (ParamBound 0)) (If (NthOf 0 LocalBound) (NthOf 1 LocalBound) (Apply (NthOf 1 LocalBound) (ParamBound 0))) 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | dist: xenial 2 | language: generic 3 | sudo: false 4 | cache: 5 | directories: 6 | - $HOME/.stack 7 | - $HOME/.ghc 8 | - $HOME/.cabal 9 | 10 | addons: 11 | apt: 12 | sources: 13 | - llvm-toolchain-xenial-8 14 | packages: 15 | - libgmp-dev 16 | - llvm-8 17 | - llvm-8-dev 18 | 19 | before_install: 20 | - mkdir -p ~/.local/bin 21 | - export PATH=$HOME/.local/bin:$PATH 22 | - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 23 | 24 | install: 25 | - stack --no-terminal --install-ghc test --only-dependencies 26 | - stack install hlint 27 | 28 | script: 29 | - hlint src 30 | - stack --no-terminal test 31 | -------------------------------------------------------------------------------- /src/Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils where 2 | 3 | import qualified Data.Map as Map 4 | 5 | flip3 :: (a -> b -> c -> d) -> b -> c -> a -> d 6 | flip3 f b c a = f a b c 7 | 8 | mapMapM :: (Ord k, Monad m) => (a -> m b) -> Map.Map k a -> m (Map.Map k b) 9 | mapMapM f = Map.foldrWithKey folder (return Map.empty) 10 | where 11 | folder k v acc = Map.insert k <$> f v <*> acc 12 | 13 | mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) 14 | mapAndUnzip f (x:xs) = (a:as, b:bs) 15 | where 16 | (a, b) = f x 17 | (as, bs) = mapAndUnzip f xs 18 | mapAndUnzip _ [] = ([], []) 19 | 20 | foldrN :: (Num i, Enum i) => (a -> a) -> a -> i -> a 21 | foldrN f x n = foldr (const f) x [0..(n - 1)] 22 | 23 | imap :: (Num i, Enum i) => (i -> a -> b) -> [a] -> [b] 24 | imap f = zipWith f [0..] 25 | -------------------------------------------------------------------------------- /test/DesugarSpec.hs: -------------------------------------------------------------------------------- 1 | module DesugarSpec (spec) where 2 | 3 | import qualified Desugar as D 4 | import qualified Parse as P 5 | import Test.Hspec 6 | 7 | spec :: Spec 8 | spec = do 9 | describe "desugar" $ do 10 | it "convert lambdas" $ do 11 | D.desugarExpr (P.Lambda ["a", "b", "c"] (P.Integer 1)) `shouldBe` D.Lambda "a" (D.Lambda "b" (D.Lambda "c" (D.Integer 1))) 12 | 13 | it "convert parameters of definitions" $ do 14 | D.desugar [P.Name (P.NameDef "f" ["a", "b", "c"] (P.Integer 1) [])] `shouldBe` [D.Name $ D.NameDef "f" $ D.Lambda "a" (D.Lambda "b" (D.Lambda "c" (D.Integer 1)))] 15 | 16 | it "convert where clause" $ do 17 | D.desugar [P.Name (P.NameDef "f" [] (P.Variable "x") [P.NameDef "x" [] (P.Integer 1) []])] `shouldBe` [D.Name $ D.NameDef "f" $ D.LetIn [D.NameDef "x" $ D.Integer 1] $ D.Variable "x"] 18 | -------------------------------------------------------------------------------- /test/MatchSpec.hs: -------------------------------------------------------------------------------- 1 | module MatchSpec (spec) where 2 | 3 | import qualified Desugar as D 4 | import qualified Errors as Err 5 | import Match 6 | import qualified Operators as Op 7 | import Test.Hspec 8 | 9 | spec :: Spec 10 | spec = do 11 | describe "compile pattern matching" $ do 12 | it "convert integer pattern" $ do 13 | convertExpr (D.Match (D.Integer 1) [(D.PInt 1, D.Integer 2)]) `shouldBe` (LetIn [NameDef "_match0" (Integer 1)] (If (BinaryOp Op.Eq (Variable "_match0") (Integer 1)) (Integer 2) (Error Err.MatchFail))) 14 | it "convert variable pattern" $ do 15 | convertExpr (D.Match (D.Integer 1) [(D.PVar "a", D.Integer 1)]) `shouldBe` (LetIn [NameDef "_match0" (Integer 1)] (LetIn [NameDef "a" (Variable "_match0")] (Integer 1))) 16 | -- some integration tests are provided to made up for missing test cases 17 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM fpco/stack-build:lts-13.26 2 | 3 | RUN echo "deb http://apt.llvm.org/xenial/ llvm-toolchain-xenial-8 main" >> /etc/apt/sources.list 4 | RUN wget -O - https://apt.llvm.org/llvm-snapshot.gpg.key | apt-key add - 5 | RUN apt-get update 6 | RUN apt-get install -y --no-install-recommends llvm-8-dev 7 | 8 | ADD ./ /work 9 | WORKDIR /work 10 | 11 | RUN stack build 12 | RUN stack install --local-bin-path=/usr/local/bin 13 | 14 | FROM ubuntu:xenial 15 | 16 | RUN apt-get update \ 17 | && apt-get install -y --no-install-recommends wget libgmp10 ca-certificates gcc libc6-dev \ 18 | && echo "deb http://apt.llvm.org/xenial/ llvm-toolchain-xenial-8 main" >> /etc/apt/sources.list \ 19 | && wget -O - https://apt.llvm.org/llvm-snapshot.gpg.key | apt-key add - \ 20 | && apt-get update \ 21 | && apt-get install -y --no-install-recommends llvm-8 \ 22 | && update-alternatives --install /usr/local/bin/llc llc `which llc-8` 10 \ 23 | && apt-get -y remove wget \ 24 | && apt-get clean \ 25 | && rm -rf /var/lib/apt/lists/* 26 | 27 | COPY --from=0 /usr/local/bin/faber-exe /usr/local/bin/faber 28 | COPY bin/fabc /usr/local/bin/ 29 | COPY bin/fabrun /usr/local/bin/ 30 | 31 | VOLUME /data 32 | WORKDIR /data 33 | 34 | CMD ["/usr/local/bin/faber"] 35 | -------------------------------------------------------------------------------- /test/HoistSpec.hs: -------------------------------------------------------------------------------- 1 | module HoistSpec (spec) where 2 | 3 | import qualified Closure as C 4 | import Hoist 5 | import Test.Hspec 6 | 7 | hoistTest :: C.Expr -> ([Function], Expr) 8 | hoistTest = destruct . hoist . makeCode 9 | where 10 | -- this integer is dummy 11 | makeCode e = C.Code [C.Name "main" e] (C.Integer 0) 12 | destruct (Module funs (Code [Name "main" e] _)) = (funs, e) 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "function hoisting" $ do 17 | it "hoist functions" $ do 18 | hoistTest (C.Function C.Parameter) `shouldBe` ([Function 2 (Parameter 1)], FunctionRef 0) 19 | hoistTest (C.Function $ C.Function $ C.Parameter) `shouldBe` ([Function 2 (Parameter 1), Function 2 (FunctionRef 0)], FunctionRef 1) 20 | 21 | it "convert function calls" $ do 22 | hoistTest (C.Apply ( 23 | C.Tuple [ 24 | C.Function C.Parameter, 25 | C.Tuple [] 26 | ]) 27 | (C.Integer 1) 28 | ) `shouldBe` ([Function 2 $ Parameter 1] , 29 | LocalLet (Tuple [FunctionRef 0, Tuple []]) 30 | ( 31 | Call (NthOf 0 LocalBound) [NthOf 1 LocalBound, Integer 1] 32 | ) 33 | ) 34 | -------------------------------------------------------------------------------- /test/FlattenSpec.hs: -------------------------------------------------------------------------------- 1 | module FlattenSpec (spec) where 2 | 3 | import Flatten 4 | import qualified Lazy as L 5 | import qualified Nameless as N 6 | import qualified Operators as Op 7 | import Test.Hspec 8 | 9 | boundL :: Int -> Int -> L.Expr 10 | boundL loc inn = L.LetBound $ N.LetIndex 0 loc inn 11 | 12 | boundF :: Int -> Expr 13 | boundF loc = LetBound $ LetIndex 0 loc 14 | 15 | addL :: L.Expr -> L.Expr -> L.Expr 16 | addL = L.BinaryOp Op.Add 17 | 18 | addF :: Expr -> Expr -> Expr 19 | addF = BinaryOp Op.Add 20 | 21 | spec :: Spec 22 | spec = do 23 | describe "flatten of recursive definitions" $ do 24 | it "simple recursion" $ do 25 | flattenExpr (L.LetIn [boundL 0 0] (boundL 0 0)) `shouldBe` LetIn Alloc (Seq (Assign (boundF 0) (Deref $ boundF 0)) (Deref (boundF 0))) 26 | it "mutual recursion" $ do 27 | flattenExpr (L.LetIn [boundL 0 1, boundL 0 0] (boundL 0 0 `addL` boundL 0 1)) `shouldBe` LetIn Alloc (LetIn Alloc $ Seq (Assign (boundF 0) (Deref $ boundF 1)) (Seq (Assign (boundF 1) (Deref $ boundF 0)) (Deref (boundF 0) `addF` Deref (boundF 1)))) 28 | it "nested let" $ do 29 | flattenExpr (L.LetIn [L.Integer 1] $ L.LetIn [boundL 1 0] (boundL 1 0 `addL` boundL 0 0)) `shouldBe` LetIn Alloc (Seq (Assign (boundF 0) (Integer 1)) (LetIn Alloc (Seq (Assign (boundF 0) (Deref $ boundF 1)) (Deref (boundF 1) `addF` Deref (boundF 0))))) 30 | -------------------------------------------------------------------------------- /src/Compile.hs: -------------------------------------------------------------------------------- 1 | module Compile where 2 | 3 | import qualified Closure as Fab 4 | import qualified Codegen as Fab 5 | import qualified Desugar as Fab 6 | import qualified Enum as Fab 7 | import qualified Flatten as Fab 8 | import qualified Hoist as Fab 9 | import qualified Lazy as Fab 10 | import qualified Match as Fab 11 | import qualified Nameless as Fab 12 | import qualified Parse as Fab 13 | import qualified Typing as Fab 14 | 15 | import Data.ByteString 16 | import Data.Either.Extra (mapLeft) 17 | 18 | import qualified LLVM.AST as LLVMAST 19 | import qualified LLVM.Context as LLVM 20 | import qualified LLVM.Module as LLVM 21 | 22 | data CompileError 23 | = ParseError Fab.ParseError 24 | | TypeError Fab.TypeError 25 | deriving Show 26 | 27 | compileToModule :: String -> String -> Either CompileError LLVMAST.Module 28 | compileToModule filename source = do 29 | ast <- mapLeft ParseError $ Fab.parseCode filename source 30 | let ir = conv1 ast 31 | () <- mapLeft TypeError $ Fab.typing ir 32 | return $ conv2 ir 33 | where 34 | conv1 = Fab.nameless . Fab.convertMatch . Fab.desugar 35 | conv2 = Fab.codegen . Fab.hoist . Fab.closure . Fab.flatten . Fab.lazy . Fab.convertEnum 36 | 37 | moduleToLLVMAssembly :: LLVMAST.Module -> IO ByteString 38 | moduleToLLVMAssembly m = LLVM.withContext $ \ctx -> LLVM.withModuleFromAST ctx m LLVM.moduleLLVMAssembly 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright coord.e (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of coord.e nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: faber 2 | version: 0.1.0.0 3 | github: "faber-lang/faber" 4 | license: BSD3 5 | author: "coord.e" 6 | maintainer: "me@coord-e.com" 7 | copyright: "2019 coord.e" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - megaparsec 25 | - parser-combinators 26 | - mtl 27 | - containers 28 | - llvm-hs-pure 29 | - llvm-hs 30 | - text 31 | - extra 32 | - bytestring 33 | - lens 34 | - transformers 35 | 36 | library: 37 | source-dirs: src 38 | 39 | executables: 40 | faber-exe: 41 | main: Main.hs 42 | source-dirs: app 43 | ghc-options: 44 | - -threaded 45 | - -rtsopts 46 | - -with-rtsopts=-N 47 | dependencies: 48 | - faber 49 | 50 | tests: 51 | faber-test: 52 | main: Main.hs 53 | source-dirs: test 54 | ghc-options: 55 | - -threaded 56 | - -rtsopts 57 | - -with-rtsopts=-N 58 | dependencies: 59 | - faber 60 | - hspec 61 | - hspec-discover 62 | - temporary 63 | - typed-process 64 | - file-embed 65 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | faber.cabal 3 | *~ 4 | # Created by https://www.gitignore.io/api/haskell,vim,linux,macos 5 | # Edit at https://www.gitignore.io/?templates=haskell,vim,linux,macos 6 | 7 | ### Haskell ### 8 | dist 9 | dist-* 10 | cabal-dev 11 | *.o 12 | *.hi 13 | *.chi 14 | *.chs.h 15 | *.dyn_o 16 | *.dyn_hi 17 | .hpc 18 | .hsenv 19 | .cabal-sandbox/ 20 | cabal.sandbox.config 21 | *.prof 22 | *.aux 23 | *.hp 24 | *.eventlog 25 | .stack-work/ 26 | cabal.project.local 27 | cabal.project.local~ 28 | .HTF/ 29 | .ghc.environment.* 30 | 31 | ### Linux ### 32 | *~ 33 | 34 | # temporary files which can be created if a process still has a handle open of a deleted file 35 | .fuse_hidden* 36 | 37 | # KDE directory preferences 38 | .directory 39 | 40 | # Linux trash folder which might appear on any partition or disk 41 | .Trash-* 42 | 43 | # .nfs files are created when an open file is removed but is still being accessed 44 | .nfs* 45 | 46 | ### macOS ### 47 | # General 48 | .DS_Store 49 | .AppleDouble 50 | .LSOverride 51 | 52 | # Icon must end with two \r 53 | Icon 54 | 55 | # Thumbnails 56 | ._* 57 | 58 | # Files that might appear in the root of a volume 59 | .DocumentRevisions-V100 60 | .fseventsd 61 | .Spotlight-V100 62 | .TemporaryItems 63 | .Trashes 64 | .VolumeIcon.icns 65 | .com.apple.timemachine.donotpresent 66 | 67 | # Directories potentially created on remote AFP share 68 | .AppleDB 69 | .AppleDesktop 70 | Network Trash Folder 71 | Temporary Items 72 | .apdisk 73 | 74 | ### Vim ### 75 | # Swap 76 | [._]*.s[a-v][a-z] 77 | [._]*.sw[a-p] 78 | [._]s[a-rt-v][a-z] 79 | [._]ss[a-gi-z] 80 | [._]sw[a-p] 81 | 82 | # Session 83 | Session.vim 84 | 85 | # Temporary 86 | .netrwhist 87 | # Auto-generated tag files 88 | tags 89 | # Persistent undo 90 | [._]*.un~ 91 | 92 | # End of https://www.gitignore.io/api/haskell,vim,linux,macos 93 | -------------------------------------------------------------------------------- /.dockerignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | faber.cabal 3 | *~ 4 | # Created by https://www.gitignore.io/api/haskell,vim,linux,macos 5 | # Edit at https://www.gitignore.io/?templates=haskell,vim,linux,macos 6 | 7 | ### Haskell ### 8 | dist 9 | dist-* 10 | cabal-dev 11 | *.o 12 | *.hi 13 | *.chi 14 | *.chs.h 15 | *.dyn_o 16 | *.dyn_hi 17 | .hpc 18 | .hsenv 19 | .cabal-sandbox/ 20 | cabal.sandbox.config 21 | *.prof 22 | *.aux 23 | *.hp 24 | *.eventlog 25 | .stack-work/ 26 | cabal.project.local 27 | cabal.project.local~ 28 | .HTF/ 29 | .ghc.environment.* 30 | 31 | ### Linux ### 32 | *~ 33 | 34 | # temporary files which can be created if a process still has a handle open of a deleted file 35 | .fuse_hidden* 36 | 37 | # KDE directory preferences 38 | .directory 39 | 40 | # Linux trash folder which might appear on any partition or disk 41 | .Trash-* 42 | 43 | # .nfs files are created when an open file is removed but is still being accessed 44 | .nfs* 45 | 46 | ### macOS ### 47 | # General 48 | .DS_Store 49 | .AppleDouble 50 | .LSOverride 51 | 52 | # Icon must end with two \r 53 | Icon 54 | 55 | # Thumbnails 56 | ._* 57 | 58 | # Files that might appear in the root of a volume 59 | .DocumentRevisions-V100 60 | .fseventsd 61 | .Spotlight-V100 62 | .TemporaryItems 63 | .Trashes 64 | .VolumeIcon.icns 65 | .com.apple.timemachine.donotpresent 66 | 67 | # Directories potentially created on remote AFP share 68 | .AppleDB 69 | .AppleDesktop 70 | Network Trash Folder 71 | Temporary Items 72 | .apdisk 73 | 74 | ### Vim ### 75 | # Swap 76 | [._]*.s[a-v][a-z] 77 | [._]*.sw[a-p] 78 | [._]s[a-rt-v][a-z] 79 | [._]ss[a-gi-z] 80 | [._]sw[a-p] 81 | 82 | # Session 83 | Session.vim 84 | 85 | # Temporary 86 | .netrwhist 87 | # Auto-generated tag files 88 | tags 89 | # Persistent undo 90 | [._]*.un~ 91 | 92 | # End of https://www.gitignore.io/api/haskell,vim,linux,macos 93 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.24 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | extra-deps: 41 | - llvm-hs-pure-8.0.0 42 | - llvm-hs-8.0.0 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.9" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /test/Integration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Integration (spec) where 5 | 6 | import Data.ByteString.Char8 as BSC 7 | import qualified Data.ByteString.Lazy as BS 8 | import Data.FileEmbed 9 | import System.IO 10 | import System.IO.Temp 11 | import System.Process.Typed 12 | import Test.Hspec 13 | 14 | import Compile 15 | 16 | execBS :: BSC.ByteString -> IO BS.ByteString 17 | execBS = execStr . BSC.unpack 18 | 19 | execExpr :: String -> IO BS.ByteString 20 | execExpr expr = execStr $ "name main = " ++ expr 21 | 22 | execStr :: String -> IO BS.ByteString 23 | execStr content = do 24 | case compileToModule "" content of 25 | Right m -> 26 | withSystemTempFile "fabertest.ll" $ \path handle -> do 27 | BS.hPut handle =<< BS.fromStrict <$> moduleToLLVMAssembly m 28 | hClose handle 29 | fst <$> readProcess_ (shell $ "lli " ++ path) 30 | Left err -> error $ show err 31 | 32 | spec :: Spec 33 | spec = do 34 | describe "Integration Tests" $ do 35 | it "return int" $ execExpr "10" `shouldReturn` "10\n" 36 | it "arithmetic" $ do 37 | execExpr "40 + 3" `shouldReturn` "43\n" 38 | execExpr "12 * 3" `shouldReturn` "36\n" 39 | execExpr "10 - 2" `shouldReturn` "8\n" 40 | it "function application" $ execExpr "(\\x=>x) 42" `shouldReturn` "42\n" 41 | it "passing function" $ execExpr "(\\f x => f (f x)) (\\x => x+1) 3" `shouldReturn` "5\n" 42 | it "many arguments" $ execExpr "(\\a b c d => a + b + c + d) 1 2 3 4" `shouldReturn` "10\n" 43 | it "conditional" $ execBS $(embedFile "test/data/if_then_else.fab") `shouldReturn` "43\n" 44 | 45 | it "let-in and where" $ execBS $(embedFile "test/data/let_in.fab") `shouldReturn` "47\n" 46 | it "nested let-in" $ execBS $(embedFile "test/data/nested_let.fab") `shouldReturn` "3\n" 47 | it "church numerals" $ execBS $(embedFile "test/data/church.fab") `shouldReturn` "15\n" 48 | it "let polymorphism" $ execBS $(embedFile "test/data/let_poly.fab") `shouldReturn` "4\n" 49 | it "annotation" $ execBS $(embedFile "test/data/annotation.fab") `shouldReturn` "10\n" 50 | 51 | it "ackermann" $ execBS $(embedFile "test/data/ack.fab") `shouldReturn` "125\n" 52 | it "factorial" $ execBS $(embedFile "test/data/factorial.fab") `shouldReturn` "120\n" 53 | it "mutual recursion (1)" $ execBS $(embedFile "test/data/multiple_names.fab") `shouldReturn` "1\n" 54 | it "mutual recursion (2)" $ execBS $(embedFile "test/data/multiple_names_let.fab") `shouldReturn` "1\n" 55 | 56 | it "pattern match (1)" $ execBS $(embedFile "test/data/match.fab") `shouldReturn` "50\n" 57 | it "pattern match (2)" $ execBS $(embedFile "test/data/match_value.fab") `shouldReturn` "28\n" 58 | 59 | it "variants" $ execBS $(embedFile "test/data/variant.fab") `shouldReturn` "56\n" 60 | it "infinite list" $ execBS $(embedFile "test/data/list.fab") `shouldReturn` "987654321\n" 61 | it "simple tree traversal" $ execBS $(embedFile "test/data/calc.fab") `shouldReturn` "68\n" 62 | -------------------------------------------------------------------------------- /test/TypingSpec.hs: -------------------------------------------------------------------------------- 1 | module TypingSpec (spec) where 2 | 3 | import Test.Hspec 4 | 5 | import Nameless 6 | import Operators 7 | import qualified Parse as P 8 | import qualified Typing as T 9 | import Utils 10 | 11 | -- helpers 12 | typeExpr :: Expr -> Either T.TypeError T.Type 13 | typeExpr = T.runTyping . T.inferExpr 14 | 15 | expectError :: Expr -> String 16 | expectError e = case typeExpr e of 17 | Left err -> show err 18 | Right t -> error $ "typing error is expected, but typed: " ++ show t 19 | 20 | add :: Expr -> Expr -> Expr 21 | add = BinaryOp Add 22 | 23 | mul :: Expr -> Expr -> Expr 24 | mul = BinaryOp Mul 25 | 26 | pos :: Expr -> Expr 27 | pos = SingleOp Positive 28 | 29 | neg :: Expr -> Expr 30 | neg = SingleOp Negative 31 | 32 | int :: Int -> Expr 33 | int = Integer 34 | 35 | var :: Int -> Expr 36 | var = ParamBound 37 | 38 | fRef :: Expr 39 | fRef = LetBound $ LetIndex 0 0 0 40 | 41 | -- test cases 42 | spec :: Spec 43 | spec = do 44 | describe "types" $ do 45 | it "type simple terms" $ do 46 | typeExpr (int 10) `shouldBe` Right T.Integer 47 | typeExpr (int 1 `add` int 2) `shouldBe` Right T.Integer 48 | typeExpr (neg $ int 3) `shouldBe` Right T.Integer 49 | 50 | it "fail in obviously invalid situation" $ do 51 | expectError (Apply (int 1) (int 2)) `shouldContain` "UnificationFail" 52 | expectError (Lambda (var 0) `add` int 1) `shouldContain` "UnificationFail" 53 | 54 | it "type terms with lambdas" $ do 55 | typeExpr (Lambda $ var 0 `add` var 0) `shouldBe` Right (T.functionTy T.Integer T.Integer) 56 | typeExpr (Apply (Lambda $ var 0) (int 1)) `shouldBe` Right T.Integer 57 | typeExpr (Apply (Apply (Lambda $ Lambda $ Apply (var 0) (var 1)) (int 10)) (Lambda $ var 0)) `shouldBe` Right T.Integer 58 | 59 | it "type terms with complex unification" $ do 60 | typeExpr (Apply (Apply (Apply (Lambda $ Lambda $ Apply (var 0) (var 1)) (int 10)) (Lambda $ Lambda $ var 0 `add` var 1)) (int 1)) `shouldBe` Right T.Integer 61 | 62 | describe "polymorphism" $ do 63 | it "type poymorphic functions" $ do 64 | -- let f x = x in f f (f 1) 65 | typeExpr (LetIn [Nothing] [Lambda $ var 0] $ Apply (Apply fRef fRef) (Apply fRef (int 1))) `shouldBe` Right T.Integer 66 | 67 | it "doesn't generalize lambda params" $ do 68 | -- (\f => (f 0, f (\x => x))) (\x => x) 69 | expectError (Apply (Lambda $ Tuple [Apply (var 0) (int 0), Apply (var 0) (Lambda $ var 0)]) (Lambda $ var 0)) `shouldContain` "UnificationFail" 70 | 71 | describe "type annotation on name definitions" $ do 72 | it "unify with inferred type" $ do 73 | expectError (LetIn [Just $ P.Forall [] $ P.Function (P.Product []) (P.Product [])] [Lambda $ int 0] $ int 0) `shouldContain` "UnificationFail" 74 | expectError (LetIn [Just $ P.Forall [] $ P.Function (P.Product []) (P.Product [])] [Lambda $ var 0] $ Apply fRef (int 0)) `shouldContain` "UnificationFail" 75 | 76 | it "won't unify with rigid type variables" $ do 77 | expectError (LetIn [Just $ P.Forall ["a"] $ P.Function (P.Ident "a") (P.Ident "a")] [Lambda $ int 0] $ int 0) `shouldContain` "RigidUnificationFail" 78 | -------------------------------------------------------------------------------- /src/Enum.hs: -------------------------------------------------------------------------------- 1 | module Enum where 2 | 3 | import Control.Monad.State 4 | import qualified Data.Map as Map 5 | 6 | import qualified Errors as Err 7 | import qualified Nameless as N 8 | import qualified Operators as Op 9 | import Parse (TypeExpr, TypeScheme) 10 | import Utils 11 | 12 | data Expr 13 | = Integer Int 14 | | Lambda Expr 15 | | Apply Expr Expr 16 | | ParamBound Int 17 | | LetBound N.LetIndex 18 | | GlobalBound String Int 19 | | BinaryOp Op.BinaryOp Expr Expr 20 | | SingleOp Op.SingleOp Expr 21 | | Tuple [Expr] 22 | | LetIn [Maybe TypeScheme] [Expr] Expr 23 | | If Expr Expr Expr 24 | | NthOf Int Int Expr 25 | | Error Err.Error 26 | deriving (Show, Eq) 27 | 28 | data NameDef 29 | = Name String Expr deriving (Show, Eq) 30 | 31 | data TypeDef 32 | = Variant String [String] [(String, TypeExpr)] 33 | deriving (Show, Eq) 34 | 35 | newtype Code = Code [NameDef] deriving (Show, Eq) 36 | 37 | type Convert = State (Map.Map String Int) 38 | 39 | runConvert :: Convert a -> a 40 | runConvert a = evalState a Map.empty 41 | 42 | convertExpr :: N.Expr -> Convert Expr 43 | convertExpr (N.ParamBound i) = return $ ParamBound i 44 | convertExpr (N.LetBound i) = return $ LetBound i 45 | convertExpr (N.GlobalBound s i) = return $ GlobalBound s i 46 | convertExpr (N.Integer i) = return $ Integer i 47 | convertExpr (N.Lambda x) = Lambda <$> convertExpr x 48 | convertExpr (N.Apply a b) = Apply <$> convertExpr a <*> convertExpr b 49 | convertExpr (N.BinaryOp op a b) = BinaryOp op <$> convertExpr a <*> convertExpr b 50 | convertExpr (N.SingleOp op x) = SingleOp op <$> convertExpr x 51 | convertExpr (N.Tuple xs) = Tuple <$> mapM convertExpr xs 52 | convertExpr (N.LetIn ts defs body) = LetIn ts <$> mapM convertExpr defs <*> convertExpr body 53 | convertExpr (N.If c t e) = If <$> convertExpr c <*> convertExpr t <*> convertExpr e 54 | convertExpr (N.NthOf n i e) = NthOf n i <$> convertExpr e 55 | convertExpr (N.Error err) = return $ Error err 56 | convertExpr (N.CtorApp name e) = do 57 | idx <- gets (Map.! name) 58 | e' <- convertExpr e 59 | return $ Tuple [Integer idx, e'] 60 | convertExpr (N.IsCtor name e) = do 61 | idx <- gets (Map.! name) 62 | e' <- convertExpr e 63 | return $ BinaryOp Op.Eq (NthOf 2 0 e') (Integer idx) 64 | convertExpr (N.DataOf _ e) = NthOf 2 1 <$> convertExpr e 65 | 66 | convertCode :: N.Code -> Code 67 | convertCode (N.Code _ typeDefs nameDefs) = Code $ runConvert defs 68 | where 69 | defs = defineCtors typeDefs >> convertDefs nameDefs 70 | 71 | convertDefs :: [N.NameDef] -> Convert [NameDef] 72 | convertDefs = mapM convertDef 73 | 74 | convertDef :: N.NameDef -> Convert NameDef 75 | convertDef (N.Name name body) = Name name <$> convertExpr body 76 | 77 | defineCtors :: [N.TypeDef] -> Convert () 78 | defineCtors = mapM_ defineCtor 79 | 80 | defineCtor :: N.TypeDef -> Convert () 81 | defineCtor (N.Variant _ _ ctors) = zipWithM_ defineOne ctors [0..] 82 | where 83 | defineOne :: (String, TypeExpr) -> Int -> Convert () 84 | defineOne (name, _) idx = modify (Map.insert name idx) 85 | 86 | convertEnum :: N.Code -> Code 87 | convertEnum = convertCode 88 | -------------------------------------------------------------------------------- /src/Match.hs: -------------------------------------------------------------------------------- 1 | module Match where 2 | 3 | import Desugar (Pattern (..)) 4 | import qualified Desugar as D 5 | import qualified Errors as Err 6 | import qualified Operators as Op 7 | import Parse (TypeExpr, TypeScheme) 8 | 9 | data Expr 10 | = Integer Int 11 | | Lambda String Expr 12 | | CtorApp String Expr 13 | | Apply Expr Expr 14 | | Variable String 15 | | BinaryOp Op.BinaryOp Expr Expr 16 | | SingleOp Op.SingleOp Expr 17 | | Tuple [Expr] 18 | | LetIn [NameDef] Expr 19 | | If Expr Expr Expr 20 | | NthOf Int Int Expr 21 | | IsCtor String Expr 22 | | DataOf String Expr 23 | | Error Err.Error 24 | deriving (Show, Eq) 25 | 26 | data NameDef 27 | = NameDef String Expr 28 | | TypeAnnot String TypeScheme 29 | deriving (Show, Eq) 30 | 31 | newtype TypeDef 32 | = Variant [(String, TypeExpr)] 33 | deriving (Show, Eq) 34 | 35 | data Def 36 | = Name NameDef 37 | | Type String [String] TypeDef 38 | deriving (Show, Eq) 39 | 40 | type Code = [Def] 41 | 42 | convertPattern :: Int -> Expr -> Expr -> Pattern -> Expr -> Expr 43 | convertPattern d fallback target pat expr = localLet target $ case pat of 44 | -- `s` must be fresh in rhs of NameDef 45 | PVar s -> LetIn [NameDef s target'] expr 46 | PWildcard -> expr 47 | PInt i -> If (BinaryOp Op.Eq target' $ Integer i) expr fallback 48 | PTuple ps -> foldr (folder $ length ps) expr (zip ps [0..]) 49 | PCtor n p -> If (IsCtor n target') (convPat' (DataOf n target') p expr) fallback 50 | where 51 | convPat' = convertPattern (d+1) fallback 52 | folder len (x, idx) = convPat' (NthOf len idx target') x 53 | bName = "_match" ++ show d 54 | localLet a = LetIn [NameDef bName a] 55 | target' = Variable bName 56 | 57 | runConvertPattern :: Expr -> Expr -> Pattern -> Expr -> Expr 58 | runConvertPattern = convertPattern 0 59 | 60 | convertExpr :: D.Expr -> Expr 61 | convertExpr (D.Apply fn arg) = Apply (convertExpr fn) (convertExpr arg) 62 | convertExpr (D.Lambda p body) = Lambda p $ convertExpr body 63 | convertExpr (D.CtorApp name e) = CtorApp name $ convertExpr e 64 | convertExpr (D.LetIn defs body) = LetIn (map go defs) (convertExpr body) 65 | where 66 | go (D.NameDef name expr) = NameDef name $ convertExpr expr 67 | go (D.TypeAnnot name scheme) = TypeAnnot name scheme 68 | convertExpr (D.Variable name) = Variable name 69 | convertExpr (D.Integer i) = Integer i 70 | convertExpr (D.BinaryOp op a b) = BinaryOp op (convertExpr a) (convertExpr b) 71 | convertExpr (D.SingleOp op x) = SingleOp op $ convertExpr x 72 | convertExpr (D.Tuple xs) = Tuple $ map convertExpr xs 73 | convertExpr (D.If c t e) = If (convertExpr c) (convertExpr t) (convertExpr e) 74 | convertExpr (D.Match target arms) = matcher (convertExpr target) arms 75 | where 76 | matcher t ((p, e):xs) = runConvertPattern (matcher t xs) t p (convertExpr e) 77 | matcher _ [] = Error Err.MatchFail 78 | 79 | convertDef :: D.Def -> Def 80 | convertDef (D.Name (D.NameDef name expr)) = Name (NameDef name $ convertExpr expr) 81 | convertDef (D.Name (D.TypeAnnot name scheme)) = Name (TypeAnnot name scheme) 82 | convertDef (D.Type name vars (D.Variant xs)) = Type name vars $ Variant xs 83 | 84 | convertCode :: D.Code -> Code 85 | convertCode = map convertDef 86 | 87 | convertMatch :: D.Code -> Code 88 | convertMatch = convertCode 89 | -------------------------------------------------------------------------------- /src/Hoist.hs: -------------------------------------------------------------------------------- 1 | module Hoist where 2 | 3 | import qualified Closure as C 4 | import Control.Monad.State 5 | import qualified Errors as Err 6 | import qualified Operators as Op 7 | import Utils 8 | 9 | -- `Call` and `Function` directly correspond to the actual call and function 10 | data Function = Function Int Expr deriving (Show, Eq) 11 | 12 | data Expr 13 | = Integer Int 14 | | Parameter Int 15 | | FunctionRef Int 16 | | NameRef String 17 | | LetRef Int 18 | | Call Expr [Expr] 19 | | BinaryOp Op.BinaryOp Expr Expr 20 | | SingleOp Op.SingleOp Expr 21 | | Tuple [Expr] 22 | | NthOf Int Expr 23 | | LocalLet Expr Expr 24 | | LocalBound 25 | | Alloc 26 | | Ref Expr 27 | | Assign Expr Expr 28 | | Seq Expr Expr 29 | | Deref Expr 30 | | If Expr Expr Expr 31 | | LetIn Expr Expr 32 | | Error Err.Error 33 | deriving (Show, Eq) 34 | 35 | data Def = Name String Expr deriving (Show, Eq) 36 | 37 | data Code = 38 | Code { definitions :: [Def] 39 | , entrypoint :: Expr } 40 | deriving (Show, Eq) 41 | 42 | data Module = 43 | Module { functions :: [Function] 44 | , code :: Code } 45 | deriving (Show, Eq) 46 | 47 | type Hoist = State [Function] 48 | 49 | hoistFun :: Expr -> Hoist Expr 50 | hoistFun e = do 51 | modify (Function 2 e:) 52 | gets (FunctionRef . pred <$> length) 53 | 54 | convertApply :: Expr -> Expr -> Hoist Expr 55 | convertApply a b = return $ LocalLet a $ Call (NthOf 0 LocalBound) [NthOf 1 LocalBound, b] 56 | 57 | hoistExpr :: C.Expr -> Hoist Expr 58 | -- function hoisting 59 | hoistExpr (C.Function e) = hoistFun =<< hoistExpr e 60 | -- closure calling convention 61 | hoistExpr (C.Apply a b) = join $ convertApply <$> hoistExpr a <*> hoistExpr b 62 | hoistExpr C.Parameter = return $ Parameter 1 63 | hoistExpr C.Env = return $ Parameter 0 64 | -- boring conversion 65 | hoistExpr (C.LetBound i) = return $ LetRef i 66 | hoistExpr (C.GlobalName name) = return $ NameRef name 67 | hoistExpr (C.Integer i) = return $ Integer i 68 | hoistExpr (C.BinaryOp op a b) = BinaryOp op <$> hoistExpr a <*> hoistExpr b 69 | hoistExpr (C.SingleOp op x) = SingleOp op <$> hoistExpr x 70 | hoistExpr (C.Tuple xs) = Tuple <$> mapM hoistExpr xs 71 | hoistExpr (C.NthOf i x) = NthOf i <$> hoistExpr x 72 | hoistExpr (C.Ref x) = Ref <$> hoistExpr x 73 | hoistExpr (C.Assign a b) = Assign <$> hoistExpr a <*> hoistExpr b 74 | hoistExpr (C.Seq a b) = Seq <$> hoistExpr a <*> hoistExpr b 75 | hoistExpr (C.Deref x) = Deref <$> hoistExpr x 76 | hoistExpr (C.If c t e) = If <$> hoistExpr c <*> hoistExpr t <*> hoistExpr e 77 | hoistExpr (C.LocalLet a b) = LocalLet <$> hoistExpr a <*> hoistExpr b 78 | hoistExpr C.LocalBound = return LocalBound 79 | hoistExpr C.Alloc = return Alloc 80 | hoistExpr (C.Error err) = return $ Error err 81 | hoistExpr (C.LetIn def body) = LetIn <$> hoistExpr def <*> hoistExpr body 82 | 83 | hoistDef :: C.Def -> Hoist Def 84 | hoistDef (C.Name name body) = Name name <$> hoistExpr body 85 | 86 | hoistCode :: C.Code -> Hoist Code 87 | hoistCode (C.Code defs entry) = Code <$> mapM hoistDef defs <*> hoistExpr entry 88 | 89 | hoist :: C.Code -> Module 90 | hoist c = Module { functions = reverse funs, code = c' } 91 | where 92 | (c', funs) = runState (hoistCode c) [] 93 | -------------------------------------------------------------------------------- /test/ClosureSpec.hs: -------------------------------------------------------------------------------- 1 | module ClosureSpec (spec) where 2 | 3 | import Test.Hspec 4 | 5 | import Closure 6 | import qualified Flatten as F 7 | 8 | spec :: Spec 9 | spec = do 10 | describe "convert conversion" $ do 11 | it "convert lambdas" $ do 12 | -- \. 0 13 | closureExpr (F.Lambda $ F.ParamBound 0) `shouldBe` Tuple [Function Parameter, Tuple []] 14 | -- \.\. 0 1 15 | closureExpr (F.Lambda ( 16 | F.Lambda ( 17 | F.Apply (F.ParamBound 0) (F.ParamBound 1) 18 | ) 19 | )) `shouldBe` ( 20 | Tuple [ 21 | Function ( 22 | Tuple [ 23 | Function ( 24 | Apply Parameter (NthOf 0 Env) 25 | ), 26 | Tuple [ 27 | Parameter 28 | ] 29 | ] 30 | ), 31 | Tuple [] 32 | ]) 33 | 34 | it "convert lambdas with reference to the global name" $ do 35 | closureExpr (F.Apply (F.GlobalBound "f" 0) (F.Lambda $ F.GlobalBound "g" 1)) `shouldBe` Apply (GlobalName "f") (Tuple [Function $ NthOf 0 Env, Tuple [GlobalName "g"]]) 36 | 37 | it "convert lambdas with multiple occured parameter" $ do 38 | -- \. 0 0 39 | closureExpr (F.Lambda $ F.Apply (F.ParamBound 0) (F.ParamBound 0)) `shouldBe` Tuple [Function (Apply Parameter Parameter), Tuple []] 40 | -- \.\. 0 1 0 1 41 | closureExpr (F.Lambda ( 42 | F.Lambda ( 43 | F.Apply ( 44 | F.Apply ( 45 | F.Apply (F.ParamBound 0) (F.ParamBound 1) 46 | ) 47 | (F.ParamBound 0) 48 | ) 49 | (F.ParamBound 1) 50 | ) 51 | )) `shouldBe` ( 52 | Tuple [ 53 | Function ( 54 | Tuple [ 55 | Function ( 56 | Apply ( 57 | Apply ( 58 | Apply Parameter (NthOf 0 Env) 59 | ) 60 | Parameter 61 | ) 62 | (NthOf 0 Env) 63 | ), 64 | Tuple [ 65 | Parameter 66 | ] 67 | ] 68 | ), 69 | Tuple [] 70 | ]) 71 | 72 | it "convert deeply nested lambdas" $ do 73 | -- \.\.\. 0 1 2 74 | closureExpr (F.Lambda ( 75 | F.Lambda ( 76 | F.Lambda ( 77 | F.Apply ( 78 | F.Apply (F.ParamBound 2) (F.ParamBound 1) 79 | ) 80 | (F.ParamBound 0) 81 | ) 82 | ) 83 | )) `shouldBe` ( 84 | Tuple [ 85 | Function ( 86 | Tuple [ 87 | Function ( 88 | Tuple [ 89 | Function ( 90 | Apply ( 91 | Apply (NthOf 0 Env) (NthOf 1 Env) 92 | ) 93 | Parameter 94 | ), 95 | Tuple [ 96 | NthOf 0 Env, 97 | Parameter 98 | ] 99 | ] 100 | ), 101 | Tuple [Parameter] 102 | ] 103 | ), 104 | Tuple [] 105 | ]) 106 | -------------------------------------------------------------------------------- /test/NamelessSpec.hs: -------------------------------------------------------------------------------- 1 | module NamelessSpec (spec) where 2 | 3 | 4 | import qualified Match as M 5 | import qualified Nameless as N 6 | 7 | import Control.Monad.Reader 8 | import qualified Data.Map as Map 9 | import Test.Hspec 10 | 11 | namelessExpr :: M.Expr -> N.Expr 12 | namelessExpr e = runReader (N.namelessExpr e) N.initEnv 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "basic conversion" $ do 17 | it "convert variable indices" $ do 18 | namelessExpr (M.Lambda "x" (M.Variable "x")) `shouldBe` N.Lambda (N.ParamBound 0) 19 | namelessExpr (M.Lambda "x" (M.Lambda "y" (M.Variable "x"))) `shouldBe` N.Lambda (N.Lambda (N.ParamBound 1)) 20 | 21 | it "convert shadowing names" $ do 22 | namelessExpr (M.Lambda "x" (M.Lambda "x" (M.Variable "x"))) `shouldBe` N.Lambda (N.Lambda (N.ParamBound 0)) 23 | 24 | describe "global names" $ do 25 | it "convert global name reference" $ do 26 | N.nameless [M.Name (M.NameDef "a" $ M.Integer 1), M.Name (M.NameDef "main" $ M.Variable "a")] `shouldBe` N.Code Map.empty [] [N.Name "a" $ N.Integer 1, N.Name "main" $ N.GlobalBound "a" 0] 27 | 28 | describe "complex examples" $ do 29 | it "complex example 1" $ do 30 | namelessExpr (M.Lambda "z" ( 31 | M.Apply ( 32 | M.Lambda "y" ( 33 | M.Apply (M.Variable "y") (M.Lambda "x" (M.Variable "x")) 34 | ) 35 | ) 36 | ( 37 | M.Lambda "x" ( 38 | M.Apply (M.Variable "z") (M.Variable "x") 39 | ) 40 | ) 41 | )) `shouldBe` ( 42 | N.Lambda ( 43 | N.Apply ( 44 | N.Lambda ( 45 | N.Apply (N.ParamBound 0) (N.Lambda (N.ParamBound 0)) 46 | ) 47 | ) 48 | ( 49 | N.Lambda ( 50 | N.Apply (N.ParamBound 1) (N.ParamBound 0) 51 | ) 52 | ) 53 | )) 54 | 55 | it "complex example 2, z combinator" $ do 56 | namelessExpr (M.Lambda "f" ( 57 | M.Apply ( 58 | M.Lambda "x" ( 59 | M.Apply 60 | (M.Variable "f") 61 | (M.Lambda "y" ( 62 | M.Apply (M.Apply (M.Variable "x") (M.Variable "x")) (M.Variable "y") 63 | )) 64 | ) 65 | ) 66 | ( 67 | M.Lambda "x" ( 68 | M.Apply 69 | (M.Variable "f") 70 | (M.Lambda "y" ( 71 | M.Apply (M.Apply (M.Variable "x") (M.Variable "x")) (M.Variable "y") 72 | )) 73 | ) 74 | ) 75 | )) `shouldBe` ( 76 | N.Lambda ( 77 | N.Apply ( 78 | N.Lambda ( 79 | N.Apply 80 | (N.ParamBound 1) 81 | (N.Lambda ( 82 | N.Apply (N.Apply (N.ParamBound 1) (N.ParamBound 1)) (N.ParamBound 0) 83 | )) 84 | ) 85 | ) 86 | ( 87 | N.Lambda ( 88 | N.Apply 89 | (N.ParamBound 1) 90 | (N.Lambda ( 91 | N.Apply (N.Apply (N.ParamBound 1) (N.ParamBound 1)) (N.ParamBound 0) 92 | )) 93 | ) 94 | ) 95 | )) 96 | -------------------------------------------------------------------------------- /src/Closure.hs: -------------------------------------------------------------------------------- 1 | module Closure where 2 | 3 | import Control.Exception (assert) 4 | import Control.Monad.Reader 5 | import Control.Monad.State 6 | import Data.List 7 | 8 | import qualified Errors as Err 9 | import qualified Flatten as F 10 | import qualified Operators as Op 11 | import Utils 12 | 13 | data Expr 14 | = Integer Int 15 | | Function Expr 16 | | GlobalName String 17 | | Parameter 18 | | Env 19 | | LetBound Int 20 | | Apply Expr Expr 21 | | BinaryOp Op.BinaryOp Expr Expr 22 | | SingleOp Op.SingleOp Expr 23 | | Tuple [Expr] 24 | | NthOf Int Expr 25 | | Alloc 26 | | Ref Expr 27 | | Assign Expr Expr 28 | | Seq Expr Expr 29 | | Deref Expr 30 | | If Expr Expr Expr 31 | | LocalLet Expr Expr 32 | | LocalBound 33 | | LetIn Expr Expr 34 | | Error Err.Error 35 | deriving (Show, Eq) 36 | 37 | data Def = Name String Expr deriving (Show, Eq) 38 | 39 | data Code = 40 | Code { definitions :: [Def] 41 | , entrypoint :: Expr } 42 | deriving (Show, Eq) 43 | 44 | -- holds a set of free variables as a state 45 | type Closure = ReaderT Int (State [F.Expr]) 46 | 47 | update :: F.Expr -> Closure Int 48 | update e = do 49 | fvs <- get 50 | case elemIndex e fvs of 51 | Just idx -> return idx 52 | Nothing -> do 53 | put $ fvs ++ [e] 54 | return $ length fvs 55 | 56 | incrDepth :: Closure a -> Closure a 57 | incrDepth = local succ 58 | 59 | -- closure a body of lambda 60 | closureBody :: F.Expr -> Closure Expr 61 | closureBody (F.ParamBound 0) = return Parameter 62 | closureBody (F.ParamBound i) = flip NthOf Env <$> update (F.ParamBound $ i - 1) 63 | closureBody (F.GlobalBound s 0) = return $ GlobalName s 64 | closureBody (F.GlobalBound s i) = flip NthOf Env <$> update (F.GlobalBound s $ i - 1) 65 | closureBody (F.LetBound i) | F.lambdaIndex i == 0 = return $ LetBound $ F.letIndex i 66 | | otherwise = flip NthOf Env <$> (update =<< asks (F.LetBound . decrIndex i)) 67 | where 68 | decrIndex (F.LetIndex lam loc) depth = F.LetIndex (pred lam) (loc - depth) 69 | closureBody (F.Lambda e) = do 70 | t <- closureBody $ F.Tuple fvs 71 | return $ Tuple [Function body, t] 72 | where 73 | (body, fvs) = runClosureBody e 74 | closureBody (F.Integer i) = return $ Integer i 75 | closureBody (F.Apply a b) = Apply <$> closureBody a <*> closureBody b 76 | closureBody (F.BinaryOp op a b) = BinaryOp op <$> closureBody a <*> closureBody b 77 | closureBody (F.SingleOp op x) = SingleOp op <$> closureBody x 78 | closureBody (F.Tuple xs) = Tuple <$> mapM closureBody xs 79 | closureBody (F.NthOf i x) = NthOf i <$> closureBody x 80 | closureBody (F.Ref x) = Ref <$> closureBody x 81 | closureBody (F.Assign a b) = Assign <$> closureBody a <*> closureBody b 82 | closureBody (F.Seq a b) = Seq <$> closureBody a <*> closureBody b 83 | closureBody (F.Deref x) = Deref <$> closureBody x 84 | closureBody (F.If c t e) = If <$> closureBody c <*> closureBody t <*> closureBody e 85 | closureBody (F.LocalLet a b) = LocalLet <$> closureBody a <*> closureBody b 86 | closureBody F.Alloc = return Alloc 87 | closureBody F.LocalBound = return LocalBound 88 | closureBody (F.Error err) = return $ Error err 89 | closureBody (F.LetIn def body) = incrDepth $ LetIn <$> closureBody def <*> closureBody body 90 | 91 | runClosureBody :: F.Expr -> (Expr, [F.Expr]) 92 | runClosureBody e = runState (runReaderT (closureBody e) 0) [] 93 | 94 | -- closure a top-level expression 95 | closureExpr :: F.Expr -> Expr 96 | closureExpr e = check $ runClosureBody e 97 | where 98 | check (e', fvs) = assert (null fvs) e' 99 | 100 | closureDef :: F.Def -> Def 101 | closureDef (F.Name name body) = Name name $ closureExpr body 102 | 103 | closure :: F.Code -> Code 104 | closure (F.Code defs entry)= Code (map closureDef defs) (closureExpr entry) 105 | -------------------------------------------------------------------------------- /src/Desugar.hs: -------------------------------------------------------------------------------- 1 | module Desugar where 2 | 3 | import Data.Bifunctor (bimap) 4 | 5 | import qualified Operators as Op 6 | import Parse (TypeExpr (..), TypeScheme (..)) 7 | import qualified Parse as P 8 | 9 | data Pattern 10 | = PVar String 11 | | PWildcard 12 | | PInt Int 13 | | PCtor String Pattern 14 | | PTuple [Pattern] 15 | deriving (Show, Eq) 16 | 17 | data Expr 18 | = Integer Int 19 | | Lambda String Expr 20 | | Apply Expr Expr 21 | | CtorApp String Expr 22 | | Variable String 23 | | BinaryOp Op.BinaryOp Expr Expr 24 | | SingleOp Op.SingleOp Expr 25 | | Tuple [Expr] 26 | | LetIn [NameDef] Expr 27 | | If Expr Expr Expr 28 | | Match Expr [(Pattern, Expr)] 29 | deriving (Show, Eq) 30 | 31 | data NameDef 32 | = NameDef String Expr 33 | | TypeAnnot String TypeScheme 34 | deriving (Show, Eq) 35 | 36 | newtype TypeDef 37 | = Variant [(String, TypeExpr)] 38 | deriving (Show, Eq) 39 | 40 | data Def 41 | = Name NameDef 42 | | Type String [String] TypeDef 43 | deriving (Show, Eq) 44 | 45 | type Code = [Def] 46 | 47 | desugarPattern :: P.Pattern -> Pattern 48 | desugarPattern (P.PVar name) = PVar name 49 | desugarPattern P.PWildcard = PWildcard 50 | desugarPattern (P.PInt i) = PInt i 51 | desugarPattern (P.PTuple xs) = PTuple $ map desugarPattern xs 52 | desugarPattern (P.PCtor name xs) = PCtor name $ desugarPattern $ P.PTuple xs 53 | 54 | desugarLambda :: [String] -> Expr -> Expr 55 | desugarLambda = flip $ foldr Lambda 56 | 57 | desugarExpr :: P.Expr -> Expr 58 | desugarExpr (P.Lambda ps body) = desugarLambda ps $ desugarExpr body 59 | desugarExpr (P.Integer i) = Integer i 60 | desugarExpr (P.Apply a b) = Apply (desugarExpr a) (desugarExpr b) 61 | desugarExpr (P.Variable x) = Variable x 62 | desugarExpr (P.BinaryOp op a b) = BinaryOp op (desugarExpr a) (desugarExpr b) 63 | desugarExpr (P.SingleOp op x) = SingleOp op $ desugarExpr x 64 | desugarExpr (P.Tuple xs) = Tuple $ map desugarExpr xs 65 | desugarExpr (P.LetIn defs x) = LetIn (map desugarNameDef defs) $ desugarExpr x 66 | desugarExpr (P.If c t e) = If (desugarExpr c) (desugarExpr t) (desugarExpr e) 67 | desugarExpr (P.Match t arms) = Match (desugarExpr t) (map (bimap desugarPattern desugarExpr) arms) 68 | 69 | desugarNameDef :: P.NameDef -> NameDef 70 | desugarNameDef (P.NameDef name ps body []) = NameDef name $ desugarLambda ps $ desugarExpr body 71 | desugarNameDef (P.NameDef name ps body defs) = NameDef name $ LetIn (map desugarNameDef defs) $ desugarLambda ps $ desugarExpr body 72 | -- using `TypeScheme` from `Parse` directly 73 | desugarNameDef (P.TypeAnnot name ty) = TypeAnnot name ty 74 | 75 | makeCtorFunction :: String -> [String] -> (String, [TypeExpr]) -> [Def] 76 | makeCtorFunction tyname vars (ctor, ts) = [Name typeAnnot, Name nameDef] 77 | where 78 | name i = "__ctorparam" ++ show i 79 | names = map name [0..(pred $ length ts)] 80 | body = CtorApp ctor (Tuple $ map Variable names) 81 | nameDef = NameDef ctor $ desugarLambda names body 82 | ctorType = foldl ApplyTy (Ident tyname) $ map Ident vars 83 | scheme = Forall vars $ foldr Function ctorType ts 84 | typeAnnot = TypeAnnot ctor scheme 85 | 86 | desugarTypeDef :: String -> [String] -> P.TypeDef -> (TypeDef, [Def]) 87 | desugarTypeDef tyname vars (P.Variant xs) = (typeDef, nameDefs) 88 | where 89 | f (ctor, ts) = (ctor, Product ts) 90 | typeDef = Variant $ map f xs 91 | nameDefs = concatMap (makeCtorFunction tyname vars) xs 92 | 93 | desugarDef :: P.Def -> [Def] -> [Def] 94 | desugarDef (P.Name body) acc = (Name $ desugarNameDef body):acc 95 | desugarDef (P.Type name vars body) acc = Type name vars typeDef:nameDefs ++ acc 96 | where 97 | (typeDef, nameDefs) = desugarTypeDef name vars body 98 | 99 | desugar :: P.Code -> Code 100 | desugar = foldr desugarDef [] 101 | -------------------------------------------------------------------------------- /src/Lazy.hs: -------------------------------------------------------------------------------- 1 | module Lazy where 2 | 3 | import Control.Monad.Reader 4 | import Data.Bool (bool) 5 | import Data.Tuple.Extra (first, second) 6 | 7 | import qualified Enum as E 8 | import qualified Errors as Err 9 | import qualified Nameless as N 10 | import qualified Operators as Op 11 | 12 | import Utils 13 | 14 | data Expr 15 | = Integer Int 16 | | Lambda Expr 17 | | Apply Expr Expr 18 | | ParamBound Int 19 | | LetBound N.LetIndex 20 | | GlobalBound String Int 21 | | BinaryOp Op.BinaryOp Expr Expr 22 | | SingleOp Op.SingleOp Expr 23 | | Tuple [Expr] 24 | | NthOf Int Expr 25 | | Ref Expr 26 | | Assign Expr Expr 27 | | Deref Expr 28 | | If Expr Expr Expr 29 | | LocalLet Expr Expr 30 | | LocalBound 31 | | LetIn [Expr] Expr 32 | | Error Err.Error 33 | deriving (Show, Eq) 34 | 35 | data Def = Name String Expr deriving (Show, Eq) 36 | 37 | data Code = 38 | Code { definitions :: [Def] 39 | , entrypoint :: Expr } 40 | deriving (Show, Eq) 41 | 42 | type Lift = Reader (Int, Int) 43 | 44 | liftVars :: E.Expr -> Lift E.Expr 45 | liftVars b@(E.ParamBound i) = bool b (E.ParamBound $ i + 1) <$> asks shouldLift 46 | where 47 | shouldLift (n, _) = i >= n 48 | liftVars b@(E.LetBound i) = bool b (E.LetBound $ N.mapLambdaIndex succ i) <$> asks (shouldLift i) 49 | where 50 | shouldLift (N.LetIndex lamI letI _) (n, m) = lamI > n || (lamI == n && letI >= m) 51 | liftVars (E.GlobalBound s i) = return $ E.GlobalBound s (i + 1) 52 | liftVars (E.Integer i) = return $ E.Integer i 53 | liftVars (E.Lambda x) = E.Lambda <$> local (first succ) (liftVars x) 54 | liftVars (E.Apply a b) = E.Apply <$> liftVars a <*> liftVars b 55 | liftVars (E.BinaryOp op a b) = E.BinaryOp op <$> liftVars a <*> liftVars b 56 | liftVars (E.SingleOp op x) = E.SingleOp op <$> liftVars x 57 | liftVars (E.Tuple xs) = E.Tuple <$> mapM liftVars xs 58 | liftVars (E.LetIn ts defs body) = local (second succ) $ E.LetIn ts <$> mapM liftVars defs <*> liftVars body 59 | liftVars (E.If c t e) = E.If <$> liftVars c <*> liftVars t <*> liftVars e 60 | liftVars (E.NthOf n i e) = E.NthOf n i <$> liftVars e 61 | liftVars (E.Error err) = return $ E.Error err 62 | 63 | makeEvaledThunk :: Expr -> Expr 64 | makeEvaledThunk e = Ref $ Tuple [Integer 1, e] 65 | 66 | makeThunk :: E.Expr -> Expr 67 | makeThunk e = Ref $ Tuple [Integer 0, code] 68 | where 69 | code = Lambda $ NthOf 1 $ Assign (ParamBound 0) updated 70 | updated = Tuple [Integer 1, lazyExpr $ runReader (liftVars e) (0, 0)] 71 | 72 | evalThunk :: Expr -> Expr 73 | evalThunk e = LocalLet (Deref e) $ If cond then_ else_ 74 | where 75 | cond = NthOf 0 LocalBound 76 | then_ = NthOf 1 LocalBound 77 | else_ = Apply (NthOf 1 LocalBound) e 78 | 79 | isValue :: E.Expr -> Bool 80 | isValue E.Integer{} = True 81 | isValue E.Tuple{} = True 82 | isValue E.Lambda{} = True 83 | isValue E.Apply{} = False 84 | isValue E.ParamBound{} = False 85 | isValue E.LetBound{} = False 86 | isValue E.GlobalBound{} = False 87 | isValue E.BinaryOp{} = False 88 | isValue E.SingleOp{} = False 89 | isValue E.LetIn{} = False 90 | isValue E.NthOf{} = False 91 | isValue E.If{} = False 92 | isValue E.Error{} = False 93 | 94 | lazify :: E.Expr -> Expr 95 | lazify (E.ParamBound i) = ParamBound i 96 | lazify (E.GlobalBound s i) = GlobalBound s i 97 | lazify (E.LetBound i) = LetBound i 98 | lazify x | isValue x = makeEvaledThunk $ lazyExpr x 99 | | otherwise = makeThunk x 100 | 101 | lazyExpr :: E.Expr -> Expr 102 | lazyExpr (E.Apply a b) = Apply (lazyExpr a) (lazify b) 103 | lazyExpr (E.ParamBound i) = evalThunk (ParamBound i) 104 | lazyExpr (E.LetBound i) = evalThunk (LetBound i) 105 | lazyExpr (E.GlobalBound s i) = evalThunk (GlobalBound s i) 106 | lazyExpr (E.Integer i) = Integer i 107 | lazyExpr (E.BinaryOp op a b) = BinaryOp op (lazyExpr a) (lazyExpr b) 108 | lazyExpr (E.SingleOp op x) = SingleOp op (lazyExpr x) 109 | lazyExpr (E.Tuple xs) = Tuple $ map lazify xs 110 | lazyExpr (E.Lambda body) = Lambda $ lazyExpr body 111 | lazyExpr (E.LetIn _ defs body) = LetIn (map lazify defs) $ lazyExpr body 112 | lazyExpr (E.If c t e) = If (lazyExpr c) (lazyExpr t) (lazyExpr e) 113 | lazyExpr (E.NthOf _ i e) = evalThunk $ NthOf i $ lazyExpr e 114 | lazyExpr (E.Error err) = Error err 115 | 116 | lazyDef :: E.NameDef -> Def 117 | lazyDef (E.Name name body) = Name name $ lazify body 118 | 119 | lazy :: E.Code -> Code 120 | lazy (E.Code code) = Code defs entry 121 | where 122 | defs = map lazyDef code 123 | entry = evalThunk (GlobalBound "main" 0) 124 | -------------------------------------------------------------------------------- /src/Nameless.hs: -------------------------------------------------------------------------------- 1 | module Nameless where 2 | 3 | import Control.Monad.Extra (mapMaybeM) 4 | import Control.Monad.Reader 5 | import Control.Monad.State 6 | import Data.Foldable (foldrM) 7 | import Data.List (elemIndex) 8 | import qualified Data.Map as Map 9 | 10 | import qualified Errors as Err 11 | import qualified Match as M 12 | import qualified Operators as Op 13 | import Parse (TypeExpr, TypeScheme) 14 | import Utils 15 | 16 | data LetIndex = 17 | LetIndex { lambdaIndex :: Int 18 | , letIndex :: Int 19 | , innerIndex :: Int } 20 | deriving (Show, Eq) 21 | 22 | mapLambdaIndex :: (Int -> Int) -> LetIndex -> LetIndex 23 | mapLambdaIndex f (LetIndex lamI letI innI) = LetIndex (f lamI) letI innI 24 | 25 | data Expr 26 | = Integer Int 27 | | Lambda Expr 28 | | CtorApp String Expr 29 | | Apply Expr Expr 30 | | ParamBound Int 31 | | LetBound LetIndex 32 | | GlobalBound String Int 33 | | BinaryOp Op.BinaryOp Expr Expr 34 | | SingleOp Op.SingleOp Expr 35 | | Tuple [Expr] 36 | | LetIn [Maybe TypeScheme] [Expr] Expr 37 | | If Expr Expr Expr 38 | | NthOf Int Int Expr 39 | | IsCtor String Expr 40 | | DataOf String Expr 41 | | Error Err.Error 42 | deriving (Show, Eq) 43 | 44 | data NameDef 45 | = Name String Expr deriving (Show, Eq) 46 | 47 | data TypeDef 48 | = Variant String [String] [(String, TypeExpr)] 49 | deriving (Show, Eq) 50 | 51 | data Code = 52 | Code { annotations :: Map.Map String TypeScheme 53 | , typeDefs :: [TypeDef] 54 | , nameDefs :: [NameDef] } 55 | deriving (Show, Eq) 56 | 57 | -- types for the conversion 58 | data Binding 59 | = Global String 60 | | Param String 61 | | Let [String] 62 | 63 | type Env = [Binding] 64 | initEnv :: Env 65 | initEnv = [] 66 | withBinding :: Binding -> Reader Env m -> Reader Env m 67 | withBinding new = local (new:) 68 | 69 | data FindState = 70 | FindState { stLambdaIndex :: Int 71 | , stLetIndex :: Int } 72 | initState :: FindState 73 | initState = FindState 0 0 74 | withNewLambda :: Finder a -> Finder a 75 | withNewLambda = local update 76 | where 77 | -- reset localI in new lambda 78 | update (FindState lamI letI) = FindState (succ lamI) letI 79 | withNewLet :: Finder a -> Finder a 80 | withNewLet = local update 81 | where 82 | update (FindState lamI letI) = FindState lamI (succ letI) 83 | 84 | type Finder = Reader FindState 85 | findInEnv :: Env -> String -> Finder Expr 86 | findInEnv (Param x:xs) s | x == s = asks $ ParamBound . stLambdaIndex 87 | | otherwise = withNewLambda $ findInEnv xs s 88 | findInEnv (Global x:xs) s | x == s = asks $ GlobalBound s . stLambdaIndex 89 | | otherwise = findInEnv xs s 90 | findInEnv (Let bs:xs) s = 91 | case s `elemIndex` bs of 92 | Just i -> do 93 | st <- ask 94 | return $ LetBound $ LetIndex (stLambdaIndex st) (stLetIndex st) i 95 | Nothing -> withNewLet $ findInEnv xs s 96 | findInEnv [] s = error $ "Unbound variable " ++ s 97 | 98 | type Nameless = Reader Env 99 | findName :: String -> Nameless Expr 100 | findName s = do 101 | env <- ask 102 | return $ runReader (findInEnv env s) initState 103 | 104 | type TypeSig = Map.Map String TypeScheme 105 | type Destructed = ([String], [M.Expr]) 106 | destructDefs :: [M.NameDef] -> (Destructed, TypeSig) 107 | destructDefs defs = runState (foldrM f ([], []) defs) Map.empty 108 | where 109 | f :: M.NameDef -> Destructed -> State TypeSig Destructed 110 | f (M.NameDef name body) (names, bodies) = return (name : names, body : bodies) 111 | f (M.TypeAnnot name scheme) acc = modify (Map.insert name scheme) >> return acc 112 | 113 | namelessExpr :: M.Expr -> Nameless Expr 114 | namelessExpr (M.Apply fn arg) = Apply <$> namelessExpr fn <*> namelessExpr arg 115 | namelessExpr (M.Lambda p body) = Lambda <$> withBinding (Param p) (namelessExpr body) 116 | namelessExpr (M.CtorApp name e) = CtorApp name <$> namelessExpr e 117 | namelessExpr (M.LetIn defs body) = withBinding (Let names) $ LetIn schemes <$> bodies' <*> namelessExpr body 118 | where 119 | ((names, bodies), sig) = destructDefs defs 120 | bodies' = mapM namelessExpr bodies 121 | schemes = map (`Map.lookup` sig) names 122 | namelessExpr (M.Variable name) = findName name 123 | namelessExpr (M.Integer i) = return $ Integer i 124 | namelessExpr (M.BinaryOp op a b) = BinaryOp op <$> namelessExpr a <*> namelessExpr b 125 | namelessExpr (M.SingleOp op x) = SingleOp op <$> namelessExpr x 126 | namelessExpr (M.Tuple xs) = Tuple <$> mapM namelessExpr xs 127 | namelessExpr (M.If c t e) = If <$> namelessExpr c <*> namelessExpr t <*> namelessExpr e 128 | namelessExpr (M.NthOf n i e) = NthOf n i <$> namelessExpr e 129 | namelessExpr (M.IsCtor n e) = IsCtor n <$> namelessExpr e 130 | namelessExpr (M.DataOf n e) = DataOf n <$> namelessExpr e 131 | namelessExpr (M.Error err) = return $ Error err 132 | 133 | namelessNameDef :: M.Def -> Nameless (Maybe NameDef) 134 | namelessNameDef (M.Name (M.NameDef name expr)) = Just . Name name <$> namelessExpr expr 135 | namelessNameDef _ = return Nothing 136 | 137 | namelessDefs :: [M.Def] -> Nameless Code 138 | namelessDefs defs = Code annots tDefs <$> foldr collectNames body defs 139 | where 140 | body = mapMaybeM namelessNameDef defs 141 | annots = foldr collectAnnots Map.empty defs 142 | tDefs = foldr collectTypeDefs [] defs 143 | collectNames (M.Name (M.NameDef name _)) acc = withBinding (Global name) acc 144 | collectNames _ acc = acc 145 | collectAnnots (M.Name (M.TypeAnnot name scheme)) = Map.insert name scheme 146 | collectAnnots _ = id 147 | collectTypeDefs (M.Type name vars (M.Variant xs)) = (Variant name vars xs:) 148 | collectTypeDefs _ = id 149 | 150 | namelessCode :: M.Code -> Nameless Code 151 | namelessCode = namelessDefs 152 | 153 | nameless :: M.Code -> Code 154 | nameless c = runReader (namelessCode c) initEnv 155 | -------------------------------------------------------------------------------- /src/Flatten.hs: -------------------------------------------------------------------------------- 1 | module Flatten where 2 | 3 | import Control.Exception (assert) 4 | import Control.Monad.Reader 5 | 6 | import qualified Errors as Err 7 | import qualified Lazy as L 8 | import qualified Nameless as N 9 | import qualified Operators as Op 10 | import Utils 11 | 12 | data LetIndex = 13 | LetIndex { lambdaIndex :: Int 14 | , letIndex :: Int } 15 | deriving (Show, Eq) 16 | 17 | data Expr 18 | = Integer Int 19 | | Lambda Expr 20 | | Apply Expr Expr 21 | | ParamBound Int 22 | | LetBound LetIndex 23 | | GlobalBound String Int 24 | | BinaryOp Op.BinaryOp Expr Expr 25 | | SingleOp Op.SingleOp Expr 26 | | Tuple [Expr] 27 | | NthOf Int Expr 28 | | Alloc 29 | | Ref Expr 30 | | Assign Expr Expr 31 | | Seq Expr Expr 32 | | Deref Expr 33 | | If Expr Expr Expr 34 | | LocalLet Expr Expr 35 | | LocalBound 36 | | LetIn Expr Expr 37 | | Error Err.Error 38 | deriving (Show, Eq) 39 | 40 | data Def = Name String Expr deriving (Show, Eq) 41 | 42 | data Code = 43 | Code { definitions :: [Def] 44 | , entrypoint :: Expr } 45 | deriving (Show, Eq) 46 | 47 | data ReplaceState = 48 | ReplaceState { stLambdaIndex :: Int 49 | , stLetIndex :: Int 50 | , stDefCount :: Int } 51 | initState :: ReplaceState 52 | initState = ReplaceState 0 0 0 53 | 54 | type Replace = Reader ReplaceState 55 | 56 | withNewLambda :: Replace a -> Replace a 57 | withNewLambda = local update 58 | where 59 | update (ReplaceState lamI letI defC) = ReplaceState (succ lamI) letI defC 60 | 61 | withNewLet :: Int -> Replace a -> Replace a 62 | withNewLet n = local update 63 | where 64 | update (ReplaceState lamI letI defC) = ReplaceState lamI (succ letI) (defC + n) 65 | 66 | replace :: L.Expr -> Replace L.Expr 67 | replace (L.Integer i) = return $ L.Integer i 68 | replace (L.Lambda body) = withNewLambda $ L.Lambda <$> replace body 69 | replace (L.LetIn defs body) = withNewLet (length defs) $ L.LetIn <$> mapM replace defs <*> replace body 70 | replace (L.Apply a b) = L.Apply <$> replace a <*> replace b 71 | replace (L.ParamBound i) = return $ L.ParamBound i 72 | replace (L.GlobalBound name i) = return $ L.GlobalBound name i 73 | replace (L.BinaryOp op a b) = L.BinaryOp op <$> replace a <*> replace b 74 | replace (L.SingleOp op x) = L.SingleOp op <$> replace x 75 | replace (L.Tuple xs) = L.Tuple <$> mapM replace xs 76 | replace (L.NthOf n x) = L.NthOf n <$> replace x 77 | replace (L.Ref x) = L.Ref <$> replace x 78 | replace (L.Assign a b) = L.Assign <$> replace a <*> replace b 79 | replace (L.Deref x) = L.Deref <$> replace x 80 | replace (L.If c t e) = L.If <$> replace c <*> replace t <*> replace e 81 | replace (L.LocalLet a b) = L.LocalLet <$> replace a <*> replace b 82 | replace L.LocalBound = return L.LocalBound 83 | replace (L.Error err) = return $ L.Error err 84 | replace (L.LetBound i) = asks (conv i) 85 | where 86 | conv idx@(N.LetIndex lam let_ inn) (ReplaceState lamI letI defc) 87 | | lamI == lam && letI == let_ = L.Deref $ L.LetBound $ N.LetIndex lamI (inn + defc) 0 88 | | otherwise = L.LetBound idx 89 | 90 | runReplace :: L.Expr -> L.Expr 91 | runReplace x = runReader (replace x) initState 92 | 93 | flattenExpr :: L.Expr -> Expr 94 | flattenExpr (L.Integer i) = Integer i 95 | flattenExpr (L.Lambda body) = Lambda $ flattenExpr body 96 | flattenExpr (L.Apply a b) = Apply (flattenExpr a) (flattenExpr b) 97 | flattenExpr (L.ParamBound i) = ParamBound i 98 | flattenExpr (L.LetBound (N.LetIndex lam let_ inn)) = assert (inn == 0) $ LetBound $ LetIndex lam let_ 99 | flattenExpr (L.GlobalBound name i) = GlobalBound name i 100 | flattenExpr (L.BinaryOp op a b) = BinaryOp op (flattenExpr a) (flattenExpr b) 101 | flattenExpr (L.SingleOp op x) = SingleOp op $ flattenExpr x 102 | flattenExpr (L.Tuple xs) = Tuple $ map flattenExpr xs 103 | flattenExpr (L.NthOf n x) = NthOf n $ flattenExpr x 104 | flattenExpr (L.Ref x) = Ref $ flattenExpr x 105 | flattenExpr (L.Assign a b) = Assign (flattenExpr a) (flattenExpr b) 106 | flattenExpr (L.Deref x) = Deref $ flattenExpr x 107 | flattenExpr (L.If c t e) = If (flattenExpr c) (flattenExpr t) (flattenExpr e) 108 | flattenExpr (L.LocalLet a b) = LocalLet (flattenExpr a) (flattenExpr b) 109 | flattenExpr L.LocalBound = LocalBound 110 | flattenExpr (L.Error err) = Error err 111 | flattenExpr (L.LetIn defs body) = foldrN alloc assignments (length defs) 112 | where 113 | body' = flattenExpr $ runReplace body 114 | assignments = foldr Seq body' $ imap makeAssign defs 115 | makeAssign n x = Assign (nthAlloc n) (flattenExpr (runReplace x)) 116 | nthAlloc = LetBound . LetIndex 0 117 | alloc = LetIn Alloc 118 | 119 | replaceGlobal :: L.Expr -> L.Expr 120 | replaceGlobal (L.Integer i) = L.Integer i 121 | replaceGlobal (L.Lambda body) = L.Lambda $ replaceGlobal body 122 | replaceGlobal (L.Apply a b) = L.Apply (replaceGlobal a) (replaceGlobal b) 123 | replaceGlobal (L.ParamBound i) = L.ParamBound i 124 | replaceGlobal (L.LetBound i) = L.LetBound i 125 | replaceGlobal (L.GlobalBound name i) = L.Deref $ L.GlobalBound name i 126 | replaceGlobal (L.BinaryOp op a b) = L.BinaryOp op (replaceGlobal a) (replaceGlobal b) 127 | replaceGlobal (L.SingleOp op x) = L.SingleOp op $ replaceGlobal x 128 | replaceGlobal (L.Tuple xs) = L.Tuple $ map replaceGlobal xs 129 | replaceGlobal (L.NthOf n x) = L.NthOf n $ replaceGlobal x 130 | replaceGlobal (L.Ref x) = L.Ref $ replaceGlobal x 131 | replaceGlobal (L.Assign a b) = L.Assign (replaceGlobal a) (replaceGlobal b) 132 | replaceGlobal (L.Deref x) = L.Deref $ replaceGlobal x 133 | replaceGlobal (L.If c t e) = L.If (replaceGlobal c) (replaceGlobal t) (replaceGlobal e) 134 | replaceGlobal (L.LocalLet a b) = L.LocalLet (replaceGlobal a) (replaceGlobal b) 135 | replaceGlobal L.LocalBound = L.LocalBound 136 | replaceGlobal (L.Error err) = L.Error err 137 | replaceGlobal (L.LetIn defs body) = L.LetIn (map replaceGlobal defs) (replaceGlobal body) 138 | 139 | flatten :: L.Code -> Code 140 | flatten (L.Code defs entry) = Code defs' entry' 141 | where 142 | fillAlloc (L.Name name _) = Name name Alloc 143 | folder (L.Name k v) = Seq (Assign (GlobalBound k 0) (flattenExpr (replaceGlobal v))) 144 | defs' = map fillAlloc defs 145 | entry' = foldr folder (flattenExpr (replaceGlobal entry)) defs 146 | -------------------------------------------------------------------------------- /test/ParseSpec.hs: -------------------------------------------------------------------------------- 1 | module ParseSpec (spec) where 2 | 3 | import Operators 4 | import Parse 5 | import Test.Hspec 6 | 7 | -- helpers 8 | parse :: String -> Expr 9 | parse s = case parseCode "" code of 10 | Left (ParseError err) -> error err 11 | Right t -> destruct t 12 | where 13 | code = "name main = " ++ s 14 | destruct [Name (NameDef _ [] body [])] = body 15 | 16 | parseTy :: String -> TypeScheme 17 | parseTy s = case parseCode "" code of 18 | Left (ParseError err) -> error err 19 | Right t -> destruct t 20 | where 21 | code = "name main :: " ++ s 22 | destruct [Name (TypeAnnot _ body)] = body 23 | 24 | add :: Expr -> Expr -> Expr 25 | add = BinaryOp Add 26 | 27 | mul :: Expr -> Expr -> Expr 28 | mul = BinaryOp Mul 29 | 30 | pos :: Expr -> Expr 31 | pos = SingleOp Positive 32 | 33 | neg :: Expr -> Expr 34 | neg = SingleOp Negative 35 | 36 | int :: Int -> Expr 37 | int = Integer 38 | 39 | var :: String -> Expr 40 | var = Variable 41 | 42 | -- tests 43 | spec :: Spec 44 | spec = do 45 | describe "skip" $ do 46 | it "skip spaces" $ do 47 | parse "24 " `shouldBe` int 24 48 | parse " 2 + 5 " `shouldBe` int 2 `add` int 5 49 | parse "- 4" `shouldBe` neg (int 4) 50 | parse " ( 24 + 12 )" `shouldBe` int 24 `add` int 12 51 | parse "\\a b c => 1+a*3 " `shouldBe` Lambda ["a", "b", "c"] (int 1 `add` (var "a" `mul` int 3)) 52 | parse "( 1 ,2 ,3 ) " `shouldBe` Tuple [int 1, int 2, int 3] 53 | 54 | it "skip comments" $ do 55 | parse "24 /* comment */ + 23" `shouldBe` int 24 `add` int 23 56 | parse "1+ /* comment */ (/*comment*/2+3)" `shouldBe` int 1 `add` (int 2 `add` int 3) 57 | parse "\\abc=>\n//comment\n\\x//comment2\n=>/*comment*/x*abc" `shouldBe` Lambda ["abc"] (Lambda ["x"] (var "x" `mul` var "abc")) 58 | 59 | describe "expression" $ do 60 | it "parse integers" $ do 61 | parse "1" `shouldBe` int 1 62 | parse "24" `shouldBe` int 24 63 | parse "312" `shouldBe` int 312 64 | 65 | it "parse variables" $ do 66 | parse "a" `shouldBe` var "a" 67 | parse "abc" `shouldBe` var "abc" 68 | parse "x1" `shouldBe` var "x1" 69 | 70 | it "parse binary operators" $ do 71 | parse "2+5" `shouldBe` int 2 `add` int 5 72 | parse "12*35" `shouldBe` int 12 `mul` int 35 73 | 74 | it "binop precedence" $ do 75 | parse "2+5*10" `shouldBe` int 2 `add` (int 5 `mul` int 10) 76 | parse "1*2+3" `shouldBe` (int 1 `mul` int 2) `add` int 3 77 | parse "2+5*10+3" `shouldBe` (int 2 `add` (int 5 `mul` int 10)) `add` int 3 78 | 79 | it "binop associativity" $ do 80 | parse "1+2+3+4+5" `shouldBe` (((int 1 `add` int 2) `add` int 3) `add` int 4) `add` int 5 81 | parse "1*2*3*4*5" `shouldBe` (((int 1 `mul` int 2) `mul` int 3) `mul` int 4) `mul` int 5 82 | 83 | it "parse single operators" $ do 84 | parse "+5" `shouldBe` pos (int 5) 85 | parse "-4" `shouldBe` neg (int 4) 86 | parse "-x" `shouldBe` neg (var "x") 87 | 88 | it "parse parentheses" $ do 89 | parse "1+(2+3)" `shouldBe` int 1 `add` (int 2 `add` int 3) 90 | parse "3*(4+5)" `shouldBe` int 3 `mul` (int 4 `add` int 5) 91 | parse "(12)" `shouldBe` int 12 92 | parse "(24+12)" `shouldBe` int 24 `add` int 12 93 | parse "3*((4+5)*6)" `shouldBe` int 3 `mul` ((int 4 `add` int 5) `mul` int 6) 94 | 95 | it "parse lambdas" $ do 96 | parse "\\x=>x" `shouldBe` Lambda ["x"] (var "x") 97 | parse "\\a b c=>1+a*3" `shouldBe` Lambda ["a", "b", "c"] (int 1 `add` (var "a" `mul` int 3)) 98 | parse "\\abc=>\\x=>x*abc" `shouldBe` Lambda ["abc"] (Lambda ["x"] (var "x" `mul` var "abc")) 99 | 100 | it "parse tuples" $ do 101 | parse "(1,2,3)" `shouldBe` Tuple [int 1, int 2, int 3] 102 | parse "(1+2,3+4)" `shouldBe` Tuple [int 1 `add` int 2, int 3 `add` int 4] 103 | parse "(0,)" `shouldBe` Tuple [int 0] 104 | parse "()" `shouldBe` Tuple [] 105 | 106 | it "parse let-in" $ do 107 | parse "let a = 1 in a" `shouldBe` LetIn [NameDef "a" [] (int 1) []] (var "a") 108 | parse "let\n - a = 1\n - b = 2 in a" `shouldBe` LetIn [NameDef "a" [] (int 1) [], NameDef "b" [] (int 2) []] (var "a") 109 | 110 | it "parse nested let-in" $ do 111 | parse "let a = 1 in let b = 1 in a + b" `shouldBe` LetIn [NameDef "a" [] (int 1) []] (LetIn [NameDef "b" [] (int 1) []] (var "a" `add` var "b")) 112 | 113 | it "parse let-in with where clause" $ do 114 | parse "let a = b where b = 1 in a" `shouldBe` LetIn [NameDef "a" [] (var "b") [NameDef "b" [] (int 1) []]] (var "a") 115 | 116 | it "parse if-then-else" $ do 117 | parse "if 1 then a + 1 else b + 1" `shouldBe` If (int 1) (var "a" `add` int 1) (var "b" `add` int 1) 118 | parse "if 1 then if 0 then 1 else 2 else if 1 then 1 else 2" `shouldBe` If (int 1) (If (int 0) (int 1) (int 2)) (If (int 1) (int 1) (int 2)) 119 | 120 | describe "type" $ do 121 | it "parse type identifiers" $ do 122 | parseTy "Int" `shouldBe` Forall [] (Ident "Int") 123 | parseTy "if" `shouldBe` Forall [] (Ident "if") 124 | 125 | it "parse function types" $ do 126 | parseTy "a -> b" `shouldBe` Forall [] (Function (Ident "a") (Ident "b")) 127 | parseTy "a -> a -> a" `shouldBe` Forall [] (Function (Ident "a") (Function (Ident "a") (Ident "a"))) 128 | 129 | it "parse product types" $ do 130 | parseTy "(a, b)" `shouldBe` Forall [] (Product [Ident "a", Ident "b"]) 131 | parseTy "(a,)" `shouldBe` Forall [] (Product [Ident "a"]) 132 | parseTy "()" `shouldBe` Forall [] (Product []) 133 | 134 | it "parse parentheses" $ do 135 | parseTy "(a -> b) -> c" `shouldBe` Forall [] (Function (Function (Ident "a") (Ident "b")) (Ident "c")) 136 | parseTy "(a)" `shouldBe` Forall [] (Ident "a") 137 | 138 | it "parse quantifiers" $ do 139 | parseTy "forall a. a -> a" `shouldBe` Forall ["a"] (Function (Ident "a") (Ident "a")) 140 | parseTy "forall a b c. a" `shouldBe` Forall ["a", "b", "c"] (Ident "a") 141 | 142 | describe "definition" $ do 143 | it "parse simple name definitions" $ do 144 | parseCode "" "name def x y = x + y\nname main = 1" `shouldBe` Right [Name (NameDef "def" ["x", "y"] (add (var "x") (var "y")) []), Name (NameDef "main" [] (int 1) [])] 145 | 146 | it "parse name definitions with where" $ do 147 | parseCode "" "name def x = y where y = x" `shouldBe` Right [Name (NameDef "def" ["x"] (var "y") [NameDef "y" [] (var "x") []])] 148 | parseCode "" "name def x = y where\n - y = x\n - z = x" `shouldBe` Right [Name (NameDef "def" ["x"] (var "y") [NameDef "y" [] (var "x") [], NameDef "z" [] (var "x") []])] 149 | 150 | it "parse type annotation syntax" $ do 151 | parseCode "" "name a :: Int" `shouldBe` Right [Name $ TypeAnnot "a" $ Forall [] $ Ident "Int"] 152 | parseCode "" "name a = f where\n- f :: Int\n- f = 1" `shouldBe` Right [Name $ NameDef "a" [] (var "f") [TypeAnnot "f" (Forall [] $ Ident "Int"), NameDef "f" [] (int 1) []]] 153 | -------------------------------------------------------------------------------- /src/Codegen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecursiveDo #-} 4 | {-# LANGUAGE TupleSections #-} 5 | 6 | module Codegen where 7 | 8 | import Control.Monad 9 | import Control.Monad.Fix 10 | import Control.Monad.Reader 11 | import Control.Monad.State 12 | 13 | import qualified Data.Map as Map 14 | import Data.Maybe (fromJust) 15 | import Data.Text (Text) 16 | import Data.Text.Encoding (decodeUtf8) 17 | 18 | import qualified LLVM.AST as AST 19 | import qualified LLVM.AST.Constant as Const 20 | import qualified LLVM.AST.IntegerPredicate as P 21 | import qualified LLVM.AST.Type as Ty 22 | import qualified LLVM.IRBuilder.Instruction as IR 23 | import qualified LLVM.IRBuilder.Module as IR 24 | import qualified LLVM.IRBuilder.Monad as IR 25 | 26 | import qualified LLVM.Context as LLVM 27 | import qualified LLVM.Module as LLVM 28 | 29 | import qualified Errors as Err 30 | import Hoist 31 | import qualified Operators as Op 32 | import Utils 33 | 34 | -- TODO: every function takes two parameters, fix it with typing 35 | 36 | genericPtr :: Ty.Type 37 | genericPtr = Ty.ptr Ty.i8 38 | 39 | functionType :: Ty.Type 40 | functionType = Ty.FunctionType genericPtr [genericPtr, genericPtr] False 41 | 42 | constInt :: Int -> AST.Operand 43 | constInt i = AST.ConstantOperand $ Const.Int 64 $ toInteger i 44 | 45 | namedFunction :: Ty.Type -> String -> AST.Operand 46 | namedFunction t = AST.ConstantOperand . Const.GlobalReference (Ty.ptr t) . AST.mkName 47 | 48 | callMalloc :: IR.MonadIRBuilder m => AST.Operand -> m AST.Operand 49 | callMalloc len = IR.call malloc [(len, [])] 50 | where 51 | malloc = namedFunction (Ty.FunctionType genericPtr [Ty.i64] False) "malloc" 52 | 53 | callMalloc' :: IR.MonadIRBuilder m => AST.Operand -> m AST.Operand 54 | callMalloc' len = do 55 | m <- callMalloc len 56 | IR.bitcast m $ Ty.ptr genericPtr 57 | 58 | data Env = 59 | Env { localBound :: Maybe AST.Operand 60 | , args :: [AST.Operand] 61 | , letBound :: [AST.Operand] } 62 | withLocalBound :: MonadReader Env m => AST.Operand -> m AST.Operand -> m AST.Operand 63 | withLocalBound newBound = local update 64 | where 65 | update x = x { localBound = Just newBound } 66 | getLocalBound :: MonadReader Env m => m AST.Operand 67 | getLocalBound = asks $ fromJust . localBound 68 | 69 | withLetBound :: MonadReader Env m => AST.Operand -> m AST.Operand -> m AST.Operand 70 | withLetBound bs = local update 71 | where 72 | update x = x { letBound = bs : letBound x } 73 | getLetBound :: MonadReader Env m => Int -> m AST.Operand 74 | getLetBound idx = asks $ (!! idx) . letBound 75 | 76 | initEnv :: Env 77 | initEnv = Env Nothing [] [] 78 | initArg :: [AST.Operand] -> Env 79 | initArg xs = initEnv { args = xs } 80 | 81 | type NameMap = Map.Map String AST.Operand 82 | 83 | initNameMap :: NameMap 84 | initNameMap = Map.empty 85 | 86 | genExpr :: (IR.MonadIRBuilder m, IR.MonadModuleBuilder m, MonadFix m, MonadReader Env m, MonadState NameMap m) => Expr -> m AST.Operand 87 | genExpr (Integer i) = IR.inttoptr (constInt i) genericPtr 88 | genExpr (Parameter i) = asks $ (!! i) . args 89 | genExpr (NameRef name) = gets (Map.! name) 90 | genExpr (FunctionRef i) = IR.bitcast (namedFunction functionType $ nameFunction i) genericPtr 91 | genExpr (LetRef i) = getLetBound i 92 | genExpr (Call f a) = do 93 | f' <- genExpr f 94 | f' <- IR.bitcast f' $ Ty.ptr functionType 95 | a' <- mapM genExpr a 96 | IR.call f' $ map (,[]) $ pad a' 97 | where 98 | pad xs = take 2 $ xs ++ repeat (AST.ConstantOperand $ Const.Null genericPtr) 99 | genExpr (Tuple xs) = do 100 | xs' <- mapM genExpr xs 101 | m <- callMalloc' $ constInt $ length xs * 8 102 | forM_ (zip [0..] xs') $ \(i, x) -> do 103 | e <- IR.gep m [constInt i] 104 | IR.store e 0 x 105 | IR.bitcast m genericPtr 106 | genExpr (NthOf i e) = do 107 | e' <- genExpr e 108 | e' <- IR.bitcast e' $ Ty.ptr genericPtr 109 | ptr <- IR.gep e' [constInt i] 110 | IR.load ptr 0 111 | genExpr (LocalLet e x) = do 112 | e' <- genExpr e 113 | withLocalBound e' $ genExpr x 114 | genExpr LocalBound = getLocalBound 115 | genExpr (LetIn def body) = do 116 | def' <- genExpr def 117 | withLetBound def' $ genExpr body 118 | genExpr (BinaryOp op l r) = join $ apply_op <$> genExpr l <*> genExpr r 119 | where 120 | apply_op a b = do 121 | a' <- IR.ptrtoint a Ty.i64 122 | b' <- IR.ptrtoint b Ty.i64 123 | x <- opr a' b' 124 | IR.inttoptr x genericPtr 125 | opr = 126 | case op of 127 | Op.Add -> IR.add 128 | Op.Mul -> IR.mul 129 | Op.Sub -> IR.sub 130 | Op.Eq -> \a b -> do 131 | x <- IR.icmp P.EQ a b 132 | IR.zext x Ty.i64 133 | 134 | genExpr (SingleOp op e) = apply_op =<< genExpr e 135 | where 136 | apply_op v = do 137 | v' <- IR.ptrtoint v Ty.i64 138 | x <- opr v' 139 | IR.inttoptr x genericPtr 140 | opr = 141 | case op of 142 | Op.Negative -> IR.sub $ constInt 0 143 | Op.Positive -> return 144 | 145 | genExpr Alloc = callMalloc $ constInt 8 146 | genExpr (Ref e) = do 147 | e' <- genExpr e 148 | m <- callMalloc' $ constInt 8 149 | IR.store m 0 e' 150 | IR.bitcast m genericPtr 151 | 152 | genExpr (Seq l r) = genExpr l >> genExpr r 153 | 154 | genExpr (Assign l r) = do 155 | l' <- genExpr l 156 | r' <- genExpr r 157 | dest <- IR.bitcast l' $ Ty.ptr genericPtr 158 | IR.store dest 0 r' 159 | return r' 160 | 161 | genExpr (Deref e) = do 162 | e' <- genExpr e 163 | ptr <- IR.bitcast e' $ Ty.ptr genericPtr 164 | IR.load ptr 0 165 | 166 | genExpr (If c t e) = mdo 167 | c' <- flip IR.ptrtoint Ty.i64 =<< genExpr c 168 | res <- IR.alloca genericPtr Nothing 4 169 | cond <- IR.icmp P.EQ c' $ constInt 0 170 | IR.condBr cond ifElse ifThen 171 | ifThen <- IR.block 172 | t' <- genExpr t 173 | IR.store res 0 t' 174 | IR.br ifExit 175 | ifElse <- IR.block 176 | e' <- genExpr e 177 | IR.store res 0 e' 178 | IR.br ifExit 179 | ifExit <- IR.block 180 | IR.load res 0 181 | 182 | genExpr (Error err) = do 183 | let puts = namedFunction (Ty.FunctionType Ty.i32 [Ty.ptr Ty.i8] False) "puts" 184 | msg <- IR.globalStringPtr (Err.message err) "err" 185 | _ <- IR.call puts [(msg, [])] 186 | let exit = namedFunction (Ty.FunctionType Ty.void [Ty.i32] False) "exit" 187 | _ <- IR.call exit [(AST.ConstantOperand $ Const.Int 32 1, [])] 188 | IR.inttoptr (constInt 0) genericPtr 189 | 190 | genFunction :: (IR.MonadModuleBuilder m, MonadFix m) => String -> Function -> m AST.Operand 191 | genFunction name (Function n expr) = 192 | IR.function (AST.mkName name) params genericPtr $ \argList -> 193 | -- prevent the use of NameRef by passing empty NameMap as a initial state 194 | IR.ret =<< evalStateT (runReaderT (genExpr expr) (initArg argList)) initNameMap 195 | where 196 | params = replicate n (genericPtr, IR.NoParameterName) 197 | 198 | genTopExpr :: (IR.MonadIRBuilder m, IR.MonadModuleBuilder m, MonadFix m, MonadState NameMap m) => Expr -> m AST.Operand 199 | genTopExpr e = runReaderT (genExpr e) initEnv 200 | 201 | genDef :: (IR.MonadIRBuilder m, IR.MonadModuleBuilder m, MonadFix m, MonadState NameMap m) => Def -> m () 202 | genDef (Name name body) = do 203 | e <- genTopExpr body 204 | modify $ Map.insert name e 205 | 206 | genCode :: (IR.MonadIRBuilder m, IR.MonadModuleBuilder m, MonadFix m) => Code -> m AST.Operand 207 | genCode (Code defs entry) = evalStateT gen initNameMap 208 | where 209 | gen = mapM_ genDef defs >> genTopExpr entry 210 | 211 | nameFunction :: Int -> String 212 | nameFunction i = "__faber_fn_" ++ show i 213 | 214 | codegen :: Module -> AST.Module 215 | codegen m = IR.buildModule "faber-output" $ do 216 | _ <- IR.extern "malloc" [Ty.i64] genericPtr 217 | _ <- IR.extern "puts" [Ty.ptr Ty.i8] Ty.i32 218 | _ <- IR.extern "exit" [Ty.i32] Ty.void 219 | zipWithM_ (genFunction . nameFunction) [0..] (functions m) 220 | IR.function "main" [(Ty.i32, "argc"), (Ty.ptr (Ty.ptr Ty.i8), "argv")] Ty.i32 $ \[_, _] -> do 221 | ret <- genCode $ code m 222 | int <- IR.ptrtoint ret Ty.i64 223 | printf <- IR.externVarArgs "printf" [Ty.ptr Ty.i8] Ty.i32 224 | fmt <- IR.globalStringPtr "%ld\n" "fmt" 225 | _ <- IR.call printf [(fmt, []), (int, [])] 226 | IR.ret $ AST.ConstantOperand $ Const.Int 32 0 227 | 228 | toLLVM :: AST.Module -> IO Text 229 | toLLVM m = LLVM.withContext $ \ctx -> 230 | decodeUtf8 <$> LLVM.withModuleFromAST ctx m LLVM.moduleLLVMAssembly 231 | -------------------------------------------------------------------------------- /src/Parse.hs: -------------------------------------------------------------------------------- 1 | module Parse where 2 | 3 | import Control.Arrow 4 | import Control.Monad.Combinators.Expr 5 | import Data.Functor (void) 6 | import Data.Maybe (fromMaybe) 7 | import Data.Void 8 | import Text.Megaparsec hiding (ParseError) 9 | import qualified Text.Megaparsec.Char as C 10 | import qualified Text.Megaparsec.Char.Lexer as L 11 | import Text.Megaparsec.Error (errorBundlePretty) 12 | 13 | import qualified Operators as Op 14 | 15 | -- syntax tree 16 | type Ident = String 17 | 18 | data Pattern 19 | = PVar Ident 20 | | PWildcard 21 | | PInt Int 22 | | PCtor String [Pattern] 23 | | PTuple [Pattern] 24 | deriving (Show, Eq) 25 | 26 | data Expr 27 | = Integer Int 28 | | Lambda [Ident] Expr 29 | | Apply Expr Expr 30 | | Variable Ident 31 | | Tuple [Expr] 32 | | BinaryOp Op.BinaryOp Expr Expr 33 | | SingleOp Op.SingleOp Expr 34 | | LetIn [NameDef] Expr 35 | | If Expr Expr Expr 36 | | Match Expr [(Pattern, Expr)] 37 | deriving (Show, Eq) 38 | 39 | data TypeExpr 40 | = Ident String 41 | | Function TypeExpr TypeExpr 42 | | Product [TypeExpr] 43 | | ApplyTy TypeExpr TypeExpr 44 | deriving (Show, Eq) 45 | 46 | data TypeScheme 47 | = Forall [String] TypeExpr 48 | deriving (Show, Eq) 49 | 50 | data NameDef 51 | = NameDef String [Ident] Expr [NameDef] 52 | | TypeAnnot String TypeScheme 53 | deriving (Show, Eq) 54 | 55 | newtype TypeDef 56 | = Variant [(String, [TypeExpr])] 57 | deriving (Show, Eq) 58 | 59 | data Def 60 | = Name NameDef 61 | | Type String [String] TypeDef 62 | deriving (Show, Eq) 63 | 64 | type Code = [Def] 65 | 66 | -- parser type definition 67 | type Parser = Parsec Void String 68 | 69 | -- lexer utils 70 | headRws :: [Parser ()] 71 | headRws = [char_ '-', string_ "name", string_ "type"] 72 | where 73 | char_ = void . C.char 74 | string_ = void . C.string 75 | 76 | space :: Parser () 77 | space = L.space skip line block 78 | where 79 | line = L.skipLineComment "//" 80 | block = L.skipBlockComment "/*" "*/" 81 | skip = notFollowedBy (lexeme_ C.newline >> choice headRws) >> (lexeme_ C.newline <|> sc) 82 | sc = void $ some (C.char ' ' <|> C.char '\t') 83 | 84 | lexeme :: Parser a -> Parser a 85 | lexeme = L.lexeme space 86 | 87 | lexeme_ :: Parser a -> Parser () 88 | lexeme_ = void . lexeme 89 | 90 | symbol :: String -> Parser () 91 | symbol = void . L.symbol space 92 | 93 | newline :: Parser () 94 | newline = lexeme_ C.newline 95 | 96 | integer :: Parser Int 97 | integer = lexeme L.decimal 98 | 99 | parens :: Parser a -> Parser a 100 | parens = between (symbol "(") (symbol ")") 101 | 102 | rword :: String -> Parser () 103 | rword w = (lexeme . try) (C.string w *> notFollowedBy C.alphaNumChar) 104 | 105 | -- the actual parser 106 | identifier' :: [String] -> Parser Ident 107 | identifier' rws = (lexeme . try) (p >>= check) 108 | where 109 | p = (:) <$> C.letterChar <*> many C.alphaNumChar 110 | check x | x `elem` rws = fail $ "attempt to parse " ++ show x ++ "as an identifier" 111 | | otherwise = return x 112 | 113 | -- pattern parser 114 | patIdentifier :: Parser Ident 115 | patIdentifier = identifier' [] 116 | 117 | patWildcard :: Parser Pattern 118 | patWildcard = symbol "_" >> return PWildcard 119 | 120 | patTuple :: Parser Pattern 121 | patTuple = PTuple <$> parens (pattern_ `sepEndBy` symbol ",") 122 | 123 | patCtor :: Parser Pattern 124 | patCtor = PCtor <$> (symbol "#" >> identifier) <*> many pattern_ 125 | 126 | pattern_ :: Parser Pattern 127 | pattern_ = try (parens pattern_) 128 | <|> patTuple 129 | <|> patWildcard 130 | <|> patCtor 131 | <|> PVar <$> patIdentifier 132 | <|> PInt <$> integer 133 | 134 | -- expression parser 135 | exprRws :: [String] 136 | exprRws = ["let", "in", "where", "if", "then", "else", "match", "with"] 137 | 138 | identifier :: Parser Ident 139 | identifier = identifier' exprRws 140 | 141 | tuple :: Parser Expr 142 | tuple = Tuple <$> parens (expr `sepEndBy` symbol ",") 143 | 144 | lambda :: Parser Expr 145 | lambda = do 146 | symbol "\\" 147 | param <- some identifier 148 | symbol "=>" 149 | Lambda param <$> expr 150 | 151 | letIn :: Parser Expr 152 | letIn = do 153 | rword "let" 154 | defs <- nameDefs 155 | rword "in" 156 | LetIn defs <$> expr 157 | 158 | ifThenElse :: Parser Expr 159 | ifThenElse = do 160 | rword "if" 161 | cond <- expr 162 | rword "then" 163 | then_ <- expr 164 | rword "else" 165 | If cond then_ <$> expr 166 | 167 | match_ :: Parser Expr 168 | match_ = do 169 | rword "match" 170 | target <- expr 171 | rword "with" 172 | _ <- optional $ symbol "|" 173 | Match target <$> arm `sepBy1` symbol "|" 174 | where 175 | arm = do 176 | pat <- pattern_ 177 | symbol "->" 178 | body <- expr 179 | return (pat, body) 180 | 181 | operators :: [[Operator Parser Expr]] 182 | operators = 183 | [ [ InfixL (Apply <$ symbol "") ], 184 | [ Prefix (SingleOp Op.Positive <$ symbol "+") 185 | , Prefix (SingleOp Op.Negative <$ symbol "-") ], 186 | [ InfixL (BinaryOp Op.Mul <$ symbol "*") ], 187 | [ InfixL (BinaryOp Op.Add <$ symbol "+") 188 | , InfixL (BinaryOp Op.Sub <$ symbol "-") ], 189 | [ InfixL (BinaryOp Op.Eq <$ symbol "==") ] ] 190 | 191 | term :: Parser Expr 192 | term = try (parens expr) 193 | <|> tuple 194 | <|> letIn 195 | <|> ifThenElse 196 | <|> match_ 197 | <|> lambda 198 | <|> Variable <$> identifier 199 | <|> Integer <$> integer 200 | 201 | expr :: Parser Expr 202 | expr = makeExprParser term operators 203 | 204 | -- type expression parser 205 | typeRws :: [String] 206 | typeRws = [] 207 | 208 | typeIdentifier :: Parser String 209 | typeIdentifier = identifier' typeRws 210 | 211 | typeOperators :: [[Operator Parser TypeExpr]] 212 | typeOperators = 213 | [ InfixL (ApplyTy <$ symbol "") ] : typeOperatorsNoApp 214 | 215 | typeOperatorsNoApp :: [[Operator Parser TypeExpr]] 216 | typeOperatorsNoApp = 217 | [ [ InfixR (Function <$ symbol "->") ] ] 218 | 219 | typeProd :: Parser TypeExpr 220 | typeProd = Product <$> parens (typeExpr `sepEndBy` symbol ",") 221 | 222 | typeTerm :: Parser TypeExpr 223 | typeTerm = try (parens typeExpr) 224 | <|> typeProd 225 | <|> Ident <$> typeIdentifier 226 | 227 | typeExpr :: Parser TypeExpr 228 | typeExpr = makeExprParser typeTerm typeOperators 229 | 230 | typeExprNoApp :: Parser TypeExpr 231 | typeExprNoApp = makeExprParser typeTerm typeOperatorsNoApp 232 | 233 | -- type scheme parser 234 | typeScheme :: Parser TypeScheme 235 | typeScheme = Forall <$> binder <*> typeExpr 236 | where 237 | binder = fromMaybe [] <$> optional forallBinder 238 | forallBinder = do 239 | symbol "forall" 240 | vars <- some typeIdentifier 241 | symbol "." 242 | return vars 243 | 244 | -- definition parser 245 | nameValueDef :: Parser NameDef 246 | nameValueDef = do 247 | name <- identifier 248 | params <- many identifier 249 | symbol "=" 250 | body <- expr 251 | defs <- fromMaybe [] <$> optional where_ 252 | return $ NameDef name params body defs 253 | where 254 | where_ = rword "where" >> nameDefs 255 | 256 | nameAnnotDef :: Parser NameDef 257 | nameAnnotDef = do 258 | name <- identifier 259 | symbol "::" 260 | TypeAnnot name <$> typeScheme 261 | 262 | nameDef :: Parser NameDef 263 | nameDef = try nameAnnotDef <|> nameValueDef 264 | 265 | nameDefs :: Parser [NameDef] 266 | nameDefs = many (optional hyphen >> nameDef) 267 | where 268 | hyphen = try (newline >> symbol "-") 269 | 270 | defName :: Parser Def 271 | defName = Name <$> (delim >> nameDef) 272 | where 273 | delim = try (optional newline >> symbol "name") 274 | 275 | defType :: Parser Def 276 | defType = delim >> body 277 | where 278 | delim = try (optional newline >> symbol "type") 279 | body = do 280 | name <- identifier 281 | vars <- many identifier 282 | symbol "=" 283 | _ <- optional $ symbol "|" 284 | Type name vars . Variant <$> variant `sepBy1` symbol "|" 285 | variant = do 286 | ctor <- identifier 287 | -- Cons a (List a) should be parsed as [a, ApplyTy List a], not [ApplyTy a (ApplyTy List a)] 288 | params <- many typeExprNoApp 289 | return (ctor, params) 290 | 291 | definition :: Parser Def 292 | definition = defName <|> defType 293 | 294 | definitions :: Parser [Def] 295 | definitions = some definition 296 | 297 | -- wrap them up 298 | code :: Parser Code 299 | code = definitions 300 | 301 | parser :: Parser Code 302 | parser = between space eof code 303 | 304 | newtype ParseError = ParseError String deriving (Show, Eq) 305 | 306 | parseCode :: String -> String -> Either ParseError Code 307 | parseCode name input = left pretty $ parse parser name input 308 | where 309 | pretty = ParseError . errorBundlePretty 310 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Align the right hand side of some elements. This is quite conservative 19 | # and only applies to statements where each element occupies a single 20 | # line. 21 | - simple_align: 22 | cases: true 23 | top_level_patterns: true 24 | records: true 25 | 26 | # Import cleanup 27 | - imports: 28 | # There are different ways we can align names and lists. 29 | # 30 | # - global: Align the import names and import list throughout the entire 31 | # file. 32 | # 33 | # - file: Like global, but don't add padding when there are no qualified 34 | # imports in the file. 35 | # 36 | # - group: Only align the imports per group (a group is formed by adjacent 37 | # import lines). 38 | # 39 | # - none: Do not perform any alignment. 40 | # 41 | # Default: global. 42 | align: group 43 | 44 | # The following options affect only import list alignment. 45 | # 46 | # List align has following options: 47 | # 48 | # - after_alias: Import list is aligned with end of import including 49 | # 'as' and 'hiding' keywords. 50 | # 51 | # > import qualified Data.List as List (concat, foldl, foldr, head, 52 | # > init, last, length) 53 | # 54 | # - with_alias: Import list is aligned with start of alias or hiding. 55 | # 56 | # > import qualified Data.List as List (concat, foldl, foldr, head, 57 | # > init, last, length) 58 | # 59 | # - new_line: Import list starts always on new line. 60 | # 61 | # > import qualified Data.List as List 62 | # > (concat, foldl, foldr, head, init, last, length) 63 | # 64 | # Default: after_alias 65 | list_align: after_alias 66 | 67 | # Right-pad the module names to align imports in a group: 68 | # 69 | # - true: a little more readable 70 | # 71 | # > import qualified Data.List as List (concat, foldl, foldr, 72 | # > init, last, length) 73 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 74 | # > init, last, length) 75 | # 76 | # - false: diff-safe 77 | # 78 | # > import qualified Data.List as List (concat, foldl, foldr, init, 79 | # > last, length) 80 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 81 | # > init, last, length) 82 | # 83 | # Default: true 84 | pad_module_names: true 85 | 86 | # Long list align style takes effect when import is too long. This is 87 | # determined by 'columns' setting. 88 | # 89 | # - inline: This option will put as much specs on same line as possible. 90 | # 91 | # - new_line: Import list will start on new line. 92 | # 93 | # - new_line_multiline: Import list will start on new line when it's 94 | # short enough to fit to single line. Otherwise it'll be multiline. 95 | # 96 | # - multiline: One line per import list entry. 97 | # Type with constructor list acts like single import. 98 | # 99 | # > import qualified Data.Map as M 100 | # > ( empty 101 | # > , singleton 102 | # > , ... 103 | # > , delete 104 | # > ) 105 | # 106 | # Default: inline 107 | long_list_align: inline 108 | 109 | # Align empty list (importing instances) 110 | # 111 | # Empty list align has following options 112 | # 113 | # - inherit: inherit list_align setting 114 | # 115 | # - right_after: () is right after the module name: 116 | # 117 | # > import Vector.Instances () 118 | # 119 | # Default: inherit 120 | empty_list_align: inherit 121 | 122 | # List padding determines indentation of import list on lines after import. 123 | # This option affects 'long_list_align'. 124 | # 125 | # - : constant value 126 | # 127 | # - module_name: align under start of module name. 128 | # Useful for 'file' and 'group' align settings. 129 | list_padding: 4 130 | 131 | # Separate lists option affects formatting of import list for type 132 | # or class. The only difference is single space between type and list 133 | # of constructors, selectors and class functions. 134 | # 135 | # - true: There is single space between Foldable type and list of it's 136 | # functions. 137 | # 138 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 139 | # 140 | # - false: There is no space between Foldable type and list of it's 141 | # functions. 142 | # 143 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 144 | # 145 | # Default: true 146 | separate_lists: true 147 | 148 | # Space surround option affects formatting of import lists on a single 149 | # line. The only difference is single space after the initial 150 | # parenthesis and a single space before the terminal parenthesis. 151 | # 152 | # - true: There is single space associated with the enclosing 153 | # parenthesis. 154 | # 155 | # > import Data.Foo ( foo ) 156 | # 157 | # - false: There is no space associated with the enclosing parenthesis 158 | # 159 | # > import Data.Foo (foo) 160 | # 161 | # Default: false 162 | space_surround: false 163 | 164 | # Language pragmas 165 | - language_pragmas: 166 | # We can generate different styles of language pragma lists. 167 | # 168 | # - vertical: Vertical-spaced language pragmas, one per line. 169 | # 170 | # - compact: A more compact style. 171 | # 172 | # - compact_line: Similar to compact, but wrap each line with 173 | # `{-#LANGUAGE #-}'. 174 | # 175 | # Default: vertical. 176 | style: vertical 177 | 178 | # Align affects alignment of closing pragma brackets. 179 | # 180 | # - true: Brackets are aligned in same column. 181 | # 182 | # - false: Brackets are not aligned together. There is only one space 183 | # between actual import and closing bracket. 184 | # 185 | # Default: true 186 | align: true 187 | 188 | # stylish-haskell can detect redundancy of some language pragmas. If this 189 | # is set to true, it will remove those redundant pragmas. Default: true. 190 | remove_redundant: true 191 | 192 | # Replace tabs by spaces. This is disabled by default. 193 | # - tabs: 194 | # # Number of spaces to use for each tab. Default: 8, as specified by the 195 | # # Haskell report. 196 | # spaces: 8 197 | 198 | # Remove trailing whitespace 199 | - trailing_whitespace: {} 200 | 201 | # Squash multiple spaces between the left and right hand sides of some 202 | # elements into single spaces. Basically, this undoes the effect of 203 | # simple_align but is a bit less conservative. 204 | # - squash: {} 205 | 206 | # A common setting is the number of columns (parts of) code will be wrapped 207 | # to. Different steps take this into account. Default: 80. 208 | columns: 80 209 | 210 | # By default, line endings are converted according to the OS. You can override 211 | # preferred format here. 212 | # 213 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 214 | # 215 | # - lf: Convert to LF ("\n"). 216 | # 217 | # - crlf: Convert to CRLF ("\r\n"). 218 | # 219 | # Default: native. 220 | newline: native 221 | 222 | # Sometimes, language extensions are specified in a cabal file or from the 223 | # command line instead of using language pragmas in the file. stylish-haskell 224 | # needs to be aware of these, so it can parse the file correctly. 225 | # 226 | # No language extensions are enabled by default. 227 | # language_extensions: 228 | # - TemplateHaskell 229 | # - QuasiQuotes 230 | -------------------------------------------------------------------------------- /src/Typing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | module Typing where 6 | 7 | import Control.Lens hiding (Level) 8 | import Control.Monad.Except 9 | import Control.Monad.Extra (fromMaybeM, maybeM) 10 | import Control.Monad.Reader 11 | import Control.Monad.State 12 | import Control.Monad.Trans.Maybe 13 | import Data.Bool (bool) 14 | import qualified Data.Map as Map 15 | import qualified Data.Set as Set 16 | 17 | import qualified Nameless as N 18 | import qualified Parse as P 19 | import Utils 20 | 21 | type TVar = Int 22 | 23 | data Level 24 | = Free Int 25 | | Bound 26 | | Rigid 27 | deriving (Show, Eq) 28 | 29 | data Type 30 | = Integer 31 | | Variable TVar Level 32 | | Apply Type Type 33 | | Enum String 34 | | Arrow 35 | | Tuple [Type] 36 | deriving (Show, Eq) 37 | 38 | functionTy :: Type -> Type -> Type 39 | functionTy a = Apply (Apply Arrow a) 40 | 41 | data Scheme = Forall [TVar] Type 42 | 43 | data TypeEnv = 44 | TypeEnv { _params :: [Type] 45 | , _locals :: [[Scheme]] 46 | , _globals :: Map.Map String Scheme } 47 | makeLenses ''TypeEnv 48 | 49 | initEnv :: TypeEnv 50 | initEnv = TypeEnv [] [] Map.empty 51 | lookupParam :: Int -> TypeEnv -> Type 52 | lookupParam i = views params (!! i) 53 | lookupLocal :: Int -> Int -> TypeEnv -> Scheme 54 | lookupLocal i1 i2 = views locals ((!! i2) . (!! i1)) 55 | lookupGlobal :: String -> TypeEnv -> Maybe Scheme 56 | lookupGlobal name = views globals (Map.lookup name) 57 | appendParam :: Type -> TypeEnv -> TypeEnv 58 | appendParam t = over params (t:) 59 | appendLocal :: [Scheme] -> TypeEnv -> TypeEnv 60 | appendLocal t = over locals (t:) 61 | appendGlobal :: String -> Scheme -> TypeEnv -> TypeEnv 62 | appendGlobal k v = over globals (Map.insert k v) 63 | 64 | type Subst = Map.Map TVar Type 65 | 66 | nullSubst :: Subst 67 | nullSubst = Map.empty 68 | 69 | class Substitutable a where 70 | apply :: Subst -> a -> a 71 | ftv :: a -> Set.Set Int 72 | 73 | instance Substitutable Type where 74 | apply s t@(Variable i _) = Map.findWithDefault t i s 75 | apply s (Apply a b) = Apply (apply s a) (apply s b) 76 | apply s (Tuple xs) = Tuple $ apply s xs 77 | apply _ Integer = Integer 78 | apply _ Arrow = Arrow 79 | apply _ (Enum n) = Enum n 80 | 81 | ftv (Apply a b) = ftv a `Set.union` ftv b 82 | ftv (Variable i _) = Set.singleton i 83 | ftv (Tuple xs) = ftv xs 84 | ftv Integer = Set.empty 85 | ftv Arrow = Set.empty 86 | ftv (Enum _) = Set.empty 87 | 88 | instance Substitutable Scheme where 89 | apply s (Forall as t) = Forall as $ apply (foldr Map.delete s as) t 90 | ftv (Forall as t) = ftv t `Set.difference` Set.fromList as 91 | 92 | instance Substitutable a => Substitutable [a] where 93 | apply = map . apply 94 | ftv = foldr (Set.union . ftv) Set.empty 95 | 96 | instance Substitutable TypeEnv where 97 | apply s (TypeEnv ps ls gs) = TypeEnv (apply s ps) (apply s ls) (Map.map (apply s) gs) 98 | ftv (TypeEnv ps ls gs) = ftv ps `Set.union` ftv ls `Set.union` ftv (Map.elems gs) 99 | 100 | type Constraint = (Type, Type) 101 | 102 | instance Substitutable Constraint where 103 | apply s c = c & both %~ apply s 104 | ftv (t1, t2) = ftv t1 `Set.union` ftv t2 105 | 106 | compose :: Subst -> Subst -> Subst 107 | s1 `compose` s2 = Map.map (apply s1) s2 `Map.union` s1 108 | 109 | type EvalEnv = Map.Map String Type 110 | initEvalEnv :: EvalEnv 111 | initEvalEnv = Map.fromList [("Int", Integer)] 112 | 113 | type CtorEnv = Map.Map String Scheme 114 | initCtorEnv :: CtorEnv 115 | initCtorEnv = Map.empty 116 | 117 | data InferReader = 118 | InferReader { _typeEnv :: TypeEnv 119 | , _letLevel :: Int } 120 | makeLenses ''InferReader 121 | 122 | initInferReader :: InferReader 123 | initInferReader = InferReader initEnv 0 124 | 125 | data InferState = 126 | InferState { _unique :: Int 127 | , _ctorEnv :: CtorEnv 128 | , _evalEnv :: EvalEnv 129 | , _cstrs :: [Constraint] } 130 | makeLenses ''InferState 131 | 132 | initInferState :: InferState 133 | initInferState = InferState 0 initCtorEnv initEvalEnv [] 134 | 135 | type Infer = ExceptT TypeError (ReaderT InferReader (State InferState)) 136 | 137 | data TypeError 138 | = UnificationFail Type Type 139 | | RigidUnificationFail Int Type 140 | | InfiniteType Int Type 141 | | UnboundVariable String 142 | | UnboundTypeIdentifier String 143 | deriving (Show, Eq) 144 | 145 | fresh :: Level -> Infer Type 146 | fresh level = unique += 1 >> uses unique (flip Variable level) 147 | 148 | freshFree :: Infer Type 149 | freshFree = fresh =<< views letLevel Free 150 | 151 | freshBound :: Infer Type 152 | freshBound = fresh Bound 153 | 154 | findParam :: Int -> Infer Type 155 | findParam i = views typeEnv (lookupParam i) 156 | 157 | findLocal :: N.LetIndex -> Infer Scheme 158 | findLocal (N.LetIndex _ local inner) = views typeEnv (lookupLocal local inner) 159 | 160 | findGlobal :: String -> Infer Scheme 161 | findGlobal s = fromMaybeM (throwError $ UnboundVariable s) $ lookupGlobal s <$> view typeEnv 162 | 163 | withParam :: Type -> Infer a -> Infer a 164 | withParam = locally typeEnv . appendParam 165 | 166 | withGlobal :: String -> Scheme -> Infer a -> Infer a 167 | withGlobal name = locally typeEnv . appendGlobal name 168 | 169 | withSubst :: Subst -> Infer a -> Infer a 170 | withSubst = locally typeEnv . apply 171 | 172 | withLocals :: [Scheme] -> Infer a -> Infer a 173 | withLocals = locally typeEnv . appendLocal 174 | 175 | pushLevel :: Infer a -> Infer a 176 | pushLevel = locally letLevel succ 177 | 178 | unify :: Type -> Type -> Infer () 179 | unify t1 t2 = cstrs %= ((t1, t2):) 180 | 181 | type Rigidify = Reader [Int] 182 | rigidify :: Type -> Rigidify Type 183 | rigidify Integer = return Integer 184 | rigidify (Enum s) = return $ Enum s 185 | rigidify Arrow = return Arrow 186 | rigidify t@(Variable i Bound) = asks $ bool t (Variable i Rigid) . elem i 187 | rigidify t@(Variable _ Rigid) = return t 188 | rigidify (Variable _ (Free _)) = error "attempt to rigidify free var" 189 | rigidify (Tuple xs) = Tuple <$> mapM rigidify xs 190 | rigidify (Apply a b) = Apply <$> rigidify a <*> rigidify b 191 | 192 | runRigidify :: [Int] -> Type -> Type 193 | runRigidify l t = runReader (rigidify t) l 194 | 195 | -- generalization and instantiation 196 | -- TODO: Stop using `Infer` here (use of `unify` in `generalizer` should be prohibited) 197 | generalizer :: Type -> Infer Subst 198 | generalizer (Apply a b) = compose <$> generalizer a <*> generalizer b 199 | generalizer Integer = return nullSubst 200 | generalizer Arrow = return nullSubst 201 | generalizer (Enum _) = return nullSubst 202 | generalizer (Tuple xs) = foldr compose nullSubst <$> mapM generalizer xs 203 | generalizer (Variable i (Free level)) = do 204 | cLevel <- view letLevel 205 | if cLevel < level 206 | then Map.singleton i <$> freshBound 207 | else return nullSubst 208 | generalizer (Variable _ _) = return nullSubst 209 | 210 | generalize :: Type -> Infer Scheme 211 | generalize t = do 212 | s <- generalizer t 213 | return $ Forall (extractAll s) (apply s t) 214 | where 215 | extractAll = map extract . Map.elems 216 | extract (Variable i Bound) = i 217 | 218 | instantiate :: Scheme -> Infer Type 219 | instantiate (Forall xs t) = do 220 | xs' <- replicateM (length xs) freshFree 221 | let s = Map.fromList $ zip xs xs' 222 | return $ apply s t 223 | 224 | {-# HLINT ignore inferExpr "Reduce duplication" #-} 225 | inferExpr :: N.Expr -> Infer Type 226 | inferExpr (N.ParamBound i) = findParam i 227 | inferExpr (N.GlobalBound name _) = instantiate =<< findGlobal name 228 | inferExpr (N.LetBound i) = instantiate =<< findLocal i 229 | inferExpr (N.Integer _) = return Integer 230 | inferExpr (N.Lambda body) = do 231 | tv <- freshFree 232 | ret <- withParam tv $ inferExpr body 233 | return $ functionTy tv ret 234 | inferExpr (N.Apply a b) = do 235 | tv <- freshFree 236 | a_ty <- inferExpr a 237 | b_ty <- inferExpr b 238 | unify a_ty (functionTy b_ty tv) 239 | return tv 240 | inferExpr (N.LetIn annots defs body) = do 241 | tys <- mapM mapper annots 242 | iTys <- withLocals tys $ pushLevel $ mapM inferExpr defs 243 | schemes <- zipWithM zipper iTys annots 244 | withLocals schemes $ inferExpr body 245 | where 246 | mapper annot = maybeM (Forall [] <$> freshFree) evalScheme $ return annot 247 | zipper t = maybe (generalize t) (go t) 248 | go t1 annot = do 249 | scheme <- evalScheme annot 250 | let (Forall vars t2) = scheme 251 | unify (runRigidify vars t2) t1 >> return scheme 252 | inferExpr (N.BinaryOp op a b) = 253 | let op_type = Integer in 254 | do 255 | a_ty <- inferExpr a 256 | b_ty <- inferExpr b 257 | unify a_ty op_type 258 | unify b_ty op_type 259 | return op_type 260 | inferExpr (N.SingleOp op x) = 261 | let op_type = Integer in 262 | do 263 | ty <- inferExpr x 264 | unify ty op_type 265 | return op_type 266 | inferExpr (N.Tuple xs) = Tuple <$> mapM inferExpr xs 267 | inferExpr (N.If c t e) = do 268 | t1 <- inferExpr c 269 | t2 <- inferExpr t 270 | t3 <- inferExpr e 271 | unify t1 Integer -- TODO: Bool 272 | unify t2 t3 273 | return t2 274 | inferExpr (N.NthOf n i e) = do 275 | ts <- replicateM n freshFree 276 | t2 <- inferExpr e 277 | unify (Tuple ts) t2 278 | return $ ts !! i 279 | inferExpr (N.Error _) = freshFree 280 | inferExpr (N.CtorApp name e) = do 281 | tv <- freshFree 282 | t1 <- instantiate =<< uses ctorEnv (Map.! name) 283 | t2 <- inferExpr e 284 | unify t1 (functionTy t2 tv) 285 | return tv 286 | inferExpr (N.DataOf name e) = do 287 | tv <- freshFree 288 | t1 <- instantiate =<< uses ctorEnv (Map.! name) 289 | t2 <- inferExpr e 290 | unify t1 (functionTy tv t2) 291 | return tv 292 | inferExpr (N.IsCtor name e) = do 293 | tv <- freshFree 294 | t1 <- instantiate =<< uses ctorEnv (Map.! name) 295 | t2 <- inferExpr e 296 | unify t1 (functionTy tv t2) 297 | return Integer -- TODO: Bool 298 | 299 | inferDefs :: Map.Map String Scheme -> [N.NameDef] -> Infer () 300 | inferDefs sig defs = do 301 | filledSig <- Map.fromList <$> mapM mapper names 302 | tys <- foldr (collectNames filledSig) (pushLevel $ mapM inferExpr bodies) names 303 | zipWithM_ zipper names tys 304 | where 305 | extract (N.Name name body) = (name, body) 306 | (names, bodies) = mapAndUnzip extract defs 307 | collectNames s name = withGlobal name (s Map.! name) 308 | mapper name = (,) name <$> fromMaybeM (Forall [] <$> freshFree) (return $ Map.lookup name sig) 309 | zipper name ty = case Map.lookup name sig of 310 | Just (Forall vars annot) -> unify (runRigidify vars annot) ty 311 | Nothing -> return () 312 | 313 | inferCode :: N.Code -> Infer () 314 | inferCode (N.Code sig typeDefs defs) = do 315 | defineTypes typeDefs 316 | flip inferDefs defs =<< mapMapM evalScheme sig 317 | 318 | defineTypes :: [N.TypeDef] -> Infer () 319 | defineTypes xs = do 320 | evalEnv %= flip Map.union names' 321 | mapM_ defineOne xs 322 | where 323 | defineOne :: N.TypeDef -> Infer () 324 | defineOne (N.Variant name as ctors) = do 325 | vars <- replicateM (length as) freshBound 326 | let et = foldl Apply (Enum name) vars 327 | let tvs = map extractVar vars 328 | withNames (Map.fromList $ zip as vars) $ mapM_ (defineCtor tvs et) ctors 329 | defineCtor :: [TVar] -> Type -> (String, P.TypeExpr) -> Infer () 330 | defineCtor vars et (name, ty) = do 331 | t <- evalType ty 332 | ctorEnv %= Map.insert name (Forall vars $ functionTy t et) 333 | extractVar (Variable i _) = i 334 | extract (N.Variant name _ _) = name 335 | names = map extract xs 336 | names' = Map.fromList $ zip names $ map Enum names 337 | 338 | runInfer :: Infer a -> Either TypeError (a, [Constraint]) 339 | runInfer m = a & _Right %~ f 340 | where 341 | f a = (a, s ^. cstrs) 342 | (a, s) = runState (runReaderT (runExceptT m) initInferReader) initInferState 343 | 344 | -- type evaluator 345 | withNames :: Map.Map String Type -> Infer a -> Infer a 346 | withNames m a = do 347 | old <- use evalEnv 348 | evalEnv %= flip Map.union m 349 | r <- a 350 | evalEnv .= old 351 | return r 352 | 353 | evalScheme :: P.TypeScheme -> Infer Scheme 354 | evalScheme (P.Forall as x) = do 355 | vars <- replicateM (length as) freshBound 356 | Forall (map destruct vars) <$> withNames (Map.fromList $ zip as vars) (evalType x) 357 | where 358 | destruct (Variable i _) = i 359 | 360 | evalType :: P.TypeExpr -> Infer Type 361 | evalType (P.Ident x) = fromMaybeM (throwError $ UnboundTypeIdentifier x) $ Map.lookup x <$> use evalEnv 362 | evalType (P.Function a b) = functionTy <$> evalType a <*> evalType b 363 | evalType (P.Product xs) = Tuple <$> mapM evalType xs 364 | evalType (P.ApplyTy a b) = Apply <$> evalType a <*> evalType b 365 | 366 | -- constraint solver 367 | type Solve = Except TypeError 368 | 369 | unifiesMany :: [Type] -> [Type] -> MaybeT Solve Subst 370 | unifiesMany [] [] = return nullSubst 371 | unifiesMany (t1 : ts1) (t2 : ts2) = do 372 | s1 <- lift $ unifies t1 t2 373 | s2 <- unifiesMany (apply s1 ts1) (apply s1 ts2) 374 | return $ s2 `compose` s1 375 | unifiesMany _ _ = mzero 376 | 377 | manyOrErr :: TypeError -> [Type] -> [Type] -> Solve Subst 378 | manyOrErr err ts1 ts2 = fromMaybeM (throwError err) $ runMaybeT $ unifiesMany ts1 ts2 379 | 380 | unifies :: Type -> Type -> Solve Subst 381 | unifies t1 t2 | t1 == t2 = return nullSubst 382 | unifies t@(Variable _ Rigid) (Variable i _) = bind i t 383 | unifies (Variable i _) t@(Variable _ Rigid) = bind i t 384 | unifies (Variable i Rigid) t = throwError $ RigidUnificationFail i t 385 | unifies t (Variable i Rigid) = throwError $ RigidUnificationFail i t 386 | unifies (Variable i _) t = bind i t 387 | unifies t (Variable i _) = bind i t 388 | unifies t1@(Apply a1 b1) t2@(Apply a2 b2) = manyOrErr (UnificationFail t1 t2) [a1, b1] [a2, b2] 389 | unifies t1@(Tuple xs) t2@(Tuple ys) = manyOrErr (UnificationFail t1 t2) xs ys 390 | unifies t1 t2 = throwError $ UnificationFail t1 t2 391 | 392 | bind :: Int -> Type -> Solve Subst 393 | bind i (Variable i' _) | i' == i = return nullSubst 394 | bind i t | occursCheck i t = throwError $ InfiniteType i t 395 | | otherwise = return $ Map.singleton i t 396 | 397 | occursCheck :: Substitutable a => Int -> a -> Bool 398 | occursCheck i t = i `Set.member` ftv t 399 | 400 | solver :: [Constraint] -> Solve Subst 401 | solver [] = return nullSubst 402 | solver ((t1, t2) : cs) = do 403 | s <- unifies t1 t2 404 | compose s <$> solver (apply s cs) 405 | 406 | runSolve :: Solve a -> Either TypeError a 407 | runSolve = runExcept 408 | 409 | runTyping_ :: Infer a -> Either TypeError () 410 | runTyping_ m = do 411 | (_, cs) <- runInfer m 412 | _ <- runSolve $ solver cs 413 | return () 414 | 415 | typing :: N.Code -> Either TypeError () 416 | typing = runTyping_ . inferCode 417 | 418 | runTyping :: Substitutable a => Infer a -> Either TypeError a 419 | runTyping m = do 420 | (a, cs) <- runInfer m 421 | s <- runSolve $ solver cs 422 | return (apply s a) 423 | --------------------------------------------------------------------------------