natural numbers

lib/Quox/Parser/FromParser.idr

@@ -14,6 +14,8 @@ import public Control.Monad.Reader
 import System.File
 import System.Path
 
+%hide Context.(<$>)
+%hide Context.(<*>)
 
 public export
 0 Defs : Type
@@ -118,6 +120,17 @@ mutual
         <*> fromPTermTScope ds ns [< r] ret
         <*> assert_total fromPTermEnumArms ds ns arms
 
+    Nat => pure Nat
+    Zero => pure Zero
+    Succ n => [|Succ $ fromPTermWith ds ns n|]
+
+    Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc)) =>
+      Prelude.map E $ Base.CaseNat pi pi'
+        <$> fromPTermElim ds ns nat
+        <*> fromPTermTScope ds ns [< r] ret
+        <*> fromPTermWith ds ns zer
+        <*> fromPTermTScope ds ns [< s, ih] suc
+
     Enum strs =>
       let set = SortedSet.fromList strs in
       if length strs == length (SortedSet.toList set) then

lib/Quox/Parser/Lexer.idr

@@ -195,6 +195,8 @@ reserved =
    Word "δ" `Or` Word "dfun",
    Word "ω" `Or` Sym "#",
    Sym "★" `Or` Word "Type",
+   Word "ℕ" `Or` Word "Nat",
+   Word1 "zero", Word1 "succ",
    Word1 "def",
    Word1 "def0",
    Word "defω" `Or` Word "def#",

lib/Quox/Parser/Parser.idr

@@ -116,6 +116,10 @@ qty = terminal "expecting quantity" $
   \case Nat 0 => Just Zero; Nat 1 => Just One; Reserved "ω" => Just Any
         _ => Nothing
 
+export
+zero : Grammar True ()
+zero = terminal "expecting 0" $ guard . (== Nat 0)
+
 
 public export
 AllReserved : List (a, String) -> Type
@@ -125,6 +129,7 @@ export
 symbols : (lst : List (a, String)) -> (0 _ : AllReserved lst) =>
           Grammar True a
 symbols []                 = fail "no symbols found"
+symbols [(x, str)]         = x <$ res str
 symbols ((x, str) :: rest) = x <$ res str <|> symbols rest
 
 export
@@ -185,11 +190,24 @@ mutual
   caseBody : Grammar True PCaseBody
   caseBody = braces $
         [|CasePair (pairPat <* darr) (term <* optSemi)|]
+    <|> CaseNat <$> zeroCase <* resC ";" <*> succCase <* optSemi
+    <|> flip CaseNat <$> succCase <* resC ";" <*> zeroCase <* optSemi
     <|> [|CaseEnum $ semiSep [|MkPair tag (darr *> term)|]|]
   where
     optSemi = optional $ res ";"
     pairPat = parens [|MkPair bname (resC "," *> bname)|]
 
+    zeroCase : Grammar True PTerm
+    zeroCase = (resC "zero" <|> zero) *> darr *> term
+
+    succCase : Grammar True (BName, PQty, BName, PTerm)
+    succCase = do
+      resC "succ"
+      n   <- bname
+      ih  <- option (Zero, Nothing) $ bracks [|MkPair qty (resC "." *> bname)|]
+      rhs <- darr *> term
+      pure $ (n, fst ih, snd ih, rhs)
+
   private covering
   bindTerm : Grammar True PTerm
   bindTerm = pi <|> sigma
@@ -199,7 +217,7 @@ mutual
     pi, sigma : Grammar True PTerm
     pi = [|makePi (qty <* res ".") domain (resC "→" *> term)|]
     where
-      makePi : Three -> (BName, PTerm) -> PTerm -> PTerm
+      makePi : PQty -> (BName, PTerm) -> PTerm -> PTerm
       makePi q (x, s) t = Pi q x s t
       domain = binderHead <|> [|(Nothing,) aTerm|]
 
@@ -226,8 +244,9 @@ mutual
 
   private covering
   appTerm : Grammar True PTerm
-  appTerm = resC "★"  *> [|TYPE nat|]
-        <|> resC "Eq" *> [|Eq (bracks optBinderTerm) aTerm aTerm|]
+  appTerm = resC "★"    *> [|TYPE nat|]
+        <|> resC "Eq"   *> [|Eq (bracks optBinderTerm) aTerm aTerm|]
+        <|> resC "succ" *> [|Succ aTerm|]
         <|> [|apply aTerm (many appArg)|]
   where
     data PArg = TermArg PTerm | DimArg PDim
@@ -245,9 +264,16 @@ mutual
   aTerm : Grammar True PTerm
   aTerm = [|Enum $ braces $ commaSep bareTag|]
       <|> [|TYPE universe|]
+      <|> Nat  <$ resC "ℕ"
+      <|> Zero <$ resC "zero"
+      <|> (nat <&> \n => fromNat n :# Nat)
       <|> [|V name|]
       <|> [|Tag tag|]
       <|> foldr1 Pair <$> parens (commaSep1 term)
+  where
+    fromNat : Nat -> PTerm
+    fromNat 0     = Zero
+    fromNat (S k) = Succ $ fromNat k
 
   private covering
   optBinderTerm : Grammar True (BName, PTerm)

lib/Quox/Parser/Syntax.idr

@@ -51,6 +51,9 @@ namespace PTerm
       | DLam BName PTerm
       | (:%) PTerm PDim
 
+      | Nat
+      | Zero | Succ PTerm
+
       | V PName
       | (:#) PTerm PTerm
     %name PTerm s, t
@@ -59,6 +62,7 @@ namespace PTerm
     data PCaseBody =
         CasePair (BName, BName) PTerm
       | CaseEnum (List (TagVal, PTerm))
+      | CaseNat PTerm (BName, PQty, BName, PTerm)
     %name PCaseBody body
 
 %runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]
@@ -143,6 +147,9 @@ mutual
            (toPTermWith ds ns l) (toPTermWith ds ns r)
       DLam (S [< i] body) =>
         DLam (Just $ show i) $ toPTermWith (ds :< baseStr i) ns body.term
+      Nat => Nat
+      Zero => Zero
+      Succ n => Succ $ toPTermWith ds ns n
       E e =>
         toPTermWith ds ns e
 
@@ -172,8 +179,14 @@ mutual
                 toPTermWith ds (ns :< baseStr x :< baseStr y) body.term)
       CaseEnum qty tag (S [< r] ret) arms =>
         Case qty (toPTermWith ds ns tag)
-             (Just $ show r, toPTermWith ds (ns :< baseStr r) ret.term)
+             (Just $ baseStr r, toPTermWith ds (ns :< baseStr r) ret.term)
              (CaseEnum $ mapSnd (toPTermWith ds ns) <$> SortedMap.toList arms)
+      CaseNat qtyNat qtyIH nat (S [< r] ret) zer (S [< p, ih] suc) =>
+        Case qtyNat (toPTermWith ds ns nat)
+             (Just $ baseStr r, toPTermWith ds (ns :< baseStr r) ret.term)
+             (CaseNat (toPTermWith ds ns zer)
+                      (Just $ baseStr p, qtyIH, Just $ baseStr ih,
+                       toPTermWith ds (ns :< baseStr p :< baseStr ih) suc.term))
       fun :% arg =>
         toPTermWith ds ns fun :% toPDimWith ds arg
       tm :# ty =>