├── arith ├── LICENSE ├── examples │ ├── ex3.a │ ├── ex2.a │ ├── ex1.a │ ├── ex4.a │ └── ex5.a ├── Setup.hs ├── src │ ├── Arith │ │ ├── Syntax.hs │ │ ├── Evaluator.hs │ │ └── Parser.hs │ └── Main.hs └── arith.cabal ├── untyped ├── examples │ ├── ex1.u │ ├── ex2.u │ ├── ex8.u │ ├── ex3.u │ ├── ex10.u │ ├── ex9.u │ ├── ex5.u │ ├── ex4.u │ ├── ex6.u │ └── ex7.u ├── Setup.hs ├── src │ ├── Untyped │ │ ├── Syntax.hs │ │ ├── Context.hs │ │ ├── Evaluator.hs │ │ └── Parser.hs │ └── Main.hs ├── README.md ├── LICENSE └── untyped.cabal ├── simplebool ├── examples │ ├── ex1.sb │ ├── ex2.sb │ ├── ex8.sb │ ├── ex3.sb │ ├── ex4.sb │ ├── ex9.sb │ ├── ex11.sb │ ├── ex5.sb │ ├── ex6.sb │ ├── ex10.sb │ └── ex7.sb ├── Setup.hs ├── README.md ├── src │ ├── Main.hs │ └── Simplebool │ │ ├── Syntax.hs │ │ ├── Context.hs │ │ ├── Typechecker.hs │ │ ├── Evaluator.hs │ │ └── Parser.hs ├── LICENSE └── simplebool.cabal ├── tyarith ├── examples │ ├── ex1.ta │ ├── ex2.ta │ ├── ex5.ta │ ├── ex6.ta │ ├── ex3.ta │ ├── ex4.ta │ └── ex7.ta ├── Setup.hs ├── README.md ├── src │ ├── Main.hs │ └── Tyarith │ │ └── Typechecker.hs ├── tyarith.cabal └── LICENSE ├── fullsimple ├── examples │ ├── ex8.fs │ ├── ex5.fs │ ├── ex1.fs │ ├── ex9.fs │ ├── ex11.fs │ ├── ex10.fs │ ├── ex2.fs │ ├── ex6.fs │ ├── ex7.fs │ ├── ex4.fs │ └── ex3.fs ├── Setup.hs ├── src │ ├── Fullsimple │ │ ├── Types.hs │ │ ├── Terms.hs │ │ ├── Context.hs │ │ ├── Printer.hs │ │ ├── Typechecker.hs │ │ ├── Evaluator.hs │ │ └── Parser.hs │ └── Main.hs ├── README.md ├── LICENSE └── fullsimple.cabal └── README.md /arith/LICENSE: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /untyped/examples/ex1.u: -------------------------------------------------------------------------------- 1 | x 2 | -------------------------------------------------------------------------------- /simplebool/examples/ex1.sb: -------------------------------------------------------------------------------- 1 | true 2 | -------------------------------------------------------------------------------- /simplebool/examples/ex2.sb: -------------------------------------------------------------------------------- 1 | false 2 | -------------------------------------------------------------------------------- /tyarith/examples/ex1.ta: -------------------------------------------------------------------------------- 1 | succ 0 2 | -------------------------------------------------------------------------------- /tyarith/examples/ex2.ta: -------------------------------------------------------------------------------- 1 | succ true 2 | -------------------------------------------------------------------------------- /tyarith/examples/ex5.ta: -------------------------------------------------------------------------------- 1 | pred false 2 | -------------------------------------------------------------------------------- /tyarith/examples/ex6.ta: -------------------------------------------------------------------------------- 1 | zero? true 2 | -------------------------------------------------------------------------------- /untyped/examples/ex2.u: -------------------------------------------------------------------------------- 1 | lambda x.x 2 | -------------------------------------------------------------------------------- /fullsimple/examples/ex8.fs: -------------------------------------------------------------------------------- 1 | {true, 0 true}.1 -------------------------------------------------------------------------------- /simplebool/examples/ex8.sb: -------------------------------------------------------------------------------- 1 | true false 2 | -------------------------------------------------------------------------------- /arith/examples/ex3.a: -------------------------------------------------------------------------------- 1 | if true then succ 0 else -1 -------------------------------------------------------------------------------- /fullsimple/examples/ex5.fs: -------------------------------------------------------------------------------- 1 | {true, false} 2 | -------------------------------------------------------------------------------- /untyped/examples/ex8.u: -------------------------------------------------------------------------------- 1 | (lambda s. (lambda z. z)) -------------------------------------------------------------------------------- /tyarith/examples/ex3.ta: -------------------------------------------------------------------------------- 1 | if true then 0 else false 2 | -------------------------------------------------------------------------------- /tyarith/examples/ex4.ta: -------------------------------------------------------------------------------- 1 | if 0 then succ 0 else 0 2 | -------------------------------------------------------------------------------- /tyarith/examples/ex7.ta: -------------------------------------------------------------------------------- 1 | if (zero? true) then 0 else 0 -------------------------------------------------------------------------------- /fullsimple/examples/ex1.fs: -------------------------------------------------------------------------------- 1 | (lambda x:Nat. succ x) 0 2 | -------------------------------------------------------------------------------- /fullsimple/examples/ex9.fs: -------------------------------------------------------------------------------- 1 | (if true then 0 else succ 0).2 -------------------------------------------------------------------------------- /simplebool/examples/ex3.sb: -------------------------------------------------------------------------------- 1 | (lambda x:Bool. x) true 2 | -------------------------------------------------------------------------------- /untyped/examples/ex3.u: -------------------------------------------------------------------------------- 1 | (lambda x.x x) (lambda x.x) 2 | -------------------------------------------------------------------------------- /arith/examples/ex2.a: -------------------------------------------------------------------------------- 1 | if false then 0 else succ (pred (succ 0)) -------------------------------------------------------------------------------- /fullsimple/examples/ex11.fs: -------------------------------------------------------------------------------- 1 | (lambda _:Unit. unit; 0) unit 2 | -------------------------------------------------------------------------------- /simplebool/examples/ex4.sb: -------------------------------------------------------------------------------- 1 | if true then true else false 2 | -------------------------------------------------------------------------------- /arith/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /fullsimple/examples/ex10.fs: -------------------------------------------------------------------------------- 1 | (lambda x:{Bool,Nat}. x.3) {true, 0} 2 | -------------------------------------------------------------------------------- /fullsimple/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /fullsimple/examples/ex2.fs: -------------------------------------------------------------------------------- 1 | (lambda x:Nat. succ (succ x)) (succ 0) 2 | -------------------------------------------------------------------------------- /fullsimple/examples/ex6.fs: -------------------------------------------------------------------------------- 1 | {if true then false else true, pred (succ 0)}.2 -------------------------------------------------------------------------------- /simplebool/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /simplebool/examples/ex9.sb: -------------------------------------------------------------------------------- 1 | if (lambda x:Bool. x) then true else false 2 | -------------------------------------------------------------------------------- /tyarith/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /untyped/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /arith/examples/ex1.a: -------------------------------------------------------------------------------- 1 | if (if zero? 0 then true else false) then true else false -------------------------------------------------------------------------------- /arith/examples/ex4.a: -------------------------------------------------------------------------------- 1 | if true then true else (if false then false else false) -------------------------------------------------------------------------------- /fullsimple/examples/ex7.fs: -------------------------------------------------------------------------------- 1 | (if false then {0, true} else {succ 0, false}).2 -------------------------------------------------------------------------------- /simplebool/examples/ex11.sb: -------------------------------------------------------------------------------- 1 | if true then (lambda x:Bool. x) else false 2 | -------------------------------------------------------------------------------- /fullsimple/examples/ex4.fs: -------------------------------------------------------------------------------- 1 | (lambda x:Nat. if zero? x then succ x else x) (succ 0) -------------------------------------------------------------------------------- /simplebool/examples/ex5.sb: -------------------------------------------------------------------------------- 1 | (lambda x:Bool. if x then false else true) false 2 | -------------------------------------------------------------------------------- /simplebool/examples/ex6.sb: -------------------------------------------------------------------------------- 1 | (lambda x:Bool->Bool. x true) (lambda x:Bool. x) 2 | -------------------------------------------------------------------------------- /tyarith/README.md: -------------------------------------------------------------------------------- 1 | ## tyarith 2 | 3 | Typed arithmetic expressions (see arith). 4 | -------------------------------------------------------------------------------- /simplebool/examples/ex10.sb: -------------------------------------------------------------------------------- 1 | (lambda x:Bool. if x then true else false) (lambda x:Bool. x) 2 | -------------------------------------------------------------------------------- /untyped/examples/ex10.u: -------------------------------------------------------------------------------- 1 | ((lambda n. lambda s. lambda z. s (n s z)) (lambda s. lambda z. s (s z))) -------------------------------------------------------------------------------- /untyped/examples/ex9.u: -------------------------------------------------------------------------------- 1 | ((lambda n. (lambda s. (lambda z. s (n s z)))) (lambda s. (lambda z. z))) -------------------------------------------------------------------------------- /arith/examples/ex5.a: -------------------------------------------------------------------------------- 1 | if (zero? (if (zero? 0) then 0 else (succ 0))) 2 | then succ 0 3 | else succ (succ 0) -------------------------------------------------------------------------------- /fullsimple/examples/ex3.fs: -------------------------------------------------------------------------------- 1 | (lambda x:Nat->Bool. if (x 0) then (succ 0) else (pred 0)) (lambda x:Nat. zero? x) 2 | -------------------------------------------------------------------------------- /simplebool/examples/ex7.sb: -------------------------------------------------------------------------------- 1 | (lambda x:Bool->Bool. if x false then true else false) (lambda x:Bool. if x then false else true) 2 | -------------------------------------------------------------------------------- /untyped/examples/ex5.u: -------------------------------------------------------------------------------- 1 | ((lambda l. (lambda m. (lambda n. l m n))) (lambda t. (lambda f. f)) (lambda t. (lambda f. t)) (lambda t. (lambda f. f))) -------------------------------------------------------------------------------- /untyped/examples/ex4.u: -------------------------------------------------------------------------------- 1 | ((lambda l. (lambda m. (lambda n. l m n))) (lambda t. (lambda f. t)) (lambda t. (lambda f. t)) (lambda t. (lambda f. f))) 2 | -------------------------------------------------------------------------------- /untyped/examples/ex6.u: -------------------------------------------------------------------------------- 1 | ((lambda p. p (lambda t. (lambda f. t))) ((lambda f. (lambda s. (lambda b. b f s))) (lambda t. (lambda f. t)) (lambda t. (lambda f. f)))) -------------------------------------------------------------------------------- /untyped/examples/ex7.u: -------------------------------------------------------------------------------- 1 | ((lambda p. p (lambda t. (lambda f. f))) ((lambda f. (lambda s. (lambda b. b f s))) (lambda t. (lambda f. t)) (lambda t. (lambda f. f)))) -------------------------------------------------------------------------------- /arith/src/Arith/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Arith.Syntax where 2 | 3 | data Term = TermTrue 4 | | TermFalse 5 | | TermIf Term Term Term 6 | | TermZero 7 | | TermSucc Term 8 | | TermPred Term 9 | | TermIsZero Term 10 | deriving (Show) 11 | -------------------------------------------------------------------------------- /arith/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Arith.Evaluator 4 | import Arith.Parser 5 | import System.Environment 6 | import Text.Parsec 7 | 8 | main :: IO () 9 | main = 10 | do args <- getArgs 11 | case args of 12 | [sourceFile] -> 13 | do parseTree <- fmap (parse parseTerm "arith") $ readFile sourceFile 14 | putStrLn $ show parseTree 15 | case parseTree of 16 | Right expr -> putStrLn $ "=> " ++ (show . eval) expr 17 | Left err -> putStrLn $ show err 18 | _ -> putStrLn "Usage: arith " 19 | -------------------------------------------------------------------------------- /untyped/src/Untyped/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Untyped.Syntax where 2 | 3 | import Untyped.Context 4 | 5 | data Term = TermVar Int Int 6 | | TermAbs String Term 7 | | TermApp Term Term 8 | deriving (Show) 9 | 10 | showTerm :: Context -> Term -> String 11 | showTerm ctx t = 12 | case t of 13 | TermVar n _ -> 14 | getVarName n ctx 15 | TermAbs x t1 -> 16 | let (x', ctx') = freshVarName x ctx 17 | in "(lambda " ++ x' ++ "." ++ showTerm ctx' t1 ++ ")" 18 | TermApp t1 t2 -> 19 | "(" ++ showTerm ctx t1 ++ " " ++ showTerm ctx t2 ++ ")" 20 | 21 | -------------------------------------------------------------------------------- /fullsimple/src/Fullsimple/Types.hs: -------------------------------------------------------------------------------- 1 | module Fullsimple.Types where 2 | 3 | import Data.List 4 | 5 | data Type = TypeUnit 6 | | TypeBool 7 | | TypeNat 8 | | TypeProduct [Type] 9 | | TypeArrow Type Type 10 | deriving (Eq) 11 | 12 | instance Show Type where 13 | show TypeUnit = "Unit" 14 | show TypeBool = "Bool" 15 | show TypeNat = "Nat" 16 | show (TypeProduct tyTs) = "{" ++ (concat . intersperse ", " . map show) tyTs ++ "}" 17 | show (TypeArrow tyT1 tyT2) = show tyT1 ++ "->" ++ show tyT2 18 | 19 | -------------------------------------------------------------------------------- /fullsimple/src/Fullsimple/Terms.hs: -------------------------------------------------------------------------------- 1 | module Fullsimple.Terms where 2 | 3 | import Fullsimple.Types 4 | 5 | data Term = TermUnit 6 | | TermAscription Term Type 7 | | TermTrue 8 | | TermFalse 9 | | TermIf Term Term Term 10 | | TermZero 11 | | TermSucc Term 12 | | TermPred Term 13 | | TermIsZero Term 14 | | TermProduct [Term] 15 | | TermProj Int Term 16 | | TermVar Int Int 17 | | TermAbs String Type Term 18 | | TermApp Term Term 19 | deriving (Eq, Show) 20 | 21 | -------------------------------------------------------------------------------- /simplebool/README.md: -------------------------------------------------------------------------------- 1 | # simplebool 2 | 3 | The pure simply typed lambda calculus (with Booleans). 4 | 5 | ## Examples 6 | 7 | Well-typed examples: 8 | 9 | * `ex1.sb` - Top-level Boolean literal 10 | * `ex2.sb` - That other Boolean literal 11 | * `ex3.sb` - Simple application on a Boolean 12 | * `ex4.sb` - Simple conditional 13 | * `ex5.sb` - More lambda application 14 | * `ex6.sb` - Simple application on a lambda abstraction 15 | * `ex7.sb` - Nested applications of lambda abstractions 16 | 17 | Ill-typed examples: 18 | 19 | * `ex8.sb` - AppArrowTypeExpected 20 | * `ex9.sb` - IfGuardNotBool 21 | * `ex10.sb` - ArrowParamTypeMismatch 22 | * `ex11.sb` - IfArmsTypeMismatch 23 | -------------------------------------------------------------------------------- /untyped/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Environment 4 | import Text.Parsec 5 | import Untyped.Context 6 | import Untyped.Evaluator 7 | import Untyped.Parser 8 | import Untyped.Syntax 9 | 10 | main :: IO () 11 | main = 12 | do args <- getArgs 13 | case args of 14 | [sourceFile] -> 15 | do let ctx = mkContext 16 | parseTree <- fmap (runParser parseTerm ctx "untyped") (readFile sourceFile) 17 | case parseTree of 18 | Right expr -> putStrLn $ "Evaluating " ++ (show parseTree) ++ "\n=> " ++ (showTerm ctx . eval) expr 19 | Left err -> putStrLn $ show err 20 | _ -> putStrLn "Usage: untyped " 21 | -------------------------------------------------------------------------------- /tyarith/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Arith.Evaluator 4 | import Arith.Parser 5 | import System.Environment 6 | import Text.Parsec 7 | import Tyarith.Typechecker 8 | 9 | main :: IO () 10 | main = 11 | do args <- getArgs 12 | case args of 13 | [sourceFile] -> 14 | do parseTree <- fmap (parse parseTerm "arith") $ readFile sourceFile 15 | case parseTree of 16 | Right expr -> 17 | case typeOf expr of 18 | Right ty -> putStrLn $ "=> " ++ (show . eval) expr 19 | Left err -> putStrLn $ "Type Error: " ++ (show err) 20 | Left err -> putStrLn $ "Parsing Error: " ++ (show err) 21 | _ -> putStrLn "Usage: tyarith " 22 | -------------------------------------------------------------------------------- /fullsimple/README.md: -------------------------------------------------------------------------------- 1 | # fullsimple 2 | 3 | The simply typed lambda calculus with additional extensions as 4 | described below. 5 | 6 | ## Extensions 7 | 8 | `fullsimple` augments the pure untyped lambda calculus with 9 | 10 | - [x] first-order types 11 | - [x] boolean primitives 12 | - [x] natural number primitives (Church/Peano-encoded natural numbers) 13 | - [ ] string primitives 14 | - [ ] float primitives 15 | - [ ] uninterpreted base types 16 | - [x] unit type 17 | - [x] sequencing 18 | - [x] wildcards 19 | - [x] ascription (type annotation) 20 | - [ ] let bindings 21 | - [x] product types 22 | - [x] pairs 23 | - [x] tuples 24 | - [ ] records 25 | - [x] binary sum types 26 | - [ ] variants 27 | - [ ] recursion 28 | - [ ] lists 29 | 30 | ## Examples 31 | 32 | -------------------------------------------------------------------------------- /untyped/src/Untyped/Context.hs: -------------------------------------------------------------------------------- 1 | module Untyped.Context where 2 | 3 | type Context = [String] 4 | 5 | mkContext :: Context 6 | mkContext = [] 7 | 8 | bindVarName :: String -> Context -> Context 9 | bindVarName = (:) 10 | 11 | getVarName :: Int -> Context -> String 12 | getVarName n ctx 13 | | length ctx > n = ctx !! n 14 | | otherwise = error $ ("Requested index " ++ show n 15 | ++ " of Context of length " ++ show (length ctx)) 16 | 17 | freshVarName :: String -> Context -> (String, Context) 18 | freshVarName x ctx = 19 | let x' = mkFreshVarName x ctx 20 | in (x', bindVarName x' ctx) 21 | 22 | mkFreshVarName :: String -> Context -> String 23 | mkFreshVarName x [] = x 24 | mkFreshVarName x ctx@(b:bs) 25 | | x == b = mkFreshVarName (x ++ "'") ctx 26 | | otherwise = mkFreshVarName x bs 27 | 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # tapl-haskell 2 | 3 | Implementations from studying 4 | [Types and Programming Languages](http://www.cis.upenn.edu/~bcpierce/tapl/) 5 | by Benjamin C. Pierce. 6 | 7 | ## Building 8 | 9 | All projects assume you have GHC >=7.8 installed (though with 10 | modification to `.cabal` build files, they'll probably work just fine 11 | on 7.6) and a recent enough version of `cabal-install` to utilize 12 | sandboxes. Then each project can be built with the following: 13 | 14 | ``` 15 | $ cabal sandbox init 16 | $ cabal install --only-dependencies 17 | $ cabal build 18 | ``` 19 | 20 | Examples of the implementation language can be found in `examples/` 21 | for each project subdirectory to test the compiler/REPL. 22 | 23 | ``` 24 | $ cabal run examples/ex1.u 25 | ``` 26 | 27 | ## License 28 | 29 | Copyright © 2014 Edward Cho. 30 | 31 | Distributed under the MIT License. 32 | -------------------------------------------------------------------------------- /simplebool/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Simplebool.Context 4 | import Simplebool.Evaluator 5 | import Simplebool.Parser 6 | import Simplebool.Syntax 7 | import Simplebool.Typechecker 8 | import System.Environment 9 | import Text.Parsec 10 | 11 | main :: IO () 12 | main = 13 | do args <- getArgs 14 | case args of 15 | [sourceFile] -> 16 | do let ctx = mkContext 17 | parseTree <- fmap (runParser parseTerm ctx "simplebool") 18 | (readFile sourceFile) 19 | case parseTree of 20 | Right expr -> 21 | case typeOf ctx expr of 22 | Right ty -> putStrLn $ "=> " ++ (showTerm ctx . eval) expr 23 | Left err -> putStrLn $ "Type Error: " ++ show err 24 | Left err -> putStrLn $ "Parsing Error: " ++ show err 25 | _ -> putStrLn "Usage: simplebool " 26 | 27 | -------------------------------------------------------------------------------- /untyped/README.md: -------------------------------------------------------------------------------- 1 | # untyped 2 | 3 | The pure untyped lambda calculus. 4 | 5 | ## Examples 6 | 7 | * `ex1.u` - Unbound top-level variable 8 | * `ex2.u` - Top-level lambda abstraction 9 | * `ex3.u` - Simple application 10 | * `ex4.u`, `ex5.u` - Church Boolean test combinator where 11 | 12 | ``` 13 | true = lambda t. lambda f. t 14 | false = lambda t. lambda f. f 15 | test = lambda l. lambda m. lambda n. l m n 16 | ``` 17 | 18 | * `ex6.u`, `ex7.u` - Pair combinators with Church Booleans where 19 | 20 | ``` 21 | pair = lambda f. lambda s. lambda b. b f s 22 | first = lambda p. p true 23 | second = lambda p. p false 24 | ``` 25 | 26 | * `ex8.u`, `ex9.u`, `ex10.u` - Church Numerals where 27 | 28 | ``` 29 | 0 = lambda s. lambda z. z 30 | 1 = lambda s. lambda z. s z 31 | 2 = lambda s. lambda z. s (s z) 32 | 3 = lambda s. lambda z. s (s (s z)) 33 | etc. 34 | ``` 35 | 36 | and 37 | 38 | ``` 39 | succ = lambda n. lambda s. lambda z. s (n s z) 40 | ``` 41 | -------------------------------------------------------------------------------- /simplebool/src/Simplebool/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Simplebool.Syntax where 2 | 3 | import Simplebool.Context 4 | 5 | data Term = TermTrue 6 | | TermFalse 7 | | TermIf Term Term Term 8 | | TermVar Int Int 9 | | TermAbs String Type Term 10 | | TermApp Term Term 11 | deriving (Eq, Show) 12 | 13 | showTerm :: Context -> Term -> String 14 | showTerm ctx t = 15 | case t of 16 | TermTrue -> "true" 17 | TermFalse -> "false" 18 | TermIf t1 t2 t3 -> 19 | "(if " ++ showTerm ctx t1 ++ " then " ++ showTerm ctx t2 ++ " else " ++ showTerm ctx t3 ++ ")" 20 | TermVar n _ -> 21 | case getName n ctx of 22 | Just x -> x 23 | Nothing -> "" 24 | TermAbs x tyX t1 -> 25 | let (x', ctx') = freshVarName x ctx 26 | in "(lambda " ++ x' ++ ":" ++ show tyX ++ "." ++ showTerm ctx' t1 ++ ")" 27 | TermApp t1 t2 -> 28 | "(" ++ showTerm ctx t1 ++ " " ++ showTerm ctx t2 ++ ")" 29 | -------------------------------------------------------------------------------- /tyarith/tyarith.cabal: -------------------------------------------------------------------------------- 1 | -- Initial tyarith.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: tyarith 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: Edward Cho 11 | maintainer: zerokarmaleft@gmail.com 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Tyarith.Typechecker 20 | build-depends: base >=4.7 && <4.8 21 | , arith >=0.1.0.0 22 | hs-source-dirs: src 23 | default-language: Haskell2010 24 | 25 | executable tyarith 26 | main-is: Main.hs 27 | build-depends: base >=4.7 && <4.8 28 | , arith >=0.1.0.0 29 | , parsec >=3.1.5 30 | hs-source-dirs: src 31 | default-language: Haskell2010 32 | -------------------------------------------------------------------------------- /fullsimple/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Fullsimple.Context 4 | import Fullsimple.Evaluator 5 | import Fullsimple.Parser 6 | import Fullsimple.Printer 7 | import Fullsimple.Typechecker 8 | import System.Environment 9 | import Text.Parsec 10 | 11 | main :: IO () 12 | main = 13 | do args <- getArgs 14 | case args of 15 | [sourceFile] -> 16 | do let ctx = mkContext 17 | parseTree <- fmap (runParser parseTerm ctx "fullsimple") 18 | (readFile sourceFile) 19 | case parseTree of 20 | Right expr -> 21 | case typeOf ctx expr of 22 | Right ty -> 23 | do putStrLn $ "Evaluating (" ++ (show expr) ++ ")" 24 | putStrLn $ "=> " ++ (printTerm ctx . eval) expr 25 | Left err -> 26 | putStrLn $ "Type Error in (" ++ show expr ++ "): " ++ show err 27 | Left err -> putStrLn $ "Parsing Error: " ++ show err 28 | _ -> putStrLn "Usage: fullsimple " 29 | 30 | -------------------------------------------------------------------------------- /arith/src/Arith/Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Arith.Evaluator (eval1, eval) where 2 | 3 | import Arith.Syntax 4 | import Control.Monad 5 | 6 | eval1 :: Term -> Maybe Term 7 | eval1 TermTrue = Nothing 8 | eval1 TermFalse = Nothing 9 | eval1 (TermIf TermTrue t2 _ ) = return t2 10 | eval1 (TermIf TermFalse _ t3) = return t3 11 | eval1 (TermIf t1 t2 t3) = liftM3 TermIf (eval1 t1) (return t2) (return t3) 12 | eval1 TermZero = Nothing 13 | eval1 (TermSucc t) = liftM TermSucc (eval1 t) 14 | eval1 (TermPred TermZero) = return TermZero 15 | eval1 (TermPred (TermSucc t)) = return t 16 | eval1 (TermPred t) = liftM TermPred (eval1 t) 17 | eval1 (TermIsZero TermZero) = return TermTrue 18 | eval1 (TermIsZero (TermSucc TermZero)) = return TermFalse 19 | eval1 (TermIsZero t) = liftM TermIsZero (eval1 t) 20 | 21 | eval :: Term -> Term 22 | eval t = 23 | case eval1 t of 24 | Just t' -> eval t' 25 | Nothing -> t 26 | -------------------------------------------------------------------------------- /fullsimple/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Edward Cho 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /simplebool/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Edward Cho 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /tyarith/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Edward Cho 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /untyped/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Edward Cho 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /arith/arith.cabal: -------------------------------------------------------------------------------- 1 | -- Initial arith.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: arith 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: Edward Cho 11 | maintainer: zerokarmaleft@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Arith.Syntax 20 | Arith.Evaluator 21 | Arith.Parser 22 | build-depends: base >=4.7 && <4.8 23 | , parsec >=3.1.5 24 | hs-source-dirs: src 25 | default-language: Haskell2010 26 | ghc-options: -Wall -fno-warn-unused-do-bind 27 | 28 | executable arith 29 | main-is: Main.hs 30 | build-depends: base >=4.7 && <4.8 31 | , parsec >=3.1.5 32 | hs-source-dirs: src 33 | default-language: Haskell2010 -------------------------------------------------------------------------------- /fullsimple/src/Fullsimple/Context.hs: -------------------------------------------------------------------------------- 1 | module Fullsimple.Context where 2 | 3 | import Fullsimple.Types 4 | import Control.Monad 5 | 6 | type Context = [(String, Binding)] 7 | 8 | data Binding = NameBinding 9 | | VarBinding Type 10 | deriving (Eq, Show) 11 | 12 | mkContext :: Context 13 | mkContext = [] 14 | 15 | addBinding :: (String, Binding) -> Context -> Context 16 | addBinding = (:) 17 | 18 | getBinding :: String -> Context -> Maybe Binding 19 | getBinding = lookup 20 | 21 | getIndex :: Int -> Context -> Maybe (String, Binding) 22 | getIndex n ctx 23 | | length ctx > n = Just $ ctx !! n 24 | | otherwise = Nothing 25 | 26 | getName :: Int -> Context -> Maybe String 27 | getName n ctx = liftM fst $ getIndex n ctx 28 | 29 | getType :: Int -> Context -> Maybe Binding 30 | getType n ctx = liftM snd $ getIndex n ctx 31 | 32 | freshVarName :: String -> Context -> (String, Context) 33 | freshVarName x ctx = 34 | let x' = mkFreshVarName x ctx 35 | in (x', addBinding (x', NameBinding) ctx) 36 | 37 | mkFreshVarName :: String -> Context -> String 38 | mkFreshVarName x [] = x 39 | mkFreshVarName x ctx@(b:bs) 40 | | x == fst b = mkFreshVarName (x ++ "'") ctx 41 | | otherwise = mkFreshVarName x bs 42 | 43 | -------------------------------------------------------------------------------- /untyped/untyped.cabal: -------------------------------------------------------------------------------- 1 | -- Initial untyped.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: untyped 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: Edward Cho 11 | maintainer: zerokarmaleft@gmail.com 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Untyped.Context 20 | Untyped.Evaluator 21 | Untyped.Parser 22 | Untyped.Syntax 23 | build-depends: base >=4.7 && <4.8 24 | , parsec >=3.1.5 25 | , transformers >=0.4.1.0 26 | hs-source-dirs: src 27 | default-language: Haskell2010 28 | ghc-options: -Wall -fno-warn-unused-do-bind -fprof-auto 29 | 30 | executable untyped 31 | main-is: Main.hs 32 | build-depends: base >=4.7 && <4.8 33 | , parsec >=3.1.5 34 | , transformers >=0.4.1.0 35 | hs-source-dirs: src 36 | default-language: Haskell2010 37 | -------------------------------------------------------------------------------- /tyarith/src/Tyarith/Typechecker.hs: -------------------------------------------------------------------------------- 1 | module Tyarith.Typechecker where 2 | 3 | import Arith.Evaluator 4 | import Arith.Parser 5 | import Arith.Syntax 6 | 7 | data Type = TypeBool 8 | | TypeNat 9 | deriving (Eq, Show) 10 | 11 | data TypeError = IfGuardNotBool 12 | | IfArmsNotSameType 13 | | SuccArgNotNat 14 | | PredArgNotNat 15 | | IsZeroArgNotNat 16 | deriving (Eq, Show) 17 | 18 | typeOf :: Term -> Either TypeError Type 19 | typeOf TermTrue = Right TypeBool 20 | typeOf TermFalse = Right TypeBool 21 | typeOf (TermIf t1 t2 t3) 22 | | typeOf t1 == Right TypeBool = if typeOf t2 == typeOf t3 23 | then typeOf t2 24 | else Left IfArmsNotSameType 25 | | otherwise = Left IfGuardNotBool 26 | typeOf TermZero = Right TypeNat 27 | typeOf (TermSucc t1) 28 | | typeOf t1 == Right TypeNat = Right TypeNat 29 | | otherwise = Left SuccArgNotNat 30 | typeOf (TermPred t1) 31 | | typeOf t1 == Right TypeNat = Right TypeNat 32 | | otherwise = Left PredArgNotNat 33 | typeOf (TermIsZero t1) 34 | | typeOf t1 == Right TypeNat = Right TypeNat 35 | | otherwise = Left IsZeroArgNotNat 36 | 37 | -------------------------------------------------------------------------------- /simplebool/simplebool.cabal: -------------------------------------------------------------------------------- 1 | -- Initial simplebool.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: simplebool 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: Edward Cho 11 | maintainer: zerokarmaleft@gmail.com 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Simplebool.Context 20 | Simplebool.Evaluator 21 | Simplebool.Parser 22 | Simplebool.Syntax 23 | Simplebool.Typechecker 24 | build-depends: base >=4.7 && <4.8 25 | , parsec >=3.1.5 26 | , transformers >=0.4.1.0 27 | hs-source-dirs: src 28 | default-language: Haskell2010 29 | ghc-options: -Wall -fno-warn-unused-do-bind 30 | 31 | executable simplebool 32 | main-is: Main.hs 33 | build-depends: base >=4.7 && <4.8 34 | , parsec >=3.1.5 35 | , transformers >=0.4.1.0 36 | hs-source-dirs: src 37 | default-language: Haskell2010 38 | -------------------------------------------------------------------------------- /fullsimple/fullsimple.cabal: -------------------------------------------------------------------------------- 1 | -- Initial fullsimple.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: fullsimple 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: Edward Cho 11 | maintainer: zerokarmaleft@gmail.com 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Fullsimple.Context 20 | Fullsimple.Evaluator 21 | Fullsimple.Parser 22 | Fullsimple.Printer 23 | Fullsimple.Terms 24 | Fullsimple.Typechecker 25 | Fullsimple.Types 26 | build-depends: base >=4.7 && <4.8 27 | , parsec >=3.1.5 28 | , transformers >=0.4.1.0 29 | hs-source-dirs: src 30 | default-language: Haskell2010 31 | 32 | executable fullsimple 33 | main-is: Main.hs 34 | build-depends: base >=4.7 && <4.8 35 | , parsec >=3.1.5 36 | , transformers >=0.4.1.0 37 | hs-source-dirs: src 38 | default-language: Haskell2010 39 | -------------------------------------------------------------------------------- /simplebool/src/Simplebool/Context.hs: -------------------------------------------------------------------------------- 1 | module Simplebool.Context where 2 | 3 | import Control.Monad 4 | 5 | data Type = TypeBool 6 | | TypeArrow Type Type 7 | deriving (Eq) 8 | 9 | type Context = [(String, Binding)] 10 | 11 | data Binding = NameBinding 12 | | VarBinding Type 13 | deriving (Eq, Show) 14 | 15 | instance Show Type where 16 | show TypeBool = "Bool" 17 | show (TypeArrow tyT1 tyT2) = show tyT1 ++ "->" ++ show tyT2 18 | 19 | mkContext :: Context 20 | mkContext = [] 21 | 22 | addBinding :: (String, Binding) -> Context -> Context 23 | addBinding = (:) 24 | 25 | getBinding :: String -> Context -> Maybe Binding 26 | getBinding = lookup 27 | 28 | getIndex :: Int -> Context -> Maybe (String, Binding) 29 | getIndex n ctx 30 | | length ctx > n = Just $ ctx !! n 31 | | otherwise = Nothing 32 | 33 | getName :: Int -> Context -> Maybe String 34 | getName n ctx = liftM fst $ getIndex n ctx 35 | 36 | getType :: Int -> Context -> Maybe Binding 37 | getType n ctx = liftM snd $ getIndex n ctx 38 | 39 | freshVarName :: String -> Context -> (String, Context) 40 | freshVarName x ctx = 41 | let x' = mkFreshVarName x ctx 42 | in (x', addBinding (x', NameBinding) ctx) 43 | 44 | mkFreshVarName :: String -> Context -> String 45 | mkFreshVarName x [] = x 46 | mkFreshVarName x ctx@(b:bs) 47 | | x == fst b = mkFreshVarName (x ++ "'") ctx 48 | | otherwise = mkFreshVarName x bs 49 | -------------------------------------------------------------------------------- /arith/src/Arith/Parser.hs: -------------------------------------------------------------------------------- 1 | module Arith.Parser (parseTerm) where 2 | 3 | import Arith.Syntax 4 | import Text.Parsec 5 | import Text.Parsec.String 6 | 7 | parseTrue :: Parser Term 8 | parseTrue = string "true" >> return TermTrue 9 | 10 | parseFalse :: Parser Term 11 | parseFalse = string "false" >> return TermFalse 12 | 13 | parseIf :: Parser Term 14 | parseIf = 15 | do string "if" 16 | space 17 | predicate <- parseTerm 18 | space 19 | string "then" 20 | space 21 | consequent <- parseTerm 22 | space 23 | string "else" 24 | space 25 | antecedent <- parseTerm 26 | return $ TermIf predicate consequent antecedent 27 | 28 | parseZero :: Parser Term 29 | parseZero = string "0" >> return TermZero 30 | 31 | parseSucc :: Parser Term 32 | parseSucc = 33 | do string "succ" 34 | space 35 | spaces 36 | t <- parseTerm 37 | return $ TermSucc t 38 | 39 | parsePred :: Parser Term 40 | parsePred = 41 | do string "pred" 42 | space 43 | spaces 44 | t <- parseTerm 45 | return $ TermPred t 46 | 47 | parseIsZero :: Parser Term 48 | parseIsZero = 49 | do string "zero?" 50 | space 51 | t <- parseTerm 52 | return $ TermIsZero t 53 | 54 | parseTerm :: Parser Term 55 | parseTerm = 56 | parseTrue <|> 57 | parseFalse <|> 58 | parseIf <|> 59 | parseZero <|> 60 | parseSucc <|> 61 | parsePred <|> 62 | parseIsZero <|> 63 | between (string "(") (string ")") parseTerm 64 | -------------------------------------------------------------------------------- /untyped/src/Untyped/Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Untyped.Evaluator where 2 | 3 | import Control.Monad 4 | import Untyped.Syntax 5 | 6 | -- Variable Shifting and Substitution 7 | -- 8 | 9 | shiftTerm :: Int -> Term -> Term 10 | shiftTerm d = walk 0 11 | where walk c (TermVar x n) 12 | | x >= c = TermVar (x+d) (n+d) 13 | | otherwise = TermVar x (n+d) 14 | walk c (TermAbs x t1) = TermAbs x (walk (c+1) t1) 15 | walk c (TermApp t1 t2) = TermApp (walk c t1) (walk c t2) 16 | 17 | substTerm :: Int -> Term -> Term -> Term 18 | substTerm j s = walk 0 19 | where walk c (TermVar x n) 20 | | x == j+c = s 21 | | otherwise = TermVar x n 22 | walk c (TermAbs x t1) = TermAbs x (walk (c+1) t1) 23 | walk c (TermApp t1 t2) = TermApp (walk c t1) (walk c t2) 24 | 25 | substTopTerm :: Term -> Term -> Term 26 | substTopTerm s t = shiftTerm (-1) (substTerm 0 (shiftTerm 1 s) t) 27 | 28 | -- Evaluation 29 | -- 30 | 31 | isValue :: Term -> Bool 32 | isValue (TermAbs _ _) = True 33 | isValue _ = False 34 | 35 | eval1 :: Term -> Maybe Term 36 | eval1 (TermApp (TermAbs _ t12) v2) 37 | | isValue v2 = return $ substTopTerm v2 t12 38 | eval1 (TermApp t1 t2) 39 | | isValue t1 = liftM2 TermApp (return t1) (eval1 t2) 40 | | otherwise = liftM2 TermApp (eval1 t1) (return t2) 41 | eval1 _ = Nothing 42 | 43 | eval :: Term -> Term 44 | eval t = 45 | case eval1 t of 46 | Just t' -> eval t' 47 | Nothing -> t 48 | 49 | -------------------------------------------------------------------------------- /simplebool/src/Simplebool/Typechecker.hs: -------------------------------------------------------------------------------- 1 | module Simplebool.Typechecker where 2 | 3 | import Simplebool.Context 4 | import Simplebool.Syntax 5 | 6 | data TypeError = IfArmsTypeMismatch 7 | | IfGuardNotBool 8 | | ArrowParamTypeMismatch 9 | | AppArrowTypeExpected 10 | | VarTypeErrorWat 11 | deriving (Eq, Show) 12 | 13 | typeOf :: Context -> Term -> Either TypeError Type 14 | typeOf _ TermTrue = Right TypeBool 15 | typeOf _ TermFalse = Right TypeBool 16 | typeOf ctx (TermIf t1 t2 t3) = 17 | if typeOf ctx t1 == Right TypeBool 18 | then if typeOf ctx t2 == typeOf ctx t3 19 | then typeOf ctx t2 20 | else Left IfArmsTypeMismatch 21 | else Left IfGuardNotBool 22 | typeOf ctx (TermVar x _) = 23 | case getType x ctx of 24 | Just (VarBinding tyT) -> Right tyT 25 | _ -> Left VarTypeErrorWat 26 | typeOf ctx (TermAbs x tyT1 t2) = 27 | let ctx' = addBinding (x,VarBinding tyT1) ctx 28 | tyT2 = typeOf ctx' t2 29 | in case tyT2 of 30 | Right tyT2' -> Right $ TypeArrow tyT1 tyT2' 31 | Left tyErrT2 -> Left tyErrT2 32 | typeOf ctx (TermApp t1 t2) = 33 | let tyT1 = typeOf ctx t1 34 | tyT2 = typeOf ctx t2 35 | in case tyT1 of 36 | Right (TypeArrow tyT11 tyT12) -> 37 | if tyT2 == Right tyT11 38 | then Right tyT12 39 | else Left ArrowParamTypeMismatch 40 | _ -> Left AppArrowTypeExpected 41 | -------------------------------------------------------------------------------- /fullsimple/src/Fullsimple/Printer.hs: -------------------------------------------------------------------------------- 1 | module Fullsimple.Printer where 2 | 3 | import Control.Monad 4 | import Data.Maybe 5 | import Data.List 6 | import Fullsimple.Context 7 | import Fullsimple.Terms 8 | 9 | foldNat :: Term -> Maybe Int 10 | foldNat TermZero = return 0 11 | foldNat (TermSucc n) = liftM2 (+) (return 1) (foldNat n) 12 | foldNat (TermPred n) = liftM2 (+) (return (-1)) (foldNat n) 13 | foldNat _ = Nothing 14 | 15 | printTerm :: Context -> Term -> String 16 | printTerm ctx TermUnit = "unit" 17 | printTerm ctx TermTrue = "true" 18 | printTerm ctx TermFalse = "false" 19 | printTerm ctx (TermIf t1 t2 t3) = "(if " ++ printTerm ctx t1 ++ " then " ++ printTerm ctx t2 ++ " else " ++ printTerm ctx t3 ++ ")" 20 | printTerm ctx TermZero = "0" 21 | printTerm ctx t@(TermSucc t1) = 22 | let n = foldNat t 23 | in fromMaybe ("(succ " ++ printTerm ctx t1 ++ ")") (liftM show n) 24 | printTerm ctx t@(TermPred t1) = 25 | let n = foldNat t 26 | in fromMaybe ("(pred " ++ printTerm ctx t1 ++ ")") (liftM show n) 27 | printTerm ctx (TermIsZero t1) = "(zero? " ++ printTerm ctx t1 ++ ")" 28 | printTerm ctx (TermProduct ts) = "{" ++ (concat . intersperse ", " . map (printTerm ctx)) ts ++ "}" 29 | printTerm ctx (TermProj i t1) = printTerm ctx t1 ++ "." ++ show i 30 | printTerm ctx (TermVar n _) = fromMaybe "" (getName n ctx) 31 | printTerm ctx (TermAbs x tyX t1) = 32 | let (x', ctx') = freshVarName x ctx 33 | in "(lambda " ++ x' ++ ":" ++ show tyX ++ "." ++ printTerm ctx' t1 ++ ")" 34 | printTerm ctx (TermApp t1 t2) = "(" ++ printTerm ctx t1 ++ " " ++ printTerm ctx t2 ++ ")" 35 | 36 | -------------------------------------------------------------------------------- /simplebool/src/Simplebool/Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Simplebool.Evaluator where 2 | 3 | import Control.Monad 4 | import Simplebool.Syntax 5 | 6 | -- Variable Shifting and Substitution 7 | -- 8 | 9 | shiftTerm :: Int -> Term -> Term 10 | shiftTerm d = walk 0 11 | where walk c (TermIf t1 t2 t3) = TermIf (walk c t1) (walk c t2) (walk c t3) 12 | walk c (TermVar x n) 13 | | x >= c = TermVar (x+d) (n+d) 14 | | otherwise = TermVar x (n+d) 15 | walk c (TermAbs x tyT1 t1) = TermAbs x tyT1 (walk (c+1) t1) 16 | walk c (TermApp t1 t2) = TermApp (walk c t1) (walk c t2) 17 | walk _ t = t 18 | 19 | substTerm :: Int -> Term -> Term -> Term 20 | substTerm j s = walk 0 21 | where walk c (TermIf t1 t2 t3) = TermIf (walk c t1) (walk c t2) (walk c t3) 22 | walk c (TermVar x n) 23 | | x == j+c = s 24 | | otherwise = TermVar x n 25 | walk c (TermAbs x tyT1 t1) = TermAbs x tyT1 (walk (c+1) t1) 26 | walk c (TermApp t1 t2) = TermApp (walk c t1) (walk c t2) 27 | walk _ t1 28 | | t1 == TermTrue = t1 29 | | t1 == TermFalse = t1 30 | | otherwise = s 31 | 32 | applyAbs :: Term -> Term -> Term 33 | applyAbs s t = shiftTerm (-1) (substTerm 0 (shiftTerm 1 s) t) 34 | 35 | -- Evaluation 36 | -- 37 | 38 | isValue :: Term -> Bool 39 | isValue (TermAbs _ _ _) = True 40 | isValue TermTrue = True 41 | isValue TermFalse = True 42 | isValue _ = False 43 | 44 | eval1 :: Term -> Maybe Term 45 | eval1 (TermIf TermTrue t2 _ ) = return t2 46 | eval1 (TermIf TermFalse _ t3) = return t3 47 | eval1 (TermIf t1 t2 t3) = liftM (\t1' -> TermIf t1' t2 t3) (eval1 t1) 48 | eval1 (TermApp (TermAbs _ _ t12) v2) 49 | | isValue v2 = return $ applyAbs v2 t12 50 | eval1 (TermApp t1 t2) 51 | | isValue t1 = liftM2 TermApp (return t1) (eval1 t2) 52 | | otherwise = liftM2 TermApp (eval1 t1) (return t2) 53 | eval1 _ = Nothing 54 | 55 | eval :: Term -> Term 56 | eval t = 57 | case eval1 t of 58 | Just t' -> eval t' 59 | Nothing -> t 60 | -------------------------------------------------------------------------------- /untyped/src/Untyped/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Untyped.Parser where 4 | 5 | import Data.Functor.Identity 6 | import Data.List 7 | import Text.Parsec 8 | import qualified Text.Parsec.Token as P 9 | import Untyped.Context 10 | import Untyped.Syntax 11 | 12 | type Parser a = ParsecT String Context Identity a 13 | 14 | untypedDef :: P.LanguageDef st 15 | untypedDef = 16 | P.LanguageDef { P.commentStart = "" 17 | , P.commentEnd = "" 18 | , P.commentLine = "" 19 | , P.nestedComments = True 20 | , P.identStart = letter 21 | , P.identLetter = alphaNum 22 | , P.opStart = letter 23 | , P.opLetter = alphaNum 24 | , P.reservedOpNames = [ "lambda" ] 25 | , P.reservedNames = [] 26 | , P.caseSensitive = True 27 | } 28 | 29 | lexer :: P.GenTokenParser String u Identity 30 | lexer = P.makeTokenParser untypedDef 31 | 32 | dot :: ParsecT String u Identity String 33 | dot = P.dot lexer 34 | 35 | identifier :: ParsecT String u Identity String 36 | identifier = P.identifier lexer 37 | 38 | parens :: ParsecT String u Identity a -> ParsecT String u Identity a 39 | parens = P.parens lexer 40 | 41 | reserved :: String -> ParsecT String u Identity () 42 | reserved = P.reserved lexer 43 | 44 | getVarIndex :: (Monad m, Eq a) => a -> [a] -> m Int 45 | getVarIndex var ctx = 46 | case elemIndex var ctx of 47 | Just i -> return i 48 | Nothing -> error "Unbound variable name" 49 | 50 | parseVar :: Parser Term 51 | parseVar = 52 | do var <- identifier 53 | ctx <- getState 54 | idx <- getVarIndex var ctx 55 | return $ TermVar idx (length ctx) 56 | 57 | parseAbs :: Parser Term 58 | parseAbs = 59 | do reserved "lambda" 60 | var <- identifier 61 | dot 62 | ctx <- getState 63 | setState $ bindVarName var ctx 64 | term <- parseTerm 65 | setState ctx 66 | return $ TermAbs var term 67 | 68 | parseTerm :: Parser Term 69 | parseTerm = 70 | chainl1 (parseAbs <|> parseVar <|> parens parseTerm) 71 | (return TermApp) 72 | -------------------------------------------------------------------------------- /fullsimple/src/Fullsimple/Typechecker.hs: -------------------------------------------------------------------------------- 1 | module Fullsimple.Typechecker where 2 | 3 | import Control.Monad 4 | import Fullsimple.Context 5 | import Fullsimple.Terms 6 | import Fullsimple.Types 7 | 8 | data TypeError = AscribeTypeExpected Type 9 | | IfArmsTypeMismatch 10 | | IfGuardBoolTypeExpected 11 | | SuccArgNatTypeExpected 12 | | PredArgNatTypeExpected 13 | | IsZeroArgNatTypeExpected 14 | | ProjProductTypeExpected 15 | | ArrowParamTypeMismatch 16 | | AppOpArrowTypeExpected 17 | | VarTypeErrorWat 18 | deriving (Eq, Show) 19 | 20 | typeOf :: Context -> Term -> Either TypeError Type 21 | typeOf _ TermUnit = Right TypeUnit 22 | typeOf ctx (TermAscription t1 tyT1) 23 | | typeOf ctx t1 == Right tyT1 = Right tyT1 24 | | otherwise = Left $ AscribeTypeExpected tyT1 25 | typeOf _ TermTrue = Right TypeBool 26 | typeOf _ TermFalse = Right TypeBool 27 | typeOf ctx (TermIf t1 t2 t3) 28 | | typeOf ctx t1 == Right TypeBool = 29 | if typeOf ctx t2 == typeOf ctx t3 30 | then typeOf ctx t2 31 | else Left IfArmsTypeMismatch 32 | | otherwise = Left IfGuardBoolTypeExpected 33 | typeOf _ TermZero = Right TypeNat 34 | typeOf ctx (TermSucc t1) 35 | | typeOf ctx t1 == Right TypeNat = Right TypeNat 36 | | otherwise = Left SuccArgNatTypeExpected 37 | typeOf ctx (TermPred t1) 38 | | typeOf ctx t1 == Right TypeNat = Right TypeNat 39 | | otherwise = Left PredArgNatTypeExpected 40 | typeOf ctx (TermIsZero t1) 41 | | typeOf ctx t1 == Right TypeNat = Right TypeBool 42 | | otherwise = Left IsZeroArgNatTypeExpected 43 | typeOf ctx (TermProduct ts) = 44 | case mapM (typeOf ctx) ts of 45 | Right tyTs -> Right $ TypeProduct tyTs 46 | Left tyErrTs -> Left tyErrTs 47 | typeOf ctx (TermProj x t1) = 48 | case typeOf ctx t1 of 49 | Right (TypeProduct tys) -> Right (tys !! x) 50 | Right _ -> Left ProjProductTypeExpected 51 | Left tyErr -> Left tyErr 52 | typeOf ctx (TermVar x _) = 53 | case getType x ctx of 54 | Just (VarBinding tyT) -> Right tyT 55 | _ -> Left VarTypeErrorWat 56 | typeOf ctx (TermAbs x tyT1 t2) = 57 | let ctx' = addBinding (x,VarBinding tyT1) ctx 58 | in case typeOf ctx' t2 of 59 | Right tyT2 -> Right $ TypeArrow tyT1 tyT2 60 | Left tyErrT2 -> Left tyErrT2 61 | typeOf ctx (TermApp t1 t2) = 62 | case typeOf ctx t1 of 63 | Right (TypeArrow tyT11 tyT12) -> 64 | case typeOf ctx t2 of 65 | Right tyT2 -> if tyT2 == tyT11 66 | then Right tyT12 67 | else Left ArrowParamTypeMismatch 68 | Left tyErrT2 -> Left tyErrT2 69 | _ -> Left AppOpArrowTypeExpected 70 | -------------------------------------------------------------------------------- /fullsimple/src/Fullsimple/Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Fullsimple.Evaluator where 2 | 3 | import Control.Monad 4 | import Data.List 5 | import Fullsimple.Terms 6 | 7 | -- Variable Shifting and Substitution 8 | -- 9 | 10 | shiftTerm :: Int -> Term -> Term 11 | shiftTerm d = walk 0 12 | where walk c (TermIf t1 t2 t3) = TermIf (walk c t1) (walk c t2) (walk c t3) 13 | walk c (TermVar x n) 14 | | x >= c = TermVar (x+d) (n+d) 15 | | otherwise = TermVar x (n+d) 16 | walk c (TermAbs x tyT1 t1) = TermAbs x tyT1 (walk (c+1) t1) 17 | walk c (TermApp t1 t2) = TermApp (walk c t1) (walk c t2) 18 | walk _ t = t 19 | 20 | substTerm :: Int -> Term -> Term -> Term 21 | substTerm j s = walk 0 22 | where walk c (TermAscription t1 tyT1) = TermAscription (walk c t1) tyT1 23 | walk c (TermIf t1 t2 t3) = TermIf (walk c t1) (walk c t2) (walk c t3) 24 | walk c (TermSucc t1) = TermSucc (walk c t1) 25 | walk c (TermPred t1) = TermPred (walk c t1) 26 | walk c (TermIsZero t1) = TermIsZero (walk c t1) 27 | walk c (TermProduct ts) = TermProduct (map (walk c) ts) 28 | walk c (TermProj x t1) = TermProj x (walk c t1) 29 | walk c (TermVar x n) 30 | | x == j+c = s 31 | | otherwise = TermVar x n 32 | walk c (TermAbs x tyT1 t1) = TermAbs x tyT1 (walk (c+1) t1) 33 | walk c (TermApp t1 t2) = TermApp (walk c t1) (walk c t2) 34 | walk _ t1 35 | | t1 == TermUnit = t1 36 | | t1 == TermTrue = t1 37 | | t1 == TermFalse = t1 38 | | t1 == TermZero = t1 39 | | otherwise = s 40 | 41 | substTopTerm :: Term -> Term -> Term 42 | substTopTerm s t = shiftTerm (-1) (substTerm 0 (shiftTerm 1 s) t) 43 | 44 | -- Evaluation 45 | -- 46 | 47 | isValue :: Term -> Bool 48 | isValue TermUnit = True 49 | isValue TermTrue = True 50 | isValue TermFalse = True 51 | isValue TermZero = True 52 | isValue (TermSucc (TermPred t1)) = False 53 | isValue (TermSucc t1) = isValue t1 54 | isValue (TermPred (TermSucc t1)) = False 55 | isValue (TermPred t1) = isValue t1 56 | isValue (TermProduct ts) = (and . map isValue) ts 57 | isValue (TermAbs _ _ _) = True 58 | isValue _ = False 59 | 60 | eval1 :: Term -> Maybe Term 61 | eval1 (TermAscription t1 tyT1) = return t1 62 | eval1 (TermIf TermTrue t2 _ ) = return t2 63 | eval1 (TermIf TermFalse _ t3) = return t3 64 | eval1 (TermIf t1 t2 t3) = liftM (\t1' -> TermIf t1' t2 t3) (eval1 t1) 65 | eval1 (TermSucc t1) = liftM TermSucc (eval1 t1) 66 | eval1 (TermPred TermZero) = return TermZero 67 | eval1 (TermPred (TermSucc t1)) = return t1 68 | eval1 (TermPred t1) = liftM TermPred (eval1 t1) 69 | eval1 (TermIsZero TermZero) = return TermTrue 70 | eval1 (TermIsZero (TermSucc TermZero)) = return TermFalse 71 | eval1 t@(TermProduct ts) 72 | | isValue t = Nothing 73 | | otherwise = liftM TermProduct (mapM (\t -> if isValue t then return t else eval1 t) ts) 74 | eval1 (TermProj x (TermProduct ts)) = return $ ts !! x 75 | eval1 (TermProj x t1) = liftM2 TermProj (return x) (eval1 t1) 76 | eval1 (TermIsZero t) = liftM TermIsZero (eval1 t) 77 | eval1 (TermApp (TermAbs _ _ t12) v2) 78 | | isValue v2 = return $ substTopTerm v2 t12 79 | eval1 (TermApp t1 t2) 80 | | isValue t1 = liftM2 TermApp (return t1) (eval1 t2) 81 | | otherwise = liftM2 TermApp (eval1 t1) (return t2) 82 | eval1 _ = Nothing 83 | 84 | eval :: Term -> Term 85 | eval t = 86 | case eval1 t of 87 | Just t' -> eval t' 88 | Nothing -> t 89 | 90 | -------------------------------------------------------------------------------- /simplebool/src/Simplebool/Parser.hs: -------------------------------------------------------------------------------- 1 | module Simplebool.Parser where 2 | 3 | import Data.Functor.Identity 4 | import Data.List 5 | import Simplebool.Context 6 | import Simplebool.Syntax 7 | import Text.Parsec 8 | import qualified Text.Parsec.Token as P 9 | 10 | type Parser a = ParsecT String Context Identity a 11 | 12 | simpleboolDef :: P.LanguageDef st 13 | simpleboolDef = 14 | P.LanguageDef { P.commentStart = "" 15 | , P.commentEnd = "" 16 | , P.commentLine = "" 17 | , P.nestedComments = True 18 | , P.identStart = letter 19 | , P.identLetter = alphaNum 20 | , P.opStart = letter 21 | , P.opLetter = alphaNum 22 | , P.reservedOpNames = [ "lambda" 23 | , "if" 24 | , "then" 25 | , "else" 26 | , "true" 27 | , "false" 28 | , "Bool" 29 | ] 30 | , P.reservedNames = [ "lambda" 31 | , "if" 32 | , "then" 33 | , "else" 34 | , "true" 35 | , "false" 36 | , "Bool" 37 | ] 38 | , P.caseSensitive = True 39 | } 40 | 41 | lexer :: P.GenTokenParser String u Identity 42 | lexer = P.makeTokenParser simpleboolDef 43 | 44 | colon :: ParsecT String u Identity String 45 | colon = P.colon lexer 46 | 47 | dot :: ParsecT String u Identity String 48 | dot = P.dot lexer 49 | 50 | identifier :: ParsecT String u Identity String 51 | identifier = P.identifier lexer 52 | 53 | parens :: ParsecT String u Identity a -> ParsecT String u Identity a 54 | parens = P.parens lexer 55 | 56 | reservedOp :: String -> ParsecT String u Identity () 57 | reservedOp = P.reservedOp lexer 58 | 59 | reserved :: String -> ParsecT String u Identity () 60 | reserved = P.reserved lexer 61 | 62 | parseTrue :: Parser Term 63 | parseTrue = reserved "true" >> return TermTrue 64 | 65 | parseFalse :: Parser Term 66 | parseFalse = reserved "false" >> return TermFalse 67 | 68 | parseIf :: Parser Term 69 | parseIf = 70 | do reservedOp "if" 71 | predicate <- parseTerm 72 | reservedOp "then" 73 | consequent <- parseTerm 74 | reservedOp "else" 75 | antecedent <- parseTerm 76 | return $ TermIf predicate consequent antecedent 77 | 78 | getVarIndex :: (Monad m, Eq a) => a -> [(a,b)] -> m Int 79 | getVarIndex var ctx = 80 | case findIndex ((== var) . fst) ctx of 81 | Just i -> return i 82 | Nothing -> error "Unbound variable name" 83 | 84 | parseVar :: Parser Term 85 | parseVar = 86 | do var <- identifier 87 | ctx <- getState 88 | idx <- getVarIndex var ctx 89 | return $ TermVar idx (length ctx) 90 | 91 | parseAbs :: Parser Term 92 | parseAbs = 93 | do reservedOp "lambda" 94 | var <- identifier 95 | tyVar <- parseTypeAnnotation 96 | dot 97 | ctx <- getState 98 | setState $ addBinding (var, VarBinding tyVar) ctx 99 | term <- parseTerm 100 | setState ctx 101 | return $ TermAbs var tyVar term 102 | 103 | parseTypeBool :: Parser Type 104 | parseTypeBool = reserved "Bool" >> return TypeBool 105 | 106 | parseTypeArrow :: Parser Type 107 | parseTypeArrow = 108 | do tyT1 <- parseTypeBool 109 | many space 110 | string "->" 111 | many space 112 | tyT2 <- parseType 113 | return $ TypeArrow tyT1 tyT2 114 | 115 | parseType :: Parser Type 116 | parseType = 117 | try parseTypeArrow <|> parseTypeBool <|> parens parseType 118 | 119 | parseTypeAnnotation :: Parser Type 120 | parseTypeAnnotation = 121 | do colon 122 | parseType 123 | 124 | parseTerm :: Parser Term 125 | parseTerm = 126 | chainl1 (parseTrue <|> 127 | parseFalse <|> 128 | parseIf <|> 129 | parseAbs <|> 130 | parseVar <|> 131 | parens parseTerm) 132 | (return TermApp) 133 | -------------------------------------------------------------------------------- /fullsimple/src/Fullsimple/Parser.hs: -------------------------------------------------------------------------------- 1 | module Fullsimple.Parser where 2 | 3 | import Debug.Trace 4 | 5 | import Data.Functor.Identity 6 | import Data.List 7 | import Fullsimple.Context 8 | import Fullsimple.Terms 9 | import Fullsimple.Types 10 | import Text.Parsec 11 | import qualified Text.Parsec.Expr as Expr 12 | import qualified Text.Parsec.Token as Token 13 | 14 | type Parser a = ParsecT String Context Identity a 15 | 16 | fullsimpleDef :: Token.LanguageDef st 17 | fullsimpleDef = 18 | Token.LanguageDef { Token.commentStart = "" 19 | , Token.commentEnd = "" 20 | , Token.commentLine = "" 21 | , Token.nestedComments = True 22 | , Token.identStart = letter 23 | , Token.identLetter = alphaNum 24 | , Token.opStart = oneOf "-a" 25 | , Token.opLetter = oneOf ">s" 26 | , Token.reservedOpNames = [ "->" 27 | , "as" 28 | ] 29 | , Token.reservedNames = [ "unit" 30 | , "_" 31 | , "true" 32 | , "false" 33 | , "if" 34 | , "then" 35 | , "else" 36 | , "0" 37 | , "succ" 38 | , "pred" 39 | , "zero?" 40 | , "lambda" 41 | , "Bool" 42 | , "Nat" 43 | ] 44 | , Token.caseSensitive = True 45 | } 46 | 47 | lexer :: Token.GenTokenParser String u Identity 48 | lexer = Token.makeTokenParser fullsimpleDef 49 | 50 | comma :: ParsecT String u Identity String 51 | comma = Token.comma lexer 52 | 53 | semi :: ParsecT String u Identity String 54 | semi = Token.semi lexer 55 | 56 | colon :: ParsecT String u Identity String 57 | colon = Token.colon lexer 58 | 59 | dot :: ParsecT String u Identity String 60 | dot = Token.dot lexer 61 | 62 | commaSep :: ParsecT String u Identity a -> ParsecT String u Identity [a] 63 | commaSep = Token.commaSep lexer 64 | 65 | identifier :: ParsecT String u Identity String 66 | identifier = Token.identifier lexer 67 | 68 | parens :: ParsecT String u Identity a -> ParsecT String u Identity a 69 | parens = Token.parens lexer 70 | 71 | braces :: ParsecT String u Identity a -> ParsecT String u Identity a 72 | braces = Token.braces lexer 73 | 74 | reservedOp :: String -> ParsecT String u Identity () 75 | reservedOp = Token.reservedOp lexer 76 | 77 | reserved :: String -> ParsecT String u Identity () 78 | reserved = Token.reserved lexer 79 | 80 | -- Term Expressions 81 | -- 82 | 83 | parseUnit :: Parser Term 84 | parseUnit = reserved "unit" >> traceM "Parsing " >> return TermUnit 85 | 86 | parseAscription :: Parser (Term -> Term) 87 | parseAscription = 88 | do reserved "as" 89 | tyT <- parseType 90 | traceM "Parsing " 91 | return $ (flip TermAscription) tyT 92 | 93 | parseTrue :: Parser Term 94 | parseTrue = reserved "true" >> traceM "Parsing " >> return TermTrue 95 | 96 | parseFalse :: Parser Term 97 | parseFalse = reserved "false" >> traceM "Parsing " >> return TermFalse 98 | 99 | parseIf :: Parser Term 100 | parseIf = 101 | do reservedOp "if" 102 | predicate <- parseTerm 103 | reservedOp "then" 104 | consequent <- parseTerm 105 | reservedOp "else" 106 | antecedent <- parseTerm 107 | traceM "Parsing " 108 | return $ TermIf predicate consequent antecedent 109 | 110 | parseZero :: Parser Term 111 | parseZero = reserved "0" >> traceM "Parsing <0>" >> return TermZero 112 | 113 | parseSucc :: Parser Term 114 | parseSucc = 115 | do reservedOp "succ" 116 | n <- parseTerm 117 | traceM "Parsing " 118 | return $ TermSucc n 119 | 120 | parsePred :: Parser Term 121 | parsePred = 122 | do reservedOp "pred" 123 | n <- parseTerm 124 | traceM "Parsing " 125 | return $ TermPred n 126 | 127 | parseIsZero :: Parser Term 128 | parseIsZero = 129 | do reservedOp "zero?" 130 | n <- parseTerm 131 | traceM "Parsing " 132 | return $ TermIsZero n 133 | 134 | parseProjections :: Parser [Term] 135 | parseProjections = commaSep parseTerm 136 | 137 | parseProduct :: Parser Term 138 | parseProduct = 139 | do ts <- braces parseProjections 140 | traceM "Parsing " 141 | return $ TermProduct ts 142 | 143 | parseProj :: Parser (Term -> Term) 144 | parseProj = 145 | do dot 146 | i <- many1 digit 147 | traceM "Parsing " 148 | return $ TermProj ((read i) - 1) 149 | 150 | getVarIndex :: (Monad m, Eq a) => a -> [(a,b)] -> m Int 151 | getVarIndex var ctx = 152 | case findIndex ((== var) . fst) ctx of 153 | Just i -> return i 154 | Nothing -> error "Unbound variable name" 155 | 156 | parseVar :: Parser Term 157 | parseVar = 158 | do var <- identifier 159 | ctx <- getState 160 | idx <- getVarIndex var ctx 161 | traceM "Parsing " 162 | return $ TermVar idx (length ctx) 163 | 164 | parseWildcardAbs :: Parser Term 165 | parseWildcardAbs = 166 | do reservedOp "lambda" 167 | reserved "_" 168 | tyVar <- parseTypeAnnotation 169 | dot 170 | ctx <- getState 171 | term <- parseTerm 172 | traceM "Parsing " 173 | return $ TermAbs "_" tyVar term 174 | 175 | parseAbs :: Parser Term 176 | parseAbs = 177 | do reservedOp "lambda" 178 | var <- identifier 179 | tyVar <- parseTypeAnnotation 180 | dot 181 | ctx <- getState 182 | setState $ addBinding (var, VarBinding tyVar) ctx 183 | term <- parseTerm 184 | setState ctx 185 | traceM "Parsing " 186 | return $ TermAbs var tyVar term 187 | 188 | parseSequence :: Parser (Term -> Term -> Term) 189 | parseSequence = 190 | do semi 191 | ctx <- getState 192 | traceM "Parsing " 193 | return $ \t1 t2 -> TermApp (TermAbs "_" TypeUnit t2) t1 194 | 195 | parseTerm :: Parser Term 196 | parseTerm = chainl1 parseTermExpr (traceM "Parsing " >> return TermApp) 197 | 198 | parseNonAppTerm :: Parser Term 199 | parseNonAppTerm = (parseUnit <|> 200 | parseTrue <|> 201 | parseFalse <|> 202 | parseIf <|> 203 | parseZero <|> 204 | parseSucc <|> 205 | parsePred <|> 206 | parseIsZero <|> 207 | parseProduct <|> 208 | (try parseWildcardAbs <|> parseAbs) <|> 209 | parseVar <|> 210 | parens parseTerm) 211 | 212 | termOps = [ [Expr.Postfix parseAscription ] 213 | , [Expr.Postfix parseProj ] 214 | , [Expr.Infix parseSequence Expr.AssocLeft] ] 215 | 216 | parseTermExpr :: Parser Term 217 | parseTermExpr = Expr.buildExpressionParser termOps parseNonAppTerm 218 | 219 | -- Type Expressions 220 | -- 221 | 222 | parseTypeUnit :: Parser Type 223 | parseTypeUnit = reserved "Unit" >> traceM "Parsing " >> return TypeUnit 224 | 225 | parseTypeBool :: Parser Type 226 | parseTypeBool = reserved "Bool" >> traceM "Parsing " >> return TypeBool 227 | 228 | parseTypeNat :: Parser Type 229 | parseTypeNat = reserved "Nat" >> traceM "Parsing " >> return TypeNat 230 | 231 | parseTypeProduct :: Parser Type 232 | parseTypeProduct = 233 | do ts <- braces (commaSep parseTypeExpr) 234 | traceM "Parsing " 235 | return $ TypeProduct ts 236 | 237 | parseTypeArrow :: Parser (Type -> Type -> Type) 238 | parseTypeArrow = reservedOp "->" >> traceM "Parsing " >> return TypeArrow 239 | 240 | parseType :: Parser Type 241 | parseType = parseTypeExpr 242 | 243 | parseNonArrowType :: Parser Type 244 | parseNonArrowType = 245 | parseTypeUnit <|> 246 | parseTypeBool <|> 247 | parseTypeNat <|> 248 | parseTypeProduct <|> 249 | parens parseType 250 | 251 | parseTypeAnnotation :: Parser Type 252 | parseTypeAnnotation = colon >> parseType 253 | 254 | typeOps = [ [Expr.Infix parseTypeArrow Expr.AssocLeft] ] 255 | 256 | parseTypeExpr :: Parser Type 257 | parseTypeExpr = Expr.buildExpressionParser typeOps parseNonArrowType 258 | 259 | --------------------------------------------------------------------------------