diff --git a/src/Core/Check.idr b/src/Core/Check.idr index e4dd020..d2218be 100644 --- a/src/Core/Check.idr +++ b/src/Core/Check.idr @@ -131,7 +131,7 @@ mutual infer trs tys (TTopInd c st) = do guardS "⊤ C" =<< check trs tys (VClos trs (TPi TTop TType)) c - guardS "⊤ ★" =<< check trs tys (VApp (VClos trs c) VStar) st + guardS "⊤ ★" =<< check trs tys (VClos trs (TApp c TStar)) st pure (VClos trs (TPi TTop (TApp (weakTr c) (TVar 0)))) infer trs tys (TBotInd c) = do diff --git a/src/Parser/Parse.idr b/src/Parser/Parse.idr index 72a38b5..b3aeed9 100644 --- a/src/Parser/Parse.idr +++ b/src/Parser/Parse.idr @@ -37,7 +37,7 @@ data PiTokenKind | PTBot | PTBotInd | PTNat - | PTZero + | PTNum | PTSuc | PTNatInd | PTSigInd @@ -67,7 +67,7 @@ Eq PiTokenKind where (==) PTBot PTBot = True (==) PTBotInd PTBotInd = True (==) PTNat PTNat = True - (==) PTZero PTZero = True + (==) PTNum PTNum = True (==) PTSuc PTSuc = True (==) PTNatInd PTNatInd = True (==) PTSigInd PTSigInd = True @@ -98,7 +98,7 @@ Show PiTokenKind where show PTBot = "PTBot" show PTBotInd = "PTBotInd" show PTNat = "PTNat" - show PTZero = "PTZero" + show PTNum = "PTNum " show PTSuc = "PTSuc" show PTNatInd = "PTNatInd" show PTSigInd = "PTSigInd" @@ -114,6 +114,7 @@ Show PiToken where TokenKind PiTokenKind where TokType PTIdentifier = String + TokType PTNum = Nat TokType _ = () tokValue PTLambda _ = () @@ -137,7 +138,7 @@ TokenKind PiTokenKind where tokValue PTBot _ = () tokValue PTBotInd _ = () tokValue PTNat _ = () - tokValue PTZero _ = () + tokValue PTNum s = cast s tokValue PTSuc _ = () tokValue PTNatInd _ = () tokValue PTSigInd _ = () @@ -185,11 +186,14 @@ tokenmap = [ (is '⊥', PTBot), (is 'ℕ', PTNat), (is '★', PTStar), - (is '0', PTZero) + (digits, PTNum) ] piTokenMap : TokenMap PiToken -piTokenMap = (spaces, Tok PTIgnore) :: +piTokenMap = + (spaces, Tok PTIgnore) :: + (lineComment (exact "--"), Tok PTIgnore) :: + (blockComment (exact "{-") (exact "-}"), Tok PTIgnore) :: toTokenMap tokenmap ++ [(identifier, \s => case lookup s keywords of @@ -211,7 +215,10 @@ mutual expr n env = tpi n env <|> tsigma n env <|> tarr n env - <|> expr1 n env + <|> (do + e <- expr1 n env + tapp n env e <|> pure e) + expr1 : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n) expr1 n env = ttopind n env @@ -232,7 +239,7 @@ mutual <|> tstar <|> tbot <|> tnat - <|> tzero + <|> tnum <|> tpair n env <|> tlet n env <|> tlam n env @@ -269,8 +276,14 @@ mutual tnat : Grammar () PiToken True (Term n) tnat = match PTNat >> pure TNat - tzero : Grammar () PiToken True (Term n) - tzero = match PTZero >> pure TZero + tnum : Grammar () PiToken True (Term n) + tnum = do + n <- match PTNum + pure (conv n) + where + conv : Nat -> Term n + conv 0 = TZero + conv (S n) = TSuc (conv n) tsuc : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n) tsuc n env = do @@ -400,6 +413,7 @@ mutual tvar : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n) tvar n env = do str <- match PTIdentifier + commit fromMaybe (fail ("'" ++ str ++ "' not in env")) (pure . TVar <$> findIndex (== str) env) paren : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n) @@ -433,6 +447,7 @@ parsePi n env parseEntry toks = Left e => (Left . show . map getErr) e where getErr : ParsingError tok -> String + getErr (Error "Unrecognised input" _) = "" getErr (Error s _) = s diff --git a/tests/fin.pi b/tests/fin.pi new file mode 100644 index 0000000..179bc65 --- /dev/null +++ b/tests/fin.pi @@ -0,0 +1,23 @@ +let bottomat : ℕ → ℕ → Type + ≔ ℕ-ind (λ_. ℕ → Type) + (λ_. ⊥) + (λn.λban. ℕ-ind (λ_. Type) ⊤ (λm.λ_. ban m)) + +let fin : ℕ → Type + ≔ λn. Σ (m : ℕ) bottomat n m + +let bool : Type + ≔ fin 2 + +let false : bool + ≔ (0, ★) + +let true : bool + ≔ (1, ★) + +{- +let boolind : Π (C : bool → Type) C false → C true → Π (b : bool) C b + ≔ λC.λCf.λCt. Σ-ind ℕ (bottomat 2) C (λn.λu. ℕ-ind (λm. Id ℕ m n → C (n, u)) + (λp. ?) + (λn.λ_.λp. ℕ-ind (λm. Id ℕ m n → C (n, u)) (λp. ?) (λm.λ_.λp. ⊥-ind (λ_. C (n, u)) ?))) +-} diff --git a/tests/id.pi b/tests/id.pi new file mode 100644 index 0000000..9d98d8d --- /dev/null +++ b/tests/id.pi @@ -0,0 +1,7 @@ +let transport : Π (A : Type) Π (f : A → Type) Π (x : A) Π (y : A) + Id A x y → f x → f y + ≔ λA.λf.λx.λy. J A x y (λa.λb.λ_. f a → f b) (λa.a) + +let ap : Π (A : Type) Π (B : Type) Π (f : A → B) + Π (x : A) Π (y : A) Id A x y → Id B (f x) (f y) + ≔ λA.λB.λf.λx.λy. J A x y (λa.λb.λ_. Id B (f a) (f b)) (refl B (f x)) diff --git a/tests/makefile b/tests/makefile new file mode 100644 index 0000000..cbb0622 --- /dev/null +++ b/tests/makefile @@ -0,0 +1,3 @@ +phony: test +test: + @make -C .. test diff --git a/tests/nat-id.pi b/tests/nat-id.pi index d96c1f7..29cd64b 100644 --- a/tests/nat-id.pi +++ b/tests/nat-id.pi @@ -1,6 +1,3 @@ -let sucf : ℕ → ℕ - ≔ λn. suc n - let add : ℕ → ℕ → ℕ ≔ ℕ-ind (λ_. ℕ → ℕ) (λn.n) (λn.λan.λm. suc (an m)) @@ -14,10 +11,10 @@ let ap : Π (A : Type) Π (B : Type) Π (f : A → B) let add_id_r : Π (n : ℕ) Id ℕ n (add n 0) ≔ ℕ-ind (λn. Id ℕ n (add n 0)) (refl ℕ 0) - (λn.λp. ap ℕ ℕ sucf n (add n 0) p) + (λn.λp. ap ℕ ℕ (λm. suc m) n (add n 0) p) let add_assoc : Π (n : ℕ) Π (m : ℕ) Π (p : ℕ) Id ℕ (add (add n m) p) (add n (add m p)) ≔ ℕ-ind (λn. Π (m : ℕ) Π (p : ℕ) Id ℕ (add (add n m) p) (add n (add m p))) (λm.λp. refl ℕ (add m p)) - (λn.λpn.λm.λp. ap ℕ ℕ sucf (add (add n m) p) (add n (add m p)) (pn m p)) + (λn.λpn.λm.λp. ap ℕ ℕ (λm. suc m) (add (add n m) p) (add n (add m p)) (pn m p))