├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── LICENSE ├── README.md ├── lph.cabal ├── prelude.lp ├── prelude.st ├── src ├── Common.hs ├── Lambda │ ├── AST.hs │ ├── Check.hs │ ├── Eval.hs │ ├── Examples.hs │ ├── Main.hs │ ├── Parser.hs │ ├── Printer.hs │ └── Quote.hs ├── LambdaPi │ ├── AST.hs │ ├── Check.hs │ ├── Eval.hs │ ├── Main.hs │ ├── Parser.hs │ ├── Printer.hs │ └── Quote.hs └── REPL.hs ├── stack.yaml └── stack.yaml.lock /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | on: [push] 2 | name: build 3 | jobs: 4 | runhaskell: 5 | name: stack build 6 | runs-on: ubuntu-latest 7 | steps: 8 | - uses: actions/checkout@v2 9 | - uses: actions/setup-haskell@v1.1.4 10 | with: 11 | ghc-version: '8.8.4' 12 | enable-stack: true 13 | stack-version: '2.5.1' 14 | - run: stack --system-ghc build 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | .idea/ 3 | *.iml 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ilya-klyuchnikov/lambdapi/79ddf21581e03ea34a94cc00ffd5c8684d845ed9/LICENSE -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Dependently Typed Lambda Calculus 2 | 3 | This project is reorganization of the source code for the paper 4 | [A Tutorial Implementation of a Dependently Typed Lambda Calculus](http://www.andres-loeh.de/LambdaPi/). 5 | 6 | The goal of this project is to make code readable and understandable. 7 | 8 | An interested reader may also look at [this darcs repo](http://sneezy.cs.nott.ac.uk/darcs/LambdaPi/). 9 | 10 | The goal of this project is to make reading and navigation of the code as simple as possible. 11 | 12 | ### How to play with examples 13 | 14 | Simply Typed Lambda Calculus 15 | 16 | ``` 17 | $ stack run st 18 | Interpreter for the simply typed lambda calculus. 19 | Type :? for help. 20 | ST> :load prelude.st 21 | ``` 22 | 23 | Dependently Typed Lambda Calculus 24 | 25 | ``` 26 | $ stack run lp 27 | Interpreter for lambda-Pi. 28 | Type :? for help. 29 | LP> :load prelude.lp 30 | ``` 31 | -------------------------------------------------------------------------------- /lph.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: lph 3 | version: 0.1 4 | build-type: Simple 5 | maintainer: Ilya Klyuchnikov 6 | description: Dependently typed lambda calculus 7 | 8 | executable st 9 | build-depends: 10 | base >=4.9.1.0, 11 | mtl >=2.2.1, 12 | parsec >=3.1.11, 13 | pretty >=1.1.3.5 14 | main-is: 15 | Lambda/Main.hs 16 | buildable: 17 | True 18 | hs-source-dirs: 19 | src 20 | other-modules: 21 | Common 22 | REPL 23 | Lambda.AST 24 | Lambda.Check 25 | Lambda.Eval 26 | Lambda.Parser 27 | Lambda.Printer 28 | Lambda.Quote 29 | ghc-options: -main-is Lambda.Main 30 | default-language: Haskell2010 31 | 32 | executable lp 33 | build-depends: 34 | base >=4.9.1.0, 35 | mtl >=2.2.1, 36 | parsec >=3.1.11, 37 | pretty >=1.1.3.5 38 | main-is: LambdaPi/Main.hs 39 | buildable: True 40 | hs-source-dirs: src 41 | other-modules: 42 | Common 43 | REPL 44 | LambdaPi.AST 45 | LambdaPi.Check 46 | LambdaPi.Eval 47 | LambdaPi.Parser 48 | LambdaPi.Printer 49 | LambdaPi.Quote 50 | ghc-options: -main-is LambdaPi.Main 51 | default-language: Haskell2010 52 | -------------------------------------------------------------------------------- /prelude.lp: -------------------------------------------------------------------------------- 1 | 2 | -- identity and const 3 | let id = (\ a x -> x) :: forall (a :: *) . a -> a 4 | let const = (\ a b x y -> x) :: forall (a :: *) (b :: *) . a -> b -> a 5 | 6 | -- addition of natural numbers 7 | let plus = 8 | natElim 9 | ( \ _ -> Nat -> Nat ) -- motive 10 | ( \ n -> n ) -- case for Zero 11 | ( \ p rec n -> Succ (rec n) ) -- case for Succ 12 | 13 | -- predecessor, mapping 0 to 0 14 | let pred = 15 | natElim 16 | ( \ _ -> Nat ) 17 | Zero 18 | ( \ n' _rec -> n' ) 19 | 20 | -- a simpler elimination scheme for natural numbers 21 | let natFold = 22 | ( \ m mz ms -> natElim 23 | ( \ _ -> m ) 24 | mz 25 | ( \ n' rec -> ms rec ) ) 26 | :: forall (m :: *) . m -> (m -> m) -> Nat -> m 27 | 28 | -- an eliminator for natural numbers that has special 29 | -- cases for 0 and 1 30 | let nat1Elim = 31 | ( \ m m0 m1 ms -> natElim m m0 32 | (\ p rec -> natElim (\ n -> m (Succ n)) m1 ms p) ) 33 | :: forall (m :: Nat -> *) . m 0 -> m 1 -> 34 | (forall n :: Nat . m (Succ n) -> m (Succ (Succ n))) -> 35 | forall (n :: Nat) . m n 36 | 37 | -- an eliminator for natural numbers that has special 38 | -- cases for 0, 1 and 2 39 | let nat2Elim = 40 | ( \ m m0 m1 m2 ms -> nat1Elim m m0 m1 41 | (\ p rec -> natElim (\ n -> m (Succ (Succ n))) m2 ms p) ) 42 | :: forall (m :: Nat -> *) . m 0 -> m 1 -> m 2 -> 43 | (forall n :: Nat . m (Succ (Succ n)) -> m (Succ (Succ (Succ n)))) -> 44 | forall (n :: Nat) . m n 45 | -- increment by one 46 | let inc = natFold Nat (Succ Zero) Succ 47 | 48 | -- embed Fin into Nat 49 | let finNat = finElim (\ _ _ -> Nat) 50 | (\ _ -> Zero) 51 | (\ _ _ rec -> Succ rec) 52 | 53 | -- unit type 54 | let Unit = Fin 1 55 | -- constructor 56 | let U = FZero 0 57 | -- eliminator 58 | let unitElim = 59 | ( \ m mu -> finElim ( nat1Elim (\ n -> Fin n -> *) 60 | (\ _ -> Unit) 61 | (\ x -> m x) 62 | (\ _ _ _ -> Unit) ) 63 | ( natElim (\ n -> natElim (\ n -> Fin (Succ n) -> *) 64 | (\ x -> m x) 65 | (\ _ _ _ -> Unit) 66 | n (FZero n)) 67 | mu 68 | (\ _ _ -> U) ) 69 | ( \ n f _ -> finElim (\ n f -> natElim (\ n -> Fin (Succ n) -> *) 70 | (\ x -> m x) 71 | (\ _ _ _ -> Unit) 72 | n (FSucc n f)) 73 | (\ _ -> U) 74 | (\ _ _ _ -> U) 75 | n f ) 76 | 1 ) 77 | :: forall (m :: Unit -> *) . m U -> forall (u :: Unit) . m u 78 | 79 | -- empty type 80 | let Void = Fin 0 81 | -- eliminator 82 | let voidElim = 83 | ( \ m -> finElim (natElim (\ n -> Fin n -> *) 84 | (\ x -> m x) 85 | (\ _ _ _ -> Unit)) 86 | (\ _ -> U) 87 | (\ _ _ _ -> U) 88 | 0 ) 89 | :: forall (m :: Void -> *) (v :: Void) . m v 90 | 91 | -- type of booleans 92 | let Bool = Fin 2 93 | -- constructors 94 | let False = FZero 1 95 | let True = FSucc 1 (FZero 0) 96 | -- eliminator 97 | let boolElim = 98 | ( \ m mf mt -> finElim ( nat2Elim (\ n -> Fin n -> *) 99 | (\ _ -> Unit) (\ _ -> Unit) 100 | (\ x -> m x) 101 | (\ _ _ _ -> Unit) ) 102 | ( nat1Elim ( \ n -> nat1Elim (\ n -> Fin (Succ n) -> *) 103 | (\ _ -> Unit) 104 | (\ x -> m x) 105 | (\ _ _ _ -> Unit) 106 | n (FZero n)) 107 | U mf (\ _ _ -> U) ) 108 | ( \ n f _ -> finElim ( \ n f -> nat1Elim (\ n -> Fin (Succ n) -> *) 109 | (\ _ -> Unit) 110 | (\ x -> m x) 111 | (\ _ _ _ -> Unit) 112 | n (FSucc n f) ) 113 | ( natElim 114 | ( \ n -> natElim 115 | (\ n -> Fin (Succ (Succ n)) -> *) 116 | (\ x -> m x) 117 | (\ _ _ _ -> Unit) 118 | n (FSucc (Succ n) (FZero n)) ) 119 | mt (\ _ _ -> U) ) 120 | ( \ n f _ -> finElim 121 | (\ n f -> natElim 122 | (\ n -> Fin (Succ (Succ n)) -> *) 123 | (\ x -> m x) 124 | (\ _ _ _ -> Unit) 125 | n (FSucc (Succ n) (FSucc n f))) 126 | (\ _ -> U) 127 | (\ _ _ _ -> U) 128 | n f ) 129 | n f ) 130 | 2 ) 131 | :: forall (m :: Bool -> *) . m False -> m True -> forall (b :: Bool) . m b 132 | 133 | -- boolean not, and, or, equivalence, xor 134 | let not = boolElim (\ _ -> Bool) True False 135 | let and = boolElim (\ _ -> Bool -> Bool) (\ _ -> False) (id Bool) 136 | let or = boolElim (\ _ -> Bool -> Bool) (id Bool) (\ _ -> True) 137 | let iff = boolElim (\ _ -> Bool -> Bool) not (id Bool) 138 | let xor = boolElim (\ _ -> Bool -> Bool) (id Bool) not 139 | 140 | -- even, odd, isZero, isSucc 141 | let even = natFold Bool True not 142 | let odd = natFold Bool False not 143 | let isZero = natFold Bool True (\ _ -> False) 144 | let isSucc = natFold Bool False (\ _ -> True) 145 | 146 | -- equality on natural numbers 147 | let natEq = 148 | natElim 149 | ( \ _ -> Nat -> Bool ) 150 | ( natElim 151 | ( \ _ -> Bool ) 152 | True 153 | ( \ n' _ -> False ) ) 154 | ( \ m' rec_m' -> natElim 155 | ( \ _ -> Bool ) 156 | False 157 | ( \ n' _ -> rec_m' n' )) 158 | 159 | -- "oh so true" 160 | let Prop = boolElim (\ _ -> *) Void Unit 161 | 162 | -- reflexivity of equality on natural numbers 163 | let pNatEqRefl = 164 | natElim 165 | (\ n -> Prop (natEq n n)) 166 | U 167 | (\ n' rec -> rec) 168 | :: forall (n :: Nat) . Prop (natEq n n) 169 | 170 | -- alias for type-level negation 171 | let Not = (\ a -> a -> Void) :: * -> * 172 | 173 | -- Leibniz prinicple (look at the type signature) 174 | let leibniz = 175 | ( \ a b f -> eqElim a 176 | (\ x y eq_x_y -> Eq b (f x) (f y)) 177 | (\ x -> Refl b (f x)) ) 178 | :: forall (a :: *) (b :: *) (f :: a -> b) (x :: a) (y :: a) . 179 | Eq a x y -> Eq b (f x) (f y) 180 | 181 | -- symmetry of (general) equality 182 | let symm = 183 | ( \ a -> eqElim a 184 | (\ x y eq_x_y -> Eq a y x) 185 | (\ x -> Refl a x) ) 186 | :: forall (a :: *) (x :: a) (y :: a) . 187 | Eq a x y -> Eq a y x 188 | 189 | -- transitivity of (general) equality 190 | let tran = 191 | ( \ a x y z eq_x_y -> eqElim a 192 | (\ x y eq_x_y -> forall (z :: a) . Eq a y z -> Eq a x z) 193 | (\ x z eq_x_z -> eq_x_z) 194 | x y eq_x_y z ) 195 | :: forall (a :: *) (x :: a) (y :: a) (z :: a) . 196 | Eq a x y -> Eq a y z -> Eq a x z 197 | 198 | -- apply an equality proof on two types 199 | let apply = 200 | eqElim * (\ a b _ -> a -> b) (\ _ x -> x) 201 | :: forall (a :: *) (b :: *) (p :: Eq * a b) . a -> b 202 | 203 | -- proof that 1 is not 0 204 | let p1IsNot0 = 205 | (\ p -> apply Unit Void 206 | (leibniz Nat * 207 | (natElim (\ _ -> *) Void (\ _ _ -> Unit)) 208 | 1 0 p) 209 | U) 210 | :: Not (Eq Nat 1 0) 211 | 212 | -- proof that 0 is not 1 213 | let p0IsNot1 = 214 | (\ p -> p1IsNot0 (symm Nat 0 1 p)) 215 | :: Not (Eq Nat 0 1) 216 | 217 | -- proof that zero is not a successor 218 | let p0IsNoSucc = 219 | natElim 220 | ( \ n -> Not (Eq Nat 0 (Succ n)) ) 221 | p0IsNot1 222 | ( \ n' rec_n' eq_0_SSn' -> 223 | rec_n' (leibniz Nat Nat pred Zero (Succ (Succ n')) eq_0_SSn') ) 224 | 225 | -- generate a vector of given length from a specified element (replicate) 226 | let replicate = 227 | ( natElim 228 | ( \ n -> forall (a :: *) . a -> Vec a n ) 229 | ( \ a _ -> Nil a ) 230 | ( \ n' rec_n' a x -> Cons a n' x (rec_n' a x) ) ) 231 | :: forall (n :: Nat) . forall (a :: *) . a -> Vec a n 232 | 233 | -- generate a vector of given length n, containing the natural numbers smaller than n 234 | let fromto = 235 | natElim 236 | ( \ n -> Vec Nat n ) 237 | ( Nil Nat ) 238 | ( \ n' rec_n' -> Cons Nat n' n' rec_n' ) 239 | 240 | -- append two vectors 241 | let append = 242 | ( \ a -> vecElim a 243 | (\ m _ -> forall (n :: Nat) . Vec a n -> Vec a (plus m n)) 244 | (\ _ v -> v) 245 | (\ m v vs rec n w -> Cons a (plus m n) v (rec n w))) 246 | :: forall (a :: *) (m :: Nat) (v :: Vec a m) (n :: Nat) (w :: Vec a n). 247 | Vec a (plus m n) 248 | 249 | -- helper function for tail, see below 250 | let tail' = 251 | (\ a -> vecElim a ( \ m v -> forall (n :: Nat) . Eq Nat m (Succ n) -> Vec a n ) 252 | ( \ n eq_0_SuccN -> voidElim ( \ _ -> Vec a n ) 253 | ( p0IsNoSucc n eq_0_SuccN ) ) 254 | ( \ m' v vs rec_m' n eq_SuccM'_SuccN -> 255 | eqElim Nat 256 | (\ m' n e -> Vec a m' -> Vec a n) 257 | (\ _ v -> v) 258 | m' n 259 | (leibniz Nat Nat pred (Succ m') (Succ n) eq_SuccM'_SuccN) vs)) 260 | :: forall (a :: *) (m :: Nat) . Vec a m -> forall (n :: Nat) . Eq Nat m (Succ n) -> Vec a n 261 | 262 | -- compute the tail of a vector 263 | let tail = 264 | (\ a n v -> tail' a (Succ n) v n (Refl Nat (Succ n))) 265 | :: forall (a :: *) (n :: Nat) . Vec a (Succ n) -> Vec a n 266 | 267 | -- projection out of a vector 268 | let at = 269 | (\ a -> vecElim a ( \ n v -> Fin n -> a ) 270 | ( \ f -> voidElim (\ _ -> a) f ) 271 | ( \ n' v vs rec_n' f_SuccN' -> 272 | finElim ( \ n _ -> Eq Nat n (Succ n') -> a ) 273 | ( \ n e -> v ) 274 | ( \ n f_N _ eq_SuccN_SuccN' -> 275 | rec_n' (eqElim Nat 276 | (\ x y e -> Fin x -> Fin y) 277 | (\ _ f -> f) 278 | n n' 279 | (leibniz Nat Nat pred 280 | (Succ n) (Succ n') eq_SuccN_SuccN') 281 | f_N)) 282 | (Succ n') 283 | f_SuccN' 284 | (Refl Nat (Succ n')))) 285 | :: forall (a :: *) (n :: Nat) . Vec a n -> Fin n -> a 286 | 287 | -- head of a vector 288 | let head = 289 | (\ a n v -> at a (Succ n) v (FZero n)) 290 | :: forall (a :: *) (n :: Nat) . Vec a (Succ n) -> a 291 | 292 | -- vector map 293 | let map = 294 | (\ a b f -> vecElim a ( \ n _ -> Vec b n ) 295 | ( Nil b ) 296 | ( \ n x _ rec -> Cons b n (f x) rec )) 297 | :: forall (a :: *) (b :: *) (f :: a -> b) (n :: Nat) . Vec a n -> Vec b n 298 | 299 | -- proofs that 0 is the neutral element of addition 300 | -- one direction is trivial by definition of plus: 301 | let p0PlusNisN = 302 | Refl Nat 303 | :: forall n :: Nat . Eq Nat (plus 0 n) n 304 | 305 | -- the other direction requires induction on N: 306 | let pNPlus0isN = 307 | natElim ( \ n -> Eq Nat (plus n 0) n ) 308 | ( Refl Nat 0 ) 309 | ( \ n' rec -> leibniz Nat Nat Succ (plus n' 0) n' rec ) 310 | :: forall n :: Nat . Eq Nat (plus n 0) n 311 | 312 | assume (k1 :: Nat) 313 | assume (k2 :: Nat) 314 | assume (z :: Eq Nat k1 k2) 315 | symm 316 | 317 | let pp = Eq Nat (plus k1 0) k1 318 | let zz = pNPlus0isN k1 :: pp 319 | 320 | -------------------------------------------------------------------------------- /prelude.st: -------------------------------------------------------------------------------- 1 | putStrLn "natural numbers" 2 | -- natural numbers 3 | assume (n :: *) 4 | -- zero element 5 | assume (z :: n) 6 | -- successor element 7 | assume (s :: n -> n) 8 | 9 | 10 | let id = z :: n 11 | -- churn numerals 12 | let zero = (\f x -> x) :: (n -> n) -> (n -> n) 13 | let one = (\f x -> (f x)) :: (n -> n) -> (n -> n) 14 | let two = (\f x -> (f (f x))) :: (n -> n) -> (n -> n) 15 | -- just numbers 16 | let n0 = zero s z 17 | let n1 = one s z 18 | let n2 = two s z 19 | -- church addition 20 | let add = (\m n -> ((\f x -> m f (n f x)) :: (n -> n) -> (n -> n))) 21 | :: ((n -> n) -> (n -> n)) -> ((n -> n) -> (n -> n)) -> ((n -> n) -> (n -> n)) 22 | 23 | let three = add one two 24 | let n3 = three s z 25 | -------------------------------------------------------------------------------- /src/Common.hs: -------------------------------------------------------------------------------- 1 | module Common where 2 | 3 | import Text.PrettyPrint.HughesPJ hiding (parens) 4 | import qualified Text.PrettyPrint.HughesPJ as PP 5 | 6 | data Name 7 | = Global String 8 | | Local Int 9 | | Quote Int 10 | deriving (Show, Eq) 11 | 12 | data Type 13 | = TFree Name 14 | | Fun Type Type 15 | deriving (Show, Eq) 16 | 17 | type Result a = Either String a 18 | type NameEnv v = [(Name, v)] 19 | 20 | data Stmt i tinf = Let String i -- let x = t 21 | | Assume [(String,tinf)] -- assume x :: t, assume x :: * 22 | | Eval i 23 | | PutStrLn String -- lhs2TeX hacking, allow to print "magic" string 24 | | Out String -- more lhs2TeX hacking, allow to print to files 25 | deriving (Show) 26 | 27 | parensIf :: Bool -> Doc -> Doc 28 | parensIf True = PP.parens 29 | parensIf False = id 30 | 31 | vars :: [String] 32 | vars = [ c : n | n <- "" : map show [1..], c <- ['x','y','z'] ++ ['a'..'w'] ] 33 | 34 | 35 | -------------------------------------------------------------------------------- /src/Lambda/AST.hs: -------------------------------------------------------------------------------- 1 | module Lambda.AST where 2 | 3 | import Common 4 | 5 | -- inferable term 6 | data ITerm 7 | = Ann CTerm Type 8 | | Bound Int 9 | | Free Name 10 | | ITerm :@: CTerm 11 | deriving (Show, Eq) 12 | 13 | -- checkable term 14 | data CTerm 15 | = Inf ITerm 16 | | Lam CTerm 17 | deriving (Show, Eq) 18 | 19 | data Value 20 | = VLam (Value -> Value) 21 | | VNeutral Neutral 22 | data Neutral 23 | = NFree Name 24 | | NApp Neutral Value 25 | 26 | data Kind = Star 27 | deriving (Show) 28 | 29 | data Info 30 | = HasKind Kind 31 | | HasType Type 32 | deriving (Show) 33 | 34 | type Context = [(Name, Info)] 35 | type Env = [Value] 36 | 37 | -- creates the value corresponding to a free variable 38 | vfree :: Name -> Value 39 | vfree n = VNeutral (NFree n) 40 | 41 | vapp :: Value -> Value -> Value 42 | vapp (VLam f) v = f v 43 | vapp (VNeutral n) v = VNeutral (NApp n v) 44 | -------------------------------------------------------------------------------- /src/Lambda/Check.hs: -------------------------------------------------------------------------------- 1 | module Lambda.Check where 2 | 3 | import Control.Monad.Except 4 | 5 | import Lambda.AST 6 | import Common 7 | 8 | cKind :: Context -> Type -> Kind -> Result () 9 | cKind g (TFree x) Star 10 | = case lookup x g of 11 | Just (HasKind Star) -> return () 12 | Nothing -> throwError "unknown identifier" 13 | cKind g (Fun kk kk') Star 14 | = do cKind g kk Star 15 | cKind g kk' Star 16 | 17 | iType0 :: Context -> ITerm -> Result Type 18 | iType0 = iType 0 19 | 20 | iType :: Int -> Context -> ITerm -> Result Type 21 | iType ii g (Ann e ty) 22 | = do cKind g ty Star 23 | cType ii g e ty 24 | return ty 25 | iType ii g (Free x) 26 | = case lookup x g of 27 | Just (HasType ty) -> return ty 28 | Nothing -> throwError "unknown identifier" 29 | iType ii g (e1 :@: e2) 30 | = do si <- iType ii g e1 31 | case si of 32 | Fun ty ty' -> do cType ii g e2 ty 33 | return ty' 34 | _ -> throwError "illegal application" 35 | 36 | cType :: Int -> Context -> CTerm -> Type -> Result () 37 | cType ii g (Inf e) ty 38 | = do ty' <- iType ii g e 39 | unless (ty == ty') (throwError "type mismatch") 40 | cType ii g (Lam e) (Fun ty ty') 41 | = cType (ii + 1) ((Local ii, HasType ty) : g) 42 | (cSubst 0 (Free (Local ii)) e) ty' 43 | cType ii g _ _ 44 | = throwError "type mismatch" 45 | 46 | iSubst :: Int -> ITerm -> ITerm -> ITerm 47 | iSubst ii r (Ann e ty) = Ann (cSubst ii r e) ty 48 | iSubst ii r (Bound j) = if ii == j then r else Bound j 49 | iSubst ii r (Free y) = Free y 50 | iSubst ii r (e1 :@: e2) = iSubst ii r e1 :@: cSubst ii r e2 51 | 52 | cSubst :: Int -> ITerm -> CTerm -> CTerm 53 | cSubst ii r (Inf e) = Inf (iSubst ii r e) 54 | cSubst ii r (Lam e) = Lam (cSubst (ii + 1) r e) 55 | -------------------------------------------------------------------------------- /src/Lambda/Eval.hs: -------------------------------------------------------------------------------- 1 | module Lambda.Eval where 2 | 3 | import Common 4 | import Lambda.AST 5 | 6 | iEval :: ITerm -> (NameEnv Value, Env) -> Value 7 | iEval (Ann e _) d = cEval e d 8 | iEval (Free x) d = case lookup x (fst d) of Nothing -> (vfree x); Just v -> v 9 | iEval (Bound ii) d = (snd d) !! ii 10 | iEval (e1 :@: e2) d = vapp (iEval e1 d) (cEval e2 d) 11 | 12 | cEval (Inf ii) d = iEval ii d 13 | cEval (Lam e) d = VLam (\ x -> cEval e (((\(e, d) -> (e, (x : d))) d))) 14 | -------------------------------------------------------------------------------- /src/Lambda/Examples.hs: -------------------------------------------------------------------------------- 1 | module Lambda.Examples where 2 | 3 | import Common 4 | import Lambda.AST 5 | import Lambda.Eval 6 | import Lambda.Check 7 | import Lambda.Quote 8 | 9 | id' = Lam (Inf (Bound 0)) 10 | const' = Lam (Lam (Inf (Bound 1))) 11 | 12 | tfree a = TFree (Global a) 13 | free x = Inf (Free (Global x)) 14 | 15 | term1 = Ann id' (Fun (tfree "a") (tfree "a")) :@: free "y" 16 | term2 = (Ann const' (Fun (Fun (tfree "b") (tfree "b")) 17 | (Fun (tfree "a") 18 | (Fun (tfree "b") (tfree "b")))) 19 | :@: id') :@: (free "y") 20 | 21 | env1 = [ (Global "y", HasType (tfree "a")), 22 | (Global "a", HasKind Star)] 23 | env2 = [(Global "b", HasKind Star)] ++ env1 24 | 25 | test_eval1 = quote0 (iEval term1 ([],[])) 26 | 27 | test_eval2 = quote0 (iEval term2 ([],[])) 28 | test_type1 = iType0 env1 term1 29 | test_type2 = iType0 env2 term2 -------------------------------------------------------------------------------- /src/Lambda/Main.hs: -------------------------------------------------------------------------------- 1 | module Lambda.Main where 2 | 3 | import Common 4 | import REPL 5 | 6 | import Lambda.AST 7 | import Lambda.Eval 8 | import Lambda.Check 9 | import Lambda.Quote 10 | import Lambda.Parser 11 | import Lambda.Printer 12 | 13 | st :: Interpreter ITerm CTerm Value Type Info Info 14 | st = I { iname = "the simply typed lambda calculus", 15 | iprompt = "ST> ", 16 | iitype = \ v c -> iType 0 c, 17 | iquote = quote0, 18 | ieval = \ e x -> iEval x (e, []), 19 | ihastype = HasType, 20 | icprint = cPrint 0 0, 21 | itprint = tPrint 0, 22 | iiparse = parseITerm 0 [], 23 | isparse = parseStmt [], 24 | iassume = \ s (x, t) -> stassume s x t } 25 | 26 | stassume state@(out, ve, te) x t = return (out, ve, (Global x, t) : te) 27 | 28 | repST :: IO () 29 | repST = readevalprint st ([], [], []) 30 | 31 | main :: IO () 32 | main = repST 33 | -------------------------------------------------------------------------------- /src/Lambda/Parser.hs: -------------------------------------------------------------------------------- 1 | module Lambda.Parser where 2 | 3 | import Data.List 4 | import Text.ParserCombinators.Parsec hiding (parse, State) 5 | import qualified Text.ParserCombinators.Parsec as P 6 | import Text.ParserCombinators.Parsec.Token 7 | import Text.ParserCombinators.Parsec.Language 8 | 9 | import Common 10 | import Lambda.AST 11 | 12 | simplyTyped = makeTokenParser (haskellStyle { identStart = letter <|> P.char '_', 13 | reservedNames = ["let", "assume", "putStrLn"] }) 14 | parseBindings :: CharParser () ([String], [Info]) 15 | parseBindings = 16 | (let rec :: [String] -> [Info] -> CharParser () ([String], [Info]) 17 | rec e ts = 18 | do 19 | (x,t) <- parens simplyTyped 20 | (do 21 | x <- identifier simplyTyped 22 | reserved simplyTyped "::" 23 | t <- pInfo 24 | return (x,t)) 25 | (rec (x : e) (t : ts) <|> return (x : e, t : ts)) 26 | in rec [] []) 27 | <|> 28 | do x <- identifier simplyTyped 29 | reserved simplyTyped "::" 30 | t <- pInfo 31 | return ([x], [t]) 32 | 33 | pInfo = fmap HasType (parseType 0 []) <|> fmap (const (HasKind Star)) (reserved simplyTyped "*") 34 | 35 | parseStmt :: [String] -> CharParser () (Stmt ITerm Info) 36 | parseStmt e = 37 | do 38 | reserved simplyTyped "let" 39 | x <- identifier simplyTyped 40 | reserved simplyTyped "=" 41 | t <- parseITerm 0 e 42 | return (Let x t) 43 | <|> do 44 | reserved simplyTyped "assume" 45 | (xs, ts) <- parseBindings 46 | return (Assume (reverse (zip xs ts))) 47 | <|> do 48 | reserved simplyTyped "putStrLn" 49 | x <- stringLiteral simplyTyped 50 | return (PutStrLn x) 51 | <|> do 52 | reserved simplyTyped "out" 53 | x <- option "" (stringLiteral simplyTyped) 54 | return (Out x) 55 | <|> fmap Eval (parseITerm 0 e) 56 | 57 | parseType :: Int -> [String] -> CharParser () Type 58 | parseType 0 e = 59 | try 60 | (do 61 | t <- parseType 1 e 62 | rest t <|> return t) 63 | where 64 | rest t = 65 | do 66 | reserved simplyTyped "->" 67 | t' <- parseType 0 e 68 | return (Fun t t') 69 | parseType 1 e = 70 | do 71 | x <- identifier simplyTyped 72 | return (TFree (Global x)) 73 | <|> parens simplyTyped (parseType 0 e) 74 | 75 | parseITerm :: Int -> [String] -> CharParser () ITerm 76 | parseITerm 0 e = 77 | try 78 | (do 79 | t <- parseITerm 1 e 80 | return t) 81 | parseITerm 1 e = 82 | try 83 | (do 84 | t <- parseITerm 2 e 85 | rest (Inf t) <|> return t) 86 | <|> do 87 | t <- parens simplyTyped (parseLam e) 88 | rest t 89 | where 90 | rest t = 91 | do 92 | reserved simplyTyped "::" 93 | t' <- parseType 0 e 94 | return (Ann t t') 95 | parseITerm 2 e = 96 | do 97 | t <- parseITerm 3 e 98 | ts <- many (parseCTerm 3 e) 99 | return (foldl (:@:) t ts) 100 | parseITerm 3 e = 101 | do 102 | x <- identifier simplyTyped 103 | case findIndex (== x) e of 104 | Just n -> return (Bound n) 105 | Nothing -> return (Free (Global x)) 106 | <|> parens simplyTyped (parseITerm 0 e) 107 | 108 | parseCTerm :: Int -> [String] -> CharParser () CTerm 109 | parseCTerm 0 e = 110 | parseLam e 111 | <|> fmap Inf (parseITerm 0 e) 112 | parseCTerm p e = 113 | try (parens simplyTyped (parseLam e)) 114 | <|> fmap Inf (parseITerm p e) 115 | 116 | parseLam :: [String] -> CharParser () CTerm 117 | parseLam e = 118 | do reservedOp simplyTyped "\\" 119 | xs <- many1 (identifier simplyTyped) 120 | reservedOp simplyTyped "->" 121 | t <- parseCTerm 0 (reverse xs ++ e) 122 | -- reserved simplyTyped "." 123 | return (iterate Lam t !! length xs) 124 | -------------------------------------------------------------------------------- /src/Lambda/Printer.hs: -------------------------------------------------------------------------------- 1 | module Lambda.Printer where 2 | 3 | import Prelude hiding ((<>)) 4 | import Text.PrettyPrint.HughesPJ hiding (parens) 5 | 6 | import Common 7 | import Lambda.AST 8 | 9 | tPrint :: Int -> Type -> Doc 10 | tPrint p (TFree (Global s)) = text s 11 | tPrint p (Fun ty ty') = parensIf (p > 0) (sep [tPrint 0 ty <> text " ->", nest 2 (tPrint 0 ty')]) 12 | iPrint :: Int -> Int -> ITerm -> Doc 13 | iPrint p ii (Ann c ty) = parensIf (p > 1) (cPrint 2 ii c <> text " :: " <> tPrint 0 ty) 14 | iPrint p ii (Bound k) = text (vars !! (ii - k - 1)) 15 | iPrint p ii (Free (Global s))= text s 16 | iPrint p ii (i :@: c) = parensIf (p > 2) (sep [iPrint 2 ii i, nest 2 (cPrint 3 ii c)]) 17 | iPrint p ii x = text ("[" ++ show x ++ "]") 18 | cPrint :: Int -> Int -> CTerm -> Doc 19 | cPrint p ii (Inf i) = iPrint p ii i 20 | cPrint p ii (Lam c) = parensIf (p > 0) (text "\\ " <> text (vars !! ii) <> text " -> " <> cPrint 0 (ii + 1) c) 21 | print = render . cPrint 0 0 22 | printType = render . tPrint 0 23 | -------------------------------------------------------------------------------- /src/Lambda/Quote.hs: -------------------------------------------------------------------------------- 1 | module Lambda.Quote where 2 | 3 | import Common 4 | import Lambda.AST 5 | 6 | quote0 :: Value -> CTerm 7 | quote0 = quote 0 8 | 9 | quote :: Int -> Value -> CTerm 10 | quote ii (VLam f) = Lam (quote (ii + 1) (f (vfree (Quote ii)))) 11 | quote ii (VNeutral n) = Inf (neutralQuote ii n) 12 | 13 | neutralQuote :: Int -> Neutral -> ITerm 14 | neutralQuote ii (NFree x) = boundfree ii x 15 | neutralQuote ii (NApp n v) = (neutralQuote ii n) :@: (quote ii v) 16 | boundfree :: Int -> Name -> ITerm 17 | boundfree ii (Quote k) = Bound (ii - k - 1) 18 | boundfree ii x = Free x -------------------------------------------------------------------------------- /src/LambdaPi/AST.hs: -------------------------------------------------------------------------------- 1 | module LambdaPi.AST where 2 | 3 | import Common 4 | 5 | data CTerm_ 6 | = Inf_ ITerm_ 7 | | Lam_ CTerm_ 8 | | Zero_ 9 | | Succ_ CTerm_ 10 | | Nil_ CTerm_ 11 | | Cons_ CTerm_ CTerm_ CTerm_ CTerm_ 12 | | Refl_ CTerm_ CTerm_ 13 | | FZero_ CTerm_ 14 | | FSucc_ CTerm_ CTerm_ 15 | deriving (Show, Eq) 16 | data ITerm_ 17 | = Ann_ CTerm_ CTerm_ 18 | | Star_ 19 | | Pi_ CTerm_ CTerm_ 20 | | Bound_ Int 21 | | Free_ Name 22 | | ITerm_ :$: CTerm_ 23 | | Nat_ 24 | | NatElim_ CTerm_ CTerm_ CTerm_ CTerm_ 25 | | Vec_ CTerm_ CTerm_ 26 | | VecElim_ CTerm_ CTerm_ CTerm_ CTerm_ CTerm_ CTerm_ 27 | | Eq_ CTerm_ CTerm_ CTerm_ 28 | | EqElim_ CTerm_ CTerm_ CTerm_ CTerm_ CTerm_ CTerm_ 29 | | Fin_ CTerm_ 30 | | FinElim_ CTerm_ CTerm_ CTerm_ CTerm_ CTerm_ 31 | deriving (Show, Eq) 32 | 33 | data Value_ 34 | = VLam_ (Value_ -> Value_) 35 | | VStar_ 36 | | VPi_ Value_ (Value_ -> Value_) 37 | | VNeutral_ Neutral_ 38 | | VNat_ 39 | | VZero_ 40 | | VSucc_ Value_ 41 | | VNil_ Value_ 42 | | VCons_ Value_ Value_ Value_ Value_ 43 | | VVec_ Value_ Value_ 44 | | VEq_ Value_ Value_ Value_ 45 | | VRefl_ Value_ Value_ 46 | | VFZero_ Value_ 47 | | VFSucc_ Value_ Value_ 48 | | VFin_ Value_ 49 | data Neutral_ 50 | = NFree_ Name 51 | | NApp_ Neutral_ Value_ 52 | | NNatElim_ Value_ Value_ Value_ Neutral_ 53 | | NVecElim_ Value_ Value_ Value_ Value_ Value_ Neutral_ 54 | | NEqElim_ Value_ Value_ Value_ Value_ Value_ Neutral_ 55 | | NFinElim_ Value_ Value_ Value_ Value_ Neutral_ 56 | type Env_ = [Value_] 57 | type Type_ = Value_ 58 | type Context_ = [(Name, Type_)] 59 | 60 | 61 | vapp_ :: Value_ -> Value_ -> Value_ 62 | vapp_ (VLam_ f) v = f v 63 | vapp_ (VNeutral_ n) v = VNeutral_ (NApp_ n v) 64 | 65 | vfree_ :: Name -> Value_ 66 | vfree_ n = VNeutral_ (NFree_ n) -------------------------------------------------------------------------------- /src/LambdaPi/Check.hs: -------------------------------------------------------------------------------- 1 | module LambdaPi.Check where 2 | 3 | import Control.Monad.Except 4 | 5 | import Text.PrettyPrint.HughesPJ hiding (parens) 6 | 7 | import Common 8 | import LambdaPi.AST 9 | import LambdaPi.Eval 10 | import LambdaPi.Quote 11 | import LambdaPi.Printer 12 | 13 | iType0_ :: (NameEnv Value_,Context_) -> ITerm_ -> Result Type_ 14 | iType0_ = iType_ 0 15 | 16 | iType_ :: Int -> (NameEnv Value_,Context_) -> ITerm_ -> Result Type_ 17 | iType_ ii g (Ann_ e tyt ) 18 | = do cType_ ii g tyt VStar_ 19 | let ty = cEval_ tyt (fst g, []) 20 | cType_ ii g e ty 21 | return ty 22 | iType_ ii g Star_ 23 | = return VStar_ 24 | iType_ ii g (Pi_ tyt tyt') 25 | = do cType_ ii g tyt VStar_ 26 | let ty = cEval_ tyt (fst g, []) 27 | cType_ (ii + 1) ((\ (d,g) -> (d, ((Local ii, ty) : g))) g) 28 | (cSubst_ 0 (Free_ (Local ii)) tyt') VStar_ 29 | return VStar_ 30 | iType_ ii g (Free_ x) 31 | = case lookup x (snd g) of 32 | Just ty -> return ty 33 | Nothing -> throwError ("unknown identifier: " ++ render (iPrint_ 0 0 (Free_ x))) 34 | iType_ ii g (e1 :$: e2) 35 | = do si <- iType_ ii g e1 36 | case si of 37 | VPi_ ty ty1 -> do cType_ ii g e2 ty 38 | return ( ty1 (cEval_ e2 (fst g, []))) 39 | _ -> throwError "illegal application" 40 | iType_ ii g Nat_ = return VStar_ 41 | iType_ ii g (NatElim_ m mz ms n) = 42 | do cType_ ii g m (VPi_ VNat_ (const VStar_)) 43 | let mVal = cEval_ m (fst g, []) 44 | cType_ ii g mz (mVal `vapp_` VZero_) 45 | cType_ ii g ms (VPi_ VNat_ (\ k -> VPi_ (mVal `vapp_` k) (\ _ -> mVal `vapp_` VSucc_ k))) 46 | cType_ ii g n VNat_ 47 | let nVal = cEval_ n (fst g, []) 48 | return (mVal `vapp_` nVal) 49 | iType_ ii g (Vec_ a n) = 50 | do cType_ ii g a VStar_ 51 | cType_ ii g n VNat_ 52 | return VStar_ 53 | iType_ ii g (VecElim_ a m mn mc n vs) = 54 | do cType_ ii g a VStar_ 55 | let aVal = cEval_ a (fst g, []) 56 | cType_ ii g m 57 | ( VPi_ VNat_ (\n -> VPi_ (VVec_ aVal n) (\ _ -> VStar_))) 58 | let mVal = cEval_ m (fst g, []) 59 | cType_ ii g mn (foldl vapp_ mVal [VZero_, VNil_ aVal]) 60 | cType_ ii g mc 61 | ( VPi_ VNat_ (\ n -> 62 | VPi_ aVal (\ y -> 63 | VPi_ (VVec_ aVal n) (\ ys -> 64 | VPi_ (foldl vapp_ mVal [n, ys]) (\ _ -> 65 | (foldl vapp_ mVal [VSucc_ n, VCons_ aVal n y ys])))))) 66 | cType_ ii g n VNat_ 67 | let nVal = cEval_ n (fst g, []) 68 | cType_ ii g vs (VVec_ aVal nVal) 69 | let vsVal = cEval_ vs (fst g, []) 70 | return (foldl vapp_ mVal [nVal, vsVal]) 71 | iType_ i g (Eq_ a x y) = 72 | do cType_ i g a VStar_ 73 | let aVal = cEval_ a (fst g, []) 74 | cType_ i g x aVal 75 | cType_ i g y aVal 76 | return VStar_ 77 | iType_ i g (EqElim_ a m mr x y eq) = 78 | do cType_ i g a VStar_ 79 | let aVal = cEval_ a (fst g, []) 80 | cType_ i g m 81 | (VPi_ aVal (\ x -> 82 | VPi_ aVal (\ y -> 83 | VPi_ (VEq_ aVal x y) (\ _ -> VStar_)))) 84 | let mVal = cEval_ m (fst g, []) 85 | cType_ i g mr 86 | (VPi_ aVal (\ x -> 87 | foldl vapp_ mVal [x, x, VRefl_ aVal x])) 88 | cType_ i g x aVal 89 | let xVal = cEval_ x (fst g, []) 90 | cType_ i g y aVal 91 | let yVal = cEval_ y (fst g, []) 92 | cType_ i g eq (VEq_ aVal xVal yVal) 93 | let eqVal = cEval_ eq (fst g, []) 94 | return (foldl vapp_ mVal [xVal, yVal, eqVal]) 95 | iType_ ii g (Fin_ n) = 96 | do cType_ ii g n VNat_ 97 | return VStar_ 98 | iType_ ii g (FinElim_ m mz ms n f) = 99 | do cType_ ii g m (VPi_ VNat_ (\k -> VPi_ (VFin_ k) (const VStar_))) 100 | let mVal = cEval_ m (fst g, []) 101 | cType_ ii g n VNat_ 102 | let nVal = cEval_ n (fst g, []) 103 | cType_ ii g mz (VPi_ VNat_ (\k -> mVal `vapp_` VSucc_ k `vapp_` VFZero_ k)) 104 | cType_ ii g ms (VPi_ VNat_ (\k -> 105 | VPi_ (VFin_ k) (\fk -> 106 | VPi_ (mVal `vapp_` k `vapp_` fk) (\_ -> 107 | mVal `vapp_` VSucc_ k `vapp_` VFSucc_ k fk)))) 108 | cType_ ii g f (VFin_ nVal) 109 | let fVal = cEval_ f (fst g, []) 110 | return (mVal `vapp_` nVal `vapp_` fVal) 111 | iType_ _ _ tm = throwError $ "No type match for " ++ render (iPrint_ 0 0 tm) 112 | 113 | cType_ :: Int -> (NameEnv Value_,Context_) -> CTerm_ -> Type_ -> Result () 114 | cType_ ii g (Inf_ e) v 115 | = do v' <- iType_ ii g e 116 | unless ( quote0_ v == quote0_ v') (throwError ("type mismatch:\n" ++ "type inferred: " ++ render (cPrint_ 0 0 (quote0_ v')) ++ "\n" ++ "type expected: " ++ render (cPrint_ 0 0 (quote0_ v)) ++ "\n" ++ "for expression: " ++ render (iPrint_ 0 0 e))) 117 | cType_ ii g (Lam_ e) ( VPi_ ty ty') 118 | = cType_ (ii + 1) ((\ (d,g) -> (d, ((Local ii, ty ) : g))) g) 119 | (cSubst_ 0 (Free_ (Local ii)) e) ( ty' (vfree_ (Local ii))) 120 | cType_ ii g Zero_ VNat_ = return () 121 | cType_ ii g (Succ_ k) VNat_ = cType_ ii g k VNat_ 122 | cType_ ii g (Nil_ a) (VVec_ bVal VZero_) = 123 | do cType_ ii g a VStar_ 124 | let aVal = cEval_ a (fst g, []) 125 | unless (quote0_ aVal == quote0_ bVal) 126 | (throwError "type mismatch") 127 | cType_ ii g (Cons_ a n x xs) (VVec_ bVal (VSucc_ k)) = 128 | do cType_ ii g a VStar_ 129 | let aVal = cEval_ a (fst g, []) 130 | unless (quote0_ aVal == quote0_ bVal) 131 | (throwError "type mismatch") 132 | cType_ ii g n VNat_ 133 | let nVal = cEval_ n (fst g, []) 134 | unless (quote0_ nVal == quote0_ k) 135 | (throwError "number mismatch") 136 | cType_ ii g x aVal 137 | cType_ ii g xs (VVec_ bVal k) 138 | cType_ ii g (Refl_ a z) (VEq_ bVal xVal yVal) = 139 | do cType_ ii g a VStar_ 140 | let aVal = cEval_ a (fst g, []) 141 | unless (quote0_ aVal == quote0_ bVal) 142 | (throwError "type mismatch") 143 | cType_ ii g z aVal 144 | let zVal = cEval_ z (fst g, []) 145 | unless (quote0_ zVal == quote0_ xVal && quote0_ zVal == quote0_ yVal) 146 | (throwError "type mismatch") 147 | cType_ ii g@(v,t) (FZero_ n) (VFin_ (VSucc_ mVal)) = 148 | do 149 | cType_ ii g n VNat_ 150 | let nVal = cEval_ n (v, []) 151 | unless (quote0_ nVal == quote0_ mVal) 152 | (throwError "number mismatch FZero") 153 | cType_ ii g@(v,t) (FSucc_ n f') (VFin_ (VSucc_ mVal)) = 154 | do 155 | cType_ ii g n VNat_ 156 | let nVal = cEval_ n (v,[]) 157 | unless (quote0_ nVal == quote0_ mVal) 158 | (throwError "number mismatch FSucc") 159 | cType_ ii g f' (VFin_ mVal) 160 | cType_ ii g _ _ 161 | = throwError "type mismatch" 162 | 163 | iSubst_ :: Int -> ITerm_ -> ITerm_ -> ITerm_ 164 | iSubst_ ii i' (Ann_ c c') = Ann_ (cSubst_ ii i' c) (cSubst_ ii i' c') 165 | 166 | iSubst_ ii r Star_ = Star_ 167 | iSubst_ ii r (Pi_ ty ty') = Pi_ (cSubst_ ii r ty) (cSubst_ (ii + 1) r ty') 168 | iSubst_ ii i' (Bound_ j) = if ii == j then i' else Bound_ j 169 | iSubst_ ii i' (Free_ y) = Free_ y 170 | iSubst_ ii i' (i :$: c) = (iSubst_ ii i' i) :$: (cSubst_ ii i' c) 171 | iSubst_ ii r Nat_ = Nat_ 172 | iSubst_ ii r (NatElim_ m mz ms n) 173 | = NatElim_ (cSubst_ ii r m) 174 | (cSubst_ ii r mz) (cSubst_ ii r ms) 175 | (cSubst_ ii r n) 176 | iSubst_ ii r (Vec_ a n) = Vec_ (cSubst_ ii r a) (cSubst_ ii r n) 177 | iSubst_ ii r (VecElim_ a m mn mc n xs) 178 | = VecElim_ (cSubst_ ii r a) (cSubst_ ii r m) 179 | (cSubst_ ii r mn) (cSubst_ ii r mc) 180 | (cSubst_ ii r n) (cSubst_ ii r xs) 181 | iSubst_ ii r (Eq_ a x y) = Eq_ (cSubst_ ii r a) 182 | (cSubst_ ii r x) (cSubst_ ii r y) 183 | iSubst_ ii r (EqElim_ a m mr x y eq) 184 | = EqElim_ (cSubst_ ii r a) (cSubst_ ii r m) 185 | (cSubst_ ii r mr) (cSubst_ ii r x) 186 | (cSubst_ ii r y) (cSubst_ ii r eq) 187 | iSubst_ ii r (Fin_ n) = Fin_ (cSubst_ ii r n) 188 | iSubst_ ii r (FinElim_ m mz ms n f) 189 | = FinElim_ (cSubst_ ii r m) 190 | (cSubst_ ii r mz) (cSubst_ ii r ms) 191 | (cSubst_ ii r n) (cSubst_ ii r f) 192 | cSubst_ :: Int -> ITerm_ -> CTerm_ -> CTerm_ 193 | cSubst_ ii i' (Inf_ i) = Inf_ (iSubst_ ii i' i) 194 | cSubst_ ii i' (Lam_ c) = Lam_ (cSubst_ (ii + 1) i' c) 195 | cSubst_ ii r Zero_ = Zero_ 196 | cSubst_ ii r (Succ_ n) = Succ_ (cSubst_ ii r n) 197 | cSubst_ ii r (Nil_ a) = Nil_ (cSubst_ ii r a) 198 | cSubst_ ii r (Cons_ a n x xs) 199 | = Cons_ (cSubst_ ii r a) (cSubst_ ii r n) 200 | (cSubst_ ii r x) (cSubst_ ii r xs) 201 | cSubst_ ii r (Refl_ a x) = Refl_ (cSubst_ ii r a) (cSubst_ ii r x) 202 | cSubst_ ii r (FZero_ n) = FZero_ (cSubst_ ii r n) 203 | cSubst_ ii r (FSucc_ n k) = FSucc_ (cSubst_ ii r n) (cSubst_ ii r k) 204 | -------------------------------------------------------------------------------- /src/LambdaPi/Eval.hs: -------------------------------------------------------------------------------- 1 | module LambdaPi.Eval where 2 | 3 | import Common 4 | import LambdaPi.AST 5 | 6 | cEval_ :: CTerm_ -> (NameEnv Value_,Env_) -> Value_ 7 | cEval_ (Inf_ ii) d = iEval_ ii d 8 | cEval_ (Lam_ c) d = VLam_ (\ x -> cEval_ c (((\(e, d) -> (e, (x : d))) d))) 9 | cEval_ Zero_ d = VZero_ 10 | cEval_ (Succ_ k) d = VSucc_ (cEval_ k d) 11 | cEval_ (Nil_ a) d = VNil_ (cEval_ a d) 12 | cEval_ (Cons_ a n x xs) d = VCons_ (cEval_ a d) (cEval_ n d) 13 | (cEval_ x d) (cEval_ xs d) 14 | cEval_ (Refl_ a x) d = VRefl_ (cEval_ a d) (cEval_ x d) 15 | cEval_ (FZero_ n) d = VFZero_ (cEval_ n d) 16 | cEval_ (FSucc_ n f) d = VFSucc_ (cEval_ n d) (cEval_ f d) 17 | 18 | iEval_ :: ITerm_ -> (NameEnv Value_,Env_) -> Value_ 19 | iEval_ (Ann_ c _) d = cEval_ c d 20 | iEval_ Star_ d = VStar_ 21 | iEval_ (Pi_ ty ty1) d = VPi_ (cEval_ ty d) (\ x -> cEval_ ty1 (((\(e, d) -> (e, (x : d))) d))) 22 | iEval_ (Free_ x) d = case lookup x (fst d) of Nothing -> (vfree_ x); Just v -> v 23 | iEval_ (Bound_ ii) d = (snd d) !! ii 24 | iEval_ (i :$: c) d = vapp_ (iEval_ i d) (cEval_ c d) 25 | iEval_ Nat_ d = VNat_ 26 | iEval_ (NatElim_ m mz ms n) d 27 | = let mzVal = cEval_ mz d 28 | msVal = cEval_ ms d 29 | rec nVal = 30 | case nVal of 31 | VZero_ -> mzVal 32 | VSucc_ k -> (msVal `vapp_` k) `vapp_` rec k 33 | VNeutral_ n -> VNeutral_ 34 | (NNatElim_ (cEval_ m d) mzVal msVal n) 35 | _ -> error "internal: eval natElim" 36 | in rec (cEval_ n d) 37 | iEval_ (Vec_ a n) d = VVec_ (cEval_ a d) (cEval_ n d) 38 | iEval_ (VecElim_ a m mn mc n xs) d = 39 | let mnVal = cEval_ mn d 40 | mcVal = cEval_ mc d 41 | rec nVal xsVal = 42 | case xsVal of 43 | VNil_ _ -> mnVal 44 | VCons_ _ k x xs -> foldl vapp_ mcVal [k, x, xs, rec k xs] 45 | VNeutral_ n -> VNeutral_ 46 | (NVecElim_ (cEval_ a d) (cEval_ m d) 47 | mnVal mcVal nVal n) 48 | _ -> error "internal: eval vecElim" 49 | in rec (cEval_ n d) (cEval_ xs d) 50 | iEval_ (Eq_ a x y) d = VEq_ (cEval_ a d) (cEval_ x d) (cEval_ y d) 51 | iEval_ (EqElim_ a m mr x y eq) d = 52 | let mrVal = cEval_ mr d 53 | rec eqVal = 54 | case eqVal of 55 | VRefl_ _ z -> mrVal `vapp_` z 56 | VNeutral_ n -> 57 | VNeutral_ (NEqElim_ (cEval_ a d) (cEval_ m d) mrVal 58 | (cEval_ x d) (cEval_ y d) n) 59 | _ -> error "internal: eval eqElim" 60 | in rec (cEval_ eq d) 61 | iEval_ (Fin_ n) d = VFin_ (cEval_ n d) 62 | iEval_ (FinElim_ m mz ms n f) d = 63 | let mzVal = cEval_ mz d 64 | msVal = cEval_ ms d 65 | rec fVal = 66 | case fVal of 67 | VFZero_ k -> mzVal `vapp_` k 68 | VFSucc_ k g -> foldl vapp_ msVal [k, g, rec g] 69 | VNeutral_ n' -> VNeutral_ 70 | (NFinElim_ (cEval_ m d) (cEval_ mz d) 71 | (cEval_ ms d) (cEval_ n d) n') 72 | _ -> error "internal: eval finElim" 73 | in rec (cEval_ f d) 74 | -------------------------------------------------------------------------------- /src/LambdaPi/Main.hs: -------------------------------------------------------------------------------- 1 | module LambdaPi.Main where 2 | 3 | import Common 4 | import REPL 5 | 6 | import LambdaPi.AST 7 | import LambdaPi.Eval 8 | import LambdaPi.Check 9 | import LambdaPi.Quote 10 | import LambdaPi.Parser 11 | import LambdaPi.Printer 12 | 13 | lpte :: Ctx Value_ 14 | lpte = [(Global "Zero", VNat_), 15 | (Global "Succ", VPi_ VNat_ (\ _ -> VNat_)), 16 | (Global "Nat", VStar_), 17 | (Global "natElim", VPi_ (VPi_ VNat_ (\ _ -> VStar_)) (\ m -> 18 | VPi_ (m `vapp_` VZero_) (\ _ -> 19 | VPi_ (VPi_ VNat_ (\ k -> VPi_ (m `vapp_` k) (\ _ -> (m `vapp_` (VSucc_ k))))) ( \ _ -> 20 | VPi_ VNat_ (\ n -> m `vapp_` n))))), 21 | (Global "Nil", VPi_ VStar_ (\ a -> VVec_ a VZero_)), 22 | (Global "Cons", VPi_ VStar_ (\ a -> 23 | VPi_ VNat_ (\ n -> 24 | VPi_ a (\ _ -> VPi_ (VVec_ a n) (\ _ -> VVec_ a (VSucc_ n)))))), 25 | (Global "Vec", VPi_ VStar_ (\ _ -> VPi_ VNat_ (\ _ -> VStar_))), 26 | (Global "vecElim", VPi_ VStar_ (\ a -> 27 | VPi_ (VPi_ VNat_ (\ n -> VPi_ (VVec_ a n) (\ _ -> VStar_))) (\ m -> 28 | VPi_ (m `vapp_` VZero_ `vapp_` (VNil_ a)) (\ _ -> 29 | VPi_ (VPi_ VNat_ (\ n -> 30 | VPi_ a (\ x -> 31 | VPi_ (VVec_ a n) (\ xs -> 32 | VPi_ (m `vapp_` n `vapp_` xs) (\ _ -> 33 | m `vapp_` VSucc_ n `vapp_` VCons_ a n x xs))))) (\ _ -> 34 | VPi_ VNat_ (\ n -> 35 | VPi_ (VVec_ a n) (\ xs -> m `vapp_` n `vapp_` xs))))))), 36 | (Global "Refl", VPi_ VStar_ (\ a -> VPi_ a (\ x -> 37 | VEq_ a x x))), 38 | (Global "Eq", VPi_ VStar_ (\ a -> VPi_ a (\ x -> VPi_ a (\ y -> VStar_)))), 39 | (Global "eqElim", VPi_ VStar_ (\ a -> 40 | VPi_ (VPi_ a (\ x -> VPi_ a (\ y -> VPi_ (VEq_ a x y) (\ _ -> VStar_)))) (\ m -> 41 | VPi_ (VPi_ a (\ x -> ((m `vapp_` x) `vapp_` x) `vapp_` VRefl_ a x)) (\ _ -> 42 | VPi_ a (\ x -> VPi_ a (\ y -> 43 | VPi_ (VEq_ a x y) (\ eq -> 44 | ((m `vapp_` x) `vapp_` y) `vapp_` eq))))))), 45 | (Global "FZero", VPi_ VNat_ (\ n -> VFin_ (VSucc_ n))), 46 | (Global "FSucc", VPi_ VNat_ (\ n -> VPi_ (VFin_ n) (\ f -> 47 | VFin_ (VSucc_ n)))), 48 | (Global "Fin", VPi_ VNat_ (\ n -> VStar_)), 49 | (Global "finElim", VPi_ (VPi_ VNat_ (\ n -> VPi_ (VFin_ n) (\ _ -> VStar_))) (\ m -> 50 | VPi_ (VPi_ VNat_ (\ n -> m `vapp_` (VSucc_ n) `vapp_` (VFZero_ n))) (\ _ -> 51 | VPi_ (VPi_ VNat_ (\ n -> VPi_ (VFin_ n) (\ f -> VPi_ (m `vapp_` n `vapp_` f) (\ _ -> m `vapp_` (VSucc_ n) `vapp_` (VFSucc_ n f))))) (\ _ -> 52 | VPi_ VNat_ (\ n -> VPi_ (VFin_ n) (\ f -> 53 | m `vapp_` n `vapp_` f))))))] 54 | 55 | lpve :: Ctx Value_ 56 | lpve = [(Global "Zero", VZero_), 57 | (Global "Succ", VLam_ (\ n -> VSucc_ n)), 58 | (Global "Nat", VNat_), 59 | (Global "natElim", cEval_ (Lam_ (Lam_ (Lam_ (Lam_ (Inf_ (NatElim_ (Inf_ (Bound_ 3)) (Inf_ (Bound_ 2)) (Inf_ (Bound_ 1)) (Inf_ (Bound_ 0)))))))) ([], [])), 60 | (Global "Nil", VLam_ (\ a -> VNil_ a)), 61 | (Global "Cons", VLam_ (\ a -> VLam_ (\ n -> VLam_ (\ x -> VLam_ (\ xs -> 62 | VCons_ a n x xs))))), 63 | (Global "Vec", VLam_ (\ a -> VLam_ (\ n -> VVec_ a n))), 64 | (Global "vecElim", cEval_ (Lam_ (Lam_ (Lam_ (Lam_ (Lam_ (Lam_ (Inf_ (VecElim_ (Inf_ (Bound_ 5)) (Inf_ (Bound_ 4)) (Inf_ (Bound_ 3)) (Inf_ (Bound_ 2)) (Inf_ (Bound_ 1)) (Inf_ (Bound_ 0)))))))))) ([],[])), 65 | (Global "Refl", VLam_ (\ a -> VLam_ (\ x -> VRefl_ a x))), 66 | (Global "Eq", VLam_ (\ a -> VLam_ (\ x -> VLam_ (\ y -> VEq_ a x y)))), 67 | (Global "eqElim", cEval_ (Lam_ (Lam_ (Lam_ (Lam_ (Lam_ (Lam_ (Inf_ (EqElim_ (Inf_ (Bound_ 5)) (Inf_ (Bound_ 4)) (Inf_ (Bound_ 3)) (Inf_ (Bound_ 2)) (Inf_ (Bound_ 1)) (Inf_ (Bound_ 0)))))))))) ([],[])), 68 | (Global "FZero", VLam_ (\ n -> VFZero_ n)), 69 | (Global "FSucc", VLam_ (\ n -> VLam_ (\ f -> VFSucc_ n f))), 70 | (Global "Fin", VLam_ (\ n -> VFin_ n)), 71 | (Global "finElim", cEval_ (Lam_ (Lam_ (Lam_ (Lam_ (Lam_ (Inf_ (FinElim_ (Inf_ (Bound_ 4)) (Inf_ (Bound_ 3)) (Inf_ (Bound_ 2)) (Inf_ (Bound_ 1)) (Inf_ (Bound_ 0))))))))) ([],[]))] 72 | 73 | lpassume state@(out, ve, te) x t = 74 | -- x: String, t: CTerm 75 | check lp state x (Ann_ t (Inf_ Star_)) 76 | (\ (y, v) -> return ()) -- putStrLn (render (text x <> text " :: " <> cPrint_ 0 0 (quote0_ v)))) 77 | (\ (y, v) -> (out, ve, (Global x, v) : te)) 78 | 79 | lp :: Interpreter ITerm_ CTerm_ Value_ Value_ CTerm_ Value_ 80 | lp = I { iname = "lambda-Pi", 81 | iprompt = "LP> ", 82 | iitype = \ v c -> iType_ 0 (v, c), 83 | iquote = quote0_, 84 | ieval = \ e x -> iEval_ x (e, []), 85 | ihastype = id, 86 | icprint = cPrint_ 0 0, 87 | itprint = cPrint_ 0 0 . quote0_, 88 | iiparse = parseITerm_ 0 [], 89 | isparse = parseStmt_ [], 90 | iassume = \ s (x, t) -> lpassume s x t } 91 | 92 | repLP :: IO () 93 | repLP = readevalprint lp ([], lpve, lpte) 94 | 95 | main :: IO () 96 | main = repLP 97 | -------------------------------------------------------------------------------- /src/LambdaPi/Parser.hs: -------------------------------------------------------------------------------- 1 | module LambdaPi.Parser where 2 | 3 | import Data.List 4 | import Text.ParserCombinators.Parsec hiding (parse, State) 5 | import qualified Text.ParserCombinators.Parsec as P 6 | import Text.ParserCombinators.Parsec.Token 7 | import Text.ParserCombinators.Parsec.Language 8 | 9 | import Common 10 | import LambdaPi.AST 11 | 12 | lambdaPi = makeTokenParser (haskellStyle { identStart = letter <|> P.char '_', 13 | reservedNames = ["forall", "let", "assume", "putStrLn", "out"] }) 14 | 15 | 16 | parseStmt_ :: [String] -> CharParser () (Stmt ITerm_ CTerm_) 17 | parseStmt_ e = 18 | do 19 | reserved lambdaPi "let" 20 | x <- identifier lambdaPi 21 | reserved lambdaPi "=" 22 | t <- parseITerm_ 0 e 23 | return (Let x t) 24 | <|> do 25 | reserved lambdaPi "assume" 26 | (xs, ts) <- parseBindings_ False [] 27 | return (Assume (reverse (zip xs ts))) 28 | <|> do 29 | reserved lambdaPi "putStrLn" 30 | x <- stringLiteral lambdaPi 31 | return (PutStrLn x) 32 | <|> do 33 | reserved lambdaPi "out" 34 | x <- option "" (stringLiteral lambdaPi) 35 | return (Out x) 36 | <|> fmap Eval (parseITerm_ 0 e) 37 | parseBindings_ :: Bool -> [String] -> CharParser () ([String], [CTerm_]) 38 | parseBindings_ b e = 39 | (let rec :: [String] -> [CTerm_] -> CharParser () ([String], [CTerm_]) 40 | rec e ts = 41 | do 42 | (x,t) <- parens lambdaPi 43 | (do 44 | x <- identifier lambdaPi 45 | reserved lambdaPi "::" 46 | t <- parseCTerm_ 0 (if b then e else []) 47 | return (x,t)) 48 | (rec (x : e) (t : ts) <|> return (x : e, t : ts)) 49 | in rec e []) 50 | <|> 51 | do x <- identifier lambdaPi 52 | reserved lambdaPi "::" 53 | t <- parseCTerm_ 0 e 54 | return (x : e, [t]) 55 | parseITerm_ :: Int -> [String] -> CharParser () ITerm_ 56 | parseITerm_ 0 e = 57 | do 58 | reserved lambdaPi "forall" 59 | (fe,t:ts) <- parseBindings_ True e 60 | reserved lambdaPi "." 61 | t' <- parseCTerm_ 0 fe 62 | return (foldl (\ p t -> Pi_ t (Inf_ p)) (Pi_ t t') ts) 63 | <|> 64 | try 65 | (do 66 | t <- parseITerm_ 1 e 67 | rest (Inf_ t) <|> return t) 68 | <|> do 69 | t <- parens lambdaPi (parseLam_ e) 70 | rest t 71 | where 72 | rest t = 73 | do 74 | reserved lambdaPi "->" 75 | t' <- parseCTerm_ 0 ([]:e) 76 | return (Pi_ t t') 77 | parseITerm_ 1 e = 78 | try 79 | (do 80 | t <- parseITerm_ 2 e 81 | rest (Inf_ t) <|> return t) 82 | <|> do 83 | t <- parens lambdaPi (parseLam_ e) 84 | rest t 85 | where 86 | rest t = 87 | do 88 | reserved lambdaPi "::" 89 | t' <- parseCTerm_ 0 e 90 | return (Ann_ t t') 91 | parseITerm_ 2 e = 92 | do 93 | t <- parseITerm_ 3 e 94 | ts <- many (parseCTerm_ 3 e) 95 | return (foldl (:$:) t ts) 96 | parseITerm_ 3 e = 97 | do 98 | reserved lambdaPi "*" 99 | return Star_ 100 | <|> do 101 | n <- natural lambdaPi 102 | return (toNat_ n) 103 | <|> do 104 | x <- identifier lambdaPi 105 | case findIndex (== x) e of 106 | Just n -> return (Bound_ n) 107 | Nothing -> return (Free_ (Global x)) 108 | <|> parens lambdaPi (parseITerm_ 0 e) 109 | 110 | parseCTerm_ :: Int -> [String] -> CharParser () CTerm_ 111 | parseCTerm_ 0 e = 112 | parseLam_ e 113 | <|> fmap Inf_ (parseITerm_ 0 e) 114 | parseCTerm_ p e = 115 | try (parens lambdaPi (parseLam_ e)) 116 | <|> fmap Inf_ (parseITerm_ p e) 117 | 118 | parseLam_ :: [String] -> CharParser () CTerm_ 119 | parseLam_ e = 120 | do reservedOp lambdaPi "\\" 121 | xs <- many1 (identifier lambdaPi) 122 | reservedOp lambdaPi "->" 123 | t <- parseCTerm_ 0 (reverse xs ++ e) 124 | -- reserved lambdaPi "." 125 | return (iterate Lam_ t !! length xs) 126 | toNat_ :: Integer -> ITerm_ 127 | toNat_ n = Ann_ (toNat_' n) (Inf_ Nat_) 128 | toNat_' :: Integer -> CTerm_ 129 | toNat_' 0 = Zero_ 130 | toNat_' n = Succ_ (toNat_' (n - 1)) -------------------------------------------------------------------------------- /src/LambdaPi/Printer.hs: -------------------------------------------------------------------------------- 1 | module LambdaPi.Printer where 2 | 3 | import Prelude hiding ((<>)) 4 | import Text.PrettyPrint.HughesPJ hiding (parens) 5 | 6 | import Common 7 | import LambdaPi.AST 8 | 9 | iPrint_ :: Int -> Int -> ITerm_ -> Doc 10 | iPrint_ p ii (Ann_ c ty) = parensIf (p > 1) (cPrint_ 2 ii c <> text " :: " <> cPrint_ 0 ii ty) 11 | iPrint_ p ii Star_ = text "*" 12 | iPrint_ p ii (Pi_ d (Inf_ (Pi_ d' r))) 13 | = parensIf (p > 0) (nestedForall_ (ii + 2) [(ii + 1, d'), (ii, d)] r) 14 | iPrint_ p ii (Pi_ d r) = parensIf (p > 0) (sep [text "forall " <> text (vars !! ii) <> text " :: " <> cPrint_ 0 ii d <> text " .", cPrint_ 0 (ii + 1) r]) 15 | iPrint_ p ii (Bound_ k) = text (vars !! (ii - k - 1)) 16 | iPrint_ p ii (Free_ (Global s))= text s 17 | iPrint_ p ii (i :$: c) = parensIf (p > 2) (sep [iPrint_ 2 ii i, nest 2 (cPrint_ 3 ii c)]) 18 | iPrint_ p ii Nat_ = text "Nat" 19 | iPrint_ p ii (NatElim_ m z s n)= iPrint_ p ii (Free_ (Global "natElim") :$: m :$: z :$: s :$: n) 20 | iPrint_ p ii (Vec_ a n) = iPrint_ p ii (Free_ (Global "Vec") :$: a :$: n) 21 | iPrint_ p ii (VecElim_ a m mn mc n xs) 22 | = iPrint_ p ii (Free_ (Global "vecElim") :$: a :$: m :$: mn :$: mc :$: n :$: xs) 23 | iPrint_ p ii (Eq_ a x y) = iPrint_ p ii (Free_ (Global "Eq") :$: a :$: x :$: y) 24 | iPrint_ p ii (EqElim_ a m mr x y eq) 25 | = iPrint_ p ii (Free_ (Global "eqElim") :$: a :$: m :$: mr :$: x :$: y :$: eq) 26 | iPrint_ p ii (Fin_ n) = iPrint_ p ii (Free_ (Global "Fin") :$: n) 27 | iPrint_ p ii (FinElim_ m mz ms n f) 28 | = iPrint_ p ii (Free_ (Global "finElim") :$: m :$: mz :$: ms :$: n :$: f) 29 | iPrint_ p ii x = text ("[" ++ show x ++ "]") 30 | cPrint_ :: Int -> Int -> CTerm_ -> Doc 31 | cPrint_ p ii (Inf_ i) = iPrint_ p ii i 32 | cPrint_ p ii (Lam_ c) = parensIf (p > 0) (text "\\ " <> text (vars !! ii) <> text " -> " <> cPrint_ 0 (ii + 1) c) 33 | cPrint_ p ii Zero_ = fromNat_ 0 ii Zero_ -- text "Zero" 34 | cPrint_ p ii (Succ_ n) = fromNat_ 0 ii (Succ_ n) -- iPrint_ p ii (Free_ (Global "Succ") :$: n) 35 | cPrint_ p ii (Nil_ a) = iPrint_ p ii (Free_ (Global "Nil") :$: a) 36 | cPrint_ p ii (Cons_ a n x xs) = 37 | iPrint_ p ii (Free_ (Global "Cons") :$: a :$: n :$: x :$: xs) 38 | cPrint_ p ii (Refl_ a x) = iPrint_ p ii (Free_ (Global "Refl") :$: a :$: x) 39 | cPrint_ p ii (FZero_ n) = iPrint_ p ii (Free_ (Global "FZero") :$: n) 40 | cPrint_ p ii (FSucc_ n f)= iPrint_ p ii (Free_ (Global "FSucc") :$: n :$: f) 41 | fromNat_ :: Int -> Int -> CTerm_ -> Doc 42 | fromNat_ n ii Zero_ = int n 43 | fromNat_ n ii (Succ_ k) = fromNat_ (n + 1) ii k 44 | fromNat_ n ii t = parensIf True (int n <> text " + " <> cPrint_ 0 ii t) 45 | nestedForall_ :: Int -> [(Int, CTerm_)] -> CTerm_ -> Doc 46 | nestedForall_ ii ds (Inf_ (Pi_ d r)) = nestedForall_ (ii + 1) ((ii, d) : ds) r 47 | nestedForall_ ii ds x = sep [text "forall " <> sep [parensIf True (text (vars !! n) <> text " :: " <> cPrint_ 0 n d) | (n,d) <- reverse ds] <> text " .", cPrint_ 0 ii x] 48 | -------------------------------------------------------------------------------- /src/LambdaPi/Quote.hs: -------------------------------------------------------------------------------- 1 | module LambdaPi.Quote where 2 | 3 | import Common 4 | import LambdaPi.AST 5 | 6 | instance Show Value_ where 7 | show = show . quote0_ 8 | 9 | quote0_ :: Value_ -> CTerm_ 10 | quote0_ = quote_ 0 11 | 12 | quote_ :: Int -> Value_ -> CTerm_ 13 | quote_ ii (VLam_ t) 14 | = Lam_ (quote_ (ii + 1) (t (vfree_ (Quote ii)))) 15 | 16 | quote_ ii VStar_ = Inf_ Star_ 17 | quote_ ii (VPi_ v f) 18 | = Inf_ (Pi_ (quote_ ii v) (quote_ (ii + 1) (f (vfree_ (Quote ii))))) 19 | quote_ ii (VNeutral_ n) 20 | = Inf_ (neutralQuote_ ii n) 21 | quote_ ii VNat_ = Inf_ Nat_ 22 | quote_ ii VZero_ = Zero_ 23 | quote_ ii (VSucc_ n) = Succ_ (quote_ ii n) 24 | quote_ ii (VVec_ a n) = Inf_ (Vec_ (quote_ ii a) (quote_ ii n)) 25 | quote_ ii (VNil_ a) = Nil_ (quote_ ii a) 26 | quote_ ii (VCons_ a n x xs) = Cons_ (quote_ ii a) (quote_ ii n) 27 | (quote_ ii x) (quote_ ii xs) 28 | quote_ ii (VEq_ a x y) = Inf_ (Eq_ (quote_ ii a) (quote_ ii x) (quote_ ii y)) 29 | quote_ ii (VRefl_ a x) = Refl_ (quote_ ii a) (quote_ ii x) 30 | quote_ ii (VFin_ n) = Inf_ (Fin_ (quote_ ii n)) 31 | quote_ ii (VFZero_ n) = FZero_ (quote_ ii n) 32 | quote_ ii (VFSucc_ n f) = FSucc_ (quote_ ii n) (quote_ ii f) 33 | neutralQuote_ :: Int -> Neutral_ -> ITerm_ 34 | neutralQuote_ ii (NFree_ v) 35 | = boundfree_ ii v 36 | neutralQuote_ ii (NApp_ n v) 37 | = neutralQuote_ ii n :$: quote_ ii v 38 | neutralQuote_ ii (NNatElim_ m z s n) 39 | = NatElim_ (quote_ ii m) (quote_ ii z) (quote_ ii s) (Inf_ (neutralQuote_ ii n)) 40 | neutralQuote_ ii (NVecElim_ a m mn mc n xs) 41 | = VecElim_ (quote_ ii a) (quote_ ii m) 42 | (quote_ ii mn) (quote_ ii mc) 43 | (quote_ ii n) (Inf_ (neutralQuote_ ii xs)) 44 | neutralQuote_ ii (NEqElim_ a m mr x y eq) 45 | = EqElim_ (quote_ ii a) (quote_ ii m) (quote_ ii mr) 46 | (quote_ ii x) (quote_ ii y) 47 | (Inf_ (neutralQuote_ ii eq)) 48 | neutralQuote_ ii (NFinElim_ m mz ms n f) 49 | = FinElim_ (quote_ ii m) 50 | (quote_ ii mz) (quote_ ii ms) 51 | (quote_ ii n) (Inf_ (neutralQuote_ ii f)) 52 | 53 | boundfree_ :: Int -> Name -> ITerm_ 54 | boundfree_ ii (Quote k) = Bound_ ((ii - k - 1) `max` 0) 55 | boundfree_ ii x = Free_ x -------------------------------------------------------------------------------- /src/REPL.hs: -------------------------------------------------------------------------------- 1 | module REPL where 2 | 3 | import Prelude hiding (print, (<>)) 4 | import Control.Monad.Except 5 | import Data.List 6 | import Data.Char 7 | import Text.PrettyPrint.HughesPJ hiding (parens) 8 | import qualified Text.PrettyPrint.HughesPJ as PP 9 | import Text.ParserCombinators.Parsec hiding (parse, State) 10 | import qualified Text.ParserCombinators.Parsec as P 11 | import Text.ParserCombinators.Parsec.Token 12 | import Text.ParserCombinators.Parsec.Language 13 | import System.IO hiding (print) 14 | import System.IO.Error 15 | 16 | 17 | import Common 18 | 19 | data Command = TypeOf String 20 | | Compile CompileForm 21 | | Browse 22 | | Quit 23 | | Help 24 | | Noop 25 | 26 | data CompileForm = CompileInteractive String 27 | | CompileFile String 28 | 29 | data InteractiveCommand = Cmd [String] String (String -> Command) String 30 | 31 | type Ctx inf = [(Name, inf)] 32 | type State v inf = (String, NameEnv v, Ctx inf) 33 | 34 | data Interpreter i c v t tinf inf = 35 | I { iname :: String, 36 | iprompt :: String, 37 | iitype :: NameEnv v -> Ctx inf -> i -> Result t, 38 | iquote :: v -> c, 39 | ieval :: NameEnv v -> i -> v, 40 | ihastype :: t -> inf, 41 | icprint :: c -> Doc, 42 | itprint :: t -> Doc, 43 | iiparse :: CharParser () i, 44 | isparse :: CharParser () (Stmt i tinf), 45 | iassume :: State v inf -> (String, tinf) -> IO (State v inf) } 46 | 47 | helpTxt :: [InteractiveCommand] -> String 48 | helpTxt cs 49 | = "List of commands: Any command may be abbreviated to :c where\n" ++ 50 | "c is the first character in the full name.\n\n" ++ 51 | " evaluate expression\n" ++ 52 | "let = define variable\n" ++ 53 | "assume :: assume variable\n\n" 54 | ++ 55 | unlines (map (\ (Cmd cs a _ d) -> let ct = concat (intersperse ", " (map (++ if null a then "" else " " ++ a) cs)) 56 | in ct ++ replicate ((24 - length ct) `max` 2) ' ' ++ d) cs) 57 | 58 | commands :: [InteractiveCommand] 59 | commands 60 | = [ Cmd [":type"] "" TypeOf "print type of expression", 61 | Cmd [":browse"] "" (const Browse) "browse names in scope", 62 | Cmd [":load"] "" (Compile . CompileFile) 63 | "load program from file", 64 | Cmd [":quit"] "" (const Quit) "exit interpreter", 65 | Cmd [":help",":?"] "" (const Help) "display this list of commands" ] 66 | 67 | dummy = makeTokenParser (haskellStyle { identStart = letter <|> P.char '_', 68 | reservedNames = [] }) 69 | 70 | parseIO :: String -> CharParser () a -> String -> IO (Maybe a) 71 | parseIO f p x = case P.parse (whiteSpace dummy >> p >>= \ x -> eof >> return x) f x of 72 | Left e -> putStrLn (show e) >> return Nothing 73 | Right r -> return (Just r) 74 | 75 | readevalprint :: Interpreter i c v t tinf inf -> State v inf -> IO () 76 | readevalprint int state@(out, ve, te) = 77 | let rec int state = 78 | do 79 | putStr (iprompt int) 80 | hFlush stdout 81 | x <- catchIOError (fmap Just getLine) (\_ -> return Nothing) 82 | case x of 83 | Nothing -> return () 84 | Just "" -> 85 | rec int state 86 | Just x -> 87 | do 88 | c <- interpretCommand x 89 | state' <- handleCommand int state c 90 | maybe (return ()) (rec int) state' 91 | in 92 | do 93 | -- welcome 94 | putStrLn ("Interpreter for " ++ iname int ++ ".\n" ++ 95 | "Type :? for help.") 96 | -- enter loop 97 | rec int state 98 | 99 | interpretCommand :: String -> IO Command 100 | interpretCommand x 101 | = if isPrefixOf ":" x then 102 | do let (cmd,t') = break isSpace x 103 | t = dropWhile isSpace t' 104 | -- find matching commands 105 | let matching = filter (\ (Cmd cs _ _ _) -> any (isPrefixOf cmd) cs) commands 106 | case matching of 107 | [] -> do putStrLn ("Unknown command `" ++ cmd ++ "'. Type :? for help.") 108 | return Noop 109 | [Cmd _ _ f _] 110 | -> do return (f t) 111 | x -> do putStrLn ("Ambiguous command, could be " ++ concat (intersperse ", " [ head cs | Cmd cs _ _ _ <- matching ]) ++ ".") 112 | return Noop 113 | else 114 | return (Compile (CompileInteractive x)) 115 | 116 | handleCommand :: Interpreter i c v t tinf inf -> State v inf -> Command -> IO (Maybe (State v inf)) 117 | handleCommand int state@(out, ve, te) cmd 118 | = case cmd of 119 | Quit -> (putStrLn "!@#$^&*") >> return Nothing 120 | Noop -> return (Just state) 121 | Help -> putStr (helpTxt commands) >> return (Just state) 122 | TypeOf x -> 123 | do x <- parseIO "" (iiparse int) x 124 | t <- maybe (return Nothing) (iinfer int ve te) x 125 | maybe (return ()) (\u -> putStrLn (render (itprint int u))) t 126 | return (Just state) 127 | Browse -> do putStr (unlines [ s | Global s <- reverse (nub (map fst te)) ]) 128 | return (Just state) 129 | Compile c -> 130 | do state <- case c of 131 | CompileInteractive s -> compilePhrase int state s 132 | CompileFile f -> compileFile int state f 133 | return (Just state) 134 | 135 | compileFile :: Interpreter i c v t tinf inf -> State v inf -> String -> IO (State v inf) 136 | compileFile int state@(out, ve, te) f = 137 | do 138 | x <- readFile f 139 | stmts <- parseIO f (many (isparse int)) x 140 | maybe (return state) (foldM (handleStmt int) state) stmts 141 | 142 | compilePhrase :: Interpreter i c v t tinf inf -> State v inf -> String -> IO (State v inf) 143 | compilePhrase int state@(out, ve, te) x = 144 | do 145 | x <- parseIO "" (isparse int) x 146 | maybe (return state) (handleStmt int state) x 147 | 148 | 149 | iinfer int d g t = 150 | case iitype int d g t of 151 | Left e -> putStrLn e >> return Nothing 152 | Right v -> return (Just v) 153 | 154 | handleStmt :: Interpreter i c v t tinf inf 155 | -> State v inf -> Stmt i tinf -> IO (State v inf) 156 | handleStmt int state@(out, ve, te) stmt = 157 | do 158 | case stmt of 159 | Assume ass -> foldM (iassume int) state ass 160 | Let x e -> checkEval x e 161 | Eval e -> checkEval it e 162 | PutStrLn x -> putStrLn x >> return state 163 | Out f -> return (f, ve, te) 164 | where 165 | -- checkEval :: String -> i -> IO (State v inf) 166 | checkEval i t = 167 | check int state i t 168 | (\ (y, v) -> do 169 | -- ugly, but we have limited space in the paper 170 | -- usually, you'd want to have the bound identifier *and* 171 | -- the result of evaluation 172 | let outtext = if i == it then render (icprint int (iquote int v) <> text " :: " <> itprint int y) 173 | else render (text i <> text " :: " <> itprint int y) 174 | putStrLn outtext 175 | unless (null out) (writeFile out (process outtext))) 176 | (\ (y, v) -> ("", (Global i, v) : ve, (Global i, ihastype int y) : te)) 177 | 178 | check :: Interpreter i c v t tinf inf -> State v inf -> String -> i 179 | -> ((t, v) -> IO ()) -> ((t, v) -> State v inf) -> IO (State v inf) 180 | check int state@(out, ve, te) i t kp k = 181 | do 182 | -- i: String, t: Type 183 | -- typecheck and evaluate 184 | x <- iinfer int ve te t 185 | case x of 186 | Nothing -> 187 | do 188 | -- putStrLn "type error" 189 | return state 190 | Just y -> 191 | do 192 | let v = ieval int ve t 193 | kp (y, v) 194 | return (k (y, v)) 195 | 196 | 197 | it = "it" 198 | process :: String -> String 199 | process = unlines . map (\ x -> "< " ++ x) . lines 200 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.22 2 | 3 | packages: [.] 4 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 532414 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/22.yaml 11 | sha256: e483fb88549fc0f454c190979bf35ac91c7aceff2c0e71e7d8edd11842d772d8 12 | original: lts-16.22 13 | --------------------------------------------------------------------------------