├── ttc ├── tests │ ├── multi │ │ ├── 1 │ │ │ ├── 2.stlc │ │ │ └── 1.stlc │ │ └── 1.gold │ ├── single │ │ ├── 1.gold │ │ ├── 15.gold │ │ ├── 14.gold │ │ ├── 6.gold │ │ ├── 2.gold │ │ ├── 7.gold │ │ ├── 3.gold │ │ ├── 8.gold │ │ ├── 4.gold │ │ ├── 5.gold │ │ ├── 1.stlc │ │ ├── 11.gold │ │ ├── 2.stlc │ │ ├── 9.gold │ │ ├── 15.stlc │ │ ├── 10.gold │ │ ├── 16.stlc │ │ ├── 14.stlc │ │ ├── 3.stlc │ │ ├── 7.stlc │ │ ├── 6.stlc │ │ ├── 12.stlc │ │ ├── 13.stlc │ │ ├── 5.stlc │ │ ├── 4.stlc │ │ ├── 11.stlc │ │ ├── 8.stlc │ │ ├── 10.stlc │ │ └── 9.stlc │ ├── .gitignore │ └── Test.hs ├── Setup.hs ├── CHANGELOG.md ├── rts.c ├── LICENSE ├── ttc.cabal └── app │ ├── Compiler.hs │ └── Main.hs ├── qtt ├── src │ ├── Parse.hs │ ├── Main.hs │ ├── Check │ │ └── Monad.hs │ ├── Equal.hs │ ├── Eval.hs │ ├── Check.hs │ └── Syntax.hs ├── Setup.hs ├── ChangeLog.md ├── qtt.cabal └── LICENSE ├── lltt ├── Setup.hs ├── src │ └── Language │ │ └── LLTT │ │ ├── Lex.hs │ │ ├── Parse.hs │ │ ├── Namecheck.hs │ │ ├── Syntax.hs │ │ └── Infer.hs ├── CHANGELOG.md ├── lltt.cabal └── LICENSE ├── stlc ├── Setup.hs ├── src │ └── Language │ │ └── STLC │ │ ├── Lex │ │ ├── .#Token.hs │ │ ├── State.hs │ │ ├── Error.hs │ │ ├── Token.hs │ │ └── Format.hs │ │ ├── Parse │ │ └── Error.hs │ │ ├── Reduce.hs │ │ ├── Lift.hs │ │ ├── Partial.hs │ │ ├── CConv.hs │ │ ├── Desugar.hs │ │ ├── Match.hs │ │ ├── Namecheck.hs │ │ └── Lex.x ├── CHANGELOG.md ├── LICENSE └── stlc.cabal ├── systemf ├── src │ └── Language │ │ └── SystemF │ │ ├── Lex.hs │ │ ├── Parse.hs │ │ ├── Infer.hs │ │ ├── Namecheck.hs │ │ ├── Partial.hs │ │ ├── Pretty.hs │ │ ├── Lift.hs │ │ ├── Monomorphize.hs │ │ ├── CConv.hs │ │ └── Syntax.hs ├── Setup.hs ├── CHANGELOG.md └── systemf.cabal ├── lltt-llvm ├── Setup.hs ├── CHANGELOG.md ├── lltt-llvm.cabal └── src │ └── LLVM │ └── IRBuilder │ └── Extra.hs ├── report ├── Setup.hs ├── CHANGELOG.md ├── report.cabal ├── LICENSE └── src │ └── Control │ └── Monad │ └── Report.hs ├── language-syntax ├── Setup.hs ├── CHANGELOG.md ├── language-syntax.cabal ├── LICENSE └── src │ └── Language │ └── Syntax │ └── Location.hs ├── cabal.project.local ├── language-module-system ├── Setup.hs ├── CHANGELOG.md ├── src │ └── Language │ │ └── Module.hs ├── language-module-system.cabal └── LICENSE ├── prof.rc ├── cabal.project ├── .gitignore ├── ISSUES.txt ├── shell.nix └── README.md /ttc/tests/multi/1.gold: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /ttc/tests/single/1.gold: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /ttc/tests/single/15.gold: -------------------------------------------------------------------------------- 1 | 3 -------------------------------------------------------------------------------- /ttc/tests/single/14.gold: -------------------------------------------------------------------------------- 1 | (1, 3) -------------------------------------------------------------------------------- /ttc/tests/single/6.gold: -------------------------------------------------------------------------------- 1 | 3 2 | -------------------------------------------------------------------------------- /ttc/tests/single/2.gold: -------------------------------------------------------------------------------- 1 | Hello World! 2 | -------------------------------------------------------------------------------- /ttc/tests/single/7.gold: -------------------------------------------------------------------------------- 1 | 1 2 | 2 3 | 3 4 | -------------------------------------------------------------------------------- /qtt/src/Parse.hs: -------------------------------------------------------------------------------- 1 | module Parse where 2 | 3 | -------------------------------------------------------------------------------- /ttc/tests/.gitignore: -------------------------------------------------------------------------------- 1 | build/* 2 | bin/* 3 | out/* -------------------------------------------------------------------------------- /ttc/tests/single/3.gold: -------------------------------------------------------------------------------- 1 | 1 2 | 2 3 | 6 4 | 24 5 | -------------------------------------------------------------------------------- /ttc/tests/single/8.gold: -------------------------------------------------------------------------------- 1 | 12929 2 | 23232 3 | 36161 4 | -------------------------------------------------------------------------------- /ttc/tests/single/4.gold: -------------------------------------------------------------------------------- 1 | 3 2 | 4 3 | 5 4 | 6 5 | Nothing 6 | -------------------------------------------------------------------------------- /ttc/tests/single/5.gold: -------------------------------------------------------------------------------- 1 | 3 2 | 4 3 | 5 4 | 6 5 | Nothing 6 | -------------------------------------------------------------------------------- /lltt/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /qtt/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stlc/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Lex/.#Token.hs: -------------------------------------------------------------------------------- 1 | gabe@gabe-G74Sx.4880:1541961347 -------------------------------------------------------------------------------- /systemf/src/Language/SystemF/Lex.hs: -------------------------------------------------------------------------------- 1 | module Language.SystemF.Lex where -------------------------------------------------------------------------------- /ttc/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lltt-llvm/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lltt/src/Language/LLTT/Lex.hs: -------------------------------------------------------------------------------- 1 | module Language.LLTT.Lex where 2 | 3 | -------------------------------------------------------------------------------- /lltt/src/Language/LLTT/Parse.hs: -------------------------------------------------------------------------------- 1 | module Language.LLTT.Parse where 2 | 3 | -------------------------------------------------------------------------------- /report/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /systemf/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /systemf/src/Language/SystemF/Parse.hs: -------------------------------------------------------------------------------- 1 | module Language.SystemF.Parse where -------------------------------------------------------------------------------- /language-syntax/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lltt/src/Language/LLTT/Namecheck.hs: -------------------------------------------------------------------------------- 1 | module Language.LLTT.Namecheck where 2 | 3 | -------------------------------------------------------------------------------- /systemf/src/Language/SystemF/Infer.hs: -------------------------------------------------------------------------------- 1 | module Language.SystemF.Infer where 2 | 3 | -------------------------------------------------------------------------------- /systemf/src/Language/SystemF/Namecheck.hs: -------------------------------------------------------------------------------- 1 | module Language.SystemF.Namecheck where -------------------------------------------------------------------------------- /cabal.project.local: -------------------------------------------------------------------------------- 1 | profiling: True 2 | tests: True 3 | keep-going: True 4 | jobs: 16 -------------------------------------------------------------------------------- /language-module-system/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ttc/tests/multi/1/2.stlc: -------------------------------------------------------------------------------- 1 | module B 2 | 3 | foo : I32 -> I32 -> I32 4 | foo a b = add a b -------------------------------------------------------------------------------- /ttc/tests/single/1.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | main : I32 -> **I8 -> I32 4 | main argc argv = 0 -------------------------------------------------------------------------------- /ttc/tests/multi/1/1.stlc: -------------------------------------------------------------------------------- 1 | module A 2 | 3 | import B 4 | 5 | main : I32 -> **I8 -> I32 6 | main argc argv = 0 -------------------------------------------------------------------------------- /ttc/tests/single/11.gold: -------------------------------------------------------------------------------- 1 | e1 = 2 | e2 = 10 3 | e3 = 14 4 | addEither e1 e2 = 5 | addEither e2 e3 = 24 6 | -------------------------------------------------------------------------------- /lltt/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for anf 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /qtt/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for qtt 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /ttc/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for ttc 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /prof.rc: -------------------------------------------------------------------------------- 1 | export NIX_CFLAGS_COMPILE="-idirafter /usr/include ${NIX_CFLAGS_COMPILE}" 2 | export NIX_CFLAGS_LINK="-L/usr/lib ${NIX_CFLAGS_LINK}" 3 | -------------------------------------------------------------------------------- /report/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for report 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /stlc/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for stlc 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /lltt-llvm/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for anf-llvm 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /systemf/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for system-f 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /language-syntax/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for ttc-util 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /language-module-system/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for ttc-modules 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /ttc/tests/single/2.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern puts : *I8 -> I32 4 | 5 | main: I32 -> **I8 -> I32 6 | main argc argv = 7 | let _ = puts "Hello World!" 8 | in 0 9 | -------------------------------------------------------------------------------- /qtt/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Eval 4 | import Check 5 | 6 | main :: IO () 7 | main = do 8 | let r = eval undefined 9 | putStrLn "Hello, Haskell!" 10 | -------------------------------------------------------------------------------- /ttc/tests/single/9.gold: -------------------------------------------------------------------------------- 1 | v1 = V { x = 1, y = 2, z = 3 } 2 | v2 = V { x = 4, y = 5, z = 6 } 3 | add v1 v2 = V { x = 5, y = 7, z = 9 } 4 | dot v1 v2 = 32 5 | cross v1 v2 = V { x = -3, y = 6, z = -3 } 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: report/ 2 | language-module-system/ 3 | language-syntax/ 4 | lltt/ 5 | lltt-llvm/ 6 | stlc/ 7 | systemf/ 8 | ttc/ 9 | jobs: 16 10 | keep-going: True -------------------------------------------------------------------------------- /ttc/tests/single/15.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern printint : I32 -> I32 4 | 5 | main : I32 -> **I8 -> I32 6 | main argc argv = 7 | let a = 1 : F32 8 | b = 2 : I32 9 | c : I64 = #add (a as I64) (b as I64) 10 | _ = printint (c as I32) 11 | in 0 -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local~ 20 | .HTF/ 21 | .ghc.environment.* -------------------------------------------------------------------------------- /ISSUES.txt: -------------------------------------------------------------------------------- 1 | - Codegen cannot generate 16 or 128 bit floating point literals 2 | - Codegen does not support allocating heap vectors 3 | - Codegen doesn not support negation 4 | - Codegen poorly supports right shifts 5 | - Typechecker does not support negation 6 | - Typechecker does not support bitshifts 7 | - Typechecker does not support vector literals -------------------------------------------------------------------------------- /ttc/tests/single/10.gold: -------------------------------------------------------------------------------- 1 | xs = 1 2 3 4 5 6 7 8 9 10 2 | sumints xs n = 55 3 | ys = 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 4 | -------------------------------------------------------------------------------- /systemf/src/Language/SystemF/Partial.hs: -------------------------------------------------------------------------------- 1 | module Language.SystemF.Partial where 2 | 3 | -- We can implement partial applications by identifying 4 | -- and wrapping them in lambdas expressions. 5 | 6 | -- Later phases will lift these functions and handle closure conversion. 7 | -- This will lead to a function new function generated for each 8 | -- partial application, which should be efficient enough to compete with C. -------------------------------------------------------------------------------- /systemf/src/Language/SystemF/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 2 | {-# LANGUAGE LambdaCase 3 | , OverloadedStrings 4 | , FlexibleInstances 5 | #-} 6 | module Language.SystemF.Pretty where 7 | 8 | import Language.SystemF.Syntax 9 | 10 | import Unbound.Generics.LocallyNameless 11 | import Unbound.Generics.LocallyNameless.Name 12 | 13 | import Data.Text.Prettyprint.Doc -------------------------------------------------------------------------------- /ttc/tests/single/16.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern printstr : *I8 -> I32 4 | extern printint : I32 -> I32 5 | 6 | printiptr : *I32 -> I32 7 | printiptr i = 8 | if #eq i null then 0 9 | else let _ = printint *i 10 | in printstr "\n" 11 | 12 | main : I32 -> **I8 -> I32 13 | main argc argv = 14 | let a = null : *I32 15 | b = &5 : *I32 16 | _ = printiptr a 17 | _ = printiptr b 18 | in 0 -------------------------------------------------------------------------------- /systemf/src/Language/SystemF/Lift.hs: -------------------------------------------------------------------------------- 1 | module Language.SystemF.Lift where 2 | 3 | -- Lambda lifting finds nested function definitions, 4 | -- generates a name for them and lifts them out of a 5 | -- function body. All lambda expressions are replaced 6 | -- by a pointer to their lifted version. 7 | 8 | -- This pass requires partial and cconv. 9 | 10 | import Language.SystemF.Syntax 11 | 12 | lift :: Module -> Module 13 | lift = undefined -------------------------------------------------------------------------------- /ttc/tests/single/14.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern printstr : *I8 -> I32 4 | extern printint : I32 -> I32 5 | 6 | addPair : (I32, I32) -> I32 7 | addPair p = 8 | let (a, b) = p 9 | in #add a b 10 | 11 | printPair : (I32, I32) -> I32 12 | printPair p = 13 | let (a, b) = p 14 | _ = printstr "(" 15 | _ = printint a 16 | _ = printstr ", " 17 | _ = printint b 18 | in printstr ")" 19 | 20 | main : I32 -> **I8 -> I32 21 | main argc argv = 22 | let _ = printPair (1, 3) 23 | in 0 -------------------------------------------------------------------------------- /systemf/src/Language/SystemF/Monomorphize.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-matches #-} 2 | module Language.SystemF.Monomorphize where 3 | 4 | import Language.SystemF.Syntax 5 | import qualified Language.STLC.Syntax as ST 6 | 7 | -- This will monomorphize polymorphic functions by 8 | -- generating monomorphic instances of each function. 9 | 10 | -- This pass requires partial, cconv, and lambda lifting. 11 | 12 | -- This will produce STLC. 13 | 14 | monomorphize :: Module -> ST.Module 15 | monomorphize modl = undefined -------------------------------------------------------------------------------- /ttc/tests/single/3.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern int2str : I32 -> *I8 -> *I8 4 | extern puts : *I8 -> I32 5 | 6 | fact : I32 -> I32 7 | fact n = fact' n 1 8 | 9 | fact' : I32 -> I32 -> I32 10 | fact' n x = 11 | if #eq n 0 12 | then x 13 | else fact' (#sub n 1) (#mul n x) 14 | 15 | main : I32 -> **I8 -> I32 16 | main argc argv = 17 | let _ = puts (int2str (fact 1) (Array[1])) 18 | _ = puts (int2str (fact 2) (Array[1])) 19 | _ = puts (int2str (fact 3) (Array[1])) 20 | _ = puts (int2str (fact 4) (Array[2])) 21 | in 0 -------------------------------------------------------------------------------- /systemf/src/Language/SystemF/CConv.hs: -------------------------------------------------------------------------------- 1 | module Language.SystemF.CConv where 2 | 3 | -- Closure conversion is done by find lambda terms, 4 | -- and adding a closure as the first argument of a function. 5 | -- A lambda expression with a closure is considered saturated. 6 | -- Since the function is a local variable, applications of 7 | -- it must be found and updated with their closure as the 8 | -- first argument. 9 | 10 | -- Lambda lifting depends on closure conversion. 11 | -- Lambda's lifted before cconv will have 12 | -- varibles that are never introduced into scope. -------------------------------------------------------------------------------- /ttc/tests/single/7.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern int2str : I32 -> *I8 -> *I8 4 | extern puts : *I8 -> I32 5 | extern malloc : I32 -> *I8 6 | extern free : *I8 -> I8 7 | 8 | printArray : *I32 -> I32 -> I32 9 | printArray xs n = printArray1 xs n 0 10 | 11 | printArray1 : *I32 -> I32 -> I32 -> I32 12 | printArray1 xs n i = 13 | if #eq i n then 0 else 14 | let _ = printInt xs[i] in 15 | printArray1 xs n (#add i 1) 16 | 17 | printInt : I32 -> I32 18 | printInt x = 19 | let txt = int2str x (Array[2]) 20 | _ = puts txt 21 | in 0 22 | 23 | main : I32 -> **I8 -> I32 24 | main argc argv = 25 | let a = new [1,2,3] 26 | in printArray a 3 -------------------------------------------------------------------------------- /ttc/tests/single/6.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern int2str : I32 -> *I8 -> *I8 4 | extern puts : *I8 -> I32 5 | extern malloc : I32 -> *I8 6 | extern free : *I8 -> I8 7 | 8 | type Maybe = Nothing | Just I32 9 | 10 | printMaybe : *Maybe -> I32 11 | printMaybe mx = 12 | case *mx of 13 | Nothing -> puts "Nothing" 14 | Just x -> printInt x 15 | 16 | printInt : I32 -> I32 17 | printInt x = 18 | let txt = new Array[2] : *I8 19 | txt1 = int2str x txt 20 | _ = puts txt1 21 | _ = delete txt1 22 | in 0 23 | 24 | main : I32 -> **I8 -> I32 25 | main argc argv = 26 | let m = &(Just 3) 27 | m1 = &(Just 2) 28 | _ = printMaybe m 29 | in 0 -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Parse/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Language.STLC.Parse.Error where 3 | 4 | import Language.STLC.Lex.Error 5 | import Language.STLC.Lex.Token 6 | 7 | import Data.Text.Prettyprint.Doc 8 | 9 | 10 | data ParseError 11 | = UnexpectedToken [Token] [String] 12 | | PLexErr LexError 13 | deriving(Show) 14 | 15 | instance Pretty ParseError where 16 | pretty = \case 17 | UnexpectedToken unexpected expected -> 18 | vsep [ pretty "Unexpected tokens:" <+> dquotes (pretty unexpected) 19 | , pretty "Expected tokens:" <+> dquotes (pretty expected) 20 | ] 21 | 22 | PLexErr err -> 23 | pretty err 24 | -------------------------------------------------------------------------------- /language-module-system/src/Language/Module.hs: -------------------------------------------------------------------------------- 1 | module Language.Module where 2 | 3 | import Data.IntMap.Strict (IntMap) 4 | -- import qualified Data.IntMap.Strict as IntMap 5 | 6 | import Data.Map.Strict (Map) 7 | 8 | import Data.List.NonEmpty (NonEmpty) 9 | 10 | data Project decl 11 | = Project 12 | { prjModules :: IntMap (Module decl) 13 | , prjAdj :: IntMap [Int] -- we can build a graph from this, and then we can figure out build order 14 | } 15 | 16 | data Module decl 17 | = Module 18 | { mPath :: FilePath 19 | , mName :: String 20 | , mImports :: [Import] 21 | , mSymbols :: Map String decl 22 | , mMisc :: [decl] 23 | } 24 | 25 | data Import 26 | = Import (NonEmpty String) [String] -------------------------------------------------------------------------------- /ttc/tests/single/12.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern printstr : *I8 -> I32 4 | extern printint : I32 -> I32 5 | 6 | type Unit = Unit 7 | 8 | fizzbuzz : I32 -> Unit 9 | fizzbuzz n = fizzbuzz' n 1 10 | 11 | fizzbuzz' : I32 -> I32 -> Unit 12 | fizzbuzz' n i = 13 | let i' = #add i 1 in 14 | if #lt n i then Unit 15 | elif #and (#eq (#rem i 3) 0) 16 | (#eq (#rem i 5) 0) then 17 | let _ = printstr "fizzbuzz " in 18 | fizzbuzz' n i' 19 | elif #eq (#rem i 3) 0 then 20 | let _ = printstr "fizz " in 21 | fizzbuzz' n i' 22 | elif #eq (#rem i 5) 0 then 23 | let _ = printstr "buzz " in 24 | fizzbuzz' n i' 25 | else 26 | let _ = printint i 27 | _ = printstr " " in 28 | fizzbuzz' n i' 29 | 30 | main : I32 -> **I8 -> I32 31 | main argc argv = 32 | let _ = fizzbuzz 6000 33 | in 0 34 | -------------------------------------------------------------------------------- /ttc/tests/single/13.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern printstr : *I8 -> I32 4 | extern printint : I32 -> I32 5 | extern malloc : I32 -> *I8 6 | 7 | type Tree = Tree I32 *Tree *Tree 8 | 9 | mkTree : I32 -> *Tree 10 | mkTree x = new Tree x null null 11 | 12 | copyTree : *Tree -> *Tree 13 | copyTree t = 14 | if #eq t null then null 15 | else case *t of 16 | Tree x l r -> new Tree x (copyTree l) (copyTree r) 17 | 18 | insertTree : *Tree -> I32 -> *Tree 19 | insertTree t x = 20 | if #eq t null then 21 | new Tree x null null 22 | else case *t of 23 | Tree y l r -> 24 | if #gt x y then 25 | new Tree y (copyTree l) (insertTree r x) 26 | elif #eq x y then 27 | new Tree y (copyTree l) (copyTree r) 28 | else 29 | new Tree y (insertTree l x) (copyTree r) 30 | 31 | 32 | main : I32 -> **I8 -> I32 33 | main argc argv = 0 -------------------------------------------------------------------------------- /language-module-system/language-module-system.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'ttc-modules.cabal' generated by 'cabal 3 | -- init'. For further documentation, see 4 | -- http://haskell.org/cabal/users-guide/ 5 | 6 | name: language-module-system 7 | version: 0.1.0.0 8 | -- synopsis: 9 | -- description: 10 | -- bug-reports: 11 | license: BSD-3-Clause 12 | license-file: LICENSE 13 | author: Gabriel Anderson 14 | maintainer: gabe4k@gmail.com 15 | -- copyright: 16 | -- category: 17 | extra-source-files: CHANGELOG.md 18 | 19 | library 20 | ghc-options: -Werror -Wall 21 | exposed-modules: Language.Module 22 | -- other-modules: 23 | -- other-extensions: 24 | build-depends: base ^>=4.12.0.0, 25 | containers 26 | hs-source-dirs: src 27 | default-language: Haskell2010 28 | -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Lex/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Language.STLC.Lex.State where 3 | 4 | import Lens.Micro.Platform 5 | import Language.Syntax.Location 6 | import Language.STLC.Lex.Token (Token) 7 | 8 | data LexState = 9 | LexState { _lexTokAcc :: [Token] 10 | , _lexRegion :: Region 11 | , _lexStartcode :: Int 12 | , _lexCommentDepth :: Int 13 | , _lexStringBuf :: String 14 | , _lexFilePath :: FilePath 15 | } deriving Show 16 | 17 | 18 | 19 | initialLexState :: FilePath -> LexState 20 | initialLexState fp = 21 | LexState 22 | { _lexTokAcc = [] 23 | , _lexRegion = R (P 0 0) (P 0 0) 24 | , _lexStartcode = 0 25 | , _lexCommentDepth = 0 26 | , _lexStringBuf = "" 27 | , _lexFilePath = fp 28 | } 29 | 30 | makeLenses ''LexState 31 | 32 | instance HasLocation LexState where 33 | locOf s = Loc { _locPath = _lexFilePath s, _locReg = _lexRegion s } -------------------------------------------------------------------------------- /report/report.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'report.cabal' generated by 'cabal init'. 3 | -- For further documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: report 6 | version: 0.1.0.0 7 | -- synopsis: 8 | -- description: 9 | -- bug-reports: 10 | license: BSD-3-Clause 11 | license-file: LICENSE 12 | author: Gabriel Anderson 13 | maintainer: gabe4k@gmail.com 14 | -- copyright: 15 | category: Control 16 | extra-source-files: CHANGELOG.md 17 | 18 | library 19 | ghc-options: -Werror -Wall 20 | exposed-modules: Control.Monad.Report 21 | -- other-modules: 22 | -- other-extensions: 23 | build-depends: base ^>=4.12.0.0, 24 | bifunctors, 25 | unbound-generics, 26 | dlist, 27 | mtl 28 | hs-source-dirs: src 29 | default-language: Haskell2010 30 | -------------------------------------------------------------------------------- /language-syntax/language-syntax.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'ttc-util.cabal' generated by 'cabal init'. 3 | -- For further documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: language-syntax 6 | version: 0.1.0.0 7 | -- synopsis: 8 | -- description: 9 | -- bug-reports: 10 | license: BSD-3-Clause 11 | license-file: LICENSE 12 | author: Gabriel Anderson 13 | maintainer: gabe4k@gmail.com 14 | -- copyright: 15 | -- category: 16 | extra-source-files: CHANGELOG.md 17 | 18 | library 19 | ghc-options: -Werror -Wall 20 | exposed-modules: Language.Syntax.Location 21 | -- other-modules: 22 | -- other-extensions: 23 | build-depends: base ^>=4.12.0.0, 24 | microlens-platform, 25 | prettyprinter, 26 | text, 27 | binary 28 | 29 | hs-source-dirs: src/ 30 | default-language: Haskell2010 31 | -------------------------------------------------------------------------------- /ttc/tests/single/5.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern int2str : I32 -> *I8 -> *I8 4 | extern puts : *I8 -> I32 5 | extern malloc : I32 -> *I8 6 | extern free : *I8 -> I8 7 | 8 | type Maybe = Nothing | Just I32 9 | 10 | addMaybe : Maybe -> Maybe -> Maybe 11 | addMaybe ma mb = 12 | case ma of 13 | Nothing -> Nothing 14 | Just a -> 15 | case mb of 16 | Nothing -> Nothing 17 | Just b -> Just (#add a b) 18 | 19 | printMaybe : Maybe -> I32 20 | printMaybe mx = 21 | case mx of 22 | Nothing -> puts "Nothing" 23 | Just x -> printInt x 24 | 25 | printInt : I32 -> I32 26 | printInt x = 27 | let txt = Array[2] : *I8 28 | txt1 = int2str x txt 29 | _ = puts txt1 30 | in 0 31 | 32 | main : I32 -> **I8 -> I32 33 | main argc argv = 34 | let m1 = Just 1 35 | m2 = Just 2 36 | m3 = Just 3 37 | mn = Nothing 38 | _ = printMaybe m3 39 | _ = printMaybe (addMaybe m1 m3) 40 | _ = printMaybe (addMaybe m2 m3) 41 | _ = printMaybe (addMaybe m3 m3) 42 | _ = printMaybe mn 43 | in 0 -------------------------------------------------------------------------------- /ttc/tests/single/4.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern int2str : I32 -> *I8 -> *I8 4 | extern puts : *I8 -> I32 5 | extern malloc : I32 -> *I8 6 | extern free : *I8 -> I8 7 | 8 | type Maybe = Nothing | Just I32 9 | 10 | addMaybe : *Maybe -> *Maybe -> *Maybe 11 | addMaybe ma mb = 12 | case *ma of 13 | Nothing -> new Nothing 14 | Just a -> 15 | case *mb of 16 | Nothing -> new Nothing 17 | Just b -> new Just (#add a b) 18 | 19 | printMaybe : *Maybe -> I32 20 | printMaybe mx = 21 | case *mx of 22 | Nothing -> puts "Nothing" 23 | Just x -> printInt x 24 | 25 | printInt : I32 -> I32 26 | printInt x = 27 | let txt = new Array[2] : *I8 28 | txt1 = int2str x txt 29 | _ = puts txt1 30 | _ = delete txt1 31 | in 0 32 | 33 | main : I32 -> **I8 -> I32 34 | main argc argv = 35 | let m1 = new Just 1 36 | m2 = new Just 2 37 | m3 = new Just 3 38 | mn = new Nothing 39 | _ = printMaybe m3 40 | _ = printMaybe (addMaybe m1 m3) 41 | _ = printMaybe (addMaybe m2 m3) 42 | _ = printMaybe (addMaybe m3 m3) 43 | _ = printMaybe mn 44 | in 0 -------------------------------------------------------------------------------- /lltt/lltt.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'anf.cabal' generated by 'cabal init'. For 3 | -- further documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: lltt 6 | version: 0.1.0.0 7 | -- synopsis: 8 | -- description: 9 | -- bug-reports: 10 | -- license: 11 | license-file: LICENSE 12 | author: Gabriel Anderson 13 | maintainer: gabe4k@gmail.com 14 | -- copyright: 15 | -- category: 16 | extra-source-files: CHANGELOG.md 17 | 18 | library 19 | ghc-options: -Werror -Wall 20 | exposed-modules: Language.LLTT.Infer 21 | Language.LLTT.Lex 22 | Language.LLTT.Namecheck 23 | Language.LLTT.Parse 24 | Language.LLTT.Pretty 25 | Language.LLTT.Syntax 26 | -- other-modules: 27 | -- other-extensions: 28 | build-depends: base ^>=4.12.0.0, 29 | containers, 30 | language-syntax, 31 | prettyprinter, 32 | 33 | hs-source-dirs: src 34 | default-language: Haskell2010 -------------------------------------------------------------------------------- /qtt/qtt.cabal: -------------------------------------------------------------------------------- 1 | -- Initial qtt.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: qtt 5 | version: 0.1.0.0 6 | synopsis: Simple example evaluator for quantitative type theory 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Gabriel Anderson 11 | maintainer: gabe4k@gmail.com 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | executable qtt 19 | main-is: Main.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >=4.11 && <4.12, 23 | containers, 24 | mtl, 25 | semirings, 26 | text, 27 | unbound-generics 28 | other-modules: Check 29 | Check.Monad 30 | Eval 31 | Equal 32 | Syntax 33 | hs-source-dirs: src 34 | default-language: Haskell2010 35 | -------------------------------------------------------------------------------- /ttc/tests/single/11.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern printint : I32 -> I32 4 | extern printstr : *I8 -> I32 5 | 6 | type Either = Left *I8 | Right I32 7 | 8 | printEither : Either -> I32 9 | printEither e = 10 | case e of 11 | Left str -> printstr str 12 | Right i -> printint i 13 | 14 | 15 | addEither : Either -> Either -> Either 16 | addEither e1 e2 = 17 | case e1 of 18 | Left str -> Left str 19 | Right x -> 20 | case e2 of 21 | Left str -> Left str 22 | Right y -> Right (#add x y) 23 | 24 | main : I32 -> **I8 -> I32 25 | main argc argv = 26 | let e1 = Left "" 27 | e2 = Right 10 28 | e3 = Right 14 29 | 30 | _ = printstr "e1 = " 31 | _ = printEither e1 32 | _ = printstr "\n" 33 | 34 | _ = printstr "e2 = " 35 | _ = printEither e2 36 | _ = printstr "\n" 37 | 38 | _ = printstr "e3 = " 39 | _ = printEither e3 40 | _ = printstr "\n" 41 | 42 | _ = printstr "addEither e1 e2 = " 43 | _ = printEither (addEither e1 e2) 44 | _ = printstr "\n" 45 | 46 | _ = printstr "addEither e2 e3 = " 47 | _ = printEither (addEither e2 e3) 48 | _ = printstr "\n" 49 | in 0 -------------------------------------------------------------------------------- /lltt-llvm/lltt-llvm.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'anf-llvm.cabal' generated by 'cabal init'. 3 | -- For further documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: lltt-llvm 6 | version: 0.1.0.0 7 | -- synopsis: 8 | -- description: 9 | -- bug-reports: 10 | -- license: 11 | license-file: LICENSE 12 | author: Gabriel Anderson 13 | maintainer: gabe4k@gmail.com 14 | -- copyright: 15 | -- category: 16 | extra-source-files: CHANGELOG.md 17 | 18 | library 19 | ghc-options: -Werror -Wall 20 | exposed-modules: Language.LLTT.LLVM.Codegen 21 | LLVM.IRBuilder.Extra 22 | -- other-modules: 23 | -- other-extensions: 24 | build-depends: language-syntax, 25 | lltt, 26 | base ^>=4.12.0.0, 27 | bifunctors, 28 | bytestring, 29 | containers, 30 | llvm-hs ==8.0.0, 31 | llvm-hs-pure ==8.0.0, 32 | prettyprinter, 33 | text 34 | hs-source-dirs: src 35 | default-language: Haskell2010 -------------------------------------------------------------------------------- /ttc/rts.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include 5 | 6 | int printstr(uint8_t* str) 7 | { 8 | return printf("%s", str); 9 | } 10 | 11 | int printint(int32_t x) 12 | { 13 | return printf("%d", x); 14 | } 15 | 16 | // /* reverse: reverse string s in place */ 17 | // void reverse(uint8_t s[]) 18 | // { 19 | // int i, j; 20 | // uint8_t c; 21 | 22 | // for (i = 0, j = strlen((char*)s)-1; i 0); /* delete it */ 39 | // if (sign < 0) 40 | // s[i++] = '-'; 41 | // s[i] = '\0'; 42 | 43 | // puts((char*)s); 44 | // reverse(s); 45 | // puts((char*)s); 46 | 47 | // return s; 48 | // } 49 | 50 | char* int2str(int32_t n, char* buff) { 51 | sprintf(buff, "%d", n); 52 | return buff; 53 | } 54 | 55 | -------------------------------------------------------------------------------- /qtt/src/Check/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Check.Monad where 3 | 4 | import Syntax 5 | 6 | import Control.Monad.Reader 7 | import Data.Map (Map) 8 | import qualified Data.Map.Strict as Map 9 | import Data.Text (Text, pack, unpack) 10 | 11 | import Unbound.Generics.LocallyNameless 12 | 13 | type Tc = FreshMT (Reader Env) 14 | 15 | data Env = Env { envDefs :: Map Text Term 16 | , envSigs :: Map Text Type } 17 | 18 | runTc :: Env -> Tc a -> a 19 | runTc env m = runReader (runFreshMT m) env 20 | 21 | insertEnvSig :: Text -> Type -> Env -> Env 22 | insertEnvSig n ty (Env defs sigs) = Env defs (Map.insert n ty sigs) 23 | 24 | lookupTyMaybe :: MonadReader Env m => TName -> m (Maybe Term) 25 | lookupTyMaybe n = do 26 | env <- asks envSigs 27 | return $ Map.lookup (name2Text n) env 28 | 29 | lookupTy :: MonadReader Env m => TName -> m Term 30 | lookupTy n = do 31 | ty_may <- lookupTyMaybe n 32 | case ty_may of 33 | Just ty -> return ty 34 | Nothing -> error "Unexpected name encountered" 35 | 36 | 37 | lookupDef :: MonadReader Env m => TName -> m (Maybe Term) 38 | lookupDef n = 39 | Map.lookup (name2Text n) <$> asks envDefs 40 | 41 | extendEnvSig :: MonadReader Env m => Text -> Type -> m a -> m a 42 | extendEnvSig n ty m = local (insertEnvSig n ty) m -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Lex/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, OverloadedStrings, ViewPatterns #-} 2 | module Language.STLC.Lex.Error where 3 | 4 | import Language.Syntax.Location 5 | import Data.Text.Prettyprint.Doc 6 | 7 | data LexError 8 | = UnrecognizedToken Loc String 9 | | InvalidCharLit Loc String 10 | | InvalidEscapeChar Loc Char 11 | | IllegalLexerSkip Loc 12 | deriving(Show) 13 | 14 | 15 | instance Pretty LexError where 16 | pretty = \case 17 | UnrecognizedToken (pretty -> l) (pretty -> cs) -> 18 | vsep [ line <> l <+> "error:" 19 | , indent 4 $ "Lexer has encountered an unrecognized token: " <+> dquotes cs 20 | ] 21 | 22 | InvalidCharLit (pretty -> l) (pretty -> str) -> 23 | vsep [ line <> l <+> "error:" 24 | , indent 4 $ "Lexer has encountered an invalid literal character:" <+> squotes str 25 | ] 26 | 27 | InvalidEscapeChar (pretty -> l) (pretty -> str) -> 28 | vsep [ line <> l <+> "error:" 29 | , indent 4 $ "Lexer has encountered an invalid literal character:" <+> squotes str 30 | ] 31 | 32 | IllegalLexerSkip (pretty -> l) -> 33 | vsep [ line <> l <+> "error:" 34 | , indent 4 $ "Lexer performed an illegal skip operation." 35 | ] 36 | -------------------------------------------------------------------------------- /ttc/tests/single/8.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern int2str : I32 -> *I8 -> *I8 4 | extern puts : *I8 -> I32 5 | extern malloc : I32 -> *I8 6 | extern free : *I8 -> I8 7 | 8 | type Unit = Unit 9 | type Nat = Zero | Succ *Nat 10 | 11 | int2nat : I32 -> *Nat 12 | int2nat x = 13 | if #eq x 0 then 14 | new Zero 15 | else 16 | new Succ (int2nat (#sub x 1)) 17 | 18 | nat2int : *Nat -> I32 19 | nat2int n = 20 | case *n of 21 | Zero -> 0 22 | Succ n1 -> #add 1 (nat2int n1) 23 | 24 | sumN : *Nat -> *Nat -> *Nat 25 | sumN a b = 26 | case *a of 27 | Zero -> 28 | case *b of 29 | Zero -> new Zero 30 | Succ b1 -> new Succ (sumN a b1) 31 | Succ a1 -> new Succ (sumN a1 b) 32 | 33 | deleteNat : *Nat -> Unit 34 | deleteNat n = 35 | case *n of 36 | Zero -> let _ = delete n in Unit 37 | Succ n1 -> 38 | let _ = delete n in 39 | deleteNat n1 40 | 41 | 42 | printNat : *Nat -> I32 43 | printNat n = printInt (nat2int n) 44 | 45 | printInt : I32 -> I32 46 | printInt x = puts (int2str x (Array[11])) 47 | 48 | main : I32 -> **I8 -> I32 49 | main argc argv = 50 | let x = int2nat 12929 51 | y = int2nat 23232 52 | z = sumN x y 53 | _ = printNat x 54 | _ = printNat y 55 | _ = printNat z 56 | _ = deleteNat x 57 | _ = deleteNat y 58 | _ = deleteNat z 59 | in 0 -------------------------------------------------------------------------------- /systemf/systemf.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'system-f.cabal' generated by 'cabal init'. 3 | -- For further documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: systemf 6 | version: 0.1.0.0 7 | -- synopsis: 8 | -- description: 9 | -- bug-reports: 10 | -- license: 11 | license-file: LICENSE 12 | author: Gabriel Anderson 13 | maintainer: gabe4k@gmail.com 14 | -- copyright: 15 | -- category: 16 | extra-source-files: CHANGELOG.md 17 | 18 | library 19 | ghc-options: -Werror -Wall 20 | exposed-modules: Language.SystemF.CConv 21 | Language.SystemF.Infer 22 | Language.SystemF.Lex 23 | Language.SystemF.Lift 24 | Language.SystemF.Monomorphize 25 | Language.SystemF.Namecheck 26 | Language.SystemF.Parse 27 | Language.SystemF.Partial 28 | Language.SystemF.Pretty 29 | Language.SystemF.Syntax 30 | 31 | -- other-modules: 32 | -- other-extensions: 33 | build-depends: stlc, 34 | language-syntax, 35 | base ^>=4.12.0.0, 36 | prettyprinter, 37 | unbound-generics 38 | hs-source-dirs: src/ 39 | default-language: Haskell2010 -------------------------------------------------------------------------------- /lltt-llvm/src/LLVM/IRBuilder/Extra.hs: -------------------------------------------------------------------------------- 1 | module LLVM.IRBuilder.Extra where 2 | 3 | import Control.Monad 4 | 5 | import LLVM.AST hiding (callingConvention) 6 | import LLVM.AST.CallingConvention 7 | import LLVM.AST.Global 8 | import LLVM.AST.Type 9 | import qualified LLVM.AST.Constant as C 10 | import LLVM.IRBuilder.Module 11 | import LLVM.IRBuilder.Monad 12 | 13 | functionCC 14 | :: MonadModuleBuilder m 15 | => Name -- ^ Function name 16 | -> CallingConvention 17 | -> [(Type, ParameterName)] -- ^ Parameter types and name suggestions 18 | -> Type -- ^ Return type 19 | -> ([Operand] -> IRBuilderT m ()) -- ^ Function body builder 20 | -> m Operand 21 | functionCC label cc argtys retty body = do 22 | let tys = fst <$> argtys 23 | (paramNames, blocks) <- runIRBuilderT emptyIRBuilder $ do 24 | paramNames <- forM argtys $ \(_, paramName) -> case paramName of 25 | NoParameterName -> fresh 26 | ParameterName p -> fresh `named` p 27 | body $ zipWith LocalReference tys paramNames 28 | return paramNames 29 | let 30 | def = GlobalDefinition functionDefaults 31 | { name = label 32 | , callingConvention = cc 33 | , parameters = (zipWith (\ty nm -> Parameter ty nm []) tys paramNames, False) 34 | , returnType = retty 35 | , basicBlocks = blocks 36 | } 37 | funty = ptr $ FunctionType retty (fst <$> argtys) False 38 | emitDefn def 39 | pure $ ConstantOperand $ C.GlobalReference funty label -------------------------------------------------------------------------------- /ttc/tests/single/10.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern free : *I8 -> I8 4 | extern malloc : I32 -> *I8 5 | 6 | extern printint : I32 -> I32 7 | extern printstr : *I8 -> I32 8 | 9 | printints : *I32 -> I32 -> I32 10 | printints xs n = printintsH xs n 0 11 | 12 | printintsH : *I32 -> I32 -> I32 -> I32 13 | printintsH xs n i = 14 | if #eq n i then 0 else 15 | let _ = printint xs[i] 16 | i1 = #add i 1 17 | _ = if #neq n i1 then printstr " " else 0 18 | in printintsH xs n i1 19 | 20 | sumints : *I32 -> I32 -> I32 21 | sumints xs n = sumintsH xs n 0 22 | 23 | sumintsH : *I32 -> I32 -> I32 -> I32 24 | sumintsH xs n acc = 25 | if #eq n 0 then acc else 26 | let n1 = #sub n 1 27 | acc1 = #add acc xs[n1] 28 | in sumintsH xs n1 acc1 29 | 30 | mkArray : I32 -> *I32 31 | mkArray n = mkArrayH n (new Array[32]) 32 | 33 | mkArrayH : I32 -> *I32 -> *I32 34 | mkArrayH i xs = 35 | if #eq i 0 then xs else 36 | let i1 = #sub i 1 37 | _ = xs[i1] := i 38 | in mkArrayH i1 xs 39 | 40 | main : I32 -> **I8 -> I32 41 | main argc argv = 42 | let xs = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] 43 | n = 10 44 | 45 | _ = printstr "xs = " 46 | _ = printints xs n 47 | _ = printstr "\n" 48 | 49 | _ = printstr "sumints xs n = " 50 | _ = printint (sumints xs n) 51 | _ = printstr "\n" 52 | 53 | ys = mkArray 100 54 | _ = printstr "ys = " 55 | _ = printints ys 100 56 | _ = printstr "\n" 57 | _ = delete ys 58 | in 0 -------------------------------------------------------------------------------- /ttc/tests/single/9.stlc: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | extern printstr : *I8 -> I32 4 | extern printint : I32 -> I32 5 | extern malloc : I32 -> *I8 6 | extern free : *I8 -> I8 7 | 8 | type V3 = V3 { x: I32, y: I32, z:I32 } 9 | 10 | printVector : V3 -> I32 11 | printVector v = 12 | let _ = printstr "V { x = " 13 | _ = printint v.x 14 | _ = printstr ", y = " 15 | _ = printint v.y 16 | _ = printstr ", z = " 17 | _ = printint v.z 18 | _ = printstr " }\n" 19 | in 0 20 | 21 | 22 | addVec : V3 -> V3 -> V3 23 | addVec v u = V3 (#add v.x u.x) 24 | (#add v.y u.y) 25 | (#add v.z u.z) 26 | 27 | add3 : I32 -> I32 -> I32 -> I32 28 | add3 x y z = #add (#add x y) z 29 | 30 | dot : V3 -> V3 -> I32 31 | dot v u = add3 (#mul v.x u.x) (#mul v.y u.y) (#mul v.z u.z) 32 | 33 | cross : V3 -> V3 -> V3 34 | cross v u = V3 (#sub (#mul v.y u.z) (#mul v.z u.y)) 35 | (#sub (#mul v.z u.x) (#mul v.x u.z)) 36 | (#sub (#mul v.x u.y) (#mul v.y u.x)) 37 | 38 | main : I32 -> **I8 -> I32 39 | main argc argv = 40 | let v1 = V3 1 2 3 41 | v2 = V3 4 5 6 42 | _ = printstr "v1 = " 43 | _ = printVector v1 44 | 45 | _ = printstr "v2 = " 46 | _ = printVector v2 47 | 48 | _ = printstr "add v1 v2 = " 49 | _ = printVector (addVec v1 v2) 50 | 51 | _ = printstr "dot v1 v2 = " 52 | _ = printint (dot v1 v2) 53 | _ = printstr "\n" 54 | 55 | _ = printstr "cross v1 v2 = " 56 | _ = printVector (cross v1 v2) 57 | in 0 -------------------------------------------------------------------------------- /lltt/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Gabriel Anderson 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 Gabriel Anderson 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 | -------------------------------------------------------------------------------- /qtt/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Gabriel Anderson 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 Gabriel Anderson 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 | -------------------------------------------------------------------------------- /stlc/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Gabriel Anderson 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 Gabriel Anderson 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 | -------------------------------------------------------------------------------- /ttc/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Gabriel Anderson 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 Gabriel Anderson 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 | -------------------------------------------------------------------------------- /report/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Gabriel Anderson 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 Gabriel Anderson 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 | -------------------------------------------------------------------------------- /language-syntax/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Gabriel Anderson 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 Gabriel Anderson 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 | -------------------------------------------------------------------------------- /language-module-system/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Gabriel Anderson 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 Gabriel Anderson 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 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { hostpkgs ? import {} }: 2 | let 3 | nixos_pkgs = hostpkgs.fetchFromGitHub { 4 | owner = "NixOS"; 5 | repo = "nixpkgs-channels"; 6 | rev = "nixos-19.03"; 7 | sha256 = "1ysggrw89p4j6w0sq9i27f2vi7kq9pjbk2f0hbx1ch6lyjh5klab"; 8 | }; 9 | 10 | nixos_unstable_pkgs = hostpkgs.fetchFromGitHub { 11 | owner = "NixOS"; 12 | repo = "nixpkgs-channels"; 13 | rev = "nixos-unstable"; 14 | sha256 = "1lvz85yc7s0yzix3hbcl9m8ahps1jdr9v2sbyq0phfawwjbgswyd"; 15 | }; 16 | 17 | darwin_pkgs18 = hostpkgs.fetchFromGitHub { 18 | owner = "NixOS"; 19 | repo = "nixpkgs-channels"; 20 | rev = "nixpkgs-18.03-darwin"; 21 | sha256 = "12f7aiwajvxcpi351yh6yg9l30xivn44k6rj5lk558q0gmc5j0p1"; 22 | }; 23 | 24 | darwin_pkgs = hostpkgs.fetchFromGitHub { 25 | owner = "NixOS"; 26 | repo = "nixpkgs-channels"; 27 | rev = "nixpkgs-19.03-darwin"; 28 | sha256 = "01va89pqny7jh9iic3f6dmywpc5m4gf6v106fsgysg50ghkg1gbb"; 29 | }; 30 | 31 | darwin_unstable_pkgs = hostpkgs.fetchFromGitHub { 32 | owner = "NixOS"; 33 | repo = "nixpkgs-channels"; 34 | rev = "nixpkgs-unstable"; 35 | sha256 = "01pfzhghkpsmbr0v1754gjzdlk5fgs6v1vwmplnh87vjjm6xka1n"; 36 | }; 37 | 38 | pkgs18 = import darwin_pkgs18 {}; 39 | 40 | pkgs = if hostpkgs.stdenv.isDarwin 41 | then import darwin_pkgs {} 42 | else import nixos_pkgs {}; 43 | 44 | upkgs = if hostpkgs.stdenv.isDarwin 45 | then import darwin_unstable_pkgs {} 46 | else import nixos_unstable_pkgs {}; 47 | 48 | nixPackages = [ 49 | pkgs.ghc 50 | pkgs.cabal-install 51 | pkgs.less 52 | pkgs.git 53 | pkgs.gcc 54 | upkgs.llvm_8 55 | upkgs.clang_7 56 | pkgs.gdb 57 | pkgs.haskellPackages.happy 58 | ]; 59 | in 60 | pkgs.stdenv.mkDerivation { 61 | name = "ttc"; 62 | buildInputs = nixPackages; 63 | } -------------------------------------------------------------------------------- /ttc/ttc.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'ttc.cabal' generated by 'cabal init'. For 3 | -- further documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: ttc 6 | version: 0.1.0.0 7 | -- synopsis: 8 | -- description: 9 | -- bug-reports: 10 | license: BSD-3-Clause 11 | license-file: LICENSE 12 | author: Gabriel Anderson 13 | maintainer: gabe4k@gmail.com 14 | -- copyright: 15 | -- category: 16 | build-type: Simple 17 | extra-source-files: CHANGELOG.md 18 | 19 | executable ttc 20 | ghc-options: -Werror -Wall 21 | main-is: Main.hs 22 | other-modules: Compiler 23 | -- other-extensions: 24 | build-depends: language-syntax, 25 | lltt, 26 | lltt-llvm, 27 | stlc, 28 | base ^>=4.12.0.0, 29 | containers, 30 | directory, 31 | filepath, 32 | llvm-hs, 33 | llvm-hs-pure, 34 | mtl, 35 | optparse-applicative, 36 | prettyprinter, 37 | process, 38 | unbound-generics, 39 | text 40 | 41 | hs-source-dirs: app/ 42 | default-language: Haskell2010 43 | 44 | test-suite ttc-golden 45 | ghc-options: -Werror -Wall 46 | hs-source-dirs: tests 47 | main-is: Test.hs 48 | default-language: Haskell2010 49 | type: exitcode-stdio-1.0 50 | build-depends: base ^>=4.12.0.0, 51 | directory, 52 | filepath, 53 | process, 54 | tasty, 55 | tasty-golden -------------------------------------------------------------------------------- /stlc/stlc.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'stlc.cabal' generated by 'cabal init'. For 3 | -- further documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: stlc 6 | version: 0.1.0.0 7 | -- synopsis: 8 | -- description: 9 | -- bug-reports: 10 | license: BSD-3-Clause 11 | license-file: LICENSE 12 | author: Gabriel Anderson 13 | maintainer: gabe4k@gmail.com 14 | -- copyright: 15 | -- category: 16 | extra-source-files: CHANGELOG.md 17 | src/Language/STLC/Lex.x 18 | src/Language/STLC/Parse.y 19 | 20 | library 21 | ghc-options: -Werror -Wall 22 | exposed-modules: Language.STLC.CConv 23 | Language.STLC.Desugar 24 | Language.STLC.Lex 25 | Language.STLC.Lex.Error 26 | Language.STLC.Lex.Format 27 | Language.STLC.Lex.State 28 | Language.STLC.Lex.Token 29 | Language.STLC.Lift 30 | Language.STLC.Match 31 | Language.STLC.Namecheck 32 | Language.STLC.Parse 33 | Language.STLC.Parse.Error 34 | Language.STLC.Partial 35 | Language.STLC.Pretty 36 | Language.STLC.Reduce 37 | Language.STLC.Syntax 38 | Language.STLC.TypeCheck 39 | -- other-modules: 40 | -- other-extensions: 41 | build-depends: language-module-system, 42 | language-syntax, 43 | lltt, 44 | array, 45 | base ^>=4.12.0.0, 46 | binary, 47 | containers, 48 | dlist, 49 | extra, 50 | filepath, 51 | microlens-platform, 52 | mtl, 53 | prettyprinter, 54 | report, 55 | safe, 56 | text, 57 | unbound-generics, 58 | writer-cps-mtl 59 | 60 | build-tools: 61 | alex ==3.2.4, happy==1.19.9 62 | 63 | hs-source-dirs: src 64 | default-language: Haskell2010 65 | -------------------------------------------------------------------------------- /qtt/src/Equal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, ViewPatterns #-} 2 | module Equal where 3 | 4 | import Syntax 5 | import Check.Monad 6 | 7 | import Unbound.Generics.LocallyNameless 8 | 9 | equate :: Term -> Term -> Tc () 10 | equate t1 t2 = if (aeq t1 t2) then return () else do 11 | n1 <- whnf' False t1 12 | n2 <- whnf' False t2 13 | case (n1, n2) of 14 | (TType, TType) -> return () 15 | 16 | (TVar x, TVar y) | x == y -> return () 17 | 18 | (TLam r1 bnd1, TLam r2 bnd2) -> do 19 | Just (_, b1, _, b2) <- unbind2 bnd1 bnd2 20 | equate b1 b2 21 | 22 | (TApp a1 a2, TApp b1 b2) -> do 23 | equate a1 b1 24 | equate a2 b2 25 | 26 | (TPi r1 bnd1, TPi r2 bnd2) -> do 27 | Just ((_, unembed -> tyA1), tyB1, 28 | (_, unembed -> tyA2), tyB2) <- unbind2 bnd1 bnd2 29 | equate tyA1 tyA2 30 | equate tyB1 tyB2 31 | 32 | -- Missing some cases... 33 | 34 | _ -> error $ "Type mismatch\nT1: " ++ show n1 ++ "\nT2: " ++ show n2 35 | 36 | 37 | -- | Ensure that the given type 'ty' is a 'Pi' type 38 | -- (or could be normalized to be such) and return the components of 39 | -- the type. 40 | -- Throws an error if this is not the case. 41 | ensurePi :: Type -> Tc (TName, Type, Type) 42 | ensurePi ty = do 43 | nf <- whnf ty 44 | case nf of 45 | (TPi _ bnd) -> do 46 | ((x, unembed -> tyA), tyB) <- unbind bnd 47 | return (x, tyA, tyB) 48 | 49 | _ -> error $ "Expected a function type, instead found " ++ show nf 50 | 51 | 52 | whnf :: Term -> Tc Term 53 | whnf = whnf' False 54 | 55 | whnf' :: Bool -> Term -> Tc Term 56 | whnf' b = \case 57 | TVar n -> do 58 | defn_may <- lookupDef n 59 | case defn_may of 60 | Just d -> whnf' b d 61 | Nothing 62 | | b -> error "records not implemented, can't lookup record" 63 | | True -> return (TVar n) 64 | 65 | TApp t1 t2 -> do 66 | nf <- whnf' b t1 67 | case nf of 68 | TLam _ bnd -> do 69 | ((x, _), body) <- unbind bnd 70 | whnf' b (subst x t2 body) 71 | 72 | TVar y -> do 73 | nf2 <- whnf' b t2 74 | maybeDef <- lookupDef y -- should be lookupRecDef 75 | case maybeDef of 76 | Just d -> whnf' False $ TApp d nf2 77 | _ -> return $ TApp nf nf2 78 | 79 | _ -> return $ TApp nf t2 80 | 81 | -- Missing some cases... 82 | 83 | tm -> return tm -------------------------------------------------------------------------------- /qtt/src/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, FlexibleContexts, RankNTypes #-} 2 | module Eval where 3 | 4 | import Syntax 5 | 6 | import Unbound.Generics.LocallyNameless 7 | 8 | import Control.Monad.Reader 9 | import Data.Map (Map) 10 | import qualified Data.Map.Strict as Map 11 | import Data.Text (Text) 12 | 13 | 14 | type Eval = FreshMT (Reader Env) 15 | data Env = Env { envTerms :: Map Text Value } 16 | 17 | insertEnv :: Text -> Value -> Env -> Env 18 | insertEnv n v (Env ts) = Env (Map.insert n v ts) 19 | 20 | runEval :: Eval a -> Env -> a 21 | runEval m env = runReader (runFreshMT m) env 22 | 23 | lookupEnv :: MonadReader Env m => Text -> m (Maybe Value) 24 | lookupEnv n = (Map.lookup n . envTerms) <$> ask 25 | 26 | localEnv :: MonadReader Env m => Text -> Value -> m a -> m a 27 | localEnv n v m = local (insertEnv n v) m 28 | 29 | eval :: Term -> Eval Value 30 | eval = \case 31 | TType -> return VType 32 | TUnit -> return VUnit 33 | TAnnot t _ -> eval t 34 | 35 | TVar n -> do 36 | may_v <- lookupEnv (name2Text n) 37 | case may_v of 38 | Nothing -> error "Name not found" 39 | Just v -> return v 40 | 41 | TPi _ bnd -> return $ VPi bnd 42 | TLam _ bnd -> return $ VLam bnd 43 | 44 | TApp f x -> do 45 | fv <- eval f 46 | xv <- eval x 47 | case fv of 48 | VLam bnd -> do 49 | ((v, _), body) <- unbind bnd 50 | eval (subst v x body) 51 | _ -> error "Can't apply a non-function" 52 | 53 | TProd _ bnd -> return $ VProd bnd 54 | TPair a b -> 55 | VPair <$> eval a <*> eval b 56 | 57 | TFst p -> do 58 | v <- eval p 59 | case v of 60 | VPair a b -> return a 61 | _ -> error "Cannot call first on non-pair" 62 | 63 | TSnd p -> do 64 | v <- eval p 65 | case v of 66 | VPair _ b -> return b 67 | _ -> error "Cannot call second on non-pair" 68 | 69 | 70 | TLet bnd -> do 71 | ((v1, v2, Embed rhs), body) <- unbind bnd 72 | rhs' <- eval rhs 73 | case rhs' of 74 | VPair a b -> localEnv (name2Text v1) a 75 | $ localEnv (name2Text v2) b 76 | $ eval body 77 | _ -> error "Expected a pair!" 78 | 79 | 80 | TSeq t1 t2 -> 81 | let t1' = eval t1 in t1' `seq` eval t2 82 | 83 | TBool -> return VType 84 | TTrue -> return $ VBool True 85 | TFalse -> return $ VBool False 86 | TIf pt elimT elimF -> do 87 | pv <- eval pt 88 | case pv of 89 | VBool p -> eval (if p then elimT else elimF) 90 | _ -> error "Expected a boolean value as the predicate" 91 | 92 | -------------------------------------------------------------------------------- /qtt/src/Check.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, ViewPatterns, FlexibleContexts #-} 2 | module Check where 3 | 4 | import Syntax 5 | import Equal 6 | import Check.Monad 7 | 8 | import Unbound.Generics.LocallyNameless 9 | 10 | 11 | -- | Infer the type of a term, producing an annotated version of the 12 | -- term (whose type can *always* be inferred). 13 | inferType :: Term -> Tc (Term,Type) 14 | inferType t = tcTerm (t, Nothing) 15 | 16 | checkType :: Term -> Type -> Tc (Term, Type) 17 | checkType tm tyx = do 18 | nf <- whnf tyx 19 | tcTerm (tm, Just nf) 20 | 21 | 22 | -- | Make sure that the term is a type (i.e. has type 'Type') 23 | tcType :: Term -> Tc Term 24 | tcType t = fst <$> checkType t TType 25 | 26 | 27 | tcTerm :: (Term, Maybe Type) -> Tc (Term, Type) 28 | tcTerm = \case 29 | (t@TType, Nothing) -> return (t, TType) 30 | (t@TUnit, Nothing) -> return (t, TType) 31 | 32 | (t@(TVar n), Nothing) -> do 33 | ty <- lookupTy n 34 | return (t, ty) 35 | 36 | (TPi r bnd, Nothing) -> do 37 | ((n, unembed -> t1), t2) <- unbind bnd 38 | t1' <- tcType t1 39 | t2' <- extendEnvSig (name2Text n) t1' $ tcType t2 40 | return (TPi r (bind (n, embed t1') t2'), TType) 41 | 42 | (TLam r1 bnd1, Just (TPi r2 bnd2)) -> do 43 | Just ((x, unembed -> mt), body, (y, unembed -> t1), t2) <- unbind2 bnd1 bnd2 44 | maybe (return ()) (equate t1) mt 45 | (body', t2') <- extendEnvSig (name2Text x) t1 $ checkType body t2 46 | return (TLam r1 (bind (x, embed mt) body'), TPi r2 (bind (y, embed t1) t2')) 47 | 48 | (TLam _ _, Just _) -> error "Lambda expression without function type encountered" 49 | 50 | (TLam r bnd, Nothing) -> do 51 | ((x, unembed -> mt), body) <- unbind bnd 52 | t1 <- maybe (error "Must annotate lambda") return mt 53 | -- Check type annotation is well-formed 54 | t1' <- tcType t1 55 | -- Infer the type of the body of the lambda expression 56 | (body', t2') <- extendEnvSig (name2Text x) t1' $ inferType body 57 | return (TLam r (bind (x, embed $ Just t1') body'), 58 | TPi r (bind (x, embed t1') t2')) 59 | 60 | (TApp t1 t2, Nothing) -> do 61 | (t1', ty1) <- inferType t1 62 | (x, tyA, tyB) <- ensurePi ty1 63 | (t2', ty2) <- checkType t2 tyA 64 | return (TApp t1' t2', subst x t2' tyB) 65 | 66 | (TUnit, Nothing) -> return (TUnit, TType) 67 | 68 | (tm, Just ty) -> do 69 | (tm', ty') <- inferType tm 70 | equate ty ty' 71 | return (tm', ty) 72 | 73 | _ -> error "Unfinished type checking behaviour encountered!" 74 | 75 | inferTerm :: Term -> Tc Term 76 | inferTerm = \case 77 | TVar n -> undefined 78 | _ -> error "Unfinished type inference" 79 | 80 | 81 | checkUsage :: (String -> Usage) -> Type -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Lex/Token.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings 2 | , TemplateHaskell 3 | , DeriveGeneric 4 | , TypeFamilies 5 | , FlexibleInstances 6 | , BangPatterns 7 | , DeriveDataTypeable 8 | #-} 9 | module Language.STLC.Lex.Token where 10 | 11 | import Language.Syntax.Location 12 | 13 | import Lens.Micro.Platform 14 | import Data.Data 15 | import GHC.Generics (Generic) 16 | 17 | import Data.Text (Text, pack) 18 | import Data.Text.Prettyprint.Doc 19 | 20 | -- ----------------------------------------------------------------------------- 21 | -- Token Types 22 | 23 | -- | A `Token` augmented with `Region` information 24 | data Token = Token 25 | { _tokClass :: !TokenClass 26 | , _tokText :: !Text 27 | , _tokLoc :: !Loc 28 | } deriving (Eq, Show, Ord, Data, Typeable, Generic) 29 | 30 | -- The token type: 31 | data TokenClass 32 | = TokenRsvp Text 33 | | TokenVarId Text 34 | | TokenConId Text 35 | | TokenPrimId Text 36 | 37 | | TokenInteger Integer 38 | | TokenDouble Double 39 | | TokenChar Char 40 | | TokenString String 41 | | TokenBool Bool 42 | 43 | | TokenLn 44 | | TokenLn' 45 | | TokenBlk 46 | | TokenBlk' 47 | | TokenEof 48 | deriving (Eq, Show, Ord, Data, Typeable, Generic) 49 | 50 | 51 | makeLenses ''Token 52 | 53 | instance HasLocation Token where 54 | locOf = _tokLoc 55 | 56 | 57 | -- ----------------------------------------------------------------------------- 58 | -- Extraction 59 | 60 | extractId :: Token -> L Text 61 | extractId (Token c _ l) = case c of 62 | TokenVarId n -> L n l 63 | TokenConId n -> L n l 64 | _ -> error "unexpected token" 65 | 66 | 67 | extractInteger :: Token -> L Integer 68 | extractInteger (Token (TokenInteger v) _ l) = L v l 69 | extractInteger _ = error "unexpected token" 70 | 71 | extractDouble :: Token -> L Double 72 | extractDouble (Token (TokenDouble v) _ l) = L v l 73 | extractDouble _ = error "unexpected token" 74 | 75 | extractChar :: Token -> L Char 76 | extractChar (Token (TokenChar v) _ l) = L v l 77 | extractChar _ = error "unexpected token" 78 | 79 | extractString :: Token -> L String 80 | extractString (Token (TokenString v) _ l) = L v l 81 | extractString _ = error "unexpected token" 82 | 83 | extractBool :: Token -> L Bool 84 | extractBool (Token (TokenBool v) _ l) = L v l 85 | extractBool _ = error "unexpected token" 86 | 87 | 88 | -- ----------------------------------------------------------------------------- 89 | -- Pretty Instances 90 | 91 | instance Pretty Token where 92 | pretty t = 93 | dquotes (pretty (t^.tokText)) 94 | <+> parens (pretty (t^.tokClass)) 95 | <+> "@" 96 | <> pretty (t^.tokLoc) 97 | 98 | instance Pretty TokenClass where 99 | pretty tc = 100 | pretty (pack . show $ tc) -------------------------------------------------------------------------------- /qtt/src/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, 2 | FlexibleInstances, 3 | MultiParamTypeClasses, 4 | FlexibleContexts, 5 | DeriveGeneric, 6 | DeriveDataTypeable 7 | #-} 8 | module Syntax where 9 | 10 | import Data.Semiring 11 | import Data.Text (Text, pack) 12 | import Data.Typeable (Typeable) 13 | import GHC.Generics (Generic) 14 | import Unbound.Generics.LocallyNameless 15 | 16 | data R 17 | = RZero 18 | | ROne 19 | | RMany 20 | deriving (Show, Generic, Typeable) 21 | 22 | instance Semiring R where 23 | plus RZero RZero = RZero 24 | plus RZero ROne = ROne 25 | plus RZero RMany = RMany 26 | plus ROne RZero = ROne 27 | plus ROne ROne = RMany 28 | plus ROne RMany = RMany 29 | plus RMany RZero = RMany 30 | plus RMany ROne = RMany 31 | plus RMany RMany = RMany 32 | 33 | times RZero RZero = RZero 34 | times RZero ROne = RZero 35 | times RZero RMany = RZero 36 | times ROne RZero = RZero 37 | times ROne ROne = ROne 38 | times ROne RMany = RMany 39 | times RMany RZero = RZero 40 | times RMany ROne = RMany 41 | times RMany RMany = RMany 42 | 43 | zero = RZero 44 | one = ROne 45 | 46 | fromNatural n 47 | | n == 0 = RZero 48 | | n == 1 = ROne 49 | | True = RMany 50 | 51 | 52 | 53 | type TName = Name Term 54 | type CName = String 55 | 56 | name2Text :: Name a -> Text 57 | name2Text = pack . name2String 58 | 59 | data Context = Map Text (R, Type) 60 | 61 | type Type = Term 62 | 63 | data Term 64 | = TType 65 | | TUnit 66 | | TAnnot Term Type 67 | 68 | | TVar TName 69 | | TPi R (Bind (TName, Embed Type) Type) 70 | 71 | | TLam R (Bind (TName, Embed (Maybe Type)) Term) 72 | | TApp Term Term 73 | 74 | | TProd R (Bind (TName, Embed Type) Type) 75 | | TPair Term Term 76 | | TFst Term 77 | | TSnd Term 78 | 79 | | TLet (Bind (TName, TName, Embed Term) Term) 80 | | TSeq Term Term 81 | 82 | | TBool 83 | | TTrue 84 | | TFalse 85 | | TIf Term Term Term 86 | 87 | | TCon CName 88 | | TNew CName 89 | | TFree Term 90 | deriving (Show, Generic, Typeable) 91 | 92 | 93 | data Value 94 | = VUnit 95 | | VType 96 | | VInt Integer 97 | | VChar Char 98 | | VString String 99 | | VCon CName [Value] 100 | | VBool Bool 101 | | VBoolType 102 | | VProd (Bind (TName, Embed Type) Type) 103 | | VPair Value Value 104 | | VLam (Bind (TName, Embed (Maybe Type)) Term) 105 | | VPi (Bind (TName, Embed Type) Type) 106 | deriving (Show, Generic, Typeable) 107 | 108 | ------------------------------------------------------- 109 | -- Instances for substitution and alpha equality 110 | ------------------------------------------------------- 111 | 112 | instance Alpha R 113 | instance Alpha Term 114 | instance Alpha Value 115 | 116 | instance Subst Term R 117 | instance Subst Term Value 118 | instance Subst Term Term where 119 | isvar (TVar v) = Just (SubstName v) 120 | isvar _ = Nothing -------------------------------------------------------------------------------- /ttc/tests/Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Data.List 5 | 6 | import Test.Tasty (defaultMain, TestTree, testGroup) 7 | import Test.Tasty.Golden (goldenVsFile, findByExtension) 8 | 9 | import System.Directory (listDirectory, removeDirectoryRecursive, createDirectoryIfMissing, doesDirectoryExist) 10 | import System.FilePath (takeBaseName, replaceExtension, ()) 11 | import System.Process (callCommand) 12 | 13 | 14 | main :: IO () 15 | main = defaultMain =<< goldenTests 16 | 17 | ifM :: Monad m => m Bool -> m () -> m () 18 | ifM mp mt = do 19 | p <- mp 20 | if p then mt else return () 21 | 22 | removeOldTests :: IO () 23 | removeOldTests = do 24 | ifM (doesDirectoryExist "tests/out") 25 | (removeDirectoryRecursive "tests/out") 26 | ifM (doesDirectoryExist "tests/build") 27 | (removeDirectoryRecursive "tests/build") 28 | ifM (doesDirectoryExist "tests/bin") 29 | (removeDirectoryRecursive "tests/bin") 30 | 31 | goldenTests :: IO TestTree 32 | goldenTests = do 33 | removeOldTests 34 | singleFileTests <- goldenTestSingle 35 | multiFileTests <- mempty -- goldenTestMulti 36 | return $ testGroup "TTC Golden Tests" (singleFileTests <> multiFileTests) 37 | 38 | goldenTestSingle :: IO [TestTree] 39 | goldenTestSingle = do 40 | let testsDir = "tests/single" 41 | outDir = "tests/out/single" 42 | binDir = "tests/bin/single" 43 | srcPaths <- findByExtension [".stlc"] testsDir 44 | createDirectoryIfMissing True outDir 45 | createDirectoryIfMissing True binDir 46 | 47 | return $ 48 | [ goldenVsFile 49 | ("Golden Test " ++ takeBaseName srcPath ++ " (Single-File)") 50 | goldPath 51 | outPath 52 | (compileFile srcPath outPath) 53 | | srcPath <- srcPaths 54 | , let outPath = outDir takeBaseName srcPath <> ".out" 55 | goldPath = replaceExtension srcPath "gold" 56 | ] 57 | 58 | 59 | goldenTestMulti :: IO [TestTree] 60 | goldenTestMulti = do 61 | let testsDir = "tests/multi" 62 | outDir = "tests/out/multi" 63 | binDir = "tests/bin/multi" 64 | srcDirs <- filterM doesDirectoryExist . map (testsDir ) =<< listDirectory testsDir 65 | createDirectoryIfMissing True outDir 66 | createDirectoryIfMissing True binDir 67 | return $ 68 | [ goldenVsFile 69 | ("Golden Test " ++ takeBaseName srcDir ++ " (Multi-File)") 70 | goldPath 71 | outPath 72 | (compileDir srcDir outPath) 73 | | srcDir <- srcDirs 74 | , let outPath = outDir takeBaseName srcDir <> ".out" 75 | goldPath = replaceExtension srcDir ".gold" 76 | ] 77 | 78 | 79 | compileFile :: FilePath -> FilePath -> IO () 80 | compileFile srcPath outPath = do 81 | let exePath = "tests/bin/single/" <> takeBaseName srcPath 82 | let buildPath = "tests/build/single/" <> takeBaseName srcPath <> "/" 83 | callCommand $ "cabal new-run ttc -- +RTS -xc -RTS " 84 | ++ srcPath ++ " -o " ++ exePath 85 | ++ " --build-dir " ++ buildPath 86 | callCommand $ exePath ++ " > " ++ outPath 87 | 88 | compileDir :: FilePath -> FilePath -> IO () 89 | compileDir srcDir outPath = do 90 | let exePath = "tests/bin/multi/" <> takeBaseName srcDir 91 | srcPaths <- findByExtension [".stlc"] srcDir 92 | callCommand $ "cabal new-run ttc -- " ++ intercalate " " srcPaths ++ " -o " ++ exePath 93 | callCommand $ exePath ++ " > " ++ outPath -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Type Theory Compiler 2 | 3 | ## About 4 | 5 | This compiler can lower a type theoretic lambda calculus into efficient LLVM IR code. 6 | Each expression is strictly evaluated, and functions are call-by-value. 7 | The languages provide primitives for pointers, arrays, and c-strings. It even includes 8 | stack and heap managment, and allows for mutation and unchecked side-effects. 9 | These are dangerous, but the theories provided are intented as compiler targets 10 | for more advanced theories, which can type-check on usages and side-effects. 11 | So far, the theories provided are Simply-Typed Lambda Calculus (STLC) and SystemF. 12 | 13 | This code is in active development, and many features are unimplemented. 14 | In the future, we hope to have a dependent type theory of some kind, 15 | which is capable of checking resource usage. The current candidate theory 16 | is Quantitative Type Theory (QTT). 17 | Another subject of interest is laziness. We may look into an alternate 18 | backend which will compile to lazy, garbage collected code. 19 | Linear languages may also be a possible future target. 20 | Currently, it's not clear how languages should interact. 21 | 22 | 23 | ## Requirements 24 | 25 | You will need llvm-8 and the latest ghc/cabal for compiling haskell. 26 | Also, you should run `cabal update` to ensure you have the freshest 27 | set of packages for haskell. 28 | 29 | ## Running tests 30 | 31 | To run tests, run the command `cabal new-test ttc-golden`. 32 | 33 | ## Building files 34 | 35 | Currently, only `.stlc` files are supported. To build files, 36 | use the command: 37 | ``` 38 | cabal new-run ttc -- [-o outfile] infile.. 39 | ``` 40 | If the build succeeds, you may execute the outfile. 41 | The default outfile is `a.out`. 42 | 43 | ## Languages 44 | 45 | We have a family of languages: 46 | - LLTT: Low Level Type Theory, a calculus that easily compiles to llvm ir code. 47 | - STLC: Simply Type Lambda Calculus 48 | - SystemF: STLC + type variables and polymorphism 49 | 50 | 51 | ## Useful Links 52 | 53 | Some links to help with development 54 | 55 | ### Parsing 56 | https://www.haskell.org/alex/doc/html/index.html 57 | 58 | https://www.haskell.org/happy/doc/html/index.html (anyone have a link for v1.19 docs?) 59 | 60 | https://github.com/harpocrates/language-rust/blob/0e02e21c389cb56c77f71b902288b195ed273af6/src/Language/Rust/Parser/Internal.y#L74 61 | 62 | 63 | ### Pattern Matching Compiler 64 | http://l-lang.org/blog/Compiling-pattern-matching/ 65 | 66 | 67 | ### LLVM 68 | http://hackage.haskell.org/package/llvm-hs 69 | 70 | http://hackage.haskell.org/package/llvm-hs-pure 71 | 72 | https://mapping-high-level-constructs-to-llvm-ir.readthedocs.io/en/latest/README.html 73 | 74 | 75 | ### Destination-Passing Style 76 | https://www.microsoft.com/en-us/research/wp-content/uploads/2016/11/dps-fhpc17.pdf 77 | 78 | 79 | ### Monomorphization 80 | https://reasonablypolymorphic.com/blog/algorithmic-sytc/ 81 | 82 | 83 | ### Arbitrary Rank Polymorphic Type Checking 84 | https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/putting.pdf 85 | 86 | https://github.com/namin/higher-rank 87 | 88 | https://github.com/garyb/infer-rank-n-types 89 | 90 | 91 | ### Bidirectional Type Checking 92 | https://www.cl.cam.ac.uk/~nk480/bidir.pdf 93 | 94 | https://github.com/ollef/Bidirectional 95 | 96 | http://davidchristiansen.dk/tutorials/bidirectional.pdf 97 | 98 | https://github.com/sweirich/pi-forall 99 | 100 | 101 | ### Tridirectional Type Checking 102 | https://www.cs.cmu.edu/~fp/papers/popl04.pdf 103 | 104 | 105 | ### Quantitative Type Theory 106 | https://github.com/LightAndLight/qtt -------------------------------------------------------------------------------- /systemf/src/Language/SystemF/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE LambdaCase, 3 | FlexibleInstances, 4 | MultiParamTypeClasses, 5 | FlexibleContexts, 6 | DeriveGeneric, 7 | DeriveDataTypeable 8 | #-} 9 | module Language.SystemF.Syntax where 10 | 11 | import Language.Syntax.Location 12 | 13 | import Data.Typeable (Typeable) 14 | import GHC.Generics (Generic) 15 | import Unbound.Generics.LocallyNameless 16 | 17 | -- SystemF, The Polymorphic Lambda Calculus 18 | -- Invariants: Type checked 19 | 20 | type Var = Name Exp 21 | 22 | data Module = Module String [Func] 23 | 24 | data Func = Func Type (Rebind Var (Bind [Pat] Exp)) 25 | deriving (Show, Generic, Typeable) 26 | 27 | 28 | data Exp 29 | = EVar Var 30 | | EApp Exp [Exp] 31 | | EType Exp Type 32 | | ECast Exp Type 33 | | ELoc Exp Loc 34 | | EParens Exp 35 | | ELam (Bind [Pat] Exp) 36 | | ELet (Bind LetBind Exp) 37 | | ECase Exp [Clause] 38 | | ECon String [Exp] 39 | | EInt Int 40 | | ENewCon String [Exp] 41 | | EFree Exp 42 | deriving (Show, Generic, Typeable) 43 | 44 | 45 | 46 | ----------------------------------------------------------------- 47 | -- Literals 48 | ----------------------------------------------------------------- 49 | 50 | -- Literals 51 | data Lit 52 | = LNull 53 | | LInt Int 54 | | LDouble Double 55 | | LBool Bool 56 | | LChar Char 57 | | LString String 58 | | LStringI Int 59 | | LArray [Exp] 60 | | LArrayI Int 61 | | LGetI Exp Int 62 | deriving (Show, Generic, Typeable) 63 | 64 | 65 | ----------------------------------------------------------------- 66 | -- Expression Extras 67 | ----------------------------------------------------------------- 68 | 69 | data LetBind 70 | = LetEmpty 71 | | LetVars (Rebind (Pat, Embed Exp) LetBind) 72 | | LetFunc (Rebind (Var, Embed (Bind [Var] Exp)) LetBind) 73 | deriving (Show, Generic, Typeable) 74 | 75 | data Clause = Clause (Bind Pat Exp) 76 | deriving (Show, Generic, Typeable) 77 | 78 | ----------------------------------------------------------------- 79 | -- Patterns 80 | ----------------------------------------------------------------- 81 | 82 | data Pat 83 | = PVar Var 84 | | PCon String [Pat] 85 | | PWild 86 | | PType Pat Type 87 | deriving (Show, Generic, Typeable) 88 | 89 | ----------------------------------------------------------------- 90 | -- Types 91 | ----------------------------------------------------------------- 92 | 93 | type TVar = Name Type 94 | data Type 95 | = TUnit 96 | | TVar TVar 97 | | TArr Type Type 98 | | TCon String 99 | | TI8 100 | | TI32 101 | | TChar 102 | | TArray Int Type 103 | | TPtr Type 104 | | TString 105 | | TVoid 106 | deriving (Show, Generic, Typeable) 107 | 108 | 109 | instance Alpha Type 110 | instance Alpha Exp 111 | instance Alpha Lit 112 | instance Alpha Pat 113 | instance Alpha Clause 114 | instance Alpha LetBind 115 | instance Alpha Loc 116 | instance Alpha Region 117 | instance Alpha Position 118 | 119 | instance Subst Type Loc 120 | instance Subst Type Region 121 | instance Subst Type Position 122 | instance Subst Type Clause 123 | instance Subst Type LetBind 124 | instance Subst Type Pat 125 | instance Subst Type Lit 126 | instance Subst Type Exp 127 | instance Subst Type Type where 128 | isvar (TVar v) = Just (SubstName v) 129 | isvar _ = Nothing 130 | 131 | 132 | instance Subst Exp Loc 133 | instance Subst Exp Region 134 | instance Subst Exp Position 135 | instance Subst Exp Clause 136 | instance Subst Exp LetBind 137 | instance Subst Exp Pat 138 | instance Subst Exp Lit 139 | instance Subst Exp Type 140 | instance Subst Exp Exp where 141 | isvar (EVar v) = Just (SubstName v) 142 | isvar _ = Nothing 143 | 144 | 145 | newTVar :: Fresh m => m Type 146 | newTVar = 147 | TVar <$> fresh (s2n "x") -------------------------------------------------------------------------------- /language-syntax/src/Language/Syntax/Location.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances 2 | , BangPatterns 3 | , DeriveGeneric 4 | , OverloadedStrings 5 | , TemplateHaskell 6 | , DeriveDataTypeable 7 | , RecordWildCards 8 | , ViewPatterns 9 | , UndecidableInstances 10 | #-} 11 | module Language.Syntax.Location where 12 | 13 | import Lens.Micro.Platform 14 | 15 | import Data.Data 16 | import GHC.Generics (Generic) 17 | 18 | import Data.Text.Prettyprint.Doc 19 | 20 | 21 | data L a = L { unL :: a, unLoc :: Loc } 22 | 23 | 24 | 25 | data Loc 26 | = Loc 27 | { _locPath :: FilePath 28 | , _locReg :: Region 29 | } 30 | deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) 31 | 32 | 33 | data Region 34 | = R 35 | { _regStart :: Position 36 | , _regEnd :: Position 37 | } 38 | deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) 39 | 40 | 41 | data Position 42 | = P 43 | { _posLine :: Int 44 | , _posColumn :: Int 45 | } 46 | deriving (Eq, Read, Show, Data, Typeable, Generic) 47 | 48 | 49 | instance Ord Position where 50 | compare (P l1 c1) (P l2 c2) 51 | | l1 == l2 = c1 `compare` c2 52 | | otherwise = l1 `compare` l2 53 | 54 | makeLenses ''Loc 55 | makeLenses ''Region 56 | makeLenses ''Position 57 | 58 | 59 | -- ----------------------------------------------------------------------------- 60 | -- Getting Classy 61 | 62 | class HasLocation a where 63 | locOf :: a -> Loc 64 | 65 | class HasRegion a where 66 | regOf :: a -> Region 67 | 68 | class HasPosition a where 69 | posOf :: a -> Position 70 | 71 | 72 | -- ----------------------------------------------------------------------------- 73 | -- Instances 74 | 75 | instance HasLocation (L a) where 76 | locOf = unLoc 77 | 78 | instance Functor L where 79 | fmap f (L a l) = L (f a) l 80 | 81 | 82 | instance Semigroup a => Semigroup (L a) where 83 | (<>) (L a l1) (L b l2) = L (a<>b) (l1<>l2) 84 | 85 | instance HasLocation Loc where 86 | locOf = id 87 | 88 | instance HasRegion Region where 89 | regOf = id 90 | 91 | instance HasPosition Position where 92 | posOf = id 93 | 94 | 95 | instance HasLocation a => HasRegion a where 96 | regOf = regOf . locOf 97 | 98 | 99 | instance Semigroup Loc where 100 | (<>) (Loc fp1 r1) (Loc fp2 r2) 101 | | fp1 == fp2 = Loc fp1 $ r1 <> r2 102 | | otherwise = error $ "Cannot mappend two locations with different file names." 103 | 104 | 105 | instance Semigroup Region where 106 | (<>) (R s1 e1) (R s2 e2) 107 | = R (min s1 s2) 108 | (max e1 e2 ) 109 | 110 | instance Monoid Region where 111 | mempty 112 | = R (P 0 0) (P 0 0) 113 | 114 | 115 | -- Location can be taken from any foldable functor with location 116 | instance {-# OVERLAPPABLE #-} (Foldable f, Functor f, HasLocation a) => HasLocation (f a) where 117 | locOf = foldl1 (<>) . fmap locOf 118 | 119 | -- ----------------------------------------------------------------------------- 120 | -- Helpers 121 | 122 | mkRegion :: (HasPosition a, HasPosition b) => a -> b -> Region 123 | mkRegion start end = R (posOf start) (posOf end) 124 | 125 | stretch :: HasPosition a => a -> Int -> Region 126 | stretch a n = mkRegion p1 p2 127 | where 128 | p1@(P l c) = posOf a 129 | p2 = P l (c + n) 130 | 131 | 132 | (<++>) :: (HasLocation a, HasLocation b) => a -> b -> Loc 133 | (<++>) a b = locOf a <> locOf b 134 | 135 | -- ----------------------------------------------------------------------------- 136 | -- Pretty Instances 137 | 138 | instance Pretty Loc where 139 | pretty Loc{..} = 140 | pretty _locPath <> ":" <> pretty _locReg 141 | 142 | 143 | instance Pretty Region where 144 | pretty (R s e) 145 | | s == e 146 | = pretty s 147 | | otherwise 148 | = pretty s <> "-" <> pretty e 149 | 150 | 151 | instance Pretty Position where 152 | pretty (P l c) = 153 | pretty (l+1) <> ":" <> pretty (c+1) 154 | -------------------------------------------------------------------------------- /ttc/app/Compiler.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 2 | {-# LANGUAGE LambdaCase 3 | , RecordWildCards 4 | , ViewPatterns 5 | #-} 6 | module Compiler where 7 | 8 | import Control.Monad.Except 9 | 10 | import Language.Syntax.Location 11 | 12 | import qualified Language.STLC.Desugar as STLC 13 | import qualified Language.STLC.Match as STLC 14 | import Language.STLC.Pretty 15 | import qualified Language.STLC.Lex as STLC 16 | import qualified Language.STLC.Lex.Format as STLC 17 | import qualified Language.STLC.Lex.Token as STLC 18 | import qualified Language.STLC.Parse as STLC 19 | import qualified Language.STLC.Syntax as STLC 20 | import qualified Language.STLC.Namecheck as STLC 21 | import qualified Language.STLC.TypeCheck as STLC 22 | 23 | import Language.LLTT.Pretty 24 | import qualified Language.LLTT.LLVM.Codegen as LL 25 | 26 | import qualified LLVM.Module as LLVM 27 | import qualified LLVM.Target as LLVM 28 | import qualified LLVM.Context as LLVM 29 | import qualified LLVM.AST as AST 30 | 31 | import Unbound.Generics.LocallyNameless 32 | 33 | import Data.Text (pack) 34 | import Data.Text.Prettyprint.Doc 35 | import Data.Text.Prettyprint.Doc.Render.Text (putDoc, hPutDoc) 36 | 37 | import System.IO 38 | import System.FilePath 39 | import System.Directory 40 | import System.Process (callCommand, waitForProcess) 41 | import System.Exit (exitFailure) 42 | 43 | 44 | data Compiler = 45 | Compiler 46 | { cInputs :: [String] 47 | , cOutput :: String 48 | , cOutputIR :: Bool 49 | , cBuildDir :: FilePath 50 | } 51 | deriving (Show) 52 | 53 | data SrcFile = SrcFile FilePath String 54 | 55 | mkCompiler :: Compiler 56 | mkCompiler 57 | = Compiler 58 | { cInputs = ["main.stlc"] 59 | , cOutput = "a.out" 60 | , cOutputIR = False 61 | , cBuildDir = "./" 62 | } 63 | 64 | runCompiler :: Compiler -> IO () 65 | runCompiler Compiler{..} = do 66 | createDirectoryIfMissing True cBuildDir 67 | createDirectoryIfMissing True (takeDirectory cOutput) 68 | llmodules <- mapM (compileSTLC cBuildDir) cInputs 69 | callCommand $ "clang -Wno-unused-command-line-argument -Wno-override-module -O2 rts.c " <> unwords llmodules <> " -o " <> cOutput 70 | 71 | 72 | handleErrors :: Pretty e => Either [e] a -> IO a 73 | handleErrors = either printErrors pure 74 | 75 | printErrors :: Pretty e => [e] -> IO a 76 | printErrors errs = do 77 | putDoc $ vsep <$> pretty errs 78 | exitFailure 79 | 80 | 81 | lexSTLC :: FilePath -> String -> [STLC.Token] 82 | lexSTLC fp c = 83 | case runExcept $ STLC.lex fp (pack c) of 84 | Left err -> do 85 | error $ show (pretty err) 86 | 87 | Right toks -> STLC.layout toks 88 | 89 | compileSTLC :: String -> String -> IO String 90 | compileSTLC build_dir in_fp = do 91 | toks <- (lexSTLC in_fp) <$> readFile in_fp 92 | -- putDoc $ pretty toks <> line 93 | let stlc = STLC.parseModule toks 94 | 95 | let build_fp = build_dir <> takeBaseName in_fp 96 | 97 | stlc1 <- handleErrors $ STLC.namecheck (STLC.getModuleNames stlc) stlc 98 | 99 | stlc' <- handleErrors $ STLC.checkModule stlc1 100 | withFile (build_fp <> ".stlc.typed") WriteMode $ \h -> 101 | hPutDoc h $ pretty stlc' 102 | 103 | --let stlc'' = matchModule stlc' 104 | --withFile (build_fp <> ".stlc.matched") WriteMode $ \h -> 105 | -- hPutDoc h $ pretty stlc'' 106 | 107 | let lltt@(locOf -> l) = STLC.desugarModule stlc' 108 | withFile (build_fp <> ".lltt") WriteMode $ \h -> 109 | hPutDoc h $ pretty lltt 110 | 111 | let llvmir = LL.genModule (LL.mkEnv l) in_fp lltt 112 | irfp = build_fp <> ".ll" 113 | LLVM.withContext $ \c -> 114 | LLVM.withModuleFromAST c llvmir $ \m -> do 115 | LLVM.writeLLVMAssemblyToFile (LLVM.File irfp) m 116 | LLVM.withHostTargetMachine $ \t -> do 117 | LLVM.writeTargetAssemblyToFile t (LLVM.File $ build_fp <> ".s") m 118 | LLVM.writeObjectToFile t (LLVM.File $ build_fp <> ".o") m 119 | 120 | callCommand $ "clang -Wno-unused-command-line-argument -Wno-override-module -O1 -S -emit-llvm " <> irfp <> " -o " <> irfp <> ".opt1" 121 | callCommand $ "clang -Wno-unused-command-line-argument -Wno-override-module -O2 -S -emit-llvm " <> irfp <> " -o " <> irfp <> ".opt2" 122 | 123 | return (build_fp <> ".o") -------------------------------------------------------------------------------- /report/src/Control/Monad/Report.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances 2 | , FunctionalDependencies 3 | , MultiParamTypeClasses 4 | , ViewPatterns 5 | , LambdaCase 6 | , CPP 7 | , UndecidableInstances 8 | #-} 9 | module Control.Monad.Report where 10 | 11 | 12 | import Control.Monad 13 | import Control.Monad.Reader 14 | -- import Control.Monad.Trans 15 | import Data.Bifunctor 16 | import Data.DList (DList) 17 | import qualified Data.DList as DL 18 | 19 | import Data.Functor.Identity 20 | import Unbound.Generics.LocallyNameless 21 | 22 | 23 | -- -------------------------------------------------------------------------- 24 | -- | Multi Error Datatype 25 | 26 | data Result e a 27 | = Success a 28 | | Failure (DList e) 29 | | Failing (DList e) a 30 | 31 | 32 | instance Functor (Result e) where 33 | fmap f = \case 34 | Success a -> Success (f a) 35 | Failure e -> Failure e 36 | Failing e a -> Failing e (f a) 37 | 38 | 39 | instance Bifunctor Result where 40 | bimap f g = \case 41 | Success a -> Success (g a) 42 | Failure es -> Failure (f <$> es) 43 | Failing es a -> Failing (f <$> es) (g a) 44 | 45 | first f = \case 46 | Success a -> Success a 47 | Failure es -> Failure (f <$> es) 48 | Failing es a -> Failing (f <$> es) a 49 | 50 | second g = \case 51 | Success a -> Success (g a) 52 | Failure es -> Failure es 53 | Failing es a -> Failing es (g a) 54 | 55 | 56 | -- -------------------------------------------------------------------------- 57 | -- | The `Report` monad. 58 | 59 | 60 | type Report e a = ReportT e Identity a 61 | 62 | runReport :: Report e a -> Either [e] a 63 | runReport = runIdentity . runReportT 64 | 65 | 66 | -- -------------------------------------------------------------------------- 67 | -- | The `ReportT` monad transformer. 68 | 69 | newtype ReportT e m a 70 | = ReportT { unReportT :: Result e () -> m (Result e a) } 71 | 72 | runReportT :: Monad m => ReportT e m a -> m (Either [e] a) 73 | runReportT m = do 74 | r <- unReportT m (Success ()) 75 | case r of 76 | Success a -> return $ Right a 77 | Failure es -> return $ Left $ DL.toList es 78 | Failing _ a -> return $ Right a 79 | 80 | 81 | instance Functor m => Functor (ReportT e m) where 82 | fmap f (ReportT r) = ReportT $ \es -> fmap f <$> r es 83 | 84 | 85 | instance (Functor m, Monad m) => Applicative (ReportT e m) where 86 | pure a = ReportT $ \case 87 | Success _ -> return $ Success a 88 | Failure es -> return $ Failure es 89 | Failing es _ -> return $ Failing es a 90 | 91 | (ReportT mf) <*> (ReportT mx) = ReportT $ \es -> 92 | do rf <- mf es 93 | case rf of 94 | Success f -> 95 | do rx <- mx (Success ()) 96 | case rx of 97 | Success x -> return $ Success (f x) 98 | Failure es2 -> return $ Failure es2 99 | Failing es2 x -> return $ Failing es2 (f x) 100 | 101 | Failure es' -> return $ Failure es' 102 | 103 | Failing es' f -> 104 | do rx <- mx $ Failing es' () 105 | case rx of 106 | Success x -> return $ Success (f x) 107 | Failure es'' -> return $ Failure es'' 108 | Failing es'' x -> return $ Failing es'' (f x) 109 | 110 | 111 | 112 | instance Monad m => Monad (ReportT e m) where 113 | #if !(MIN_VERSION_base(4,8,9)) 114 | return a = ReportT $ \case 115 | Success _ -> return $ Success a 116 | Failure es -> return $ Failure es 117 | Failing es _ -> return $ Failing es a 118 | #endif 119 | 120 | (ReportT ma) >>= k = ReportT $ \es -> do 121 | ra <- ma es 122 | case ra of 123 | Success a -> unReportT (k a) (Success ()) 124 | Failure es' -> return $ Failure es' 125 | Failing es' a -> unReportT (k a) (Failing es' ()) 126 | 127 | 128 | instance MonadTrans (ReportT e) where 129 | lift m = ReportT $ \case 130 | Success _ -> Success `liftM` m 131 | Failure es -> return $ Failure es 132 | Failing es _ -> Failing es `liftM` m 133 | 134 | 135 | instance (MonadReader r m) => MonadReader r (ReportT e m) where 136 | ask = lift ask 137 | local f (ReportT m) 138 | = ReportT $ \r -> local f (m r) 139 | reader = lift . reader 140 | 141 | instance Fresh m => Fresh (ReportT e m) where 142 | fresh = lift . fresh 143 | 144 | -- -------------------------------------------------------------------------- 145 | -- | The `MonadReport` typeclass. 146 | 147 | class MonadReport e m | m -> e where 148 | witness :: e -> m () 149 | nonfatal :: e -> a -> m a 150 | fatal :: e -> m a 151 | allFatal :: m a -> m a 152 | report :: Result e a -> m a 153 | 154 | 155 | instance Monad m => MonadReport e (ReportT e m) where 156 | witness = report . (`Failing` ()) . pure 157 | 158 | nonfatal e a = report $ Failing (pure e) a 159 | 160 | fatal = report . Failure . pure 161 | 162 | allFatal m = ReportT $ \case 163 | Failure es -> return $ Failure es 164 | Failing es _ -> do 165 | ja <- unReportT m $ Success () 166 | return $ case ja of 167 | Failure es' -> let es'' = es' <> es in es'' `seq` Failure es'' 168 | Failing es' _ -> let es'' = es' <> es in es'' `seq` Failure es'' 169 | Success a -> Failing es a 170 | Success _ -> do 171 | ja <- unReportT m $ Success () 172 | return $ case ja of 173 | Failure es' -> Failure es' 174 | Failing es' _ -> Failure es' 175 | Success a -> Success a 176 | 177 | 178 | report ra = ReportT $ \r -> 179 | return $ case r of 180 | Success _ -> ra 181 | Failure es -> Failure es 182 | Failing es _ -> 183 | case ra of 184 | Success a -> Failing es a 185 | Failure es' -> let es'' = es' <> es in es'' `seq` Failure es'' 186 | Failing es' a -> let es'' = es' <> es in es'' `seq` Failing es'' a 187 | -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Lex/Format.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts 2 | , OverloadedStrings 3 | , RankNTypes 4 | , TemplateHaskell 5 | , DataKinds 6 | , KindSignatures 7 | , GADTs 8 | #-} 9 | module Language.STLC.Lex.Format where 10 | 11 | import Lens.Micro.Platform 12 | import Control.Monad (when, unless, void) 13 | import Control.Monad.State.Strict (State, evalState, gets) 14 | import Language.STLC.Lex.Token 15 | import Language.Syntax.Location (Loc(..), Region) 16 | import Safe (headDef) 17 | 18 | import qualified Language.Syntax.Location as L 19 | 20 | 21 | blkTriggers :: [TokenClass] 22 | blkTriggers = [TokenRsvp "of", TokenRsvp "let"] 23 | 24 | blkEndTriggers :: [TokenClass] 25 | blkEndTriggers = [TokenRsvp "in"] 26 | 27 | -- ----------------------------------------------------------------------------- 28 | -- Cell Type 29 | 30 | data CellType = 31 | Block 32 | | LineFold 33 | deriving (Eq, Ord, Show) 34 | 35 | data Cell = 36 | Cell 37 | { _cellIndent :: !Int 38 | , _cellType :: CellType 39 | } deriving (Eq, Ord, Show) 40 | 41 | 42 | makeLenses ''Cell 43 | 44 | defCell :: Cell 45 | defCell = Cell 0 Block 46 | 47 | -- ----------------------------------------------------------------------------- 48 | -- Layout Types 49 | 50 | data LayoutState = 51 | LayoutState 52 | { _layFilePath :: FilePath 53 | , _layRegion :: Region 54 | , _layStack :: [Cell] 55 | , _blkTriggered :: Bool 56 | , _layToks :: [Token] 57 | , _layToks' :: [Token] 58 | , _layResults :: [[Token]] 59 | } deriving (Eq, Ord, Show) 60 | 61 | makeLenses ''LayoutState 62 | 63 | type Layout = State LayoutState 64 | 65 | mkLayout :: [Token] -> LayoutState 66 | mkLayout input = LayoutState "" mempty [defCell] False input [] [] 67 | 68 | 69 | -- ----------------------------------------------------------------------------- 70 | -- Layout Driver 71 | 72 | 73 | -- This would be more performant with a foldM in the State monad 74 | -- Since this was originally implemented with conduit, using recursion in a state monad that 75 | -- maintains input/out lists was easier. 76 | layout :: [Token] -> [Token] 77 | layout toks = mconcat $ reverse $ evalState layoutDriver (mkLayout toks) 78 | 79 | 80 | layoutDriver :: Layout [[Token]] 81 | layoutDriver = do 82 | ts <- use layToks 83 | case ts of 84 | (t:ts') -> do 85 | layToks .= ts' 86 | updateLocation t 87 | handleTok t 88 | layoutDriver 89 | 90 | [] -> do 91 | closeStack 92 | use layResults 93 | 94 | 95 | handleTok :: Token -> Layout () 96 | handleTok t 97 | | t^.tokClass == TokenEof = closeStack 98 | 99 | | otherwise = do 100 | -- Blocks triggered on last token need to be handled 101 | emitBlk <- use blkTriggered 102 | when emitBlk $ do 103 | blkTriggered .= False 104 | open Block 105 | 106 | when (t^.tokClass `elem` blkEndTriggers) 107 | closeBlk 108 | 109 | closeInvalid 110 | yieldTok t 111 | 112 | -- Colons trigger block emission for the next token 113 | when (t^.tokClass `elem` blkTriggers) 114 | (blkTriggered .= True) 115 | 116 | 117 | -- ----------------------------------------------------------------------------- 118 | -- Driver Helpers 119 | 120 | 121 | yieldTok :: Token -> Layout () 122 | yieldTok t = do 123 | layToks' %= (t:) 124 | 125 | d <- length <$> use layStack 126 | let isTopLevel = (d == 1) && (t^.tokClass == TokenLn') 127 | isEof = (t^.tokClass == TokenEof) 128 | 129 | -- Is it time to split it up? 130 | when (isTopLevel || isEof) 131 | $ do ts <- reverse <$> use layToks' 132 | layResults %= (ts:) 133 | layToks' .= [] 134 | 135 | 136 | 137 | 138 | closeStack :: Layout () 139 | closeStack = do 140 | cl <- peekCell 141 | unless (cl == defCell) 142 | (close >> closeStack) 143 | 144 | 145 | closeInvalid :: Layout () 146 | closeInvalid = do 147 | go =<< getCurrIndent 148 | fillBlock 149 | where 150 | go i = do 151 | cl <- peekCell 152 | unless (isValid i cl) 153 | (close >> go i) 154 | 155 | 156 | fillBlock :: Layout () 157 | fillBlock = do 158 | (Cell _ ct) <- peekCell 159 | when (ct == Block) 160 | (open LineFold) 161 | 162 | 163 | open :: CellType -> Layout () 164 | open ct = do 165 | fp <- use layFilePath 166 | r <- use layRegion 167 | i <- getCurrIndent 168 | 169 | let cl = Cell i ct 170 | pushCell cl 171 | yieldTok $ openTok (Loc fp r) cl 172 | 173 | 174 | close :: Layout () 175 | close = do 176 | cl <- peekCell 177 | fp <- use layFilePath 178 | r <- use layRegion 179 | void popCell 180 | yieldTok $ closeTok (Loc fp r) cl 181 | 182 | 183 | -- | This will close a block layout, if there is one. 184 | -- | Otherwise, it will just close a linefold, if there is one. 185 | closeBlk :: Layout () 186 | closeBlk = do 187 | -- Peek two cells off the stack 188 | (Cell i1 ct1) <- peekCell 189 | (Cell i2 ct2) <- (headDef defCell . tail) <$> use layStack 190 | 191 | -- Close twice when there is a linefold followed by a block that isn't root 192 | when (ct1 == LineFold && ct2 == Block && i2 /= 0) 193 | (close >> close) 194 | 195 | -- Close once when there is a block that isn't root 196 | when (ct1 == Block && i1 /= 0) 197 | (close) 198 | 199 | 200 | -- ----------------------------------------------------------------------------- 201 | -- Layout Helpers 202 | 203 | updateLocation :: Token -> Layout () 204 | updateLocation (Token _ _ (Loc fp r)) = do 205 | layFilePath .= fp 206 | layRegion .= r 207 | 208 | 209 | getCellIndent :: Layout Int 210 | getCellIndent = 211 | _cellIndent <$> peekCell 212 | 213 | 214 | getCurrIndent :: Layout Int 215 | getCurrIndent = 216 | gets $ L._posColumn . L._regStart . _layRegion 217 | 218 | 219 | setIndent :: Int -> Layout () 220 | setIndent i = 221 | layStack . ix 0 . cellIndent .= i 222 | 223 | 224 | pushCell :: Cell -> Layout () 225 | pushCell l = 226 | layStack %= (l:) 227 | 228 | 229 | popCell :: Layout Cell 230 | popCell = do 231 | cn <- peekCell 232 | layStack %= tail 233 | return cn 234 | 235 | 236 | peekCell :: Layout Cell 237 | peekCell = 238 | headDef defCell <$> use layStack 239 | 240 | 241 | openTok :: Loc -> Cell -> Token 242 | openTok loc cl = 243 | case cl ^. cellType of 244 | Block -> Token TokenBlk "" loc 245 | LineFold -> Token TokenLn "" loc 246 | 247 | 248 | closeTok :: Loc -> Cell -> Token 249 | closeTok loc cl = 250 | case cl ^. cellType of 251 | Block -> Token TokenBlk' "" loc 252 | LineFold -> Token TokenLn' "" loc 253 | 254 | 255 | isValid :: Int -> Cell -> Bool 256 | isValid i (Cell ci ct) = 257 | case ct of 258 | Block -> 259 | ci <= i 260 | 261 | LineFold -> 262 | ci < i 263 | -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Reduce.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase 2 | , ConstraintKinds 3 | , FlexibleContexts 4 | , ViewPatterns 5 | #-} 6 | module Language.STLC.Reduce where 7 | 8 | import Language.STLC.Syntax 9 | 10 | import Control.Monad.Reader 11 | 12 | import Data.Bifunctor 13 | import Data.List.NonEmpty ((<|)) 14 | import qualified Data.List.NonEmpty as NE 15 | import Data.Either 16 | import Data.Map.Strict (Map) 17 | import qualified Data.Map.Strict as Map 18 | 19 | import Unbound.Generics.LocallyNameless 20 | import Unbound.Generics.LocallyNameless.Name (name2String) 21 | 22 | type Env = Map String Exp 23 | 24 | type MonadReduce m = (MonadReader Env m, Fresh m) 25 | 26 | 27 | lookupVar ::MonadReader Env m => Var -> m (Maybe Exp) 28 | lookupVar v = reader $ Map.lookup (name2String v) 29 | 30 | reduceBy :: Env -> Int -> Exp -> Exp 31 | reduceBy env i e = either id id $ runFreshM $ runReaderT (reduceBy' i e) env 32 | 33 | reduceBy' :: MonadReduce m => Int -> Exp -> m (Either Exp Exp) 34 | reduceBy' 0 e = return $ Left e 35 | reduceBy' fuel e = do 36 | some_e' <- reduce e 37 | case some_e' of 38 | Left e' -> return $ Left e' 39 | Right e' -> reduceBy' (fuel-1) e' 40 | 41 | 42 | reduce :: MonadReduce m => Exp -> m (Either Exp Exp) 43 | reduce = \case 44 | EVar v -> do 45 | may_e <- lookupVar v 46 | case may_e of 47 | Just e -> return $ Right e 48 | Nothing -> return $ Left $ EVar v 49 | 50 | ELit l -> bimap ELit ELit <$> reduceLit l 51 | 52 | EApp f xs -> do 53 | some_xs' <- mapM reduce xs 54 | let xs' = either id id <$> some_xs' 55 | if length (rights $ NE.toList some_xs') /= 0 56 | then return $ Right $ EApp f xs' 57 | else do 58 | some_f' <- reduce f 59 | case some_f' of 60 | Left (ELam bnd) -> do 61 | (ps, body) <- unbind bnd 62 | let qs' = concatMap extractPat (NE.zip ps xs') 63 | body' = substs qs' body 64 | return $ Right body' 65 | 66 | 67 | Left f' -> error $ "reduce - can't apply non-function:\n\n" ++ show f' ++ "\n\n" 68 | Right f' -> return $ Right $ EApp f' xs' 69 | 70 | EType e ty -> bimap (`EType` ty) (`EType` ty) <$> reduce e 71 | ECast e ty -> bimap (`ECast` ty) (`ECast` ty) <$> reduce e 72 | 73 | ELoc e _ -> reduce e 74 | EParens e -> reduce e 75 | 76 | ELam bnd -> return $ Left $ ELam bnd 77 | 78 | ELet bnd -> return $ Left $ ELet bnd 79 | EIf p t f -> return $ Left $ EIf p t f 80 | 81 | ECase e cls -> return $ Left $ ECase e cls 82 | 83 | ERef e -> return $ Left $ ERef e 84 | EDeref e -> return $ Left $ EDeref e 85 | 86 | ETuple e es -> do 87 | some_e' <- reduce e 88 | some_es' <- mapM reduce es 89 | let e' = either id id some_e' 90 | es' = either id id <$> some_es' 91 | if length (rights (some_e' : NE.toList some_es')) == 0 92 | then return $ Left $ ETuple e' es' 93 | else return $ Right $ ETuple e' es' 94 | 95 | ECon n es -> do 96 | some_es' <- mapM reduce es 97 | let es' = either id id <$> some_es' 98 | if length (rights some_es') == 0 99 | then return $ Left $ ECon n es' 100 | else return $ Right $ ECon n es' 101 | 102 | ENewCon n es -> return $ Left $ ENewCon n es 103 | EFree e -> return $ Left $ EFree e 104 | 105 | EGet e m -> return $ Left $ EGet e m 106 | EGetI e i -> return $ Left $ EGetI e i 107 | ESet lhs rhs -> return $ Left $ ESet lhs rhs 108 | 109 | ENewArray e -> return $ Left $ ENewArray e 110 | ENewArrayI e -> return $ Left $ ENewArrayI e 111 | EResizeArray e s -> return $ Left $ EResizeArray e s 112 | 113 | ENewVect e -> return $ Left $ ENewVect e 114 | ENewVectI e -> return $ Left $ ENewVectI e 115 | 116 | ENewString s -> return $ Left $ ENewString s 117 | 118 | EOp op -> reduceOp op 119 | 120 | 121 | reduceLit :: MonadReduce m => Lit -> m (Either Lit Lit) 122 | reduceLit = \case 123 | LNull -> return $ Left $ LNull 124 | LBool b -> return $ Left $ LBool b 125 | LInt i -> return $ Left $ LInt i 126 | LDouble d -> return $ Left $ LDouble d 127 | LChar c -> return $ Left $ LChar c 128 | LString str -> return $ Left $ LString str 129 | 130 | LArray xs -> do 131 | xs' <- mapM reduce xs 132 | if length (rights xs') == 0 133 | then return $ Left $ LArray (lefts xs') 134 | else return $ Right $ LArray (either id id <$> xs') 135 | 136 | LArrayI e -> do 137 | bimap LArrayI LArrayI <$> reduce e 138 | 139 | LVect xs -> do 140 | xs' <- mapM reduce xs 141 | if length (rights xs') == 0 142 | then return $ Left $ LVect (lefts xs') 143 | else return $ Right $ LVect (either id id <$> xs') 144 | 145 | LVectI e -> do 146 | bimap LVectI LVectI <$> reduce e 147 | 148 | 149 | extractPat :: (Pat, Exp) -> [(Var, Exp)] 150 | extractPat (pat, e) 151 | = case pat of 152 | PVar v -> [(v, e)] 153 | PCon n ps -> 154 | case exEAnn e of 155 | ECon _ es 156 | | length ps == length es -> concatMap extractPat (zip ps es) 157 | | otherwise -> error $ "extractPat - Pattern-Constructor length mismatch!" 158 | 159 | _ -> error $ "Unsupported pattern match.\n\n" 160 | ++ "Pattern: " ++ show (PCon n ps) ++ "\n\n" 161 | ++ "Expression: " ++ show e ++ "\n\n" 162 | 163 | PTuple p ps -> 164 | case exEAnn e of 165 | ETuple _ es 166 | | NE.length ps == length es -> concatMap extractPat $ NE.toList $ NE.zip (p<|ps) es 167 | | otherwise -> error $ "extractPat - Pattern-Constructor length mismatch!" 168 | 169 | _ -> error $ "Unsupported pattern match.\n\n" 170 | ++ "Pattern: " ++ show (PTuple p ps) ++ "\n\n" 171 | ++ "Expression: " ++ show e ++ "\n\n" 172 | 173 | PWild -> [] 174 | PType p _ -> extractPat (p, e) 175 | PLoc p _ -> extractPat (p, e) 176 | PParens p -> extractPat (p, e) 177 | 178 | 179 | reduceOp :: MonadReduce m => Op -> m (Either Exp Exp) 180 | reduceOp = \case 181 | OpAdd a b -> reduceBinaryOp OpAdd (+) (+) a b 182 | OpSub a b -> reduceBinaryOp OpAdd (-) (-) a b 183 | OpMul a b -> reduceBinaryOp OpAdd (*) (*) a b 184 | OpDiv a b -> reduceBinaryOp OpAdd (div) (/) a b 185 | 186 | _ -> error $ "Unsupported operator encountered!" 187 | 188 | 189 | reduceBinaryOp :: MonadReduce m 190 | => (Exp -> Exp -> Op) 191 | -> (Integer -> Integer -> Integer) 192 | -> (Double -> Double -> Double) 193 | -> Exp -> Exp -> m (Either Exp Exp) 194 | reduceBinaryOp constr instr instrf a b = do 195 | some_a' <- reduce a 196 | case some_a' of 197 | Right a' -> return $ Right $ EOp $ constr a' b 198 | Left a' -> do 199 | some_b' <- reduce b 200 | case some_b' of 201 | Right b' -> return $ Right $ EOp $ constr a' b' 202 | Left b' -> 203 | case (a', b') of 204 | (ELit (LInt x), ELit (LInt y)) -> 205 | return $ Left $ ELit (LInt (instr x y)) 206 | 207 | (ELit (LDouble x), ELit (LDouble y)) -> 208 | return $ Left $ ELit (LDouble (instrf x y)) 209 | 210 | (ELit (LInt (fromIntegral -> x)), ELit (LDouble y)) -> 211 | return $ Left $ ELit (LDouble (instrf x y)) 212 | 213 | (ELit (LDouble x), ELit (LInt (fromIntegral -> y))) -> 214 | return $ Left $ ELit (LDouble (instrf x y)) 215 | 216 | _ -> return $ Left $ EOp $ constr a' b' -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Lift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds 2 | , LambdaCase 3 | , ViewPatterns 4 | , FlexibleContexts 5 | , GeneralizedNewtypeDeriving 6 | , OverloadedStrings 7 | #-} 8 | module Language.STLC.Lift where 9 | 10 | import Language.Syntax.Location 11 | import Language.STLC.Syntax 12 | 13 | import Control.Monad.Reader 14 | import Control.Monad.Writer.CPS 15 | import Data.Bifunctor 16 | import Data.DList (DList) 17 | import qualified Data.DList as DL 18 | import qualified Data.List.NonEmpty as NE 19 | 20 | import Unbound.Generics.LocallyNameless 21 | 22 | --- Lambda Lift Environment 23 | data Env = Env { envLoc :: Loc } 24 | 25 | mkEnv :: Loc -> Env 26 | mkEnv l = Env { envLoc = l } 27 | 28 | -- Lambda Lifting Monad 29 | type MonadLift m = (Fresh m, MonadReader Env m, MonadWriter (DList Func) m) 30 | 31 | newtype Lift a = Lift { unLift :: FreshMT (WriterT (DList Func) (Reader Env)) a } 32 | deriving (Functor, Applicative, Monad, Fresh, MonadReader Env, MonadWriter (DList Func)) 33 | 34 | runLift :: Lift a -> Loc -> (a, [Func]) 35 | runLift m l 36 | = second DL.toList $ runReader (runWriterT (runFreshMT (unLift m))) (mkEnv l) 37 | 38 | withLoc :: MonadLift m => Loc -> m a -> m a 39 | withLoc l = local (\env -> env { envLoc = l }) 40 | 41 | withMaybeLoc :: MonadLift m => Maybe Loc -> m a -> m a 42 | withMaybeLoc (Just l) = withLoc l 43 | withMaybeLoc Nothing = id 44 | 45 | writeFunc :: MonadLift m => String -> [Pat] -> Exp -> m () 46 | writeFunc n ps body = do 47 | l <- envLoc <$> ask 48 | let ty = tarr (exPType <$> ps) (exType body) 49 | tell $ DL.singleton $ Func l ty n (bind ps body) 50 | 51 | 52 | -- Lift should transform a module without any errors 53 | lift :: Module -> (Module, [Func]) 54 | lift m@(Module l _ _) = runLift (liftModule m) l 55 | 56 | 57 | liftModule :: MonadLift m => Module -> m Module 58 | liftModule (Module l n defns) = 59 | Module l n <$> mapM liftDefn defns 60 | 61 | liftDefn :: MonadLift m => Defn -> m Defn 62 | liftDefn = \case 63 | FuncDefn f -> FuncDefn <$> liftFunc f 64 | ExternDefn ex -> ExternDefn <$> liftExtern ex 65 | DataTypeDefn dt -> DataTypeDefn <$> liftDataType dt 66 | 67 | 68 | liftFunc :: MonadLift m => Func -> m Func 69 | liftFunc (Func l ty n bnd) = withLoc l $ do 70 | ty' <- liftType ty 71 | (args, body) <- unbind bnd 72 | args' <- mapM liftPat args 73 | body' <- liftExp body 74 | return $ Func l ty' n (bind args' body') 75 | 76 | liftExtern :: MonadLift m => Extern -> m Extern 77 | liftExtern (Extern l n argtys retty) = withLoc l $ do 78 | argtys' <- mapM liftType argtys 79 | retty' <- liftType retty 80 | return $ Extern l n argtys' retty' 81 | 82 | 83 | liftDataType :: MonadLift m => DataType -> m DataType 84 | liftDataType (DataType l n constrs) 85 | = DataType l n <$> withLoc l (mapM liftConstrDefn constrs) 86 | 87 | liftConstrDefn :: MonadLift m => ConstrDefn -> m ConstrDefn 88 | liftConstrDefn = \case 89 | ConstrDefn l n tys -> ConstrDefn l n <$> withLoc l (mapM liftType tys) 90 | RecordDefn l n es -> RecordDefn l n <$> withLoc l (mapM liftEntry es) 91 | 92 | liftEntry :: MonadLift m => Entry -> m Entry 93 | liftEntry (Entry l n ty) = Entry l n <$> withLoc l (liftType ty) 94 | 95 | 96 | liftType :: MonadLift m => Type -> m Type 97 | liftType = \case 98 | TArr t1 t2 -> TArr <$> liftType t1 <*> liftType t2 99 | TCon n -> TCon <$> pure n 100 | 101 | TInt i -> pure $ TInt i 102 | TUInt i -> pure $ TUInt i 103 | TFp i -> pure $ TFp i 104 | 105 | TTuple t ts -> 106 | TTuple <$> liftType t <*> mapM liftType ts 107 | 108 | TArray i ty -> 109 | TArray i <$> liftType ty 110 | 111 | TVect i ty -> 112 | TVect i <$> liftType ty 113 | 114 | TPtr ty -> TPtr <$> liftType ty 115 | TLoc ty l -> withLoc l (TLoc <$> liftType ty <*> pure l) 116 | TParens ty -> TParens <$> liftType ty 117 | 118 | 119 | liftExp :: MonadLift m => Exp -> m Exp 120 | liftExp = \case 121 | EVar v -> EVar <$> pure v 122 | 123 | ELit l -> ELit <$> liftLit l 124 | EApp f xs -> EApp <$> liftExp f <*> mapM liftExp xs 125 | 126 | EType e ty -> EType <$> liftExp e <*> liftType ty 127 | ECast e ty -> ECast <$> liftExp e <*> liftType ty 128 | ELoc e l -> withLoc l (ELoc <$> liftExp e <*> pure l) 129 | EParens e -> EParens <$> liftExp e 130 | 131 | ELam bnd -> do 132 | (ps, body) <- unbind bnd 133 | n <- fresh $ s2n "lambda" 134 | ps' <- mapM liftPat ps 135 | body' <- liftExp body 136 | writeFunc (name2String n) (NE.toList ps') body' 137 | return $ EVar n 138 | 139 | 140 | ELet bnd -> do 141 | (unrec -> qs, body) <- unbind bnd 142 | let ps = fst <$> qs 143 | es = (unembed . snd) <$> qs 144 | ps' <- mapM liftPat ps 145 | es' <- mapM liftExp es 146 | body' <- liftExp body 147 | return $ ELet (bind (rec $ NE.zip ps' (embed <$> es')) body') 148 | 149 | 150 | EIf p t f -> EIf <$> liftExp p <*> liftExp t <*> liftElse f 151 | ECase e cs -> ECase <$> liftExp e <*> mapM liftClause cs 152 | 153 | ERef e -> ERef <$> liftExp e 154 | EDeref e -> EDeref <$> liftExp e 155 | 156 | ETuple e es -> ETuple <$> liftExp e <*> mapM liftExp es 157 | ECon n es -> 158 | ECon <$> pure n <*> mapM liftExp es 159 | ENewCon n es -> 160 | ENewCon <$> pure n <*> mapM liftExp es 161 | EFree e -> EFree <$> liftExp e 162 | 163 | EGet a str -> EGet <$> liftExp a <*> pure str -- lol check member names you doofus 164 | EGetI a b -> EGetI <$> liftExp a <*> liftExp b 165 | ESet a b -> ESet <$> liftExp a <*> liftExp b 166 | 167 | ENewArray es -> ENewArray <$> mapM liftExp es 168 | ENewArrayI i -> ENewArrayI <$> liftExp i 169 | EResizeArray e i -> EResizeArray <$> liftExp e <*> liftExp i 170 | 171 | ENewVect es -> ENewVect <$> mapM liftExp es 172 | ENewVectI i -> ENewVectI <$> liftExp i 173 | 174 | ENewString str -> pure $ ENewString str 175 | EOp op -> EOp <$> liftOp op 176 | 177 | 178 | liftLit :: MonadLift m => Lit -> m Lit 179 | liftLit = \case 180 | LNull -> pure LNull 181 | LBool b -> pure $ LBool b 182 | LInt i -> pure $ LInt i 183 | LDouble i -> pure $ LDouble i 184 | LChar c -> pure $ LChar c 185 | LString str -> pure $ LString str 186 | LArray es -> LArray <$> mapM liftExp es 187 | LArrayI i -> LArrayI <$> liftExp i 188 | LVect es -> LVect <$> mapM liftExp es 189 | LVectI i -> LVectI <$> liftExp i 190 | 191 | 192 | liftElse :: MonadLift m => Else -> m Else 193 | liftElse = \case 194 | Else may_l body -> withMaybeLoc may_l $ 195 | Else may_l <$> liftExp body 196 | 197 | Elif may_l p t f -> withMaybeLoc may_l $ 198 | Elif may_l <$> liftExp p <*> liftExp t <*> liftElse f 199 | 200 | 201 | liftOp :: MonadLift m => Op -> m Op 202 | liftOp = \case 203 | OpAdd a b -> OpAdd <$> liftExp a <*> liftExp b 204 | OpSub a b -> OpSub <$> liftExp a <*> liftExp b 205 | OpMul a b -> OpMul <$> liftExp a <*> liftExp b 206 | OpDiv a b -> OpDiv <$> liftExp a <*> liftExp b 207 | OpRem a b -> OpRem <$> liftExp a <*> liftExp b 208 | OpNeg a -> OpNeg <$> liftExp a 209 | 210 | 211 | OpAnd a b -> OpAnd <$> liftExp a <*> liftExp b 212 | OpOr a b -> OpOr <$> liftExp a <*> liftExp b 213 | OpXor a b -> OpXor <$> liftExp a <*> liftExp b 214 | 215 | OpShR a b -> OpShR <$> liftExp a <*> liftExp b 216 | OpShL a b -> OpShL <$> liftExp a <*> liftExp b 217 | 218 | OpEq a b -> OpEq <$> liftExp a <*> liftExp b 219 | OpNeq a b -> OpNeq <$> liftExp a <*> liftExp b 220 | 221 | OpLT a b -> OpLT <$> liftExp a <*> liftExp b 222 | OpLE a b -> OpLE <$> liftExp a <*> liftExp b 223 | 224 | OpGT a b -> OpGT <$> liftExp a <*> liftExp b 225 | OpGE a b -> OpGE <$> liftExp a <*> liftExp b 226 | 227 | 228 | liftPat :: MonadLift m => Pat -> m Pat 229 | liftPat = \case 230 | PVar v -> return $ PVar v 231 | PCon n ps -> 232 | PCon <$> pure n <*> mapM liftPat ps 233 | 234 | PTuple p ps -> 235 | PTuple <$> liftPat p <*> mapM liftPat ps 236 | 237 | PWild -> pure PWild 238 | 239 | PType p ty -> 240 | PType <$> liftPat p <*> liftType ty 241 | 242 | PLoc p l -> withLoc l (PLoc <$> liftPat p <*> pure l) 243 | PParens p -> PParens <$> liftPat p 244 | 245 | 246 | liftClause :: MonadLift m => Clause -> m Clause 247 | liftClause (Clause may_l bnd) = withMaybeLoc may_l $ do 248 | (p, e) <- unbind bnd 249 | p' <- liftPat p 250 | e' <- liftExp e 251 | return $ Clause may_l (bind p' e') -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Partial.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds 2 | , LambdaCase 3 | , ViewPatterns 4 | , FlexibleContexts 5 | , GeneralizedNewtypeDeriving 6 | , OverloadedStrings 7 | #-} 8 | module Language.STLC.Partial where 9 | 10 | import Language.Syntax.Location 11 | import Language.STLC.Syntax 12 | 13 | import Control.Monad.Reader 14 | import Control.Monad.Writer.CPS 15 | import Data.Bifunctor 16 | import Data.DList (DList) 17 | import qualified Data.DList as DL 18 | import qualified Data.List.NonEmpty as NE 19 | 20 | import Unbound.Generics.LocallyNameless 21 | 22 | --- Lambda Lift Environment 23 | data Env = Env { envLoc :: Loc } 24 | 25 | mkEnv :: Loc -> Env 26 | mkEnv l = Env { envLoc = l } 27 | 28 | 29 | -- Lambda Lifting Monad 30 | type MonadLift m = (Fresh m, MonadReader Env m, MonadWriter (DList Func) m) 31 | 32 | newtype Lift a = Lift { unLift :: FreshMT (WriterT (DList Func) (Reader Env)) a } 33 | deriving (Functor, Applicative, Monad, Fresh, MonadReader Env, MonadWriter (DList Func)) 34 | 35 | runLift :: Lift a -> Loc -> (a, [Func]) 36 | runLift m l 37 | = second DL.toList $ runReader (runWriterT (runFreshMT (unLift m))) (mkEnv l) 38 | 39 | withLoc :: MonadLift m => Loc -> m a -> m a 40 | withLoc l = local (\env -> env { envLoc = l }) 41 | 42 | withMaybeLoc :: MonadLift m => Maybe Loc -> m a -> m a 43 | withMaybeLoc (Just l) = withLoc l 44 | withMaybeLoc Nothing = id 45 | 46 | writeFunc :: MonadLift m => String -> [Pat] -> Exp -> m () 47 | writeFunc n ps body = do 48 | l <- envLoc <$> ask 49 | let ty = tarr (exPType <$> ps) (exType body) 50 | tell $ DL.singleton $ Func l ty n (bind ps body) 51 | 52 | 53 | -- Lift should transform a module without any errors 54 | lift :: Module -> (Module, [Func]) 55 | lift m@(Module l _ _) = runLift (liftModule m) l 56 | 57 | liftModule :: MonadLift m => Module -> m Module 58 | liftModule (Module l n defns) = 59 | Module l n <$> mapM liftDefn defns 60 | 61 | liftDefn :: MonadLift m => Defn -> m Defn 62 | liftDefn = \case 63 | FuncDefn f -> FuncDefn <$> liftFunc f 64 | ExternDefn ex -> ExternDefn <$> liftExtern ex 65 | DataTypeDefn dt -> DataTypeDefn <$> liftDataType dt 66 | 67 | 68 | liftFunc :: MonadLift m => Func -> m Func 69 | liftFunc (Func l ty n bnd) = withLoc l $ do 70 | ty' <- liftType ty 71 | (args, body) <- unbind bnd 72 | args' <- mapM liftPat args 73 | body' <- liftExp body 74 | return $ Func l ty' n (bind args' body') 75 | 76 | liftExtern :: MonadLift m => Extern -> m Extern 77 | liftExtern (Extern l n argtys retty) = withLoc l $ do 78 | argtys' <- mapM liftType argtys 79 | retty' <- liftType retty 80 | return $ Extern l n argtys' retty' 81 | 82 | 83 | liftDataType :: MonadLift m => DataType -> m DataType 84 | liftDataType (DataType l n constrs) 85 | = DataType l n <$> withLoc l (mapM liftConstrDefn constrs) 86 | 87 | liftConstrDefn :: MonadLift m => ConstrDefn -> m ConstrDefn 88 | liftConstrDefn = \case 89 | ConstrDefn l n tys -> ConstrDefn l n <$> withLoc l (mapM liftType tys) 90 | RecordDefn l n es -> RecordDefn l n <$> withLoc l (mapM liftEntry es) 91 | 92 | liftEntry :: MonadLift m => Entry -> m Entry 93 | liftEntry (Entry l n ty) = Entry l n <$> withLoc l (liftType ty) 94 | 95 | 96 | liftType :: MonadLift m => Type -> m Type 97 | liftType = \case 98 | TArr t1 t2 -> TArr <$> liftType t1 <*> liftType t2 99 | TCon n -> TCon <$> pure n 100 | 101 | TInt i -> pure $ TInt i 102 | TUInt i -> pure $ TUInt i 103 | TFp i -> pure $ TFp i 104 | 105 | TTuple t ts -> 106 | TTuple <$> liftType t <*> mapM liftType ts 107 | 108 | TArray i ty -> 109 | TArray i <$> liftType ty 110 | 111 | TVect i ty -> 112 | TVect i <$> liftType ty 113 | 114 | TPtr ty -> TPtr <$> liftType ty 115 | TLoc ty l -> withLoc l (TLoc <$> liftType ty <*> pure l) 116 | TParens ty -> TParens <$> liftType ty 117 | 118 | 119 | liftExp :: MonadLift m => Exp -> m Exp 120 | liftExp = \case 121 | EVar v -> EVar <$> pure v 122 | 123 | ELit l -> ELit <$> liftLit l 124 | EApp f xs -> EApp <$> liftExp f <*> mapM liftExp xs 125 | 126 | EType e ty -> EType <$> liftExp e <*> liftType ty 127 | ECast e ty -> ECast <$> liftExp e <*> liftType ty 128 | ELoc e l -> withLoc l (ELoc <$> liftExp e <*> pure l) 129 | EParens e -> EParens <$> liftExp e 130 | 131 | ELam bnd -> do 132 | (ps, body) <- unbind bnd 133 | n <- fresh $ s2n "lambda" 134 | ps' <- mapM liftPat ps 135 | body' <- liftExp body 136 | writeFunc (name2String n) (NE.toList ps') body' 137 | return $ EVar n 138 | 139 | 140 | ELet bnd -> do 141 | (unrec -> qs, body) <- unbind bnd 142 | let ps = fst <$> qs 143 | es = (unembed . snd) <$> qs 144 | ps' <- mapM liftPat ps 145 | es' <- mapM liftExp es 146 | body' <- liftExp body 147 | return $ ELet (bind (rec $ NE.zip ps' (embed <$> es')) body') 148 | 149 | 150 | EIf p t f -> EIf <$> liftExp p <*> liftExp t <*> liftElse f 151 | ECase e cs -> ECase <$> liftExp e <*> mapM liftClause cs 152 | 153 | ERef e -> ERef <$> liftExp e 154 | EDeref e -> EDeref <$> liftExp e 155 | 156 | ETuple e es -> ETuple <$> liftExp e <*> mapM liftExp es 157 | ECon n es -> 158 | ECon <$> pure n <*> mapM liftExp es 159 | ENewCon n es -> 160 | ENewCon <$> pure n <*> mapM liftExp es 161 | EFree e -> EFree <$> liftExp e 162 | 163 | EGet a str -> EGet <$> liftExp a <*> pure str -- lol check member names you doofus 164 | EGetI a b -> EGetI <$> liftExp a <*> liftExp b 165 | ESet a b -> ESet <$> liftExp a <*> liftExp b 166 | 167 | ENewArray es -> ENewArray <$> mapM liftExp es 168 | ENewArrayI i -> ENewArrayI <$> liftExp i 169 | EResizeArray e i -> EResizeArray <$> liftExp e <*> liftExp i 170 | 171 | ENewVect es -> ENewVect <$> mapM liftExp es 172 | ENewVectI i -> ENewVectI <$> liftExp i 173 | 174 | ENewString str -> pure $ ENewString str 175 | EOp op -> EOp <$> liftOp op 176 | 177 | 178 | liftLit :: MonadLift m => Lit -> m Lit 179 | liftLit = \case 180 | LNull -> pure LNull 181 | LBool b -> pure $ LBool b 182 | LInt i -> pure $ LInt i 183 | LDouble i -> pure $ LDouble i 184 | LChar c -> pure $ LChar c 185 | LString str -> pure $ LString str 186 | LArray es -> LArray <$> mapM liftExp es 187 | LArrayI i -> LArrayI <$> liftExp i 188 | LVect es -> LVect <$> mapM liftExp es 189 | LVectI i -> LVectI <$> liftExp i 190 | 191 | 192 | liftElse :: MonadLift m => Else -> m Else 193 | liftElse = \case 194 | Else may_l body -> withMaybeLoc may_l $ 195 | Else may_l <$> liftExp body 196 | 197 | Elif may_l p t f -> withMaybeLoc may_l $ 198 | Elif may_l <$> liftExp p <*> liftExp t <*> liftElse f 199 | 200 | 201 | liftOp :: MonadLift m => Op -> m Op 202 | liftOp = \case 203 | OpAdd a b -> OpAdd <$> liftExp a <*> liftExp b 204 | OpSub a b -> OpSub <$> liftExp a <*> liftExp b 205 | OpMul a b -> OpMul <$> liftExp a <*> liftExp b 206 | OpDiv a b -> OpDiv <$> liftExp a <*> liftExp b 207 | OpRem a b -> OpRem <$> liftExp a <*> liftExp b 208 | OpNeg a -> OpNeg <$> liftExp a 209 | 210 | 211 | OpAnd a b -> OpAnd <$> liftExp a <*> liftExp b 212 | OpOr a b -> OpOr <$> liftExp a <*> liftExp b 213 | OpXor a b -> OpXor <$> liftExp a <*> liftExp b 214 | 215 | OpShR a b -> OpShR <$> liftExp a <*> liftExp b 216 | OpShL a b -> OpShL <$> liftExp a <*> liftExp b 217 | 218 | OpEq a b -> OpEq <$> liftExp a <*> liftExp b 219 | OpNeq a b -> OpNeq <$> liftExp a <*> liftExp b 220 | 221 | OpLT a b -> OpLT <$> liftExp a <*> liftExp b 222 | OpLE a b -> OpLE <$> liftExp a <*> liftExp b 223 | 224 | OpGT a b -> OpGT <$> liftExp a <*> liftExp b 225 | OpGE a b -> OpGE <$> liftExp a <*> liftExp b 226 | 227 | 228 | liftPat :: MonadLift m => Pat -> m Pat 229 | liftPat = \case 230 | PVar v -> return $ PVar v 231 | PCon n ps -> 232 | PCon <$> pure n <*> mapM liftPat ps 233 | 234 | PTuple p ps -> 235 | PTuple <$> liftPat p <*> mapM liftPat ps 236 | 237 | PWild -> pure PWild 238 | 239 | PType p ty -> 240 | PType <$> liftPat p <*> liftType ty 241 | 242 | PLoc p l -> withLoc l (PLoc <$> liftPat p <*> pure l) 243 | PParens p -> PParens <$> liftPat p 244 | 245 | 246 | liftClause :: MonadLift m => Clause -> m Clause 247 | liftClause (Clause may_l bnd) = withMaybeLoc may_l $ do 248 | (p, e) <- unbind bnd 249 | p' <- liftPat p 250 | e' <- liftExp e 251 | return $ Clause may_l (bind p' e') -------------------------------------------------------------------------------- /stlc/src/Language/STLC/CConv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds 2 | , LambdaCase 3 | , ViewPatterns 4 | , FlexibleContexts 5 | , GeneralizedNewtypeDeriving 6 | , OverloadedStrings 7 | #-} 8 | module Language.STLC.CConv where 9 | 10 | import Language.STLC.Syntax 11 | 12 | import Lens.Micro.Platform 13 | import Control.Monad.Reader 14 | import Data.Set (Set) 15 | import qualified Data.Set as Set 16 | import qualified Data.List.NonEmpty as NE 17 | 18 | import Unbound.Generics.LocallyNameless 19 | 20 | --- CConv Environment 21 | data Env = Env { envNames :: Set String } 22 | 23 | envEmpty :: Env 24 | envEmpty = Env { envNames = mempty } 25 | 26 | envInsertNames :: [String] -> Env -> Env 27 | envInsertNames ns env 28 | = env { envNames = Set.union (Set.fromList ns) 29 | (envNames env) 30 | } 31 | 32 | 33 | -- CConv Monad 34 | type MonadCConv m = (Fresh m, MonadReader Env m) 35 | 36 | newtype CConv a = CConv { unCConv :: FreshMT (Reader Env) a } 37 | deriving (Functor, Applicative, Monad, Fresh, MonadReader Env) 38 | 39 | runCConv :: CConv a -> a 40 | runCConv m 41 | = runReader (runFreshMT (unCConv m)) envEmpty 42 | 43 | withNames :: MonadCConv m => [String] -> m a -> m a 44 | withNames ns = local (envInsertNames ns) 45 | 46 | 47 | -- CConv should transform a module without any errors 48 | cconv :: Module -> Module 49 | cconv m = runCConv (cconvModule m) 50 | 51 | 52 | cconvModule :: MonadCConv m => Module -> m Module 53 | cconvModule (Module l n defns) = 54 | Module l n <$> mapM cconvDefn defns 55 | 56 | cconvDefn :: MonadCConv m => Defn -> m Defn 57 | cconvDefn = \case 58 | FuncDefn f -> FuncDefn <$> cconvFunc f 59 | ExternDefn ex -> ExternDefn <$> cconvExtern ex 60 | DataTypeDefn dt -> DataTypeDefn <$> cconvDataType dt 61 | 62 | 63 | cconvFunc :: MonadCConv m => Func -> m Func 64 | cconvFunc (Func l ty n bnd) = do 65 | ty' <- cconvType ty 66 | (args, body) <- unbind bnd 67 | args' <- mapM cconvPat args 68 | let ns = fst <$> concatMap patVars args 69 | body' <- withNames ns $ cconvExp body 70 | return $ Func l ty' n (bind args' body') 71 | 72 | cconvExtern :: MonadCConv m => Extern -> m Extern 73 | cconvExtern (Extern l n argtys retty) = do 74 | argtys' <- mapM cconvType argtys 75 | retty' <- cconvType retty 76 | return $ Extern l n argtys' retty' 77 | 78 | 79 | cconvDataType :: MonadCConv m => DataType -> m DataType 80 | cconvDataType (DataType l n constrs) 81 | = DataType l n <$> mapM cconvConstrDefn constrs 82 | 83 | cconvConstrDefn :: MonadCConv m => ConstrDefn -> m ConstrDefn 84 | cconvConstrDefn = \case 85 | ConstrDefn l n tys -> ConstrDefn l n <$> mapM cconvType tys 86 | RecordDefn l n es -> RecordDefn l n <$> mapM cconvEntry es 87 | 88 | cconvEntry :: MonadCConv m => Entry -> m Entry 89 | cconvEntry (Entry l n ty) = Entry l n <$> cconvType ty 90 | 91 | 92 | cconvType :: MonadCConv m => Type -> m Type 93 | cconvType = \case 94 | TArr t1 t2 -> TArr <$> cconvType t1 <*> cconvType t2 95 | TCon n -> TCon <$> pure n 96 | 97 | TInt i -> pure $ TInt i 98 | TUInt i -> pure $ TUInt i 99 | TFp i -> pure $ TFp i 100 | 101 | TTuple t ts -> 102 | TTuple <$> cconvType t <*> mapM cconvType ts 103 | 104 | TArray i ty -> 105 | TArray i <$> cconvType ty 106 | 107 | TVect i ty -> 108 | TVect i <$> cconvType ty 109 | 110 | TPtr ty -> TPtr <$> cconvType ty 111 | TLoc ty l -> TLoc <$> cconvType ty <*> pure l 112 | TParens ty -> TParens <$> cconvType ty 113 | 114 | 115 | cconvExp :: MonadCConv m => Exp -> m Exp 116 | cconvExp = \case 117 | EVar v -> EVar <$> pure v 118 | 119 | ELit l -> ELit <$> cconvLit l 120 | EApp f xs -> EApp <$> cconvExp f <*> mapM cconvExp xs 121 | 122 | EType e ty -> EType <$> cconvExp e <*> cconvType ty 123 | ECast e ty -> ECast <$> cconvExp e <*> cconvType ty 124 | ELoc e l -> ELoc <$> cconvExp e <*> pure l 125 | EParens e -> EParens <$> cconvExp e 126 | 127 | ELam bnd -> do 128 | locals <- envNames <$> ask 129 | (ps, body) <- unbind bnd 130 | ps' <- mapM cconvPat ps 131 | let lam_free = name2String <$> (toListOf fv bnd :: [Var]) 132 | closure_ns = Set.intersection locals (Set.fromList lam_free) 133 | closure_vars = s2n <$> Set.toList closure_ns 134 | e_cl = case closure_vars of 135 | [] -> ELit LNull 136 | [x] -> EVar x 137 | x:xs -> ETuple (EVar x) (EVar <$> NE.fromList xs) 138 | 139 | p_cl = case closure_vars of 140 | [] -> PWild 141 | [x] -> PVar x 142 | x:xs -> PTuple (PVar x) (PVar <$> NE.fromList xs) 143 | 144 | body' <- withNames (fst <$> concatMap patVars (NE.toList ps')) $ cconvExp body 145 | if length lam_free == 0 then 146 | return $ ELam (bind ps' body') 147 | else 148 | return $ EApp (ELam (bind (NE.cons p_cl ps') body')) (pure e_cl) 149 | 150 | 151 | ELet bnd -> do 152 | (unrec -> qs, body) <- unbind bnd 153 | let ps = fst <$> qs 154 | es = (unembed . snd) <$> qs 155 | ps' <- mapM cconvPat ps 156 | withNames (fst <$> concatMap patVars ps') $ do 157 | es' <- mapM cconvExp es 158 | body' <- cconvExp body 159 | return $ ELet (bind (rec $ NE.zip ps' (embed <$> es')) body') 160 | 161 | 162 | EIf p t f -> EIf <$> cconvExp p <*> cconvExp t <*> cconvElse f 163 | ECase e cs -> ECase <$> cconvExp e <*> mapM cconvClause cs 164 | 165 | ERef e -> ERef <$> cconvExp e 166 | EDeref e -> EDeref <$> cconvExp e 167 | 168 | ETuple e es -> ETuple <$> cconvExp e <*> mapM cconvExp es 169 | ECon n es -> 170 | ECon <$> pure n <*> mapM cconvExp es 171 | ENewCon n es -> 172 | ENewCon <$> pure n <*> mapM cconvExp es 173 | EFree e -> EFree <$> cconvExp e 174 | 175 | EGet a str -> EGet <$> cconvExp a <*> pure str -- lol check member names you doofus 176 | EGetI a b -> EGetI <$> cconvExp a <*> cconvExp b 177 | ESet a b -> ESet <$> cconvExp a <*> cconvExp b 178 | 179 | ENewArray es -> ENewArray <$> mapM cconvExp es 180 | ENewArrayI i -> ENewArrayI <$> cconvExp i 181 | EResizeArray e i -> EResizeArray <$> cconvExp e <*> cconvExp i 182 | 183 | ENewVect es -> ENewVect <$> mapM cconvExp es 184 | ENewVectI i -> ENewVectI <$> cconvExp i 185 | 186 | ENewString str -> pure $ ENewString str 187 | EOp op -> EOp <$> cconvOp op 188 | 189 | 190 | cconvLit :: MonadCConv m => Lit -> m Lit 191 | cconvLit = \case 192 | LNull -> pure LNull 193 | LBool b -> pure $ LBool b 194 | LInt i -> pure $ LInt i 195 | LDouble i -> pure $ LDouble i 196 | LChar c -> pure $ LChar c 197 | LString str -> pure $ LString str 198 | LArray es -> LArray <$> mapM cconvExp es 199 | LArrayI i -> LArrayI <$> cconvExp i 200 | LVect es -> LVect <$> mapM cconvExp es 201 | LVectI i -> LVectI <$> cconvExp i 202 | 203 | 204 | cconvElse :: MonadCConv m => Else -> m Else 205 | cconvElse = \case 206 | Else may_l body -> 207 | Else may_l <$> cconvExp body 208 | 209 | Elif may_l p t f -> do 210 | Elif may_l <$> cconvExp p <*> cconvExp t <*> cconvElse f 211 | 212 | 213 | cconvOp :: MonadCConv m => Op -> m Op 214 | cconvOp = \case 215 | OpAdd a b -> OpAdd <$> cconvExp a <*> cconvExp b 216 | OpSub a b -> OpSub <$> cconvExp a <*> cconvExp b 217 | OpMul a b -> OpMul <$> cconvExp a <*> cconvExp b 218 | OpDiv a b -> OpDiv <$> cconvExp a <*> cconvExp b 219 | OpRem a b -> OpRem <$> cconvExp a <*> cconvExp b 220 | OpNeg a -> OpNeg <$> cconvExp a 221 | 222 | 223 | OpAnd a b -> OpAnd <$> cconvExp a <*> cconvExp b 224 | OpOr a b -> OpOr <$> cconvExp a <*> cconvExp b 225 | OpXor a b -> OpXor <$> cconvExp a <*> cconvExp b 226 | 227 | OpShR a b -> OpShR <$> cconvExp a <*> cconvExp b 228 | OpShL a b -> OpShL <$> cconvExp a <*> cconvExp b 229 | 230 | OpEq a b -> OpEq <$> cconvExp a <*> cconvExp b 231 | OpNeq a b -> OpNeq <$> cconvExp a <*> cconvExp b 232 | 233 | OpLT a b -> OpLT <$> cconvExp a <*> cconvExp b 234 | OpLE a b -> OpLE <$> cconvExp a <*> cconvExp b 235 | 236 | OpGT a b -> OpGT <$> cconvExp a <*> cconvExp b 237 | OpGE a b -> OpGE <$> cconvExp a <*> cconvExp b 238 | 239 | 240 | cconvPat :: MonadCConv m => Pat -> m Pat 241 | cconvPat = \case 242 | PVar v -> return $ PVar v 243 | PCon n ps -> 244 | PCon <$> pure n <*> mapM cconvPat ps 245 | 246 | PTuple p ps -> 247 | PTuple <$> cconvPat p <*> mapM cconvPat ps 248 | 249 | PWild -> pure PWild 250 | 251 | PType p ty -> 252 | PType <$> cconvPat p <*> cconvType ty 253 | 254 | PLoc p l -> PLoc <$> cconvPat p <*> pure l 255 | PParens p -> PParens <$> cconvPat p 256 | 257 | 258 | cconvClause :: MonadCConv m => Clause -> m Clause 259 | cconvClause (Clause may_l bnd) = do 260 | (p, e) <- unbind bnd 261 | p' <- cconvPat p 262 | e' <- withNames (fst <$> patVars p') $ cconvExp e 263 | return $ Clause may_l (bind p' e') -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Desugar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase 2 | , FlexibleContexts 3 | , RankNTypes 4 | , ConstraintKinds 5 | , TupleSections 6 | , ViewPatterns 7 | , OverloadedStrings 8 | #-} 9 | module Language.STLC.Desugar where 10 | 11 | import Language.Syntax.Location 12 | import Language.STLC.Syntax 13 | import qualified Language.LLTT.Syntax as LL 14 | 15 | import Language.STLC.Reduce 16 | 17 | import Control.Monad.Reader 18 | import Data.Bifunctor 19 | import Data.List.NonEmpty () 20 | import qualified Data.List.NonEmpty as NE 21 | import Data.Bitraversable () 22 | 23 | import Unbound.Generics.LocallyNameless 24 | import Unbound.Generics.LocallyNameless.Name (name2String) 25 | 26 | import Data.Text.Prettyprint.Doc 27 | 28 | -- This pass produces a desugared STLC syntax tree. 29 | -- The end result of desugaring is a Low-Level Type 30 | -- Theory (LLTT) ast. 31 | -- This is a form of the STLC which can be easily 32 | -- translated into LLVM IR. 33 | 34 | type MonadDesugar m = (Fresh m, MonadReader Loc m) 35 | 36 | withLoc :: MonadDesugar m => Loc -> m a -> m a 37 | withLoc l = local (const l) 38 | 39 | askLoc :: MonadDesugar m => m Loc 40 | askLoc = ask 41 | 42 | desugarModule :: Module -> LL.Module 43 | desugarModule (Module l n defns) 44 | = LL.Module l n $ runFreshM $ runReaderT (mapM desugarDefn defns) l 45 | 46 | 47 | desugarDefn :: MonadDesugar m => Defn -> m LL.Defn 48 | desugarDefn = \case 49 | FuncDefn f -> LL.FuncDefn <$> desugarFunc f 50 | ExternDefn ex -> return $ LL.ExternDefn (desugarExtern ex) 51 | DataTypeDefn dt -> return $ LL.DataTypeDefn (desugarDataType dt) 52 | 53 | desugarExtern :: Extern -> LL.Extern 54 | desugarExtern (Extern l n paramtys retty) 55 | = LL.Extern l n (desugarType <$> paramtys) (desugarType retty) 56 | 57 | desugarDataType :: DataType -> LL.DataType 58 | desugarDataType (DataType l n cs) 59 | = LL.DataType l n (desugarConstrDefn <$> cs) 60 | 61 | 62 | desugarConstrDefn :: ConstrDefn -> LL.ConstrDefn 63 | desugarConstrDefn = \case 64 | ConstrDefn l n tys -> LL.ConstrDefn l n (desugarType <$> tys) 65 | RecordDefn l n ens -> LL.RecordDefn l n (desugarEntry <$> ens) 66 | 67 | 68 | desugarEntry :: Entry -> LL.Entry 69 | desugarEntry (Entry l n ty) = LL.Entry l n (desugarType ty) 70 | 71 | desugarFunc :: MonadDesugar m => Func -> m LL.Func 72 | desugarFunc (Func l _ fn_n bnd) = withLoc l $ do 73 | (ps, body) <- unbind bnd 74 | let ps' = desugarPat <$> ps 75 | body' <- desugarExp body 76 | return $ LL.Func l fn_n ps' body' 77 | 78 | desugarExp :: MonadDesugar m => Exp -> m LL.Exp 79 | desugarExp e@(exType -> ty) = desugarExp' ty e 80 | 81 | 82 | desugarExp' :: MonadDesugar m => Type -> Exp -> m LL.Exp 83 | desugarExp' ty = \case 84 | EVar n -> 85 | return $ LL.EVar . name2String $ n 86 | 87 | ELit l -> LL.ELit <$> desugarLit l 88 | 89 | EApp f xs -> 90 | LL.ECall <$> desugarExp f <*> mapM desugarExp xs 91 | 92 | EType e ty' -> LL.EType <$> desugarExp' ty' e <*> pure (desugarType ty') 93 | ECast e ty' -> LL.ECast <$> desugarExp e <*> pure (desugarType ty') 94 | 95 | ELoc e l -> withLoc l $ LL.ELoc <$> desugarExp' ty e <*> pure l 96 | EParens e -> LL.EParens <$> desugarExp' ty e 97 | 98 | ELam _ -> error "Unlifted lambda expression encountered!" 99 | 100 | ELet bnd -> do 101 | (unrec -> letbnds, body) <- unbind bnd 102 | let (ps, es) = NE.unzip (second unembed <$> letbnds) 103 | let ps' = desugarPat <$> ps 104 | es' <- mapM desugarExp es 105 | let rhs = NE.zip ps' es' 106 | body' <- desugarExp body 107 | return $ LL.ELet rhs body' 108 | 109 | EIf p t f -> LL.EIf <$> desugarExp p <*> desugarExp t <*> desugarElse f 110 | 111 | ECase e cls -> 112 | case exTyAnn (exType e) of 113 | TCon _ -> LL.EMatch <$> desugarExp e <*> mapM desugarClause cls 114 | t | t `elem` intTypes -> LL.EMatch <$> desugarExp e <*> mapM desugarClause cls 115 | _ -> error "Case analysis on unsupported type!" 116 | -- At some point, it would be nice if case could work with any type... 117 | 118 | ERef e -> 119 | LL.ERef <$> desugarExp e 120 | 121 | EDeref e -> 122 | LL.EDeref <$> desugarExp e 123 | 124 | ETuple x xs -> 125 | LL.ETuple <$> desugarExp x <*> mapM desugarExp xs 126 | 127 | ECon n xs -> LL.ECon n <$> mapM desugarExp xs 128 | ENewCon n xs -> LL.ENewCon n <$> mapM desugarExp xs 129 | 130 | EFree e -> LL.EFree <$> desugarExp e 131 | EGet e m -> LL.EGet <$> desugarExp e <*> pure m 132 | EGetI e i -> LL.EGetI <$> desugarExp e <*> desugarExp i 133 | ESet lhs rhs -> LL.ESet <$> desugarExp lhs <*> desugarExp rhs 134 | 135 | ENewArray xs -> LL.ENewArray <$> mapM desugarExp xs 136 | ENewArrayI i -> LL.ENewArrayI <$> desugarExp i 137 | EResizeArray e i -> LL.EResizeArray <$> desugarExp e <*> desugarExp i 138 | 139 | ENewVect es -> LL.ENewVect <$> mapM desugarExp es 140 | ENewVectI i -> LL.ENewVectI <$> desugarExp i 141 | 142 | ENewString s -> return $ LL.ENewString s 143 | 144 | EOp op -> LL.EOp <$> desugarOp op 145 | 146 | 147 | desugarLit :: MonadDesugar m => Lit -> m LL.Lit 148 | desugarLit = \case 149 | LNull -> pure $ LL.LNull 150 | LBool b -> pure $ LL.LBool b 151 | LInt i -> pure $ LL.LInt i 152 | LDouble d -> pure $ LL.LDouble d 153 | LChar c -> pure $ LL.LChar c 154 | LString s -> pure $ LL.LString s 155 | LArray xs -> LL.LArray <$> mapM desugarExp xs 156 | LArrayI i -> 157 | case reduceBy mempty 50 i of 158 | (exEAnn -> ELit (LInt i')) -> return $ LL.LArrayI i' 159 | _ -> error $ "desugar - expected constant integer! Found: " ++ show i 160 | LVect xs -> LL.LVect <$> mapM desugarExp xs 161 | LVectI i -> 162 | case reduceBy mempty 50 i of 163 | (exEAnn -> ELit (LInt i')) -> return $ LL.LVectI i' 164 | _ -> error $ "desugar - expected constant integer! Found: " ++ show i 165 | 166 | 167 | 168 | desugarElse :: MonadDesugar m => Else -> m LL.Else 169 | desugarElse = \case 170 | Else (Just l) e -> withLoc l $ desugarElse $ Else Nothing e 171 | Else Nothing e -> LL.Else <$> fmap Just askLoc <*> desugarExp e 172 | 173 | Elif (Just l) p t f 174 | -> withLoc l $ desugarElse $ Elif Nothing p t f 175 | Elif Nothing p t f 176 | -> LL.Elif <$> fmap Just askLoc <*> desugarExp p <*> desugarExp t <*> desugarElse f 177 | 178 | 179 | desugarOp :: MonadDesugar m => Op -> m LL.Op 180 | desugarOp = \case 181 | OpAdd a b -> LL.OpAdd <$> desugarExp a <*> desugarExp b 182 | OpSub a b -> LL.OpSub <$> desugarExp a <*> desugarExp b 183 | OpMul a b -> LL.OpMul <$> desugarExp a <*> desugarExp b 184 | OpDiv a b -> LL.OpDiv <$> desugarExp a <*> desugarExp b 185 | OpRem a b -> LL.OpRem <$> desugarExp a <*> desugarExp b 186 | OpNeg a -> LL.OpNeg <$> desugarExp a 187 | 188 | OpAnd a b -> LL.OpAnd <$> desugarExp a <*> desugarExp b 189 | OpOr a b -> LL.OpOr <$> desugarExp a <*> desugarExp b 190 | OpXor a b -> LL.OpXor <$> desugarExp a <*> desugarExp b 191 | OpShR a b -> LL.OpShR <$> desugarExp a <*> desugarExp b 192 | OpShL a b -> LL.OpShL <$> desugarExp a <*> desugarExp b 193 | 194 | OpEq a b -> LL.OpEq <$> desugarExp a <*> desugarExp b 195 | OpNeq a b -> LL.OpNeq <$> desugarExp a <*> desugarExp b 196 | 197 | OpLT a b -> LL.OpLT <$> desugarExp a <*> desugarExp b 198 | OpLE a b -> LL.OpLE <$> desugarExp a <*> desugarExp b 199 | OpGT a b -> LL.OpGT <$> desugarExp a <*> desugarExp b 200 | OpGE a b -> LL.OpGE <$> desugarExp a <*> desugarExp b 201 | 202 | desugarType :: Type -> LL.Type 203 | desugarType = \case 204 | ty@(TArr _ _) -> 205 | let (paramtys, retty) = splitType ty 206 | in LL.TFunc (desugarType retty) (NE.fromList $ desugarType <$> paramtys) 207 | 208 | TCon n -> LL.TCon n 209 | TInt i -> LL.TInt i 210 | TUInt i -> LL.TUInt i 211 | TFp i -> LL.TFp i 212 | TTuple t ts -> LL.TTuple (desugarType t) (desugarType <$> ts) 213 | TArray i ty -> LL.TArray i (desugarType ty) 214 | TVect i ty -> LL.TVect i (desugarType ty) 215 | TPtr ty -> LL.TPtr (desugarType ty) 216 | TLoc t l -> LL.TLoc (desugarType t) l 217 | TParens t -> LL.TParens (desugarType t) 218 | 219 | 220 | desugarPat :: Pat -> LL.Pat 221 | desugarPat = \case 222 | PVar v -> LL.PVar (name2String v) 223 | PCon n ps -> LL.PCon n (desugarPat <$> ps) 224 | PTuple p ps -> LL.PTuple (desugarPat p) (desugarPat <$> ps) 225 | PWild -> LL.PWild 226 | PType p ty -> LL.PType (desugarPat p) (desugarType ty) 227 | PLoc p l -> LL.PLoc (desugarPat p) l 228 | PParens p -> LL.PParens (desugarPat p) 229 | 230 | 231 | 232 | desugarClause :: MonadDesugar m => Clause -> m LL.Clause 233 | desugarClause (Clause (Just l) bnd) 234 | = withLoc l $ desugarClause (Clause Nothing bnd) 235 | 236 | desugarClause (Clause Nothing bnd) = do 237 | (p, e) <- unbind bnd 238 | let ns = (Just . fst) <$> patTypedVars p 239 | case exPAnn p of 240 | PCon n _ -> do 241 | e' <- desugarExp e 242 | return $ LL.Clause n ns e' 243 | 244 | _ -> do 245 | l <- ask 246 | error $ show $ vsep [ line <> pretty l <+> "error:" 247 | , indent 4 $ vsep 248 | [ "Simple pattern expected in case clause." 249 | , "Found:" <+> pretty (show (exPAnn p)) 250 | , "in" 251 | , pretty (show p) <+> "=" <+> pretty (show e) 252 | ] 253 | , line 254 | ] 255 | 256 | 257 | -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Match.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds 2 | , FlexibleContexts 3 | , LambdaCase 4 | , ViewPatterns 5 | , TupleSections 6 | #-} 7 | module Language.STLC.Match where 8 | 9 | -- Match generates simple patterns from nested patterns 10 | import Prelude hiding (exp) 11 | 12 | import Control.Monad.Reader 13 | 14 | import Data.Bifunctor 15 | import qualified Data.List.NonEmpty as NE 16 | import Data.Map.Strict (Map) 17 | import qualified Data.Map.Strict as Map 18 | 19 | import Language.Syntax.Location 20 | import Language.STLC.Syntax 21 | 22 | import Unbound.Generics.LocallyNameless 23 | import Unbound.Generics.LocallyNameless.Name (s2n) 24 | 25 | type Equation = ([Pat], Exp) 26 | 27 | type Constr = String 28 | data Env = Env { envArity :: Map Constr Int 29 | , envConstrs :: Map Constr [Constr] 30 | , envConstrTys :: Map Constr Type 31 | , envLoc :: Loc 32 | } 33 | type MonadMatch m = (MonadReader Env m, Fresh m) 34 | 35 | envUpdateLoc :: Loc -> Env -> Env 36 | envUpdateLoc l env = env { envLoc = l } 37 | 38 | withLoc :: MonadMatch m => Loc -> m a -> m a 39 | withLoc l = local (envUpdateLoc l) 40 | 41 | 42 | matchModule :: Module -> Module 43 | matchModule (Module l n defns) 44 | = Module l n defns' 45 | where env = makeEnv l defns 46 | defns' = runFreshM $ runReaderT (mapM matchDefn defns) env 47 | 48 | 49 | makeEnv :: Loc -> [Defn] -> Env 50 | makeEnv l modl = Env { envArity = Map.fromList rs 51 | , envConstrs = Map.fromList cs 52 | , envConstrTys = Map.fromList contys 53 | , envLoc = l 54 | } 55 | where (rs, cs, contys) = foldl (\(rs1, cs1, contys1) (rs2, cs2, contys2) -> 56 | (rs1 ++ rs2, cs1 ++ cs2, contys1 ++ contys2) ) 57 | ([],[], []) 58 | $ map go modl 59 | 60 | -- Extract environment information from datatype definitions 61 | go :: Defn 62 | -> ( [(Constr, Int)] -- ^ Constructor name to constructor arity 63 | , [(Constr, [Constr])] -- ^ Constructor name to sibling constructor names 64 | , [(Constr, Type)]) -- ^ Constructor name to type 65 | go = \case 66 | DataTypeDefn (DataType _ dt_n dt_cons) -> 67 | let cons = constrName <$> dt_cons 68 | rs_i = second constrArity <$> zip cons dt_cons 69 | cs_i = (,cons) <$> cons 70 | contys_i = zip cons (repeat $ TCon dt_n) 71 | in (rs_i, cs_i, contys_i) 72 | 73 | _ -> 74 | ([], [], []) 75 | 76 | matchDefn :: MonadMatch m => Defn -> m Defn 77 | matchDefn = \case 78 | FuncDefn f -> FuncDefn <$> matchFunc f 79 | defn -> pure defn 80 | 81 | matchFunc :: MonadMatch m => Func -> m Func 82 | matchFunc (Func l ty f bnd) = withLoc l $ do 83 | (ps, body) <- unbind bnd 84 | body' <- matchExp body 85 | let bnd' = bind ps body' 86 | return $ Func l ty f bnd' 87 | 88 | matchExp :: MonadMatch m => Exp -> m Exp 89 | matchExp exp = case exp of 90 | EVar _ -> return exp 91 | ELit _ -> return exp 92 | EApp f xs -> EApp <$> matchExp f <*> (mapM matchExp xs) 93 | 94 | EType e ty -> EType <$> matchExp e <*> pure ty 95 | ECast e ty -> ECast <$> matchExp e <*> pure ty 96 | 97 | ELoc e l -> ELoc <$> withLoc l (matchExp e) <*> pure l 98 | EParens e -> EParens <$> matchExp e 99 | 100 | ELam _ -> error "Pattern matching on unlifted expressions is unsupported" 101 | 102 | ELet bnd -> do 103 | (unrec -> qs, body) <- unbind bnd 104 | es' <- mapM (matchExp . unembed . snd) qs 105 | let qs' = NE.zip (fst <$> qs) (embed <$> es') 106 | body' <- matchExp body 107 | let bnd' = bind (rec qs') body' 108 | return $ ELet bnd' 109 | 110 | EIf p t f -> 111 | EIf <$> matchExp p <*> matchExp t <*> matchElse f 112 | 113 | ECase e@(exType -> ty) clauses -> do 114 | v <- fresh (s2n "match.e") 115 | e' <- matchExp e 116 | qs' <- forM clauses $ \(Clause _ bnd) -> 117 | do (p, body) <- unbind bnd 118 | body' <- matchExp body 119 | return ([p], body') 120 | 121 | body <- match [v] (NE.toList qs') 122 | (eapp "error" [ELit $ LString "Default match"]) 123 | return $ elet [(PType (PVar v) ty, e')] body 124 | 125 | ERef e -> ERef <$> matchExp e 126 | EDeref e -> EDeref <$> matchExp e 127 | 128 | ETuple x xs -> ETuple <$> matchExp x <*> mapM matchExp xs 129 | ECon n xs -> ECon n <$> mapM matchExp xs 130 | ENewCon n xs -> ENewCon n <$> mapM matchExp xs 131 | EFree e -> EFree <$> matchExp e 132 | 133 | EGet e mem_n -> EGet <$> matchExp e <*> pure mem_n 134 | EGetI e i -> EGetI <$> matchExp e <*> matchExp i 135 | ESet lhs rhs -> ESet <$> matchExp lhs <*> matchExp rhs 136 | 137 | ENewArray xs -> ENewArray <$> mapM matchExp xs 138 | ENewArrayI i -> ENewArrayI <$> matchExp i 139 | EResizeArray e i -> EResizeArray <$> matchExp e <*> matchExp i 140 | 141 | ENewVect xs -> ENewVect <$> mapM matchExp xs 142 | ENewVectI i -> ENewVectI <$> matchExp i 143 | 144 | ENewString _ -> return exp 145 | 146 | EOp op -> EOp <$> matchOp op 147 | 148 | matchElse :: MonadMatch m => Else -> m Else 149 | matchElse = \case 150 | Elif Nothing p t f 151 | -> Elif Nothing <$> matchExp p <*> matchExp t <*> matchElse f 152 | Elif (Just l) p t f 153 | -> withLoc l $ Elif (Just l) <$> matchExp p <*> matchExp t <*> matchElse f 154 | 155 | Else Nothing e -> Else Nothing <$> matchExp e 156 | Else (Just l) e -> withLoc l $ Else (Just l) <$> matchExp e 157 | 158 | matchOp :: MonadMatch m => Op -> m Op 159 | matchOp = \case 160 | OpAdd a b -> OpAdd <$> matchExp a <*> matchExp b 161 | OpSub a b -> OpSub <$> matchExp a <*> matchExp b 162 | OpMul a b -> OpMul <$> matchExp a <*> matchExp b 163 | OpDiv a b -> OpDiv <$> matchExp a <*> matchExp b 164 | OpRem a b -> OpRem <$> matchExp a <*> matchExp b 165 | OpNeg a -> OpNeg <$> matchExp a 166 | 167 | OpAnd a b -> OpAnd <$> matchExp a <*> matchExp b 168 | OpOr a b -> OpOr <$> matchExp a <*> matchExp b 169 | OpXor a b -> OpXor <$> matchExp a <*> matchExp b 170 | OpShR a b -> OpShR <$> matchExp a <*> matchExp b 171 | OpShL a b -> OpShL <$> matchExp a <*> matchExp b 172 | 173 | OpEq a b -> OpEq <$> matchExp a <*> matchExp b 174 | OpNeq a b -> OpNeq <$> matchExp a <*> matchExp b 175 | OpLT a b -> OpLT <$> matchExp a <*> matchExp b 176 | OpGT a b -> OpGT <$> matchExp a <*> matchExp b 177 | OpGE a b -> OpGE <$> matchExp a <*> matchExp b 178 | OpLE a b -> OpLE <$> matchExp a <*> matchExp b 179 | 180 | 181 | 182 | arity :: MonadMatch m => String -> m Int 183 | arity c = reader (Map.lookup c . envArity) >>= maybe err return 184 | where err = error $ "Match: unrecognized constructor name: " ++ c 185 | 186 | constrs :: MonadMatch m => String -> m [String] 187 | constrs c = reader (Map.lookup c . envConstrs) >>= maybe err return 188 | where err = error $ "Match: unrecognized constructor name: " ++ c 189 | 190 | 191 | constrTys :: MonadMatch m => String -> m Type 192 | constrTys c = reader (Map.lookup c . envConstrTys) >>= maybe err return 193 | where err = error $ "Match: unrecognized constructor name: " ++ c 194 | 195 | 196 | isVar :: Equation -> Bool 197 | isVar ((PVar _):_, _) = True 198 | isVar ((PCon _ _):_, _) = False 199 | isVar ((PWild):_, _) = True 200 | isVar ((PType p _):ps, e) = isVar (p:ps, e) 201 | isVar _ = undefined 202 | 203 | isCon :: Equation -> Bool 204 | isCon ((PVar _):_, _) = False 205 | isCon ((PCon _ _):_, _) = True 206 | isCon ((PWild):_, _) = False 207 | isCon ((PType p _):ps, e) = isCon (p:ps, e) 208 | isCon _ = undefined 209 | 210 | getCon :: Equation -> String 211 | getCon ((PCon n _):_, _) = n 212 | getCon ((PType p _):ps, e) = getCon (p:ps, e) 213 | getCon _ = error "expected constructor pattern!!" 214 | 215 | getEqType :: Equation -> Type 216 | getEqType (_, EType _ ty) = ty 217 | getEqType _ = error "Expected equation type!!" 218 | 219 | getEqPatType :: Equation -> Type 220 | getEqPatType ((PType _ ty):_, _) = ty 221 | getEqPatType eq = error $ "getEqPatType - Expected typed pattern:\n\n" ++ show eq ++ "\n\n" 222 | 223 | partition :: Eq q => (a -> q) -> [a] -> [[a]] 224 | partition _ [] = [] 225 | partition _ [x] = [[x]] 226 | partition f (x:xs@(x':_)) 227 | | f x == f x' = tack x (partition f xs) 228 | | otherwise = [x]:(partition f xs) 229 | 230 | tack :: x -> [[x]] -> [[x]] 231 | tack x xss = (x : head xss) : tail xss 232 | 233 | 234 | match :: MonadMatch m => [Var] -> [Equation] -> Exp -> m Exp 235 | match [] ((_, e):_) _ = pure e 236 | match us qs def 237 | = foldM (flip $ matchVarCon us) def (reverse $ partition isVar qs) 238 | 239 | 240 | matchVarCon :: MonadMatch m => [Var] -> [Equation] -> Exp -> m Exp 241 | matchVarCon us qs def 242 | | isVar (head qs) = matchVar us qs def 243 | | isCon (head qs) = matchCon us qs def 244 | | otherwise = undefined 245 | 246 | matchVar :: MonadMatch m => [Var] -> [Equation] -> Exp -> m Exp 247 | matchVar [] _ _ = undefined 248 | matchVar (u:us) qs def 249 | = match us [(ps, subst v (EVar u) e) | (PType (PVar v) _ : ps, e) <- qs] def 250 | 251 | matchCon :: MonadMatch m => [Var] -> [Equation] -> Exp -> m Exp 252 | matchCon [] _ _ = undefined 253 | matchCon (u:us) qs def = do 254 | cs <- constrs (getCon (head qs)) 255 | cs' <- mapM (\c -> matchClause c (u:us) (choose c qs) def) cs 256 | let ty = getEqType (head qs) 257 | uty = getEqPatType (head qs) 258 | l <- reader envLoc 259 | return $ ELoc (EType (ECase (EType (EVar u) uty) (NE.fromList cs')) ty) l 260 | 261 | 262 | matchClause :: MonadMatch m => Constr -> [Var] -> [Equation] -> Exp -> m Clause 263 | matchClause _ [] _ _ = undefined 264 | matchClause c (_:us) qs def = do 265 | let ty = getEqPatType (head qs) 266 | conty <- constrTys c 267 | k <- arity c 268 | us' <- mapM (\_ -> fresh (s2n "match.x")) [1..k] 269 | body <- match (us' ++ us) [(ps' ++ ps, e) | ((PType (PCon _ ps') _):ps, e) <- qs] def 270 | l <- reader envLoc 271 | return $ Clause (Just l) (bind (PType (PCon c (PType <$> (PVar <$> us') <*> pure ty)) conty) body) 272 | 273 | choose :: String -> [Equation] -> [Equation] 274 | choose c qs = [q | q <- qs, getCon q == c] -------------------------------------------------------------------------------- /ttc/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ApplicativeDo #-} 5 | module Main where 6 | 7 | import Data.Map.Strict (Map) 8 | import qualified Data.Map.Strict as Map 9 | 10 | import Data.List 11 | import Data.Maybe (fromMaybe) 12 | 13 | import qualified Data.Text.IO as T 14 | 15 | import Compiler 16 | 17 | import Language.STLC.Desugar 18 | import Language.STLC.Match 19 | import Language.STLC.Pretty 20 | import Language.STLC.Syntax 21 | import Language.STLC.TypeCheck 22 | 23 | import Language.LLTT.Pretty 24 | import Language.LLTT.LLVM.Codegen 25 | 26 | import qualified LLVM.Module as LLVM 27 | import qualified LLVM.Internal.Context as LLVM 28 | import qualified LLVM.AST as AST 29 | 30 | import Unbound.Generics.LocallyNameless 31 | 32 | 33 | import Data.Text.Prettyprint.Doc (Pretty (..)) 34 | import Data.Text.Prettyprint.Doc.Render.Text (hPutDoc) 35 | 36 | import System.IO 37 | import Options.Applicative 38 | {- 39 | 40 | mallocExtern = ExternDefn $ Extern "malloc" [TI32] (TPtr TI8) 41 | freeExtern = ExternDefn $ Extern "free" [TPtr TI8] (TVoid) 42 | memcpyExtern = ExternDefn $ Extern "memcpy" [TPtr TI8, TPtr TI8, TI32] (TPtr TI8) 43 | putsExtern = ExternDefn $ Extern "puts" [TString] TI32 44 | 45 | 46 | derefIntFunc = FuncDefn $ func "derefInt" 47 | (tarr [TPtr TI32] TI32) 48 | [(PType (pvar "a") (TPtr TI32))] 49 | body 50 | where body = EDeref (evar "a") 51 | 52 | maybeIntType = DataTypeDefn $ DataType "MaybeInt" [("Nothing", []), ("Just", [(Nothing, TI32)])] 53 | 54 | iVector3Type = DataTypeDefn $ DataType "IVector3" [("V3", [(Just "x", TI32), (Just "y", TI32), (Just "z", TI32)])] 55 | 56 | nothingFunc = FuncDefn $ func "nothing" (TCon "MaybeInt") [] body 57 | where body = ECon "Nothing" [] 58 | 59 | just5Func = FuncDefn $ func "just5" (TPtr $ TCon "MaybeInt") [] body 60 | where body = ENewCon "Just" [ELit $ LInt 5] 61 | 62 | 63 | dotFunc = FuncDefn $ func "dot" 64 | ( tarr [TCon "IVector3", TCon "IVector3"] TI32 ) 65 | [ PType (pvar "v1") (TCon "IVector3") 66 | , PType (pvar "v2") (TCon "IVector3") ] 67 | body 68 | where body = elet [ (pvar "x1", EGet (evar "v1") "x") 69 | , (pvar "y1", EGet (evar "v1") "y") 70 | , (pvar "z1", EGet (evar "v1") "z") 71 | , (pvar "x2", EGet (evar "v2") "x") 72 | , (pvar "y2", EGet (evar "v2") "y") 73 | , (pvar "z2", EGet (evar "v2") "z") 74 | , (pvar "a1", EOp $ OpMulI (evar "x1") (evar "x2")) 75 | , (pvar "a2", EOp $ OpMulI (evar "y1") (evar "y2")) 76 | , (pvar "a3", EOp $ OpMulI (evar "z1") (evar "z2")) 77 | , (pvar "a4", EOp $ OpAddI (evar "a1") (evar "a2")) 78 | , (pvar "a5", EOp $ OpAddI (evar "a3") (evar "a4")) ] 79 | $ evar "a5" 80 | 81 | 82 | exMaybeFunc = FuncDefn $ func "exMaybe" 83 | (tarr [TCon "MaybeInt"] TI32) 84 | [PType (pvar "may_x") (TCon "MaybeInt")] 85 | body 86 | where body = ecase (evar "may_x") 87 | [ (PCon "Just" [pvar "x"], evar "x") 88 | , (PCon "Nothing" [], ELit $ LInt 0) 89 | ] 90 | 91 | addFunc = FuncDefn $ func "add" 92 | (tarr [TI32, TI32] TI32) 93 | [ PType (pvar "a") TI32 94 | , PType (pvar "b") TI32] 95 | body 96 | where body = EOp $ OpAddI (evar "a") (evar "b") 97 | 98 | mulFunc = FuncDefn $ func "mul" 99 | (tarr [TI32, TI32] TI32) 100 | [ PType (pvar "a") TI32 101 | , PType (pvar "b") TI32] 102 | body 103 | where body = EOp $ OpMulI (evar "a") (evar "b") 104 | 105 | constFunc = FuncDefn $ func "const" 106 | (tarr [TI32, TI32] TI32) 107 | [ PType (pvar "a") TI32 108 | , PType (pvar "b") TI32] 109 | body 110 | where body = evar "a" 111 | 112 | idFunc = FuncDefn $ func "id" 113 | (tarr [TI32] TI32) 114 | [ PType (pvar "x") TI32 ] 115 | body 116 | where body = evar "x" 117 | 118 | 119 | idMaybeFunc = FuncDefn $ func "idMaybe" 120 | (tarr [TCon "MaybeInt"] (TCon "MaybeInt")) 121 | [ PType (pvar "x") (TCon "MaybeInt") ] 122 | body 123 | where body = evar "x" 124 | 125 | 126 | addMulFunc = FuncDefn $ func "addMul" 127 | (tarr [TI32, TI32, TI32] TI32) 128 | [ PType (pvar "a") TI32 129 | , PType (pvar "b") TI32 130 | , PType (pvar "c") TI32] 131 | body 132 | where body = elet [ (pvar "d", eapp "add" [evar "a", evar "b"]) 133 | , (pvar "e", eapp "mul" [evar "d", evar "c"]) ] 134 | $ eapp "id" [evar "e"] 135 | 136 | 137 | maybeAddMulFunc = FuncDefn $ func "maybeAddMul" 138 | ( tarr [ TCon "MaybeInt" 139 | , TCon "MaybeInt" 140 | , TCon "MaybeInt" ] 141 | (TCon "MaybeInt") ) 142 | [ PType (pvar "may_a") (TCon "MaybeInt") 143 | , PType (pvar "may_b") (TCon "MaybeInt") 144 | , PType (pvar "may_c") (TCon "MaybeInt") ] 145 | body 146 | where body = ecase (evar "may_a") 147 | [ ( PCon "Nothing" [], ECon "Nothing" []) 148 | , ( PCon "Just" [pvar "a"], case2) ] 149 | case2 = ecase (evar "may_b") 150 | [ (PCon "Nothing" [] , ECon "Nothing" []) 151 | , (PCon "Just" [pvar "b"], case3) ] 152 | case3 = ecase (evar "may_c") 153 | [ (PCon "Nothing" [], ECon "Nothing" []) 154 | , (PCon "Just" [pvar "c"], let1) ] 155 | let1 = elet [ (pvar "d", eapp "addMul" [evar "a", evar "b", evar "c"]) ] 156 | (ECon "Just" [evar "d"]) 157 | 158 | mainFunc = FuncDefn $ func "main" 159 | (tarr [TI32, TPtr (TPtr TI8)] TI32) 160 | [ pvar "argc", pvar "argv" ] 161 | body 162 | where body = elet [ (pvar "hello", ELit $ LString "Hello World") 163 | , (pvar "five", ELit $ LString "5") 164 | , (pvar "may_5_ptr", evar "just5") 165 | , (pvar "may_5", EDeref $ evar "may_5_ptr") 166 | , (pvar "may_not", evar "nothing") ] 167 | case1 168 | case1 = ecase (evar "may_5") 169 | [ (PCon "Nothing" [], eapp "puts" [evar "hello"]) 170 | , (PCon "Just" [pvar "c"], eapp "puts" [evar "five"]) 171 | ] 172 | 173 | testSource :: Module 174 | testSource 175 | = Module "Test" 176 | [ mallocExtern 177 | , freeExtern 178 | , memcpyExtern 179 | , putsExtern 180 | , derefIntFunc 181 | , maybeIntType 182 | , iVector3Type 183 | , nothingFunc 184 | , just5Func 185 | , dotFunc 186 | , exMaybeFunc 187 | , addFunc 188 | , mulFunc 189 | , constFunc 190 | , idFunc 191 | , idMaybeFunc 192 | , addMulFunc 193 | , maybeAddMulFunc 194 | , mainFunc 195 | ] 196 | 197 | 198 | compileModule :: FilePath -> Module -> IO () 199 | compileModule fp modl = do 200 | let stlc = modl 201 | withFile (fp ++ ".stlc") WriteMode $ \h -> 202 | hPutDoc h $ pretty stlc 203 | 204 | let stlc = modl 205 | withFile (fp ++ ".stlc") WriteMode $ \h -> 206 | hPutDoc h $ pretty stlc 207 | 208 | let stlc' = checkModule stlc 209 | withFile (fp ++ "-typed.stlc") WriteMode $ \h -> 210 | hPutDoc h $ pretty stlc' 211 | 212 | --let stlc'' = matchModule stlc' 213 | --withFile (fp ++ "-matched.stlc") WriteMode $ \h -> 214 | -- hPutDoc h $ pretty stlc'' 215 | 216 | let lltc = desugarModule stlc' 217 | withFile (fp ++ ".lltt") WriteMode $ \h -> 218 | hPutDoc h $ pretty lltc 219 | 220 | let llvmir = genModule envEmpty lltc 221 | LLVM.withContext $ \c -> LLVM.withModuleFromAST c llvmir (LLVM.writeLLVMAssemblyToFile (LLVM.File (fp ++ ".ll"))) 222 | -} 223 | 224 | 225 | data Options 226 | = Options { optInputs :: [String] 227 | , optOutput :: String 228 | , optOutputIR :: Bool 229 | , optBuildDir :: FilePath 230 | } 231 | deriving (Eq, Show) 232 | 233 | options :: Parser Options 234 | options = do 235 | optOutputIR <- switch 236 | ( long "output-ir" 237 | <> help "Output all ir representations" ) 238 | optOutput <- strOption 239 | ( long "output" 240 | <> short 'o' 241 | <> metavar "FILE" 242 | <> value "a.out" 243 | <> help "Write output to FILE" ) 244 | optBuildDir <- strOption 245 | ( long "build-dir" 246 | <> metavar "FILE" 247 | <> value "./" 248 | <> help "Write build output to FILE" ) 249 | optInputs <- many (argument str idm) 250 | pure Options {..} 251 | 252 | opt2c :: Options -> Compiler 253 | opt2c Options {..} 254 | = mkCompiler 255 | { cInputs = optInputs 256 | , cOutput = optOutput 257 | , cOutputIR = optOutputIR 258 | , cBuildDir = optBuildDir 259 | } 260 | 261 | opts :: ParserInfo Options 262 | opts = info (options <**> helper) idm 263 | 264 | main :: IO () 265 | main = execParser opts >>= runCompiler . opt2c -------------------------------------------------------------------------------- /lltt/src/Language/LLTT/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, ViewPatterns #-} 2 | module Language.LLTT.Syntax where 3 | 4 | import Language.Syntax.Location 5 | 6 | import Data.List.NonEmpty (NonEmpty) 7 | import qualified Data.List.NonEmpty as NE 8 | 9 | import Data.Map.Strict (Map) 10 | import qualified Data.Map.Strict as Map 11 | 12 | -- A-Normal Form Simply Typed Lambda Calculus 13 | -- Invariants: Fully Type Annotated 14 | -- , Lambda Lifted 15 | -- , Monomorphic 16 | -- , No Partial Application 17 | -- , No Nested Applications 18 | -- , Single-level Pattern matching 19 | 20 | --------------------------------------------------------------------------- 21 | -- Module and Definitions 22 | --------------------------------------------------------------------------- 23 | 24 | data Module = Module Loc String [Defn] 25 | 26 | data Defn 27 | = FuncDefn Func 28 | | ExternDefn Extern 29 | | DataTypeDefn DataType 30 | deriving(Show) 31 | 32 | data Func = Func Loc String [Pat] Exp 33 | deriving(Show) 34 | 35 | data Extern = Extern Loc String [Type] Type 36 | deriving(Show) 37 | 38 | 39 | data SName = SName String NameClass 40 | 41 | data NameClass 42 | = VarName 43 | | ConName 44 | | TyConName 45 | 46 | getModuleNames :: Module -> [(SName, Loc)] 47 | getModuleNames (Module _ _ body) 48 | = concatMap getDefnNames body 49 | 50 | getDefnNames :: Defn -> [(SName, Loc)] 51 | getDefnNames = \case 52 | FuncDefn (Func l n _ _) -> [(SName n VarName, l)] 53 | ExternDefn (Extern l n _ _) -> [(SName n VarName, l)] 54 | DataTypeDefn dt -> getDataTypeNames dt 55 | 56 | --------------------------------------------------------------------------- 57 | -- Data Types 58 | --------------------------------------------------------------------------- 59 | 60 | data DataType = 61 | DataType Loc String [ConstrDefn] 62 | deriving(Show) 63 | 64 | data ConstrDefn 65 | = ConstrDefn Loc String [Type] 66 | | RecordDefn Loc String (NonEmpty Entry) 67 | deriving (Show) 68 | 69 | constrName :: ConstrDefn -> String 70 | constrName = \case 71 | ConstrDefn _ n _ -> n 72 | RecordDefn _ n _ -> n 73 | 74 | data Entry = Entry Loc String Type 75 | deriving (Show) 76 | 77 | 78 | getDataTypeNames :: DataType -> [(SName, Loc)] 79 | getDataTypeNames (DataType l n constrs) 80 | = (SName n TyConName, l) : concatMap getConstrNames constrs 81 | 82 | getConstrNames :: ConstrDefn -> [(SName, Loc)] 83 | getConstrNames = \case 84 | ConstrDefn l n _ -> [(SName n ConName, l)] 85 | RecordDefn l n (NE.toList -> es) 86 | -> (SName n ConName, l) : (concatMap getEntryNames es) 87 | 88 | getEntryNames :: Entry -> [(SName, Loc)] 89 | getEntryNames (Entry l n _) = [(SName n VarName, l)] 90 | 91 | 92 | --------------------------------------------------------------------------- 93 | -- Data Type Size 94 | --------------------------------------------------------------------------- 95 | 96 | sizeDataType :: Map String Int -> DataType -> Int 97 | sizeDataType sizes (DataType _ _ cs) 98 | = maximum $ sizeConstrDefn sizes <$> cs 99 | 100 | sizeConstrDefn :: Map String Int -> ConstrDefn -> Int 101 | sizeConstrDefn sizes = \case 102 | ConstrDefn _ _ tys -> sum $ sizeType sizes <$> tys 103 | RecordDefn _ _ ens -> sum $ sizeEntry sizes <$> ens 104 | 105 | sizeEntry :: Map String Int -> Entry -> Int 106 | sizeEntry sizes (Entry _ _ ty) = sizeType sizes ty 107 | 108 | sizeType :: Map String Int -> Type -> Int 109 | sizeType sizes = \case 110 | TVar _ -> 8 -- size of pointer, since its boxed. Might change later 111 | TCon n -> case Map.lookup n sizes of 112 | Nothing -> error "DataType not registered" 113 | Just i -> i 114 | TInt s -> ceiling $ (fromIntegral s) / (8.0 :: Double) 115 | TUInt s -> ceiling $ (fromIntegral s) / (8.0 :: Double) 116 | TFp s -> ceiling $ (fromIntegral s) / (8.0 :: Double) 117 | TTuple t1 ts -> sizeType sizes t1 + foldl (\s t -> sizeType sizes t + s) (0 :: Int) ts 118 | TArray n ty -> n * sizeType sizes ty 119 | TVect n ty -> n * sizeType sizes ty 120 | TPtr _ -> 8 -- asssume 64-bit system 121 | TFunc _ _ -> 8 -- size of pointer 122 | TLoc t _ -> sizeType sizes t 123 | TParens t -> sizeType sizes t 124 | 125 | 126 | --------------------------------------------------------------------------- 127 | -- Expressions 128 | --------------------------------------------------------------------------- 129 | 130 | data Exp 131 | = EVar String 132 | | ELit Lit 133 | | ECall Exp (NonEmpty Exp) 134 | 135 | | EType Exp Type 136 | | ECast Exp Type 137 | 138 | | ELoc Exp Loc 139 | | EParens Exp 140 | 141 | | ELet (NonEmpty (Pat, Exp)) Exp 142 | | EIf Exp Exp Else 143 | | EMatch Exp (NonEmpty Clause) 144 | 145 | | ERef Exp 146 | | EDeref Exp 147 | 148 | | ETuple Exp (NonEmpty Exp) 149 | | ECon String [Exp] 150 | | ENewTuple Exp (NonEmpty Exp) 151 | | ENewCon String [Exp] 152 | | EFree Exp 153 | 154 | | EGet Exp String 155 | | EGetI Exp Exp 156 | | ESet Exp Exp 157 | 158 | | ENewArray [Exp] 159 | | ENewArrayI Exp 160 | | EResizeArray Exp Exp 161 | 162 | | ENewVect [Exp] 163 | | ENewVectI Exp 164 | 165 | | ENewString String 166 | 167 | | EOp Op 168 | deriving(Show) 169 | 170 | 171 | exEAnn :: Exp -> Exp 172 | exEAnn = \case 173 | ELoc e _ -> exEAnn e 174 | EType e _ -> exEAnn e 175 | EParens e -> exEAnn e 176 | e -> e 177 | 178 | exType :: Exp -> Type 179 | exType = \case 180 | EType _ ty -> ty 181 | ECast _ ty -> ty 182 | ELoc e _ -> exType e 183 | EParens e -> exType e 184 | e -> error $ "Expected typed expression, found: " ++ show e 185 | 186 | exTyArrElem :: Type -> Type 187 | exTyArrElem (exTyAnn -> TArray _ ty) = ty 188 | exTyArrElem _ = error "expected array type" 189 | 190 | exTyPtrElem :: Type -> Type 191 | exTyPtrElem (exTyAnn -> TPtr ty) = ty 192 | exTyPtrElem _ = error "expected pointer type" 193 | 194 | -- Literals 195 | data Lit 196 | = LNull 197 | | LInt Integer 198 | | LDouble Double 199 | | LBool Bool 200 | | LChar Char 201 | | LString String 202 | | LArray [Exp] 203 | | LArrayI Integer 204 | | LVect [Exp] 205 | | LVectI Integer 206 | | LGetI Exp Int 207 | deriving(Show) 208 | 209 | -- If Branches 210 | data Else 211 | = Else (Maybe Loc) Exp 212 | | Elif (Maybe Loc) Exp Exp Else 213 | deriving(Show) 214 | 215 | -- Operations 216 | data Op 217 | = OpAdd Exp Exp 218 | | OpSub Exp Exp 219 | | OpMul Exp Exp 220 | | OpDiv Exp Exp 221 | | OpRem Exp Exp 222 | | OpNeg Exp 223 | 224 | | OpAnd Exp Exp 225 | | OpOr Exp Exp 226 | | OpXor Exp Exp 227 | | OpShR Exp Exp 228 | | OpShL Exp Exp 229 | 230 | | OpEq Exp Exp 231 | | OpNeq Exp Exp 232 | | OpLT Exp Exp 233 | | OpLE Exp Exp 234 | | OpGT Exp Exp 235 | | OpGE Exp Exp 236 | deriving (Show) 237 | 238 | 239 | --------------------------------------------------------------------------- 240 | -- Types 241 | --------------------------------------------------------------------------- 242 | 243 | data Type 244 | = TVar String 245 | | TCon String 246 | | TInt Int 247 | | TUInt Int 248 | | TFp Int 249 | | TTuple Type (NonEmpty Type) 250 | | TArray Int Type 251 | | TVect Int Type 252 | | TPtr Type 253 | | TFunc Type (NonEmpty Type) 254 | | TLoc Type Loc 255 | | TParens Type 256 | deriving(Show) 257 | 258 | 259 | exTyAnn :: Type -> Type 260 | exTyAnn = \case 261 | TLoc t _ -> exTyAnn t 262 | TParens t -> exTyAnn t 263 | t -> t 264 | 265 | intSizes :: [Int] 266 | intSizes = [1, 8, 16, 32, 64] 267 | 268 | uintSizes :: [Int] 269 | uintSizes = [8, 16, 32, 64] 270 | 271 | floatSizes :: [Int] 272 | floatSizes = [16, 32, 64, 128] 273 | 274 | intTypes :: [Type] 275 | intTypes = TInt <$> intSizes 276 | 277 | uintTypes :: [Type] 278 | uintTypes = TUInt <$> uintSizes 279 | 280 | floatTypes :: [Type] 281 | floatTypes = TFp <$> floatSizes 282 | 283 | numTypes :: [Type] 284 | numTypes = intTypes <> uintTypes <> floatTypes 285 | 286 | isIntTy :: Type -> Bool 287 | isIntTy (exTyAnn -> TInt _) = True 288 | isIntTy _ = False 289 | 290 | isUIntTy :: Type -> Bool 291 | isUIntTy (exTyAnn -> TUInt _) = True 292 | isUIntTy _ = False 293 | 294 | isFloatTy :: Type -> Bool 295 | isFloatTy (exTyAnn -> TFp _) = True 296 | isFloatTy _ = False 297 | 298 | isNumType :: Type -> Bool 299 | isNumType ty = isIntTy ty || isUIntTy ty || isFloatTy ty 300 | 301 | isBitType :: Type -> Bool 302 | isBitType ty = isNumType ty || isPtrTy ty 303 | 304 | isBoolType :: Type -> Bool 305 | isBoolType (exTyAnn -> TInt 1) = True 306 | isBoolType _ = False 307 | 308 | isPtrTy :: Type -> Bool 309 | isPtrTy (exTyAnn -> ty) = 310 | case ty of 311 | TArray _ _ -> True 312 | TVect _ _ -> True 313 | TPtr _ -> True 314 | _ -> False 315 | 316 | 317 | exPtrTyElem :: Type -> Type 318 | exPtrTyElem (exTyAnn -> ty) = 319 | case ty of 320 | TArray _ ety -> ety 321 | TVect _ ety -> ety 322 | TPtr ety -> ety 323 | _ -> error "expected a pointer type" 324 | 325 | --------------------------------------------------------------------------- 326 | -- Patterns 327 | --------------------------------------------------------------------------- 328 | 329 | data Pat 330 | = PVar String 331 | | PCon String [Pat] 332 | | PTuple Pat (NonEmpty Pat) 333 | | PWild 334 | | PType Pat Type 335 | | PLoc Pat Loc 336 | | PParens Pat 337 | deriving(Show) 338 | 339 | -- Case branches 340 | data Clause = Clause String [Maybe String] Exp 341 | deriving(Show) 342 | 343 | exPType :: Pat -> Type 344 | exPType = \case 345 | PType _ ty -> ty 346 | PLoc p _ -> exPType p 347 | PParens p -> exPType p 348 | p -> error $ "error: Cannot extract Type from: " ++ show p 349 | 350 | patFreeTyped :: Pat -> [(String, Type)] 351 | patFreeTyped p = patFreeTyped' (exPType p) p 352 | 353 | patFreeTyped' :: Type -> Pat -> [(String, Type)] 354 | patFreeTyped' ty = \case 355 | PVar n -> [(n, ty)] 356 | PCon _ ps -> concatMap patFreeTyped ps 357 | PTuple p (NE.toList -> ps) -> 358 | concatMap patFreeTyped (p:ps) 359 | PWild -> [] 360 | PType p ty' -> patFreeTyped' ty' p 361 | PLoc p _ -> patFreeTyped' ty p 362 | PParens p -> patFreeTyped' ty p 363 | 364 | 365 | --------------------------------------------------------------------------- 366 | -- Location instances 367 | --------------------------------------------------------------------------- 368 | 369 | instance HasLocation Module where 370 | locOf (Module l _ _) = l 371 | 372 | instance HasLocation Exp where 373 | locOf = \case 374 | ELoc _ l -> l 375 | EType e _ -> locOf e 376 | EParens e -> locOf e 377 | _ -> error $ "expected located expression!" 378 | 379 | 380 | instance HasLocation Type where 381 | locOf = \case 382 | TLoc _ l -> l 383 | TParens t -> locOf t 384 | _ -> error $ "expected located type!" 385 | 386 | instance HasLocation Pat where 387 | locOf = \case 388 | PLoc _ l -> l 389 | PType p _ -> locOf p 390 | PParens p -> locOf p 391 | _ -> error $ "expected located pattern!" 392 | -------------------------------------------------------------------------------- /lltt/src/Language/LLTT/Infer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase 2 | , ConstraintKinds 3 | , FlexibleContexts 4 | , FlexibleInstances 5 | , MultiParamTypeClasses 6 | , ViewPatterns 7 | , DeriveGeneric 8 | , DeriveDataTypeable 9 | , TypeSynonymInstances 10 | #-} 11 | module Language.LLTT.Infer where 12 | 13 | {- 14 | import Language.LLTT.Syntax 15 | 16 | -- Type Inference 17 | -- Type inference will enrich the ast with type annotations. 18 | -- While this language is intended to be the target of a 19 | -- higher level language, type inference is necessary 20 | -- for generating tests. 21 | 22 | import Language.STLC.Lifted.Syntax 23 | 24 | import Control.Monad.Reader 25 | 26 | import Data.Bifunctor 27 | import Data.List 28 | 29 | import Data.Map.Strict (Map) 30 | import qualified Data.Map.Strict as Map 31 | 32 | import Data.Typeable (Typeable) 33 | import GHC.Generics (Generic) 34 | import Unbound.Generics.LocallyNameless 35 | 36 | 37 | ----------------------------------------------------------------- 38 | -- Environment and Inference Monad 39 | ----------------------------------------------------------------- 40 | 41 | type Substitution = (PolyType, PolyType) 42 | type Substitutions = [Substitution] 43 | type Constraint = (PolyType, PolyType) 44 | type Constraints = [Constraint] 45 | 46 | type Env = Map String Type 47 | type Infer = ReaderT Env FreshM 48 | type MonadInfer m = (MonadReader Env m, Fresh m) 49 | 50 | -- helpers 51 | 52 | lookupType :: MonadReader Env m => String -> m Type 53 | lookupType n 54 | = reader (Map.lookup n) >>= maybe err return 55 | where err = error $ "Check: untyped variable encounted: " ++ n 56 | 57 | withType :: MonadReader Env m => String -> Type -> m a -> m a 58 | withType n ty 59 | = local (Map.insert n ty) 60 | 61 | withTypes :: MonadReader Env m => [(String, Type)] -> m a -> m a 62 | withTypes ns = local (\env -> foldl f env ns) 63 | where f env (n, ty) = Map.insert n ty env 64 | 65 | inferModule :: Module -> Module 66 | inferModule (Module n defns) 67 | = Module n defns' 68 | where env = makeEnv defns 69 | m = mapM inferDefn defns 70 | defns' = runFreshM (runReaderT m env) 71 | 72 | makeEnv :: [Defn] -> Map String Type 73 | makeEnv defns = Map.fromList defns'' 74 | where defns' = concatMap f defns 75 | defns'' = nubBy (\(n1,_) (n2, _) -> if n1 == n2 then err n1 else False) defns' 76 | err n = error $ "Illegal duplicate definition: " ++ n 77 | f = \case 78 | FuncDefn (Func ty f bnd) -> [(f, ty)] 79 | 80 | ExternDefn (Extern n paramty retty) -> 81 | [(n, tarr paramty retty)] 82 | 83 | DataTypeDefn (DataType dt_n dt_cons) -> 84 | let mems = mconcat (snd <$> dt_cons) 85 | mem_tys = [ (n, TArr (TCon dt_n) ty) | (Just n, ty) <- mems ] 86 | con_tys = do 87 | (con_n, con_params) <- dt_cons 88 | let v = con_n 89 | ty = tarr (snd <$> con_params) (TCon dt_n) 90 | return (v, ty) 91 | in mem_tys ++ con_tys 92 | 93 | 94 | ----------------------------------------------------------- 95 | -- Algorithm W 96 | -- This algorithm does type inference in three phases: 97 | -- 1) Constraint gathering, temporary type variable instantiation 98 | -- 2) Unification, turning constraints into substitutions 99 | -- 3) Inference, apply substitutions and 100 | -- convert back to a monotype. 101 | ----------------------------------------------------------- 102 | 103 | ----------------------------------------------------------- 104 | -- Constraint Gathering 105 | ----------------------------------------------------------- 106 | 107 | 108 | constraints :: Fresh m => Exp -> m (PolyExp, Constraints) 109 | constraints = \case 110 | EVar v -> do 111 | ty <- lookupType (name2String v) 112 | return (EType (EVar v) ty, []) 113 | 114 | ELit l -> do 115 | ty <- typeOfLit 116 | return $ (EType (ELit l) ty, []) 117 | 118 | EType e ty -> do 119 | (e'@(EType _ ty'), cs) <- constraints e 120 | return (e', (ty, ty'):cs) 121 | 122 | EApp f xs -> do 123 | (f, cs1) <- constraints f 124 | (xs', css) <- unzip <$> mapM constraints xs 125 | let cs2 = mconcat css 126 | (paramtys, retty) = splitType $ exType f 127 | paramtys' = exType <$> xs' 128 | cs3 = zip paramtys paramtys' 129 | e' = EType (EApp f' xs') retty 130 | return (e', cs1 <> cs2 <> cs3) 131 | 132 | ELet _ -> undefined 133 | EIf _ _ _ -> undefined 134 | ECase _ _ -> undefined 135 | 136 | ERef _ -> undefined 137 | EDeref _ -> undefined 138 | 139 | ECon _ [] -> undefined 140 | ECon _ _ -> undefined 141 | ENewCon _ _ -> undefined 142 | EFree e -> undefined 143 | 144 | EGet e _ -> isAExp e 145 | EGetI e _ -> isAExp e 146 | ESet _ _ -> undefined 147 | 148 | ENewArray _ -> undefined 149 | ENewArrayI _ -> undefined 150 | EResizeArray _ _ -> undefined 151 | 152 | ENewString _ -> undefined 153 | ENewStringI _ -> undefined 154 | 155 | EOp _ -> undefined 156 | 157 | 158 | typeOfLit :: Fresh m => Lit -> m Type 159 | typeOfLit = \case 160 | LInt _ -> newTVar 161 | LChar _ -> return TChar 162 | LString _ -> return TString 163 | LStringI _ -> return TString 164 | LArray _ -> newTVar 165 | LArrayI _ -> newTVar 166 | 167 | 168 | inferDefn :: MonadInfer m => Defn -> m Defn 169 | inferDefn = \case 170 | FuncDefn (Func ty f bnd) -> do 171 | (ps, body) <- unbind bnd 172 | 173 | let (argtys, retty) = splitType ty 174 | ps' <- mapM (uncurry inferPat) (zip argtys ps) 175 | let paramtys = concatMap patTypedVars ps' 176 | body' <- withTypes paramtys $ infer body 177 | 178 | let bnd' = bind ps' body' 179 | return $ FuncDefn $ Func ty f bnd' 180 | 181 | defn -> return defn 182 | 183 | 184 | infer :: MonadInfer m => Exp -> m Exp 185 | infer = \case 186 | e@(EVar v) -> EType e <$> lookupType (name2String v) 187 | 188 | ELit l -> undefined 189 | 190 | EType e t -> do 191 | e' <- infer e 192 | case e' of 193 | EType _ t' 194 | | t /= t' -> error "Type mismatch!" 195 | | True -> return e' 196 | 197 | _ -> error "Type inference has mysteriously failed!" 198 | 199 | EApp f xs -> do 200 | f' <- infer f 201 | xs' <- mapM infer xs 202 | let f_ty = exType f' 203 | (paramtys, retty) = splitType f_ty 204 | x_tys = exType <$> xs' 205 | 206 | if and (zipWith (==) x_tys paramtys) 207 | then 208 | return $ EType (EApp f' xs') retty 209 | else error $ "tcabalype application mismatch\n\n" 210 | ++ "expected: " ++ show paramtys ++ "\n\n" 211 | ++ "actual: " ++ show x_tys ++ "\n\n" 212 | 213 | ELet bnd -> do 214 | (unrec -> letbnds, body) <- unbind bnd 215 | let qs = second unembed <$> letbnds 216 | go (ns, qs) (p, e) = withTypes ns $ do 217 | e' <- infer e 218 | case e' of 219 | EType _ ty -> do 220 | p' <- inferPat ty p 221 | let ns' = patTypedVars p' 222 | return (ns' ++ ns, (p', e'):qs) 223 | _ -> error "Inference: Expected typed expression in let equation" 224 | (ns, qs') <- foldM go ([], []) qs 225 | withTypes ns $ do 226 | body' <- infer body 227 | let letbnds' = rec (second embed <$> qs') 228 | return $ EType (ELet $ bind letbnds' body') 229 | (exType body') 230 | 231 | ECase e cls -> do 232 | e' <- infer e 233 | case e' of 234 | EType _ ty -> do 235 | cls' <- mapM (inferClause ty) cls 236 | case cls' of 237 | (Clause bnd):_ -> do 238 | (cls_p, cls_body) <- unbind bnd 239 | case cls_body of 240 | EType _ cls_ty -> 241 | return $ EType (ECase e' cls') cls_ty 242 | _ -> error "Expected clause type!" 243 | _ -> error "Empty case encountered!" 244 | 245 | _ -> error "Expected typed expression!" 246 | 247 | ECon n args -> do 248 | (paramtys, retty) <- splitType <$> lookupType n 249 | let argtys = zipWith EType args paramtys 250 | e' <- ECon n <$> mapM infer argtys 251 | return $ EType e' retty 252 | 253 | ENewCon n args -> do 254 | (paramtys, retty) <- splitType <$> lookupType n 255 | let argtys = zipWith EType args paramtys 256 | e' <- ENewCon n <$> mapM infer argtys 257 | return $ EType e' retty 258 | 259 | EFree e -> 260 | EType <$> (EFree <$> infer e) <*> pure TVoid 261 | 262 | EDeref e -> do 263 | e' <- infer e 264 | case e' of 265 | EType _ (TPtr ty) -> return $ EType (EDeref e') ty 266 | _ -> error "Type check error: can't dereference a non-pointer" 267 | 268 | ERef e -> do 269 | e' <- infer e 270 | case e' of 271 | EType _ ty -> return $ EType (ERef e') (TPtr ty) 272 | _ -> error "Type check error: can't dereference a non-pointer" 273 | 274 | EGet e mem_n -> do 275 | e' <- infer e 276 | ty <- lookupType mem_n 277 | let (argtys', retty') = splitType ty 278 | case e' of 279 | EType _ argty -> 280 | case argtys' of 281 | [argty'] 282 | | argty' == argty -> return $ EType (EGet e' mem_n) retty' 283 | | otherwise -> error $ "Type mismatch!" 284 | _ -> error $ "Expected member to only take one argument: " ++ mem_n 285 | _ -> error "Expected typed expression" 286 | 287 | EOp op -> inferOp op 288 | 289 | inferClause :: MonadInfer m => Type -> Clause -> m Clause 290 | inferClause ty (Clause bnd) = do 291 | (p, e) <- unbind bnd 292 | p' <- inferPat ty p 293 | let ns = patTypedVars p' 294 | withTypes ns $ do 295 | e' <- infer e 296 | let bnd' = bind p' e' 297 | return $ Clause bnd' 298 | 299 | 300 | inferOp :: MonadInfer m => Op -> m Exp 301 | inferOp = \case 302 | OpAddI a b -> do 303 | op' <- OpAddI <$> infer (EType a TI32) <*> infer (EType b TI32) 304 | return $ EType (EOp op') TI32 305 | 306 | OpMulI a b -> do 307 | op' <- OpMulI <$> infer (EType a TI32) <*> infer (EType b TI32) 308 | return $ EType (EOp op') TI32 309 | 310 | 311 | inferPat :: MonadInfer m => Type -> Pat -> m Pat 312 | inferPat ty = \case 313 | PVar v -> return $ PType (PVar v) ty 314 | 315 | PCon n ps -> do 316 | n_ty <- lookupType n 317 | let (argtys, retty) = splitType n_ty 318 | ps' <- mapM (\(p, ty') -> inferPat ty' p) (zip ps argtys) 319 | if ty /= retty 320 | then error $ "Pattern type mismatch" 321 | else return $ PType (PCon n ps') retty 322 | 323 | PWild -> return $ PType PWild ty 324 | 325 | PType p ty' 326 | | ty /= ty' -> do 327 | env <- ask 328 | error $ "\nPattern type mismatch:\n" 329 | ++ "pattern: " ++ show p ++ "\n\n" 330 | ++ "actual type: " ++ show ty ++ "\n\n" 331 | ++ "expected type: " ++ show ty' ++ "\n\n" 332 | ++ "env: " ++ show env ++ "\n\n" 333 | | True -> inferPat ty' p 334 | -} 335 | ----------------------------------------------------------- 336 | -- Unification 337 | ----------------------------------------------------------- 338 | 339 | --unify :: Constraints -> Substitutions 340 | --unify = undefined 341 | 342 | 343 | ----------------------------------------------------------- 344 | -- Inference 345 | ----------------------------------------------------------- 346 | 347 | --infer :: Substitutions -> PolyExp -> Exp -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Namecheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds 2 | , LambdaCase 3 | , ViewPatterns 4 | , FlexibleContexts 5 | , GeneralizedNewtypeDeriving 6 | , OverloadedStrings 7 | #-} 8 | module Language.STLC.Namecheck where 9 | 10 | 11 | import Language.Syntax.Location 12 | import Language.STLC.Syntax 13 | 14 | import Control.Monad.Reader 15 | import Control.Monad.Report 16 | import Data.Bifunctor 17 | import Data.Map.Strict (Map) 18 | import qualified Data.Map.Strict as Map 19 | import qualified Data.List.NonEmpty as NE 20 | 21 | import Unbound.Generics.LocallyNameless 22 | import Data.Text.Prettyprint.Doc 23 | 24 | --- Namecheck Environment 25 | data Env = Env 26 | { envNames :: Map SName Loc 27 | , envLoc :: Loc 28 | } 29 | 30 | mkEnv :: [(SName, Loc)] -> Loc -> Env 31 | mkEnv ns l 32 | = Env { envNames = Map.fromList ns 33 | , envLoc = l 34 | } 35 | 36 | envInsertNames :: [(String, Loc)] -> Env -> Env 37 | envInsertNames ns env 38 | = env { envNames = Map.union (Map.fromList $ first (`SName` VarName) <$> ns) 39 | (envNames env) 40 | } 41 | 42 | 43 | --- Namecheck Errors 44 | 45 | data Err 46 | = UndefinedName Loc String 47 | | UndefinedConstructor Loc String 48 | | UndefinedTypeConstructor Loc String 49 | 50 | 51 | instance Pretty Err where 52 | pretty = \case 53 | UndefinedName l n -> 54 | vsep [ line <> pretty l <+> "error:" 55 | , indent 4 $ "Undefined variable encountered: " <+> pretty n 56 | , line 57 | ] 58 | 59 | UndefinedConstructor l n -> 60 | vsep [ line <> pretty l <+> "error:" 61 | , indent 4 $ "Undefined constructor encountered: " <+> pretty n 62 | , line 63 | ] 64 | 65 | UndefinedTypeConstructor l n -> 66 | vsep [ line <> pretty l <+> "error:" 67 | , indent 4 $ "Undefined type constructor encountered: " <+> pretty n 68 | , line 69 | ] 70 | 71 | -- Namecheck Monad 72 | type MonadNamecheck m = (Fresh m, MonadReader Env m, MonadReport Err m) 73 | 74 | newtype Namecheck a = NC { unNamecheck :: ReportT Err (FreshMT (Reader Env)) a } 75 | deriving (Functor, Applicative, Monad, Fresh, MonadReader Env, MonadReport Err) 76 | 77 | runNamecheck :: Namecheck a -> Env-> Either [Err] a 78 | runNamecheck m env 79 | = runReader (runFreshMT (runReportT (unNamecheck m))) env 80 | 81 | withNames :: MonadNamecheck m => [(String, Loc)] -> m a -> m a 82 | withNames dict = local (envInsertNames dict) 83 | 84 | withLoc :: MonadNamecheck m => Loc -> m a -> m a 85 | withLoc l = local (\env -> env { envLoc = l }) 86 | 87 | checkVar :: MonadNamecheck m => Var -> m Var 88 | checkVar v = checkName (name2String v) >> return v 89 | 90 | checkName :: MonadNamecheck m => String -> m String 91 | checkName n = do 92 | may_n <- (Map.lookup (SName n VarName) . envNames) <$> ask 93 | l <- envLoc <$> ask 94 | case may_n of 95 | Nothing -> nonfatal (UndefinedName l n) n 96 | Just _ -> return n 97 | 98 | 99 | checkCon :: MonadNamecheck m => String -> m String 100 | checkCon n = do 101 | may_n <- (Map.lookup (SName n ConName) . envNames) <$> ask 102 | l <- envLoc <$> ask 103 | case may_n of 104 | Nothing -> nonfatal (UndefinedConstructor l n) n 105 | Just _ -> return n 106 | 107 | checkTyCon :: MonadNamecheck m => String -> m String 108 | checkTyCon n = do 109 | may_n <- (Map.lookup (SName n TyConName) . envNames) <$> ask 110 | l <- envLoc <$> ask 111 | case may_n of 112 | Nothing -> nonfatal (UndefinedTypeConstructor l n) n 113 | Just _ -> return n 114 | 115 | 116 | -- Namecheck requires some global name sets and a module to check on 117 | namecheck :: [(SName, Loc)] -> Module -> Either [Err] Module 118 | namecheck ns m 119 | = runNamecheck (allFatal $ namecheckModule m) 120 | (mkEnv ns (locOf m)) 121 | 122 | 123 | namecheckModule :: MonadNamecheck m => Module -> m Module 124 | namecheckModule (Module l n defns) = 125 | Module l n <$> mapM namecheckDefn defns 126 | 127 | namecheckDefn :: MonadNamecheck m => Defn -> m Defn 128 | namecheckDefn = \case 129 | FuncDefn f -> FuncDefn <$> namecheckFunc f 130 | ExternDefn ex -> ExternDefn <$> namecheckExtern ex 131 | DataTypeDefn dt -> DataTypeDefn <$> namecheckDataType dt 132 | 133 | 134 | namecheckFunc :: MonadNamecheck m => Func -> m Func 135 | namecheckFunc (Func l ty n bnd) = do 136 | ty' <- namecheckType ty 137 | (args, body) <- unbind bnd 138 | args' <- mapM namecheckPat args 139 | let ns = concatMap patVars args 140 | body' <- withNames ns $ namecheckExp body 141 | return $ Func l ty' n (bind args' body') 142 | 143 | namecheckExtern :: MonadNamecheck m => Extern -> m Extern 144 | namecheckExtern (Extern l n argtys retty) = withLoc l $ do 145 | argtys' <- mapM namecheckType argtys 146 | retty' <- namecheckType retty 147 | return $ Extern l n argtys' retty' 148 | 149 | 150 | namecheckDataType :: MonadNamecheck m => DataType -> m DataType 151 | namecheckDataType (DataType l n constrs) 152 | = withLoc l $ 153 | DataType l n <$> mapM namecheckConstrDefn constrs 154 | 155 | namecheckConstrDefn :: MonadNamecheck m => ConstrDefn -> m ConstrDefn 156 | namecheckConstrDefn = \case 157 | ConstrDefn l n tys -> ConstrDefn l n <$> (withLoc l $ mapM namecheckType tys) 158 | RecordDefn l n es -> RecordDefn l n <$> (withLoc l $ mapM namecheckEntry es) 159 | 160 | namecheckEntry :: MonadNamecheck m => Entry -> m Entry 161 | namecheckEntry (Entry l n ty) = Entry l n <$> (withLoc l $ namecheckType ty) 162 | 163 | 164 | namecheckType :: MonadNamecheck m => Type -> m Type 165 | namecheckType = \case 166 | TArr t1 t2 -> TArr <$> namecheckType t1 <*> namecheckType t2 167 | TCon n -> TCon <$> checkTyCon n 168 | 169 | TInt i -> pure $ TInt i 170 | TUInt i -> pure $ TUInt i 171 | TFp i -> pure $ TFp i 172 | 173 | TTuple t ts -> 174 | TTuple <$> namecheckType t <*> mapM namecheckType ts 175 | 176 | TArray i ty -> 177 | TArray i <$> namecheckType ty 178 | 179 | TVect i ty -> 180 | TVect i <$> namecheckType ty 181 | 182 | TPtr ty -> TPtr <$> namecheckType ty 183 | TLoc ty l -> withLoc l (TLoc <$> namecheckType ty <*> pure l) 184 | TParens ty -> TParens <$> namecheckType ty 185 | 186 | 187 | namecheckExp :: MonadNamecheck m => Exp -> m Exp 188 | namecheckExp = \case 189 | EVar v -> EVar <$> (checkVar v) 190 | 191 | ELit l -> ELit <$> namecheckLit l 192 | EApp f xs -> EApp <$> namecheckExp f <*> mapM namecheckExp xs 193 | 194 | EType e ty -> EType <$> namecheckExp e <*> namecheckType ty 195 | ECast e ty -> ECast <$> namecheckExp e <*> namecheckType ty 196 | ELoc e l -> withLoc l $ ELoc <$> namecheckExp e <*> pure l 197 | EParens e -> EParens <$> namecheckExp e 198 | 199 | ELam bnd -> do 200 | (ps, body) <- unbind bnd 201 | ps' <- mapM namecheckPat ps 202 | body' <- withNames (concatMap patVars (NE.toList ps')) $ namecheckExp body 203 | return $ ELam (bind ps' body') 204 | 205 | ELet bnd -> do 206 | (unrec -> qs, body) <- unbind bnd 207 | let ps = fst <$> qs 208 | es = (unembed . snd) <$> qs 209 | ps' <- mapM namecheckPat ps 210 | withNames (concatMap patVars ps') $ do 211 | es' <- mapM namecheckExp es 212 | body' <- namecheckExp body 213 | return $ ELet (bind (rec $ NE.zip ps' (embed <$> es')) body') 214 | 215 | 216 | EIf p t f -> EIf <$> namecheckExp p <*> namecheckExp t <*> namecheckElse f 217 | ECase e cs -> ECase <$> namecheckExp e <*> mapM namecheckClause cs 218 | 219 | ERef e -> ERef <$> namecheckExp e 220 | EDeref e -> EDeref <$> namecheckExp e 221 | 222 | ETuple e es -> ETuple <$> namecheckExp e <*> mapM namecheckExp es 223 | ECon n es -> 224 | ECon <$> checkCon n <*> mapM namecheckExp es 225 | ENewCon n es -> 226 | ENewCon <$> checkCon n <*> mapM namecheckExp es 227 | EFree e -> EFree <$> namecheckExp e 228 | 229 | EGet a str -> EGet <$> namecheckExp a <*> pure str -- lol check member names you doofus 230 | EGetI a b -> EGetI <$> namecheckExp a <*> namecheckExp b 231 | ESet a b -> ESet <$> namecheckExp a <*> namecheckExp b 232 | 233 | ENewArray es -> ENewArray <$> mapM namecheckExp es 234 | ENewArrayI i -> ENewArrayI <$> namecheckExp i 235 | EResizeArray e i -> EResizeArray <$> namecheckExp e <*> namecheckExp i 236 | 237 | ENewVect es -> ENewVect <$> mapM namecheckExp es 238 | ENewVectI i -> ENewVectI <$> namecheckExp i 239 | 240 | ENewString str -> pure $ ENewString str 241 | EOp op -> EOp <$> namecheckOp op 242 | 243 | 244 | namecheckLit :: MonadNamecheck m => Lit -> m Lit 245 | namecheckLit = \case 246 | LNull -> pure LNull 247 | LBool b -> pure $ LBool b 248 | LInt i -> pure $ LInt i 249 | LDouble i -> pure $ LDouble i 250 | LChar c -> pure $ LChar c 251 | LString str -> pure $ LString str 252 | LArray es -> LArray <$> mapM namecheckExp es 253 | LArrayI i -> LArrayI <$> namecheckExp i 254 | LVect es -> LVect <$> mapM namecheckExp es 255 | LVectI i -> LVectI <$> namecheckExp i 256 | 257 | namecheckElse :: MonadNamecheck m => Else -> m Else 258 | namecheckElse = \case 259 | Else may_l body -> do 260 | l <- maybe (envLoc <$> ask) pure may_l 261 | withLoc l $ Else may_l <$> namecheckExp body 262 | 263 | Elif may_l p t f -> do 264 | l <- maybe (envLoc <$> ask) pure may_l 265 | withLoc l $ Elif may_l <$> namecheckExp p <*> namecheckExp t <*> namecheckElse f 266 | 267 | 268 | namecheckOp :: MonadNamecheck m => Op -> m Op 269 | namecheckOp = \case 270 | OpAdd a b -> OpAdd <$> namecheckExp a <*> namecheckExp b 271 | OpSub a b -> OpSub <$> namecheckExp a <*> namecheckExp b 272 | OpMul a b -> OpMul <$> namecheckExp a <*> namecheckExp b 273 | OpDiv a b -> OpDiv <$> namecheckExp a <*> namecheckExp b 274 | OpRem a b -> OpRem <$> namecheckExp a <*> namecheckExp b 275 | OpNeg a -> OpNeg <$> namecheckExp a 276 | 277 | 278 | OpAnd a b -> OpAnd <$> namecheckExp a <*> namecheckExp b 279 | OpOr a b -> OpOr <$> namecheckExp a <*> namecheckExp b 280 | OpXor a b -> OpXor <$> namecheckExp a <*> namecheckExp b 281 | 282 | OpShR a b -> OpShR <$> namecheckExp a <*> namecheckExp b 283 | OpShL a b -> OpShL <$> namecheckExp a <*> namecheckExp b 284 | 285 | OpEq a b -> OpEq <$> namecheckExp a <*> namecheckExp b 286 | OpNeq a b -> OpNeq <$> namecheckExp a <*> namecheckExp b 287 | 288 | OpLT a b -> OpLT <$> namecheckExp a <*> namecheckExp b 289 | OpLE a b -> OpLE <$> namecheckExp a <*> namecheckExp b 290 | 291 | OpGT a b -> OpGT <$> namecheckExp a <*> namecheckExp b 292 | OpGE a b -> OpGE <$> namecheckExp a <*> namecheckExp b 293 | 294 | 295 | namecheckPat :: MonadNamecheck m => Pat -> m Pat 296 | namecheckPat = \case 297 | PVar v -> return $ PVar v 298 | PCon n ps -> 299 | PCon <$> checkCon n <*> mapM namecheckPat ps 300 | 301 | PTuple p ps -> 302 | PTuple <$> namecheckPat p <*> mapM namecheckPat ps 303 | 304 | PWild -> pure PWild 305 | 306 | PType p ty -> 307 | PType <$> namecheckPat p <*> namecheckType ty 308 | 309 | PLoc p l -> withLoc l (PLoc <$> namecheckPat p <*> pure l) 310 | PParens p -> PParens <$> namecheckPat p 311 | 312 | 313 | namecheckClause :: MonadNamecheck m => Clause -> m Clause 314 | namecheckClause (Clause may_l bnd) = do 315 | l <- maybe (envLoc <$> ask) pure may_l 316 | withLoc l $ do 317 | (p, e) <- unbind bnd 318 | p' <- namecheckPat p 319 | e' <- withNames (patVars p') $ namecheckExp e 320 | return $ Clause may_l (bind p' e') -------------------------------------------------------------------------------- /stlc/src/Language/STLC/Lex.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE OverloadedStrings 3 | , TupleSections 4 | , FlexibleContexts 5 | , GeneralizedNewtypeDeriving 6 | #-} 7 | 8 | module Language.STLC.Lex where 9 | 10 | 11 | import Prelude hiding (lex) 12 | import Lens.Micro.Platform 13 | import Control.Monad.Except 14 | import Control.Monad.State.Strict 15 | import Data.Bits (shiftR, (.&.)) 16 | import Data.Char (ord) 17 | import Data.Text (Text) 18 | import Data.Word (Word8) 19 | import Language.STLC.Lex.Error 20 | import Language.STLC.Lex.State 21 | import Language.STLC.Lex.Token 22 | import Language.Syntax.Location 23 | import Safe (headDef) 24 | import System.FilePath (FilePath) 25 | 26 | import qualified Data.Text as T 27 | import qualified Data.Text.Read as T 28 | 29 | } 30 | 31 | -- ----------------------------------------------------------------------------- 32 | -- Alex "Character set macros" 33 | 34 | $digit = 0-9 35 | 36 | 37 | $opchar = [\!\#\$\%\&\*\+\/\<\=\>\?\@\\\^\|\-\~\:] 38 | 39 | $small = [a-z] 40 | $large = [A-Z] 41 | $idchar = [A-Za-z0-9] 42 | $idcharsym = [A-Za-z0-9\_\'] 43 | 44 | $nonwhite = ~$white 45 | $whiteNoNewline = $white # \n 46 | 47 | 48 | -- ----------------------------------------------------------------------------- 49 | -- Alex "Regular expression macros" 50 | 51 | -- Basic Ids 52 | @varid = $small $idcharsym* 53 | @conid = $large $idcharsym* 54 | @primid = \# $small $idcharsym* 55 | 56 | @qual = (@conid \.)+ 57 | @qvarid = @qual @varid 58 | @qconid = @qual @conid 59 | 60 | -- ----------------------------------------------------------------------------- 61 | -- Alex "Identifier" 62 | 63 | hawk :- 64 | 65 | -- ----------------------------------------------------------------------------- 66 | -- Alex "Rules" 67 | 68 | <0> { 69 | -- Skip whitespace everywhere 70 | $whiteNoNewline { skipBreak } 71 | [\n\r] { \ _ _ -> nextLineBreak } 72 | "/*" { beginComment } 73 | "//" { beginLineComment } 74 | 75 | \" { beginString } 76 | \' .* \' { handleChar } 77 | 78 | 79 | \\ { rsvp } 80 | \-\> { rsvp } 81 | \| { rsvp } 82 | \: { rsvp } 83 | \:\= { rsvp } 84 | \:\: { rsvp } 85 | \; { rsvp } 86 | \, { rsvp } 87 | \. { rsvp } 88 | \= { rsvp } 89 | \_ { rsvp } 90 | \~ { rsvp } 91 | \* { rsvp } 92 | \& { rsvp } 93 | 94 | \( { rsvp } 95 | \) { rsvp } 96 | \[ { rsvp } 97 | \] { rsvp } 98 | \{ { rsvp } 99 | \} { rsvp } 100 | \< { rsvp } 101 | \> { rsvp } 102 | 103 | "I1" { rsvp } 104 | "I8" { rsvp } 105 | "I16" { rsvp } 106 | "I32" { rsvp } 107 | "I64" { rsvp } 108 | 109 | "U8" { rsvp } 110 | "U16" { rsvp } 111 | "U32" { rsvp } 112 | "U64" { rsvp } 113 | 114 | "F16" { rsvp } 115 | "F32" { rsvp } 116 | "F64" { rsvp } 117 | "F128" { rsvp } 118 | 119 | "Array" { rsvp } 120 | "Vect" { rsvp } 121 | "null" { rsvp } 122 | 123 | "module" { rsvp } 124 | "import" { rsvp } 125 | 126 | "extern" { rsvp } 127 | "type" { rsvp } 128 | "class" { rsvp } 129 | "impl" { rsvp } 130 | 131 | "foreign" { rsvp } 132 | "export" { rsvp } 133 | "ccall" { rsvp } 134 | 135 | "infix" { rsvp } 136 | "infixl" { rsvp } 137 | "infixr" { rsvp } 138 | 139 | "let" { rsvp } 140 | "in" { rsvp } 141 | "as" { rsvp } 142 | "case" { rsvp } 143 | "of" { rsvp } 144 | 145 | "if" { rsvp } 146 | "then" { rsvp } 147 | "elif" { rsvp } 148 | "else" { rsvp } 149 | 150 | "new" { rsvp } 151 | "resize" { rsvp } 152 | "delete" { rsvp } 153 | 154 | "True" { \text -> yieldTokAt (TokenBool True) text} 155 | "False" { \text -> yieldTokAt (TokenBool False) text} 156 | 157 | @primid { \text -> yieldTokAt (TokenPrimId text) text } 158 | @conid { \text -> yieldTokAt (TokenConId text) text } 159 | @varid { \text -> yieldTokAt (TokenVarId text) text } 160 | 161 | $digit* \. $digit+ { \text -> yieldTokAt (TokenDouble $ readDbl text) text } 162 | $digit+ \. $digit* { \text -> yieldTokAt (TokenDouble $ readDbl text) text } 163 | 164 | ($digit)+ { \text -> yieldTokAt (TokenInteger $ readInt text) text } 165 | } 166 | 167 | { 168 | \\[nt\"] { escapeString } 169 | \" { endString } 170 | [.] { appendString } 171 | } 172 | 173 | { 174 | "/*" { continueComment } 175 | "*/" { endComment } 176 | [\n\r] { \_ _ -> nextLineContinue } 177 | [.] { skipContinue } 178 | } 179 | 180 | { 181 | [\n\r] { endLineComment } 182 | [.] { skipContinue } 183 | } 184 | 185 | { 186 | 187 | 188 | newtype Lex a = Lex { unLex :: StateT LexState (Except LexError) a } 189 | deriving ( Functor, Applicative, Monad 190 | , MonadState LexState 191 | , MonadError LexError 192 | ) 193 | 194 | type LexAction = Text -> Int -> Lex () 195 | 196 | 197 | runLexer :: FilePath -> Lex a -> Except LexError a 198 | runLexer fp lexer = evalStateT (unLex lexer) (initialLexState fp) 199 | 200 | 201 | tag :: Text -> TokenClass -> Lex Token 202 | tag text tc = do 203 | fp <- use lexFilePath 204 | r <- use lexRegion 205 | return $ Token tc text (Loc fp r) 206 | 207 | 208 | moveRegion :: Int -> Lex () 209 | moveRegion len = do 210 | r1 <- use $ lexRegion . regEnd 211 | lexRegion . regStart .= r1 212 | lexRegion . regEnd . posColumn += len 213 | 214 | 215 | growRegion :: Int -> Lex () 216 | growRegion len = 217 | lexRegion . regEnd . posColumn += len 218 | 219 | 220 | nextLineBreak :: Lex () 221 | nextLineBreak = do 222 | lexRegion . regStart . posLine += 1 223 | lexRegion . regStart . posColumn .= 0 224 | 225 | lexRegion . regEnd . posLine += 1 226 | lexRegion . regEnd . posColumn .= 0 227 | 228 | 229 | nextLineContinue :: Lex () 230 | nextLineContinue = do 231 | lexRegion . regEnd . posLine += 1 232 | lexRegion . regEnd . posColumn .= 0 233 | 234 | 235 | yieldTokAt :: TokenClass -> LexAction 236 | yieldTokAt c text len = do 237 | moveRegion len 238 | yieldTaggedTok c text 239 | 240 | 241 | yieldTaggedTok :: TokenClass -> Text -> Lex () 242 | yieldTaggedTok c text = do 243 | t <- tag text c 244 | yieldTok t 245 | 246 | yieldTok :: Token -> Lex () 247 | yieldTok t = 248 | lexTokAcc %= (t:) 249 | 250 | 251 | rsvp :: LexAction 252 | rsvp text = 253 | yieldTokAt (TokenRsvp text) text 254 | 255 | 256 | skipBreak :: LexAction 257 | skipBreak _ len = do 258 | moveRegion len 259 | 260 | skipContinue :: LexAction 261 | skipContinue _ len = do 262 | growRegion len 263 | 264 | beginString :: LexAction 265 | beginString _ len = 266 | do 267 | moveRegion len 268 | lexStartcode .= stringSC 269 | 270 | endString :: LexAction 271 | endString text len = do 272 | buf <- do 273 | growRegion len 274 | use lexStringBuf 275 | 276 | yieldTaggedTok (TokenString $ reverse buf) text 277 | 278 | do 279 | lexStringBuf .= "" 280 | lexStartcode .= 0 281 | 282 | appendString :: LexAction 283 | appendString text len = 284 | do 285 | growRegion len 286 | let c = T.head text 287 | lexStringBuf %= (c:) 288 | 289 | escapeString :: LexAction 290 | escapeString text len = do 291 | let c = T.head $ T.tail text 292 | unesc <- case c of 293 | 'n' -> return '\n' 294 | 't' -> return '\t' 295 | '"' -> return '"' 296 | _ -> do 297 | l <- locOf <$> get 298 | throwError $ InvalidEscapeChar l c 299 | growRegion len 300 | lexStringBuf %= (unesc:) 301 | 302 | 303 | 304 | handleChar :: LexAction 305 | handleChar text len = do 306 | let trim = T.unpack . T.tail . T.init 307 | yieldCharAt ch = yieldTokAt (TokenChar ch) text len 308 | case (trim text) of 309 | ([]) -> yieldCharAt '\0' 310 | "\\0" -> yieldCharAt '\0' 311 | "\\t" -> yieldCharAt '\t' 312 | "\\n" -> yieldCharAt '\n' 313 | "\\r" -> yieldCharAt '\r' 314 | "\'" -> yieldCharAt '\'' 315 | (c:[]) -> yieldCharAt c 316 | _ -> do 317 | l <- locOf <$> get 318 | throwError $ InvalidCharLit l (trim text) 319 | 320 | 321 | beginComment :: LexAction 322 | beginComment _ len = 323 | do 324 | moveRegion len 325 | lexStartcode .= commentSC 326 | lexCommentDepth .= 1 327 | 328 | continueComment :: LexAction 329 | continueComment _ len = 330 | do 331 | growRegion len 332 | lexCommentDepth += 1 333 | 334 | 335 | endComment :: LexAction 336 | endComment _ len = 337 | do 338 | growRegion len 339 | 340 | lexCommentDepth -= 1 341 | cd <- use lexCommentDepth 342 | 343 | lexStartcode .= 344 | if cd == 0 345 | then 0 346 | else commentSC 347 | 348 | beginLineComment :: LexAction 349 | beginLineComment _ len = 350 | do 351 | moveRegion len 352 | lexStartcode .= lineCommentSC 353 | 354 | endLineComment :: LexAction 355 | endLineComment _ _ = 356 | do 357 | nextLineContinue 358 | lexStartcode .= 0 359 | 360 | 361 | 362 | -- Helpers 363 | 364 | forceRight :: Either a b -> b 365 | forceRight (Right b) = b 366 | forceRight _ = undefined 367 | 368 | readInt :: Text -> Integer 369 | readInt = fst . forceRight . T.decimal 370 | 371 | readSignedInt :: Text -> Integer 372 | readSignedInt = fst . forceRight . T.signed T.decimal 373 | 374 | readDbl :: Text -> Double 375 | readDbl = fst . forceRight . T.double 376 | 377 | readSignedDbl :: Text -> Double 378 | readSignedDbl = fst . forceRight . T.signed T.double 379 | 380 | -- This was lifted almost intact from the @alex@ source code 381 | encode :: Char -> (Word8, [Word8]) 382 | encode c = (fromIntegral h, map fromIntegral t) 383 | where 384 | (h, t) = go (ord c) 385 | go n 386 | | n <= 0x7f = (n, []) 387 | | n <= 0x7ff = (0xc0 + (n `shiftR` 6), [0x80 + n .&. 0x3f]) 388 | | n <= 0xffff = 389 | ( 0xe0 + (n `shiftR` 12) 390 | , [ 0x80 + ((n `shiftR` 6) .&. 0x3f) 391 | , 0x80 + n .&. 0x3f 392 | ] 393 | ) 394 | | otherwise = 395 | ( 0xf0 + (n `shiftR` 18) 396 | , [ 0x80 + ((n `shiftR` 12) .&. 0x3f) 397 | , 0x80 + ((n `shiftR` 6) .&. 0x3f) 398 | , 0x80 + n .&. 0x3f 399 | ] 400 | ) 401 | 402 | 403 | {- @alex@ does not provide a `Text` wrapper, so the following code just modifies 404 | the code from their @basic@ wrapper to work with `Text` 405 | 406 | I could not get the @basic-bytestring@ wrapper to work; it does not correctly 407 | recognize Unicode regular expressions. 408 | -} 409 | data AlexInput = AlexInput 410 | { prevChar :: Char 411 | , currBytes :: [Word8] 412 | , currInput :: Text 413 | } 414 | 415 | alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) 416 | alexGetByte (AlexInput c bytes text) = case bytes of 417 | b:ytes -> Just (b, AlexInput c ytes text) 418 | [] -> case T.uncons text of 419 | Nothing -> Nothing 420 | Just (t, ext) -> case encode t of 421 | (b, ytes) -> Just (b, AlexInput t ytes ext) 422 | 423 | alexInputPrevChar :: AlexInput -> Char 424 | alexInputPrevChar = prevChar 425 | 426 | 427 | 428 | lex :: FilePath -> Text -> Except LexError [Token] 429 | lex fp text = do 430 | runLexer fp start 431 | 432 | where 433 | start = go $ AlexInput '\n' [] text 434 | 435 | 436 | go input = do 437 | sc <- use lexStartcode 438 | case alexScan input sc of 439 | AlexEOF -> do 440 | yieldTaggedTok TokenEof "" 441 | reverse <$> use lexTokAcc 442 | 443 | AlexError (AlexInput p _ text') -> do 444 | r <- use lexRegion 445 | let l = Loc fp r 446 | throwError $ UnrecognizedToken l (headDef (show p) $ words $ show text') 447 | 448 | AlexSkip _ _ -> do 449 | l <- locOf <$> get 450 | throwError $ IllegalLexerSkip l 451 | 452 | AlexToken input' len act -> do 453 | act (T.take (fromIntegral len) (currInput input)) (fromIntegral len) 454 | go input' 455 | 456 | } 457 | --------------------------------------------------------------------------------