nat literals and comments in parser

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

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
 
 

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)) ?)))
+-}

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))

tests/makefile

@@ -0,0 +1,3 @@
+phony: test
+test:
+	@make -C .. test

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))