diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 61635b7..fed340c 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -61,6 +61,9 @@ isTyCon (Enum {}) = True isTyCon (Tag {}) = False isTyCon (Eq {}) = True isTyCon (DLam {}) = False +isTyCon Nat = True +isTyCon Zero = False +isTyCon (Succ {}) = False isTyCon (E {}) = True isTyCon (CloT {}) = False isTyCon (DCloT {}) = False @@ -79,6 +82,8 @@ sameTyCon (Enum {}) (Enum {}) = True sameTyCon (Enum {}) _ = False sameTyCon (Eq {}) (Eq {}) = True sameTyCon (Eq {}) _ = False +sameTyCon Nat Nat = True +sameTyCon Nat _ = False sameTyCon (E {}) (E {}) = True sameTyCon (E {}) _ = False @@ -107,6 +112,9 @@ parameters (defs : Definitions' q g) Tag {} => pure False Eq {} => pure True DLam {} => pure False + Nat => pure False + Zero => pure False + Succ {} => pure False E (s :# _) => isSubSing s E _ => pure False @@ -218,6 +226,31 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)} -- Γ ⊢ e = f : Eq [i ⇒ A] s t pure () + compare0' ctx Nat s t = local {mode := Equal} $ + case (s, t) of + -- --------------- + -- Γ ⊢ 0 = 0 : ℕ + (Zero, Zero) => pure () + + -- Γ ⊢ m = n : ℕ + -- ------------------------- + -- Γ ⊢ succ m = succ n : ℕ + (Succ m, Succ n) => compare0 ctx Nat m n + + (E e, E f) => Elim.compare0 ctx e f + + (Zero, Succ _) => clashT ctx Nat s t + (Zero, E _) => clashT ctx Nat s t + (Succ _, Zero) => clashT ctx Nat s t + (Succ _, E _) => clashT ctx Nat s t + (E _, Zero) => clashT ctx Nat s t + (E _, Succ _) => clashT ctx Nat s t + + (Zero, t) => wrongType ctx Nat t + (Succ _, t) => wrongType ctx Nat t + (E _, t) => wrongType ctx Nat t + (s, _) => wrongType ctx Nat s + compare0' ctx ty@(E _) s t = do -- a neutral type can only be inhabited by neutral values -- e.g. an abstract value in an abstract type, bound variables, … @@ -290,6 +323,11 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)} -- a runtime coercion unless (tags1 == tags2) $ clashTy ctx s t + compareType' ctx Nat Nat = + -- ------------ + -- Γ ⊢ ℕ <: ℕ + pure () + compareType' ctx (E e) (E f) = do -- no fanciness needed here cos anything other than a neutral -- has been inlined by whnf @@ -311,6 +349,7 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)} pure $ sub1 res (s :# arg) computeElimType ctx (CasePair {pair, ret, _}) _ = pure $ sub1 ret pair computeElimType ctx (CaseEnum {tag, ret, _}) _ = pure $ sub1 ret tag + computeElimType ctx (CaseNat {nat, ret, _}) _ = pure $ sub1 ret nat computeElimType ctx (f :% p) ne = do (ty, _, _) <- expectEqE defs ctx !(computeElimType ctx f (noOr1 ne)) pure $ dsub1 ty p @@ -401,6 +440,21 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)} Nothing => throwError $ TagNotIn t (fromList $ keys arms) compare0' ctx e@(CaseEnum {}) f _ _ = clashE ctx e f + compare0' ctx (CaseNat epi epi' e eret ezer esuc) + (CaseNat fpi fpi' f fret fzer fsuc) ne nf = + local {mode := Equal} $ do + compare0 ctx e f + ety <- computeElimType ctx e (noOr1 ne) + compareType (extendTy zero eret.name ety ctx) eret.term fret.term + compare0 ctx (sub1 eret (Zero :# Nat)) ezer fzer + let [< p, ih] = esuc.names + compare0 (extendTyN [< (epi, p, Nat), (epi', ih, eret.term)] ctx) + (weakT eret.term) + esuc.term fsuc.term + expectEqualQ epi fpi + expectEqualQ epi' fpi' + compare0' ctx e@(CaseNat {}) f _ _ = clashE ctx e f + compare0' ctx (s :# a) (t :# b) _ _ = Term.compare0 ctx !(bigger a b) s t where diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 4949aeb..16f976b 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/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 diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index 89484f9..6eb86ac 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/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#", diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index 015cd9a..605d50f 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/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) diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index 8d4f81b..20345c6 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/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 => diff --git a/lib/Quox/Reduce.idr b/lib/Quox/Reduce.idr index d4e34ad..e52a0f8 100644 --- a/lib/Quox/Reduce.idr +++ b/lib/Quox/Reduce.idr @@ -66,6 +66,12 @@ isTagHead : Elim {} -> Bool isTagHead (Tag t :# Enum _) = True isTagHead _ = False +public export %inline +isNatHead : Elim {} -> Bool +isNatHead (Zero :# Nat) = True +isNatHead (Succ n :# Nat) = True +isNatHead _ = False + public export %inline isE : Term {} -> Bool isE (E _) = True @@ -89,6 +95,8 @@ mutual isRedexE defs pair || isPairHead pair isRedexE defs (CaseEnum {tag, _}) = isRedexE defs tag || isTagHead tag + isRedexE defs (CaseNat {nat, _}) = + isRedexE defs nat || isNatHead nat isRedexE defs (f :% _) = isRedexE defs f || isDLamHead f isRedexE defs (t :# a) = @@ -148,6 +156,21 @@ mutual Right nt => pure $ Element (CaseEnum pi tag ret arms) $ tagnf `orNo` nt + whnf defs (CaseNat pi piIH nat ret zer suc) = do + Element nat natnf <- whnf defs nat + case nchoose $ isNatHead nat of + Left _ => + let ty = sub1 ret nat in + case nat of + Zero :# Nat => whnf defs (zer :# ty) + Succ n :# Nat => + let nn = n :# Nat + tm = subN suc [nn, CaseNat pi piIH nn ret zer suc] + in + whnf defs $ tm :# ty + Right nn => + pure $ Element (CaseNat pi piIH nat ret zer suc) $ natnf `orNo` nn + whnf defs (f :% p) = do Element f fnf <- whnf defs f case nchoose $ isDLamHead f of @@ -181,6 +204,9 @@ mutual whnf _ t@(Tag {}) = pure $ nred t whnf _ t@(Eq {}) = pure $ nred t whnf _ t@(DLam {}) = pure $ nred t + whnf _ Nat = pure $ nred Nat + whnf _ Zero = pure $ nred Zero + whnf _ t@(Succ {}) = pure $ nred t whnf defs (E e) = do Element e enf <- whnf defs e diff --git a/lib/Quox/Syntax/Term/Base.idr b/lib/Quox/Syntax/Term/Base.idr index f3c43a4..1929fb4 100644 --- a/lib/Quox/Syntax/Term/Base.idr +++ b/lib/Quox/Syntax/Term/Base.idr @@ -75,6 +75,12 @@ mutual ||| equality term DLam : (body : DScopeTerm q d n) -> Term q d n + ||| natural numbers (temporary until 𝐖 gets added) + Nat : Term q d n + -- [todo] can these be elims? + Zero : Term q d n + Succ : (p : Term q d n) -> Term q d n + ||| elimination E : (e : Elim q d n) -> Term q d n @@ -111,6 +117,13 @@ mutual (arms : CaseEnumArms q d n) -> Elim q d n + ||| nat matching + CaseNat : (qty, qtyIH : q) -> (nat : Elim q d n) -> + (ret : ScopeTerm q d n) -> + (zero : Term q d n) -> + (succ : ScopeTermN 2 q d n) -> + Elim q d n + ||| dim application (:%) : (fun : Elim q d n) -> (arg : Dim d) -> Elim q d n diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index fdafa58..c1e4750 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -11,8 +11,8 @@ import Data.Vect %default total -private %inline -typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD : +export %inline +typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD : Pretty.HasEnv m => m (Doc HL) typeD = hlF Syntax $ ifUnicode "★" "Type" arrowD = hlF Syntax $ ifUnicode "→" "->" @@ -22,9 +22,10 @@ lamD = hlF Syntax $ ifUnicode "λ" "fun" eqndD = hlF Syntax $ ifUnicode "≡" "==" dlamD = hlF Syntax $ ifUnicode "δ" "dfun" annD = hlF Syntax $ ifUnicode "∷" "::" +natD = hlF Syntax $ ifUnicode "ℕ" "Nat" -private %inline -eqD, colonD, commaD, caseD, returnD, ofD, dotD : Doc HL +export %inline +eqD, colonD, commaD, caseD, returnD, ofD, dotD, zeroD, succD : Doc HL eqD = hl Syntax "Eq" colonD = hl Syntax ":" commaD = hl Syntax "," @@ -32,6 +33,8 @@ caseD = hl Syntax "case" ofD = hl Syntax "of" returnD = hl Syntax "return" dotD = hl Delim "." +zeroD = hl Syntax "zero" +succD = hl Syntax "succ" export @@ -157,6 +160,16 @@ export prettyTagBare : TagVal -> Doc HL prettyTagBare t = hl Tag $ quoteTag t +export +toNatLit : Term q d n -> Maybe Nat +toNatLit Zero = Just 0 +toNatLit (Succ n) = [|S $ toNatLit n|] +toNatLit _ = Nothing + +private +eterm : Term q d n -> Exists (Term q d) +eterm = Evidence n + parameters (showSubsts : Bool) mutual @@ -201,6 +214,14 @@ parameters (showSubsts : Bool) prettyM (DLam (S i t)) = let GotDLams {names, body, _} = getDLams' i t.term Refl in prettyLams (Just !dlamD) D (toSnocList' names) body + prettyM Nat = natD + prettyM Zero = pure $ hl Syntax "0" + prettyM (Succ n) = + case toNatLit n of + Just n => pure $ hl Syntax $ pretty $ S n + Nothing => do + n <- withPrec Arg $ prettyM n + parensIfM App $ succD <++> n prettyM (E e) = prettyM e prettyM (CloT s th) = if showSubsts then @@ -231,6 +252,14 @@ parameters (showSubsts : Bool) prettyM (CaseEnum pi t (S [< r] ret) arms) = prettyCase pi t r ret.term [([<], prettyTag t, b) | (t, b) <- SortedMap.toList arms] + prettyM (CaseNat pi pi' nat (S [< r] ret) zer (S [< s, ih] suc)) = + prettyCase pi nat r ret.term + [([<], zeroD, eterm zer), + ([< s, ih], !succPat, eterm suc.term)] + where + succPat : m (Doc HL) + succPat = pure $ + hsep [succD, !(pretty0M s), bracks !(pretty0M $ MkWithQty pi' ih)] prettyM (e :% d) = let GotDArgs {fun, args, _} = getDArgs' e [d] in prettyApps (Just "@") fun args diff --git a/lib/Quox/Syntax/Term/Subst.idr b/lib/Quox/Syntax/Term/Subst.idr index c62de69..49e4211 100644 --- a/lib/Quox/Syntax/Term/Subst.idr +++ b/lib/Quox/Syntax/Term/Subst.idr @@ -268,6 +268,9 @@ mutual nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) pushSubstsWith th ph (DLam body) = nclo $ DLam (body // th // ph) + pushSubstsWith _ _ Nat = nclo Nat + pushSubstsWith _ _ Zero = nclo Zero + pushSubstsWith th ph (Succ n) = nclo $ Succ $ n // th // ph pushSubstsWith th ph (E e) = let Element e nc = pushSubstsWith th ph e in nclo $ E e pushSubstsWith th ph (CloT s ps) = @@ -291,6 +294,9 @@ mutual pushSubstsWith th ph (CaseEnum pi t r arms) = nclo $ CaseEnum pi (t // th // ph) (r // th // ph) (map (\b => b // th // ph) arms) + pushSubstsWith th ph (CaseNat pi pi' n r z s) = + nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph) + (z // th // ph) (s // th // ph) pushSubstsWith th ph (f :% d) = nclo $ (f // th // ph) :% (d // th) pushSubstsWith th ph (s :# a) = diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index 1b135b8..f5d6235 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -166,6 +166,16 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m} -- then Ψ | Γ ⊢ σ · (δ i ⇒ t) ⇐ Eq [i ⇒ A] l r ⊳ Σ pure qout + check' ctx sg Nat ty = toCheckType ctx sg Nat ty + + check' ctx sg Zero ty = do + expectNat !ask ctx ty + pure $ zeroFor ctx + + check' ctx sg (Succ n) ty = do + expectNat !ask ctx ty + checkC ctx sg n Nat + check' ctx sg (E e) ty = do -- if Ψ | Γ ⊢ σ · e ⇒ A' ⊳ Σ infres <- inferC ctx sg e @@ -229,6 +239,10 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m} checkType' ctx t@(DLam {}) u = throwError $ NotType ctx t + checkType' ctx Nat u = pure () + checkType' ctx Zero u = throwError $ NotType ctx Zero + checkType' ctx t@(Succ _) u = throwError $ NotType ctx t + checkType' ctx (E e) u = do -- if Ψ | Γ ⊢ σ · e ⇒ A' ⊳ Σ infres <- inferC ctx szero e @@ -328,6 +342,36 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m} else throwError $ BadCaseQtys ctx $ map (\(qs, t, s) => (qs, Tag t, s)) lst + infer' ctx sg (CaseNat pi pi' n ret zer suc) = do + -- if 1 ≤ π + expectCompatQ one pi + -- if Ψ | Γ ⊢ σ · n ⇒ ℕ ⊳ Σn + nres <- inferC ctx sg n + expectNat !ask ctx nres.type + -- if Ψ | Γ, n : ℕ ⊢₀ A ⇐ Type + checkTypeC (extendTy zero ret.name Nat ctx) ret.term Nothing + -- if Ψ | Γ ⊢ σ · zer ⇐ A[0 ∷ ℕ/n] ⊳ Σz + zerout <- checkC ctx sg zer (sub1 ret (Zero :# Nat)) + -- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ₁.p, ρ₂.ih + -- with Σz = Σs, (ρ₁ + ρ₂) ≤ πσ + let [< p, ih] = suc.names + pisg = pi * sg.fst + sucCtx = extendTyN [< (pisg, p, Nat), (pi', ih, ret.term)] ctx + sucType = substCaseNatRet ret + sucout :< qp :< qih <- checkC sucCtx sg suc.term sucType + unless (zerout == sucout) $ do + let sucp = Succ $ FT $ unq p + suc = subN suc [F $ unq ih, F $ unq p] + throwError $ BadCaseQtys ctx [(zerout, Zero, zer), (sucout, sucp, suc)] + expectCompatQ qih pi' + -- [fixme] better error here + expectCompatQ (qp + qih) pisg + -- then Ψ | Γ ⊢ case ⋯ ⇒ A[n] ⊳ πΣn + Σz + pure $ InfRes { + type = sub1 ret n, + qout = pi * nres.qout + zerout + } + infer' ctx sg (fun :% dim) = do -- if Ψ | Γ ⊢ σ · f ⇒ Eq [i ⇒ A] l r ⊳ Σ InfRes {type, qout} <- inferC ctx sg fun diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index b0a0c71..ab7fa76 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -44,6 +44,10 @@ substCasePairRet dty retty = let arg = Pair (BVT 0) (BVT 1) :# (dty // fromNat 2) in retty.term // (arg ::: shift 2) +public export +substCaseNatRet : ScopeTerm q d n -> Term q d (2 + n) +substCaseNatRet retty = retty.term // (Succ (BVT 1) :# Nat ::: shift 2) + parameters {auto _ : HasErr q m} (defs : Definitions' q _) export covering %inline @@ -83,6 +87,12 @@ parameters {auto _ : HasErr q m} (defs : Definitions' q _) Eq {ty, l, r, _} => pure (ty, l, r) _ => throwError $ ExpectedEq ctx (s // th) + export covering %inline + expectNat_ : Term q d2 n -> m () + expectNat_ s = case fst !(whnfT s) of + Nat => pure () + _ => throwError $ ExpectedNat ctx (s // th) + -- [fixme] refactor this stuff @@ -117,6 +127,12 @@ parameters {auto _ : HasErr q m} (defs : Definitions' q _) let Val d = ctx.dimLen; Val n = ctx.termLen in expectEq_ ctx id + export covering %inline + expectNat : Term q d n -> m () + expectNat = + let Val d = ctx.dimLen; Val n = ctx.termLen in + expectNat_ ctx id + parameters (ctx : EqContext q n) export covering %inline @@ -148,3 +164,9 @@ parameters {auto _ : HasErr q m} (defs : Definitions' q _) expectEqE t = let Val n = ctx.termLen in expectEq_ (toTyContext ctx) (shift0 ctx.dimLen) t + + export covering %inline + expectNatE : Term q 0 n -> m () + expectNatE t = + let Val n = ctx.termLen in + expectNat_ (toTyContext ctx) (shift0 ctx.dimLen) t diff --git a/lib/Quox/Typing/Error.idr b/lib/Quox/Typing/Error.idr index cdffd1b..930ab8d 100644 --- a/lib/Quox/Typing/Error.idr +++ b/lib/Quox/Typing/Error.idr @@ -17,6 +17,7 @@ data Error q | ExpectedSig (TyContext q d n) (Term q d n) | ExpectedEnum (TyContext q d n) (Term q d n) | ExpectedEq (TyContext q d n) (Term q d n) +| ExpectedNat (TyContext q d n) (Term q d n) | BadUniverse Universe Universe | TagNotIn TagVal (SortedSet TagVal) | BadCaseQtys (TyContext q d n) (List (QOutput q n, Term q d n, Term q d n)) @@ -165,7 +166,7 @@ parameters {auto _ : (Eq q, IsQty q, PrettyHL q)} (unicode : Bool) private dissectCaseQtys : TyContext q d n -> - NContext n' -> List (QOutput q n', Term q d n, z) -> + NContext n' -> List (QOutput q n', y, z) -> List (Doc HL) dissectCaseQtys ctx [<] arms = [] dissectCaseQtys ctx (tel :< x) arms = @@ -206,6 +207,9 @@ parameters {auto _ : (Eq q, IsQty q, PrettyHL q)} (unicode : Bool) ExpectedEq ctx s => sep ["expected an equality type, but got", termt ctx s] + ExpectedNat ctx s => + sep ["expected the type ℕ, but got", termt ctx s] + BadUniverse k l => sep ["the universe level", prettyUniverse k, "is not strictly less than", prettyUniverse l] diff --git a/tests/TermImpls.idr b/tests/TermImpls.idr index 13abf76..090cede 100644 --- a/tests/TermImpls.idr +++ b/tests/TermImpls.idr @@ -51,6 +51,15 @@ mutual DLam body1 == DLam body2 = body1.term == body2.term DLam {} == _ = False + Nat == Nat = True + Nat == _ = False + + Zero == Zero = True + Zero == _ = False + + Succ m == Succ n = m == n + Succ _ == _ = False + E e == E f = e == f E _ == _ = False @@ -85,6 +94,11 @@ mutual q1 == q2 && t1 == t2 && r1.term == r2.term && a1 == a2 CaseEnum {} == _ = False + CaseNat q1 q1' n1 r1 z1 s1 == CaseNat q2 q2' n2 r2 z2 s2 = + q1 == q2 && q1' == q2' && n1 == n2 && + r1.term == r2.term && z1 == z2 && s1.term == s2.term + CaseNat {} == _ = False + (fun1 :% dim1) == (fun2 :% dim2) = fun1 == fun2 && dim1 == dim2 (_ :% _) == _ = False diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index c3e460a..0a2338d 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -224,6 +224,15 @@ tests = "parser" :- [ parseFails term "≡" ], + "naturals" :- [ + parsesAs term "ℕ" Nat, + parsesAs term "Nat" Nat, + parsesAs term "zero" Zero, + parsesAs term "succ n" (Succ $ V "n"), + parsesAs term "3" (Succ (Succ (Succ Zero)) :# Nat), + parseFails term "succ" + ], + "case" :- [ parsesAs term "case1 f s return x ⇒ A x of { (l, r) ⇒ add l r }" $ @@ -251,7 +260,15 @@ tests = "parser" :- [ parsesAs term "caseω t return A of {}" $ Case Any (V "t") (Nothing, V "A") (CaseEnum []), parsesAs term "case# t return A of {}" $ - Case Any (V "t") (Nothing, V "A") (CaseEnum []) + Case Any (V "t") (Nothing, V "A") (CaseEnum []), + parsesAs term "caseω n return A of { 0 ⇒ a; succ n' ⇒ b }" $ + Case Any (V "n") (Nothing, V "A") $ + CaseNat (V "a") (Just "n'", Zero, Nothing, V "b"), + parsesAs term "caseω n return ℕ of { succ _ [1.ih] ⇒ ih; zero ⇒ 0; }" $ + Case Any (V "n") (Nothing, Nat) $ + CaseNat (Zero :# Nat) (Nothing, One, Just "ih", V "ih"), + parseFails term "caseω n return A of { zero ⇒ a }", + parseFails term "caseω n return ℕ of { succ ⇒ 5 }" ], "definitions" :- [ diff --git a/tests/Tests/Typechecker.idr b/tests/Tests/Typechecker.idr index 08cc0c4..977d99d 100644 --- a/tests/Tests/Typechecker.idr +++ b/tests/Tests/Typechecker.idr @@ -363,6 +363,18 @@ tests = "typechecker" :- [ check_ empty01 sone (Tag "a") (enum ["b", "c"]) ], + "enum matching" :- [ + testTC "ω.x : {tt} ⊢ 1 · case1 x return {tt} of { 'tt ⇒ 'tt } ⇒ {tt}" $ + inferAs (ctx [< ("x", enum ["tt"])]) sone + (CaseEnum One (BV 0) (SN (enum ["tt"])) $ + singleton "tt" (Tag "tt")) + (enum ["tt"]), + testTCFail "ω.x : {tt} ⊢ 1 · case1 x return {tt} of { 'ff ⇒ 'tt } ⇏" $ + infer_ (ctx [< ("x", enum ["tt"])]) sone + (CaseEnum One (BV 0) (SN (enum ["tt"])) $ + singleton "ff" (Tag "tt")) + ], + "equalities" :- [ testTC "1 · (δ i ⇒ a) ⇐ a ≡ a" $ check_ empty sone (DLam $ SN $ FT "a")