rachel/pi
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

implemented types ⊤, ⊥, and ℕ

Browse Source
This commit is contained in:
Rachel Lambda Samuelsson 2022-07-21 00:05:45 +02:00
parent 2b441fe0ec
commit ab7d70d562
7 changed files with 267 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
README.md
View File

@ -1,19 +1,37 @@
# pi # pi
A dependently typed system A dependently typed system
# Implemented
* A Basic dependent lambda calculus
* lambda abstractions
* variables
* pi types
* type of types
* Unit type
* Empty type
* Natural numbers
# TODO # TODO
* Some fun types * Fun types
* ⊤
* ⊥
* ℕ
* Σ * Σ
* Id * Id
* Parser
* Implicit arguments * Implicit arguments
* Universes * Universes
* (indexed) inductive datatypes
* Write down the rules (I'll not get this far)
# References # References
Some of the material I found helpful in groking dependent type checking: Some of the material I found helpful in groking dependent type checking:

34
src/Check.idr
View File

@ -41,16 +41,42 @@ mutual
-- terms types term -- terms types term
infer : Ctx n -> Ctx n -> Term n -> PI Value infer : Ctx n -> Ctx n -> Term n -> PI Value
infer trs tys (TVar i _) = pure (index (natToFinLT i) tys) infer trs tys (TVar i) = pure (index i tys)
infer trs tys TType = pure VType infer trs tys TType = pure VType
infer trs tys (TApp f x) = infer trs tys f >>= whnf >>= infer trs tys (TApp f x) = infer trs tys f >>= whnf >>=
\case \case
VClos env (TPi a b) => do VClos env (TPi a b) => do
if !(check trs tys (VClos env a) x) guard =<< check trs tys (VClos env a) x
then pure (VClos (VClos trs x :: env) b) pure (VClos (VClos trs x :: env) b)
else oops "application"
_ => oops "expected infer pi" _ => oops "expected infer pi"
infer trs tys TTop = pure VType
infer trs tys TBot = pure VType
infer trs tys TNat = pure VType
infer trs tys TStar = pure VTop
infer trs tys TZero = pure VNat
infer trs tys (TSuc n) = do
guard =<< check trs tys VNat n
pure VNat
infer trs tys (TTopInd c st) = do
guard =<< check trs tys (VClos trs (TPi TTop TType)) c
guard =<< check trs tys (VApp (VClos trs c) VStar) st
pure (VClos trs (TPi TTop (TApp (weakTr c) (TVar 0))))
infer trs tys (TBotInd c) = do
guard =<< check trs tys (VClos trs (TPi TBot TType)) c
pure (VClos trs (TPi TBot (TApp (weakTr c) (TVar 0))))
infer trs tys (TNatInd c z s) = do
guard =<< check trs tys (VClos trs (TPi TNat TType)) c
guard =<< check trs tys (VApp (VClos trs c) (VNatTr 0)) z
guard =<< check trs tys (VClos trs (TPi TNat
(TPi (TApp (weakTr c) (TVar 0))
(TApp (weakTr2 c) (TSuc (TVar (FS FZ))))))) s
pure (VClos trs (TPi TNat (TApp (weakTr c) (TVar 0))))
infer trs tys _ = oops "cannot infer type" infer trs tys _ = oops "cannot infer type"
public export public export

34
src/Convert.idr
View File

@ -24,6 +24,13 @@ convert u1 u2 = do
assert_total $ -- :( assert_total $ -- :(
case (u1', u2') of case (u1', u2') of
(VType, VType) => pure True (VType, VType) => pure True
(VTop, VTop) => pure True
(VStar, VStar) => pure True
(VBot, VBot) => pure True
(VNat, VNat) => pure True
(VNatTr n, VNatTr m) => pure (n == m)
(VApp f1 x1, VApp f2 x2) => (&&) <$> convert f1 f2 (VApp f1 x1, VApp f2 x2) => (&&) <$> convert f1 f2
<*> delay <$> convert x1 x2 <*> delay <$> convert x1 x2
(VGen k1, VGen k2) => pure (k1 == k2) (VGen k1, VGen k2) => pure (k1 == k2)
@ -38,5 +45,30 @@ convert u1 u2 = do
(&&) <$> convert (VClos env1 a1) (&&) <$> convert (VClos env1 a1)
(VClos env2 a2) (VClos env2 a2)
<*> delay <$> convert (VClos (v :: env1) b1) <*> delay <$> convert (VClos (v :: env1) b1)
(VClos (v :: env2) b2) (VClos (v :: env2) b2)
(VClos env1 (TTopInd c1 st1), VClos env2 (TTopInd c2 st2)) => do
c1' <- eval env1 c1
c2' <- eval env2 c2
st1' <- eval env1 st1
st2' <- eval env2 st2
(&&) <$> convert c1' c2' <*> delay <$> convert st1' st2'
(VClos env1 (TBotInd c1), VClos env2 (TBotInd c2)) => do
c1' <- eval env1 c1
c2' <- eval env2 c2
convert c1' c2'
-- lmao
(VClos env1 (TNatInd c1 z1 s1), VClos env2 (TNatInd c2 z2 s2)) => do
c1' <- eval env1 c1
c2' <- eval env2 c2
z1' <- eval env1 z1
z2' <- eval env2 z2
s1' <- eval env1 s1
s2' <- eval env2 s2
b1 <- (&&) <$> convert c1' c2' <*> delay <$> convert z1' z2'
guard b1
convert s1' s2'
_ => pure False _ => pure False

40
src/Normalize.idr
View File

@ -15,18 +15,52 @@ import Data.Vect
mutual mutual
public export public export
-- no computational rule for ⊥
app : Value -> Value -> PI Value app : Value -> Value -> PI Value
app (VClos env (TLam sc)) x = eval (x :: env) sc app (VClos env (TLam sc)) x = eval (x :: env) sc
app f x = pure (VApp f x)
app (VClos env (TTopInd c st)) VTop = eval env st
app f@(VClos env (TTopInd c st)) x = logS ("⊤-ind applied to " ++ show x)
>> pure (VApp f x)
app (VClos env (TNatInd _ z s)) (VNatTr n) = do
z' <- eval env z
s' <- eval env s
assert_total (nind z' s' n) -- :(
where
nind : Value -> Value -> Nat -> PI Value
nind z s 0 = pure z
nind z s (S n) = do
rec <- nind z s n
sn <- app s (VNatTr n)
app sn rec
app f@(VClos env (TNatInd _ z s)) x = logS ("ℕ-ind applied to " ++ show x)
>> pure (VApp f x)
app f x = pure (VApp f x)
public export public export
eval : Ctx n -> Term n -> PI Value eval : Ctx n -> Term n -> PI Value
eval env (TVar i _) = pure (index (natToFinLT i) env) eval env (TVar i) = pure (index i env)
eval env (TApp f x) = do eval env (TApp f x) = do
f' <- eval env f f' <- eval env f
x' <- eval env x x' <- eval env x
assert_total (app f' x') -- :( assert_total (app f' x') -- :(
eval env TType = pure VType eval env TType = pure VType
eval env TTop = pure VTop
eval env TStar = pure VStar
eval env TBot = pure VBot
eval env TNat = pure VNat
eval env TZero = pure (VNatTr 0)
eval env (TSuc n) = do
n' <- eval env n
case n' of
VNatTr n => pure (VNatTr (S n))
x => logS ("suc applied to " ++ show x)
>> pure (VClos env (TSuc n))
eval env tr = pure (VClos env tr) eval env tr = pure (VClos env tr)
public export public export

86
src/Term.idr
View File

@ -1,6 +1,6 @@
module Term module Term
import Data.Nat import Data.Fin
import Misc import Misc
@ -12,16 +12,80 @@ import Misc
-} -}
public export public export
data Term : (_ : Index) -> Type where data Term : (_ : Index) -> Type where
TType : Term n -- Type of types TType : Term n -- Type of types
TLam : Term (S n) -> Term n -- Lambda abstraction (λ _ . Scope)
TPi : Term n -> Term (S n) -> Term n -- Pi type (∏ _ : A . B _ ) TTop : Term n -- Unit type
TApp : Term n -> Term n -> Term n -- Appliction TStar : Term n -- Unit term
TVar : (n : Nat) -> LT n m -> Term m -- Variable TTopInd : Term n -> Term n -> Term n -- : (x : ⊤) → C x
TBot : Term n -- Empty type
TBotInd : Term n -> Term n -- : (x : ⊥) → C x
TNat : Term n -- ℕ
TZero : Term n -- 0
TSuc : Term n -> Term n -- successor
TNatInd : Term n -> Term n -> Term n -> Term n -- : (x : ℕ) → C x
TLam : Term (S n) -> Term n -- Lambda abstraction (λ _ . Scope)
TPi : Term n -> Term (S n) -> Term n -- Pi type (∏ _ : A . B _ )
TApp : Term n -> Term n -> Term n -- Appliction
TVar : Fin n -> Term n -- Variable
infixl 2 `TApp`
public export public export
Show (Term n) where Show (Term n) where
show TType = "TType" show TType = "TType"
show (TLam sc) = "TLam (" ++ show sc ++ ")"
show (TPi ty sc) = "TPi (" ++ show ty ++ ") (" ++ show sc ++ ")" show TTop = "⊤"
show (TApp f x) = "TApp (" ++ show f ++ ") (" ++ show x ++ ")" show TStar = "★"
show (TVar i _) = "TVar " ++ show i show (TTopInd c st) = "⊤-ind (" ++ show c ++ ") (" ++ show st ++ ")"
show TBot = "⊥"
show (TBotInd c) = "⊥-ind (" ++ show c ++ ")"
show TNat = "ℕ"
show TZero = "0"
show (TSuc n) = "suc (" ++ show n ++ ")"
show (TNatInd c z s) = "ℕ-ind (" ++ show c ++ ") (" ++ show z ++ ") (" ++ show s ++ ")"
show (TLam sc) = "TLam (" ++ show sc ++ ")"
show (TPi ty sc) = "TPi (" ++ show ty ++ ") (" ++ show sc ++ ")"
show (TApp f x) = "TApp (" ++ show f ++ ") (" ++ show x ++ ")"
show (TVar i) = "TVar " ++ show i
public export
weakTr : Term n -> Term (S n)
weakTr = go 0
where
go : {0 n : Nat} -> Fin (S n) -> Term n -> Term (S n)
go n TType = TType
go n TTop = TTop
go n TStar = TTop
go n (TTopInd c st) = TTopInd (go n c) (go n st)
go n TBot = TBot
go n (TBotInd c) = TBotInd (go n c)
go n TNat = TNat
go n TZero = TZero
go n (TSuc m) = TSuc (go n m)
go n (TNatInd c z s) = TNatInd (go n c) (go n z) (go n s)
go n (TLam sc) = TLam (go (FS n) sc)
go n (TPi ty sc) = TPi (go n ty) (go (FS n) sc)
go n (TApp f x) = TApp (go n f) (go n x)
go n (TVar i) = if weaken i < n
then TVar (weaken i)
else TVar (FS i)
public export
weakTr2 : Term n -> Term (2+n)
weakTr2 = weakTr . weakTr
public export
weakTr3 : Term n -> Term (3+n)
weakTr3 = weakTr . weakTr2
public export
weakTr4 : Term n -> Term (4+n)
weakTr4 = weakTr2 . weakTr2

64
src/Tests.idr
View File

@ -11,25 +11,22 @@ import Control.Monad.RWS
import Control.Monad.Identity import Control.Monad.Identity
import Control.Monad.Either import Control.Monad.Either
import Data.Nat import Data.Fin
%default total %default total
a : {p, q : Nat} -> lt p q = True -> LT p q
a {p} {q} eq = ltReflectsLT p q eq
{- λA. λx. x : ∏ (A : Type) → A → A -} {- λA. λx. x : ∏ (A : Type) → A → A -}
test_id : Either String (Bool, List String) test_id : Either String (Bool, List String)
test_id = typecheck (TLam (TLam (TVar 0 (a Refl)))) test_id = typecheck (TLam (TLam (TVar 0)))
(TPi TType (TPi (TVar 0 (a Refl)) (TVar 1 (a Refl)))) (TPi TType (TPi (TVar 0) (TVar 1)))
{- λA. λB. λf. λx. f x : ∏ (A : Type) ∏ (B : A → Type) ∏ (f : ∏ (x : A) B x) ∏ (x : A) B x -} {- λA. λB. λf. λx. f x : ∏ (A : Type) ∏ (B : A → Type) ∏ (f : ∏ (x : A) B x) ∏ (x : A) B x -}
test_app : Either String (Bool, List String) test_app : Either String (Bool, List String)
test_app = typecheck (TLam (TLam (TLam (TLam (TApp (TVar 1 (a Refl)) (TVar 0 (a Refl))))))) test_app = typecheck (TLam (TLam (TLam (TLam (TApp (TVar 1) (TVar 0))))))
(TPi TType (TPi TType
(TPi (TPi (TVar 0 (a Refl)) TType) (TPi (TPi (TVar 0) TType)
(TPi (TPi (TVar 1 (a Refl)) (TApp (TVar 1 (a Refl)) (TVar 0 (a Refl)))) (TPi (TPi (TVar 1) (TApp (TVar 1) (TVar 0)))
(TPi (TVar 2 (a Refl)) (TApp (TVar 2 (a Refl)) (TVar 0 (a Refl))))))) (TPi (TVar 2) (TApp (TVar 2) (TVar 0))))))
{- λf. λx. f x ≃ λf. λx. (λy. f y) x -} {- λf. λx. f x ≃ λf. λx. (λy. f y) x -}
eta_test : Either String (Bool, List String) eta_test : Either String (Bool, List String)
@ -37,6 +34,49 @@ eta_test = resolve action
where where
action : PI Bool action : PI Bool
action = do action = do
x <- eval ctx0 (TLam (TLam (TApp (TVar 1 (a Refl)) (TVar 0 (a Refl))))) x <- eval ctx0 (TLam (TLam (TApp (TVar 1) (TVar 0))))
y <- eval ctx0 (TLam (TLam (TApp (TLam (TApp (TVar 2 (a Refl)) (TVar 0 (a Refl)))) (TVar 0 (a Refl))))) y <- eval ctx0 (TLam (TLam (TApp (TLam (TApp (TVar 2) (TVar 0))) (TVar 0))))
convert x y convert x y
addition : Term 0
addition = TNatInd (TLam (TPi TNat TNat))
(TLam (TVar 0))
(TLam {-n-} (TLam {-n+-} (TLam {-m-} (TSuc (TApp (TVar 1) (TVar 0))))))
addition_type : Either String (Bool, List String)
addition_type = typecheck addition (TPi TNat (TPi TNat TNat))
{- 2 + 1 = 3 -}
add_test : Either String (Bool, List String)
add_test = resolve action
where
action : PI Bool
action = do
x <- eval ctx0 (addition `TApp` TSuc (TSuc TZero) `TApp` TSuc TZero)
y <- eval ctx0 (TSuc (TSuc (TSuc TZero)))
convert x y
multi : Term 0
multi = TNatInd (TLam (TPi TNat TNat))
(TLam TZero)
(TLam {-n-} (TLam {-n*-} (TLam {-m-} (weakTr3 addition `TApp` TVar 0 `TApp` (TVar 1 `TApp` TVar 0)))))
multi_type : Either String (Bool, List String)
multi_type = typecheck multi (TPi TNat (TPi TNat TNat))
{- 2 * 3 = 6 -}
multi_test : Either String (Bool, List String)
multi_test = resolve action
where
action : PI Bool
action = do
x <- eval ctx0 (multi `TApp` TSuc (TSuc TZero) `TApp` TSuc (TSuc (TSuc TZero)))
y <- eval ctx0 (TSuc (TSuc (TSuc (TSuc (TSuc (TSuc TZero))))))
convert x y
-- no, not that kind
unit_test : Either String (Bool, List String)
unit_test = typecheck TStar TTop
absurd_test : Either String (Bool, List String)
absurd_test = typecheck (TLam (TBotInd (TLam (TVar 1)))) (TPi TType (TPi TBot (TVar 1)))

22
src/Value.idr
View File

@ -10,10 +10,19 @@ import Data.Vect
mutual mutual
public export public export
data Value : Type where data Value : Type where
VType : Value VType : Value
VGen : Nat -> Value
VApp : Value -> Value -> Value VTop : Value
VClos : Ctx n -> Term n -> Value VStar : Value
VBot : Value
VNat : Value
VNatTr : Nat -> Value
VGen : Nat -> Value
VApp : Value -> Value -> Value
VClos : Ctx n -> Term n -> Value
public export public export
Ctx : Index -> Type Ctx : Index -> Type
@ -26,6 +35,11 @@ ctx0 = []
public export public export
Show Value where Show Value where
show VType = "VType" show VType = "VType"
show VTop = "VTop"
show VStar = "VStar"
show VBot = "VBot"
show VNat = "VNat"
show (VNatTr n) = "V" ++ show n
show (VGen i) = "VGen " ++ show i show (VGen i) = "VGen " ++ show i
show (VApp f x) = "VApp (" ++ show f ++ ") (" ++ show x ++ ")" show (VApp f x) = "VApp (" ++ show f ++ ") (" ++ show x ++ ")"
show (VClos e t) = "VClos (" ++ assert_total (show e) ++ ") (" ++ show t ++ ")" show (VClos e t) = "VClos (" ++ assert_total (show e) ++ ") (" ++ show t ++ ")"