diff --git a/examples/misc.quox b/examples/misc.quox index f6ba7d9..5ae7e76 100644 --- a/examples/misc.quox +++ b/examples/misc.quox @@ -33,4 +33,4 @@ def sym : 0.(A : ★₀) → 0.(x y : A) → 1.(x ≡ y : A) → y ≡ x : A = def trans : 0.(A : ★₀) → 0.(x y z : A) → ω.(x ≡ y : A) → ω.(y ≡ z : A) → x ≡ z : A = λ A x y z eq1 eq2 ⇒ δ 𝑖 ⇒ - comp [A] @0 @1 (eq1 @𝑖) @𝑖 { 0 _ ⇒ eq1 @0; 1 𝑗 ⇒ eq2 @𝑗 }; + comp [A] @0 @1 (eq1 @𝑖) @𝑖 { 0 _ ⇒ eq1 @0; 1 𝑗 ⇒ eq2 @0 }; diff --git a/exe/Main.idr b/exe/Main.idr index 4a1ba98..8014772 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -20,9 +20,10 @@ main : IO () main = do seen <- newIORef SortedSet.empty defs <- newIORef SortedMap.empty + suf <- newIORef $ the Nat 0 for_ (drop 1 !getArgs) $ \file => do putStrLn "checking \{file}" - Right res <- fromParserIO ["."] seen defs $ loadProcessFile file + Right res <- fromParserIO ["."] seen suf defs $ loadProcessFile noLoc file | Left err => die $ prettyError True True err for_ res $ \(name, def) => do putDoc $ map termHL $ nest 2 $ diff --git a/lib/Quox/Context.idr b/lib/Quox/Context.idr index 683cf67..1b13dba 100644 --- a/lib/Quox/Context.idr +++ b/lib/Quox/Context.idr @@ -40,6 +40,10 @@ public export NContext : Nat -> Type NContext = Context' BaseName +public export +BContext : Nat -> Type +BContext = Context' BindName + public export unsnoc : Context tm (S n) -> (Context tm n, tm n) @@ -183,6 +187,10 @@ parameters {auto _ : Applicative f} traverse f [<] = pure [<] traverse f (tel :< x) = [|traverse f tel :< f x|] + export %inline + traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to) + traverse' f = traverse f + infixl 3 `app` ||| like `(<*>)` but with effects export @@ -197,6 +205,7 @@ parameters {auto _ : Applicative f} sequence : Telescope (f . tm) from to -> f (Telescope tm from to) sequence = traverse id + parameters {0 tm1, tm2 : Nat -> Type} (f : forall n. tm1 n -> tm2 n) export %inline @@ -207,6 +216,8 @@ parameters {0 tm1, tm2 : Nat -> Type} (<$>) : Telescope tm1 from to -> Telescope tm2 from to (<$>) = map + + export %inline (<*>) : Telescope (\n => tm1 n -> tm2 n) from to -> Telescope tm1 from to -> Telescope tm2 from to @@ -311,3 +322,9 @@ export %inline export %inline (forall n. PrettyHL (tm n)) => PrettyHL (Telescope tm from to) where prettyM tel = separate (hl Delim ";") <$> traverse prettyM (toList tel) + + +namespace BContext + export + toNames : BContext n -> SnocList BaseName + toNames = foldl (\xs, x => xs :< x.name) [<] diff --git a/lib/Quox/Definition.idr b/lib/Quox/Definition.idr index 45dd3e7..2642b29 100644 --- a/lib/Quox/Definition.idr +++ b/lib/Quox/Definition.idr @@ -3,6 +3,7 @@ module Quox.Definition import public Quox.No import public Quox.Syntax import public Data.SortedMap +import public Quox.Loc import Control.Eff import Decidable.Decidable @@ -25,14 +26,18 @@ record Definition where qty : GQty type0 : Term 0 0 body0 : DefBody + loc_ : Loc public export %inline -mkPostulate : GQty -> (type0 : Term 0 0) -> Definition -mkPostulate qty type0 = MkDef {qty, type0, body0 = Postulate} +mkPostulate : GQty -> (type0 : Term 0 0) -> Loc -> Definition +mkPostulate qty type0 loc_ = MkDef {qty, type0, body0 = Postulate, loc_} public export %inline -mkDef : GQty -> (type0, term0 : Term 0 0) -> Definition -mkDef qty type0 term0 = MkDef {qty, type0, body0 = Concrete term0} +mkDef : GQty -> (type0, term0 : Term 0 0) -> Loc -> Definition +mkDef qty type0 term0 loc_ = MkDef {qty, type0, body0 = Concrete term0, loc_} + +export Located Definition where def.loc = def.loc_ +export Relocatable Definition where setLoc loc = {loc_ := loc} parameters {d, n : Nat} @@ -46,7 +51,7 @@ parameters {d, n : Nat} public export %inline toElim : Definition -> Maybe $ Elim d n - toElim def = pure $ !def.term :# def.type + toElim def = pure $ Ann !def.term def.type def.loc public export %inline @@ -62,9 +67,13 @@ Definitions : Type Definitions = SortedMap Name Definition public export -0 DefsReader : Type -> Type +DefsReader : Type -> Type DefsReader = ReaderL DEFS Definitions +public export +DefsState : Type -> Type +DefsState = StateL DEFS Definitions + export defs : Has DefsReader fs => Eff fs Definitions defs = askAt DEFS diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 2db3e83..50d2d01 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -9,20 +9,41 @@ import Quox.EffExtra public export -0 EqModeState : Type -> Type +EqModeState : Type -> Type EqModeState = State EqMode public export -0 EqualEff : List (Type -> Type) -EqualEff = [ErrorEff, EqModeState] +Equal : Type -> Type +Equal = Eff [ErrorEff, DefsReader, NameGen] public export -0 Equal : Type -> Type -Equal = Eff $ EqualEff +Equal_ : Type -> Type +Equal_ = Eff [ErrorEff, NameGen, EqModeState] export -runEqual : EqMode -> Equal a -> Either Error a -runEqual mode = extract . runExcept . evalState mode +runEqualWith_ : EqMode -> NameSuf -> Equal_ a -> (Either Error a, NameSuf) +runEqualWith_ mode suf act = + extract $ + runNameGenWith suf $ + runExcept $ + evalState mode act + +export +runEqual_ : EqMode -> Equal_ a -> Either Error a +runEqual_ mode act = fst $ runEqualWith_ mode 0 act + + +export +runEqualWith : NameSuf -> Definitions -> Equal a -> (Either Error a, NameSuf) +runEqualWith suf defs act = + extract $ + runStateAt GEN suf $ + runReaderAt DEFS defs $ + runExcept act + +export +runEqual : Definitions -> Equal a -> Either Error a +runEqual defs act = fst $ runEqualWith 0 defs act export %inline @@ -30,22 +51,22 @@ mode : Has EqModeState fs => Eff fs EqMode mode = get -parameters (ctx : EqContext n) +parameters (loc : Loc) (ctx : EqContext n) private %inline - clashT : Term 0 n -> Term 0 n -> Term 0 n -> Equal a - clashT ty s t = throw $ ClashT ctx !mode ty s t + clashT : Term 0 n -> Term 0 n -> Term 0 n -> Equal_ a + clashT ty s t = throw $ ClashT loc ctx !mode ty s t private %inline - clashTy : Term 0 n -> Term 0 n -> Equal a - clashTy s t = throw $ ClashTy ctx !mode s t + clashTy : Term 0 n -> Term 0 n -> Equal_ a + clashTy s t = throw $ ClashTy loc ctx !mode s t private %inline - clashE : Elim 0 n -> Elim 0 n -> Equal a - clashE e f = throw $ ClashE ctx !mode e f + clashE : Elim 0 n -> Elim 0 n -> Equal_ a + clashE e f = throw $ ClashE loc ctx !mode e f private %inline - wrongType : Term 0 n -> Term 0 n -> Equal a - wrongType ty s = throw $ WrongType ctx ty s + wrongType : Term 0 n -> Term 0 n -> Equal_ a + wrongType ty s = throw $ WrongType loc ctx ty s public export %inline @@ -62,8 +83,8 @@ sameTyCon (Enum {}) (Enum {}) = True sameTyCon (Enum {}) _ = False sameTyCon (Eq {}) (Eq {}) = True sameTyCon (Eq {}) _ = False -sameTyCon Nat Nat = True -sameTyCon Nat _ = False +sameTyCon (Nat {}) (Nat {}) = True +sameTyCon (Nat {}) _ = False sameTyCon (BOX {}) (BOX {}) = True sameTyCon (BOX {}) _ = False sameTyCon (E {}) (E {}) = True @@ -80,37 +101,39 @@ sameTyCon (E {}) _ = False ||| * an enum type is a subsingleton if it has zero or one tags. ||| * a box type is a subsingleton if its content is public export covering -isSubSing : Has ErrorEff fs => {n : Nat} -> - Definitions -> EqContext n -> Term 0 n -> Eff fs Bool +isSubSing : {n : Nat} -> Definitions -> EqContext n -> Term 0 n -> Equal_ Bool isSubSing defs ctx ty0 = do - Element ty0 nc <- whnf defs ctx ty0 + Element ty0 nc <- whnf defs ctx ty0.loc ty0 case ty0 of - TYPE _ => pure False - Pi _ arg res => isSubSing defs (extendTy Zero res.name arg ctx) res.term - Sig fst snd => isSubSing defs ctx fst `andM` - isSubSing defs (extendTy Zero snd.name fst ctx) snd.term - Enum tags => pure $ length (SortedSet.toList tags) <= 1 - Eq {} => pure True - Nat => pure False - BOX _ ty => isSubSing defs ctx ty - E (s :# _) => isSubSing defs ctx s - E _ => pure False - Lam _ => pure False - Pair _ _ => pure False - Tag _ => pure False - DLam _ => pure False - Zero => pure False - Succ _ => pure False - Box _ => pure False + TYPE {} => pure False + Pi {arg, res, _} => + isSubSing defs (extendTy Zero res.name arg ctx) res.term + Sig {fst, snd, _} => + isSubSing defs ctx fst `andM` + isSubSing defs (extendTy Zero snd.name fst ctx) snd.term + Enum {cases, _} => + pure $ length (SortedSet.toList cases) <= 1 + Eq {} => pure True + Nat {} => pure False + BOX {ty, _} => isSubSing defs ctx ty + E (Ann {tm, _}) => isSubSing defs ctx tm + E _ => pure False + Lam {} => pure False + Pair {} => pure False + Tag {} => pure False + DLam {} => pure False + Zero {} => pure False + Succ {} => pure False + Box {} => pure False export ensureTyCon : Has ErrorEff fs => - (ctx : EqContext n) -> (t : Term 0 n) -> + (loc : Loc) -> (ctx : EqContext n) -> (t : Term 0 n) -> Eff fs (So (isTyConE t)) -ensureTyCon ctx t = case nchoose $ isTyConE t of +ensureTyCon loc ctx t = case nchoose $ isTyConE t of Left y => pure y - Right n => throw $ NotType (toTyContext ctx) (t // shift0 ctx.dimLen) + Right n => throw $ NotType loc (toTyContext ctx) (t // shift0 ctx.dimLen) ||| performs the minimum work required to recompute the type of an elim. ||| @@ -118,10 +141,10 @@ ensureTyCon ctx t = case nchoose $ isTyConE t of private covering computeElimTypeE : (defs : Definitions) -> EqContext n -> (e : Elim 0 n) -> (0 ne : NotRedex defs e) => - Equal (Term 0 n) + Equal_ (Term 0 n) computeElimTypeE defs ectx e = let Val n = ectx.termLen in - rethrow $ computeElimType defs (toWhnfContext ectx) e + lift $ computeElimType defs (toWhnfContext ectx) e parameters (defs : Definitions) mutual @@ -131,55 +154,56 @@ parameters (defs : Definitions) ||| ||| ⚠ **assumes that `s`, `t` have already been checked against `ty`**. ⚠ export covering %inline - compare0 : EqContext n -> (ty, s, t : Term 0 n) -> Equal () + compare0 : EqContext n -> (ty, s, t : Term 0 n) -> Equal_ () compare0 ctx ty s t = wrapErr (WhileComparingT ctx !mode ty s t) $ do let Val n = ctx.termLen - Element ty _ <- whnf defs ctx ty - Element s _ <- whnf defs ctx s - Element t _ <- whnf defs ctx t - tty <- ensureTyCon ctx ty - compare0' ctx ty s t + Element ty' _ <- whnf defs ctx ty.loc ty + Element s' _ <- whnf defs ctx s.loc s + Element t' _ <- whnf defs ctx t.loc t + tty <- ensureTyCon ty.loc ctx ty' + compare0' ctx ty' s' t' ||| converts an elim "Γ ⊢ e" to "Γ, x ⊢ e x", for comparing with ||| a lambda "Γ ⊢ λx ⇒ t" that has been converted to "Γ, x ⊢ t". private %inline toLamBody : Elim d n -> Term d (S n) - toLamBody e = E $ weakE 1 e :@ BVT 0 + toLamBody e = E $ App (weakE 1 e) (BVT 0 e.loc) e.loc private covering compare0' : EqContext n -> (ty, s, t : Term 0 n) -> (0 _ : NotRedex defs ty) => (0 _ : So (isTyConE ty)) => (0 _ : NotRedex defs s) => (0 _ : NotRedex defs t) => - Equal () - compare0' ctx (TYPE _) s t = compareType ctx s t + Equal_ () + compare0' ctx (TYPE {}) s t = compareType ctx s t - compare0' ctx ty@(Pi {qty, arg, res}) s t {n} = local_ Equal $ + compare0' ctx ty@(Pi {qty, arg, res, _}) s t {n} = local_ Equal $ case (s, t) of -- Γ, x : A ⊢ s = t : B -- ------------------------------------------- -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) : (π·x : A) → B - (Lam b1, Lam b2) => compare0 ctx' res.term b1.term b2.term + (Lam b1 {}, Lam b2 {}) => + compare0 ctx' res.term b1.term b2.term -- Γ, x : A ⊢ s = e x : B -- ----------------------------------- -- Γ ⊢ (λ x ⇒ s) = e : (π·x : A) → B - (E e, Lam b) => eta e b - (Lam b, E e) => eta e b + (E e, Lam b {}) => eta s.loc e b + (Lam b {}, E e) => eta s.loc e b (E e, E f) => Elim.compare0 ctx e f - (Lam _, t) => wrongType ctx ty t - (E _, t) => wrongType ctx ty t - (s, _) => wrongType ctx ty s + (Lam {}, t) => wrongType t.loc ctx ty t + (E _, t) => wrongType t.loc ctx ty t + (s, _) => wrongType s.loc ctx ty s where ctx' : EqContext (S n) ctx' = extendTy qty res.name arg ctx - eta : Elim 0 n -> ScopeTerm 0 n -> Equal () - eta e (S _ (Y b)) = compare0 ctx' res.term (toLamBody e) b - eta e (S _ (N _)) = clashT ctx ty s t + eta : Loc -> Elim 0 n -> ScopeTerm 0 n -> Equal_ () + eta _ e (S _ (Y b)) = compare0 ctx' res.term (toLamBody e) b + eta loc e (S _ (N _)) = clashT loc ctx ty s t compare0' ctx ty@(Sig {fst, snd, _}) s t = local_ Equal $ case (s, t) of @@ -188,34 +212,35 @@ parameters (defs : Definitions) -- Γ ⊢ (s₁, t₁) = (s₂,t₂) : (x : A) × B -- -- [todo] η for π ≥ 0 maybe - (Pair sFst sSnd, Pair tFst tSnd) => do + (Pair sFst sSnd {}, Pair tFst tSnd {}) => do compare0 ctx fst sFst tFst - compare0 ctx (sub1 snd (sFst :# fst)) sSnd tSnd + compare0 ctx (sub1 snd (Ann sFst fst fst.loc)) sSnd tSnd (E e, E f) => Elim.compare0 ctx e f - (Pair {}, E _) => clashT ctx ty s t - (E _, Pair {}) => clashT ctx ty s t + (Pair {}, E _) => clashT s.loc ctx ty s t + (E _, Pair {}) => clashT s.loc ctx ty s t - (Pair {}, t) => wrongType ctx ty t - (E _, t) => wrongType ctx ty t - (s, _) => wrongType ctx ty s + (Pair {}, t) => wrongType t.loc ctx ty t + (E _, t) => wrongType t.loc ctx ty t + (s, _) => wrongType s.loc ctx ty s - compare0' ctx ty@(Enum tags) s t = local_ Equal $ + compare0' ctx ty@(Enum {}) s t = local_ Equal $ case (s, t) of -- -------------------- -- Γ ⊢ `t = `t : {ts} -- -- t ∈ ts is in the typechecker, not here, ofc - (Tag t1, Tag t2) => unless (t1 == t2) $ clashT ctx ty s t - (E e, E f) => Elim.compare0 ctx e f + (Tag t1 {}, Tag t2 {}) => + unless (t1 == t2) $ clashT s.loc ctx ty s t + (E e, E f) => Elim.compare0 ctx e f - (Tag _, E _) => clashT ctx ty s t - (E _, Tag _) => clashT ctx ty s t + (Tag {}, E _) => clashT s.loc ctx ty s t + (E _, Tag {}) => clashT s.loc ctx ty s t - (Tag _, t) => wrongType ctx ty t - (E _, t) => wrongType ctx ty t - (s, _) => wrongType ctx ty s + (Tag {}, t) => wrongType t.loc ctx ty t + (E _, t) => wrongType t.loc ctx ty t + (s, _) => wrongType s.loc ctx ty s compare0' _ (Eq {}) _ _ = -- ✨ uip ✨ @@ -224,84 +249,85 @@ parameters (defs : Definitions) -- Γ ⊢ e = f : Eq [i ⇒ A] s t pure () - compare0' ctx Nat s t = local_ Equal $ + compare0' ctx nat@(Nat {}) s t = local_ Equal $ case (s, t) of -- --------------- -- Γ ⊢ 0 = 0 : ℕ - (Zero, Zero) => pure () + (Zero {}, Zero {}) => pure () - -- Γ ⊢ m = n : ℕ + -- Γ ⊢ s = t : ℕ -- ------------------------- - -- Γ ⊢ succ m = succ n : ℕ - (Succ m, Succ n) => compare0 ctx Nat m n + -- Γ ⊢ succ s = succ t : ℕ + (Succ s' {}, Succ t' {}) => compare0 ctx nat s' t' (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 {}, Succ {}) => clashT s.loc ctx nat s t + (Zero {}, E _) => clashT s.loc ctx nat s t + (Succ {}, Zero {}) => clashT s.loc ctx nat s t + (Succ {}, E _) => clashT s.loc ctx nat s t + (E _, Zero {}) => clashT s.loc ctx nat s t + (E _, Succ {}) => clashT s.loc 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 + (Zero {}, t) => wrongType t.loc ctx nat t + (Succ {}, t) => wrongType t.loc ctx nat t + (E _, t) => wrongType t.loc ctx nat t + (s, _) => wrongType s.loc ctx nat s - compare0' ctx ty@(BOX q ty') s t = local_ Equal $ + compare0' ctx ty@(BOX q ty' {}) s t = local_ Equal $ case (s, t) of -- Γ ⊢ s = t : A -- ----------------------- -- Γ ⊢ [s] = [t] : [π.A] - (Box s, Box t) => compare0 ctx ty' s t + (Box s' {}, Box t' {}) => compare0 ctx ty' s' t' (E e, E f) => Elim.compare0 ctx e f - (Box _, t) => wrongType ctx ty t - (E _, t) => wrongType ctx ty t - (s, _) => wrongType ctx ty s + (Box {}, t) => wrongType t.loc ctx ty t + (E _, t) => wrongType t.loc ctx ty t + (s, _) => wrongType s.loc ctx ty 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, … - E e <- pure s | _ => wrongType ctx ty s - E f <- pure t | _ => wrongType ctx ty t + let E e = s | _ => wrongType s.loc ctx ty s + E f = t | _ => wrongType t.loc ctx ty t Elim.compare0 ctx e f ||| compares two types, using the current variance `mode` for universes. ||| fails if they are not types, even if they would happen to be equal. export covering %inline - compareType : EqContext n -> (s, t : Term 0 n) -> Equal () + compareType : EqContext n -> (s, t : Term 0 n) -> Equal_ () compareType ctx s t = do let Val n = ctx.termLen - Element s _ <- whnf defs ctx s - Element t _ <- whnf defs ctx t - ts <- ensureTyCon ctx s - tt <- ensureTyCon ctx t - st <- either pure (const $ clashTy ctx s t) $ nchoose $ sameTyCon s t - compareType' ctx s t + Element s' _ <- whnf defs ctx s.loc s + Element t' _ <- whnf defs ctx t.loc t + ts <- ensureTyCon s.loc ctx s' + tt <- ensureTyCon t.loc ctx t' + st <- either pure (const $ clashTy s.loc ctx s' t') $ + nchoose $ sameTyCon s' t' + compareType' ctx s' t' private covering compareType' : EqContext n -> (s, t : Term 0 n) -> (0 _ : NotRedex defs s) => (0 _ : So (isTyConE s)) => (0 _ : NotRedex defs t) => (0 _ : So (isTyConE t)) => (0 _ : So (sameTyCon s t)) => - Equal () + Equal_ () -- equality is the same as subtyping, except with the -- "≤" in the TYPE rule being replaced with "=" - compareType' ctx (TYPE k) (TYPE l) = + compareType' ctx a@(TYPE k {}) (TYPE l {}) = -- 𝓀 ≤ ℓ -- ---------------------- -- Γ ⊢ Type 𝓀 <: Type ℓ - expectModeU !mode k l + expectModeU a.loc !mode k l - compareType' ctx (Pi {qty = sQty, arg = sArg, res = sRes, _}) - (Pi {qty = tQty, arg = tArg, res = tRes, _}) = do + compareType' ctx a@(Pi {qty = sQty, arg = sArg, res = sRes, _}) + (Pi {qty = tQty, arg = tArg, res = tRes, _}) = do -- Γ ⊢ A₁ :> A₂ Γ, x : A₁ ⊢ B₁ <: B₂ -- ---------------------------------------- -- Γ ⊢ (π·x : A₁) → B₁ <: (π·x : A₂) → B₂ - expectEqualQ sQty tQty + expectEqualQ a.loc sQty tQty local flip $ compareType ctx sArg tArg -- contra compareType (extendTy Zero sRes.name sArg ctx) sRes.term tRes.term @@ -325,21 +351,21 @@ parameters (defs : Definitions) Term.compare0 ctx sTy.zero sl tl Term.compare0 ctx sTy.one sr tr - compareType' ctx s@(Enum tags1) t@(Enum tags2) = do + compareType' ctx s@(Enum tags1 {}) t@(Enum tags2 {}) = do -- ------------------ -- Γ ⊢ {ts} <: {ts} -- -- no subtyping based on tag subsets, since that would need -- a runtime coercion - unless (tags1 == tags2) $ clashTy ctx s t + unless (tags1 == tags2) $ clashTy s.loc ctx s t - compareType' ctx Nat Nat = + compareType' ctx (Nat {}) (Nat {}) = -- ------------ -- Γ ⊢ ℕ <: ℕ pure () - compareType' ctx (BOX pi a) (BOX rh b) = do - expectEqualQ pi rh + compareType' ctx (BOX pi a loc) (BOX rh b {}) = do + expectEqualQ loc pi rh compareType ctx a b compareType' ctx (E e) (E f) = do @@ -347,13 +373,17 @@ parameters (defs : Definitions) -- has been inlined by whnf Elim.compare0 ctx e f + -- Ψ | Γ ⊢₀ e ⇒ Eq [𝑖 ⇒ A] s t + -- ----------------------------- + -- Ψ | Γ ⊢ e @0 = s ⇒ A[0/𝑖] + -- Ψ | Γ ⊢ e @1 = s ⇒ A[1/𝑖] private covering replaceEnd : EqContext n -> - (e : Elim 0 n) -> DimConst -> (0 ne : NotRedex defs e) -> - Equal (Elim 0 n) - replaceEnd ctx e p ne = do - (ty, l, r) <- expectEq defs ctx !(computeElimTypeE defs ctx e) - pure $ ends l r p :# dsub1 ty (K p) + (e : Elim 0 n) -> Loc -> DimConst -> Loc -> + (0 ne : NotRedex defs e) -> Equal_ (Elim 0 n) + replaceEnd ctx e eloc p ploc ne = do + (ty, l, r) <- expectEq defs ctx eloc !(computeElimTypeE defs ctx e) + pure $ Ann (ends l r p) (dsub1 ty (K p ploc)) eloc namespace Elim -- [fixme] the following code ends up repeating a lot of work in the @@ -364,133 +394,179 @@ parameters (defs : Definitions) ||| ⚠ **assumes that they have both been typechecked, and have ||| equal types.** ⚠ export covering %inline - compare0 : EqContext n -> (e, f : Elim 0 n) -> Equal () + compare0 : EqContext n -> (e, f : Elim 0 n) -> Equal_ () compare0 ctx e f = wrapErr (WhileComparingE ctx !mode e f) $ do let Val n = ctx.termLen - Element e ne <- whnf defs ctx e - Element f nf <- whnf defs ctx f - -- [fixme] there is a better way to do this "isSubSing" stuff for sure - unless !(isSubSing defs ctx !(computeElimTypeE defs ctx e)) $ - compare0' ctx e f ne nf + Element e' ne <- whnf defs ctx e.loc e + Element f' nf <- whnf defs ctx f.loc f + unless !(isSubSing defs ctx =<< computeElimTypeE defs ctx e') $ + compare0' ctx e' f' ne nf private covering compare0' : EqContext n -> (e, f : Elim 0 n) -> (0 ne : NotRedex defs e) -> (0 nf : NotRedex defs f) -> - Equal () + Equal_ () -- replace applied equalities with the appropriate end first - -- e.g. e : Eq [i ⇒ A] s t ⊢ e 𝟎 = s : A‹𝟎/i› - -- - -- [todo] maybe have typed whnf and do this (and η???) there instead - compare0' ctx (e :% K p) f ne nf = - compare0 ctx !(replaceEnd ctx e p $ noOr1 ne) f - compare0' ctx e (f :% K q) ne nf = - compare0 ctx e !(replaceEnd ctx f q $ noOr1 nf) + -- (see `replaceEnd`) + compare0' ctx (DApp e (K p ploc) loc) f ne nf = + compare0 ctx !(replaceEnd ctx e loc p ploc $ noOr1 ne) f + compare0' ctx e (DApp f (K q qloc) loc) ne nf = + compare0 ctx e !(replaceEnd ctx f loc q qloc $ noOr1 nf) - compare0' ctx e@(F x) f@(F y) _ _ = unless (x == y) $ clashE ctx e f - compare0' ctx e@(F _) f _ _ = clashE ctx e f + compare0' ctx e@(F x {}) f@(F y {}) _ _ = + unless (x == y) $ clashE e.loc ctx e f + compare0' ctx e@(F {}) f _ _ = clashE e.loc ctx e f - compare0' ctx e@(B i) f@(B j) _ _ = unless (i == j) $ clashE ctx e f - compare0' ctx e@(B _) f _ _ = clashE ctx e f + compare0' ctx e@(B i {}) f@(B j {}) _ _ = + unless (i == j) $ clashE e.loc ctx e f + compare0' ctx e@(B {}) f _ _ = clashE e.loc ctx e f - compare0' ctx (e :@ s) (f :@ t) ne nf = + -- Ψ | Γ ⊢ e = f ⇒ π.(x : A) → B + -- Ψ | Γ ⊢ s = t ⇐ A + -- ------------------------------- + -- Ψ | Γ ⊢ e s = f t ⇒ B[s∷A/x] + compare0' ctx (App e s eloc) (App f t floc) ne nf = local_ Equal $ do compare0 ctx e f - (_, arg, _) <- expectPi defs ctx =<< + (_, arg, _) <- expectPi defs ctx eloc =<< computeElimTypeE defs ctx e @{noOr1 ne} Term.compare0 ctx arg s t - compare0' ctx e@(_ :@ _) f _ _ = clashE ctx e f + compare0' ctx e@(App {}) f _ _ = clashE e.loc ctx e f - compare0' ctx (CasePair epi e eret ebody) - (CasePair fpi f fret fbody) ne nf = + -- Ψ | Γ ⊢ e = f ⇒ (x : A) × B + -- Ψ | Γ, 0.p : (x : A) × B ⊢ Q = R + -- Ψ | Γ, x : A, y : B ⊢ s = t ⇐ Q[((x, y) ∷ (x : A) × B)/p] + -- ----------------------------------------------------------- + -- Ψ | Γ ⊢ caseπ e return Q of { (x, y) ⇒ s } + -- = caseπ f return R of { (x, y) ⇒ t } ⇒ Q[e/p] + compare0' ctx (CasePair epi e eret ebody eloc) + (CasePair fpi f fret fbody {}) ne nf = local_ Equal $ do compare0 ctx e f ety <- computeElimTypeE defs ctx e @{noOr1 ne} compareType (extendTy Zero eret.name ety ctx) eret.term fret.term - (fst, snd) <- expectSig defs ctx ety + (fst, snd) <- expectSig defs ctx eloc ety let [< x, y] = ebody.names Term.compare0 (extendTyN [< (epi, x, fst), (epi, y, snd.term)] ctx) - (substCasePairRet ety eret) + (substCasePairRet ebody.names ety eret) ebody.term fbody.term - expectEqualQ epi fpi - compare0' ctx e@(CasePair {}) f _ _ = clashE ctx e f + expectEqualQ e.loc epi fpi + compare0' ctx e@(CasePair {}) f _ _ = clashE e.loc ctx e f - compare0' ctx (CaseEnum epi e eret earms) - (CaseEnum fpi f fret farms) ne nf = + -- Ψ | Γ ⊢ e = f ⇒ {𝐚s} + -- Ψ | Γ, x : {𝐚s} ⊢ Q = R + -- Ψ | Γ ⊢ sᵢ = tᵢ ⇐ Q[𝐚ᵢ∷{𝐚s}] + -- -------------------------------------------------- + -- Ψ | Γ ⊢ caseπ e return Q of { '𝐚ᵢ ⇒ sᵢ } + -- = caseπ f return R of { '𝐚ᵢ ⇒ tᵢ } ⇒ Q[e/x] + compare0' ctx (CaseEnum epi e eret earms eloc) + (CaseEnum fpi f fret farms floc) ne nf = local_ Equal $ do compare0 ctx e f ety <- computeElimTypeE defs ctx e @{noOr1 ne} compareType (extendTy Zero eret.name ety ctx) eret.term fret.term - for_ !(expectEnum defs ctx ety) $ \t => - compare0 ctx (sub1 eret $ Tag t :# ety) - !(lookupArm t earms) !(lookupArm t farms) - expectEqualQ epi fpi + for_ !(expectEnum defs ctx eloc ety) $ \t => do + l <- lookupArm eloc t earms + r <- lookupArm floc t farms + compare0 ctx (sub1 eret $ Ann (Tag t l.loc) ety l.loc) l r + expectEqualQ eloc epi fpi where - lookupArm : TagVal -> CaseEnumArms d n -> Equal (Term d n) - lookupArm t arms = case lookup t arms of + lookupArm : Loc -> TagVal -> CaseEnumArms d n -> Equal_ (Term d n) + lookupArm loc t arms = case lookup t arms of Just arm => pure arm - Nothing => throw $ TagNotIn t (fromList $ keys arms) - compare0' ctx e@(CaseEnum {}) f _ _ = clashE ctx e f + Nothing => throw $ TagNotIn loc t (fromList $ keys arms) + compare0' ctx e@(CaseEnum {}) f _ _ = clashE e.loc ctx e f - compare0' ctx (CaseNat epi epi' e eret ezer esuc) - (CaseNat fpi fpi' f fret fzer fsuc) ne nf = + -- Ψ | Γ ⊢ e = f ⇒ ℕ + -- Ψ | Γ, x : ℕ ⊢ Q = R + -- Ψ | Γ ⊢ s₀ = t₀ ⇐ Q[(0 ∷ ℕ)/x] + -- Ψ | Γ, x : ℕ, y : Q ⊢ s₁ = t₁ ⇐ Q[(succ x ∷ ℕ)/x] + -- ----------------------------------------------------- + -- Ψ | Γ ⊢ caseπ e return Q of { 0 ⇒ s₀; x, π.y ⇒ s₁ } + -- = caseπ f return R of { 0 ⇒ t₀; x, π.y ⇒ t₁ } + -- ⇒ Q[e/x] + compare0' ctx (CaseNat epi epi' e eret ezer esuc eloc) + (CaseNat fpi fpi' f fret fzer fsuc floc) ne nf = local_ Equal $ do compare0 ctx e f ety <- computeElimTypeE defs ctx e @{noOr1 ne} compareType (extendTy Zero eret.name ety ctx) eret.term fret.term - compare0 ctx (sub1 eret (Zero :# Nat)) ezer fzer + compare0 ctx + (sub1 eret (Ann (Zero ezer.loc) (Nat ezer.loc) ezer.loc)) + ezer fzer let [< p, ih] = esuc.names - compare0 (extendTyN [< (epi, p, Nat), (epi', ih, eret.term)] ctx) - (substCaseSuccRet eret) - esuc.term fsuc.term - expectEqualQ epi fpi - expectEqualQ epi' fpi' - compare0' ctx e@(CaseNat {}) f _ _ = clashE ctx e f + compare0 + (extendTyN [< (epi, p, Nat p.loc), (epi', ih, eret.term)] ctx) + (substCaseSuccRet esuc.names eret) esuc.term fsuc.term + expectEqualQ e.loc epi fpi + expectEqualQ e.loc epi' fpi' + compare0' ctx e@(CaseNat {}) f _ _ = clashE e.loc ctx e f - compare0' ctx (CaseBox epi e eret ebody) - (CaseBox fpi f fret fbody) ne nf = + -- Ψ | Γ ⊢ e = f ⇒ [ρ. A] + -- Ψ | Γ, x : [ρ. A] ⊢ Q = R + -- Ψ | Γ, x : A ⊢ s = t ⇐ Q[([x] ∷ [ρ. A])/x] + -- -------------------------------------------------- + -- Ψ | Γ ⊢ caseπ e return Q of { [x] ⇒ s } + -- = caseπ f return R of { [x] ⇒ t } ⇒ Q[e/x] + compare0' ctx (CaseBox epi e eret ebody eloc) + (CaseBox fpi f fret fbody floc) ne nf = local_ Equal $ do compare0 ctx e f ety <- computeElimTypeE defs ctx e @{noOr1 ne} compareType (extendTy Zero eret.name ety ctx) eret.term fret.term - (q, ty) <- expectBOX defs ctx ety + (q, ty) <- expectBOX defs ctx eloc ety compare0 (extendTy (epi * q) ebody.name ty ctx) - (substCaseBoxRet ety eret) + (substCaseBoxRet ebody.name ety eret) ebody.term fbody.term - expectEqualQ epi fpi - compare0' ctx e@(CaseBox {}) f _ _ = clashE ctx e f + expectEqualQ eloc epi fpi + compare0' ctx e@(CaseBox {}) f _ _ = clashE e.loc ctx e f - compare0' ctx (s :# a) (t :# b) _ _ = + -- Ψ | Γ ⊢ s <: t : B + -- -------------------------------- + -- Ψ | Γ ⊢ (s ∷ A) <: (t ∷ B) ⇒ B + -- + -- and similar for :> and A + compare0' ctx (Ann s a _) (Ann t b _) _ _ = let ty = case !mode of Super => a; _ => b in Term.compare0 ctx ty s t - compare0' ctx (Coe ty1 p1 q1 (E val1)) (Coe ty2 p2 q2 (E val2)) ne nf = do + -- Ψ | Γ ⊢ A‹p₁/𝑖› <: B‹p₂/𝑖› + -- Ψ | Γ ⊢ A‹q₁/𝑖› <: B‹q₂/𝑖› + -- Ψ | Γ ⊢ e <: f ⇒ _ + -- (non-neutral forms have the coercion already pushed in) + -- ----------------------------------------------------------- + -- Ψ | Γ ⊢ coe [𝑖 ⇒ A] @p₁ @q₁ e + -- <: coe [𝑖 ⇒ B] @p₂ @q₂ f ⇒ B‹q₂/𝑖› + compare0' ctx (Coe ty1 p1 q1 (E val1) _) + (Coe ty2 p2 q2 (E val2) _) ne nf = do compareType ctx (dsub1 ty1 p1) (dsub1 ty2 p2) compareType ctx (dsub1 ty1 q1) (dsub1 ty2 q2) compare0 ctx val1 val2 - compare0' ctx e@(Coe {}) f _ _ = clashE ctx e f + compare0' ctx e@(Coe {}) f _ _ = clashE e.loc ctx e f - compare0' ctx (Comp _ _ _ _ (K _) _ _) _ ne _ = void $ absurd $ noOr2 ne - compare0' ctx (Comp _ _ _ _ (B i) _ _) _ _ _ = absurd i - compare0' ctx _ (Comp _ _ _ _ (K _) _ _) _ nf = void $ absurd $ noOr2 nf + -- (no neutral compositions in a closed dctx) + compare0' _ (Comp {r = K e _, _}) _ ne _ = void $ absurd $ noOr2 ne + compare0' _ (Comp {r = B i _, _}) _ _ _ = absurd i + compare0' _ _ (Comp {r = K _ _, _}) _ nf = void $ absurd $ noOr2 nf - compare0' ctx (TypeCase ty1 ret1 arms1 def1) - (TypeCase ty2 ret2 arms2 def2) - ne _ = + compare0' ctx (TypeCase ty1 ret1 arms1 def1 eloc) + (TypeCase ty2 ret2 arms2 def2 floc) ne _ = local_ Equal $ do compare0 ctx ty1 ty2 - u <- expectTYPE defs ctx =<< computeElimTypeE defs ctx ty1 @{noOr1 ne} + u <- expectTYPE defs ctx eloc =<< + computeElimTypeE defs ctx ty1 @{noOr1 ne} compareType ctx ret1 ret2 compareType ctx def1 def2 for_ allKinds $ \k => compareArm ctx k ret1 u (lookupPrecise k arms1) (lookupPrecise k arms2) def1 - compare0' ctx e@(TypeCase {}) f _ _ = clashE ctx e f + compare0' ctx e@(TypeCase {}) f _ _ = clashE e.loc ctx e f - compare0' ctx (s :# a) f _ _ = Term.compare0 ctx a s (E f) - compare0' ctx e (t :# b) _ _ = Term.compare0 ctx b (E e) t - compare0' ctx e@(_ :# _) f _ _ = clashE ctx e f + compare0' ctx (Ann s a _) f _ _ = Term.compare0 ctx a s (E f) + compare0' ctx e (Ann t b _) _ _ = Term.compare0 ctx b (E e) t + compare0' ctx e@(Ann {}) f _ _ = clashE e.loc ctx e f ||| compare two type-case branches, which came from the arms of the given ||| kind. `ret` is the return type of the case expression, and `u` is the @@ -500,7 +576,7 @@ parameters (defs : Definitions) (ret : Term 0 n) -> (u : Universe) -> (b1, b2 : Maybe (TypeCaseArmBody k 0 n)) -> (def : Term 0 n) -> - Equal () + Equal_ () compareArm {b1 = Nothing, b2 = Nothing, _} = pure () compareArm ctx k ret u b1 b2 def = let def = SN def in @@ -510,22 +586,22 @@ parameters (defs : Definitions) compareArm_ : EqContext n -> (k : TyConKind) -> (ret : Term 0 n) -> (u : Universe) -> (b1, b2 : TypeCaseArmBody k 0 n) -> - Equal () + Equal_ () compareArm_ ctx KTYPE ret u b1 b2 = compare0 ctx ret b1.term b2.term compareArm_ ctx KPi ret u b1 b2 = do let [< a, b] = b1.names ctx = extendTyN - [< (Zero, a, TYPE u), - (Zero, b, Arr Zero (BVT 0) (TYPE u))] ctx + [< (Zero, a, TYPE u a.loc), + (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] ctx compare0 ctx (weakT 2 ret) b1.term b2.term compareArm_ ctx KSig ret u b1 b2 = do let [< a, b] = b1.names ctx = extendTyN - [< (Zero, a, TYPE u), - (Zero, b, Arr Zero (BVT 0) (TYPE u))] ctx + [< (Zero, a, TYPE u a.loc), + (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] ctx compare0 ctx (weakT 2 ret) b1.term b2.term compareArm_ ctx KEnum ret u b1 b2 = @@ -534,70 +610,76 @@ parameters (defs : Definitions) compareArm_ ctx KEq ret u b1 b2 = do let [< a0, a1, a, l, r] = b1.names ctx = extendTyN - [< (Zero, a0, TYPE u), - (Zero, a1, TYPE u), - (Zero, a, Eq0 (TYPE u) (BVT 1) (BVT 0)), - (Zero, l, BVT 2), - (Zero, r, BVT 2)] ctx + [< (Zero, a0, TYPE u a0.loc), + (Zero, a1, TYPE u a1.loc), + (Zero, a, Eq0 (TYPE u a.loc) + (BVT 1 a0.loc) (BVT 0 a1.loc) a.loc), + (Zero, l, BVT 2 a0.loc), + (Zero, r, BVT 2 a1.loc)] ctx compare0 ctx (weakT 5 ret) b1.term b2.term compareArm_ ctx KNat ret u b1 b2 = compare0 ctx ret b1.term b2.term compareArm_ ctx KBOX ret u b1 b2 = do - let ctx = extendTy Zero b1.name (TYPE u) ctx + let ctx = extendTy Zero b1.name (TYPE u b1.name.loc) ctx compare0 ctx (weakT 1 ret) b1.term b1.term -parameters {auto _ : (Has DefsReader fs, Has ErrorEff fs)} (ctx : TyContext d n) +parameters (loc : Loc) (ctx : TyContext d n) -- [todo] only split on the dvars that are actually used anywhere in -- the calls to `splits` parameters (mode : EqMode) + private + fromEqual_ : Equal_ a -> Equal a + fromEqual_ act = lift $ evalState mode act + + private + eachFace : Applicative f => (EqContext n -> DSubst d 0 -> f ()) -> f () + eachFace act = + for_ (splits loc ctx.dctx) $ \th => act (makeEqContext ctx th) th + + private + runCompare : (Definitions -> EqContext n -> DSubst d 0 -> Equal_ ()) -> + Equal () + runCompare act = fromEqual_ $ eachFace $ act !defs + namespace Term export covering - compare : (ty, s, t : Term d n) -> Eff fs () - compare ty s t = - map fst $ runState @{Z} mode $ - for_ (splits ctx.dctx) $ \th => - let ectx = makeEqContext ctx th in - lift $ compare0 !defs ectx (ty // th) (s // th) (t // th) + compare : (ty, s, t : Term d n) -> Equal () + compare ty s t = runCompare $ \defs, ectx, th => + compare0 defs ectx (ty // th) (s // th) (t // th) export covering - compareType : (s, t : Term d n) -> Eff fs () - compareType s t = - map fst $ runState @{Z} mode $ - for_ (splits ctx.dctx) $ \th => - let ectx = makeEqContext ctx th in - lift $ compareType !defs ectx (s // th) (t // th) + compareType : (s, t : Term d n) -> Equal () + compareType s t = runCompare $ \defs, ectx, th => + compareType defs ectx (s // th) (t // th) namespace Elim ||| you don't have to pass the type in but the arguments must still be ||| of the same type!! - export covering %inline - compare : (e, f : Elim d n) -> Eff fs () - compare e f = - map fst $ runState @{Z} mode $ - for_ (splits ctx.dctx) $ \th => - let ectx = makeEqContext ctx th in - lift $ compare0 !defs ectx (e // th) (f // th) + export covering + compare : (e, f : Elim d n) -> Equal () + compare e f = runCompare $ \defs, ectx, th => + compare0 defs ectx (e // th) (f // th) namespace Term export covering %inline - equal, sub, super : (ty, s, t : Term d n) -> Eff fs () + equal, sub, super : (ty, s, t : Term d n) -> Equal () equal = compare Equal sub = compare Sub super = compare Super export covering %inline - equalType, subtype, supertype : (s, t : Term d n) -> Eff fs () + equalType, subtype, supertype : (s, t : Term d n) -> Equal () equalType = compareType Equal subtype = compareType Sub supertype = compareType Super namespace Elim export covering %inline - equal, sub, super : (e, f : Elim d n) -> Eff fs () + equal, sub, super : (e, f : Elim d n) -> Equal () equal = compare Equal sub = compare Sub super = compare Super diff --git a/lib/Quox/Loc.idr b/lib/Quox/Loc.idr index 4b65199..cd63e2f 100644 --- a/lib/Quox/Loc.idr +++ b/lib/Quox/Loc.idr @@ -1,7 +1,8 @@ ||| file locations module Quox.Loc -import Text.Bounded +import public Text.Bounded +import Data.SortedMap import Derive.Prelude %default total @@ -11,53 +12,110 @@ public export FileName : Type FileName = String +%runElab derive "Bounds" [Ord] + public export -record Loc' where +data Loc_ = NoLoc | YesLoc FileName Bounds +%name Loc_ loc +%runElab derive "Loc_" [Eq, Ord, Show] + + +||| a wrapper for locations which are always considered equal +public export +record Loc where constructor L - fname : FileName - startLine, startCol, endLine, endCol : Int -%name Loc' loc -%runElab derive "Loc'" [Eq, Ord, Show] + val : Loc_ +%name Loc loc +%runElab derive "Loc" [Show] -public export -Loc : Type -Loc = Maybe Loc' +export %inline Eq Loc where _ == _ = True +export %inline Ord Loc where compare _ _ = EQ -export +public export %inline +noLoc : Loc +noLoc = L NoLoc + +public export %inline makeLoc : FileName -> Bounds -> Loc -makeLoc fname (MkBounds {startLine, startCol, endLine, endCol}) = - Just $ L {fname, startLine, startCol, endLine, endCol} +makeLoc = L .: YesLoc + export +onlyStart_ : Loc_ -> Loc_ +onlyStart_ NoLoc = NoLoc +onlyStart_ (YesLoc fname (MkBounds sl sc _ _)) = + YesLoc fname $ MkBounds sl sc sl sc + +export %inline onlyStart : Loc -> Loc -onlyStart Nothing = Nothing -onlyStart (Just (L fname sl sc _ _)) = Just $ L fname sl sc sl sc +onlyStart = {val $= onlyStart_} export +onlyEnd_ : Loc_ -> Loc_ +onlyEnd_ NoLoc = NoLoc +onlyEnd_ (YesLoc fname (MkBounds _ _ el ec)) = + YesLoc fname $ MkBounds el ec el ec + +export %inline onlyEnd : Loc -> Loc -onlyEnd Nothing = Nothing -onlyEnd (Just (L fname _ _ el ec)) = Just $ L fname el ec el ec +onlyEnd = {val $= onlyEnd_} export -extend : Loc -> Bounds -> Loc -extend Nothing _ = Nothing -extend (Just (L fname sl1 sc1 el1 ec1)) (MkBounds sl2 sc2 el2 ec2) = +extend_ : Loc_ -> Bounds -> Loc_ +extend_ NoLoc _ = NoLoc +extend_ (YesLoc fname (MkBounds sl1 sc1 el1 ec1)) (MkBounds sl2 sc2 el2 ec2) = let (sl, sc) = (sl1, sc1) `min` (sl2, sc2) (el, ec) = (el1, ec1) `max` (el2, ec2) in - Just $ L fname sl sc el ec + YesLoc fname $ MkBounds sl sc el ec + +export +extend : Loc -> Bounds -> Loc +extend l b = L $ extend_ l.val b export extend' : Loc -> Maybe Bounds -> Loc extend' l b = maybe l (extend l) b +namespace Loc_ + export + (.bounds) : Loc_ -> Maybe Bounds + (YesLoc _ b).bounds = Just b + (NoLoc).bounds = Nothing + +namespace Loc + export + (.bounds) : Loc -> Maybe Bounds + l.bounds = l.val.bounds + +export %inline +extendL : Loc -> Loc -> Loc +extendL l1 l2 = l1 `extend'` l2.bounds + + +infixr 1 `or_`, `or` +export %inline +or_ : Loc_ -> Loc_ -> Loc_ +or_ l1@(YesLoc {}) _ = l1 +or_ NoLoc l2 = l2 + +export %inline +or : Loc -> Loc -> Loc +or (L l1) (L l2) = L $ l1 `or_` l2 + + public export interface Located a where (.loc) : a -> Loc -export -(.bounds) : Loc -> Maybe Bounds -(Just (L {fname, startLine, startCol, endLine, endCol})).bounds = - Just $ MkBounds {startLine, startCol, endLine, endCol} -(Nothing).bounds = Nothing +public export +0 Located1 : (a -> Type) -> Type +Located1 f = forall x. Located (f x) + +public export +interface Located a => Relocatable a where setLoc : Loc -> a -> a + +public export +0 Relocatable1 : (a -> Type) -> Type +Relocatable1 f = forall x. Relocatable (f x) diff --git a/lib/Quox/Name.idr b/lib/Quox/Name.idr index 03f4271..f4637e7 100644 --- a/lib/Quox/Name.idr +++ b/lib/Quox/Name.idr @@ -1,8 +1,10 @@ module Quox.Name +import Quox.Loc import Quox.CharExtra import public Data.SnocList import Data.List +import Control.Eff import Text.Lexer import Derive.Prelude @@ -12,16 +14,22 @@ import Derive.Prelude %language ElabReflection +public export +NameSuf : Type +NameSuf = Nat + public export data BaseName -= UN String -- user-given name -| Unused -- "_" += UN String -- user-given name +| MN String NameSuf -- machine-generated name +| Unused -- "_" %runElab derive "BaseName" [Eq, Ord] export baseStr : BaseName -> String -baseStr (UN x) = x -baseStr Unused = "_" +baseStr (UN x) = x +baseStr (MN x i) = "\{x}#\{show i}" +baseStr Unused = "_" export Show BaseName where show = baseStr export FromString BaseName where fromString = UN @@ -83,6 +91,17 @@ export FromString PName where fromString = MakePName [<] export FromString Name where fromString = fromPBaseName +public export +record BindName where + constructor BN + name : BaseName + loc_ : Loc +%runElab derive "BindName" [Eq, Ord, Show] + +export Located BindName where n.loc = n.loc_ +export Relocatable BindName where setLoc loc (BN x _) = BN x loc + + export toDotsP : PName -> String toDotsP x = fastConcat $ cast $ map (<+> ".") x.mods :< x.base @@ -140,3 +159,41 @@ isName str = case scan name [] (unpack str) of Just (_, []) => True _ => False + + +public export +data GenTag = GEN + +public export +NameGen : Type -> Type +NameGen = StateL GEN NameSuf + +export +runNameGenWith : Has NameGen fs => + NameSuf -> Eff fs a -> Eff (fs - NameGen) (a, NameSuf) +runNameGenWith = runStateAt GEN + +export +runNameGen : Has NameGen fs => Eff fs a -> Eff (fs - NameGen) a +runNameGen = map fst . runNameGenWith 0 + +||| generate a fresh name with the given base +export +mn : Has NameGen fs => PBaseName -> Eff fs BaseName +mn base = do + i <- getAt GEN + modifyAt GEN S + pure $ MN base i + +||| generate a fresh binding name with the given base and +||| (optionally) location `loc` +export +mnb : Has NameGen fs => + PBaseName -> {default noLoc loc : Loc} -> Eff fs BindName +mnb base = pure $ BN !(mn base) loc + +export +fresh : Has NameGen fs => BindName -> Eff fs BindName +fresh (BN (UN str) loc) = mnb str {loc} +fresh (BN (MN str k) loc) = mnb str {loc} +fresh (BN Unused loc) = mnb "x" {loc} diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 47d97da..8420c16 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -1,4 +1,4 @@ -||| take freshly-parsed input, translate it to core, and check it +||| take freshly-parsed input, scope check, type check, add to env module Quox.Parser.FromParser import Quox.Parser.Syntax @@ -41,19 +41,19 @@ data StateTag = NS | SEEN public export FromParserPure : List (Type -> Type) FromParserPure = - [Except Error, StateL DEFS Definitions, StateL NS Mods] + [Except Error, DefsState, StateL NS Mods, NameGen] public export -FromParserEff : List (Type -> Type) -FromParserEff = - [Except Error, StateL DEFS Definitions, StateL NS Mods, - Reader IncludePath, StateL SEEN SeenFiles, IO] +LoadFile' : List (Type -> Type) +LoadFile' = [IO, StateL SEEN SeenFiles, Reader IncludePath] public export -FromParser : Type -> Type -FromParser = Eff FromParserEff +LoadFile : List (Type -> Type) +LoadFile = LoadFile' ++ [Except Error] --- [todo] put the locs in the core ast, obv +public export +FromParserIO : List (Type -> Type) +FromParserIO = FromParserPure ++ LoadFile' parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a) @@ -70,31 +70,32 @@ parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a) export fromPDimWith : Has (Except Error) fs => Context' PatVar d -> PDim -> Eff fs (Dim d) -fromPDimWith ds (K e _) = pure $ K e -fromPDimWith ds (V i _) = - fromBaseName (pure . B) (const $ throw $ DimNotInScope i) ds i +fromPDimWith ds (K e loc) = pure $ K e loc +fromPDimWith ds (V i loc) = + fromBaseName (\i => pure $ B i loc) + (const $ throw $ DimNotInScope loc i) ds i private avoidDim : Has (Except Error) fs => - Context' PatVar d -> PName -> Eff fs Name -avoidDim ds x = - fromName (const $ throw $ DimNameInTerm x.base) (pure . fromPName) ds x + Context' PatVar d -> Loc -> PName -> Eff fs Name +avoidDim ds loc x = + fromName (const $ throw $ DimNameInTerm loc x.base) (pure . fromPName) ds x private -resolveName : Mods -> Name -> Eff FromParserPure (Term d n) -resolveName ns x = +resolveName : Mods -> Loc -> Name -> Eff FromParserPure (Term d n) +resolveName ns loc x = let here = addMods ns x in if isJust $ lookup here !(getAt DEFS) then - pure $ FT here + pure $ FT here loc else do let ns :< _ = ns - | _ => throw $ TermNotInScope x - resolveName ns x + | _ => throw $ TermNotInScope loc x + resolveName ns loc x export -fromPatVar : PatVar -> BaseName -fromPatVar (Unused _) = Unused -fromPatVar (PV x _) = UN x +fromPatVar : PatVar -> BindName +fromPatVar (Unused loc) = BN Unused loc +fromPatVar (PV x loc) = BN (UN x) loc export fromPQty : PQty -> Qty @@ -110,93 +111,112 @@ mutual fromPTermWith : Context' PatVar d -> Context' PatVar n -> PTerm -> Eff FromParserPure (Term d n) fromPTermWith ds ns t0 = case t0 of - TYPE k _ => - pure $ TYPE k + TYPE k loc => + pure $ TYPE k loc - Pi pi x s t _ => + Pi pi x s t loc => Pi (fromPQty pi) <$> fromPTermWith ds ns s <*> fromPTermTScope ds ns [< x] t + <*> pure loc - Lam x s _ => - Lam <$> fromPTermTScope ds ns [< x] s + Lam x s loc => + Lam <$> fromPTermTScope ds ns [< x] s <*> pure loc - App s t _ => - map E $ (:@) <$> fromPTermElim ds ns s <*> fromPTermWith ds ns t + App s t loc => + map E $ App + <$> fromPTermElim ds ns s + <*> fromPTermWith ds ns t + <*> pure loc - Sig x s t _ => - Sig <$> fromPTermWith ds ns s <*> fromPTermTScope ds ns [< x] t + Sig x s t loc => + Sig <$> fromPTermWith ds ns s + <*> fromPTermTScope ds ns [< x] t + <*> pure loc - Pair s t _ => - Pair <$> fromPTermWith ds ns s <*> fromPTermWith ds ns t + Pair s t loc => + Pair <$> fromPTermWith ds ns s <*> fromPTermWith ds ns t <*> pure loc - Case pi pair (r, ret) (CasePair (x, y) body _) _ => + Case pi pair (r, ret) (CasePair (x, y) body _) loc => map E $ CasePair (fromPQty pi) <$> fromPTermElim ds ns pair <*> fromPTermTScope ds ns [< r] ret <*> fromPTermTScope ds ns [< x, y] body + <*> pure loc - Case pi tag (r, ret) (CaseEnum arms _) _ => + Case pi tag (r, ret) (CaseEnum arms _) loc => map E $ CaseEnum (fromPQty pi) <$> fromPTermElim ds ns tag <*> fromPTermTScope ds ns [< r] ret <*> assert_total fromPTermEnumArms ds ns arms + <*> pure loc - Nat _ => pure Nat - Zero _ => pure Zero - Succ n _ => [|Succ $ fromPTermWith ds ns n|] + Nat loc => pure $ Nat loc + Zero loc => pure $ Zero loc + Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|] - Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) _ => + Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc => map E $ CaseNat (fromPQty pi) (fromPQty pi') <$> fromPTermElim ds ns nat <*> fromPTermTScope ds ns [< r] ret <*> fromPTermWith ds ns zer <*> fromPTermTScope ds ns [< s, ih] suc + <*> pure loc - Enum strs _ => + Enum strs loc => let set = SortedSet.fromList strs in if length strs == length (SortedSet.toList set) then - pure $ Enum set + pure $ Enum set loc else - throw $ DuplicatesInEnum strs + throw $ DuplicatesInEnum loc strs - Tag str _ => pure $ Tag str + Tag str loc => pure $ Tag str loc - Eq (i, ty) s t _ => + Eq (i, ty) s t loc => Eq <$> fromPTermDScope ds ns [< i] ty <*> fromPTermWith ds ns s <*> fromPTermWith ds ns t + <*> pure loc - DLam i s _ => - DLam <$> fromPTermDScope ds ns [< i] s + DLam i s loc => + DLam <$> fromPTermDScope ds ns [< i] s <*> pure loc - DApp s p _ => - map E $ (:%) <$> fromPTermElim ds ns s <*> fromPDimWith ds p + DApp s p loc => + map E $ DApp + <$> fromPTermElim ds ns s + <*> fromPDimWith ds p + <*> pure loc - BOX q ty _ => BOX (fromPQty q) <$> fromPTermWith ds ns ty + BOX q ty loc => BOX (fromPQty q) <$> fromPTermWith ds ns ty <*> pure loc - Box val _ => Box <$> fromPTermWith ds ns val + Box val loc => Box <$> fromPTermWith ds ns val <*> pure loc - Case pi box (r, ret) (CaseBox b body _) _ => + Case pi box (r, ret) (CaseBox b body _) loc => map E $ CaseBox (fromPQty pi) <$> fromPTermElim ds ns box <*> fromPTermTScope ds ns [< r] ret <*> fromPTermTScope ds ns [< b] body + <*> pure loc - V x _ => - fromName (pure . E . B) (resolveName !(getAt NS) <=< avoidDim ds) ns x + V x loc => + fromName (\i => pure $ E $ B i loc) + (resolveName !(getAt NS) loc <=< avoidDim ds loc) ns x - Ann s a _ => - map E $ (:#) <$> fromPTermWith ds ns s <*> fromPTermWith ds ns a + Ann s a loc => + map E $ Ann + <$> fromPTermWith ds ns s + <*> fromPTermWith ds ns a + <*> pure loc - Coe (i, ty) p q val _ => + Coe (i, ty) p q val loc => map E $ Coe <$> fromPTermDScope ds ns [< i] ty <*> fromPDimWith ds p <*> fromPDimWith ds q <*> fromPTermWith ds ns val + <*> pure loc - Comp (i, ty) p q val r (j0, val0) (j1, val1) _ => + Comp (i, ty) p q val r (j0, val0) (j1, val1) loc => map E $ CompH' <$> fromPTermDScope ds ns [< i] ty <*> fromPDimWith ds p @@ -205,6 +225,7 @@ mutual <*> fromPDimWith ds r <*> fromPTermDScope ds ns [< j0] val0 <*> fromPTermDScope ds ns [< j1] val1 + <*> pure loc private fromPTermEnumArms : Context' PatVar d -> Context' PatVar n -> @@ -221,7 +242,7 @@ mutual case !(fromPTermWith ds ns e) of E e => pure e t => let ctx = MkNameContexts (map fromPatVar ds) (map fromPatVar ns) in - throw $ AnnotationNeeded ctx t + throw $ AnnotationNeeded t.loc ctx t -- [todo] use SN if the var is named but still unused private @@ -251,10 +272,10 @@ fromPTerm = fromPTermWith [<] [<] export -globalPQty : (q : Qty) -> Eff [Except Error] (So $ isGlobal q) -globalPQty pi = case choose $ isGlobal pi of +globalPQty : Loc -> (q : Qty) -> Eff [Except Error] (So $ isGlobal q) +globalPQty loc pi = case choose $ isGlobal pi of Left y => pure y - Right _ => throw $ QtyNotGlobal pi + Right _ => throw $ QtyNotGlobal loc pi export @@ -262,30 +283,31 @@ fromPBaseNameNS : PBaseName -> Eff [StateL NS Mods] Name fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name private -injTC : TC a -> Eff FromParserPure a -injTC act = rethrow $ mapFst WrapTypeError $ runTC !(getAt DEFS) act +liftTC : TC a -> Eff FromParserPure a +liftTC act = do + res <- lift $ runExcept $ runReaderAt DEFS !(getAt DEFS) act + rethrow $ mapFst WrapTypeError res export covering fromPDef : PDefinition -> Eff FromParserPure NDefinition -fromPDef (MkPDef qty pname ptype pterm _) = do +fromPDef (MkPDef qty pname ptype pterm defLoc) = do name <- lift $ fromPBaseNameNS pname - let qty = fromPQty qty - qtyGlobal <- lift $ globalPQty qty - let gqty = Element qty qtyGlobal - let sqty = globalToSubj gqty + qtyGlobal <- lift $ globalPQty qty.loc qty.val + let gqty = Element qty.val qtyGlobal + sqty = globalToSubj gqty type <- lift $ traverse fromPTerm ptype term <- lift $ fromPTerm pterm case type of Just type => do - injTC $ checkTypeC empty type Nothing - injTC $ ignore $ checkC empty sqty term type - let def = mkDef gqty type term + liftTC $ checkTypeC empty type Nothing + liftTC $ ignore $ checkC empty sqty term type + let def = mkDef gqty type term defLoc modifyAt DEFS $ insert name def pure (name, def) Nothing => do - let E elim = term | t => throw $ AnnotationNeeded empty t - res <- injTC $ inferC empty sqty elim - let def = mkDef gqty res.type term + let E elim = term | _ => throw $ AnnotationNeeded term.loc empty term + res <- liftTC $ inferC empty sqty elim + let def = mkDef gqty res.type term defLoc modifyAt DEFS $ insert name def pure (name, def) @@ -296,27 +318,23 @@ fromPDecl (PNs ns) = localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls -public export -LoadFile : List (Type -> Type) -LoadFile = [IO, StateL SEEN SeenFiles, Reader IncludePath, Except Error] - export covering -loadFile : String -> Eff LoadFile (Maybe String) -loadFile file = +loadFile : Loc -> String -> Eff LoadFile (Maybe String) +loadFile loc file = if contains file !(getAt SEEN) then pure Nothing else do Just ifile <- firstExists (map ( file) !ask) - | Nothing => throw $ LoadError file FileNotFound + | Nothing => throw $ LoadError loc file FileNotFound case !(readFile ifile) of Right res => modifyAt SEEN (insert file) $> Just res - Left err => throw $ LoadError ifile err + Left err => throw $ LoadError loc ifile err mutual export covering - loadProcessFile : String -> FromParser (List NDefinition) - loadProcessFile file = - case !(lift $ loadFile file) of + loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition) + loadProcessFile loc file = + case !(lift $ loadFile loc file) of Just inp => do tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp concat <$> traverse fromPTopLevel tl @@ -324,26 +342,29 @@ mutual ||| populates the `defs` field of the state export covering - fromPTopLevel : PTopLevel -> FromParser (List NDefinition) - fromPTopLevel (PD decl) = lift $ fromPDecl decl - fromPTopLevel (PLoad file _) = loadProcessFile file + fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition) + fromPTopLevel (PD decl) = lift $ fromPDecl decl + fromPTopLevel (PLoad file loc) = loadProcessFile loc file export -fromParserPure : Definitions -> +fromParserPure : NameSuf -> Definitions -> Eff FromParserPure a -> - Either Error (a, Definitions) -fromParserPure defs act = + (Either Error (a, Definitions), NameSuf) +fromParserPure suf defs act = extract $ + runStateAt GEN suf $ runExcept $ evalStateAt NS [<] $ runStateAt DEFS defs act export fromParserIO : (MonadRec io, HasIO io) => - IncludePath -> IORef SeenFiles -> IORef Definitions -> - FromParser a -> io (Either Error a) -fromParserIO inc seen defs act = + IncludePath -> + IORef SeenFiles -> IORef NameSuf -> IORef Definitions -> + Eff FromParserIO a -> io (Either Error a) +fromParserIO inc seen suf defs act = runIO $ + runStateIORefAt GEN suf $ runExcept $ evalStateAt NS [<] $ runStateIORefAt SEEN seen $ diff --git a/lib/Quox/Parser/FromParser/Error.idr b/lib/Quox/Parser/FromParser/Error.idr index e23996b..6b0a885 100644 --- a/lib/Quox/Parser/FromParser/Error.idr +++ b/lib/Quox/Parser/FromParser/Error.idr @@ -18,33 +18,24 @@ ParseError = Parser.Error public export data Error = - AnnotationNeeded (NameContexts d n) (Term d n) - | DuplicatesInEnum (List TagVal) - | TermNotInScope Name - | DimNotInScope PBaseName - | QtyNotGlobal Qty - | DimNameInTerm PBaseName + AnnotationNeeded Loc (NameContexts d n) (Term d n) + | DuplicatesInEnum Loc (List TagVal) + | TermNotInScope Loc Name + | DimNotInScope Loc PBaseName + | QtyNotGlobal Loc Qty + | DimNameInTerm Loc PBaseName | WrapTypeError TypeError - | LoadError String FileError + | LoadError Loc String FileError | WrapParseError String ParseError parameters (unicode, showContext : Bool) - export - prettyBounds : String -> Bounds -> Doc HL - prettyBounds file (MkBounds l1 c1 l2 c2) = - hcat [hl Free $ pretty file, hl Delim ":", - hl TVar $ pretty l1, hl Delim ":", - hl DVar $ pretty c1, hl Delim "-", - hl TVar $ pretty l2, hl Delim ":", - hl DVar $ pretty c2] - export prettyParseError1 : String -> ParsingError _ -> Doc HL prettyParseError1 file (Error msg Nothing) = pretty msg prettyParseError1 file (Error msg (Just bounds)) = - asep [prettyBounds file bounds <+> hl Delim ":", pretty msg] + hsep [prettyLoc $ makeLoc file bounds, pretty msg] export prettyParseError : String -> ParseError -> Doc HL @@ -56,33 +47,38 @@ parameters (unicode, showContext : Bool) export prettyError : Error -> Doc HL - prettyError (AnnotationNeeded ctx tm) = - sep ["the term", prettyTerm unicode ctx.dnames ctx.tnames tm, + prettyError (AnnotationNeeded loc ctx tm) = + sep [prettyLoc loc <++> "the term", + prettyTerm unicode ctx.dnames ctx.tnames tm, "needs a type annotation"] -- [todo] print the original PTerm instead - prettyError (DuplicatesInEnum tags) = - sep ["duplicate tags in enum type", braces $ fillSep $ map pretty tags] + prettyError (DuplicatesInEnum loc tags) = + sep [prettyLoc loc <++> "duplicate tags in enum type", + braces $ fillSep $ map pretty tags] - prettyError (DimNotInScope i) = - sep ["dimension", pretty0 unicode $ DV $ fromString i, "not in scope"] + prettyError (DimNotInScope loc i) = + sep [prettyLoc loc <++> "dimension", + pretty0 unicode $ DV $ fromString i, "not in scope"] - prettyError (TermNotInScope x) = - sep ["term variable", pretty0 unicode $ F x {d = 0, n = 0}, "not in scope"] + prettyError (TermNotInScope loc x) = + sep [prettyLoc loc <++> "term variable", + hl Free $ pretty0 unicode x, "not in scope"] - prettyError (QtyNotGlobal pi) = - sep ["quantity", pretty0 unicode pi, + prettyError (QtyNotGlobal loc pi) = + sep [prettyLoc loc <++> "quantity", pretty0 unicode pi, "can't be used on a top level declaration"] - prettyError (DimNameInTerm i) = - sep ["dimension variable", pretty0 unicode $ DV $ fromString i, - "used in a term context"] + prettyError (DimNameInTerm loc i) = + sep [prettyLoc loc <++> "dimension variable", + pretty0 unicode $ DV $ fromString i, "used in a term context"] prettyError (WrapTypeError err) = Typing.prettyError unicode showContext $ trimContext 2 err - prettyError (LoadError str err) = - vsep [hsep ["couldn't load file", pretty str], fromString $ show err] + prettyError (LoadError loc str err) = + vsep [hsep [prettyLoc loc, "couldn't load file", pretty str], + fromString $ show err] prettyError (WrapParseError file err) = prettyParseError file err diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index b65c9d9..b27816f 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -36,7 +36,7 @@ lexParseWith grm input = do export withLoc : {c : Bool} -> FileName -> (Grammar c (Loc -> a)) -> Grammar c a withLoc fname act = bounds act <&> \res => - if res.isIrrelevant then res.val Nothing + if res.isIrrelevant then res.val noLoc else res.val $ makeLoc fname res.bounds export @@ -241,40 +241,40 @@ casePat fname = withLoc fname $ <|> delim "[" "]" [|PBox (patVar fname)|] <|> fatalError "invalid pattern" -export covering +export term : FileName -> Grammar True PTerm -- defined after all the subterm parsers -export covering +export typeLine : FileName -> Grammar True (PatVar, PTerm) typeLine fname = do resC "[" mustWork $ do i <- patVar fname <* resC "⇒" <|> unused fname - t <- term fname <* needRes "]" + t <- assert_total term fname <* needRes "]" pure (i, t) ||| box term `[t]` or type `[π.A]` -export covering +export boxTerm : FileName -> Grammar True PTerm boxTerm fname = withLoc fname $ do res "["; commit - q <- optional $ qty fname <* res "." - t <- mustWork $ term fname <* needRes "]" + q <- optional $ qty fname <* res "." + t <- mustWork $ assert_total term fname <* needRes "]" pure $ maybe (Box t) (\q => BOX q t) q ||| tuple term like `(a, b)`, or parenthesised single term. ||| allows terminating comma. more than two elements are nested on the right: ||| `(a, b, c, d) = (a, (b, (c, d)))`. -export covering +export tupleTerm : FileName -> Grammar True PTerm tupleTerm fname = withLoc fname $ do - terms <- delimSep1 "(" ")" "," $ term fname + terms <- delimSep1 "(" ")" "," $ assert_total term fname pure $ \loc => foldr1 (\s, t => Pair s t loc) terms ||| argument/atomic term: single-token terms, or those with delimiters e.g. ||| `[t]` -export covering +export termArg : FileName -> Grammar True PTerm termArg fname = withLoc fname $ [|TYPE universe1|] @@ -287,7 +287,7 @@ termArg fname = withLoc fname $ <|> [|V qname|] <|> const <$> tupleTerm fname -export covering +export coeTerm : FileName -> Grammar True PTerm coeTerm fname = withLoc fname $ do resC "coe" @@ -298,9 +298,11 @@ public export CompBranch : Type CompBranch = (DimConst, PatVar, PTerm) -export covering +export compBranch : FileName -> Grammar True CompBranch -compBranch fname = [|(,,) dimConst (patVar fname) (needRes "⇒" *> term fname)|] +compBranch fname = + [|(,,) dimConst (patVar fname) + (needRes "⇒" *> assert_total term fname)|] private checkCompTermBody : (PatVar, PTerm) -> PDim -> PDim -> PTerm -> PDim -> @@ -313,7 +315,7 @@ checkCompTermBody a p q s r (e0, s0) (e1, s1) bounds = (_, _) => fatalLoc bounds "body of 'comp' needs one 0 case and one 1 case" -export covering +export compTerm : FileName -> Grammar True PTerm compTerm fname = withLoc fname $ do resC "comp" @@ -328,27 +330,27 @@ compTerm fname = withLoc fname $ do let body = bounds $ mergeBounds bodyStart bodyEnd checkCompTermBody a p q s r s0 s1 body -export covering +export splitUniverseTerm : FileName -> Grammar True PTerm splitUniverseTerm fname = withLoc fname $ resC "★" *> mustWork [|TYPE nat|] -export covering +export eqTerm : FileName -> Grammar True PTerm eqTerm fname = withLoc fname $ resC "Eq" *> mustWork [|Eq (typeLine fname) (termArg fname) (termArg fname)|] -export covering +export succTerm : FileName -> Grammar True PTerm succTerm fname = withLoc fname $ resC "succ" *> mustWork [|Succ (termArg fname)|] ||| a dimension argument with an `@` prefix, or ||| a term argument with no prefix -export covering +export anyArg : FileName -> Grammar True (Either PDim PTerm) anyArg fname = dimArg fname <||> termArg fname -export covering +export normalAppTerm : FileName -> Grammar True PTerm normalAppTerm fname = withLoc fname $ do head <- termArg fname @@ -360,7 +362,7 @@ where ap : Loc -> PTerm -> Either PDim PTerm -> PTerm ||| application term `f x @y z`, or other terms that look like application ||| like `succ` or `coe`. -export covering +export appTerm : FileName -> Grammar True PTerm appTerm fname = coeTerm fname @@ -370,53 +372,55 @@ appTerm fname = <|> succTerm fname <|> normalAppTerm fname -export covering +export infixEqTerm : FileName -> Grammar True PTerm infixEqTerm fname = withLoc fname $ do l <- appTerm fname; commit - rest <- optional $ - res "≡" *> [|(,) (term fname) (needRes ":" *> appTerm fname)|] + rest <- optional $ res "≡" *> + [|(,) (assert_total term fname) (needRes ":" *> appTerm fname)|] let u = Unused $ onlyStart l.loc pure $ \loc => maybe l (\rest => Eq (u, snd rest) l (fst rest) loc) rest -export covering +export annTerm : FileName -> Grammar True PTerm annTerm fname = withLoc fname $ do tm <- infixEqTerm fname; commit - ty <- optional $ res "∷" *> term fname + ty <- optional $ res "∷" *> assert_total term fname pure $ \loc => maybe tm (\ty => Ann tm ty loc) ty -export covering +export lamTerm : FileName -> Grammar True PTerm lamTerm fname = withLoc fname $ do k <- DLam <$ res "δ" <|> Lam <$ res "λ" mustWork $ do - xs <- some $ patVar fname; needRes "⇒" - body <- term fname; commit + xs <- some $ patVar fname; needRes "⇒" + body <- assert_total term fname; commit pure $ \loc => foldr (\x, s => k x s loc) body xs -- [todo] fix the backtracking in e.g. (F x y z × B) -export covering +export properBinders : FileName -> Grammar True (List1 PatVar, PTerm) -properBinders fname = do +properBinders fname = assert_total $ do + -- putting assert_total directly on `term`, in this one function, + -- doesn't work. i cannot tell why res "(" xs <- some $ patVar fname; resC ":" t <- term fname; needRes ")" pure (xs, t) -export covering +export piTerm : FileName -> Grammar True PTerm piTerm fname = withLoc fname $ do - q <- qty fname; resC "." - dom <- piBinder; needRes "→" - cod <- term fname; commit + q <- qty fname; resC "." + dom <- piBinder; needRes "→" + cod <- assert_total term fname; commit pure $ \loc => foldr (\x, t => Pi q x (snd dom) t loc) cod (fst dom) where piBinder : Grammar True (List1 PatVar, PTerm) piBinder = properBinders fname <|> [|(,) [|singleton $ unused fname|] (termArg fname)|] -export covering +export sigmaTerm : FileName -> Grammar True PTerm sigmaTerm fname = (properBinders fname >>= continueDep) @@ -440,9 +444,10 @@ public export PCaseArm : Type PCaseArm = (PCasePat, PTerm) -export covering +export caseArm : FileName -> Grammar True PCaseArm -caseArm fname = [|(,) (casePat fname) (needRes "⇒" *> term fname)|] +caseArm fname = + [|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|] export checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody @@ -468,30 +473,30 @@ checkCaseArms loc ((PBox x _, rhs) :: rest) = if null rest then pure $ CaseBox x rhs loc else fatalError "unexpected pattern after box" -export covering +export caseBody : FileName -> Grammar True PCaseBody caseBody fname = do body <- bounds $ delimSep "{" "}" ";" $ caseArm fname let loc = makeLoc fname body.bounds checkCaseArms loc body.val -export covering +export caseReturn : FileName -> Grammar True (PatVar, PTerm) caseReturn fname = do x <- patVar fname <* resC "⇒" <|> unused fname - ret <- term fname + ret <- assert_total term fname pure (x, ret) -export covering +export caseTerm : FileName -> Grammar True PTerm caseTerm fname = withLoc fname $ do - qty <- caseIntro fname; commit - head <- mustWork $ term fname; needRes "return" - ret <- mustWork $ caseReturn fname; needRes "of" + qty <- caseIntro fname; commit + head <- mustWork $ assert_total term fname; needRes "return" + ret <- mustWork $ caseReturn fname; needRes "of" body <- mustWork $ caseBody fname pure $ Case qty head ret body --- export covering +-- export -- term : FileName -> Grammar True PTerm term fname = lamTerm fname <|> caseTerm fname @@ -499,7 +504,7 @@ term fname = lamTerm fname <|> sigmaTerm fname -export covering +export decl : FileName -> Grammar True PDecl ||| `def` alone means `defω` @@ -512,7 +517,7 @@ defIntro fname = let any = PQ Any $ makeLoc fname pos.bounds option any $ qty fname <* needRes "." -export covering +export definition : FileName -> Grammar True PDefinition definition fname = withLoc fname $ do qty <- defIntro fname @@ -522,7 +527,7 @@ definition fname = withLoc fname $ do optRes ";" pure $ MkPDef qty name type term -export covering +export namespace_ : FileName -> Grammar True PNamespace namespace_ fname = withLoc fname $ do ns <- resC "namespace" *> qname; needRes "{" @@ -531,28 +536,28 @@ namespace_ fname = withLoc fname $ do where nsInner : Grammar True (List PDecl) nsInner = [] <$ resC "}" - <|> [|(decl fname <* commit) :: nsInner|] + <|> [|(assert_total decl fname <* commit) :: assert_total nsInner|] decl fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|] -export covering +export load : FileName -> Grammar True PTopLevel load fname = withLoc fname $ resC "load" *> mustWork [|PLoad strLit|] <* optRes ";" -export covering +export topLevel : FileName -> Grammar True PTopLevel topLevel fname = load fname <|> [|PD $ decl fname|] -export covering +export input : FileName -> Grammar False (List PTopLevel) input fname = [] <$ eof - <|> [|(topLevel fname <* commit) :: input fname|] + <|> [|(topLevel fname <* commit) :: assert_total input fname|] -export covering +export lexParseTerm : FileName -> String -> Either Error PTerm lexParseTerm = lexParseWith . term -export covering +export lexParseInput : FileName -> String -> Either Error (List PTopLevel) lexParseInput = lexParseWith . input diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index c5a8648..59feadd 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -33,11 +33,14 @@ isUnused _ = False public export -data PQty = PQ Qty Loc +record PQty where + constructor PQ + val : Qty + loc_ : Loc %name PQty qty %runElab derive "PQty" [Eq, Ord, Show] -export Located PQty where (PQ _ loc).loc = loc +export Located PQty where q.loc = q.loc_ namespace PDim public export diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index e4f100e..b8cbac5 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -1,5 +1,6 @@ module Quox.Pretty +import Quox.Loc import Quox.Name import public Text.PrettyPrint.Prettyprinter.Doc @@ -200,6 +201,7 @@ pretty0 unicode = pretty0With unicode [<] [<] export PrettyHL BaseName where prettyM = pure . pretty . baseStr export PrettyHL Name where prettyM = pure . pretty . toDots +export PrettyHL BindName where prettyM = prettyM . name export @@ -278,3 +280,14 @@ epretty @{p} x = Evidence a (p, x) public export data Lit = L (Doc HL) export PrettyHL Lit where prettyM (L doc) = pure doc + + +export +prettyLoc : Loc -> Doc HL +prettyLoc (L NoLoc) = hl TVarErr "no location" <+> hl Delim ":" +prettyLoc (L (YesLoc file (MkBounds l1 c1 l2 c2))) = + hcat [hl Free $ pretty file, hl Delim ":", + hl TVar $ pretty l1, hl Delim ":", + hl DVar $ pretty c1, hl Delim "-", + hl TVar $ pretty l2, hl Delim ":", + hl DVar $ pretty c2, hl Delim ":"] diff --git a/lib/Quox/Reduce.idr b/lib/Quox/Reduce.idr index 19b76ff..46d346d 100644 --- a/lib/Quox/Reduce.idr +++ b/lib/Quox/Reduce.idr @@ -8,10 +8,25 @@ import Quox.Typing.Error import Data.SnocVect import Data.Maybe import Data.List +import Control.Eff %default total +-- [fixme] rename this to Whnf and the interface to CanWhnf +public export +WhnfM : Type -> Type +WhnfM = Eff [NameGen, Except Error] + +export +runWhnfWith : NameSuf -> WhnfM a -> (Either Error a, NameSuf) +runWhnfWith suf act = extract $ runStateAt GEN suf $ runExcept act + +export +runWhnf : WhnfM a -> Either Error a +runWhnf = fst . runWhnfWith 0 + + public export 0 RedexTest : TermLike -> Type RedexTest tm = {d, n : Nat} -> Definitions -> tm d n -> Bool @@ -21,12 +36,11 @@ interface Whnf (0 tm : TermLike) (0 isRedex : RedexTest tm) | tm where whnf : {d, n : Nat} -> (defs : Definitions) -> (ctx : WhnfContext d n) -> - tm d n -> Either Error (Subset (tm d n) (No . isRedex defs)) + tm d n -> WhnfM (Subset (tm d n) (No . isRedex defs)) public export %inline whnf0 : {d, n : Nat} -> {0 isRedex : RedexTest tm} -> Whnf tm isRedex => - (defs : Definitions) -> - WhnfContext d n -> tm d n -> Either Error (tm d n) + (defs : Definitions) -> WhnfContext d n -> tm d n -> WhnfM (tm d n) whnf0 defs ctx t = fst <$> whnf defs ctx t public export @@ -37,8 +51,7 @@ NotRedex defs = No . isRedex defs public export 0 NonRedex : (tm : TermLike) -> {isRedex : RedexTest tm} -> - Whnf tm isRedex => (d, n : Nat) -> - (defs : Definitions) -> Type + Whnf tm isRedex => (d, n : Nat) -> (defs : Definitions) -> Type NonRedex tm d n defs = Subset (tm d n) (NotRedex defs) public export %inline @@ -49,71 +62,71 @@ nred t = Element t nr public export %inline isLamHead : Elim {} -> Bool -isLamHead (Lam {} :# Pi {}) = True -isLamHead (Coe {}) = True -isLamHead _ = False +isLamHead (Ann (Lam {}) (Pi {}) _) = True +isLamHead (Coe {}) = True +isLamHead _ = False public export %inline isDLamHead : Elim {} -> Bool -isDLamHead (DLam {} :# Eq {}) = True -isDLamHead (Coe {}) = True -isDLamHead _ = False +isDLamHead (Ann (DLam {}) (Eq {}) _) = True +isDLamHead (Coe {}) = True +isDLamHead _ = False public export %inline isPairHead : Elim {} -> Bool -isPairHead (Pair {} :# Sig {}) = True -isPairHead (Coe {}) = True -isPairHead _ = False +isPairHead (Ann (Pair {}) (Sig {}) _) = True +isPairHead (Coe {}) = True +isPairHead _ = False public export %inline isTagHead : Elim {} -> Bool -isTagHead (Tag t :# Enum _) = True -isTagHead (Coe {}) = True -isTagHead _ = False +isTagHead (Ann (Tag {}) (Enum {}) _) = True +isTagHead (Coe {}) = True +isTagHead _ = False public export %inline isNatHead : Elim {} -> Bool -isNatHead (Zero :# Nat) = True -isNatHead (Succ n :# Nat) = True -isNatHead (Coe {}) = True -isNatHead _ = False +isNatHead (Ann (Zero {}) (Nat {}) _) = True +isNatHead (Ann (Succ {}) (Nat {}) _) = True +isNatHead (Coe {}) = True +isNatHead _ = False public export %inline isBoxHead : Elim {} -> Bool -isBoxHead (Box {} :# BOX {}) = True -isBoxHead (Coe {}) = True -isBoxHead _ = False +isBoxHead (Ann (Box {}) (BOX {}) _) = True +isBoxHead (Coe {}) = True +isBoxHead _ = False public export %inline isE : Term {} -> Bool -isE (E _) = True -isE _ = False +isE (E {}) = True +isE _ = False public export %inline isAnn : Elim {} -> Bool -isAnn (_ :# _) = True +isAnn (Ann {}) = True isAnn _ = False ||| true if a term is syntactically a type. public export %inline isTyCon : Term {} -> Bool -isTyCon (TYPE {}) = True -isTyCon (Pi {}) = True -isTyCon (Lam {}) = False -isTyCon (Sig {}) = True -isTyCon (Pair {}) = False -isTyCon (Enum {}) = True -isTyCon (Tag {}) = False -isTyCon (Eq {}) = True -isTyCon (DLam {}) = False -isTyCon Nat = True -isTyCon Zero = False -isTyCon (Succ {}) = False -isTyCon (BOX {}) = True -isTyCon (Box {}) = False -isTyCon (E {}) = False -isTyCon (CloT {}) = False -isTyCon (DCloT {}) = False +isTyCon (TYPE {}) = True +isTyCon (Pi {}) = True +isTyCon (Lam {}) = False +isTyCon (Sig {}) = True +isTyCon (Pair {}) = False +isTyCon (Enum {}) = True +isTyCon (Tag {}) = False +isTyCon (Eq {}) = True +isTyCon (DLam {}) = False +isTyCon (Nat {}) = True +isTyCon (Zero {}) = False +isTyCon (Succ {}) = False +isTyCon (BOX {}) = True +isTyCon (Box {}) = False +isTyCon (E {}) = False +isTyCon (CloT {}) = False +isTyCon (DCloT {}) = False ||| true if a term is syntactically a type, or a neutral. public export %inline @@ -123,23 +136,23 @@ isTyConE s = isTyCon s || isE s ||| true if a term is syntactically a type. public export %inline isAnnTyCon : Elim {} -> Bool -isAnnTyCon (ty :# TYPE _) = isTyCon ty -isAnnTyCon _ = False +isAnnTyCon (Ann ty (TYPE {}) _) = isTyCon ty +isAnnTyCon _ = False public export %inline isK : Dim d -> Bool -isK (K _) = True -isK _ = False +isK (K {}) = True +isK _ = False mutual public export isRedexE : RedexTest Elim - isRedexE defs (F x) {d, n} = + isRedexE defs (F {x, _}) {d, n} = isJust $ lookupElim x defs {d, n} - isRedexE _ (B _) = False - isRedexE defs (f :@ _) = - isRedexE defs f || isLamHead f + isRedexE _ (B {}) = False + isRedexE defs (App {fun, _}) = + isRedexE defs fun || isLamHead fun isRedexE defs (CasePair {pair, _}) = isRedexE defs pair || isPairHead pair isRedexE defs (CaseEnum {tag, _}) = @@ -148,10 +161,10 @@ mutual isRedexE defs nat || isNatHead nat isRedexE defs (CaseBox {box, _}) = isRedexE defs box || isBoxHead box - isRedexE defs (f :% p) = - isRedexE defs f || isDLamHead f || isK p - isRedexE defs (t :# a) = - isE t || isRedexT defs t || isRedexT defs a + isRedexE defs (DApp {fun, arg, _}) = + isRedexE defs fun || isDLamHead fun || isK arg + isRedexE defs (Ann {tm, ty, _}) = + isE tm || isRedexT defs tm || isRedexT defs ty isRedexE defs (Coe {val, _}) = isRedexT defs val || not (isE val) isRedexE defs (Comp {ty, r, _}) = @@ -165,7 +178,7 @@ mutual isRedexT : RedexTest Term isRedexT _ (CloT {}) = True isRedexT _ (DCloT {}) = True - isRedexT defs (E e) = isAnn e || isRedexE defs e + isRedexT defs (E {e, _}) = isAnn e || isRedexE defs e isRedexT _ _ = False @@ -203,508 +216,537 @@ dweakS by (S names (Y body)) = S names $ Y $ dweakT by body dweakS by (S names (N body)) = S names $ N $ dweakT by body private -coeScoped : {s : Nat} -> DScopeTerm d n -> Dim d -> Dim d -> +coeScoped : {s : Nat} -> DScopeTerm d n -> Dim d -> Dim d -> Loc -> ScopeTermN s d n -> ScopeTermN s d n -coeScoped ty p q (S names (Y body)) = - S names $ Y $ E $ Coe (weakDS s ty) p q body -coeScoped ty p q (S names (N body)) = - S names $ N $ E $ Coe ty p q body +coeScoped ty p q loc (S names (Y body)) = + S names $ Y $ E $ Coe (weakDS s ty) p q body loc +coeScoped ty p q loc (S names (N body)) = + S names $ N $ E $ Coe ty p q body loc -mutual - parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n) - ||| performs the minimum work required to recompute the type of an elim. - ||| - ||| ⚠ **assumes the elim is already typechecked.** ⚠ - export covering - computeElimType : (e : Elim d n) -> (0 ne : No (isRedexE defs e)) => - Either Error (Term d n) - computeElimType (F x) = do - let Just def = lookup x defs | Nothing => Left $ NotInScope x - pure $ def.type - computeElimType (B i) = pure $ ctx.tctx !! i - computeElimType (f :@ s) {ne} = do - -- can't use `expectPi` (or `expectEq` below) without making this - -- mutual block from hell even worse lol - Pi {arg, res, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne} - | t => Left $ ExpectedPi ctx.names t - pure $ sub1 res (s :# arg) - computeElimType (CasePair {pair, ret, _}) = pure $ sub1 ret pair - computeElimType (CaseEnum {tag, ret, _}) = pure $ sub1 ret tag - computeElimType (CaseNat {nat, ret, _}) = pure $ sub1 ret nat - computeElimType (CaseBox {box, ret, _}) = pure $ sub1 ret box - computeElimType (f :% p) {ne} = do - Eq {ty, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne} - | t => Left $ ExpectedEq ctx.names t - pure $ dsub1 ty p - computeElimType (Coe {ty, q, _}) = pure $ dsub1 ty q - computeElimType (Comp {ty, _}) = pure ty - computeElimType (TypeCase {ret, _}) = pure ret - computeElimType (_ :# ty) = pure ty - - parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext (S d) n) - ||| for π.(x : A) → B, returns (A, B); - ||| for an elim returns a pair of type-cases that will reduce to that; - ||| for other intro forms error - private covering - tycasePi : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) => - Either Error (Term (S d) n, ScopeTerm (S d) n) - tycasePi (Pi {arg, res, _}) = pure (arg, res) - tycasePi (E e) {tnf} = do - ty <- computeElimType defs ctx e @{noOr2 tnf} - let arg = E $ typeCase1Y e ty KPi [< "Arg", "Ret"] (BVT 1) - res' = typeCase1Y e (Arr Zero arg ty) KPi [< "Arg", "Ret"] (BVT 0) - res = SY [< "Arg"] $ E $ weakE 1 res' :@ BVT 0 - pure (arg, res) - tycasePi t = Left $ ExpectedPi ctx.names t - - ||| for (x : A) × B, returns (A, B); - ||| for an elim returns a pair of type-cases that will reduce to that; - ||| for other intro forms error - private covering - tycaseSig : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) => - Either Error (Term (S d) n, ScopeTerm (S d) n) - tycaseSig (Sig {fst, snd, _}) = pure (fst, snd) - tycaseSig (E e) {tnf} = do - ty <- computeElimType defs ctx e @{noOr2 tnf} - let fst = E $ typeCase1Y e ty KSig [< "Fst", "Snd"] (BVT 1) - snd' = typeCase1Y e (Arr Zero fst ty) KSig [< "Fst", "Snd"] (BVT 0) - snd = SY [< "Fst"] $ E $ weakE 1 snd' :@ BVT 0 - pure (fst, snd) - tycaseSig t = Left $ ExpectedSig ctx.names t - - ||| for [π. A], returns A; - ||| for an elim returns a type-case that will reduce to that; - ||| for other intro forms error - private covering - tycaseBOX : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) => - Either Error (Term (S d) n) - tycaseBOX (BOX _ a) = pure a - tycaseBOX (E e) {tnf} = do - ty <- computeElimType defs ctx e @{noOr2 tnf} - pure $ E $ typeCase1Y e ty KBOX [< "Ty"] (BVT 0) - tycaseBOX t = Left $ ExpectedBOX ctx.names t - - ||| for Eq [i ⇒ A] l r, returns (A‹0/i›, A‹1/i›, A, l, r); - ||| for an elim returns five type-cases that will reduce to that; - ||| for other intro forms error - private covering - tycaseEq : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) => - Either Error (Term (S d) n, Term (S d) n, DScopeTerm (S d) n, - Term (S d) n, Term (S d) n) - tycaseEq (Eq {ty, l, r}) = pure (ty.zero, ty.one, ty, l, r) - tycaseEq (E e) {tnf} = do - ty <- computeElimType defs ctx e @{noOr2 tnf} - let names = [< "A0", "A1", "A", "L", "R"] - a0 = E $ typeCase1Y e ty KEq names (BVT 4) - a1 = E $ typeCase1Y e ty KEq names (BVT 3) - a' = typeCase1Y e (Eq0 ty a0 a1) KEq names (BVT 2) - a = SY [< "i"] $ E $ dweakE 1 a' :% BV 0 - l = E $ typeCase1Y e a0 KEq names (BVT 1) - r = E $ typeCase1Y e a1 KEq names (BVT 0) - pure (a0, a1, a, l, r) - tycaseEq t = Left $ ExpectedEq ctx.names t - - -- new block because the functions below might pass a different ctx - -- into the ones above - parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n) - ||| reduce a function application `Coe ty p q val :@ s` - private covering - piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val, s : Term d n) -> - Either Error (Subset (Elim d n) (No . isRedexE defs)) - piCoe sty@(S [< i] ty) p q val s = do - -- (coe [i ⇒ π.(x : A) → B] @p @q t) s ⇝ - -- coe [i ⇒ B[𝒔‹i›/x] @p @q ((t ∷ (π.(x : A) → B)‹p/i›) 𝒔‹p›) - -- where 𝒔‹j› ≔ coe [i ⇒ A] @q @j s - -- - -- type-case is used to expose A,B if the type is neutral - let ctx1 = extendDim i ctx - Element ty tynf <- whnf defs ctx1 ty.term - (arg, res) <- tycasePi defs ctx1 ty - let s0 = CoeT i arg q p s - body = E $ (val :# (ty // one p)) :@ E s0 - s1 = CoeT i (arg // (BV 0 ::: shift 2)) (weakD 1 q) (BV 0) - (s // shift 1) - whnf defs ctx $ CoeT i (sub1 res s1) p q body - - ||| reduce a pair elimination `CasePair pi (Coe ty p q val) ret body` - private covering - sigCoe : (qty : Qty) -> - (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> - (ret : ScopeTerm d n) -> (body : ScopeTermN 2 d n) -> - Either Error (Subset (Elim d n) (No . isRedexE defs)) - sigCoe qty sty@(S [< i] ty) p q val ret body = do - -- caseπ (coe [i ⇒ (x : A) × B] @p @q s) return z ⇒ C of { (a, b) ⇒ e } - -- ⇝ - -- caseπ s ∷ ((x : A) × B)‹p/i› return z ⇒ C - -- of { (a, b) ⇒ - -- e[(coe [i ⇒ A] @p @q a)/a, - -- (coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i a)/x]] @p @q b)/b] } - -- - -- type-case is used to expose A,B if the type is neutral - let ctx1 = extendDim i ctx - Element ty tynf <- whnf defs ctx1 ty.term - (tfst, tsnd) <- tycaseSig defs ctx1 ty - let a' = CoeT i (weakT 2 tfst) p q (BVT 1) - tsnd' = tsnd.term // - (CoeT i (weakT 2 $ tfst // (BV 0 ::: shift 2)) - (weakD 1 p) (BV 0) (BVT 1) ::: shift 2) - b' = CoeT i tsnd' p q (BVT 0) - whnf defs ctx $ CasePair qty (val :# (ty // one p)) ret $ - ST body.names $ body.term // (a' ::: b' ::: shift 2) - - ||| reduce a dimension application `Coe ty p q val :% r` - private covering - eqCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> - (r : Dim d) -> - Either Error (Subset (Elim d n) (No . isRedexE defs)) - eqCoe sty@(S [< j] ty) p q val r = do - -- (coe [j ⇒ Eq [i ⇒ A] L R] @p @q eq) @r - -- ⇝ - -- comp [j ⇒ A‹r/i›] @p @q (eq ∷ (Eq [i ⇒ A] L R)‹p/j›) - -- { (r=0) j ⇒ L; (r=1) j ⇒ R } - let ctx1 = extendDim j ctx - Element ty tynf <- whnf defs ctx1 ty.term - (a0, a1, a, s, t) <- tycaseEq defs ctx1 ty - let a' = dsub1 a (weakD 1 r) - val' = E $ (val :# (ty // one p)) :% r - whnf defs ctx $ CompH j a' p q val' r j s j t - - ||| reduce a pair elimination `CaseBox pi (Coe ty p q val) ret body` - private covering - boxCoe : (qty : Qty) -> - (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> - (ret : ScopeTerm d n) -> (body : ScopeTerm d n) -> - Either Error (Subset (Elim d n) (No . isRedexE defs)) - boxCoe qty sty@(S [< i] ty) p q val ret body = do - -- caseπ (coe [i ⇒ [ρ. A]] @p @q s) return z ⇒ C of { [a] ⇒ e } - -- ⇝ - -- caseπ s ∷ [ρ. A]‹p/i› return z ⇒ C - -- of { [a] ⇒ e[(coe [i ⇒ A] p q a)/a] } - let ctx1 = extendDim i ctx - Element ty tynf <- whnf defs ctx1 ty.term - ta <- tycaseBOX defs ctx1 ty - let a' = CoeT i (weakT 1 ta) p q $ BVT 0 - whnf defs ctx $ CaseBox qty (val :# (ty // one p)) ret $ - ST body.names $ body.term // (a' ::: shift 1) +export covering +Whnf Term Reduce.isRedexT +export covering +Whnf Elim Reduce.isRedexE +parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n) + ||| performs the minimum work required to recompute the type of an elim. + ||| + ||| ⚠ **assumes the elim is already typechecked.** ⚠ export covering - Whnf Elim Reduce.isRedexE where - whnf defs ctx (F x) with (lookupElim x defs) proof eq - _ | Just y = whnf defs ctx y - _ | Nothing = pure $ Element (F x) $ rewrite eq in Ah + computeElimType : (e : Elim d n) -> (0 ne : No (isRedexE defs e)) => + WhnfM (Term d n) + computeElimType (F {x, loc}) = do + let Just def = lookup x defs | Nothing => throw $ NotInScope loc x + pure $ def.type + computeElimType (B {i, _}) = pure $ ctx.tctx !! i + computeElimType (App {fun = f, arg = s, loc}) {ne} = do + Pi {arg, res, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne} + | t => throw $ ExpectedPi loc ctx.names t + pure $ sub1 res $ Ann s arg loc + computeElimType (CasePair {pair, ret, _}) = pure $ sub1 ret pair + computeElimType (CaseEnum {tag, ret, _}) = pure $ sub1 ret tag + computeElimType (CaseNat {nat, ret, _}) = pure $ sub1 ret nat + computeElimType (CaseBox {box, ret, _}) = pure $ sub1 ret box + computeElimType (DApp {fun = f, arg = p, loc}) {ne} = do + Eq {ty, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne} + | t => throw $ ExpectedEq loc ctx.names t + pure $ dsub1 ty p + computeElimType (Coe {ty, q, _}) = pure $ dsub1 ty q + computeElimType (Comp {ty, _}) = pure ty + computeElimType (TypeCase {ret, _}) = pure ret + computeElimType (Ann {ty, _}) = pure ty - whnf _ _ (B i) = pure $ nred $ B i +parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext (S d) n) + ||| for π.(x : A) → B, returns (A, B); + ||| for an elim returns a pair of type-cases that will reduce to that; + ||| for other intro forms error + private covering + tycasePi : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) => + WhnfM (Term (S d) n, ScopeTerm (S d) n) + tycasePi (Pi {arg, res, _}) = pure (arg, res) + tycasePi (E e) {tnf} = do + ty <- computeElimType defs ctx e @{noOr2 tnf} + let loc = e.loc + narg = mnb "Arg"; nret = mnb "Ret" + arg = E $ typeCase1Y e ty KPi [< !narg, !nret] (BVT 1 loc) loc + res' = typeCase1Y e (Arr Zero arg ty loc) KPi [< !narg, !nret] + (BVT 0 loc) loc + res = SY [< !narg] $ E $ App (weakE 1 res') (BVT 0 loc) loc + pure (arg, res) + tycasePi t = throw $ ExpectedPi t.loc ctx.names t - -- ((λ x ⇒ t) ∷ (π.x : A) → B) s ⇝ t[s∷A/x] ∷ B[s∷A/x] - whnf defs ctx (f :@ s) = do - Element f fnf <- whnf defs ctx f - case nchoose $ isLamHead f of - Left _ => case f of - Lam body :# Pi {arg, res, _} => - let s = s :# arg in - whnf defs ctx $ sub1 body s :# sub1 res s - Coe ty p q val => piCoe defs ctx ty p q val s - Right nlh => pure $ Element (f :@ s) $ fnf `orNo` nlh + ||| for (x : A) × B, returns (A, B); + ||| for an elim returns a pair of type-cases that will reduce to that; + ||| for other intro forms error + private covering + tycaseSig : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) => + WhnfM (Term (S d) n, ScopeTerm (S d) n) + tycaseSig (Sig {fst, snd, _}) = pure (fst, snd) + tycaseSig (E e) {tnf} = do + ty <- computeElimType defs ctx e @{noOr2 tnf} + let loc = e.loc + nfst = mnb "Fst"; nsnd = mnb "Snd" + fst = E $ typeCase1Y e ty KSig [< !nfst, !nsnd] (BVT 1 loc) loc + snd' = typeCase1Y e (Arr Zero fst ty loc) KSig [< !nfst, !nsnd] + (BVT 0 loc) loc + snd = SY [< !nfst] $ E $ App (weakE 1 snd') (BVT 0 loc) loc + pure (fst, snd) + tycaseSig t = throw $ ExpectedSig t.loc ctx.names t - -- case (s, t) ∷ (x : A) × B return p ⇒ C of { (a, b) ⇒ u } ⇝ - -- u[s∷A/a, t∷B[s∷A/x]] ∷ C[(s, t)∷((x : A) × B)/p] - whnf defs ctx (CasePair pi pair ret body) = do - Element pair pairnf <- whnf defs ctx pair - case nchoose $ isPairHead pair of - Left _ => case pair of - Pair {fst, snd} :# Sig {fst = tfst, snd = tsnd, _} => - let fst = fst :# tfst - snd = snd :# sub1 tsnd fst - in - whnf defs ctx $ subN body [< fst, snd] :# sub1 ret pair - Coe ty p q val => do - sigCoe defs ctx pi ty p q val ret body - Right np => - pure $ Element (CasePair pi pair ret body) $ pairnf `orNo` np + ||| for [π. A], returns A; + ||| for an elim returns a type-case that will reduce to that; + ||| for other intro forms error + private covering + tycaseBOX : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) => + WhnfM (Term (S d) n) + tycaseBOX (BOX {ty, _}) = pure ty + tycaseBOX (E e) {tnf} = do + ty <- computeElimType defs ctx e @{noOr2 tnf} + pure $ E $ typeCase1Y e ty KBOX [< !(mnb "Ty")] (BVT 0 e.loc) e.loc + tycaseBOX t = throw $ ExpectedBOX t.loc ctx.names t - -- case 'a ∷ {a,…} return p ⇒ C of { 'a ⇒ u } ⇝ - -- u ∷ C['a∷{a,…}/p] - whnf defs ctx (CaseEnum pi tag ret arms) = do - Element tag tagnf <- whnf defs ctx tag - case nchoose $ isTagHead tag of - Left t => case tag of - Tag t :# Enum ts => - let ty = sub1 ret tag in - case lookup t arms of - Just arm => whnf defs ctx $ arm :# ty - Nothing => Left $ MissingEnumArm t (keys arms) - Coe ty p q val => - -- there is nowhere an equality can be hiding inside an Enum - whnf defs ctx $ CaseEnum pi (val :# dsub1 ty q) ret arms - Right nt => - pure $ Element (CaseEnum pi tag ret arms) $ tagnf `orNo` nt + ||| for Eq [i ⇒ A] l r, returns (A‹0/i›, A‹1/i›, A, l, r); + ||| for an elim returns five type-cases that will reduce to that; + ||| for other intro forms error + private covering + tycaseEq : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) => + WhnfM (Term (S d) n, Term (S d) n, DScopeTerm (S d) n, + Term (S d) n, Term (S d) n) + tycaseEq (Eq {ty, l, r, _}) = pure (ty.zero, ty.one, ty, l, r) + tycaseEq (E e) {tnf} = do + ty <- computeElimType defs ctx e @{noOr2 tnf} + let loc = e.loc + names = traverse' (\x => mnb x) [< "A0", "A1", "A", "L", "R"] + a0 = E $ typeCase1Y e ty KEq !names (BVT 4 loc) loc + a1 = E $ typeCase1Y e ty KEq !names (BVT 3 loc) loc + a' = typeCase1Y e (Eq0 ty a0 a1 loc) KEq !names (BVT 2 loc) loc + a = SY [< !(mnb "i")] $ E $ DApp (dweakE 1 a') (B VZ loc) loc + l = E $ typeCase1Y e a0 KEq !names (BVT 1 loc) loc + r = E $ typeCase1Y e a1 KEq !names (BVT 0 loc) loc + pure (a0, a1, a, l, r) + tycaseEq t = throw $ ExpectedEq t.loc ctx.names t - -- case zero ∷ ℕ return p ⇒ C of { zero ⇒ u; … } ⇝ - -- u ∷ C[zero∷ℕ/p] +-- new block because the functions below might pass a different ctx +-- into the ones above +parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n) + ||| reduce a function application `App (Coe ty p q val) s loc` + private covering + piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> + (val, s : Term d n) -> Loc -> + WhnfM (Subset (Elim d n) (No . isRedexE defs)) + piCoe sty@(S [< i] ty) p q val s loc = do + -- (coe [i ⇒ π.(x : A) → B] @p @q t) s ⇝ + -- coe [i ⇒ B[𝒔‹i›/x] @p @q ((t ∷ (π.(x : A) → B)‹p/i›) 𝒔‹p›) + -- where 𝒔‹j› ≔ coe [i ⇒ A] @q @j s -- - -- case succ n ∷ ℕ return p ⇒ C of { succ n', π.ih ⇒ u; … } ⇝ - -- u[n∷ℕ/n', (case n ∷ ℕ ⋯)/ih] ∷ C[succ n ∷ ℕ/p] - whnf defs ctx (CaseNat pi piIH nat ret zer suc) = do - Element nat natnf <- whnf defs ctx nat - case nchoose $ isNatHead nat of - Left _ => - let ty = sub1 ret nat in - case nat of - Zero :# Nat => whnf defs ctx (zer :# ty) - Succ n :# Nat => - let nn = n :# Nat - tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc] - in - whnf defs ctx $ tm :# ty - Coe ty p q val => - -- same deal as Enum - whnf defs ctx $ CaseNat pi piIH (val :# dsub1 ty q) ret zer suc - Right nn => - pure $ Element (CaseNat pi piIH nat ret zer suc) $ natnf `orNo` nn + -- type-case is used to expose A,B if the type is neutral + let ctx1 = extendDim i ctx + Element ty tynf <- whnf defs ctx1 ty.term + (arg, res) <- tycasePi defs ctx1 ty + let s0 = CoeT i arg q p s s.loc + body = E $ App (Ann val (ty // one p) val.loc) (E s0) loc + s1 = CoeT i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc) + (s // shift 1) s.loc + whnf defs ctx $ CoeT i (sub1 res s1) p q body loc - -- case [t] ∷ [π.A] return p ⇒ C of { [x] ⇒ u } ⇝ - -- u[t∷A/x] ∷ C[[t] ∷ [π.A]/p] - whnf defs ctx (CaseBox pi box ret body) = do - Element box boxnf <- whnf defs ctx box - case nchoose $ isBoxHead box of - Left _ => case box of - Box val :# BOX q bty => - let ty = sub1 ret box in - whnf defs ctx $ sub1 body (val :# bty) :# ty - Coe ty p q val => - boxCoe defs ctx pi ty p q val ret body - Right nb => - pure $ Element (CaseBox pi box ret body) $ boxnf `orNo` nb - - -- ((δ 𝑖 ⇒ s) ∷ Eq [𝑗 ⇒ A] t u) @0 ⇝ t ∷ A‹0/𝑗› - -- ((δ 𝑖 ⇒ s) ∷ Eq [𝑗 ⇒ A] t u) @1 ⇝ u ∷ A‹1/𝑗› - -- ((δ 𝑖 ⇒ s) ∷ Eq [𝑗 ⇒ A] t u) @𝑘 ⇝ s‹𝑘/𝑖› ∷ A‹𝑘/𝑗› - -- (if 𝑘 is a variable) - whnf defs ctx (f :% p) = do - Element f fnf <- whnf defs ctx f - case nchoose $ isDLamHead f of - Left _ => case f of - DLam body :# Eq {ty = ty, l, r, _} => - let body = endsOr l r (dsub1 body p) p in - whnf defs ctx $ body :# dsub1 ty p - Coe ty p' q' val => - eqCoe defs ctx ty p' q' val p - Right ndlh => case p of - K e => do - Eq {l, r, ty, _} <- whnf0 defs ctx =<< computeElimType defs ctx f - | ty => Left $ ExpectedEq ctx.names ty - whnf defs ctx $ ends (l :# ty.zero) (r :# ty.one) e - B _ => pure $ Element (f :% p) $ fnf `orNo` ndlh `orNo` Ah - - -- e ∷ A ⇝ e - whnf defs ctx (s :# a) = do - Element s snf <- whnf defs ctx s - case nchoose $ isE s of - Left _ => let E e = s in pure $ Element e $ noOr2 snf - Right ne => do - Element a anf <- whnf defs ctx a - pure $ Element (s :# a) $ ne `orNo` snf `orNo` anf - - whnf defs ctx (Coe (S _ (N ty)) _ _ val) = - whnf defs ctx $ val :# ty - whnf defs ctx (Coe (S [< i] ty) p q val) = do - Element ty tynf <- whnf defs (extendDim i ctx) ty.term - Element val valnf <- whnf defs ctx val - pushCoe defs ctx i ty p q val - - whnf defs ctx (Comp ty p q val r zero one) = - -- comp [A] @p @p s { ⋯ } ⇝ s ∷ A - if p == q then whnf defs ctx $ val :# ty else - case nchoose (isK r) of - -- comp [A] @p @q s { (0=0) j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A - -- comp [A] @p @q s { (1=1) j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A - Left y => case r of - K Zero => whnf defs ctx $ dsub1 zero q :# ty - K One => whnf defs ctx $ dsub1 one q :# ty - Right nk => do - Element ty tynf <- whnf defs ctx ty - pure $ Element (Comp ty p q val r zero one) $ tynf `orNo` nk - -- [todo] anything other than just the boundaries?? - - whnf defs ctx (TypeCase ty ret arms def) = do - Element ty tynf <- whnf defs ctx ty - Element ret retnf <- whnf defs ctx ret - case nchoose $ isAnnTyCon ty of - Left y => let ty :# TYPE u = ty in - reduceTypeCase defs ctx ty u ret arms def - Right nt => pure $ Element (TypeCase ty ret arms def) $ - tynf `orNo` retnf `orNo` nt - - whnf defs ctx (CloE (Sub el th)) = whnf defs ctx $ pushSubstsWith' id th el - whnf defs ctx (DCloE (Sub el th)) = whnf defs ctx $ pushSubstsWith' th id el - - export covering - Whnf Term Reduce.isRedexT where - whnf _ _ t@(TYPE {}) = pure $ nred t - whnf _ _ t@(Pi {}) = pure $ nred t - whnf _ _ t@(Lam {}) = pure $ nred t - whnf _ _ t@(Sig {}) = pure $ nred t - whnf _ _ t@(Pair {}) = pure $ nred t - whnf _ _ t@(Enum {}) = pure $ nred t - 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 _ _ t@(BOX {}) = pure $ nred t - whnf _ _ t@(Box {}) = pure $ nred t - - -- s ∷ A ⇝ s (in term context) - whnf defs ctx (E e) = do - Element e enf <- whnf defs ctx e - case nchoose $ isAnn e of - Left _ => let tm :# _ = e in pure $ Element tm $ noOr1 $ noOr2 enf - Right na => pure $ Element (E e) $ na `orNo` enf - - whnf defs ctx (CloT (Sub tm th)) = whnf defs ctx $ pushSubstsWith' id th tm - whnf defs ctx (DCloT (Sub tm th)) = whnf defs ctx $ pushSubstsWith' th id tm - - ||| reduce a type-case applied to a type constructor + ||| reduce a pair elimination `CasePair pi (Coe ty p q val) ret body loc` private covering - reduceTypeCase : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n -> - (ty : Term d n) -> (u : Universe) -> (ret : Term d n) -> - (arms : TypeCaseArms d n) -> (def : Term d n) -> - (0 _ : So (isTyCon ty)) => - Either Error (Subset (Elim d n) (No . isRedexE defs)) - reduceTypeCase defs ctx ty u ret arms def = case ty of - -- (type-case ★ᵢ ∷ _ return Q of { ★ ⇒ s; ⋯ }) ⇝ s ∷ Q - TYPE _ => - whnf defs ctx $ tycaseRhsDef0 def KTYPE arms :# ret + sigCoe : (qty : Qty) -> + (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> + (ret : ScopeTerm d n) -> (body : ScopeTermN 2 d n) -> Loc -> + WhnfM (Subset (Elim d n) (No . isRedexE defs)) + sigCoe qty sty@(S [< i] ty) p q val ret body loc = do + -- caseπ (coe [i ⇒ (x : A) × B] @p @q s) return z ⇒ C of { (a, b) ⇒ e } + -- ⇝ + -- caseπ s ∷ ((x : A) × B)‹p/i› return z ⇒ C + -- of { (a, b) ⇒ + -- e[(coe [i ⇒ A] @p @q a)/a, + -- (coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i a)/x]] @p @q b)/b] } + -- + -- type-case is used to expose A,B if the type is neutral + let ctx1 = extendDim i ctx + Element ty tynf <- whnf defs ctx1 ty.term + (tfst, tsnd) <- tycaseSig defs ctx1 ty + let [< x, y] = body.names + a' = CoeT i (weakT 2 tfst) p q (BVT 1 noLoc) x.loc + tsnd' = tsnd.term // + (CoeT i (weakT 2 $ tfst // (B VZ noLoc ::: shift 2)) + (weakD 1 p) (B VZ noLoc) (BVT 1 noLoc) y.loc ::: shift 2) + b' = CoeT i tsnd' p q (BVT 0 noLoc) y.loc + whnf defs ctx $ CasePair qty (Ann val (ty // one p) val.loc) ret + (ST body.names $ body.term // (a' ::: b' ::: shift 2)) loc - -- (type-case π.(x : A) → B ∷ ★ᵢ return Q of { (a → b) ⇒ s; ⋯ }) ⇝ - -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ ★ᵢ - Pi _ arg res => - let arg = arg :# TYPE u - res = Lam res :# Arr Zero (TYPE u) (TYPE u) - in - whnf defs ctx $ subN (tycaseRhsDef def KPi arms) [< arg, res] :# ret - - -- (type-case (x : A) × B ∷ ★ᵢ return Q of { (a × b) ⇒ s; ⋯ }) ⇝ - -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ ★ᵢ - Sig fst snd => - let fst = fst :# TYPE u - snd = Lam snd :# Arr Zero (TYPE u) (TYPE u) - in - whnf defs ctx $ subN (tycaseRhsDef def KSig arms) [< fst, snd] :# ret - - -- (type-case {⋯} ∷ _ return Q of { {} ⇒ s; ⋯ }) ⇝ s ∷ Q - Enum _ => - whnf defs ctx $ tycaseRhsDef0 def KEnum arms :# ret - - -- (type-case Eq [i ⇒ A] L R ∷ ★ᵢ return Q - -- of { Eq a₀ a₁ a l r ⇒ s; ⋯ }) ⇝ - -- s[(A‹0/i› ∷ ★ᵢ)/a₀, (A‹1/i› ∷ ★ᵢ)/a₁, - -- ((δ i ⇒ A) ∷ Eq [★ᵢ] A‹0/i› A‹1/i›)/a, - -- (L ∷ A‹0/i›)/l, (R ∷ A‹1/i›)/r] ∷ Q - Eq a l r => - let a0 = a.zero; a1 = a.one in - whnf defs ctx $ - subN (tycaseRhsDef def KEq arms) - [< a0 :# TYPE u, a1 :# TYPE u, - DLam a :# Eq0 (TYPE u) a0 a1, l :# a0, r :# a1] - :# ret - - -- (type-case ℕ ∷ _ return Q of { ℕ ⇒ s; ⋯ }) ⇝ s ∷ Q - Nat => - whnf defs ctx $ tycaseRhsDef0 def KNat arms :# ret - - -- (type-case [π.A] ∷ ★ᵢ return Q of { [a] ⇒ s; ⋯ }) ⇝ s[(A ∷ ★ᵢ)/a] ∷ Q - BOX _ s => - whnf defs ctx $ sub1 (tycaseRhsDef def KBOX arms) (s :# TYPE u) :# ret - - ||| pushes a coercion inside a whnf-ed term + ||| reduce a dimension application `DApp (Coe ty p q val) r loc` private covering - pushCoe : {n, d : Nat} -> (defs : Definitions) -> WhnfContext d n -> - BaseName -> - (ty : Term (S d) n) -> (0 tynf : No (isRedexT defs ty)) => - Dim d -> Dim d -> - (s : Term d n) -> (0 snf : No (isRedexT defs s)) => - Either Error (NonRedex Elim d n defs) - pushCoe defs ctx i ty p q s = - if p == q then whnf defs ctx $ s :# (ty // one q) else - case s of - -- (coe [_ ⇒ ★ᵢ] @_ @_ ty) ⇝ (ty ∷ ★ᵢ) - TYPE {} => pure $ nred $ s :# TYPE !(unwrapTYPE ty) - Pi {} => pure $ nred $ s :# TYPE !(unwrapTYPE ty) - Sig {} => pure $ nred $ s :# TYPE !(unwrapTYPE ty) - Enum {} => pure $ nred $ s :# TYPE !(unwrapTYPE ty) - Eq {} => pure $ nred $ s :# TYPE !(unwrapTYPE ty) - Nat => pure $ nred $ s :# TYPE !(unwrapTYPE ty) - BOX {} => pure $ nred $ s :# TYPE !(unwrapTYPE ty) + eqCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> + (r : Dim d) -> Loc -> + WhnfM (Subset (Elim d n) (No . isRedexE defs)) + eqCoe sty@(S [< j] ty) p q val r loc = do + -- (coe [j ⇒ Eq [i ⇒ A] L R] @p @q eq) @r + -- ⇝ + -- comp [j ⇒ A‹r/i›] @p @q (eq ∷ (Eq [i ⇒ A] L R)‹p/j›) + -- @r { 0 j ⇒ L; 1 j ⇒ R } + let ctx1 = extendDim j ctx + Element ty tynf <- whnf defs ctx1 ty.term + (a0, a1, a, s, t) <- tycaseEq defs ctx1 ty + let a' = dsub1 a (weakD 1 r) + val' = E $ DApp (Ann val (ty // one p) val.loc) r loc + whnf defs ctx $ CompH j a' p q val' r j s j t loc - -- just η expand it. then whnf for (:@) will handle it later - -- this is how @xtt does it - Lam body => do - let body' = CoeT i ty p q $ Lam body - term' = [< "y"] :\\ E (weakE 1 body' :@ BVT 0) - type' = ty // one q - whnf defs ctx $ term' :# type' + ||| reduce a pair elimination `CaseBox pi (Coe ty p q val) ret body` + private covering + boxCoe : (qty : Qty) -> + (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> + (ret : ScopeTerm d n) -> (body : ScopeTerm d n) -> Loc -> + WhnfM (Subset (Elim d n) (No . isRedexE defs)) + boxCoe qty sty@(S [< i] ty) p q val ret body loc = do + -- caseπ (coe [i ⇒ [ρ. A]] @p @q s) return z ⇒ C of { [a] ⇒ e } + -- ⇝ + -- caseπ s ∷ [ρ. A]‹p/i› return z ⇒ C + -- of { [a] ⇒ e[(coe [i ⇒ A] p q a)/a] } + let ctx1 = extendDim i ctx + Element ty tynf <- whnf defs ctx1 ty.term + ta <- tycaseBOX defs ctx1 ty + let a' = CoeT i (weakT 1 ta) p q (BVT 0 noLoc) body.name.loc + whnf defs ctx $ CaseBox qty (Ann val (ty // one p) val.loc) ret + (ST body.names $ body.term // (a' ::: shift 1)) loc - {- - -- maybe: - -- (coe [i ⇒ π.(x : A) → B] @p @q (λ x ⇒ s)) ⇝ - -- (λ x ⇒ coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @q @i x)/x]] @p @q s) - -- ∷ (π.(x: A‹q/i›) → B‹q/i›) - Lam body => do - let Pi {qty, arg, res} = ty - | _ => Left $ ?err - let arg' = ST [< "j"] $ weakT 1 $ arg // (BV 0 ::: shift 2) - res' = ST [< i] $ res.term // - (Coe arg' (weakD 1 q) (BV 0) (BVT 0) ::: shift 1) - body = ST body.names $ E $ Coe res' p q body.term - pure $ Element (Lam body :# Pi qty (arg // one q) (res // one q)) Ah - -} - -- (coe [i ⇒ (x : A) × B] @p @q (s, t)) ⇝ - -- (coe [i ⇒ A] @p @q s, - -- coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i s)/x]] @p @q t) - -- ∷ (x : A‹q/i›) × B‹q/i› - -- - -- can't use η here because... it doesn't exist - Pair fst snd => do - let Sig {fst = tfst, snd = tsnd} = ty - | _ => Left $ ExpectedSig (extendDim i ctx.names) ty - let fst' = E $ CoeT i tfst p q fst - tfst' = tfst // (BV 0 ::: shift 2) - tsnd' = sub1 tsnd $ CoeT "j" tfst' (weakD 1 p) (BV 0) $ dweakT 1 fst - snd' = E $ CoeT i tsnd' p q snd - pure $ - Element (Pair fst' snd' :# Sig (tfst // one q) (tsnd // one q)) Ah +||| reduce a type-case applied to a type constructor +private covering +reduceTypeCase : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n -> + (ty : Term d n) -> (u : Universe) -> (ret : Term d n) -> + (arms : TypeCaseArms d n) -> (def : Term d n) -> + (0 _ : So (isTyCon ty)) => Loc -> + WhnfM (Subset (Elim d n) (No . isRedexE defs)) +reduceTypeCase defs ctx ty u ret arms def loc = case ty of + -- (type-case ★ᵢ ∷ _ return Q of { ★ ⇒ s; ⋯ }) ⇝ s ∷ Q + TYPE {} => + whnf defs ctx $ Ann (tycaseRhsDef0 def KTYPE arms) ret loc - -- η expand like λ - DLam body => do - let body' = CoeT i ty p q $ DLam body - term' = [< "j"] :\\% E (dweakE 1 body' :% BV 0) - type' = ty // one q - whnf defs ctx $ term' :# type' + -- (type-case π.(x : A) → B ∷ ★ᵢ return Q of { (a → b) ⇒ s; ⋯ }) ⇝ + -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q + Pi {arg, res, loc = piLoc, _} => + let arg' = Ann arg (TYPE u noLoc) arg.loc + res' = Ann (Lam res res.loc) + (Arr Zero arg (TYPE u noLoc) arg.loc) res.loc + in + whnf defs ctx $ + Ann (subN (tycaseRhsDef def KPi arms) [< arg', res']) ret loc - -- (coe [_ ⇒ {⋯}] @_ @_ t) ⇝ (t ∷ {⋯}) - Tag tag => do - let Enum ts = ty - | _ => Left $ ExpectedEnum (extendDim i ctx.names) ty - pure $ Element (Tag tag :# Enum ts) Ah + -- (type-case (x : A) × B ∷ ★ᵢ return Q of { (a × b) ⇒ s; ⋯ }) ⇝ + -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q + Sig {fst, snd, loc = sigLoc, _} => + let fst' = Ann fst (TYPE u noLoc) fst.loc + snd' = Ann (Lam snd snd.loc) + (Arr Zero fst (TYPE u noLoc) fst.loc) snd.loc + in + whnf defs ctx $ + Ann (subN (tycaseRhsDef def KSig arms) [< fst', snd']) ret loc - -- (coe [_ ⇒ ℕ] @_ @_ n) ⇝ (n ∷ ℕ) - Zero => pure $ Element (Zero :# Nat) Ah - Succ t => pure $ Element (Succ t :# Nat) Ah + -- (type-case {⋯} ∷ _ return Q of { {} ⇒ s; ⋯ }) ⇝ s ∷ Q + Enum {} => + whnf defs ctx $ Ann (tycaseRhsDef0 def KEnum arms) ret loc - -- (coe [i ⇒ [π.A]] @p @q [s]) ⇝ - -- [coe [i ⇒ A] @p @q s] ∷ [π. A‹q/i›] - Box val => do - let BOX {qty, ty = a} = ty - | _ => Left $ ExpectedBOX (extendDim i ctx.names) ty - pure $ Element (Box (E $ CoeT i a p q s) :# BOX qty (a // one q)) Ah + -- (type-case Eq [i ⇒ A] L R ∷ ★ᵢ return Q + -- of { Eq a₀ a₁ a l r ⇒ s; ⋯ }) ⇝ + -- s[(A‹0/i› ∷ ★ᵢ)/a₀, (A‹1/i› ∷ ★ᵢ)/a₁, + -- ((δ i ⇒ A) ∷ Eq [★ᵢ] A‹0/i› A‹1/i›)/a, + -- (L ∷ A‹0/i›)/l, (R ∷ A‹1/i›)/r] ∷ Q + Eq {ty = a, l, r, loc = eqLoc, _} => + let a0 = a.zero; a1 = a.one in + whnf defs ctx $ Ann + (subN (tycaseRhsDef def KEq arms) + [< Ann a0 (TYPE u noLoc) a.loc, Ann a1 (TYPE u noLoc) a.loc, + Ann (DLam a a.loc) (Eq0 (TYPE u noLoc) a0 a1 a.loc) a.loc, + Ann l a0 l.loc, Ann r a1 r.loc]) + ret loc - E e => pure $ Element (CoeT i ty p q (E e)) (snf `orNo` Ah) - where - unwrapTYPE : Term (S d) n -> Either Error Universe - unwrapTYPE (TYPE u) = pure u - unwrapTYPE ty = Left $ ExpectedTYPE (extendDim i ctx.names) ty + -- (type-case ℕ ∷ _ return Q of { ℕ ⇒ s; ⋯ }) ⇝ s ∷ Q + Nat {} => + whnf defs ctx $ Ann (tycaseRhsDef0 def KNat arms) ret loc + + -- (type-case [π.A] ∷ ★ᵢ return Q of { [a] ⇒ s; ⋯ }) ⇝ s[(A ∷ ★ᵢ)/a] ∷ Q + BOX {ty = a, loc = boxLoc, _} => + whnf defs ctx $ Ann + (sub1 (tycaseRhsDef def KBOX arms) (Ann a (TYPE u noLoc) a.loc)) + ret loc + + +||| pushes a coercion inside a whnf-ed term +private covering +pushCoe : {n, d : Nat} -> (defs : Definitions) -> WhnfContext d n -> + BindName -> + (ty : Term (S d) n) -> (0 tynf : No (isRedexT defs ty)) => + Dim d -> Dim d -> + (s : Term d n) -> (0 snf : No (isRedexT defs s)) => Loc -> + WhnfM (NonRedex Elim d n defs) +pushCoe defs ctx i ty p q s loc = + if p == q then whnf defs ctx $ Ann s (ty // one q) loc else + case s of + -- (coe [_ ⇒ ★ᵢ] @_ @_ ty) ⇝ (ty ∷ ★ᵢ) + TYPE {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc + Pi {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc + Sig {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc + Enum {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc + Eq {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc + Nat {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc + BOX {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc + + -- just η expand it. then whnf for App will handle it later + -- this is how @xtt does it + -- + -- (coe [i ⇒ A] @p @q (λ x ⇒ s)) ⇝ + -- (λ y ⇒ (coe [i ⇒ A] @p @q (λ x ⇒ s)) y) ∷ A‹q/i› ⇝ ⋯ + lam@(Lam {body, _}) => do + let lam' = CoeT i ty p q lam loc + term' = LamY !(fresh body.name) + (E $ App (weakE 1 lam') (BVT 0 noLoc) loc) loc + type' = ty // one q + whnf defs ctx $ Ann term' type' loc + + -- (coe [i ⇒ (x : A) × B] @p @q (s, t)) ⇝ + -- (coe [i ⇒ A] @p @q s, + -- coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i s)/x]] @p @q t) + -- ∷ (x : A‹q/i›) × B‹q/i› + -- + -- can't use η here because... it doesn't exist + Pair {fst, snd, loc = pairLoc} => do + let Sig {fst = tfst, snd = tsnd, loc = sigLoc} = ty + | _ => throw $ ExpectedSig ty.loc (extendDim i ctx.names) ty + let fst' = E $ CoeT i tfst p q fst fst.loc + tfst' = tfst // (B VZ noLoc ::: shift 2) + tsnd' = sub1 tsnd $ + CoeT !(fresh i) tfst' (weakD 1 p) (B VZ noLoc) + (dweakT 1 fst) fst.loc + snd' = E $ CoeT i tsnd' p q snd snd.loc + pure $ + Element (Ann (Pair fst' snd' pairLoc) + (Sig (tfst // one q) (tsnd // one q) sigLoc) loc) + Ah + + -- η expand, like for Lam + -- + -- (coe [i ⇒ A] @p @q (δ j ⇒ s)) ⇝ + -- (δ k ⇒ (coe [i ⇒ A] @p @q (δ j ⇒ s)) @k) ∷ A‹q/i› ⇝ ⋯ + dlam@(DLam {body, _}) => do + let dlam' = CoeT i ty p q dlam loc + term' = DLamY !(mnb "j") + (E $ DApp (dweakE 1 dlam') (B VZ noLoc) loc) loc + type' = ty // one q + whnf defs ctx $ Ann term' type' loc + + -- (coe [_ ⇒ {⋯}] @_ @_ t) ⇝ (t ∷ {⋯}) + Tag {tag, loc = tagLoc} => do + let Enum {cases, loc = enumLoc} = ty + | _ => throw $ ExpectedEnum ty.loc (extendDim i ctx.names) ty + pure $ Element (Ann (Tag tag tagLoc) (Enum cases enumLoc) loc) Ah + + -- (coe [_ ⇒ ℕ] @_ @_ n) ⇝ (n ∷ ℕ) + Zero {loc = zeroLoc} => do + pure $ Element (Ann (Zero zeroLoc) (Nat ty.loc) loc) Ah + Succ {p = pred, loc = succLoc} => do + pure $ Element (Ann (Succ pred succLoc) (Nat ty.loc) loc) Ah + + -- (coe [i ⇒ [π.A]] @p @q [s]) ⇝ + -- [coe [i ⇒ A] @p @q s] ∷ [π. A‹q/i›] + Box {val, loc = boxLoc} => do + let BOX {qty, ty = a, loc = tyLoc} = ty + | _ => throw $ ExpectedBOX ty.loc (extendDim i ctx.names) ty + pure $ Element + (Ann (Box (E $ CoeT i a p q val val.loc) boxLoc) + (BOX qty (a // one q) tyLoc) loc) + Ah + + E e => pure $ Element (CoeT i ty p q (E e) e.loc) (snf `orNo` Ah) +where + unwrapTYPE : Term (S d) n -> WhnfM Universe + unwrapTYPE (TYPE {l, _}) = pure l + unwrapTYPE ty = throw $ ExpectedTYPE ty.loc (extendDim i ctx.names) ty + + +export covering +Whnf Elim Reduce.isRedexE where + whnf defs ctx (F x loc) with (lookupElim x defs) proof eq + _ | Just y = whnf defs ctx $ setLoc loc y + _ | Nothing = pure $ Element (F x loc) $ rewrite eq in Ah + + whnf _ _ (B i loc) = pure $ nred $ B i loc + + -- ((λ x ⇒ t) ∷ (π.x : A) → B) s ⇝ t[s∷A/x] ∷ B[s∷A/x] + whnf defs ctx (App f s appLoc) = do + Element f fnf <- whnf defs ctx f + case nchoose $ isLamHead f of + Left _ => case f of + Ann (Lam {body, _}) (Pi {arg, res, _}) floc => + let s = Ann s arg s.loc in + whnf defs ctx $ Ann (sub1 body s) (sub1 res s) appLoc + Coe ty p q val _ => piCoe defs ctx ty p q val s appLoc + Right nlh => pure $ Element (App f s appLoc) $ fnf `orNo` nlh + + -- case (s, t) ∷ (x : A) × B return p ⇒ C of { (a, b) ⇒ u } ⇝ + -- u[s∷A/a, t∷B[s∷A/x]] ∷ C[(s, t)∷((x : A) × B)/p] + whnf defs ctx (CasePair pi pair ret body caseLoc) = do + Element pair pairnf <- whnf defs ctx pair + case nchoose $ isPairHead pair of + Left _ => case pair of + Ann (Pair {fst, snd, _}) (Sig {fst = tfst, snd = tsnd, _}) pairLoc => + let fst = Ann fst tfst fst.loc + snd = Ann snd (sub1 tsnd fst) snd.loc + in + whnf defs ctx $ Ann (subN body [< fst, snd]) (sub1 ret pair) caseLoc + Coe ty p q val _ => do + sigCoe defs ctx pi ty p q val ret body caseLoc + Right np => + pure $ Element (CasePair pi pair ret body caseLoc) $ pairnf `orNo` np + + -- case 'a ∷ {a,…} return p ⇒ C of { 'a ⇒ u } ⇝ + -- u ∷ C['a∷{a,…}/p] + whnf defs ctx (CaseEnum pi tag ret arms caseLoc) = do + Element tag tagnf <- whnf defs ctx tag + case nchoose $ isTagHead tag of + Left _ => case tag of + Ann (Tag t _) (Enum ts _) _ => + let ty = sub1 ret tag in + case lookup t arms of + Just arm => whnf defs ctx $ Ann arm ty arm.loc + Nothing => throw $ MissingEnumArm caseLoc t (keys arms) + Coe ty p q val _ => + -- there is nowhere an equality can be hiding inside an enum type + whnf defs ctx $ + CaseEnum pi (Ann val (dsub1 ty q) val.loc) ret arms caseLoc + Right nt => + pure $ Element (CaseEnum pi tag ret arms caseLoc) $ tagnf `orNo` nt + + -- case zero ∷ ℕ return p ⇒ C of { zero ⇒ u; … } ⇝ + -- u ∷ C[zero∷ℕ/p] + -- + -- case succ n ∷ ℕ return p ⇒ C of { succ n', π.ih ⇒ u; … } ⇝ + -- u[n∷ℕ/n', (case n ∷ ℕ ⋯)/ih] ∷ C[succ n ∷ ℕ/p] + whnf defs ctx (CaseNat pi piIH nat ret zer suc caseLoc) = do + Element nat natnf <- whnf defs ctx nat + case nchoose $ isNatHead nat of + Left _ => + let ty = sub1 ret nat in + case nat of + Ann (Zero _) (Nat _) _ => + whnf defs ctx $ Ann zer ty zer.loc + Ann (Succ n succLoc) (Nat natLoc) _ => + let nn = Ann n (Nat natLoc) succLoc + tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc] + in + whnf defs ctx $ Ann tm ty caseLoc + Coe ty p q val _ => + -- same deal as Enum + whnf defs ctx $ + CaseNat pi piIH (Ann val (dsub1 ty q) val.loc) ret zer suc caseLoc + Right nn => pure $ + Element (CaseNat pi piIH nat ret zer suc caseLoc) $ natnf `orNo` nn + + -- case [t] ∷ [π.A] return p ⇒ C of { [x] ⇒ u } ⇝ + -- u[t∷A/x] ∷ C[[t] ∷ [π.A]/p] + whnf defs ctx (CaseBox pi box ret body caseLoc) = do + Element box boxnf <- whnf defs ctx box + case nchoose $ isBoxHead box of + Left _ => case box of + Ann (Box val boxLoc) (BOX q bty tyLoc) _ => + let ty = sub1 ret box in + whnf defs ctx $ Ann (sub1 body (Ann val bty val.loc)) ty caseLoc + Coe ty p q val _ => + boxCoe defs ctx pi ty p q val ret body caseLoc + Right nb => + pure $ Element (CaseBox pi box ret body caseLoc) $ boxnf `orNo` nb + + -- ((δ 𝑖 ⇒ s) ∷ Eq [𝑗 ⇒ A] t u) @0 ⇝ t ∷ A‹0/𝑗› + -- ((δ 𝑖 ⇒ s) ∷ Eq [𝑗 ⇒ A] t u) @1 ⇝ u ∷ A‹1/𝑗› + -- ((δ 𝑖 ⇒ s) ∷ Eq [𝑗 ⇒ A] t u) @𝑘 ⇝ s‹𝑘/𝑖› ∷ A‹𝑘/𝑗› + -- (if 𝑘 is a variable) + whnf defs ctx (DApp f p appLoc) = do + Element f fnf <- whnf defs ctx f + case nchoose $ isDLamHead f of + Left _ => case f of + Ann (DLam {body, _}) (Eq {ty, l, r, _}) _ => + whnf defs ctx $ + Ann (endsOr (setLoc appLoc l) (setLoc appLoc r) (dsub1 body p) p) + (dsub1 ty p) appLoc + Coe ty p' q' val _ => + eqCoe defs ctx ty p' q' val p appLoc + Right ndlh => case p of + K e _ => do + Eq {l, r, ty, _} <- whnf0 defs ctx =<< computeElimType defs ctx f + | ty => throw $ ExpectedEq ty.loc ctx.names ty + whnf defs ctx $ + ends (Ann (setLoc appLoc l) ty.zero appLoc) + (Ann (setLoc appLoc r) ty.one appLoc) e + B {} => pure $ Element (DApp f p appLoc) $ fnf `orNo` ndlh `orNo` Ah + + -- e ∷ A ⇝ e + whnf defs ctx (Ann s a annLoc) = do + Element s snf <- whnf defs ctx s + case nchoose $ isE s of + Left _ => let E e = s in pure $ Element e $ noOr2 snf + Right ne => do + Element a anf <- whnf defs ctx a + pure $ Element (Ann s a annLoc) $ ne `orNo` snf `orNo` anf + + whnf defs ctx (Coe (S _ (N ty)) _ _ val coeLoc) = + whnf defs ctx $ Ann val ty coeLoc + whnf defs ctx (Coe (S [< i] ty) p q val coeLoc) = do + Element ty tynf <- whnf defs (extendDim i ctx) ty.term + Element val valnf <- whnf defs ctx val + pushCoe defs ctx i ty p q val coeLoc + + whnf defs ctx (Comp ty p q val r zero one compLoc) = + -- comp [A] @p @p s { ⋯ } ⇝ s ∷ A + if p == q then whnf defs ctx $ Ann val ty compLoc else + case nchoose (isK r) of + -- comp [A] @p @q s @0 { 0 j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A + -- comp [A] @p @q s @1 { 1 j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A + Left y => case r of + K Zero _ => whnf defs ctx $ Ann (dsub1 zero q) ty compLoc + K One _ => whnf defs ctx $ Ann (dsub1 one q) ty compLoc + Right nk => do + Element ty tynf <- whnf defs ctx ty + pure $ Element (Comp ty p q val r zero one compLoc) $ tynf `orNo` nk + + whnf defs ctx (TypeCase ty ret arms def tcLoc) = do + Element ty tynf <- whnf defs ctx ty + Element ret retnf <- whnf defs ctx ret + case nchoose $ isAnnTyCon ty of + Left y => + let Ann ty (TYPE u _) _ = ty in + reduceTypeCase defs ctx ty u ret arms def tcLoc + Right nt => pure $ + Element (TypeCase ty ret arms def tcLoc) (tynf `orNo` retnf `orNo` nt) + + whnf defs ctx (CloE (Sub el th)) = whnf defs ctx $ pushSubstsWith' id th el + whnf defs ctx (DCloE (Sub el th)) = whnf defs ctx $ pushSubstsWith' th id el + +export covering +Whnf Term Reduce.isRedexT where + whnf _ _ t@(TYPE {}) = pure $ nred t + whnf _ _ t@(Pi {}) = pure $ nred t + whnf _ _ t@(Lam {}) = pure $ nred t + whnf _ _ t@(Sig {}) = pure $ nred t + whnf _ _ t@(Pair {}) = pure $ nred t + whnf _ _ t@(Enum {}) = pure $ nred t + whnf _ _ t@(Tag {}) = pure $ nred t + whnf _ _ t@(Eq {}) = pure $ nred t + whnf _ _ t@(DLam {}) = pure $ nred t + whnf _ _ t@(Nat {}) = pure $ nred t + whnf _ _ t@(Zero {}) = pure $ nred t + whnf _ _ t@(Succ {}) = pure $ nred t + whnf _ _ t@(BOX {}) = pure $ nred t + whnf _ _ t@(Box {}) = pure $ nred t + + -- s ∷ A ⇝ s (in term context) + whnf defs ctx (E e) = do + Element e enf <- whnf defs ctx e + case nchoose $ isAnn e of + Left _ => let Ann {tm, _} = e in pure $ Element tm $ noOr1 $ noOr2 enf + Right na => pure $ Element (E e) $ na `orNo` enf + + whnf defs ctx (CloT (Sub tm th)) = whnf defs ctx $ pushSubstsWith' id th tm + whnf defs ctx (DCloT (Sub tm th)) = whnf defs ctx $ pushSubstsWith' th id tm diff --git a/lib/Quox/Syntax/Dim.idr b/lib/Quox/Syntax/Dim.idr index 826b1df..2271515 100644 --- a/lib/Quox/Syntax/Dim.idr +++ b/lib/Quox/Syntax/Dim.idr @@ -1,5 +1,6 @@ module Quox.Syntax.Dim +import Quox.Loc import Quox.Name import Quox.Syntax.Var import Quox.Syntax.Subst @@ -17,7 +18,6 @@ import Derive.Prelude public export data DimConst = Zero | One %name DimConst e - %runElab derive "DimConst" [Eq, Ord, Show] ||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`. @@ -26,23 +26,42 @@ ends : Lazy a -> Lazy a -> DimConst -> a ends l r Zero = l ends l r One = r +export Uninhabited (Zero = One) where uninhabited _ impossible +export Uninhabited (One = Zero) where uninhabited _ impossible + +public export +DecEq DimConst where + decEq Zero Zero = Yes Refl + decEq Zero One = No absurd + decEq One Zero = No absurd + decEq One One = Yes Refl + public export data Dim : Nat -> Type where - K : DimConst -> Dim d - B : Var d -> Dim d + K : DimConst -> Loc -> Dim d + B : Var d -> Loc -> Dim d %name Dim.Dim p, q - %runElab deriveIndexed "Dim" [Eq, Ord, Show] +export +Located (Dim d) where + (K _ loc).loc = loc + (B _ loc).loc = loc + +export +Relocatable (Dim d) where + setLoc loc (K e _) = K e loc + setLoc loc (B i _) = B i loc + export PrettyHL DimConst where prettyM = pure . hl Dim . ends "0" "1" export PrettyHL (Dim n) where - prettyM (K e) = prettyM e - prettyM (B i) = prettyVar DVar DVarErr (!ask).dnames i + prettyM (K e _) = prettyM e + prettyM (B i _) = prettyVar DVar DVarErr (!ask).dnames i export prettyDim : (dnames : NContext d) -> Dim d -> Doc HL @@ -60,13 +79,13 @@ prettyDim dnames p = ||| - `x` otherwise. public export endsOr : Lazy a -> Lazy a -> Lazy a -> Dim n -> a -endsOr l r x (K e) = ends l r e -endsOr l r x (B _) = x +endsOr l r x (K e _) = ends l r e +endsOr l r x (B _ _) = x public export %inline toConst : Dim 0 -> DimConst -toConst (K e) = e +toConst (K e _) = e public export @@ -81,52 +100,55 @@ prettyDSubst th = !(ifUnicode "⟨" "<") !(ifUnicode "⟩" ">") th -public export FromVar Dim where fromVar = B +public export FromVar Dim where fromVarLoc = B export CanShift Dim where - K e // _ = K e - B i // by = B (i // by) + K e loc // _ = K e loc + B i loc // by = B (i // by) loc export CanSubstSelf Dim where - K e // _ = K e - B i // th = th !! i + K e loc // _ = K e loc + B i loc // th = getLoc th i loc -export Uninhabited (Zero = One) where uninhabited _ impossible -export Uninhabited (One = Zero) where uninhabited _ impossible - -export Uninhabited (B i = K e) where uninhabited _ impossible -export Uninhabited (K e = B i) where uninhabited _ impossible - -public export %inline Injective Dim.B where injective Refl = Refl -public export %inline Injective Dim.K where injective Refl = Refl +export Uninhabited (B i loc1 = K e loc2) where uninhabited _ impossible +export Uninhabited (K e loc1 = B i loc2) where uninhabited _ impossible public export -DecEq DimConst where - decEq Zero Zero = Yes Refl - decEq Zero One = No absurd - decEq One Zero = No absurd - decEq One One = Yes Refl +data Eqv : Dim d1 -> Dim d2 -> Type where + EK : K e _ `Eqv` K e _ + EB : i `Eqv` j -> B i _ `Eqv` B j _ + +export Uninhabited (K e l1 `Eqv` B i l2) where uninhabited _ impossible +export Uninhabited (B i l1 `Eqv` K e l2) where uninhabited _ impossible + +export +injectiveB : B i loc1 `Eqv` B j loc2 -> i `Eqv` j +injectiveB (EB e) = e + +export +injectiveK : K e loc1 `Eqv` K f loc2 -> e = f +injectiveK EK = Refl public export -DecEq (Dim d) where - decEq (K e) (K f) with (decEq e f) - _ | Yes prf = Yes $ cong K prf - _ | No contra = No $ contra . injective - decEq (K e) (B j) = No absurd - decEq (B i) (K f) = No absurd - decEq (B i) (B j) with (decEq i j) - _ | Yes prf = Yes $ cong B prf - _ | No contra = No $ contra . injective +decEqv : Dec2 Dim.Eqv +decEqv (K e _) (K f _) = case decEq e f of + Yes Refl => Yes EK + No n => No $ n . injectiveK +decEqv (B i _) (B j _) = case decEqv i j of + Yes y => Yes $ EB y + No n => No $ \(EB y) => n y +decEqv (B _ _) (K _ _) = No absurd +decEqv (K _ _) (B _ _) = No absurd ||| abbreviation for a bound variable like `BV 4` instead of ||| `B (VS (VS (VS (VS VZ))))` public export %inline -BV : (i : Nat) -> (0 _ : LT i d) => Dim d -BV i = B $ V i +BV : (i : Nat) -> (0 _ : LT i d) => (loc : Loc) -> Dim d +BV i loc = B (V i) loc export diff --git a/lib/Quox/Syntax/DimEq.idr b/lib/Quox/Syntax/DimEq.idr index 2359181..ddea7eb 100644 --- a/lib/Quox/Syntax/DimEq.idr +++ b/lib/Quox/Syntax/DimEq.idr @@ -72,7 +72,7 @@ toMaybe (Just x) = Just x export fromGround' : Context' DimConst d -> DimEq' d fromGround' [<] = [<] -fromGround' (ctx :< e) = fromGround' ctx :< Just (K e) +fromGround' (ctx :< e) = fromGround' ctx :< Just (K e noLoc) export fromGround : Context' DimConst d -> DimEq d @@ -98,8 +98,8 @@ get' : DimEq' d -> Var d -> Maybe (Dim d) get' = getWith $ \p, by => map (// by) p public export %inline -getVar : DimEq' d -> Var d -> Dim d -getVar eqs i = fromMaybe (B i) $ get' eqs i +getVar : DimEq' d -> Var d -> Loc -> Dim d +getVar eqs i loc = fromMaybe (B i loc) $ get' eqs i public export %inline getShift' : Shift len out -> DimEq' len -> Var len -> Maybe (Dim out) @@ -107,8 +107,8 @@ getShift' = getShiftWith $ \p, by => map (// by) p public export %inline get : DimEq' d -> Dim d -> Dim d -get _ (K e) = K e -get eqs (B i) = getVar eqs i +get _ (K e loc) = K e loc +get eqs (B i loc) = getVar eqs i loc public export %inline @@ -126,7 +126,7 @@ C eqs : Dim d -> Maybe (Dim d) -> Maybe (Dim d) -ifVar i p = map $ \q => if q == B i then p else q +ifVar i p = map $ \q => if q == B i noLoc then p else q -- (using decEq instead of (==) because of the proofs below) private %inline @@ -135,39 +135,43 @@ checkConst e f eqs = if isYes $ e `decEq` f then C eqs else ZeroIsOne export -setConst : Var d -> DimConst -> DimEq' d -> DimEq d -setConst VZ e (eqs :< Nothing) = C $ eqs :< Just (K e) -setConst VZ e (eqs :< Just (K f)) = checkConst e f $ eqs :< Just (K f) -setConst VZ e (eqs :< Just (B i)) = setConst i e eqs : DimConst -> Loc -> DimEq' d -> DimEq d +setConst VZ e loc (eqs :< Nothing) = + C $ eqs :< Just (K e loc) +setConst VZ e _ (eqs :< Just (K f loc)) = + checkConst e f $ eqs :< Just (K f loc) +setConst VZ e loc (eqs :< Just (B i _)) = + setConst i e loc eqs : (0 _ : i `LT` j) -> DimEq' d -> DimEq d - setVar' VZ (VS i) LTZ (eqs :< Nothing) = - C eqs : (0 _ : i `LT` j) -> Loc -> DimEq' d -> DimEq d + setVar' VZ (VS i) LTZ loc (eqs :< Nothing) = + C eqs : i then B j jloc else B i loc) + setVar' (VS i) (VS j) (LTS lt) loc (eqs :< p) = + setVar' i j lt loc eqs : DimEq' d -> DimEq d - setVar i j eqs with (compareP i j) | (compare i.nat j.nat) - setVar i j eqs | IsLT lt | LT = setVar' i j lt eqs - setVar i i eqs | IsEQ | EQ = C eqs - setVar i j eqs | IsGT gt | GT = setVar' j i gt eqs + setVar : (i, j : Var d) -> Loc -> Loc -> DimEq' d -> DimEq d + setVar i j li lj eqs with (compareP i j) | (compare i.nat j.nat) + setVar i j li lj eqs | IsLT lt | LT = setVar' i j lt lj eqs + setVar i i li lj eqs | IsEQ | EQ = C eqs + setVar i j li lj eqs | IsGT gt | GT = setVar' j i gt li eqs export %inline set : (p, q : Dim d) -> DimEq d -> DimEq d set _ _ ZeroIsOne = ZeroIsOne -set (K e) (K f) (C eqs) = checkConst e f eqs -set (K e) (B i) (C eqs) = setConst i e eqs -set (B i) (K e) (C eqs) = setConst i e eqs -set (B i) (B j) (C eqs) = setVar i j eqs +set (K e eloc) (K f floc) (C eqs) = checkConst e f eqs +set (K e eloc) (B i iloc) (C eqs) = setConst i e eloc eqs +set (B i iloc) (K e eloc) (C eqs) = setConst i e eloc eqs +set (B i iloc) (B j jloc) (C eqs) = setVar i j iloc jloc eqs public export %inline @@ -175,25 +179,26 @@ Split : Nat -> Type Split d = (DimEq' d, DSubst (S d) d) export %inline -split1 : DimConst -> DimEq' (S d) -> Maybe (Split d) -split1 e eqs = case setConst VZ e eqs of +split1 : DimConst -> Loc -> DimEq' (S d) -> Maybe (Split d) +split1 e loc eqs = case setConst VZ e loc eqs of ZeroIsOne => Nothing - C (eqs :< _) => Just (eqs, K e ::: id) + C (eqs :< _) => Just (eqs, K e loc ::: id) export %inline -split : DimEq' (S d) -> List (Split d) -split eqs = toList (split1 Zero eqs) <+> toList (split1 One eqs) - +split : Loc -> DimEq' (S d) -> List (Split d) +split loc eqs = toList (split1 Zero loc eqs) <+> toList (split1 One loc eqs) export -splits' : DimEq' d -> List (DSubst d 0) -splits' [<] = [id] -splits' eqs@(_ :< _) = [th . ph | (eqs', th) <- split eqs, ph <- splits' eqs'] +splits' : Loc -> DimEq' d -> List (DSubst d 0) +splits' _ [<] = [id] +splits' loc eqs@(_ :< _) = + [th . ph | (eqs', th) <- split loc eqs, ph <- splits' loc eqs'] +||| the Loc is put into each of the DimConsts export %inline -splits : DimEq d -> List (DSubst d 0) -splits ZeroIsOne = [] -splits (C eqs) = splits' eqs +splits : Loc -> DimEq d -> List (DSubst d 0) +splits _ ZeroIsOne = [] +splits loc (C eqs) = splits' loc eqs private @@ -208,16 +213,16 @@ newGet' d i = newGetShift d i SZ export 0 newGet : (d : Nat) -> (p : Dim d) -> get (new' {d}) p = p -newGet d (K e) = Refl -newGet d (B i) = rewrite newGet' d i in Refl +newGet d (K e _) = Refl +newGet d (B i _) = rewrite newGet' d i in Refl export 0 setSelf : (p : Dim d) -> (eqs : DimEq d) -> set p p eqs = eqs setSelf p ZeroIsOne = Refl -setSelf (K Zero) (C eqs) = Refl -setSelf (K One) (C eqs) = Refl -setSelf (B i) (C eqs) with (compareP i i) | (compare i.nat i.nat) +setSelf (K Zero _) (C eqs) = Refl +setSelf (K One _) (C eqs) = Refl +setSelf (B i _) (C eqs) with (compareP i i) | (compare i.nat i.nat) _ | IsLT lt | LT = absurd lt _ | IsEQ | EQ = Refl _ | IsGT gt | GT = absurd gt @@ -250,7 +255,7 @@ PrettyHL (DimEq' d) where go [<] = pure [<] go (eqs :< Nothing) = local {dnames $= tail} $ go eqs go (eqs :< Just p) = do - eq <- prettyCst (BV {d = 1} 0) (weakD 1 p) + eq <- prettyCst (BV {d = 1} 0 noLoc) (weakD 1 p) eqs <- local {dnames $= tail} $ go eqs pure $ eqs :< eq @@ -262,16 +267,16 @@ PrettyHL (DimEq d) where prettyM (C eqs) = prettyM eqs export -prettyDimEq : NContext d -> DimEq d -> Doc HL -prettyDimEq ds = pretty0With False (toSnocList' ds) [<] +prettyDimEq : BContext d -> DimEq d -> Doc HL +prettyDimEq ds = pretty0With False (toNames ds) [<] public export wf' : DimEq' d -> Bool -wf' [<] = True -wf' (eqs :< Nothing) = wf' eqs -wf' (eqs :< Just (K e)) = wf' eqs -wf' (eqs :< Just (B i)) = isNothing (get' eqs i) && wf' eqs +wf' [<] = True +wf' (eqs :< Nothing) = wf' eqs +wf' (eqs :< Just (K e _)) = wf' eqs +wf' (eqs :< Just (B i _)) = isNothing (get' eqs i) && wf' eqs public export wf : DimEq d -> Bool diff --git a/lib/Quox/Syntax/Shift.idr b/lib/Quox/Syntax/Shift.idr index b101cf9..79a7e2b 100644 --- a/lib/Quox/Syntax/Shift.idr +++ b/lib/Quox/Syntax/Shift.idr @@ -35,27 +35,28 @@ public export data Eqv : Shift from1 to1 -> Shift from2 to2 -> Type where EqSZ : SZ `Eqv` SZ EqSS : by `Eqv` bz -> SS by `Eqv` SS bz -%name Eqv e +%name Shift.Eqv e -||| two equivalent shifts are equal if they have the same indices. -export -0 fromEqv : by `Eqv` bz -> by = bz -fromEqv EqSZ = Refl -fromEqv (EqSS e) = cong SS $ fromEqv e +using (by : Shift from to, bz : Shift from to) + ||| two equivalent shifts are equal if they have the same indices. + export + 0 fromEqv : by `Eqv` bz -> by = bz + fromEqv EqSZ = Refl + fromEqv (EqSS e) = cong SS $ fromEqv e -||| two equal shifts are equivalent. -export -0 toEqv : by = bz -> by `Eqv` bz -toEqv Refl {by = SZ} = EqSZ -toEqv Refl {by = (SS by)} = EqSS $ toEqv Refl + ||| two equal shifts are equivalent. + export + 0 toEqv : by = bz -> by `Eqv` bz + toEqv Refl {by = SZ} = EqSZ + toEqv Refl {by = (SS by)} = EqSS $ toEqv Refl export -eqLen : Shift from1 to -> Shift from2 to -> Maybe (from1 = from2) -eqLen SZ SZ = Just Refl -eqLen SZ (SS by) = Nothing -eqLen (SS by) SZ = Nothing -eqLen (SS by) (SS bz) = eqLen by bz +cmpLen : Shift from1 to -> Shift from2 to -> Either Ordering (from1 = from2) +cmpLen SZ SZ = Right Refl +cmpLen SZ (SS by) = Left LT +cmpLen (SS by) SZ = Left GT +cmpLen (SS by) (SS bz) = cmpLen by bz export 0 shiftDiff : (by : Shift from to) -> to = by.nat + from diff --git a/lib/Quox/Syntax/Subst.idr b/lib/Quox/Syntax/Subst.idr index e445405..b152664 100644 --- a/lib/Quox/Syntax/Subst.idr +++ b/lib/Quox/Syntax/Subst.idr @@ -48,12 +48,16 @@ interface FromVar term => CanSubstSelf term where (//) : term from -> Lazy (Subst term from to) -> term to -infixl 8 !! public export -(!!) : FromVar term => Subst term from to -> Var from -> term to -(Shift by) !! i = fromVar $ shift by i -(t ::: th) !! VZ = t -(t ::: th) !! (VS i) = th !! i +getLoc : FromVar term => Subst term from to -> Var from -> Loc -> term to +getLoc (Shift by) i loc = fromVarLoc (shift by i) loc +getLoc (t ::: th) VZ _ = t +getLoc (t ::: th) (VS i) loc = getLoc th i loc + +-- infixl 8 !! +-- public export +-- (!!) : FromVar term => Subst term from to -> Var from -> term to +-- th !! i = getLoc th i noLoc public export @@ -160,12 +164,16 @@ PrettyHL (f to) => PrettyHL (Subst f from to) where prettyM th = prettySubstM prettyM (!ask).tnames TVar "[" "]" th +||| whether two substitutions with the same codomain have the same shape +||| (the same number of terms and the same shift at the end). if so, they +||| also have the same domain export -eqShape : Subst env from1 to -> Subst env from2 to -> Maybe (from1 = from2) -eqShape (Shift by) (Shift bz) = eqLen by bz -eqShape (Shift by) (t ::: th) = Nothing -eqShape (t ::: th) (Shift by) = Nothing -eqShape (t ::: th) (x ::: ph) = cong S <$> eqShape th ph +cmpShape : Subst env from1 to -> Subst env from2 to -> + Either Ordering (from1 = from2) +cmpShape (Shift by) (Shift bz) = cmpLen by bz +cmpShape (Shift _) (_ ::: _) = Left LT +cmpShape (_ ::: _) (Shift _) = Left GT +cmpShape (_ ::: th) (_ ::: ph) = cong S <$> cmpShape th ph public export @@ -175,13 +183,20 @@ record WithSubst tm env n where subst : Lazy (Subst env from n) export -(forall n. Eq (tm n), Eq (env n)) => Eq (WithSubst tm env n) where +(Eq (env n), forall n. Eq (tm n)) => Eq (WithSubst tm env n) where Sub t1 s1 == Sub t2 s2 = - case eqShape s1 s2 of - Just Refl => t1 == t2 && s1 == s2 - Nothing => False + case cmpShape s1 s2 of + Left _ => False + Right Refl => t1 == t2 && s1 == s2 + +export +(Ord (env n), forall n. Ord (tm n)) => Ord (WithSubst tm env n) where + Sub t1 s1 `compare` Sub t2 s2 = + case cmpShape s1 s2 of + Left o => o + Right Refl => compare (t1, s1) (t2, s2) export %hint -ShowWithSubst : (forall n. Show (tm n), Show (env n)) => +ShowWithSubst : (Show (env n), forall n. Show (tm n)) => Show (WithSubst tm env n) ShowWithSubst = deriveShow diff --git a/lib/Quox/Syntax/Term/Base.idr b/lib/Quox/Syntax/Term/Base.idr index aefae38..7b5e089 100644 --- a/lib/Quox/Syntax/Term/Base.idr +++ b/lib/Quox/Syntax/Term/Base.idr @@ -7,6 +7,7 @@ import public Quox.Syntax.Qty import public Quox.Syntax.Dim import public Quox.Syntax.Term.TyConKind import public Quox.Name +import public Quox.Loc import public Quox.Context import Quox.Pretty @@ -63,7 +64,7 @@ ShowScopedBody = deriveShow public export record Scoped (s : Nat) (f : Nat -> Type) (n : Nat) where constructor S - names : NContext s + names : BContext s body : ScopedBody s f n %name Scoped body @@ -88,38 +89,38 @@ mutual public export data Term : (d, n : Nat) -> Type where ||| type of types - TYPE : (l : Universe) -> Term d n + TYPE : (l : Universe) -> (loc : Loc) -> Term d n ||| function type Pi : (qty : Qty) -> (arg : Term d n) -> - (res : ScopeTerm d n) -> Term d n + (res : ScopeTerm d n) -> (loc : Loc) -> Term d n ||| function term - Lam : (body : ScopeTerm d n) -> Term d n + Lam : (body : ScopeTerm d n) -> (loc : Loc) -> Term d n ||| pair type - Sig : (fst : Term d n) -> (snd : ScopeTerm d n) -> Term d n + Sig : (fst : Term d n) -> (snd : ScopeTerm d n) -> (loc : Loc) -> Term d n ||| pair value - Pair : (fst, snd : Term d n) -> Term d n + Pair : (fst, snd : Term d n) -> (loc : Loc) -> Term d n ||| enumeration type - Enum : (cases : SortedSet TagVal) -> Term d n + Enum : (cases : SortedSet TagVal) -> (loc : Loc) -> Term d n ||| enumeration value - Tag : (tag : TagVal) -> Term d n + Tag : (tag : TagVal) -> (loc : Loc) -> Term d n ||| equality type - Eq : (ty : DScopeTerm d n) -> (l, r : Term d n) -> Term d n + Eq : (ty : DScopeTerm d n) -> (l, r : Term d n) -> (loc : Loc) -> Term d n ||| equality term - DLam : (body : DScopeTerm d n) -> Term d n + DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n ||| natural numbers (temporary until 𝐖 gets added) - Nat : Term d n + Nat : (loc : Loc) -> Term d n -- [todo] can these be elims? - Zero : Term d n - Succ : (p : Term d n) -> Term d n + Zero : (loc : Loc) -> Term d n + Succ : (p : Term d n) -> (loc : Loc) -> Term d n ||| "box" (package a value up with a certain quantity) - BOX : (qty : Qty) -> (ty : Term d n) -> Term d n - Box : (val : Term d n) -> Term d n + BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n + Box : (val : Term d n) -> (loc : Loc) -> Term d n ||| elimination E : (e : Elim d n) -> Term d n @@ -134,12 +135,12 @@ mutual public export data Elim : (d, n : Nat) -> Type where ||| free variable - F : (x : Name) -> Elim d n + F : (x : Name) -> (loc : Loc) -> Elim d n ||| bound variable - B : (i : Var n) -> Elim d n + B : (i : Var n) -> (loc : Loc) -> Elim d n ||| term application - (:@) : (fun : Elim d n) -> (arg : Term d n) -> Elim d n + App : (fun : Elim d n) -> (arg : Term d n) -> (loc : Loc) -> Elim d n ||| pair destruction ||| @@ -148,12 +149,14 @@ mutual CasePair : (qty : Qty) -> (pair : Elim d n) -> (ret : ScopeTerm d n) -> (body : ScopeTermN 2 d n) -> + (loc : Loc) -> Elim d n ||| enum matching CaseEnum : (qty : Qty) -> (tag : Elim d n) -> (ret : ScopeTerm d n) -> (arms : CaseEnumArms d n) -> + (loc : Loc) -> Elim d n ||| nat matching @@ -161,33 +164,36 @@ mutual (ret : ScopeTerm d n) -> (zero : Term d n) -> (succ : ScopeTermN 2 d n) -> + (loc : Loc) -> Elim d n ||| unboxing CaseBox : (qty : Qty) -> (box : Elim d n) -> (ret : ScopeTerm d n) -> (body : ScopeTerm d n) -> + (loc : Loc) -> Elim d n ||| dim application - (:%) : (fun : Elim d n) -> (arg : Dim d) -> Elim d n + DApp : (fun : Elim d n) -> (arg : Dim d) -> (loc : Loc) -> Elim d n ||| type-annotated term - (:#) : (tm, ty : Term d n) -> Elim d n + Ann : (tm, ty : Term d n) -> (loc : Loc) -> Elim d n ||| coerce a value along a type equality, or show its coherence ||| [@xtt; §2.1.1] Coe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> - (val : Term d n) -> Elim d n + (val : Term d n) -> (loc : Loc) -> Elim d n ||| "generalised composition" [@xtt; §2.1.2] Comp : (ty : Term d n) -> (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) -> - (zero, one : DScopeTerm d n) -> Elim d n + (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n ||| match on types. needed for b.s. of coercions [@xtt; §2.2] TypeCase : (ty : Elim d n) -> (ret : Term d n) -> (arms : TypeCaseArms d n) -> (def : Term d n) -> + (loc : Loc) -> Elim d n ||| term closure/suspended substitution @@ -244,88 +250,211 @@ mutual ||| scope which ignores all its binders public export %inline SN : {s : Nat} -> f n -> Scoped s f n -SN = S (replicate s Unused) . N +SN = S (replicate s $ BN Unused noLoc) . N ||| scope which uses its binders public export %inline -SY : NContext s -> f (s + n) -> Scoped s f n +SY : BContext s -> f (s + n) -> Scoped s f n SY ns = S ns . Y public export %inline -name : Scoped 1 f n -> BaseName +name : Scoped 1 f n -> BindName name (S [< x] _) = x public export %inline -(.name) : Scoped 1 f n -> BaseName +(.name) : Scoped 1 f n -> BindName s.name = name s ||| more convenient Pi public export %inline -PiY : (qty : Qty) -> (x : BaseName) -> - (arg : Term d n) -> (res : Term d (S n)) -> Term d n -PiY {qty, x, arg, res} = Pi {qty, arg, res = SY [< x] res} +PiY : (qty : Qty) -> (x : BindName) -> + (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n +PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc} + +||| more convenient Lam +public export %inline +LamY : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n +LamY {x, body, loc} = Lam {body = SY [< x] body, loc} + +public export %inline +LamN : (body : Term d n) -> (loc : Loc) -> Term d n +LamN {body, loc} = Lam {body = SN body, loc} ||| non dependent function type public export %inline -Arr : (qty : Qty) -> (arg, res : Term d n) -> Term d n -Arr {qty, arg, res} = Pi {qty, arg, res = SN res} +Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n +Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc} ||| more convenient Sig public export %inline -SigY : (x : BaseName) -> (fst : Term d n) -> - (snd : Term d (S n)) -> Term d n -SigY {x, fst, snd} = Sig {fst, snd = SY [< x] snd} +SigY : (x : BindName) -> (fst : Term d n) -> + (snd : Term d (S n)) -> (loc : Loc) -> Term d n +SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc} ||| non dependent pair type public export %inline -And : (fst, snd : Term d n) -> Term d n -And {fst, snd} = Sig {fst, snd = SN snd} +And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n +And {fst, snd, loc} = Sig {fst, snd = SN snd, loc} ||| more convenient Eq public export %inline -EqY : (i : BaseName) -> (ty : Term (S d) n) -> - (l, r : Term d n) -> Term d n -EqY {i, ty, l, r} = Eq {ty = SY [< i] ty, l, r} +EqY : (i : BindName) -> (ty : Term (S d) n) -> + (l, r : Term d n) -> (loc : Loc) -> Term d n +EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc} + +||| more convenient DLam +public export %inline +DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n +DLamY {i, body, loc} = DLam {body = SY [< i] body, loc} + +public export %inline +DLamN : (body : Term d n) -> (loc : Loc) -> Term d n +DLamN {body, loc} = DLam {body = SN body, loc} ||| non dependent equality type public export %inline -Eq0 : (ty, l, r : Term d n) -> Term d n -Eq0 {ty, l, r} = Eq {ty = SN ty, l, r} +Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n +Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc} ||| same as `F` but as a term public export %inline -FT : Name -> Term d n -FT = E . F +FT : Name -> (loc : Loc) -> Term d n +FT x loc = E $ F x loc ||| abbreviation for a bound variable like `BV 4` instead of ||| `B (VS (VS (VS (VS VZ))))` public export %inline -BV : (i : Nat) -> (0 _ : LT i n) => Elim d n -BV i = B $ V i +BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim d n +BV i loc = B (V i) loc ||| same as `BV` but as a term public export %inline -BVT : (i : Nat) -> (0 _ : LT i n) => Term d n -BVT i = E $ BV i +BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n +BVT i loc = E $ BV i loc public export -makeNat : Nat -> Term d n -makeNat 0 = Zero -makeNat (S k) = Succ $ makeNat k +makeNat : Nat -> Loc -> Term d n +makeNat 0 loc = Zero loc +makeNat (S k) loc = Succ (makeNat k loc) loc public export %inline -enum : List TagVal -> Term d n -enum = Enum . SortedSet.fromList +enum : List TagVal -> Loc -> Term d n +enum ts loc = Enum (SortedSet.fromList ts) loc public export %inline typeCase : Elim d n -> Term d n -> - List (TypeCaseArm d n) -> Term d n -> Elim d n -typeCase ty ret arms def = TypeCase ty ret (fromList arms) def + List (TypeCaseArm d n) -> Term d n -> Loc -> Elim d n +typeCase ty ret arms def loc = TypeCase ty ret (fromList arms) def loc public export %inline typeCase1Y : Elim d n -> Term d n -> - (k : TyConKind) -> NContext (arity k) -> Term d (arity k + n) -> - {default Nat def : Term d n} -> + (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) -> + (loc : Loc) -> + {default (Nat loc) def : Term d n} -> Elim d n -typeCase1Y ty ret k ns body {def} = - typeCase ty ret [(k ** SY ns body)] def +typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc + + +export +Located (Elim d n) where + (F _ loc).loc = loc + (B _ loc).loc = loc + (App _ _ loc).loc = loc + (CasePair _ _ _ _ loc).loc = loc + (CaseEnum _ _ _ _ loc).loc = loc + (CaseNat _ _ _ _ _ _ loc).loc = loc + (CaseBox _ _ _ _ loc).loc = loc + (DApp _ _ loc).loc = loc + (Ann _ _ loc).loc = loc + (Coe _ _ _ _ loc).loc = loc + (Comp _ _ _ _ _ _ _ loc).loc = loc + (TypeCase _ _ _ _ loc).loc = loc + (CloE (Sub e _)).loc = e.loc + (DCloE (Sub e _)).loc = e.loc + +export +Located (Term d n) where + (TYPE _ loc).loc = loc + (Pi _ _ _ loc).loc = loc + (Lam _ loc).loc = loc + (Sig _ _ loc).loc = loc + (Pair _ _ loc).loc = loc + (Enum _ loc).loc = loc + (Tag _ loc).loc = loc + (Eq _ _ _ loc).loc = loc + (DLam _ loc).loc = loc + (Nat loc).loc = loc + (Zero loc).loc = loc + (Succ _ loc).loc = loc + (BOX _ _ loc).loc = loc + (Box _ loc).loc = loc + (E e).loc = e.loc + (CloT (Sub t _)).loc = t.loc + (DCloT (Sub t _)).loc = t.loc + +export +Located1 f => Located (ScopedBody s f n) where + (Y t).loc = t.loc + (N t).loc = t.loc + +export +Located1 f => Located (Scoped s f n) where + t.loc = t.body.loc + + +export +Relocatable (Elim d n) where + setLoc loc (F x _) = F x loc + setLoc loc (B i _) = B i loc + setLoc loc (App fun arg _) = App fun arg loc + setLoc loc (CasePair qty pair ret body _) = + CasePair qty pair ret body loc + setLoc loc (CaseEnum qty tag ret arms _) = + CaseEnum qty tag ret arms loc + setLoc loc (CaseNat qty qtyIH nat ret zero succ _) = + CaseNat qty qtyIH nat ret zero succ loc + setLoc loc (CaseBox qty box ret body _) = + CaseBox qty box ret body loc + setLoc loc (DApp fun arg _) = + DApp fun arg loc + setLoc loc (Ann tm ty _) = + Ann tm ty loc + setLoc loc (Coe ty p q val _) = + Coe ty p q val loc + setLoc loc (Comp ty p q val r zero one _) = + Comp ty p q val r zero one loc + setLoc loc (TypeCase ty ret arms def _) = + TypeCase ty ret arms def loc + setLoc loc (CloE (Sub term subst)) = + CloE $ Sub (setLoc loc term) subst + setLoc loc (DCloE (Sub term subst)) = + DCloE $ Sub (setLoc loc term) subst + +export +Relocatable (Term d n) where + setLoc loc (TYPE l _) = TYPE l loc + setLoc loc (Pi qty arg res _) = Pi qty arg res loc + setLoc loc (Lam body _) = Lam body loc + setLoc loc (Sig fst snd _) = Sig fst snd loc + setLoc loc (Pair fst snd _) = Pair fst snd loc + setLoc loc (Enum cases _) = Enum cases loc + setLoc loc (Tag tag _) = Tag tag loc + setLoc loc (Eq ty l r _) = Eq ty l r loc + setLoc loc (DLam body _) = DLam body loc + setLoc loc (Nat _) = Nat loc + setLoc loc (Zero _) = Zero loc + setLoc loc (Succ p _) = Succ p loc + setLoc loc (BOX qty ty _) = BOX qty ty loc + setLoc loc (Box val _) = Box val loc + setLoc loc (E e) = E $ setLoc loc e + setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst + setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst + +export +Relocatable1 f => Relocatable (ScopedBody s f n) where + setLoc loc (Y body) = Y $ setLoc loc body + setLoc loc (N body) = N $ setLoc loc body + +export +Relocatable1 f => Relocatable (Scoped s f n) where + setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body) diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index 0892c77..7bf10d6 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -82,8 +82,8 @@ PrettyHL a => PrettyHL (Binder a) where export prettyBindType : PrettyHL a => PrettyHL b => Pretty.HasEnv m => - Maybe Qty -> BaseName -> a -> Doc HL -> b -> m (Doc HL) -prettyBindType q x s arr t = do + Maybe Qty -> BindName -> a -> Doc HL -> b -> m (Doc HL) +prettyBindType q (BN x _) s arr t = do bind <- case q of Nothing => pretty0M $ MkBinder x s Just q => pretty0M $ MkWithQty q $ MkBinder x s @@ -92,14 +92,15 @@ prettyBindType q x s arr t = do export prettyArm : PrettyHL a => Pretty.HasEnv m => - BinderSort -> SnocList BaseName -> Doc HL -> a -> m (Doc HL) + BinderSort -> SnocList BindName -> Doc HL -> a -> m (Doc HL) prettyArm sort xs pat body = do + let xs = map name xs body <- withPrec Outer $ unders sort xs $ prettyM body pure $ hang 2 $ sep [pat <++> !darrowD, body] export prettyLams : PrettyHL a => Pretty.HasEnv m => - Maybe (Doc HL) -> BinderSort -> SnocList BaseName -> a -> + Maybe (Doc HL) -> BinderSort -> SnocList BindName -> a -> m (Doc HL) prettyLams lam sort names body = do let var = case sort of T => TVar; D => DVar @@ -109,14 +110,15 @@ prettyLams lam sort names body = do public export -data TypeLine a = MkTypeLine BaseName a +data TypeLine a = MkTypeLine BindName a export PrettyHL a => PrettyHL (TypeLine a) where - prettyM (MkTypeLine Unused ty) = - bracks <$> pretty0M ty prettyM (MkTypeLine i ty) = - map bracks $ withPrec Outer $ prettyLams Nothing D [< i] ty + if i.name == Unused then + bracks <$> pretty0M ty + else + map bracks $ withPrec Outer $ prettyLams Nothing D [< i] ty export @@ -142,28 +144,28 @@ prettyTuple = map (parens . align . separate commaD) . traverse prettyM export prettyArms : PrettyHL a => Pretty.HasEnv m => - BinderSort -> List (SnocList BaseName, Doc HL, a) -> m (Doc HL) + BinderSort -> List (SnocList BindName, Doc HL, a) -> m (Doc HL) prettyArms s = map (braces . aseparate semiD) . traverse (\(xs, l, r) => prettyArm s xs l r) export prettyCase' : (PrettyHL a, PrettyHL b, PrettyHL c, Pretty.HasEnv m) => - Doc HL -> a -> BaseName -> b -> - List (SnocList BaseName, Doc HL, c) -> + Doc HL -> a -> BindName -> b -> + List (SnocList BindName, Doc HL, c) -> m (Doc HL) prettyCase' intro elim r ret arms = do elim <- pretty0M elim - ret <- case r of - Unused => under T r $ pretty0M ret + ret <- case r.name of + Unused => under T r.name $ pretty0M ret _ => prettyLams Nothing T [< r] ret arms <- prettyArms T arms pure $ asep [intro <++> elim, returnD <++> ret, ofD <++> arms] export prettyCase : (PrettyHL a, PrettyHL b, PrettyHL c, Pretty.HasEnv m) => - Qty -> a -> BaseName -> b -> - List (SnocList BaseName, Doc HL, c) -> + Qty -> a -> BindName -> b -> + List (SnocList BindName, Doc HL, c) -> m (Doc HL) prettyCase pi elim r ret arms = do caseq <- (caseD <+>) <$> prettySuffix pi @@ -197,14 +199,14 @@ prettyBoxVal : PrettyHL a => Pretty.HasEnv m => a -> m (Doc HL) prettyBoxVal val = bracks <$> pretty0M val export -prettyCompPat : Pretty.HasEnv m => DimConst -> BaseName -> m (Doc HL) -prettyCompPat e j = hsep <$> sequence [pretty0M e, pretty0M $ DV j] +prettyCompPat : Pretty.HasEnv m => DimConst -> BindName -> m (Doc HL) +prettyCompPat e j = hsep <$> sequence [pretty0M e, pretty0M $ DV j.name] export toNatLit : Term d n -> Maybe Nat -toNatLit Zero = Just 0 -toNatLit (Succ n) = [|S $ toNatLit n|] -toNatLit _ = Nothing +toNatLit (Zero _) = Just 0 +toNatLit (Succ n _) = [|S $ toNatLit n|] +toNatLit _ = Nothing private eterm : Term d n -> Exists (Term d) @@ -216,69 +218,69 @@ parameters (showSubsts : Bool) export covering [TermSubst] PrettyHL (Term d n) using ElimSubst where - prettyM (TYPE l) = + prettyM (TYPE l _) = pure $ !typeD <+> hl Syntax !(prettyUnivSuffix l) - prettyM (Pi qty s (S _ (N t))) = do + prettyM (Pi qty s (S _ (N t)) _) = do dom <- pretty0M $ MkWithQty qty s cod <- withPrec AnnR $ prettyM t parensIfM AnnR $ asep [dom <++> !arrowD, cod] - prettyM (Pi qty s (S [< x] (Y t))) = + prettyM (Pi qty s (S [< x] (Y t)) _) = prettyBindType (Just qty) x s !arrowD t - prettyM (Lam (S x t)) = + prettyM (Lam (S x t) _) = let GotLams {names, body, _} = getLams' x t.term Refl in prettyLams (Just !lamD) T (toSnocList' names) body - prettyM (Sig s (S _ (N t))) = do + prettyM (Sig s (S _ (N t)) _) = do s <- withPrec InTimes $ prettyM s t <- withPrec Times $ prettyM t parensIfM Times $ asep [s <++> !timesD, t] - prettyM (Sig s (S [< x] (Y t))) = + prettyM (Sig s (S [< x] (Y t)) _) = prettyBindType Nothing x s !timesD t - prettyM (Pair s t) = + prettyM (Pair s t _) = let GotPairs {init, last, _} = getPairs' [< s] t in prettyTuple $ toList $ init :< last - prettyM (Enum tags) = + prettyM (Enum tags _) = pure $ delims "{" "}" . aseparate comma $ map prettyTagBare $ Prelude.toList tags - prettyM (Tag t) = + prettyM (Tag t _) = pure $ prettyTag t - prettyM (Eq (S _ (N ty)) l r) = do + prettyM (Eq (S _ (N ty)) l r _) = do l <- withPrec InEq $ prettyM l r <- withPrec InEq $ prettyM r ty <- withPrec InEq $ prettyM ty parensIfM Eq $ asep [l <++> !eqndD, r <++> colonD, ty] - prettyM (Eq (S [< i] (Y ty)) l r) = do + prettyM (Eq (S [< i] (Y ty)) l r _) = do prettyApps Nothing (L eqD) [epretty $ MkTypeLine i ty, epretty l, epretty r] - prettyM (DLam (S i t)) = + 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 (Nat _) = natD - prettyM Zero = pure $ hl Syntax "0" + prettyM (Zero _) = pure $ hl Syntax "0" - prettyM (Succ n) = + prettyM (Succ n _) = case toNatLit n of Just n => pure $ hl Syntax $ pretty $ S n Nothing => prettyApps Nothing (L succD) [n] - prettyM (BOX pi ty) = do + prettyM (BOX pi ty _) = do pi <- pretty0M pi ty <- pretty0M ty pure $ bracks $ hcat [pi, dotD, align ty] - prettyM (Box val) = prettyBoxVal val + prettyM (Box val _) = prettyBoxVal val prettyM (E e) = prettyM e @@ -299,49 +301,49 @@ parameters (showSubsts : Bool) export covering [ElimSubst] PrettyHL (Elim d n) using TermSubst where - prettyM (F x) = + prettyM (F x _) = hl' Free <$> prettyM x - prettyM (B i) = + prettyM (B i _) = prettyVar TVar TVarErr (!ask).tnames i - prettyM (e :@ s) = + prettyM (App e s _) = let GotArgs {fun, args, _} = getArgs' e [s] in prettyApps Nothing fun args - prettyM (CasePair pi p (S [< r] ret) (S [< x, y] body)) = do + prettyM (CasePair pi p (S [< r] ret) (S [< x, y] body) _) = do pat <- parens . separate commaD <$> traverse (hlF TVar . prettyM) [x, y] prettyCase pi p r ret.term [([< x, y], pat, body.term)] - prettyM (CaseEnum pi t (S [< r] ret) arms) = + 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)) = + 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 = case (ih, pi') of - (Unused, Zero) => pure $ succD <++> !(pretty0M s) + (BN Unused _, Zero) => pure $ succD <++> !(pretty0M s) _ => pure $ asep [succD <++> !(pretty0M s) <+> comma, !(pretty0M $ MkWithQty pi' ih)] - prettyM (CaseBox pi box (S [< r] ret) (S [< u] body)) = + prettyM (CaseBox pi box (S [< r] ret) (S [< u] body) _) = prettyCase pi box r ret.term - [([< u], !(prettyBoxVal $ TV u), body.term)] + [([< u], !(prettyBoxVal $ TV u.name), body.term)] - prettyM (e :% d) = + prettyM (DApp e d _) = let GotDArgs {fun, args, _} = getDArgs' e [d] in prettyApps (Just "@") fun args - prettyM (s :# a) = do + prettyM (Ann s a _) = do s <- withPrec AnnL $ prettyM s a <- withPrec AnnR $ prettyM a parensIfM AnnR $ hang 2 $ s <++> !annD <%%> a - prettyM (Coe (S [< i] ty) p q val) = + prettyM (Coe (S [< i] ty) p q val _) = let ty = case ty of Y ty => epretty $ MkTypeLine i ty N ty => epretty ty @@ -352,9 +354,9 @@ parameters (showSubsts : Bool) (Just "@", epretty q), (Nothing, epretty val)] - prettyM (Comp ty p q val r (S [< z] zero) (S [< o] one)) = do + prettyM (Comp ty p q val r (S [< z] zero) (S [< o] one) _) = do apps <- prettyApps' (L compD) - [(Nothing, epretty $ MkTypeLine Unused ty), + [(Nothing, epretty $ MkTypeLine (BN Unused noLoc) ty), (Just "@", epretty p), (Just "@", epretty q), (Nothing, epretty val), @@ -364,29 +366,30 @@ parameters (showSubsts : Bool) ([< o], !(prettyCompPat One o), one.term)] pure $ apps <++> arms - prettyM (TypeCase ty ret arms def) = do + prettyM (TypeCase ty ret arms def _) = do arms <- traverse fromArm (toList arms) - prettyCase' typecaseD ty Unused ret $ + prettyCase' typecaseD ty (BN Unused noLoc) ret $ arms ++ [([<], hl Syntax "_", eterm def)] where - v : BaseName -> Doc HL - v = pretty0 True . TV + v : BindName -> Doc HL + v = pretty0 True . TV . name - tyCasePat : (k : TyConKind) -> NContext (arity k) -> m (Doc HL) + tyCasePat : (k : TyConKind) -> BContext (arity k) -> m (Doc HL) tyCasePat KTYPE [<] = typeD tyCasePat KPi [< a, b] = pure $ parens $ hsep [v a, !arrowD, v b] tyCasePat KSig [< a, b] = pure $ parens $ hsep [v a, !arrowD, v b] tyCasePat KEnum [<] = pure $ hl Syntax "{}" - tyCasePat KEq vars = prettyApps Nothing (L eqD) $ map TV $ toList' vars tyCasePat KNat [<] = natD tyCasePat KBOX [< a] = pure $ bracks $ v a + tyCasePat KEq vars = + prettyApps Nothing (L eqD) $ map (TV . name) $ toList' vars fromArm : TypeCaseArm d n -> - m (SnocList BaseName, Doc HL, Exists (Term d)) + m (SnocList BindName, Doc HL, Exists (Term d)) fromArm (k ** S ns t) = pure (toSnocList' ns, !(tyCasePat k ns), eterm t.term) - prettyM (CloE (Sub e th)) = + prettyM (CloE (Sub e th)) = if showSubsts then parensIfM SApp . hang 2 =<< [|withPrec SApp (prettyM e) <%> prettyTSubst th|] @@ -414,7 +417,7 @@ PrettyHL (Elim d n) where prettyM = prettyM @{ElimSubst False} export covering prettyTerm : (unicode : Bool) -> - (dnames : NContext d) -> (tnames : NContext n) -> + (dnames : BContext d) -> (tnames : BContext n) -> Term d n -> Doc HL prettyTerm unicode dnames tnames term = - pretty0With unicode (toSnocList' dnames) (toSnocList' tnames) term + pretty0With unicode (toNames dnames) (toNames tnames) term diff --git a/lib/Quox/Syntax/Term/Split.idr b/lib/Quox/Syntax/Term/Split.idr index eafda5d..300cf2c 100644 --- a/lib/Quox/Syntax/Term/Split.idr +++ b/lib/Quox/Syntax/Term/Split.idr @@ -13,8 +13,8 @@ import public Data.Vect public export %inline isLam : Term {} -> Bool -isLam (Lam _) = True -isLam _ = False +isLam (Lam {}) = True +isLam _ = False public export 0 NotLam : Pred $ Term {} @@ -23,8 +23,8 @@ NotLam = No . isLam public export %inline isDLam : Term {} -> Bool -isDLam (DLam _) = True -isDLam _ = False +isDLam (DLam {}) = True +isDLam _ = False public export 0 NotDLam : Pred $ Term {} @@ -43,7 +43,7 @@ NotPair = No . isPair public export %inline isApp : Elim {} -> Bool -isApp (_ :@ _) = True +isApp (App {}) = True isApp _ = False public export @@ -53,19 +53,21 @@ NotApp = No . isApp public export %inline isDApp : Elim {} -> Bool -isDApp (_ :% _) = True -isDApp _ = False +isDApp (DApp {}) = True +isDApp _ = False public export 0 NotDApp : Pred $ Elim {} NotDApp = No . isDApp -infixl 9 :@@ -||| apply multiple arguments at once -public export %inline -(:@@) : Elim d n -> List (Term d n) -> Elim d n -f :@@ ss = foldl (:@) f ss +-- infixl 9 :@@ +-- ||| apply multiple arguments at once +-- public export %inline +-- (:@@) : Elim d n -> List (Term d n) -> Elim d n +-- f :@@ ss = foldl app f ss where +-- app : Elim d n -> Term d n -> Elim d n +-- app f s = App f s (f.loc `extend'` s.loc.bounds) public export record GetArgs d n where @@ -85,7 +87,7 @@ mutual getArgsNc : (e : Elim d n) -> (0 nc : NotClo e) => List (Term d n) -> GetArgs d n getArgsNc fun args = case nchoose $ isApp fun of - Left y => let f :@ a = fun in getArgs' f (a :: args) + Left y => let App f a _ = fun in getArgs' f (a :: args) Right n => GotArgs {fun, args, notApp = n} ||| splits an application into its head and arguments. if it's not an @@ -96,11 +98,13 @@ getArgs : Elim d n -> GetArgs d n getArgs e = getArgs' e [] -infixl 9 :%% -||| apply multiple dimension arguments at once -public export %inline -(:%%) : Elim d n -> List (Dim d) -> Elim d n -f :%% ss = foldl (:%) f ss +-- infixl 9 :%% +-- ||| apply multiple dimension arguments at once +-- public export %inline +-- (:%%) : Elim d n -> List (Dim d) -> Elim d n +-- f :%% ss = foldl dapp f ss where +-- dapp : Elim d n -> Dim d -> Elim d n +-- dapp f p = DApp f p (f.loc `extend'` p.loc.bounds) public export record GetDArgs d n where @@ -120,7 +124,7 @@ mutual getDArgsNc : (e : Elim d n) -> (0 nc : NotClo e) => List (Dim d) -> GetDArgs d n getDArgsNc fun args = case nchoose $ isDApp fun of - Left y => let f :% d = fun in getDArgs' f (d :: args) + Left y => let DApp f d _ = fun in getDArgs' f (d :: args) Right n => GotDArgs {fun, args, notDApp = n} ||| splits a dimension application into its head and arguments. if it's not an @@ -130,33 +134,33 @@ getDArgs : Elim d n -> GetDArgs d n getDArgs e = getDArgs' e [] -infixr 1 :\\ -public export -absN : NContext m -> Term d (m + n) -> Term d n -absN [<] s = s -absN (xs :< x) s = absN xs $ Lam $ ST [< x] s +-- infixr 1 :\\ +-- public export +-- absN : BContext m -> Term d (m + n) -> Term d n +-- absN [<] s = s +-- absN (xs :< x) s = absN xs $ Lam (ST [< x] s) ?absloc -public export %inline -(:\\) : NContext m -> Term d (m + n) -> Term d n -(:\\) = absN +-- public export %inline +-- (:\\) : BContext m -> Term d (m + n) -> Term d n +-- (:\\) = absN -infixr 1 :\\% -public export -dabsN : NContext m -> Term (m + d) n -> Term d n -dabsN [<] s = s -dabsN (xs :< x) s = dabsN xs $ DLam $ DST [< x] s +-- infixr 1 :\\% +-- public export +-- dabsN : BContext m -> Term (m + d) n -> Term d n +-- dabsN [<] s = s +-- dabsN (xs :< x) s = dabsN xs $ DLam (DST [< x] s) ?dabsLoc -public export %inline -(:\\%) : NContext m -> Term (m + d) n -> Term d n -(:\\%) = dabsN +-- public export %inline +-- (:\\%) : BContext m -> Term (m + d) n -> Term d n +-- (:\\%) = dabsN public export record GetLams d n where constructor GotLams {0 lams, rest : Nat} - names : NContext lams + names : BContext lams body : Term d rest 0 eq : lams + n = rest 0 notLam : NotLam body @@ -164,7 +168,7 @@ record GetLams d n where mutual export %inline getLams' : forall lams, rest. - NContext lams -> Term d rest -> (0 eq : lams + n = rest) -> + BContext lams -> Term d rest -> (0 eq : lams + n = rest) -> GetLams d n getLams' xs s0 eq = let Element s nc = pushSubsts s0 in @@ -172,12 +176,12 @@ mutual private getLamsNc : forall lams, rest. - NContext lams -> + BContext lams -> (t : Term d rest) -> (0 nc : NotClo t) => (0 eq : lams + n = rest) -> GetLams d n getLamsNc xs s Refl = case nchoose $ isLam s of - Left y => let Lam (S [< x] body) = s in + Left y => let Lam (S [< x] body) _ = s in getLams' (xs :< x) (assert_smaller s body.term) Refl Right n => GotLams xs s Refl n @@ -190,7 +194,7 @@ public export record GetDLams d n where constructor GotDLams {0 lams, rest : Nat} - names : NContext lams + names : BContext lams body : Term rest n 0 eq : lams + d = rest 0 notDLam : NotDLam body @@ -198,7 +202,7 @@ record GetDLams d n where mutual export %inline getDLams' : forall lams, rest. - NContext lams -> Term rest n -> (0 eq : lams + d = rest) -> + BContext lams -> Term rest n -> (0 eq : lams + d = rest) -> GetDLams d n getDLams' xs s0 eq = let Element s nc = pushSubsts s0 in @@ -206,12 +210,12 @@ mutual private getDLamsNc : forall lams, rest. - NContext lams -> + BContext lams -> (t : Term rest n) -> (0 nc : NotClo t) => (0 eq : lams + d = rest) -> GetDLams d n getDLamsNc is s Refl = case nchoose $ isDLam s of - Left y => let DLam (S [< i] body) = s in + Left y => let DLam (S [< i] body) _ = s in getDLams' (is :< i) (assert_smaller s body.term) Refl Right n => GotDLams is s Refl n @@ -238,7 +242,7 @@ mutual (t : Term d n) -> (0 nc : NotClo t) => GetPairs d n getPairsNc ss t = case nchoose $ isPair t of - Left y => let Pair s t = t in + Left y => let Pair s t _ = t in getPairs' (ss :< s) t Right n => GotPairs ss t n diff --git a/lib/Quox/Syntax/Term/Subst.idr b/lib/Quox/Syntax/Term/Subst.idr index a0d2376..e525bbc 100644 --- a/lib/Quox/Syntax/Term/Subst.idr +++ b/lib/Quox/Syntax/Term/Subst.idr @@ -20,14 +20,14 @@ namespace CanDSubst export CanDSubst Term where s // Shift SZ = s - TYPE l // _ = TYPE l + TYPE l loc // _ = TYPE l loc DCloT (Sub s ph) // th = DCloT $ Sub s $ ph . th s // th = DCloT $ Sub s th private subDArgs : Elim dfrom n -> DSubst dfrom dto -> Elim dto n -subDArgs (f :% d) th = subDArgs f th :% (d // th) -subDArgs e th = DCloE $ Sub e th +subDArgs (DApp f d loc) th = DApp (subDArgs f th) (d // th) loc +subDArgs e th = DCloE $ Sub e th ||| does the minimal reasonable work: ||| - deletes the closure around a term variable @@ -39,9 +39,9 @@ subDArgs e th = DCloE $ Sub e th export CanDSubst Elim where e // Shift SZ = e - F x // _ = F x - B i // _ = B i - f :% d // th = subDArgs (f :% d) th + F x loc // _ = F x loc + B i loc // _ = B i loc + e@(DApp {}) // th = subDArgs e th DCloE (Sub e ph) // th = DCloE $ Sub e $ ph . th e // th = DCloE $ Sub e th @@ -61,8 +61,8 @@ namespace DSubst.DScopeTermN S ns (N body) // th = S ns $ N $ body // th -export %inline FromVar (Elim d) where fromVar = B -export %inline FromVar (Term d) where fromVar = E . fromVar +export %inline FromVar (Elim d) where fromVarLoc = B +export %inline FromVar (Term d) where fromVarLoc = E .: fromVar ||| does the minimal reasonable work: @@ -73,8 +73,8 @@ export %inline FromVar (Term d) where fromVar = E . fromVar ||| - otherwise, wraps in a new closure export CanSubstSelf (Elim d) where - F x // _ = F x - B i // th = th !! i + F x loc // _ = F x loc + B i loc // th = getLoc th i loc CloE (Sub e ph) // th = assert_total CloE $ Sub e $ ph . th e // th = case force th of Shift SZ => e @@ -93,7 +93,7 @@ namespace CanTSubst ||| - otherwise, wraps in a new closure export CanTSubst Term where - TYPE l // _ = TYPE l + TYPE l loc // _ = TYPE l loc E e // th = E $ e // th CloT (Sub s ph) // th = CloT $ Sub s $ ph . th s // th = case force th of @@ -192,12 +192,12 @@ dsub1 t p = dsubN t [< p] public export %inline -(.zero) : DScopeTerm d n -> Term d n -body.zero = dsub1 body $ K Zero +(.zero) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n +body.zero = dsub1 body $ K Zero loc public export %inline -(.one) : DScopeTerm d n -> Term d n -body.one = dsub1 body $ K One +(.one) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n +body.one = dsub1 body $ K One loc public export @@ -251,29 +251,34 @@ mutual mutual export PushSubsts Term Subst.isCloT where - pushSubstsWith th ph (TYPE l) = - nclo $ TYPE l - pushSubstsWith th ph (Pi qty a body) = - nclo $ Pi qty (a // th // ph) (body // th // ph) - pushSubstsWith th ph (Lam body) = - nclo $ Lam (body // th // ph) - pushSubstsWith th ph (Sig a b) = - nclo $ Sig (a // th // ph) (b // th // ph) - pushSubstsWith th ph (Pair s t) = - nclo $ Pair (s // th // ph) (t // th // ph) - pushSubstsWith th ph (Enum tags) = - nclo $ Enum tags - pushSubstsWith th ph (Tag tag) = - nclo $ Tag tag - pushSubstsWith th ph (Eq ty l r) = - 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 (BOX pi ty) = nclo $ BOX pi $ ty // th // ph - pushSubstsWith th ph (Box val) = nclo $ Box $ val // th // ph + pushSubstsWith th ph (TYPE l loc) = + nclo $ TYPE l loc + pushSubstsWith th ph (Pi qty a body loc) = + nclo $ Pi qty (a // th // ph) (body // th // ph) loc + pushSubstsWith th ph (Lam body loc) = + nclo $ Lam (body // th // ph) loc + pushSubstsWith th ph (Sig a b loc) = + nclo $ Sig (a // th // ph) (b // th // ph) loc + pushSubstsWith th ph (Pair s t loc) = + nclo $ Pair (s // th // ph) (t // th // ph) loc + pushSubstsWith th ph (Enum tags loc) = + nclo $ Enum tags loc + pushSubstsWith th ph (Tag tag loc) = + nclo $ Tag tag loc + pushSubstsWith th ph (Eq ty l r loc) = + nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc + pushSubstsWith th ph (DLam body loc) = + nclo $ DLam (body // th // ph) loc + pushSubstsWith _ _ (Nat loc) = + nclo $ Nat loc + pushSubstsWith _ _ (Zero loc) = + nclo $ Zero loc + pushSubstsWith th ph (Succ n loc) = + nclo $ Succ (n // th // ph) loc + pushSubstsWith th ph (BOX pi ty loc) = + nclo $ BOX pi (ty // th // ph) loc + pushSubstsWith th ph (Box val loc) = + nclo $ Box (val // th // ph) loc pushSubstsWith th ph (E e) = let Element e nc = pushSubstsWith th ph e in nclo $ E e pushSubstsWith th ph (CloT (Sub s ps)) = @@ -283,38 +288,38 @@ mutual export PushSubsts Elim Subst.isCloE where - pushSubstsWith th ph (F x) = - nclo $ F x - pushSubstsWith th ph (B i) = - let res = ph !! i in + pushSubstsWith th ph (F x loc) = + nclo $ F x loc + pushSubstsWith th ph (B i loc) = + let res = getLoc ph i loc in case nchoose $ isCloE res of Left yes => assert_total pushSubsts res Right no => Element res no - pushSubstsWith th ph (f :@ s) = - nclo $ (f // th // ph) :@ (s // th // ph) - pushSubstsWith th ph (CasePair pi p r b) = - nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) - pushSubstsWith th ph (CaseEnum pi t r arms) = + pushSubstsWith th ph (App f s loc) = + nclo $ App (f // th // ph) (s // th // ph) loc + pushSubstsWith th ph (CasePair pi p r b loc) = + nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc + pushSubstsWith th ph (CaseEnum pi t r arms loc) = 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) = + (map (\b => b // th // ph) arms) loc + pushSubstsWith th ph (CaseNat pi pi' n r z s loc) = nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph) - (z // th // ph) (s // th // ph) - pushSubstsWith th ph (CaseBox pi x r b) = - nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) - pushSubstsWith th ph (f :% d) = - nclo $ (f // th // ph) :% (d // th) - pushSubstsWith th ph (s :# a) = - nclo $ (s // th // ph) :# (a // th // ph) - pushSubstsWith th ph (Coe ty p q val) = - nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) - pushSubstsWith th ph (Comp ty p q val r zero one) = + (z // th // ph) (s // th // ph) loc + pushSubstsWith th ph (CaseBox pi x r b loc) = + nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) loc + pushSubstsWith th ph (DApp f d loc) = + nclo $ DApp (f // th // ph) (d // th) loc + pushSubstsWith th ph (Ann s a loc) = + nclo $ Ann (s // th // ph) (a // th // ph) loc + pushSubstsWith th ph (Coe ty p q val loc) = + nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) loc + pushSubstsWith th ph (Comp ty p q val r zero one loc) = nclo $ Comp (ty // th // ph) (p // th) (q // th) (val // th // ph) (r // th) - (zero // th // ph) (one // th // ph) - pushSubstsWith th ph (TypeCase ty ret arms def) = + (zero // th // ph) (one // th // ph) loc + pushSubstsWith th ph (TypeCase ty ret arms def loc) = nclo $ TypeCase (ty // th // ph) (ret // th // ph) - (map (\t => t // th // ph) arms) (def // th // ph) + (map (\t => t // th // ph) arms) (def // th // ph) loc pushSubstsWith th ph (CloE (Sub e ps)) = pushSubstsWith th (comp th ps ph) e pushSubstsWith th ph (DCloE (Sub e ps)) = @@ -323,14 +328,19 @@ mutual private %inline CompHY : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> - (r : Dim d) -> (zero, one : DScopeTerm d n) -> Elim d n -CompHY {ty, p, q, val, r, zero, one} = - let ty' = SY ty.names $ ty.term // (B VZ ::: shift 2) in + (r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n +CompHY {ty, p, q, val, r, zero, one, loc} = + -- [fixme] maintain location of existing B VZ + let ty' = SY ty.names $ ty.term // (B VZ noLoc ::: shift 2) in Comp { ty = dsub1 ty q, p, q, - val = E $ Coe ty p q val, r, - zero = SY zero.names $ E $ Coe ty' (B VZ) (weakD 1 q) zero.term, - one = SY one.names $ E $ Coe ty' (B VZ) (weakD 1 q) one.term + val = E $ Coe ty p q val val.loc, r, + -- [fixme] better locations for these vars? + zero = SY zero.names $ E $ + Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc, + one = SY one.names $ E $ + Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc, + loc } public export %inline @@ -338,26 +348,28 @@ CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) -> (zero : DScopeTerm d n) -> (one : DScopeTerm d n) -> + (loc : Loc) -> Elim d n -CompH' {ty, p, q, val, r, zero, one} = +CompH' {ty, p, q, val, r, zero, one, loc} = case dsqueeze ty of - S _ (N ty) => Comp {ty, p, q, val, r, zero, one} - S _ (Y _) => CompHY {ty, p, q, val, r, zero, one} + S _ (N ty) => Comp {ty, p, q, val, r, zero, one, loc} + S _ (Y _) => CompHY {ty, p, q, val, r, zero, one, loc} ||| heterogeneous composition, using Comp and Coe (and subst) ||| -||| comp [i ⇒ A] @p @q s { (r=0) j ⇒ t₀; (r=1) j ⇒ t₁ } +||| comp [i ⇒ A] @p @q s @r { 0 j ⇒ t₀; 1 j ⇒ t₁ } ||| ≔ -||| comp [A‹q/i›] @p @q (coe [i ⇒ A] @p @q s) { -||| (r=0) j ⇒ coe [i ⇒ A] @j @q t₀; -||| (r=1) j ⇒ coe [i ⇒ A] @j @q t₁ +||| comp [A‹q/i›] @p @q (coe [i ⇒ A] @p @q s) @r { +||| 0 j ⇒ coe [i ⇒ A] @j @q t₀; +||| 1 j ⇒ coe [i ⇒ A] @j @q t₁ ||| } public export %inline -CompH : (i : BaseName) -> (ty : Term (S d) n) -> +CompH : (i : BindName) -> (ty : Term (S d) n) -> (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) -> - (j0 : BaseName) -> (zero : Term (S d) n) -> - (j1 : BaseName) -> (one : Term (S d) n) -> + (j0 : BindName) -> (zero : Term (S d) n) -> + (j1 : BindName) -> (one : Term (S d) n) -> + (loc : Loc) -> Elim d n -CompH {i, ty, p, q, val, r, j0, zero, j1, one} = +CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} = CompH' {ty = SY [< i] ty, p, q, val, r, - zero = SY [< j0] zero, one = SY [< j0] one} + zero = SY [< j0] zero, one = SY [< j0] one, loc} diff --git a/lib/Quox/Syntax/Term/Tighten.idr b/lib/Quox/Syntax/Term/Tighten.idr index 74428a2..1062342 100644 --- a/lib/Quox/Syntax/Term/Tighten.idr +++ b/lib/Quox/Syntax/Term/Tighten.idr @@ -18,6 +18,12 @@ Tighten (Shift from) where tighten (Keep p) (SS by) = [|SS $ tighten p by|] +export +Tighten Dim where + tighten p (K e loc) = pure $ K e loc + tighten p (B i loc) = B <$> tighten p i <*> pure loc + + export tightenSub : (forall m, n. OPE m n -> env n -> Maybe (env m)) -> OPE to1 to2 -> Subst env from to2 -> Maybe (Subst env from to1) @@ -46,23 +52,35 @@ tightenDScope f p (S names (N body)) = S names . N <$> f p body mutual private tightenT : OPE n1 n2 -> Term d n2 -> Maybe (Term d n1) - tightenT p (TYPE l) = pure $ TYPE l - tightenT p (Pi qty arg res) = - Pi qty <$> tightenT p arg <*> tightenS p res - tightenT p (Lam body) = Lam <$> tightenS p body - tightenT p (Sig fst snd) = Sig <$> tightenT p fst <*> tightenS p snd - tightenT p (Pair fst snd) = Pair <$> tightenT p fst <*> tightenT p snd - tightenT p (Enum cases) = pure $ Enum cases - tightenT p (Tag tag) = pure $ Tag tag - tightenT p (Eq ty l r) = - Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r - tightenT p (DLam body) = DLam <$> tightenDS p body - tightenT p Nat = pure Nat - tightenT p Zero = pure Zero - tightenT p (Succ s) = Succ <$> tightenT p s - tightenT p (BOX qty ty) = BOX qty <$> tightenT p ty - tightenT p (Box val) = Box <$> tightenT p val - tightenT p (E e) = assert_total $ E <$> tightenE p e + tightenT p (TYPE l loc) = pure $ TYPE l loc + tightenT p (Pi qty arg res loc) = + Pi qty <$> tightenT p arg <*> tightenS p res <*> pure loc + tightenT p (Lam body loc) = + Lam <$> tightenS p body <*> pure loc + tightenT p (Sig fst snd loc) = + Sig <$> tightenT p fst <*> tightenS p snd <*> pure loc + tightenT p (Pair fst snd loc) = + Pair <$> tightenT p fst <*> tightenT p snd <*> pure loc + tightenT p (Enum cases loc) = + pure $ Enum cases loc + tightenT p (Tag tag loc) = + pure $ Tag tag loc + tightenT p (Eq ty l r loc) = + Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r <*> pure loc + tightenT p (DLam body loc) = + DLam <$> tightenDS p body <*> pure loc + tightenT p (Nat loc) = + pure $ Nat loc + tightenT p (Zero loc) = + pure $ Zero loc + tightenT p (Succ s loc) = + Succ <$> tightenT p s <*> pure loc + tightenT p (BOX qty ty loc) = + BOX qty <$> tightenT p ty <*> pure loc + tightenT p (Box val loc) = + Box <$> tightenT p val <*> pure loc + tightenT p (E e) = + assert_total $ E <$> tightenE p e tightenT p (CloT (Sub tm th)) = do th <- assert_total $ tightenSub tightenE p th pure $ CloT $ Sub tm th @@ -72,45 +90,57 @@ mutual private tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1) - tightenE p (F x) = pure $ F x - tightenE p (B i) = [|B $ tighten p i|] - tightenE p (fun :@ arg) = [|tightenE p fun :@ tightenT p arg|] - tightenE p (CasePair qty pair ret body) = + tightenE p (F x loc) = + pure $ F x loc + tightenE p (B i loc) = + B <$> tighten p i <*> pure loc + tightenE p (App fun arg loc) = + App <$> tightenE p fun <*> tightenT p arg <*> pure loc + tightenE p (CasePair qty pair ret body loc) = CasePair qty <$> tightenE p pair <*> tightenS p ret <*> tightenS p body - tightenE p (CaseEnum qty tag ret arms) = + <*> pure loc + tightenE p (CaseEnum qty tag ret arms loc) = CaseEnum qty <$> tightenE p tag <*> tightenS p ret <*> traverse (tightenT p) arms - tightenE p (CaseNat qty qtyIH nat ret zero succ) = + <*> pure loc + tightenE p (CaseNat qty qtyIH nat ret zero succ loc) = CaseNat qty qtyIH <$> tightenE p nat <*> tightenS p ret <*> tightenT p zero <*> tightenS p succ - tightenE p (CaseBox qty box ret body) = + <*> pure loc + tightenE p (CaseBox qty box ret body loc) = CaseBox qty <$> tightenE p box <*> tightenS p ret <*> tightenS p body - tightenE p (fun :% arg) = (:% arg) <$> tightenE p fun - tightenE p (tm :# ty) = [|tightenT p tm :# tightenT p ty|] - tightenE p (Coe ty q0 q1 val) = + <*> pure loc + tightenE p (DApp fun arg loc) = + DApp <$> tightenE p fun <*> pure arg <*> pure loc + tightenE p (Ann tm ty loc) = + Ann <$> tightenT p tm <*> tightenT p ty <*> pure loc + tightenE p (Coe ty q0 q1 val loc) = Coe <$> tightenDS p ty <*> pure q0 <*> pure q1 <*> tightenT p val - tightenE p (Comp ty q0 q1 val r zero one) = + <*> pure loc + tightenE p (Comp ty q0 q1 val r zero one loc) = Comp <$> tightenT p ty <*> pure q0 <*> pure q1 <*> tightenT p val <*> pure r <*> tightenDS p zero <*> tightenDS p one - tightenE p (TypeCase ty ret arms def) = + <*> pure loc + tightenE p (TypeCase ty ret arms def loc) = TypeCase <$> tightenE p ty <*> tightenT p ret <*> traverse (tightenS p) arms <*> tightenT p def + <*> pure loc tightenE p (CloE (Sub el th)) = do th <- assert_total $ tightenSub tightenE p th pure $ CloE $ Sub el th @@ -130,35 +160,40 @@ mutual export Tighten (Elim d) where tighten p e = tightenE p e export Tighten (Term d) where tighten p t = tightenT p t -export -Tighten Dim where - tighten p (K e) = pure $ K e - tighten p (B i) = B <$> tighten p i - mutual export dtightenT : OPE d1 d2 -> Term d2 n -> Maybe (Term d1 n) - dtightenT p (TYPE l) = pure $ TYPE l - dtightenT p (Pi qty arg res) = - Pi qty <$> dtightenT p arg <*> dtightenS p res - dtightenT p (Lam body) = - Lam <$> dtightenS p body - dtightenT p (Sig fst snd) = - Sig <$> dtightenT p fst <*> dtightenS p snd - dtightenT p (Pair fst snd) = - Pair <$> dtightenT p fst <*> dtightenT p snd - dtightenT p (Enum cases) = pure $ Enum cases - dtightenT p (Tag tag) = pure $ Tag tag - dtightenT p (Eq ty l r) = - Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r - dtightenT p (DLam body) = DLam <$> dtightenDS p body - dtightenT p Nat = pure Nat - dtightenT p Zero = pure Zero - dtightenT p (Succ s) = Succ <$> dtightenT p s - dtightenT p (BOX qty ty) = BOX qty <$> dtightenT p ty - dtightenT p (Box val) = Box <$> dtightenT p val - dtightenT p (E e) = assert_total $ E <$> dtightenE p e + dtightenT p (TYPE l loc) = + pure $ TYPE l loc + dtightenT p (Pi qty arg res loc) = + Pi qty <$> dtightenT p arg <*> dtightenS p res <*> pure loc + dtightenT p (Lam body loc) = + Lam <$> dtightenS p body <*> pure loc + dtightenT p (Sig fst snd loc) = + Sig <$> dtightenT p fst <*> dtightenS p snd <*> pure loc + dtightenT p (Pair fst snd loc) = + Pair <$> dtightenT p fst <*> dtightenT p snd <*> pure loc + dtightenT p (Enum cases loc) = + pure $ Enum cases loc + dtightenT p (Tag tag loc) = + pure $ Tag tag loc + dtightenT p (Eq ty l r loc) = + Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r <*> pure loc + dtightenT p (DLam body loc) = + DLam <$> dtightenDS p body <*> pure loc + dtightenT p (Nat loc) = + pure $ Nat loc + dtightenT p (Zero loc) = + pure $ Zero loc + dtightenT p (Succ s loc) = + Succ <$> dtightenT p s <*> pure loc + dtightenT p (BOX qty ty loc) = + BOX qty <$> dtightenT p ty <*> pure loc + dtightenT p (Box val loc) = + Box <$> dtightenT p val <*> pure loc + dtightenT p (E e) = + assert_total $ E <$> dtightenE p e dtightenT p (CloT (Sub tm th)) = do tm <- dtightenT p tm th <- assert_total $ traverse (dtightenE p) th @@ -169,38 +204,48 @@ mutual export dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n) - dtightenE p (F x) = pure $ F x - dtightenE p (B i) = pure $ B i - dtightenE p (fun :@ arg) = [|dtightenE p fun :@ dtightenT p arg|] - dtightenE p (CasePair qty pair ret body) = + dtightenE p (F x loc) = + pure $ F x loc + dtightenE p (B i loc) = + pure $ B i loc + dtightenE p (App fun arg loc) = + App <$> dtightenE p fun <*> dtightenT p arg <*> pure loc + dtightenE p (CasePair qty pair ret body loc) = CasePair qty <$> dtightenE p pair <*> dtightenS p ret <*> dtightenS p body - dtightenE p (CaseEnum qty tag ret arms) = + <*> pure loc + dtightenE p (CaseEnum qty tag ret arms loc) = CaseEnum qty <$> dtightenE p tag <*> dtightenS p ret <*> traverse (dtightenT p) arms - dtightenE p (CaseNat qty qtyIH nat ret zero succ) = + <*> pure loc + dtightenE p (CaseNat qty qtyIH nat ret zero succ loc) = CaseNat qty qtyIH <$> dtightenE p nat <*> dtightenS p ret <*> dtightenT p zero <*> dtightenS p succ - dtightenE p (CaseBox qty box ret body) = + <*> pure loc + dtightenE p (CaseBox qty box ret body loc) = CaseBox qty <$> dtightenE p box <*> dtightenS p ret <*> dtightenS p body - dtightenE p (fun :% arg) = [|dtightenE p fun :% tighten p arg|] - dtightenE p (tm :# ty) = [|dtightenT p tm :# dtightenT p ty|] - dtightenE p (Coe ty q0 q1 val) = - [|Coe (dtightenDS p ty) (tighten p q0) (tighten p q1) (dtightenT p val)|] - dtightenE p (Comp ty q0 q1 val r zero one) = + <*> pure loc + dtightenE p (DApp fun arg loc) = + DApp <$> dtightenE p fun <*> tighten p arg <*> pure loc + dtightenE p (Ann tm ty loc) = + Ann <$> dtightenT p tm <*> dtightenT p ty <*> pure loc + dtightenE p (Coe ty q0 q1 val loc) = + [|Coe (dtightenDS p ty) (tighten p q0) (tighten p q1) (dtightenT p val) + (pure loc)|] + dtightenE p (Comp ty q0 q1 val r zero one loc) = [|Comp (dtightenT p ty) (tighten p q0) (tighten p q1) (dtightenT p val) (tighten p r) - (dtightenDS p zero) (dtightenDS p one)|] - dtightenE p (TypeCase ty ret arms def) = + (dtightenDS p zero) (dtightenDS p one) (pure loc)|] + dtightenE p (TypeCase ty ret arms def loc) = [|TypeCase (dtightenE p ty) (dtightenT p ret) - (traverse (dtightenS p) arms) (dtightenT p def)|] + (traverse (dtightenS p) arms) (dtightenT p def) (pure loc)|] dtightenE p (CloE (Sub el th)) = do el <- dtightenE p el th <- assert_total $ traverse (dtightenE p) th @@ -226,46 +271,55 @@ export [ElimD] Tighten (\d => Elim d n) where tighten p e = dtightenE p e -- versions of SY, etc, that try to tighten and use SN automatically public export -ST : Tighten f => {s : Nat} -> NContext s -> f (s + n) -> Scoped s f n +ST : Tighten f => {s : Nat} -> BContext s -> f (s + n) -> Scoped s f n ST names body = case tightenN s body of Just body => S names $ N body Nothing => S names $ Y body public export -DST : {s : Nat} -> NContext s -> Term (s + d) n -> DScopeTermN s d n +DST : {s : Nat} -> BContext s -> Term (s + d) n -> DScopeTermN s d n DST names body = case tightenN @{TermD} s body of Just body => S names $ N body Nothing => S names $ Y body public export %inline -PiT : (qty : Qty) -> (x : BaseName) -> - (arg : Term d n) -> (res : Term d (S n)) -> Term d n -PiT {qty, x, arg, res} = Pi {qty, arg, res = ST [< x] res} +PiT : (qty : Qty) -> (x : BindName) -> + (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n +PiT {qty, x, arg, res, loc} = Pi {qty, arg, res = ST [< x] res, loc} public export %inline -SigT : (x : BaseName) -> (fst : Term d n) -> - (snd : Term d (S n)) -> Term d n -SigT {x, fst, snd} = Sig {fst, snd = ST [< x] snd} +LamT : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n +LamT {x, body, loc} = Lam {body = ST [< x] body, loc} public export %inline -EqT : (i : BaseName) -> (ty : Term (S d) n) -> - (l, r : Term d n) -> Term d n -EqT {i, ty, l, r} = Eq {ty = DST [< i] ty, l, r} +SigT : (x : BindName) -> (fst : Term d n) -> + (snd : Term d (S n)) -> (loc : Loc) -> Term d n +SigT {x, fst, snd, loc} = Sig {fst, snd = ST [< x] snd, loc} public export %inline -CoeT : (i : BaseName) -> (ty : Term (S d) n) -> - (p, q : Dim d) -> (val : Term d n) -> Elim d n -CoeT {i, ty, p, q, val} = Coe {ty = DST [< i] ty, p, q, val} +EqT : (i : BindName) -> (ty : Term (S d) n) -> + (l, r : Term d n) -> (loc : Loc) -> Term d n +EqT {i, ty, l, r, loc} = Eq {ty = DST [< i] ty, l, r, loc} + +public export %inline +DLamT : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n +DLamT {i, body, loc} = DLam {body = DST [< i] body, loc} + +public export %inline +CoeT : (i : BindName) -> (ty : Term (S d) n) -> + (p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n +CoeT {i, ty, p, q, val, loc} = Coe {ty = DST [< i] ty, p, q, val, loc} public export %inline typeCase1T : Elim d n -> Term d n -> - (k : TyConKind) -> NContext (arity k) -> Term d (arity k + n) -> - {default Nat def : Term d n} -> + (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) -> + (loc : Loc) -> + {default (Nat loc) def : Term d n} -> Elim d n -typeCase1T ty ret k ns body {def} = - typeCase ty ret [(k ** ST ns body)] def +typeCase1T ty ret k ns body loc {def} = + typeCase ty ret [(k ** ST ns body)] def loc export diff --git a/lib/Quox/Syntax/Var.idr b/lib/Quox/Syntax/Var.idr index 137c952..c0b57fa 100644 --- a/lib/Quox/Syntax/Var.idr +++ b/lib/Quox/Syntax/Var.idr @@ -1,6 +1,7 @@ module Quox.Syntax.Var -import Quox.Name +import public Quox.Loc +import public Quox.Name import Quox.Pretty import Quox.OPE @@ -42,6 +43,23 @@ export Uninhabited (VZ = VS i) where uninhabited _ impossible export Uninhabited (VS i = VZ) where uninhabited _ impossible +public export +data Eqv : Var m -> Var n -> Type where + EZ : VZ `Eqv` VZ + ES : i `Eqv` j -> VS i `Eqv` VS j +%name Var.Eqv e + +export +decEqv : Dec2 Eqv +decEqv VZ VZ = Yes EZ +decEqv VZ (VS i) = No $ \case _ impossible +decEqv (VS i) VZ = No $ \case _ impossible +decEqv (VS i) (VS j) = + case decEqv i j of + Yes y => Yes $ ES y + No n => No $ \(ES y) => n y + + private lookupS : Nat -> SnocList a -> Maybe a lookupS _ [<] = Nothing @@ -148,9 +166,13 @@ weakIsSpec p i = toNatInj $ trans (weakCorrect p i) (sym $ weakSpecCorrect p i) public export -interface FromVar f where %inline fromVar : Var n -> f n +interface FromVar f where %inline fromVarLoc : Var n -> Loc -> f n -public export FromVar Var where fromVar = id +public export %inline +fromVar : FromVar f => Var n -> {default noLoc loc : Loc} -> f n +fromVar x = fromVarLoc x loc + +public export FromVar Var where fromVarLoc x _ = x export tabulateV : {0 tm : Nat -> Type} -> (forall n. Var n -> tm n) -> diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index 8e077ef..bfe0208 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -13,26 +13,30 @@ import Quox.EffExtra public export 0 TCEff : List (Type -> Type) -TCEff = [ErrorEff, DefsReader] +TCEff = [ErrorEff, DefsReader, NameGen] public export 0 TC : Type -> Type TC = Eff TCEff export -runTC : Definitions -> TC a -> Either Error a -runTC defs = - extract . runExcept . runReaderAt DEFS defs - +runTCWith : NameSuf -> Definitions -> TC a -> (Either Error a, NameSuf) +runTCWith = runEqualWith export -popQs : Has ErrorEff fs => QContext s -> QOutput (s + n) -> Eff fs (QOutput n) -popQs [<] qout = pure qout -popQs (pis :< pi) (qout :< rh) = do expectCompatQ rh pi; popQs pis qout +runTC : Definitions -> TC a -> Either Error a +runTC = runEqual -export %inline -popQ : Has ErrorEff fs => Qty -> QOutput (S n) -> Eff fs (QOutput n) -popQ pi = popQs [< pi] + +parameters (loc : Loc) + export + popQs : Has ErrorEff fs => QContext s -> QOutput (s + n) -> Eff fs (QOutput n) + popQs [<] qout = pure qout + popQs (pis :< pi) (qout :< rh) = do expectCompatQ loc rh pi; popQs pis qout + + export %inline + popQ : Has ErrorEff fs => Qty -> QOutput (S n) -> Eff fs (QOutput n) + popQ pi = popQs [< pi] export lubs1 : List1 (QOutput n) -> Maybe (QOutput n) @@ -47,29 +51,32 @@ lubs ctx [] = Just $ zeroFor ctx lubs ctx (x :: xs) = lubs1 $ x ::: xs -||| context extension with no names or quantities -private -CtxExtension0' : Nat -> Nat -> Nat -> Type -CtxExtension0' s d n = Context (Term d . (+ n)) s - -private -addNames0 : Context (Term d . (+ n)) s -> NContext s -> CtxExtension d n (s + n) -addNames0 [<] [<] = [<] -addNames0 (ts :< t) (xs :< x) = addNames0 ts xs :< (Zero, x, t) - export -typecaseTel : (k : TyConKind) -> Universe -> CtxExtension0' (arity k) d n -typecaseTel k u = case k of +typecaseTel : (k : TyConKind) -> BContext (arity k) -> Universe -> + CtxExtension d n (arity k + n) +typecaseTel k xs u = case k of KTYPE => [<] -- A : ★ᵤ, B : 0.A → ★ᵤ - KPi => [< TYPE u, Arr Zero (BVT 0) (TYPE u)] - KSig => [< TYPE u, Arr Zero (BVT 0) (TYPE u)] + KPi => + let [< a, b] = xs in + [< (Zero, a, TYPE u a.loc), + (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] + KSig => + let [< a, b] = xs in + [< (Zero, a, TYPE u a.loc), + (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] KEnum => [<] -- A₀ : ★ᵤ, A₁ : ★ᵤ, A : (A₀ ≡ A₁ : ★ᵤ), L : A₀, R : A₀ - KEq => [< TYPE u, TYPE u, Eq0 (TYPE u) (BVT 1) (BVT 0), BVT 2, BVT 2] + KEq => + let [< a0, a1, a, l, r] = xs in + [< (Zero, a0, TYPE u a0.loc), + (Zero, a1, TYPE u a1.loc), + (Zero, a, Eq0 (TYPE u a.loc) (BVT 1 a.loc) (BVT 0 a.loc) a.loc), + (Zero, l, BVT 2 l.loc), + (Zero, r, BVT 2 r.loc)] KNat => [<] -- A : ★ᵤ - KBOX => [< TYPE u] + KBOX => let [< a] = xs in [< (Zero, a, TYPE u a.loc)] mutual @@ -149,8 +156,8 @@ mutual (subj : Term d n) -> (0 nc : NotClo subj) => Term d n -> TC (CheckResult' n) toCheckType ctx sg t ty = do - u <- expectTYPE !defs ctx ty - expectEqualQ Zero sg.fst + u <- expectTYPE !defs ctx ty.loc ty + expectEqualQ t.loc Zero sg.fst checkTypeNoWrap ctx t (Just u) pure $ zeroFor ctx @@ -159,70 +166,70 @@ mutual (subj : Term d n) -> (0 nc : NotClo subj) => Term d n -> TC (CheckResult' n) - check' ctx sg t@(TYPE _) ty = toCheckType ctx sg t ty + check' ctx sg t@(TYPE {}) ty = toCheckType ctx sg t ty check' ctx sg t@(Pi {}) ty = toCheckType ctx sg t ty - check' ctx sg (Lam body) ty = do - (qty, arg, res) <- expectPi !defs ctx ty + check' ctx sg (Lam body loc) ty = do + (qty, arg, res) <- expectPi !defs ctx ty.loc ty -- if Ψ | Γ, x : A ⊢ σ · t ⇐ B ⊳ Σ, ρ·x -- with ρ ≤ σπ let qty' = sg.fst * qty qout <- checkC (extendTy qty' body.name arg ctx) sg body.term res.term -- then Ψ | Γ ⊢ σ · (λx ⇒ t) ⇐ (π·x : A) → B ⊳ Σ - popQ qty' qout + popQ loc qty' qout check' ctx sg t@(Sig {}) ty = toCheckType ctx sg t ty - check' ctx sg (Pair fst snd) ty = do - (tfst, tsnd) <- expectSig !defs ctx ty + check' ctx sg (Pair fst snd loc) ty = do + (tfst, tsnd) <- expectSig !defs ctx ty.loc ty -- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ₁ qfst <- checkC ctx sg fst tfst - let tsnd = sub1 tsnd (fst :# tfst) + let tsnd = sub1 tsnd (Ann fst tfst fst.loc) -- if Ψ | Γ ⊢ σ · t ⇐ B[s] ⊳ Σ₂ qsnd <- checkC ctx sg snd tsnd -- then Ψ | Γ ⊢ σ · (s, t) ⇐ (x : A) × B ⊳ Σ₁ + Σ₂ pure $ qfst + qsnd - check' ctx sg t@(Enum _) ty = toCheckType ctx sg t ty + check' ctx sg t@(Enum {}) ty = toCheckType ctx sg t ty - check' ctx sg (Tag t) ty = do - tags <- expectEnum !defs ctx ty + check' ctx sg (Tag t loc) ty = do + tags <- expectEnum !defs ctx ty.loc ty -- if t ∈ ts - unless (t `elem` tags) $ throw $ TagNotIn t tags + unless (t `elem` tags) $ throw $ TagNotIn loc t tags -- then Ψ | Γ ⊢ σ · t ⇐ {ts} ⊳ 𝟎 pure $ zeroFor ctx check' ctx sg t@(Eq {}) ty = toCheckType ctx sg t ty - check' ctx sg (DLam body) ty = do - (ty, l, r) <- expectEq !defs ctx ty + check' ctx sg (DLam body loc) ty = do + (ty, l, r) <- expectEq !defs ctx ty.loc ty let ctx' = extendDim body.name ctx ty = ty.term body = body.term -- if Ψ, i | Γ ⊢ σ · t ⇐ A ⊳ Σ qout <- checkC ctx' sg body ty -- if Ψ, i, i = 0 | Γ ⊢ t = l : A - equal (eqDim (BV 0) (K Zero) ctx') ty body (dweakT 1 l) + lift $ equal loc (eqDim (B VZ loc) (K Zero loc) ctx') ty body (dweakT 1 l) -- if Ψ, i, i = 1 | Γ ⊢ t = r : A - equal (eqDim (BV 0) (K One) ctx') ty body (dweakT 1 r) + lift $ equal loc (eqDim (B VZ loc) (K One loc) ctx') ty body (dweakT 1 r) -- then Ψ | Γ ⊢ σ · (δ i ⇒ t) ⇐ Eq [i ⇒ A] l r ⊳ Σ pure qout - check' ctx sg Nat ty = toCheckType ctx sg Nat ty + check' ctx sg t@(Nat {}) ty = toCheckType ctx sg t ty - check' ctx sg Zero ty = do - expectNat !defs ctx ty + check' ctx sg (Zero {}) ty = do + expectNat !defs ctx ty.loc ty pure $ zeroFor ctx - check' ctx sg (Succ n) ty = do - expectNat !defs ctx ty - checkC ctx sg n Nat + check' ctx sg (Succ n {}) ty = do + expectNat !defs ctx ty.loc ty + checkC ctx sg n ty check' ctx sg t@(BOX {}) ty = toCheckType ctx sg t ty - check' ctx sg (Box val) ty = do - (q, ty) <- expectBOX !defs ctx ty + check' ctx sg (Box val loc) ty = do + (q, ty) <- expectBOX !defs ctx ty.loc ty -- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ valout <- checkC ctx sg val ty -- then Ψ | Γ ⊢ σ · [s] ⇐ [π.A] ⊳ πΣ @@ -232,7 +239,7 @@ mutual -- if Ψ | Γ ⊢ σ · e ⇒ A' ⊳ Σ infres <- inferC ctx sg e -- if Ψ | Γ ⊢ A' <: A - subtype ctx infres.type ty + lift $ subtype e.loc ctx infres.type ty -- then Ψ | Γ ⊢ σ · e ⇐ A ⊳ Σ pure infres.qout @@ -241,13 +248,13 @@ mutual (subj : Term d n) -> (0 nc : NotClo subj) => Maybe Universe -> TC () - checkType' ctx (TYPE k) u = do + checkType' ctx (TYPE k loc) u = do -- if 𝓀 < ℓ then Ψ | Γ ⊢₀ Type 𝓀 ⇐ Type ℓ case u of - Just l => unless (k < l) $ throw $ BadUniverse k l + Just l => unless (k < l) $ throw $ BadUniverse loc k l Nothing => pure () - checkType' ctx (Pi qty arg res) u = do + checkType' ctx (Pi qty arg res _) u = do -- if Ψ | Γ ⊢₀ A ⇐ Type ℓ checkTypeC ctx arg u -- if Ψ | Γ, x : A ⊢₀ B ⇐ Type ℓ @@ -255,9 +262,9 @@ mutual -- then Ψ | Γ ⊢₀ (π·x : A) → B ⇐ Type ℓ checkType' ctx t@(Lam {}) u = - throw $ NotType ctx t + throw $ NotType t.loc ctx t - checkType' ctx (Sig fst snd) u = do + checkType' ctx (Sig fst snd _) u = do -- if Ψ | Γ ⊢₀ A ⇐ Type ℓ checkTypeC ctx fst u -- if Ψ | Γ, x : A ⊢₀ B ⇐ Type ℓ @@ -265,15 +272,15 @@ mutual -- then Ψ | Γ ⊢₀ (x : A) × B ⇐ Type ℓ checkType' ctx t@(Pair {}) u = - throw $ NotType ctx t + throw $ NotType t.loc ctx t - checkType' ctx (Enum _) u = pure () + checkType' ctx (Enum {}) u = pure () -- Ψ | Γ ⊢₀ {ts} ⇐ Type ℓ checkType' ctx t@(Tag {}) u = - throw $ NotType ctx t + throw $ NotType t.loc ctx t - checkType' ctx (Eq t l r) u = do + checkType' ctx (Eq t l r _) u = do -- if Ψ, i | Γ ⊢₀ A ⇐ Type ℓ case t.body of Y t' => checkTypeC (extendDim t.name ctx) t' u @@ -285,50 +292,31 @@ mutual -- then Ψ | Γ ⊢₀ Eq [i ⇒ A] l r ⇐ Type ℓ checkType' ctx t@(DLam {}) u = - throw $ NotType ctx t + throw $ NotType t.loc ctx t - checkType' ctx Nat u = pure () - checkType' ctx Zero u = throw $ NotType ctx Zero - checkType' ctx t@(Succ _) u = throw $ NotType ctx t + checkType' ctx (Nat {}) u = pure () + checkType' ctx t@(Zero {}) u = throw $ NotType t.loc ctx t + checkType' ctx t@(Succ {}) u = throw $ NotType t.loc ctx t - checkType' ctx (BOX q ty) u = checkType ctx ty u - checkType' ctx t@(Box _) u = throw $ NotType ctx t + checkType' ctx (BOX q ty _) u = checkType ctx ty u + checkType' ctx t@(Box {}) u = throw $ NotType t.loc ctx t checkType' ctx (E e) u = do -- if Ψ | Γ ⊢₀ E ⇒ Type ℓ infres <- inferC ctx szero e -- if Ψ | Γ ⊢ Type ℓ <: Type 𝓀 case u of - Just u => subtype ctx infres.type (TYPE u) - Nothing => ignore $ - expectTYPE !defs ctx infres.type + Just u => lift $ subtype e.loc ctx infres.type (TYPE u noLoc) + Nothing => ignore $ expectTYPE !defs ctx e.loc infres.type -- then Ψ | Γ ⊢₀ E ⇐ Type 𝓀 - private covering - check0ScopeN : {s : Nat} -> - TyContext d n -> CtxExtension0' s d n -> - ScopeTermN s d n -> Term d n -> TC () - check0ScopeN ctx ext (S _ (N body)) ty = check0 ctx body ty - check0ScopeN ctx ext (S names (Y body)) ty = - check0 (extendTyN (addNames0 ext names) ctx) body (weakT s ty) - - private covering - check0Scope : TyContext d n -> Term d n -> - ScopeTerm d n -> Term d n -> TC () - check0Scope ctx t = check0ScopeN ctx [< t] - - - private covering - checkTypeScopeN : TyContext d n -> CtxExtension0' s d n -> - ScopeTermN s d n -> Maybe Universe -> TC () - checkTypeScopeN ctx ext (S _ (N body)) u = checkType ctx body u - checkTypeScopeN ctx ext (S names (Y body)) u = - checkType (extendTyN (addNames0 ext names) ctx) body u private covering checkTypeScope : TyContext d n -> Term d n -> ScopeTerm d n -> Maybe Universe -> TC () - checkTypeScope ctx s = checkTypeScopeN ctx [< s] + checkTypeScope ctx s (S _ (N body)) u = checkType ctx body u + checkTypeScope ctx s (S [< x] (Y body)) u = + checkType (extendTy Zero x s ctx) body u private covering @@ -336,20 +324,20 @@ mutual (subj : Elim d n) -> (0 nc : NotClo subj) => TC (InferResult' d n) - infer' ctx sg (F x) = do + infer' ctx sg (F x loc) = do -- if π·x : A {≔ s} in global context - g <- lookupFree x !defs + g <- lookupFree x loc !defs -- if σ ≤ π - expectCompatQ sg.fst g.qty.fst + expectCompatQ loc sg.fst g.qty.fst -- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎 let Val d = ctx.dimLen; Val n = ctx.termLen pure $ InfRes {type = g.type, qout = zeroFor ctx} - infer' ctx sg (B i) = + infer' ctx sg (B i _) = -- if x : A ∈ Γ -- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ (𝟎, σ·x, 𝟎) pure $ lookupBound sg.fst i ctx.tctx - where + where lookupBound : forall n. Qty -> Var n -> TContext d n -> InferResult' d n lookupBound pi VZ (ctx :< type) = InfRes {type = weakT 1 type, qout = zeroFor ctx :< pi} @@ -357,19 +345,19 @@ mutual let InfRes {type, qout} = lookupBound pi i ctx in InfRes {type = weakT 1 type, qout = qout :< Zero} - infer' ctx sg (fun :@ arg) = do + infer' ctx sg (App fun arg loc) = do -- if Ψ | Γ ⊢ σ · f ⇒ (π·x : A) → B ⊳ Σ₁ funres <- inferC ctx sg fun - (qty, argty, res) <- expectPi !defs ctx funres.type + (qty, argty, res) <- expectPi !defs ctx fun.loc funres.type -- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ₂ argout <- checkC ctx (subjMult sg qty) arg argty -- then Ψ | Γ ⊢ σ · f s ⇒ B[s] ⊳ Σ₁ + πΣ₂ pure $ InfRes { - type = sub1 res $ arg :# argty, + type = sub1 res $ Ann arg argty arg.loc, qout = funres.qout + qty * argout } - infer' ctx sg (CasePair pi pair ret body) = do + infer' ctx sg (CasePair pi pair ret body loc) = do -- no check for 1 ≤ π, since pairs have a single constructor. -- e.g. at 0 the components are also 0 in the body -- @@ -377,27 +365,28 @@ mutual pairres <- inferC ctx sg pair -- if Ψ | Γ, p : (x : A) × B ⊢₀ ret ⇐ Type checkTypeC (extendTy Zero ret.name pairres.type ctx) ret.term Nothing - (tfst, tsnd) <- expectSig !defs ctx pairres.type + (tfst, tsnd) <- expectSig !defs ctx pair.loc pairres.type -- if Ψ | Γ, x : A, y : B ⊢ σ · body ⇐ -- ret[(x, y) ∷ (x : A) × B/p] ⊳ Σ₂, ρ₁·x, ρ₂·y -- with ρ₁, ρ₂ ≤ πσ let [< x, y] = body.names pisg = pi * sg.fst bodyctx = extendTyN [< (pisg, x, tfst), (pisg, y, tsnd.term)] ctx - bodyty = substCasePairRet pairres.type ret - bodyout <- checkC bodyctx sg body.term bodyty >>= popQs [< pisg, pisg] + bodyty = substCasePairRet body.names pairres.type ret + bodyout <- checkC bodyctx sg body.term bodyty >>= + popQs loc [< pisg, pisg] -- then Ψ | Γ ⊢ σ · caseπ ⋯ ⇒ ret[pair/p] ⊳ πΣ₁ + Σ₂ pure $ InfRes { type = sub1 ret pair, qout = pi * pairres.qout + bodyout } - infer' ctx sg (CaseEnum pi t ret arms) {d, n} = do + infer' ctx sg (CaseEnum pi t ret arms loc) {d, n} = do -- if Ψ | Γ ⊢ σ · t ⇒ {ts} ⊳ Σ₁ tres <- inferC ctx sg t - ttags <- expectEnum !defs ctx tres.type + ttags <- expectEnum !defs ctx t.loc tres.type -- if 1 ≤ π, OR there is only zero or one option - unless (length (SortedSet.toList ttags) <= 1) $ expectCompatQ One pi + unless (length (SortedSet.toList ttags) <= 1) $ expectCompatQ loc One pi -- if Ψ | Γ, x : {ts} ⊢₀ A ⇐ Type checkTypeC (extendTy Zero ret.name tres.type ctx) ret.term Nothing -- if for each "a ⇒ s" in arms, @@ -405,109 +394,109 @@ mutual -- with Σ₂ = lubs Σᵢ let arms = SortedMap.toList arms let armTags = SortedSet.fromList $ map fst arms - unless (ttags == armTags) $ throw $ BadCaseEnum ttags armTags + unless (ttags == armTags) $ throw $ BadCaseEnum loc ttags armTags armres <- for arms $ \(a, s) => - checkC ctx sg s (sub1 ret (Tag a :# tres.type)) + checkC ctx sg s $ sub1 ret $ Ann (Tag a s.loc) tres.type s.loc let Just armout = lubs ctx armres - | _ => throw $ BadQtys "case arms" ctx $ - zipWith (\qs, (t, rhs) => (qs, Tag t)) armres arms + | _ => throw $ BadQtys loc "case arms" ctx $ + zipWith (\qs, (t, rhs) => (qs, Tag t noLoc)) armres arms pure $ InfRes { type = sub1 ret t, qout = pi * tres.qout + armout } - infer' ctx sg (CaseNat pi pi' n ret zer suc) = do + infer' ctx sg (CaseNat pi pi' n ret zer suc loc) = do -- if 1 ≤ π - expectCompatQ One pi + expectCompatQ loc One pi -- if Ψ | Γ ⊢ σ · n ⇒ ℕ ⊳ Σn nres <- inferC ctx sg n - expectNat !defs ctx nres.type + let nat = nres.type + expectNat !defs ctx n.loc nat -- if Ψ | Γ, n : ℕ ⊢₀ A ⇐ Type - checkTypeC (extendTy Zero ret.name Nat ctx) ret.term Nothing + 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)) + zerout <- checkC ctx sg zer $ sub1 ret $ Ann (Zero zer.loc) nat zer.loc -- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ₁.p, ρ₂.ih -- with ρ₂ ≤ π'σ, (ρ₁ + ρ₂) ≤ πσ let [< p, ih] = suc.names pisg = pi * sg.fst - sucCtx = extendTyN [< (pisg, p, Nat), (pi', ih, ret.term)] ctx - sucType = substCaseSuccRet ret + sucCtx = extendTyN [< (pisg, p, Nat p.loc), (pi', ih, ret.term)] ctx + sucType = substCaseSuccRet suc.names ret sucout :< qp :< qih <- checkC sucCtx sg suc.term sucType - expectCompatQ qih (pi' * sg.fst) + expectCompatQ loc qih (pi' * sg.fst) -- [fixme] better error here - expectCompatQ (qp + qih) pisg + expectCompatQ loc (qp + qih) pisg -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σz + ωΣs pure $ InfRes { type = sub1 ret n, qout = pi * nres.qout + zerout + Any * sucout } - infer' ctx sg (CaseBox pi box ret body) = do + infer' ctx sg (CaseBox pi box ret body loc) = do -- if Ψ | Γ ⊢ σ · b ⇒ [ρ.A] ⊳ Σ₁ boxres <- inferC ctx sg box - (q, ty) <- expectBOX !defs ctx boxres.type + (q, ty) <- expectBOX !defs ctx box.loc boxres.type -- if Ψ | Γ, x : [ρ.A] ⊢₀ R ⇐ Type checkTypeC (extendTy Zero ret.name boxres.type ctx) ret.term Nothing -- if Ψ | Γ, x : A ⊢ t ⇐ R[[x] ∷ [ρ.A/x]] ⊳ Σ₂, ς·x -- with ς ≤ ρπσ let qpisg = q * pi * sg.fst bodyCtx = extendTy qpisg body.name ty ctx - bodyType = substCaseBoxRet ty ret - bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ qpisg + bodyType = substCaseBoxRet body.name ty ret + bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc qpisg -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ R[b/x] ⊳ Σ₁ + Σ₂ pure $ InfRes { type = sub1 ret box, qout = boxres.qout + bodyout } - infer' ctx sg (fun :% dim) = do + infer' ctx sg (DApp fun dim loc) = do -- if Ψ | Γ ⊢ σ · f ⇒ Eq [𝑖 ⇒ A] l r ⊳ Σ InfRes {type, qout} <- inferC ctx sg fun - ty <- fst <$> expectEq !defs ctx type + ty <- fst <$> expectEq !defs ctx fun.loc type -- then Ψ | Γ ⊢ σ · f p ⇒ A‹p/𝑖› ⊳ Σ pure $ InfRes {type = dsub1 ty dim, qout} - infer' ctx sg (Coe (S [< i] ty) p q val) = do - let ty = ty.term - checkType (extendDim i ctx) ty Nothing - qout <- checkC ctx sg val (ty // one p) - pure $ InfRes {type = ty // one q, qout} + infer' ctx sg (Coe ty p q val loc) = do + checkType (extendDim ty.name ctx) ty.term Nothing + qout <- checkC ctx sg val $ dsub1 ty p + pure $ InfRes {type = dsub1 ty q, qout} - infer' ctx sg (Comp ty p q val r (S [< j0] val0) (S [< j1] val1)) = do + infer' ctx sg (Comp ty p q val r (S [< j0] val0) (S [< j1] val1) loc) = do checkType ctx ty Nothing qout <- checkC ctx sg val ty let ty' = dweakT 1 ty; val' = dweakT 1 val; p' = weakD 1 p - ctx0 = extendDim j0 $ eqDim r (K Zero) ctx + ctx0 = extendDim j0 $ eqDim r (K Zero j0.loc) ctx val0 = val0.term qout0 <- check ctx0 sg val0 ty' - equal (eqDim (BV 0) p' ctx0) ty' val0 val' - let ctx1 = extendDim j0 $ eqDim r (K One) ctx + lift $ equal loc (eqDim (B VZ p.loc) p' ctx0) ty' val0 val' + let ctx1 = extendDim j1 $ eqDim r (K One j1.loc) ctx val1 = val1.term qout1 <- check ctx1 sg val1 ty' - equal (eqDim (BV 0) p' ctx1) ty' val1 val' + lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) ty' val1 val' let qout0' = toMaybe $ map (, val0 // one p) qout0 qout1' = toMaybe $ map (, val1 // one p) qout1 qouts = (qout, val) :: catMaybes [qout0', qout1'] let Just qout = lubs ctx $ map fst qouts - | Nothing => throw $ BadQtys "composition" ctx qouts + | Nothing => throw $ BadQtys loc "composition" ctx qouts pure $ InfRes {type = ty, qout} - infer' ctx sg (TypeCase ty ret arms def) = do + infer' ctx sg (TypeCase ty ret arms def loc) = do -- if σ = 0 - expectEqualQ Zero sg.fst + expectEqualQ loc Zero sg.fst -- if Ψ, Γ ⊢₀ e ⇒ Type u - u <- expectTYPE !defs ctx . type =<< inferC ctx szero ty + u <- expectTYPE !defs ctx ty.loc . type =<< inferC ctx szero ty -- if Ψ, Γ ⊢₀ C ⇐ Type (non-dependent return type) checkTypeC ctx ret Nothing -- if Ψ, Γ' ⊢₀ A ⇐ C for each rhs A for_ allKinds $ \k => for_ (lookupPrecise k arms) $ \(S names t) => - check0 (extendTyN (addNames0 (typecaseTel k u) names) ctx) + check0 (extendTyN (typecaseTel k names u) ctx) t.term (weakT (arity k) ret) -- then Ψ, Γ ⊢₀ type-case ⋯ ⇒ C pure $ InfRes {type = ret, qout = zeroFor ctx} - infer' ctx sg (term :# type) = do + infer' ctx sg (Ann term type loc) = do -- if Ψ | Γ ⊢₀ A ⇐ Type ℓ checkTypeC ctx type Nothing -- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index 6e27e9b..4314c3c 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -39,111 +39,122 @@ InferResult eqs d n = IfConsistent eqs $ InferResult' d n export -lookupFree : Has ErrorEff fs => Name -> Definitions -> Eff fs Definition -lookupFree x defs = maybe (throw $ NotInScope x) pure $ lookup x defs +lookupFree : Has ErrorEff fs => Name -> Loc -> Definitions -> Eff fs Definition +lookupFree x loc defs = maybe (throw $ NotInScope loc x) pure $ lookup x defs public export -substCasePairRet : Term d n -> ScopeTerm d n -> Term d (2 + n) -substCasePairRet dty retty = - let arg = Pair (BVT 1) (BVT 0) :# (dty // fromNat 2) in +substCasePairRet : BContext 2 -> Term d n -> ScopeTerm d n -> Term d (2 + n) +substCasePairRet [< x, y] dty retty = + let tm = Pair (BVT 1 x.loc) (BVT 0 y.loc) $ x.loc `extendL` y.loc + arg = Ann tm (dty // fromNat 2) tm.loc + in retty.term // (arg ::: shift 2) public export -substCaseSuccRet : ScopeTerm d n -> Term d (2 + n) -substCaseSuccRet retty = retty.term // (Succ (BVT 1) :# Nat ::: shift 2) +substCaseSuccRet : BContext 2 -> ScopeTerm d n -> Term d (2 + n) +substCaseSuccRet [< p, ih] retty = + let arg = Ann (Succ (BVT 1 p.loc) p.loc) (Nat noLoc) $ p.loc `extendL` ih.loc + in + retty.term // (arg ::: shift 2) public export -substCaseBoxRet : Term d n -> ScopeTerm d n -> Term d (S n) -substCaseBoxRet dty retty = - retty.term // (Box (BVT 0) :# weakT 1 dty ::: shift 1) +substCaseBoxRet : BindName -> Term d n -> ScopeTerm d n -> Term d (S n) +substCaseBoxRet x dty retty = + let arg = Ann (Box (BVT 0 x.loc) x.loc) (weakT 1 dty) x.loc in + retty.term // (arg ::: shift 1) -parameters (defs : Definitions) {auto _ : Has ErrorEff fs} +parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)} namespace TyContext - parameters (ctx : TyContext d n) + parameters (ctx : TyContext d n) (loc : Loc) export covering whnf : {0 isRedex : RedexTest tm} -> Whnf tm isRedex => tm d n -> Eff fs (NonRedex tm d n defs) - whnf = let Val n = ctx.termLen; Val d = ctx.dimLen in - rethrow . whnf defs (toWhnfContext ctx) + whnf tm = do + let Val n = ctx.termLen; Val d = ctx.dimLen + res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) tm + rethrow res private covering %macro - expect : (forall d, n. NameContexts d n -> Term d n -> Error) -> + expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) -> TTImp -> TTImp -> Elab (Term d n -> Eff fs a) expect k l r = do f <- check `(\case ~(l) => Just ~(r); _ => Nothing) - pure $ \t => maybe (throw $ k ctx.names t) pure . f . fst =<< whnf t + pure $ \t => maybe (throw $ k loc ctx.names t) pure . f . fst =<< whnf t export covering %inline expectTYPE : Term d n -> Eff fs Universe - expectTYPE = expect ExpectedTYPE `(TYPE l) `(l) + expectTYPE = expect ExpectedTYPE `(TYPE {l, _}) `(l) export covering %inline expectPi : Term d n -> Eff fs (Qty, Term d n, ScopeTerm d n) - expectPi = expect ExpectedPi `(Pi {qty, arg, res}) `((qty, arg, res)) + expectPi = expect ExpectedPi `(Pi {qty, arg, res, _}) `((qty, arg, res)) export covering %inline expectSig : Term d n -> Eff fs (Term d n, ScopeTerm d n) - expectSig = expect ExpectedSig `(Sig {fst, snd}) `((fst, snd)) + expectSig = expect ExpectedSig `(Sig {fst, snd, _}) `((fst, snd)) export covering %inline expectEnum : Term d n -> Eff fs (SortedSet TagVal) - expectEnum = expect ExpectedEnum `(Enum ts) `(ts) + expectEnum = expect ExpectedEnum `(Enum {cases, _}) `(cases) export covering %inline expectEq : Term d n -> Eff fs (DScopeTerm d n, Term d n, Term d n) - expectEq = expect ExpectedEq `(Eq {ty, l, r}) `((ty, l, r)) + expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r)) export covering %inline expectNat : Term d n -> Eff fs () - expectNat = expect ExpectedNat `(Nat) `(()) + expectNat = expect ExpectedNat `(Nat {}) `(()) export covering %inline expectBOX : Term d n -> Eff fs (Qty, Term d n) - expectBOX = expect ExpectedBOX `(BOX {qty, ty}) `((qty, ty)) + expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty)) namespace EqContext - parameters (ctx : EqContext n) + parameters (ctx : EqContext n) (loc : Loc) export covering whnf : {0 isRedex : RedexTest tm} -> Whnf tm isRedex => tm 0 n -> Eff fs (NonRedex tm 0 n defs) - whnf = let Val n = ctx.termLen in rethrow . whnf defs (toWhnfContext ctx) + whnf tm = do + let Val n = ctx.termLen + res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) tm + rethrow res private covering %macro - expect : (forall d, n. NameContexts d n -> Term d n -> Error) -> + expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) -> TTImp -> TTImp -> Elab (Term 0 n -> Eff fs a) expect k l r = do f <- check `(\case ~(l) => Just ~(r); _ => Nothing) pure $ \t => - let err = throw $ k ctx.names (t // shift0 ctx.dimLen) in + let err = throw $ k loc ctx.names (t // shift0 ctx.dimLen) in maybe err pure . f . fst =<< whnf t export covering %inline expectTYPE : Term 0 n -> Eff fs Universe - expectTYPE = expect ExpectedTYPE `(TYPE l) `(l) + expectTYPE = expect ExpectedTYPE `(TYPE {l, _}) `(l) export covering %inline expectPi : Term 0 n -> Eff fs (Qty, Term 0 n, ScopeTerm 0 n) - expectPi = expect ExpectedPi `(Pi {qty, arg, res}) `((qty, arg, res)) + expectPi = expect ExpectedPi `(Pi {qty, arg, res, _}) `((qty, arg, res)) export covering %inline expectSig : Term 0 n -> Eff fs (Term 0 n, ScopeTerm 0 n) - expectSig = expect ExpectedSig `(Sig {fst, snd}) `((fst, snd)) + expectSig = expect ExpectedSig `(Sig {fst, snd, _}) `((fst, snd)) export covering %inline expectEnum : Term 0 n -> Eff fs (SortedSet TagVal) - expectEnum = expect ExpectedEnum `(Enum ts) `(ts) + expectEnum = expect ExpectedEnum `(Enum {cases, _}) `(cases) export covering %inline expectEq : Term 0 n -> Eff fs (DScopeTerm 0 n, Term 0 n, Term 0 n) - expectEq = expect ExpectedEq `(Eq {ty, l, r}) `((ty, l, r)) + expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r)) export covering %inline expectNat : Term 0 n -> Eff fs () - expectNat = expect ExpectedNat `(Nat) `(()) + expectNat = expect ExpectedNat `(Nat {}) `(()) export covering %inline expectBOX : Term 0 n -> Eff fs (Qty, Term 0 n) - expectBOX = expect ExpectedBOX `(BOX {qty, ty}) `((qty, ty)) + expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty)) diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index 2ad6f34..1d5c7cd 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -31,9 +31,9 @@ record TyContext d n where {auto dimLen : Singleton d} {auto termLen : Singleton n} dctx : DimEq d - dnames : NContext d + dnames : BContext d tctx : TContext d n - tnames : NContext n + tnames : BContext n qtys : QContext n -- only used for printing %name TyContext ctx @@ -44,9 +44,9 @@ record EqContext n where {dimLen : Nat} {auto termLen : Singleton n} dassign : DimAssign dimLen -- only used for printing - dnames : NContext dimLen -- only used for printing + dnames : BContext dimLen -- only used for printing tctx : TContext 0 n - tnames : NContext n + tnames : BContext n qtys : QContext n -- only used for printing %name EqContext ctx @@ -54,8 +54,8 @@ record EqContext n where public export record WhnfContext d n where constructor MkWhnfContext - dnames : NContext d - tnames : NContext n + dnames : BContext d + tnames : BContext n tctx : TContext d n %name WhnfContext ctx @@ -76,7 +76,7 @@ extendLen (tel :< _) x = [|S $ extendLen tel x|] public export CtxExtension : Nat -> Nat -> Nat -> Type -CtxExtension d = Telescope ((Qty, BaseName,) . Term d) +CtxExtension d = Telescope ((Qty, BindName,) . Term d) namespace TyContext public export %inline @@ -101,11 +101,11 @@ namespace TyContext } export %inline - extendTy : Qty -> BaseName -> Term d n -> TyContext d n -> TyContext d (S n) + extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n) extendTy q x s = extendTyN [< (q, x, s)] export %inline - extendDim : BaseName -> TyContext d n -> TyContext (S d) n + extendDim : BindName -> TyContext d n -> TyContext (S d) n extendDim x (MkTyContext {dimLen, dctx, dnames, tctx, tnames, qtys}) = MkTyContext { dctx = dctx : DimAssign d -makeDAssign (Shift SZ) = [<] -makeDAssign (K e ::: th) = makeDAssign th :< e +makeDAssign (Shift SZ) = [<] +makeDAssign (K e _ ::: th) = makeDAssign th :< e export makeEqContext' : {d : Nat} -> TyContext d n -> DSubst d 0 -> EqContext n @@ -172,8 +172,7 @@ namespace EqContext null ctx = null ctx.dnames && null ctx.tnames export %inline - extendTyN : Telescope (\n => (Qty, BaseName, Term 0 n)) from to -> - EqContext from -> EqContext to + extendTyN : CtxExtension 0 from to -> EqContext from -> EqContext to extendTyN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) = let (qs, xs, ss) = unzip3 xss in MkEqContext { @@ -185,11 +184,11 @@ namespace EqContext } export %inline - extendTy : Qty -> BaseName -> Term 0 n -> EqContext n -> EqContext (S n) + extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n) extendTy q x s = extendTyN [< (q, x, s)] export %inline - extendDim : BaseName -> DimConst -> EqContext n -> EqContext n + extendDim : BindName -> DimConst -> EqContext n -> EqContext n extendDim x e (MkEqContext {dassign, dnames, tctx, tnames, qtys}) = MkEqContext {dassign = dassign :< e, dnames = dnames :< x, tctx, tnames, qtys} @@ -214,7 +213,7 @@ namespace WhnfContext empty = MkWhnfContext [<] [<] [<] export - extendDimN : {s : Nat} -> NContext s -> WhnfContext d n -> + extendDimN : {s : Nat} -> BContext s -> WhnfContext d n -> WhnfContext (s + d) n extendDimN ns (MkWhnfContext {dnames, tnames, tctx}) = MkWhnfContext { @@ -224,16 +223,16 @@ namespace WhnfContext } export - extendDim : BaseName -> WhnfContext d n -> WhnfContext (S d) n + extendDim : BindName -> WhnfContext d n -> WhnfContext (S d) n extendDim i = extendDimN [< i] private -data CtxBinder a = MkCtxBinder BaseName a +data CtxBinder a = MkCtxBinder BindName a PrettyHL a => PrettyHL (CtxBinder a) where prettyM (MkCtxBinder x t) = pure $ - sep [hsep [!(pretty0M $ TV x), colonD], !(pretty0M t)] + sep [hsep [!(pretty0M $ TV x.name), colonD], !(pretty0M t)] parameters (unicode : Bool) private @@ -241,16 +240,16 @@ parameters (unicode : Bool) pipeD = hl Syntax "|" export covering - prettyTContext : NContext d -> - QContext n -> NContext n -> + prettyTContext : BContext d -> + QContext n -> BContext n -> TContext d n -> Doc HL prettyTContext ds qs xs ctx = separate comma $ toList $ go qs xs ctx where - go : QContext m -> NContext m -> TContext d m -> SnocList (Doc HL) + go : QContext m -> BContext m -> TContext d m -> SnocList (Doc HL) go [<] [<] [<] = [<] go (qs :< q) (xs :< x) (ctx :< t) = let bind = MkWithQty q $ MkCtxBinder x t in go qs xs ctx :< - runPrettyWith unicode (toSnocList' ds) (toSnocList' xs) (pretty0M bind) + runPrettyWith unicode (toNames ds) (toNames xs) (pretty0M bind) export covering prettyTyContext : TyContext d n -> Doc HL diff --git a/lib/Quox/Typing/Error.idr b/lib/Quox/Typing/Error.idr index b8d962b..b786ce6 100644 --- a/lib/Quox/Typing/Error.idr +++ b/lib/Quox/Typing/Error.idr @@ -1,5 +1,6 @@ module Quox.Typing.Error +import Quox.Loc import Quox.Syntax import Quox.Typing.Context import Quox.Typing.EqMode @@ -12,8 +13,8 @@ import Control.Eff public export record NameContexts d n where constructor MkNameContexts - dnames : NContext d - tnames : NContext n + dnames : BContext d + tnames : BContext n namespace NameContexts export @@ -21,11 +22,11 @@ namespace NameContexts empty = MkNameContexts [<] [<] export - extendDimN : NContext s -> NameContexts d n -> NameContexts (s + d) n + extendDimN : BContext s -> NameContexts d n -> NameContexts (s + d) n extendDimN xs = {dnames $= (++ toSnocVect' xs)} export - extendDim : BaseName -> NameContexts d n -> NameContexts (S d) n + extendDim : BindName -> NameContexts d n -> NameContexts (S d) n extendDim i = extendDimN [< i] namespace TyContext @@ -54,30 +55,30 @@ namespace WhnfContext public export data Error -= ExpectedTYPE (NameContexts d n) (Term d n) -| ExpectedPi (NameContexts d n) (Term d n) -| ExpectedSig (NameContexts d n) (Term d n) -| ExpectedEnum (NameContexts d n) (Term d n) -| ExpectedEq (NameContexts d n) (Term d n) -| ExpectedNat (NameContexts d n) (Term d n) -| ExpectedBOX (NameContexts d n) (Term d n) -| BadUniverse Universe Universe -| TagNotIn TagVal (SortedSet TagVal) -| BadCaseEnum (SortedSet TagVal) (SortedSet TagVal) -| BadQtys String (TyContext d n) (List (QOutput n, Term d n)) += ExpectedTYPE Loc (NameContexts d n) (Term d n) +| ExpectedPi Loc (NameContexts d n) (Term d n) +| ExpectedSig Loc (NameContexts d n) (Term d n) +| ExpectedEnum Loc (NameContexts d n) (Term d n) +| ExpectedEq Loc (NameContexts d n) (Term d n) +| ExpectedNat Loc (NameContexts d n) (Term d n) +| ExpectedBOX Loc (NameContexts d n) (Term d n) +| BadUniverse Loc Universe Universe +| TagNotIn Loc TagVal (SortedSet TagVal) +| BadCaseEnum Loc (SortedSet TagVal) (SortedSet TagVal) +| BadQtys Loc String (TyContext d n) (List (QOutput n, Term d n)) -- first term arg of ClashT is the type -| ClashT (EqContext n) EqMode (Term 0 n) (Term 0 n) (Term 0 n) -| ClashTy (EqContext n) EqMode (Term 0 n) (Term 0 n) -| ClashE (EqContext n) EqMode (Elim 0 n) (Elim 0 n) -| ClashU EqMode Universe Universe -| ClashQ Qty Qty -| NotInScope Name +| ClashT Loc (EqContext n) EqMode (Term 0 n) (Term 0 n) (Term 0 n) +| ClashTy Loc (EqContext n) EqMode (Term 0 n) (Term 0 n) +| ClashE Loc (EqContext n) EqMode (Elim 0 n) (Elim 0 n) +| ClashU Loc EqMode Universe Universe +| ClashQ Loc Qty Qty +| NotInScope Loc Name -| NotType (TyContext d n) (Term d n) -| WrongType (EqContext n) (Term 0 n) (Term 0 n) +| NotType Loc (TyContext d n) (Term d n) +| WrongType Loc (EqContext n) (Term 0 n) (Term 0 n) -| MissingEnumArm TagVal (List TagVal) +| MissingEnumArm Loc TagVal (List TagVal) -- extra context | WhileChecking @@ -166,18 +167,18 @@ expect : Has (Except e) fs => (a -> a -> e) -> (a -> a -> Bool) -> a -> a -> Eff fs () expect err cmp x y = unless (x `cmp` y) $ throw $ err x y -parameters {auto _ : Has ErrorEff fs} +parameters {auto _ : Has ErrorEff fs} (loc : Loc) export %inline expectEqualQ : Qty -> Qty -> Eff fs () - expectEqualQ = expect ClashQ (==) + expectEqualQ = expect (ClashQ loc) (==) export %inline expectCompatQ : Qty -> Qty -> Eff fs () - expectCompatQ = expect ClashQ compat + expectCompatQ = expect (ClashQ loc) compat export %inline expectModeU : EqMode -> Universe -> Universe -> Eff fs () - expectModeU mode = expect (ClashU mode) $ ucmp mode + expectModeU mode = expect (ClashU loc mode) $ ucmp mode private @@ -207,8 +208,8 @@ parameters (unicode : Bool) dstermn ctx (S i t) = termn (extendDimN i ctx) t.term private - filterSameQtys : NContext n -> List (QOutput n, z) -> - Exists $ \n' => (NContext n', List (QOutput n', z)) + filterSameQtys : BContext n -> List (QOutput n, z) -> + Exists $ \n' => (BContext n', List (QOutput n', z)) filterSameQtys [<] qts = Evidence 0 ([<], qts) filterSameQtys (ns :< n) qts = let (qs, qts) = unzip $ map (\(qs :< q, t) => (q, qs, t)) qts @@ -224,7 +225,7 @@ parameters (unicode : Bool) private printCaseQtys : TyContext d n -> - NContext n' -> List (QOutput n', Term d n) -> + BContext n' -> List (QOutput n', Term d n) -> List (Doc HL) printCaseQtys ctx ns qts = let Evidence l (ns, qts) = filterSameQtys ns qts in @@ -233,94 +234,97 @@ parameters (unicode : Bool) commaList : PrettyHL a => Context' a l -> Doc HL commaList = hseparate comma . map (pretty0 unicode) . toList' - line : NContext l -> (QOutput l, Term d n) -> Doc HL + line : BContext l -> (QOutput l, Term d n) -> Doc HL line ns (qs, t) = "-" <++> asep ["the term", termn ctx.names t, - "uses variables", commaList $ TV <$> ns, + "uses variables", commaList $ (TV . name) <$> ns, "with quantities", commaList qs] -- [todo] only show some contexts, probably export prettyError : (showContext : Bool) -> Error -> Doc HL prettyError showContext = \case - ExpectedTYPE ctx s => - sep ["expected a type universe, but got", termn ctx s] + ExpectedTYPE loc ctx s => + sep [prettyLoc loc <++> "expected a type universe, but got", termn ctx s] - ExpectedPi ctx s => - sep ["expected a function type, but got", termn ctx s] + ExpectedPi loc ctx s => + sep [prettyLoc loc <++> "expected a function type, but got", termn ctx s] - ExpectedSig ctx s => - sep ["expected a pair type, but got", termn ctx s] + ExpectedSig loc ctx s => + sep [prettyLoc loc <++> "expected a pair type, but got", termn ctx s] - ExpectedEnum ctx s => - sep ["expected an enumeration type, but got", termn ctx s] + ExpectedEnum loc ctx s => + sep [prettyLoc loc <++> "expected an enumeration type, but got", + termn ctx s] - ExpectedEq ctx s => - sep ["expected an equality type, but got", termn ctx s] + ExpectedEq loc ctx s => + sep [prettyLoc loc <++> "expected an equality type, but got", termn ctx s] - ExpectedNat ctx s {d, n} => - sep ["expected the type", pretty0 unicode $ Nat {d, n}, - "but got", termn ctx s] + ExpectedNat loc ctx s {d, n} => + sep [prettyLoc loc <++> "expected the type", + pretty0 unicode $ Nat noLoc {d, n}, "but got", termn ctx s] - ExpectedBOX ctx s => - sep ["expected a box type, but got", termn ctx s] + ExpectedBOX loc ctx s => + sep [prettyLoc loc <++> "expected a box type, but got", termn ctx s] - BadUniverse k l => - sep ["the universe level", prettyUniverse k, + BadUniverse loc k l => + sep [prettyLoc loc <++> "the universe level", prettyUniverse k, "is not strictly less than", prettyUniverse l] - TagNotIn tag set => - sep [sep ["tag", prettyTag tag, "is not contained in"], - termn empty (Enum set)] + TagNotIn loc tag set => + sep [hsep [prettyLoc loc, "tag", prettyTag tag, "is not contained in"], + termn empty (Enum set noLoc)] - BadCaseEnum type arms => - sep ["case expression has head of type", termn empty (Enum type), - "but cases for", termn empty (Enum arms)] + BadCaseEnum loc type arms => + sep [prettyLoc loc <++> "case expression has head of type", + termn empty (Enum type noLoc), + "but cases for", termn empty (Enum arms noLoc)] - BadQtys what ctx arms => + BadQtys loc what ctx arms => hang 4 $ sep $ - ("inconsistent variable usage in" <++> fromString what) :: - printCaseQtys ctx ctx.tnames arms + hsep [prettyLoc loc, "inconsistent variable usage in", fromString what] + :: printCaseQtys ctx ctx.tnames arms - ClashT ctx mode ty s t => + ClashT loc ctx mode ty s t => inEContext ctx $ - sep ["the term", termn ctx.names0 s, + sep [prettyLoc loc <++> "the term", termn ctx.names0 s, hsep ["is not", prettyMode mode], termn ctx.names0 t, "at type", termn ctx.names0 ty] - ClashTy ctx mode a b => + ClashTy loc ctx mode a b => inEContext ctx $ - sep ["the type", termn ctx.names0 a, + sep [prettyLoc loc <++> "the type", termn ctx.names0 a, hsep ["is not", prettyMode mode], termn ctx.names0 b] - ClashE ctx mode e f => + ClashE loc ctx mode e f => inEContext ctx $ - sep ["the term", termn ctx.names0 $ E e, + sep [prettyLoc loc <++> "the term", termn ctx.names0 $ E e, hsep ["is not", prettyMode mode], termn ctx.names0 $ E f] - ClashU mode k l => - sep ["the universe level", prettyUniverse k, + ClashU loc mode k l => + sep [prettyLoc loc <++> "the universe level", prettyUniverse k, hsep ["is not", prettyMode mode], prettyUniverse l] - ClashQ pi rh => - sep ["the quantity", pretty0 unicode pi, + ClashQ loc pi rh => + sep [prettyLoc loc <++> "the quantity", pretty0 unicode pi, "is not equal to", pretty0 unicode rh] - NotInScope x => - hsep [hl' Free $ pretty0 unicode x, "is not in scope"] + NotInScope loc x => + hsep [prettyLoc loc, hl' Free $ pretty0 unicode x, "is not in scope"] - NotType ctx s => + NotType loc ctx s => inTContext ctx $ - sep ["the term", termn ctx.names s, "is not a type"] + sep [prettyLoc loc <++> "the term", termn ctx.names s, "is not a type"] - WrongType ctx ty s => + WrongType loc ctx ty s => inEContext ctx $ - sep ["the term", termn ctx.names0 s, + sep [prettyLoc loc <++> "the term", termn ctx.names0 s, "cannot have type", termn ctx.names0 ty] - MissingEnumArm tag tags => - sep [hsep ["the tag", hl Tag $ pretty tag, "is not contained in"], - termn empty $ Enum $ fromList tags] + MissingEnumArm loc tag tags => + sep [hsep [prettyLoc loc, "the tag", hl Tag $ pretty tag, + "is not contained in"], + termn empty $ Enum (fromList tags) noLoc] WhileChecking ctx pi s a err => vsep [inTContext ctx $ diff --git a/tests/AstExtra.idr b/tests/AstExtra.idr new file mode 100644 index 0000000..2528d9a --- /dev/null +++ b/tests/AstExtra.idr @@ -0,0 +1,33 @@ +module AstExtra + +import Quox.Syntax +import Quox.Parser.Syntax +import Quox.Typing.Context + +prefix 9 ^ +public export +(^) : (Loc -> a) -> a +(^) a = a noLoc + +public export +FromString BindName where fromString str = BN (fromString str) noLoc + +public export +FromString PatVar where fromString x = PV x noLoc + +public export +empty01 : TyContext 0 0 +empty01 = eqDim (^K Zero) (^K One) empty + + +anys : {n : Nat} -> QContext n +anys {n = 0} = [<] +anys {n = S n} = anys :< Any + +public export +ctx, ctx01 : {n : Nat} -> Context (\n => (BindName, Term 0 n)) n -> + TyContext 0 n +ctx tel = let (ns, ts) = unzip tel in + MkTyContext new [<] ts ns anys +ctx01 tel = let (ns, ts) = unzip tel in + MkTyContext ZeroIsOne [<] ts ns anys diff --git a/tests/Tests/DimEq.idr b/tests/Tests/DimEq.idr index ecebc5e..e0bf1fe 100644 --- a/tests/Tests/DimEq.idr +++ b/tests/Tests/DimEq.idr @@ -2,6 +2,7 @@ module Tests.DimEq import Quox.Syntax.DimEq import PrettyExtra +import AstExtra import TAP import Data.Maybe @@ -95,9 +96,9 @@ tests = "dimension constraints" :- [ testPrettyD ii new "𝑖", testPrettyD iijj (fromGround [< Zero, One]) "𝑖, 𝑗, 𝑖 = 0, 𝑗 = 1", - testPrettyD iijj (C [< Just (K Zero), Nothing]) + testPrettyD iijj (C [< Just (^K Zero), Nothing]) "𝑖, 𝑗, 𝑖 = 0", - testPrettyD iijjkk (C [< Nothing, Just (BV 0), Just (BV 1)]) + testPrettyD iijjkk (C [< Nothing, Just (^BV 0), Just (^BV 1)]) "𝑖, 𝑗, 𝑘, 𝑗 = 𝑖, 𝑘 = 𝑖" ], @@ -108,56 +109,56 @@ tests = "dimension constraints" :- [ testNeq [<] new ZeroIsOne, testNeq iijj new ZeroIsOne, testSet iijj - (C [< Nothing, Just (BV 0)]) - new [(BV 1, BV 0)], + (C [< Nothing, Just (^BV 0)]) + new [(^BV 1, ^BV 0)], testSet iijj - (C [< Nothing, Just (BV 0)]) - new [(BV 0, BV 1)], + (C [< Nothing, Just (^BV 0)]) + new [(^BV 0, ^BV 1)], testNeq iijj new - (C [< Nothing, Just (BV 0)]), + (C [< Nothing, Just (^BV 0)]), testSet [<] ZeroIsOne - new [(K Zero, K One)], + new [(^K Zero, ^K One)], testSet iijjkk - (C [< Nothing, Just (BV 0), Just (BV 1)]) - new [(BV 0, BV 1), (BV 1, BV 2)], + (C [< Nothing, Just (^BV 0), Just (^BV 1)]) + new [(^BV 0, ^BV 1), (^BV 1, ^BV 2)], testSet iijjkk - (C [< Nothing, Just (BV 0), Just (BV 1)]) - new [(BV 0, BV 1), (BV 0, BV 2)], + (C [< Nothing, Just (^BV 0), Just (^BV 1)]) + new [(^BV 0, ^BV 1), (^BV 0, ^BV 2)], testSet iijjkk - (C [< Nothing, Nothing, Just (BV 0)]) - new [(BV 0, BV 1), (BV 0, BV 1)], + (C [< Nothing, Nothing, Just (^BV 0)]) + new [(^BV 0, ^BV 1), (^BV 0, ^BV 1)], testSet iijj - (C [< Just (K Zero), Just (K Zero)]) - new [(BV 1, K Zero), (BV 0, BV 1)], + (C [< Just (^K Zero), Just (^K Zero)]) + new [(^BV 1, ^K Zero), (^BV 0, ^BV 1)], testSet iijjkk - (C [< Just (K Zero), Just (K Zero), Just (K Zero)]) - new [(BV 2, K Zero), (BV 1, BV 2), (BV 0, BV 1)], + (C [< Just (^K Zero), Just (^K Zero), Just (^K Zero)]) + new [(^BV 2, ^K Zero), (^BV 1, ^BV 2), (^BV 0, ^BV 1)], testSet iijjkk - (C [< Just (K Zero), Just (K Zero), Just (K Zero)]) - new [(BV 2, K Zero), (BV 0, BV 1), (BV 1, BV 2)], + (C [< Just (^K Zero), Just (^K Zero), Just (^K Zero)]) + new [(^BV 2, ^K Zero), (^BV 0, ^BV 1), (^BV 1, ^BV 2)], testSet iijjkk - (C [< Just (K Zero), Just (K Zero), Just (K Zero)]) - new [(BV 0, BV 2), (BV 1, K Zero), (BV 2, BV 1)], + (C [< Just (^K Zero), Just (^K Zero), Just (^K Zero)]) + new [(^BV 0, ^BV 2), (^BV 1, ^K Zero), (^BV 2, ^BV 1)], testSet iijjkk - (C [< Nothing, Just (BV 0), Just (BV 1)]) - new [(BV 0, BV 2), (BV 2, BV 1)], + (C [< Nothing, Just (^BV 0), Just (^BV 1)]) + new [(^BV 0, ^BV 2), (^BV 2, ^BV 1)], testSet iijjkkll - (C [< Nothing, Just (BV 0), Just (BV 1), Just (BV 2)]) - new [(BV 2, BV 1), (BV 3, BV 0), (BV 2, BV 3)], + (C [< Nothing, Just (^BV 0), Just (^BV 1), Just (^BV 2)]) + new [(^BV 2, ^BV 1), (^BV 3, ^BV 0), (^BV 2, ^BV 3)], testSet iijjkk - (C [< Just (K One), Just (K One), Just (K One)]) - (C [< Just (K One), Nothing, Just (BV 0)]) - [(BV 1, BV 2)], + (C [< Just (^K One), Just (^K One), Just (^K One)]) + (C [< Just (^K One), Nothing, Just (^BV 0)]) + [(^BV 1, ^BV 2)], testSet iijj ZeroIsOne - (C [< Just (K One), Just (K Zero)]) - [(BV 1, BV 0)], + (C [< Just (^K One), Just (^K Zero)]) + [(^BV 1, ^BV 0)], testSet iijj ZeroIsOne - (C [< Nothing, Just (BV 0)]) - [(BV 1, K Zero), (BV 0, K One)] + (C [< Nothing, Just (^BV 0)]) + [(^BV 1, ^K Zero), (^BV 0, ^K One)] ], "wf" :- [ @@ -165,9 +166,9 @@ tests = "dimension constraints" :- [ testWf ii ZeroIsOne, testWf [<] new, testWf iijjkk new, - testWf iijjkk (C [< Nothing, Just (BV 0), Just (BV 1)]), - testNwf iijjkk (C [< Nothing, Just (BV 0), Just (BV 0)]), - testWf iijj (C [< Just (K Zero), Just (K Zero)]), - testNwf iijj (C [< Just (K Zero), Just (BV 0)]) + testWf iijjkk (C [< Nothing, Just (^BV 0), Just (^BV 1)]), + testNwf iijjkk (C [< Nothing, Just (^BV 0), Just (^BV 0)]), + testWf iijj (C [< Just (^K Zero), Just (^K Zero)]), + testNwf iijj (C [< Just (^K Zero), Just (^BV 0)]) ] ] diff --git a/tests/Tests/Equal.idr b/tests/Tests/Equal.idr index 223ba1c..ccd690e 100644 --- a/tests/Tests/Equal.idr +++ b/tests/Tests/Equal.idr @@ -5,52 +5,40 @@ import Quox.Typechecker import public TypingImpls import TAP import Quox.EffExtra +import AstExtra + defGlobals : Definitions defGlobals = fromList - [("A", mkPostulate gzero $ TYPE 0), - ("B", mkPostulate gzero $ TYPE 0), - ("a", mkPostulate gany $ FT "A"), - ("a'", mkPostulate gany $ FT "A"), - ("b", mkPostulate gany $ FT "B"), - ("f", mkPostulate gany $ Arr One (FT "A") (FT "A")), - ("id", mkDef gany (Arr One (FT "A") (FT "A")) ([< "x"] :\\ BVT 0)), - ("eq-AB", mkPostulate gzero $ Eq0 (TYPE 0) (FT "A") (FT "B")), - ("two", mkDef gany Nat (Succ (Succ Zero)))] + [("A", ^mkPostulate gzero (^TYPE 0)), + ("B", ^mkPostulate gzero (^TYPE 0)), + ("a", ^mkPostulate gany (^FT "A")), + ("a'", ^mkPostulate gany (^FT "A")), + ("b", ^mkPostulate gany (^FT "B")), + ("f", ^mkPostulate gany (^Arr One (^FT "A") (^FT "A"))), + ("id", ^mkDef gany (^Arr One (^FT "A") (^FT "A")) (^LamY "x" (^BVT 0))), + ("eq-AB", ^mkPostulate gzero (^Eq0 (^TYPE 0) (^FT "A") (^FT "B"))), + ("two", ^mkDef gany (^Nat) (^Succ (^Succ (^Zero))))] -parameters (label : String) (act : Lazy (TC ())) +parameters (label : String) (act : Equal ()) {default defGlobals globals : Definitions} testEq : Test - testEq = test label $ runTC globals act + testEq = test label $ runEqual globals act testNeq : Test testNeq = testThrows label (const True) $ runTC globals act $> "()" -parameters (0 d : Nat) (ctx : TyContext d n) - subTD, equalTD : Term d n -> Term d n -> Term d n -> TC () - subTD ty s t = Term.sub ctx ty s t - equalTD ty s t = Term.equal ctx ty s t - equalTyD : Term d n -> Term d n -> TC () - equalTyD s t = Term.equalType ctx s t +parameters (ctx : TyContext d n) + subT, equalT : Term d n -> Term d n -> Term d n -> TC () + subT ty s t = lift $ Term.sub noLoc ctx ty s t + equalT ty s t = lift $ Term.equal noLoc ctx ty s t + equalTy : Term d n -> Term d n -> TC () + equalTy s t = lift $ Term.equalType noLoc ctx s t - subED, equalED : Elim d n -> Elim d n -> TC () - subED e f = Elim.sub ctx e f - equalED e f = Elim.equal ctx e f - -parameters (ctx : TyContext 0 n) - subT, equalT : Term 0 n -> Term 0 n -> Term 0 n -> TC () - subT = subTD 0 ctx - equalT = equalTD 0 ctx - equalTy : Term 0 n -> Term 0 n -> TC () - equalTy = equalTyD 0 ctx - - subE, equalE : Elim 0 n -> Elim 0 n -> TC () - subE = subED 0 ctx - equalE = equalED 0 ctx - -empty01 : TyContext 0 0 -empty01 = eqDim (K Zero) (K One) empty + subE, equalE : Elim d n -> Elim d n -> TC () + subE e f = lift $ Elim.sub noLoc ctx e f + equalE e f = lift $ Elim.equal noLoc ctx e f export @@ -61,410 +49,434 @@ tests = "equality & subtyping" :- [ "universes" :- [ testEq "★₀ = ★₀" $ - equalT empty (TYPE 1) (TYPE 0) (TYPE 0), + equalT empty (^TYPE 1) (^TYPE 0) (^TYPE 0), testNeq "★₀ ≠ ★₁" $ - equalT empty (TYPE 2) (TYPE 0) (TYPE 1), + equalT empty (^TYPE 2) (^TYPE 0) (^TYPE 1), testNeq "★₁ ≠ ★₀" $ - equalT empty (TYPE 2) (TYPE 1) (TYPE 0), + equalT empty (^TYPE 2) (^TYPE 1) (^TYPE 0), testEq "★₀ <: ★₀" $ - subT empty (TYPE 1) (TYPE 0) (TYPE 0), + subT empty (^TYPE 1) (^TYPE 0) (^TYPE 0), testEq "★₀ <: ★₁" $ - subT empty (TYPE 2) (TYPE 0) (TYPE 1), + subT empty (^TYPE 2) (^TYPE 0) (^TYPE 1), testNeq "★₁ ≮: ★₀" $ - subT empty (TYPE 2) (TYPE 1) (TYPE 0) + subT empty (^TYPE 2) (^TYPE 1) (^TYPE 0) ], "function types" :- [ - note #""𝐴 ⊸ 𝐵" for (1·𝐴) → 𝐵"#, - note #""𝐴 ⇾ 𝐵" for (0·𝐴) → 𝐵"#, - testEq "★₀ ⇾ ★₀ = ★₀ ⇾ ★₀" $ - let tm = Arr Zero (TYPE 0) (TYPE 0) in - equalT empty (TYPE 1) tm tm, - testEq "★₀ ⇾ ★₀ <: ★₀ ⇾ ★₀" $ - let tm = Arr Zero (TYPE 0) (TYPE 0) in - subT empty (TYPE 1) tm tm, - testNeq "★₁ ⊸ ★₀ ≠ ★₀ ⇾ ★₀" $ - let tm1 = Arr Zero (TYPE 1) (TYPE 0) - tm2 = Arr Zero (TYPE 0) (TYPE 0) in - equalT empty (TYPE 2) tm1 tm2, - testEq "★₁ ⊸ ★₀ <: ★₀ ⊸ ★₀" $ - let tm1 = Arr One (TYPE 1) (TYPE 0) - tm2 = Arr One (TYPE 0) (TYPE 0) in - subT empty (TYPE 2) tm1 tm2, - testEq "★₀ ⊸ ★₀ <: ★₀ ⊸ ★₁" $ - let tm1 = Arr One (TYPE 0) (TYPE 0) - tm2 = Arr One (TYPE 0) (TYPE 1) in - subT empty (TYPE 2) tm1 tm2, - testEq "★₀ ⊸ ★₀ <: ★₀ ⊸ ★₁" $ - let tm1 = Arr One (TYPE 0) (TYPE 0) - tm2 = Arr One (TYPE 0) (TYPE 1) in - subT empty (TYPE 2) tm1 tm2, - testEq "A ⊸ B = A ⊸ B" $ - let tm = Arr One (FT "A") (FT "B") in - equalT empty (TYPE 0) tm tm, - testEq "A ⊸ B <: A ⊸ B" $ - let tm = Arr One (FT "A") (FT "B") in - subT empty (TYPE 0) tm tm, + note "cumulativity", + testEq "0.★₀ → ★₀ = 0.★₀ → ★₀" $ + let tm = ^Arr Zero (^TYPE 0) (^TYPE 0) in + equalT empty (^TYPE 1) tm tm, + testEq "0.★₀ → ★₀ <: 0.★₀ → ★₀" $ + let tm = ^Arr Zero (^TYPE 0) (^TYPE 0) in + subT empty (^TYPE 1) tm tm, + testNeq "0.★₁ → ★₀ ≠ 0.★₀ → ★₀" $ + let tm1 = ^Arr Zero (^TYPE 1) (^TYPE 0) + tm2 = ^Arr Zero (^TYPE 0) (^TYPE 0) in + equalT empty (^TYPE 2) tm1 tm2, + testEq "1.★₁ → ★₀ <: 1.★₀ → ★₀" $ + let tm1 = ^Arr One (^TYPE 1) (^TYPE 0) + tm2 = ^Arr One (^TYPE 0) (^TYPE 0) in + subT empty (^TYPE 2) tm1 tm2, + testEq "1.★₀ → ★₀ <: 1.★₀ → ★₁" $ + let tm1 = ^Arr One (^TYPE 0) (^TYPE 0) + tm2 = ^Arr One (^TYPE 0) (^TYPE 1) in + subT empty (^TYPE 2) tm1 tm2, + testEq "1.★₀ → ★₀ <: 1.★₀ → ★₁" $ + let tm1 = ^Arr One (^TYPE 0) (^TYPE 0) + tm2 = ^Arr One (^TYPE 0) (^TYPE 1) in + subT empty (^TYPE 2) tm1 tm2, + testEq "1.A → B = 1.A → B" $ + let tm = ^Arr One (^FT "A") (^FT "B") in + equalT empty (^TYPE 0) tm tm, + testEq "1.A → B <: 1.A → B" $ + let tm = ^Arr One (^FT "A") (^FT "B") in + subT empty (^TYPE 0) tm tm, note "incompatible quantities", - testNeq "★₀ ⊸ ★₀ ≠ ★₀ ⇾ ★₁" $ - let tm1 = Arr Zero (TYPE 0) (TYPE 0) - tm2 = Arr Zero (TYPE 0) (TYPE 1) in - equalT empty (TYPE 2) tm1 tm2, - testNeq "A ⇾ B ≠ A ⊸ B" $ - let tm1 = Arr Zero (FT "A") (FT "B") - tm2 = Arr One (FT "A") (FT "B") in - equalT empty (TYPE 0) tm1 tm2, - testNeq "A ⇾ B ≮: A ⊸ B" $ - let tm1 = Arr Zero (FT "A") (FT "B") - tm2 = Arr One (FT "A") (FT "B") in - subT empty (TYPE 0) tm1 tm2, - testEq "0=1 ⊢ A ⇾ B = A ⊸ B" $ - let tm1 = Arr Zero (FT "A") (FT "B") - tm2 = Arr One (FT "A") (FT "B") in - equalT empty01 (TYPE 0) tm1 tm2, - todo "dependent function types", - note "[todo] should π ≤ ρ ⊢ (ρ·A) → B <: (π·A) → B?" + testNeq "1.★₀ → ★₀ ≠ 0.★₀ → ★₁" $ + let tm1 = ^Arr Zero (^TYPE 0) (^TYPE 0) + tm2 = ^Arr Zero (^TYPE 0) (^TYPE 1) in + equalT empty (^TYPE 2) tm1 tm2, + testNeq "0.A → B ≠ 1.A → B" $ + let tm1 = ^Arr Zero (^FT "A") (^FT "B") + tm2 = ^Arr One (^FT "A") (^FT "B") in + equalT empty (^TYPE 0) tm1 tm2, + testNeq "0.A → B ≮: 1.A → B" $ + let tm1 = ^Arr Zero (^FT "A") (^FT "B") + tm2 = ^Arr One (^FT "A") (^FT "B") in + subT empty (^TYPE 0) tm1 tm2, + testEq "0=1 ⊢ 0.A → B = 1.A → B" $ + let tm1 = ^Arr Zero (^FT "A") (^FT "B") + tm2 = ^Arr One (^FT "A") (^FT "B") in + equalT empty01 (^TYPE 0) tm1 tm2, + todo "dependent function types" ], "lambda" :- [ - testEq "λ x ⇒ [x] = λ x ⇒ [x]" $ - equalT empty (Arr One (FT "A") (FT "A")) - ([< "x"] :\\ BVT 0) - ([< "x"] :\\ BVT 0), - testEq "λ x ⇒ [x] <: λ x ⇒ [x]" $ - subT empty (Arr One (FT "A") (FT "A")) - ([< "x"] :\\ BVT 0) - ([< "x"] :\\ BVT 0), - testEq "λ x ⇒ [x] = λ y ⇒ [y]" $ - equalT empty (Arr One (FT "A") (FT "A")) - ([< "x"] :\\ BVT 0) - ([< "y"] :\\ BVT 0), - testEq "λ x ⇒ [x] <: λ y ⇒ [y]" $ - equalT empty (Arr One (FT "A") (FT "A")) - ([< "x"] :\\ BVT 0) - ([< "y"] :\\ BVT 0), - testNeq "λ x y ⇒ [x] ≠ λ x y ⇒ [y]" $ - equalT empty (Arr One (FT "A") $ Arr One (FT "A") (FT "A")) - ([< "x", "y"] :\\ BVT 1) - ([< "x", "y"] :\\ BVT 0), - testEq "λ x ⇒ [a] = λ x ⇒ [a] (Y vs N)" $ - equalT empty (Arr Zero (FT "B") (FT "A")) - (Lam $ SY [< "x"] $ FT "a") - (Lam $ SN $ FT "a"), - testEq "λ x ⇒ [f [x]] = [f] (η)" $ - equalT empty (Arr One (FT "A") (FT "A")) - ([< "x"] :\\ E (F "f" :@ BVT 0)) - (FT "f") + testEq "λ x ⇒ x = λ x ⇒ x" $ + equalT empty (^Arr One (^FT "A") (^FT "A")) + (^LamY "x" (^BVT 0)) + (^LamY "x" (^BVT 0)), + testEq "λ x ⇒ x <: λ x ⇒ x" $ + subT empty (^Arr One (^FT "A") (^FT "A")) + (^LamY "x" (^BVT 0)) + (^LamY "x" (^BVT 0)), + testEq "λ x ⇒ x = λ y ⇒ y" $ + equalT empty (^Arr One (^FT "A") (^FT "A")) + (^LamY "x" (^BVT 0)) + (^LamY "y" (^BVT 0)), + testEq "λ x ⇒ x <: λ y ⇒ y" $ + subT empty (^Arr One (^FT "A") (^FT "A")) + (^LamY "x" (^BVT 0)) + (^LamY "y" (^BVT 0)), + testNeq "λ x y ⇒ x ≠ λ x y ⇒ y" $ + equalT empty + (^Arr One (^FT "A") (^Arr One (^FT "A") (^FT "A"))) + (^LamY "x" (^LamY "y" (^BVT 1))) + (^LamY "x" (^LamY "y" (^BVT 0))), + testEq "λ x ⇒ a = λ x ⇒ a (Y vs N)" $ + equalT empty + (^Arr Zero (^FT "B") (^FT "A")) + (^LamY "x" (^FT "a")) + (^LamN (^FT "a")), + testEq "λ x ⇒ f x = f (η)" $ + equalT empty + (^Arr One (^FT "A") (^FT "A")) + (^LamY "x" (E $ ^App (^F "f") (^BVT 0))) + (^FT "f") ], "eq type" :- [ testEq "(★₀ ≡ ★₀ : ★₁) = (★₀ ≡ ★₀ : ★₁)" $ - let tm = Eq0 (TYPE 1) (TYPE 0) (TYPE 0) in - equalT empty (TYPE 2) tm tm, + let tm = ^Eq0 (^TYPE 1) (^TYPE 0) (^TYPE 0) in + equalT empty (^TYPE 2) tm tm, testEq "A ≔ ★₁ ⊢ (★₀ ≡ ★₀ : ★₁) = (★₀ ≡ ★₀ : A)" - {globals = fromList [("A", mkDef gzero (TYPE 2) (TYPE 1))]} $ - equalT empty (TYPE 2) - (Eq0 (TYPE 1) (TYPE 0) (TYPE 0)) - (Eq0 (FT "A") (TYPE 0) (TYPE 0)), + {globals = fromList [("A", ^mkDef gzero (^TYPE 2) (^TYPE 1))]} $ + equalT empty (^TYPE 2) + (^Eq0 (^TYPE 1) (^TYPE 0) (^TYPE 0)) + (^Eq0 (^FT "A") (^TYPE 0) (^TYPE 0)), todo "dependent equality types" ], "equalities and uip" :- let refl : Term d n -> Term d n -> Elim d n - refl a x = (DLam $ S [< "_"] $ N x) :# (Eq0 a x x) + refl a x = ^Ann (^DLam (SN x)) (^Eq0 a x x) in [ - note #""refl [A] x" is an abbreviation for "(δ i ⇒ x) ∷ (x ≡ x : A)""#, note "binds before ∥ are globals, after it are BVs", - testEq "refl [A] a = refl [A] a" $ - equalE empty (refl (FT "A") (FT "a")) (refl (FT "A") (FT "a")), + note #"refl A x is an abbreviation for "(δ i ⇒ x) ∷ (x ≡ x : A)""#, + testEq "refl A a = refl A a" $ + equalE empty (refl (^FT "A") (^FT "a")) (refl (^FT "A") (^FT "a")), testEq "p : (a ≡ a' : A), q : (a ≡ a' : A) ∥ ⊢ p = q (free)" {globals = - let def = mkPostulate gzero $ Eq0 (FT "A") (FT "a") (FT "a'") in - defGlobals `mergeLeft` fromList [("p", def), ("q", def)]} $ - equalE empty (F "p") (F "q"), + let def = ^mkPostulate gzero (^Eq0 (^FT "A") (^FT "a") (^FT "a'")) + in defGlobals `mergeLeft` fromList [("p", def), ("q", def)]} $ + equalE empty (^F "p") (^F "q"), testEq "∥ x : (a ≡ a' : A), y : (a ≡ a' : A) ⊢ x = y (bound)" $ - let ty : forall n. Term 0 n := Eq0 (FT "A") (FT "a") (FT "a'") in + let ty : forall n. Term 0 n := ^Eq0 (^FT "A") (^FT "a") (^FT "a'") in equalE (extendTyN [< (Any, "x", ty), (Any, "y", ty)] empty) - (BV 0) (BV 1), + (^BV 0) (^BV 1), - testEq "∥ x : [(a ≡ a' : A) ∷ Type 0], y : [ditto] ⊢ x = y" $ + testEq "∥ x : (a ≡ a' : A) ∷ Type 0, y : [ditto] ⊢ x = y" $ let ty : forall n. Term 0 n := - E (Eq0 (FT "A") (FT "a") (FT "a'") :# TYPE 0) in + E $ ^Ann (^Eq0 (^FT "A") (^FT "a") (^FT "a'")) (^TYPE 0) in equalE (extendTyN [< (Any, "x", ty), (Any, "y", ty)] empty) - (BV 0) (BV 1), + (^BV 0) (^BV 1), testEq "E ≔ a ≡ a' : A, EE ≔ E ∥ x : EE, y : EE ⊢ x = y" {globals = defGlobals `mergeLeft` fromList - [("E", mkDef gzero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'"))), - ("EE", mkDef gzero (TYPE 0) (FT "E"))]} $ - equalE (extendTyN [< (Any, "x", FT "EE"), (Any, "y", FT "EE")] empty) - (BV 0) (BV 1), + [("E", ^mkDef gzero (^TYPE 0) + (^Eq0 (^FT "A") (^FT "a") (^FT "a'"))), + ("EE", ^mkDef gzero (^TYPE 0) (^FT "E"))]} $ + equalE (extendTyN [< (Any, "x", ^FT "EE"), (Any, "y", ^FT "EE")] empty) + (^BV 0) (^BV 1), testEq "E ≔ a ≡ a' : A, EE ≔ E ∥ x : EE, y : E ⊢ x = y" {globals = defGlobals `mergeLeft` fromList - [("E", mkDef gzero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'"))), - ("EE", mkDef gzero (TYPE 0) (FT "E"))]} $ - equalE (extendTyN [< (Any, "x", FT "EE"), (Any, "y", FT "E")] empty) - (BV 0) (BV 1), + [("E", ^mkDef gzero (^TYPE 0) + (^Eq0 (^FT "A") (^FT "a") (^FT "a'"))), + ("EE", ^mkDef gzero (^TYPE 0) (^FT "E"))]} $ + equalE (extendTyN [< (Any, "x", ^FT "EE"), (Any, "y", ^FT "E")] empty) + (^BV 0) (^BV 1), testEq "E ≔ a ≡ a' : A ∥ x : E, y : E ⊢ x = y" {globals = defGlobals `mergeLeft` fromList - [("E", mkDef gzero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'")))]} $ - equalE (extendTyN [< (Any, "x", FT "E"), (Any, "y", FT "E")] empty) - (BV 0) (BV 1), + [("E", ^mkDef gzero (^TYPE 0) + (^Eq0 (^FT "A") (^FT "a") (^FT "a'")))]} $ + equalE (extendTyN [< (Any, "x", ^FT "E"), (Any, "y", ^FT "E")] empty) + (^BV 0) (^BV 1), testEq "E ≔ a ≡ a' : A ∥ x : (E×E), y : (E×E) ⊢ x = y" {globals = defGlobals `mergeLeft` fromList - [("E", mkDef gzero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'")))]} $ - let ty : forall n. Term 0 n := - Sig (FT "E") $ S [< "_"] $ N $ FT "E" in + [("E", ^mkDef gzero (^TYPE 0) + (^Eq0 (^FT "A") (^FT "a") (^FT "a'")))]} $ + let ty : forall n. Term 0 n := ^Sig (^FT "E") (SN $ ^FT "E") in equalE (extendTyN [< (Any, "x", ty), (Any, "y", ty)] empty) - (BV 0) (BV 1), + (^BV 0) (^BV 1), - testEq "E ≔ a ≡ a' : A, W ≔ E × E ∥ x : W, y : W ⊢ x = y" + testEq "E ≔ a ≡ a' : A, W ≔ E × E ∥ x : W, y : E×E ⊢ x = y" {globals = defGlobals `mergeLeft` fromList - [("E", mkDef gzero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'"))), - ("W", mkDef gzero (TYPE 0) (FT "E" `And` FT "E"))]} $ + [("E", ^mkDef gzero (^TYPE 0) + (^Eq0 (^FT "A") (^FT "a") (^FT "a'"))), + ("W", ^mkDef gzero (^TYPE 0) (^And (^FT "E") (^FT "E")))]} $ equalE - (extendTyN [< (Any, "x", FT "W"), (Any, "y", FT "W")] empty) - (BV 0) (BV 1) + (extendTyN [< (Any, "x", ^FT "W"), + (Any, "y", ^And (^FT "E") (^FT "E"))] empty) + (^BV 0) (^BV 1) ], "term closure" :- [ - testEq "[#0]{} = [#0] : A" $ - equalT (extendTy Any "x" (FT "A") empty) - (FT "A") - (CloT (Sub (BVT 0) id)) - (BVT 0), - testEq "[#0]{a} = [a] : A" $ - equalT empty (FT "A") - (CloT (Sub (BVT 0) (F "a" ::: id))) - (FT "a"), - testEq "[#0]{a,b} = [a] : A" $ - equalT empty (FT "A") - (CloT (Sub (BVT 0) (F "a" ::: F "b" ::: id))) - (FT "a"), - testEq "[#1]{a,b} = [b] : A" $ - equalT empty (FT "A") - (CloT (Sub (BVT 1) (F "a" ::: F "b" ::: id))) - (FT "b"), - testEq "(λy ⇒ [#1]){a} = λy ⇒ [a] : B ⇾ A (N)" $ - equalT empty (Arr Zero (FT "B") (FT "A")) - (CloT (Sub (Lam $ S [< "y"] $ N $ BVT 0) (F "a" ::: id))) - (Lam $ S [< "y"] $ N $ FT "a"), - testEq "(λy ⇒ [#1]){a} = λy ⇒ [a] : B ⇾ A (Y)" $ - equalT empty (Arr Zero (FT "B") (FT "A")) - (CloT (Sub ([< "y"] :\\ BVT 1) (F "a" ::: id))) - ([< "y"] :\\ FT "a") + note "bold numbers for de bruijn indices", + testEq "𝟎{} = 𝟎 : A" $ + equalT (extendTy Any "x" (^FT "A") empty) + (^FT "A") + (CloT (Sub (^BVT 0) id)) + (^BVT 0), + testEq "𝟎{a} = a : A" $ + equalT empty (^FT "A") + (CloT (Sub (^BVT 0) (^F "a" ::: id))) + (^FT "a"), + testEq "𝟎{a,b} = a : A" $ + equalT empty (^FT "A") + (CloT (Sub (^BVT 0) (^F "a" ::: ^F "b" ::: id))) + (^FT "a"), + testEq "𝟏{a,b} = b : A" $ + equalT empty (^FT "A") + (CloT (Sub (^BVT 1) (^F "a" ::: ^F "b" ::: id))) + (^FT "b"), + testEq "(λy ⇒ 𝟏){a} = λy ⇒ a : 0.B → A (N)" $ + equalT empty (^Arr Zero (^FT "B") (^FT "A")) + (CloT (Sub (^LamN (^BVT 0)) (^F "a" ::: id))) + (^LamN (^FT "a")), + testEq "(λy ⇒ 𝟏){a} = λy ⇒ a : 0.B → A (Y)" $ + equalT empty (^Arr Zero (^FT "B") (^FT "A")) + (CloT (Sub (^LamY "y" (^BVT 1)) (^F "a" ::: id))) + (^LamY "y" (^FT "a")) ], "term d-closure" :- [ - testEq "★₀‹𝟎› = ★₀ : ★₁" $ - equalTD 1 - (extendDim "𝑗" empty) - (TYPE 1) (DCloT (Sub (TYPE 0) (K Zero ::: id))) (TYPE 0), - testEq "(δ i ⇒ a)‹𝟎› = (δ i ⇒ a) : (a ≡ a : A)" $ - equalTD 1 - (extendDim "𝑗" empty) - (Eq0 (FT "A") (FT "a") (FT "a")) - (DCloT (Sub ([< "i"] :\\% FT "a") (K Zero ::: id))) - ([< "i"] :\\% FT "a"), + testEq "★₀‹0› = ★₀ : ★₁" $ + equalT (extendDim "𝑗" empty) + (^TYPE 1) (DCloT (Sub (^TYPE 0) (^K Zero ::: id))) (^TYPE 0), + testEq "(δ i ⇒ a)‹0› = (δ i ⇒ a) : (a ≡ a : A)" $ + equalT (extendDim "𝑗" empty) + (^Eq0 (^FT "A") (^FT "a") (^FT "a")) + (DCloT (Sub (^DLamN (^FT "a")) (^K Zero ::: id))) + (^DLamN (^FT "a")), note "it is hard to think of well-typed terms with big dctxs" ], "free var" :- let au_bu = fromList - [("A", mkDef gany (TYPE 1) (TYPE 0)), - ("B", mkDef gany (TYPE 1) (TYPE 0))] + [("A", ^mkDef gany (^TYPE 1) (^TYPE 0)), + ("B", ^mkDef gany (^TYPE 1) (^TYPE 0))] au_ba = fromList - [("A", mkDef gany (TYPE 1) (TYPE 0)), - ("B", mkDef gany (TYPE 1) (FT "A"))] + [("A", ^mkDef gany (^TYPE 1) (^TYPE 0)), + ("B", ^mkDef gany (^TYPE 1) (^FT "A"))] in [ testEq "A = A" $ - equalE empty (F "A") (F "A"), + equalE empty (^F "A") (^F "A"), testNeq "A ≠ B" $ - equalE empty (F "A") (F "B"), + equalE empty (^F "A") (^F "B"), testEq "0=1 ⊢ A = B" $ - equalE empty01 (F "A") (F "B"), + equalE empty01 (^F "A") (^F "B"), testEq "A : ★₁ ≔ ★₀ ⊢ A = (★₀ ∷ ★₁)" {globals = au_bu} $ - equalE empty (F "A") (TYPE 0 :# TYPE 1), - testEq "A : ★₁ ≔ ★₀ ⊢ [A] = ★₀" {globals = au_bu} $ - equalT empty (TYPE 1) (FT "A") (TYPE 0), + equalE empty (^F "A") (^Ann (^TYPE 0) (^TYPE 1)), + testEq "A : ★₁ ≔ ★₀ ⊢ A = ★₀" {globals = au_bu} $ + equalT empty (^TYPE 1) (^FT "A") (^TYPE 0), testEq "A ≔ ★₀, B ≔ ★₀ ⊢ A = B" {globals = au_bu} $ - equalE empty (F "A") (F "B"), + equalE empty (^F "A") (^F "B"), testEq "A ≔ ★₀, B ≔ A ⊢ A = B" {globals = au_ba} $ - equalE empty (F "A") (F "B"), + equalE empty (^F "A") (^F "B"), testEq "A <: A" $ - subE empty (F "A") (F "A"), + subE empty (^F "A") (^F "A"), testNeq "A ≮: B" $ - subE empty (F "A") (F "B"), + subE empty (^F "A") (^F "B"), testEq "A : ★₃ ≔ ★₀, B : ★₃ ≔ ★₂ ⊢ A <: B" - {globals = fromList [("A", mkDef gany (TYPE 3) (TYPE 0)), - ("B", mkDef gany (TYPE 3) (TYPE 2))]} $ - subE empty (F "A") (F "B"), + {globals = fromList [("A", ^mkDef gany (^TYPE 3) (^TYPE 0)), + ("B", ^mkDef gany (^TYPE 3) (^TYPE 2))]} $ + subE empty (^F "A") (^F "B"), note "(A and B in different universes)", testEq "A : ★₁ ≔ ★₀, B : ★₃ ≔ ★₂ ⊢ A <: B" - {globals = fromList [("A", mkDef gany (TYPE 1) (TYPE 0)), - ("B", mkDef gany (TYPE 3) (TYPE 2))]} $ - subE empty (F "A") (F "B"), + {globals = fromList [("A", ^mkDef gany (^TYPE 1) (^TYPE 0)), + ("B", ^mkDef gany (^TYPE 3) (^TYPE 2))]} $ + subE empty (^F "A") (^F "B"), testEq "0=1 ⊢ A <: B" $ - subE empty01 (F "A") (F "B") + subE empty01 (^F "A") (^F "B") ], "bound var" :- [ - testEq "#0 = #0" $ - equalE (extendTy Any "A" (TYPE 0) empty) (BV 0) (BV 0), - testEq "#0 <: #0" $ - subE (extendTy Any "A" (TYPE 0) empty) (BV 0) (BV 0), - testNeq "#0 ≠ #1" $ - equalE (extendTyN [< (Any, "A", TYPE 0), (Any, "B", TYPE 0)] empty) - (BV 0) (BV 1), - testNeq "#0 ≮: #1" $ - subE (extendTyN [< (Any, "A", TYPE 0), (Any, "B", TYPE 0)] empty) - (BV 0) (BV 1), - testEq "0=1 ⊢ #0 = #1" $ - equalE (extendTyN [< (Any, "A", TYPE 0), (Any, "B", TYPE 0)] empty01) - (BV 0) (BV 1) + note "bold numbers for de bruijn indices", + testEq "𝟎 = 𝟎" $ + equalE (extendTy Any "A" (^TYPE 0) empty) (^BV 0) (^BV 0), + testEq "𝟎 <: 𝟎" $ + subE (extendTy Any "A" (^TYPE 0) empty) (^BV 0) (^BV 0), + testNeq "𝟎 ≠ 𝟏" $ + equalE (extendTyN [< (Any, "A", ^TYPE 0), (Any, "B", ^TYPE 0)] empty) + (^BV 0) (^BV 1), + testNeq "𝟎 ≮: 𝟏" $ + subE (extendTyN [< (Any, "A", ^TYPE 0), (Any, "B", ^TYPE 0)] empty) + (^BV 0) (^BV 1), + testEq "0=1 ⊢ 𝟎 = 𝟏" $ + equalE (extendTyN [< (Any, "A", ^TYPE 0), (Any, "B", ^TYPE 0)] empty01) + (^BV 0) (^BV 1) ], "application" :- [ - testEq "f [a] = f [a]" $ - equalE empty (F "f" :@ FT "a") (F "f" :@ FT "a"), - testEq "f [a] <: f [a]" $ - subE empty (F "f" :@ FT "a") (F "f" :@ FT "a"), - testEq "(λ x ⇒ [x] ∷ A ⊸ A) a = ([a ∷ A] ∷ A) (β)" $ + testEq "f a = f a" $ + equalE empty (^App (^F "f") (^FT "a")) (^App (^F "f") (^FT "a")), + testEq "f a <: f a" $ + subE empty (^App (^F "f") (^FT "a")) (^App (^F "f") (^FT "a")), + testEq "(λ x ⇒ x ∷ 1.A → A) a = ((a ∷ A) ∷ A) (β)" $ equalE empty - ((([< "x"] :\\ BVT 0) :# Arr One (FT "A") (FT "A")) :@ FT "a") - (E (FT "a" :# FT "A") :# FT "A"), - testEq "(λ x ⇒ [x] ∷ A ⊸ A) a = a (βυ)" $ + (^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A"))) + (^FT "a")) + (^Ann (E $ ^Ann (^FT "a") (^FT "A")) (^FT "A")), + testEq "(λ x ⇒ x ∷ A ⊸ A) a = a (βυ)" $ equalE empty - ((([< "x"] :\\ BVT 0) :# Arr One (FT "A") (FT "A")) :@ FT "a") - (F "a"), - testEq "(λ g ⇒ [g [a]] ∷ ⋯)) [f] = (λ y ⇒ [f [y]] ∷ ⋯) [a] (β↘↙)" $ - let a = FT "A"; a2a = (Arr One a a) in + (^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A"))) + (^FT "a")) + (^F "a"), + testEq "((λ g ⇒ g a) ∷ 1.(1.A → A) → A) f = ((λ y ⇒ f y) ∷ 1.A → A) a # β↘↙" $ + let a = ^FT "A"; a2a = ^Arr One a a; aa2a = ^Arr One a2a a in equalE empty - ((([< "g"] :\\ E (BV 0 :@ FT "a")) :# Arr One a2a a) :@ FT "f") - ((([< "y"] :\\ E (F "f" :@ BVT 0)) :# a2a) :@ FT "a"), - testEq "(λ x ⇒ [x] ∷ A ⊸ A) a <: a" $ + (^App (^Ann (^LamY "g" (E $ ^App (^BV 0) (^FT "a"))) aa2a) (^FT "f")) + (^App (^Ann (^LamY "y" (E $ ^App (^F "f") (^BVT 0))) a2a) (^FT "a")), + testEq "((λ x ⇒ x) ∷ 1.A → A) a <: a" $ subE empty - ((([< "x"] :\\ BVT 0) :# (Arr One (FT "A") (FT "A"))) :@ FT "a") - (F "a"), - note "id : A ⊸ A ≔ λ x ⇒ [x]", - testEq "id [a] = a" $ equalE empty (F "id" :@ FT "a") (F "a"), - testEq "id [a] <: a" $ subE empty (F "id" :@ FT "a") (F "a") + (^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A"))) + (^FT "a")) + (^F "a"), + note "id : A ⊸ A ≔ λ x ⇒ x", + testEq "id a = a" $ equalE empty (^App (^F "id") (^FT "a")) (^F "a"), + testEq "id a <: a" $ subE empty (^App (^F "id") (^FT "a")) (^F "a") ], "dim application" :- [ testEq "eq-AB @0 = eq-AB @0" $ - equalE empty (F "eq-AB" :% K Zero) (F "eq-AB" :% K Zero), + equalE empty + (^DApp (^F "eq-AB") (^K Zero)) + (^DApp (^F "eq-AB") (^K Zero)), testNeq "eq-AB @0 ≠ eq-AB @1" $ - equalE empty (F "eq-AB" :% K Zero) (F "eq-AB" :% K One), + equalE empty + (^DApp (^F "eq-AB") (^K Zero)) + (^DApp (^F "eq-AB") (^K One)), testEq "𝑖 | ⊢ eq-AB @𝑖 = eq-AB @𝑖" $ - equalED 1 + equalE (extendDim "𝑖" empty) - (F "eq-AB" :% BV 0) (F "eq-AB" :% BV 0), + (^DApp (^F "eq-AB") (^BV 0)) + (^DApp (^F "eq-AB") (^BV 0)), testNeq "𝑖 | ⊢ eq-AB @𝑖 ≠ eq-AB @0" $ - equalED 1 - (extendDim "𝑖" empty) - (F "eq-AB" :% BV 0) (F "eq-AB" :% K Zero), + equalE (extendDim "𝑖" empty) + (^DApp (^F "eq-AB") (^BV 0)) + (^DApp (^F "eq-AB") (^K Zero)), testEq "𝑖, 𝑖=0 | ⊢ eq-AB @𝑖 = eq-AB @0" $ - equalED 1 - (eqDim (BV 0) (K Zero) $ extendDim "𝑖" empty) - (F "eq-AB" :% BV 0) (F "eq-AB" :% K Zero), + equalE (eqDim (^BV 0) (^K Zero) $ extendDim "𝑖" empty) + (^DApp (^F "eq-AB") (^BV 0)) + (^DApp (^F "eq-AB") (^K Zero)), testNeq "𝑖, 𝑖=1 | ⊢ eq-AB @𝑖 ≠ eq-AB @0" $ - equalED 1 - (eqDim (BV 0) (K One) $ extendDim "𝑖" empty) - (F "eq-AB" :% BV 0) (F "eq-AB" :% K Zero), + equalE (eqDim (^BV 0) (^K One) $ extendDim "𝑖" empty) + (^DApp (^F "eq-AB") (^BV 0)) + (^DApp (^F "eq-AB") (^K Zero)), testNeq "𝑖, 𝑗 | ⊢ eq-AB @𝑖 ≠ eq-AB @𝑗" $ - equalED 2 - (extendDim "𝑗" $ extendDim "𝑖" empty) - (F "eq-AB" :% BV 1) (F "eq-AB" :% BV 0), + equalE (extendDim "𝑗" $ extendDim "𝑖" empty) + (^DApp (^F "eq-AB") (^BV 1)) + (^DApp (^F "eq-AB") (^BV 0)), testEq "𝑖, 𝑗, 𝑖=𝑗 | ⊢ eq-AB @𝑖 = eq-AB @𝑗" $ - equalED 2 - (eqDim (BV 0) (BV 1) $ extendDim "𝑗" $ extendDim "𝑖" empty) - (F "eq-AB" :% BV 1) (F "eq-AB" :% BV 0), + equalE (eqDim (^BV 0) (^BV 1) $ extendDim "𝑗" $ extendDim "𝑖" empty) + (^DApp (^F "eq-AB") (^BV 1)) + (^DApp (^F "eq-AB") (^BV 0)), testEq "𝑖, 𝑗, 𝑖=0, 𝑗=0 | ⊢ eq-AB @𝑖 = eq-AB @𝑗" $ - equalED 2 - (eqDim (BV 0) (K Zero) $ eqDim (BV 1) (K Zero) $ + equalE + (eqDim (^BV 0) (^K Zero) $ eqDim (^BV 1) (^K Zero) $ extendDim "𝑗" $ extendDim "𝑖" empty) - (F "eq-AB" :% BV 1) (F "eq-AB" :% BV 0), + (^DApp (^F "eq-AB") (^BV 1)) + (^DApp (^F "eq-AB") (^BV 0)), testEq "0=1 | ⊢ eq-AB @𝑖 = eq-AB @𝑗" $ - equalED 2 - (extendDim "𝑗" $ extendDim "𝑖" empty01) - (F "eq-AB" :% BV 1) (F "eq-AB" :% BV 0), - testEq "eq-AB @0 = A" $ equalE empty (F "eq-AB" :% K Zero) (F "A"), - testEq "eq-AB @1 = B" $ equalE empty (F "eq-AB" :% K One) (F "B"), - testEq "((δ i ⇒ a) ∷ a ≡ a) @0 = a" $ + equalE (extendDim "𝑗" $ extendDim "𝑖" empty01) + (^DApp (^F "eq-AB") (^BV 1)) + (^DApp (^F "eq-AB") (^BV 0)), + testEq "eq-AB @0 = A" $ + equalE empty (^DApp (^F "eq-AB") (^K Zero)) (^F "A"), + testEq "eq-AB @1 = B" $ + equalE empty (^DApp (^F "eq-AB") (^K One)) (^F "B"), + testEq "((δ i ⇒ a) ∷ a ≡ a : A) @0 = a" $ equalE empty - (((DLam $ SN $ FT "a") :# Eq0 (FT "A") (FT "a") (FT "a")) :% K Zero) - (F "a"), - testEq "((δ i ⇒ a) ∷ a ≡ a) @0 = ((δ i ⇒ a) ∷ a ≡ a) @1" $ + (^DApp (^Ann (^DLamN (^FT "a")) (^Eq0 (^FT "A") (^FT "a") (^FT "a"))) + (^K Zero)) + (^F "a"), + testEq "((δ i ⇒ a) ∷ a ≡ a : A) @0 = ((δ i ⇒ a) ∷ a ≡ a : A) @1" $ equalE empty - (((DLam $ SN $ FT "a") :# Eq0 (FT "A") (FT "a") (FT "a")) :% K Zero) - (((DLam $ SN $ FT "a") :# Eq0 (FT "A") (FT "a") (FT "a")) :% K One) + (^DApp (^Ann (^DLamN (^FT "a")) (^Eq0 (^FT "A") (^FT "a") (^FT "a"))) + (^K Zero)) + (^DApp (^Ann (^DLamN (^FT "a")) (^Eq0 (^FT "A") (^FT "a") (^FT "a"))) + (^K One)) ], "annotation" :- [ - testEq "(λ x ⇒ f [x]) ∷ A ⊸ A = [f] ∷ A ⊸ A" $ + testEq "(λ x ⇒ f x) ∷ 1.A → A = f ∷ 1.A → A" $ equalE empty - (([< "x"] :\\ E (F "f" :@ BVT 0)) :# Arr One (FT "A") (FT "A")) - (FT "f" :# Arr One (FT "A") (FT "A")), - testEq "[f] ∷ A ⊸ A = f" $ - equalE empty (FT "f" :# Arr One (FT "A") (FT "A")) (F "f"), - testEq "(λ x ⇒ f [x]) ∷ A ⊸ A = f" $ + (^Ann (^LamY "x" (E $ ^App (^F "f") (^BVT 0))) + (^Arr One (^FT "A") (^FT "A"))) + (^Ann (^FT "f") (^Arr One (^FT "A") (^FT "A"))), + testEq "f ∷ 1.A → A = f" $ equalE empty - (([< "x"] :\\ E (F "f" :@ BVT 0)) :# Arr One (FT "A") (FT "A")) - (F "f") + (^Ann (^FT "f") (^Arr One (^FT "A") (^FT "A"))) + (^F "f"), + testEq "(λ x ⇒ f x) ∷ 1.A → A = f" $ + equalE empty + (^Ann (^LamY "x" (E $ ^App (^F "f") (^BVT 0))) + (^Arr One (^FT "A") (^FT "A"))) + (^F "f") ], "natural type" :- [ - testEq "ℕ = ℕ" $ equalTy empty Nat Nat, - testEq "ℕ = ℕ : ★₀" $ equalT empty (TYPE 0) Nat Nat, - testEq "ℕ = ℕ : ★₆₉" $ equalT empty (TYPE 69) Nat Nat, - testNeq "ℕ ≠ {}" $ equalTy empty Nat (enum []), - testEq "0=1 ⊢ ℕ = {}" $ equalTy empty01 Nat (enum []) + testEq "ℕ = ℕ" $ equalTy empty (^Nat) (^Nat), + testEq "ℕ = ℕ : ★₀" $ equalT empty (^TYPE 0) (^Nat) (^Nat), + testEq "ℕ = ℕ : ★₆₉" $ equalT empty (^TYPE 69) (^Nat) (^Nat), + testNeq "ℕ ≠ {}" $ equalTy empty (^Nat) (^enum []), + testEq "0=1 ⊢ ℕ = {}" $ equalTy empty01 (^Nat) (^enum []) ], "natural numbers" :- [ - testEq "zero = zero" $ equalT empty Nat Zero Zero, + testEq "0 = 0" $ equalT empty (^Nat) (^Zero) (^Zero), testEq "succ two = succ two" $ - equalT empty Nat (Succ (FT "two")) (Succ (FT "two")), + equalT empty (^Nat) (^Succ (^FT "two")) (^Succ (^FT "two")), testNeq "succ two ≠ two" $ - equalT empty Nat (Succ (FT "two")) (FT "two"), - testNeq "zero ≠ succ zero" $ - equalT empty Nat Zero (Succ Zero), - testEq "0=1 ⊢ zero = succ zero" $ - equalT empty01 Nat Zero (Succ Zero) + equalT empty (^Nat) (^Succ (^FT "two")) (^FT "two"), + testNeq "0 ≠ 1" $ + equalT empty (^Nat) (^Zero) (^Succ (^Zero)), + testEq "0=1 ⊢ 0 = 1" $ + equalT empty01 (^Nat) (^Zero) (^Succ (^Zero)) ], "natural elim" :- [ testEq "caseω 0 return {a,b} of {zero ⇒ 'a; succ _ ⇒ 'b} = 'a" $ equalT empty - (enum ["a", "b"]) - (E $ CaseNat Any Zero (Zero :# Nat) - (SN $ enum ["a", "b"]) - (Tag "a") - (SN $ Tag "b")) - (Tag "a"), + (^enum ["a", "b"]) + (E $ ^CaseNat Any Zero (^Ann (^Zero) (^Nat)) + (SN $ ^enum ["a", "b"]) + (^Tag "a") + (SN $ ^Tag "b")) + (^Tag "a"), testEq "caseω 1 return {a,b} of {zero ⇒ 'a; succ _ ⇒ 'b} = 'b" $ equalT empty - (enum ["a", "b"]) - (E $ CaseNat Any Zero (Succ Zero :# Nat) - (SN $ enum ["a", "b"]) - (Tag "a") - (SN $ Tag "b")) - (Tag "b"), + (^enum ["a", "b"]) + (E $ ^CaseNat Any Zero (^Ann (^Succ (^Zero)) (^Nat)) + (SN $ ^enum ["a", "b"]) + (^Tag "a") + (SN $ ^Tag "b")) + (^Tag "b"), testEq "caseω 4 return ℕ of {0 ⇒ 0; succ n ⇒ n} = 3" $ equalT empty - Nat - (E $ CaseNat Any Zero (makeNat 4 :# Nat) - (SN Nat) - Zero - (SY [< "n", Unused] $ BVT 1)) - (makeNat 3) + (^Nat) + (E $ ^CaseNat Any Zero (^Ann (^makeNat 4) (^Nat)) + (SN $ ^Nat) + (^Zero) + (SY [< "n", ^BN Unused] $ ^BVT 1)) + (^makeNat 3) ], todo "pair types", @@ -472,24 +484,24 @@ tests = "equality & subtyping" :- [ "pairs" :- [ testEq "('a, 'b) = ('a, 'b) : {a} × {b}" $ equalT empty - (enum ["a"] `And` enum ["b"]) - (Tag "a" `Pair` Tag "b") - (Tag "a" `Pair` Tag "b"), + (^And (^enum ["a"]) (^enum ["b"])) + (^Pair (^Tag "a") (^Tag "b")) + (^Pair (^Tag "a") (^Tag "b")), testNeq "('a, 'b) ≠ ('b, 'a) : {a,b} × {a,b}" $ equalT empty - (enum ["a", "b"] `And` enum ["a", "b"]) - (Tag "a" `Pair` Tag "b") - (Tag "b" `Pair` Tag "a"), + (^And (^enum ["a", "b"]) (^enum ["a", "b"])) + (^Pair (^Tag "a") (^Tag "b")) + (^Pair (^Tag "b") (^Tag "a")), testEq "0=1 ⊢ ('a, 'b) = ('b, 'a) : {a,b} × {a,b}" $ equalT empty01 - (enum ["a", "b"] `And` enum ["a", "b"]) - (Tag "a" `Pair` Tag "b") - (Tag "b" `Pair` Tag "a"), + (^And (^enum ["a", "b"]) (^enum ["a", "b"])) + (^Pair (^Tag "a") (^Tag "b")) + (^Pair (^Tag "b") (^Tag "a")), testEq "0=1 ⊢ ('a, 'b) = ('b, 'a) : ℕ" $ equalT empty01 - Nat - (Tag "a" `Pair` Tag "b") - (Tag "b" `Pair` Tag "a") + (^Nat) + (^Pair (^Tag "a") (^Tag "b")) + (^Pair (^Tag "b") (^Tag "a")) ], todo "pair elim", @@ -503,61 +515,60 @@ tests = "equality & subtyping" :- [ todo "box elim", "elim closure" :- [ - testEq "#0{a} = a" $ - equalE empty (CloE (Sub (BV 0) (F "a" ::: id))) (F "a"), - testEq "#1{a} = #0" $ - equalE (extendTy Any "x" (FT "A") empty) - (CloE (Sub (BV 1) (F "a" ::: id))) (BV 0) + note "bold numbers for de bruijn indices", + testEq "𝟎{a} = a" $ + equalE empty (CloE (Sub (^BV 0) (^F "a" ::: id))) (^F "a"), + testEq "𝟏{a} = 𝟎" $ + equalE (extendTy Any "x" (^FT "A") empty) + (CloE (Sub (^BV 1) (^F "a" ::: id))) (^BV 0) ], "elim d-closure" :- [ + note "bold numbers for de bruijn indices", note "0·eq-AB : (A ≡ B : ★₀)", - testEq "(eq-AB #0)‹𝟎› = eq-AB 𝟎" $ - equalED 1 - (extendDim "𝑖" empty) - (DCloE (Sub (F "eq-AB" :% BV 0) (K Zero ::: id))) - (F "eq-AB" :% K Zero), - testEq "(eq-AB #0)‹𝟎› = A" $ - equalED 1 - (extendDim "𝑖" empty) - (DCloE (Sub (F "eq-AB" :% BV 0) (K Zero ::: id))) (F "A"), - testEq "(eq-AB #0)‹𝟏› = B" $ - equalED 1 - (extendDim "𝑖" empty) - (DCloE (Sub (F "eq-AB" :% BV 0) (K One ::: id))) (F "B"), - testNeq "(eq-AB #0)‹𝟏› ≠ A" $ - equalED 1 - (extendDim "𝑖" empty) - (DCloE (Sub (F "eq-AB" :% BV 0) (K One ::: id))) (F "A"), - testEq "(eq-AB #0)‹#0,𝟎› = (eq-AB #0)" $ - equalED 2 - (extendDim "𝑗" $ extendDim "𝑖" empty) - (DCloE (Sub (F "eq-AB" :% BV 0) (BV 0 ::: K Zero ::: id))) - (F "eq-AB" :% BV 0), - testNeq "(eq-AB #0)‹𝟎› ≠ (eq-AB 𝟎)" $ - equalED 2 - (extendDim "𝑗" $ extendDim "𝑖" empty) - (DCloE (Sub (F "eq-AB" :% BV 0) (BV 0 ::: K Zero ::: id))) - (F "eq-AB" :% K Zero), - testEq "#0‹𝟎› = #0 # term and dim vars distinct" $ - equalED 1 - (extendTy Any "x" (FT "A") $ extendDim "𝑖" empty) - (DCloE (Sub (BV 0) (K Zero ::: id))) (BV 0), - testEq "a‹𝟎› = a" $ - equalED 1 (extendDim "𝑖" empty) - (DCloE (Sub (F "a") (K Zero ::: id))) (F "a"), - testEq "(f [a])‹𝟎› = f‹𝟎› [a]‹𝟎›" $ - let th = K Zero ::: id in - equalED 1 (extendDim "𝑖" empty) - (DCloE (Sub (F "f" :@ FT "a") th)) - (DCloE (Sub (F "f") th) :@ DCloT (Sub (FT "a") th)) + testEq "(eq-AB @𝟎)‹0› = eq-AB @0" $ + equalE empty + (DCloE (Sub (^DApp (^F "eq-AB") (^BV 0)) (^K Zero ::: id))) + (^DApp (^F "eq-AB") (^K Zero)), + testEq "(eq-AB @𝟎)‹0› = A" $ + equalE empty + (DCloE (Sub (^DApp (^F "eq-AB") (^BV 0)) (^K Zero ::: id))) + (^F "A"), + testEq "(eq-AB @𝟎)‹1› = B" $ + equalE empty + (DCloE (Sub (^DApp (^F "eq-AB") (^BV 0)) (^K One ::: id))) + (^F "B"), + testNeq "(eq-AB @𝟎)‹1› ≠ A" $ + equalE empty + (DCloE (Sub (^DApp (^F "eq-AB") (^BV 0)) (^K One ::: id))) + (^F "A"), + testEq "(eq-AB @𝟎)‹𝟎,0› = (eq-AB 𝟎)" $ + equalE (extendDim "𝑖" empty) + (DCloE (Sub (^DApp (^F "eq-AB") (^BV 0)) (^BV 0 ::: ^K Zero ::: id))) + (^DApp (^F "eq-AB") (^BV 0)), + testNeq "(eq-AB 𝟎)‹0› ≠ (eq-AB 0)" $ + equalE (extendDim "𝑖" empty) + (DCloE (Sub (^DApp (^F "eq-AB") (^BV 0)) (^BV 0 ::: ^K Zero ::: id))) + (^DApp (^F "eq-AB") (^K Zero)), + testEq "𝟎‹0› = 𝟎 # term and dim vars distinct" $ + equalE + (extendTy Any "x" (^FT "A") empty) + (DCloE (Sub (^BV 0) (^K Zero ::: id))) (^BV 0), + testEq "a‹0› = a" $ + equalE empty + (DCloE (Sub (^F "a") (^K Zero ::: id))) (^F "a"), + testEq "(f a)‹0› = f‹0› a‹0›" $ + let th = ^K Zero ::: id in + equalE empty + (DCloE (Sub (^App (^F "f") (^FT "a")) th)) + (^App (DCloE (Sub (^F "f") th)) (DCloT (Sub (^FT "a") th))) ], "clashes" :- [ - testNeq "★₀ ≠ ★₀ ⇾ ★₀" $ - equalT empty (TYPE 1) (TYPE 0) (Arr Zero (TYPE 0) (TYPE 0)), - testEq "0=1 ⊢ ★₀ = ★₀ ⇾ ★₀" $ - equalT empty01 (TYPE 1) (TYPE 0) (Arr Zero (TYPE 0) (TYPE 0)), + testNeq "★₀ ≠ 0.★₀ → ★₀" $ + equalT empty (^TYPE 1) (^TYPE 0) (^Arr Zero (^TYPE 0) (^TYPE 0)), + testEq "0=1 ⊢ ★₀ = 0.★₀ → ★₀" $ + equalT empty01 (^TYPE 1) (^TYPE 0) (^Arr Zero (^TYPE 0) (^TYPE 0)), todo "others" ] ] diff --git a/tests/Tests/FromPTerm.idr b/tests/Tests/FromPTerm.idr index 91d861d..aecf622 100644 --- a/tests/Tests/FromPTerm.idr +++ b/tests/Tests/FromPTerm.idr @@ -4,8 +4,9 @@ import Quox.Parser.FromParser import Quox.Parser import TypingImpls import Tests.Parser as TParser -import TAP import Quox.EffExtra +import TAP +import AstExtra import System.File import Derive.Prelude @@ -49,6 +50,11 @@ parameters {c : Bool} {auto _ : Show b} parses : Test parses = parsesWith $ const True + %macro + parseMatch : TTImp -> Elab Test + parseMatch pat = + parsesWith <$> check `(\case ~(pat) => True; _ => False) + parsesAs : Eq b => b -> Test parsesAs exp = parsesWith (== exp) @@ -59,11 +65,9 @@ parameters {c : Bool} {auto _ : Show b} either (const $ Right ()) (Left . ExpectedFail . show) $ fromP pres -FromString PatVar where fromString x = PV x Nothing - runFromParser : {default empty defs : Definitions} -> Eff FromParserPure a -> Either FromParser.Error a -runFromParser = map fst . fromParserPure defs +runFromParser = map fst . fst . fromParserPure 0 defs export tests : Test @@ -72,30 +76,35 @@ tests = "PTerm → Term" :- [ let fromPDim = runFromParser . fromPDimWith [< "𝑖", "𝑗"] in [ note "dim ctx: [𝑖, 𝑗]", - parsesAs dim fromPDim "𝑖" (BV 1), - parsesAs dim fromPDim "𝑗" (BV 0), + parseMatch dim fromPDim "𝑖" `(B (VS VZ) _), + parseMatch dim fromPDim "𝑗" `(B VZ _), parseFails dim fromPDim "𝑘", - parsesAs dim fromPDim "0" (K Zero), - parsesAs dim fromPDim "1" (K One) + parseMatch dim fromPDim "0" `(K Zero _), + parseMatch dim fromPDim "1" `(K One _) ], "terms" :- - let defs = fromList [("f", mkDef gany Nat Zero)] + let defs = fromList [("f", mkDef gany (Nat noLoc) (Zero noLoc) noLoc)] -- doesn't have to be well typed yet, just well scoped fromPTerm = runFromParser {defs} . fromPTermWith [< "𝑖", "𝑗"] [< "A", "x", "y", "z"] in [ note "dim ctx: [𝑖, 𝑗]; term ctx: [A, x, y, z]", - parsesAs term fromPTerm "x" $ BVT 2, + parseMatch term fromPTerm "x" `(E $ B (VS $ VS VZ) _), parseFails term fromPTerm "𝑖", - parsesAs term fromPTerm "f" $ FT "f", - parsesAs term fromPTerm "λ w ⇒ w" $ [< "w"] :\\ BVT 0, - parsesAs term fromPTerm "λ w ⇒ x" $ [< "w"] :\\ BVT 3, - parsesAs term fromPTerm "λ x ⇒ x" $ [< "x"] :\\ BVT 0, - parsesAs term fromPTerm "λ a b ⇒ f a b" $ - [< "a", "b"] :\\ E (F "f" :@@ [BVT 1, BVT 0]), - parsesAs term fromPTerm "f @𝑖" $ - E $ F "f" :% BV 1 + parseMatch term fromPTerm "f" `(E $ F "f" _), + parseMatch term fromPTerm "λ w ⇒ w" + `(Lam (S _ $ Y $ E $ B VZ _) _), + parseMatch term fromPTerm "λ w ⇒ x" + `(Lam (S _ $ N $ E $ B (VS $ VS VZ) _) _), + parseMatch term fromPTerm "λ x ⇒ x" + `(Lam (S _ $ Y $ E $ B VZ _) _), + parseMatch term fromPTerm "λ a b ⇒ f a b" + `(Lam (S _ $ Y $ + Lam (S _ $ Y $ + E $ App (App (F "f" _) (E $ B (VS VZ) _) _) (E $ B VZ _) _) _) _), + parseMatch term fromPTerm "f @𝑖" $ + `(E $ DApp (F "f" _) (B (VS VZ) _) _) ], todo "everything else" diff --git a/tests/Tests/PrettyTerm.idr b/tests/Tests/PrettyTerm.idr index 3d8c921..324ac93 100644 --- a/tests/Tests/PrettyTerm.idr +++ b/tests/Tests/PrettyTerm.idr @@ -23,128 +23,179 @@ parameters (ds : NContext d) (ns : NContext n) {default str label : String} -> Test testPrettyE1 e str {label} = testPrettyT1 (E e) str {label} + +prefix 9 ^ +(^) : (Loc -> a) -> a +(^) a = a noLoc + +FromString BindName where fromString str = BN (fromString str) noLoc + + export tests : Test tests = "pretty printing terms" :- [ "free vars" :- [ - testPrettyE1 [<] [<] (F "x") "x", - testPrettyE1 [<] [<] (F $ MakeName [< "A", "B", "C"] "x") "A.B.C.x" + testPrettyE1 [<] [<] (^F "x") "x", + testPrettyE1 [<] [<] (^F (MakeName [< "A", "B", "C"] "x")) "A.B.C.x" ], "bound vars" :- [ - testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (BV 0) "y", - testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (BV 1) "x", - testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (F "eq" :% BV 1) "eq @𝑖", - testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (F "eq" :% BV 1 :% BV 0) "eq @𝑖 @𝑗" + testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (^BV 0) "y", + testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (^BV 1) "x", + testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] + (^DApp (^F "eq") (^BV 1)) + "eq @𝑖", + testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] + (^DApp (^DApp (^F "eq") (^BV 1)) (^BV 0)) + "eq @𝑖 @𝑗" ], "applications" :- [ - testPrettyE1 [<] [<] (F "f" :@ FT "x") "f x", - testPrettyE1 [<] [<] (F "f" :@@ [FT "x", FT "y"]) "f x y", - testPrettyE1 [<] [<] (F "f" :% K Zero) "f @0", - testPrettyE1 [<] [<] (F "f" :@ FT "x" :% K Zero) "f x @0", - testPrettyE1 [<] [<] (F "g" :% K One :@ FT "y") "g @1 y" + testPrettyE1 [<] [<] + (^App (^F "f") (^FT "x")) + "f x", + testPrettyE1 [<] [<] + (^App (^App (^F "f") (^FT "x")) (^FT "y")) + "f x y", + testPrettyE1 [<] [<] + (^DApp (^F "f") (^K Zero)) + "f @0", + testPrettyE1 [<] [<] + (^DApp (^App (^F "f") (^FT "x")) (^K Zero)) + "f x @0", + testPrettyE1 [<] [<] + (^App (^DApp (^F "g") (^K One)) (^FT "y")) + "g @1 y" ], "lambda" :- [ - testPrettyT [<] [<] ([< "x"] :\\ BVT 0) "λ x ⇒ x" "fun x => x", - testPrettyT [<] [<] (Lam $ SN $ FT "a") "λ _ ⇒ a" "fun _ => a", - testPrettyT [<] [< "y"] ([< "x"] :\\ BVT 1) "λ x ⇒ y" "fun x => y", testPrettyT [<] [<] - ([< "x", "y", "f"] :\\ E (BV 0 :@@ [BVT 2, BVT 1])) + (^LamY "x" (^BVT 0)) + "λ x ⇒ x" + "fun x => x", + testPrettyT [<] [<] + (^LamN (^FT "a")) + "λ _ ⇒ a" + "fun _ => a", + testPrettyT [<] [< "y"] + (^LamY "x" (^BVT 1)) + "λ x ⇒ y" + "fun x => y", + testPrettyT [<] [<] + (^LamY "x" (^LamY "y" (^LamY "f" + (E $ ^App (^App (^BV 0) (^BVT 2)) (^BVT 1))))) "λ x y f ⇒ f x y" "fun x y f => f x y", - testPrettyT [<] [<] (DLam $ SN $ FT "a") "δ _ ⇒ a" "dfun _ => a", - testPrettyT [<] [<] ([< "i"] :\\% FT "x") "δ i ⇒ x" "dfun i => x", testPrettyT [<] [<] - ([< "x"] :\\ [< "i"] :\\% E (BV 0 :% BV 0)) + (^DLam (SN (^FT "a"))) + "δ _ ⇒ a" + "dfun _ => a", + testPrettyT [<] [<] + (^DLamY "i" (^FT "x")) + "δ i ⇒ x" + "dfun i => x", + testPrettyT [<] [<] + (^LamY "x" (^DLamY "i" (E $ ^DApp (^BV 0) (^BV 0)))) "λ x ⇒ δ i ⇒ x @i" "fun x => dfun i => x @i" ], "type universes" :- [ - testPrettyT [<] [<] (TYPE 0) "★₀" "Type0", - testPrettyT [<] [<] (TYPE 100) "★₁₀₀" "Type100" + testPrettyT [<] [<] (^TYPE 0) "★₀" "Type0", + testPrettyT [<] [<] (^TYPE 100) "★₁₀₀" "Type100" ], "function types" :- [ - testPrettyT [<] [<] (Arr One (FT "A") (FT "B")) "1.A → B" "1.A -> B", testPrettyT [<] [<] - (PiY One "x" (FT "A") (E $ F "B" :@ BVT 0)) + (^Arr One (^FT "A") (^FT "B")) + "1.A → B" + "1.A -> B", + testPrettyT [<] [<] + (^PiY One "x" (^FT "A") (E $ ^App (^F "B") (^BVT 0))) "1.(x : A) → B x" "1.(x : A) -> B x", testPrettyT [<] [<] - (PiY Zero "A" (TYPE 0) $ Arr Any (BVT 0) (BVT 0)) + (^PiY Zero "A" (^TYPE 0) (^Arr Any (^BVT 0) (^BVT 0))) "0.(A : ★₀) → ω.A → A" "0.(A : Type0) -> #.A -> A", testPrettyT [<] [<] - (Arr Any (Arr Any (FT "A") (FT "A")) (FT "A")) + (^Arr Any (^Arr Any (^FT "A") (^FT "A")) (^FT "A")) "ω.(ω.A → A) → A" "#.(#.A -> A) -> A", testPrettyT [<] [<] - (Arr Any (FT "A") (Arr Any (FT "A") (FT "A"))) + (^Arr Any (^FT "A") (^Arr Any (^FT "A") (^FT "A"))) "ω.A → ω.A → A" "#.A -> #.A -> A", testPrettyT [<] [<] - (PiY Zero "P" (Arr Zero (FT "A") (TYPE 0)) (E $ BV 0 :@ FT "a")) + (^PiY Zero "P" (^Arr Zero (^FT "A") (^TYPE 0)) + (E $ ^App (^BV 0) (^FT "a"))) "0.(P : 0.A → ★₀) → P a" "0.(P : 0.A -> Type0) -> P a" ], "pair types" :- [ - testPrettyT [<] [<] (FT "A" `And` FT "B") "A × B" "A ** B", testPrettyT [<] [<] - (SigY "x" (FT "A") (E $ F "B" :@ BVT 0)) + (^And (^FT "A") (^FT "B")) + "A × B" + "A ** B", + testPrettyT [<] [<] + (^SigY "x" (^FT "A") (E $ ^App (^F "B") (^BVT 0))) "(x : A) × B x" "(x : A) ** B x", testPrettyT [<] [<] - (SigY "x" (FT "A") $ - SigY "y" (E $ F "B" :@ BVT 0) $ - E $ F "C" :@@ [BVT 1, BVT 0]) + (^SigY "x" (^FT "A") + (^SigY "y" (E $ ^App (^F "B") (^BVT 0)) + (E $ ^App (^App (^F "C") (^BVT 1)) (^BVT 0)))) "(x : A) × (y : B x) × C x y" "(x : A) ** (y : B x) ** C x y", todo "non-dependent, left and right nested" ], "pairs" :- [ - testPrettyT1 [<] [<] (Pair (FT "A") (FT "B")) "(A, B)", - testPrettyT1 [<] [<] (Pair (FT "A") (Pair (FT "B") (FT "C"))) "(A, B, C)", - testPrettyT1 [<] [<] (Pair (Pair (FT "A") (FT "B")) (FT "C")) "((A, B), C)", + testPrettyT1 [<] [<] + (^Pair (^FT "A") (^FT "B")) + "(A, B)", + testPrettyT1 [<] [<] + (^Pair (^FT "A") (^Pair (^FT "B") (^FT "C"))) + "(A, B, C)", + testPrettyT1 [<] [<] + (^Pair (^Pair (^FT "A") (^FT "B")) (^FT "C")) + "((A, B), C)", testPrettyT [<] [<] - (Pair ([< "x"] :\\ BVT 0) (Arr One (FT "B₁") (FT "B₂"))) + (^Pair (^LamY "x" (^BVT 0)) (^Arr One (^FT "B₁") (^FT "B₂"))) "(λ x ⇒ x, 1.B₁ → B₂)" "(fun x => x, 1.B₁ -> B₂)" ], "enum types" :- [ - testPrettyT1 [<] [<] (enum []) "{}", - testPrettyT1 [<] [<] (enum ["a"]) "{a}", - testPrettyT1 [<] [<] (enum ["aa", "bb", "cc"]) "{aa, bb, cc}", - testPrettyT1 [<] [<] (enum ["a b c"]) #"{"a b c"}"#, - testPrettyT1 [<] [<] (enum ["\"", ",", "\\"]) #" {"\"", ",", \} "# + testPrettyT1 [<] [<] (^enum []) "{}", + testPrettyT1 [<] [<] (^enum ["a"]) "{a}", + testPrettyT1 [<] [<] (^enum ["aa", "bb", "cc"]) "{aa, bb, cc}", + testPrettyT1 [<] [<] (^enum ["a b c"]) #"{"a b c"}"#, + testPrettyT1 [<] [<] (^enum ["\"", ",", "\\"]) #" {"\"", ",", \} "# {label = #"{"\"", ",", \} # ｢\｣ is an identifier"#} ], "tags" :- [ - testPrettyT1 [<] [<] (Tag "a") "'a", - testPrettyT1 [<] [<] (Tag "hello") "'hello", - testPrettyT1 [<] [<] (Tag "qualified.tag") "'qualified.tag", - testPrettyT1 [<] [<] (Tag "non-identifier tag") #"'"non-identifier tag""#, - testPrettyT1 [<] [<] (Tag #"""#) #" '"\"" "# + testPrettyT1 [<] [<] (^Tag "a") "'a", + testPrettyT1 [<] [<] (^Tag "hello") "'hello", + testPrettyT1 [<] [<] (^Tag "qualified.tag") "'qualified.tag", + testPrettyT1 [<] [<] (^Tag "non-identifier tag") #"'"non-identifier tag""#, + testPrettyT1 [<] [<] (^Tag #"""#) #" '"\"" "# ], todo "equality types", "case" :- [ testPrettyE [<] [<] - (CasePair One (F "a") (SN $ TYPE 1) (SN $ TYPE 0)) + (^CasePair One (^F "a") (SN $ ^TYPE 1) (SN $ ^TYPE 0)) "case1 a return ★₁ of { (_, _) ⇒ ★₀ }" "case1 a return Type1 of { (_, _) => Type0 }", testPrettyT [<] [<] - ([< "u"] :\\ - E (CaseEnum One (F "u") - (SY [< "x"] $ Eq0 (enum ["tt"]) (BVT 0) (Tag "tt")) - (fromList [("tt", [< Unused] :\\% Tag "tt")]))) + (^LamY "u" (E $ + ^CaseEnum One (^F "u") + (SY [< "x"] $ ^Eq0 (^enum ["tt"]) (^BVT 0) (^Tag "tt")) + (fromList [("tt", ^DLamN (^Tag "tt"))]))) "λ u ⇒ case1 u return x ⇒ x ≡ 'tt : {tt} of { 'tt ⇒ δ _ ⇒ 'tt }" """ fun u => @@ -155,27 +206,30 @@ tests = "pretty printing terms" :- [ "type-case" :- [ testPrettyE [<] [<] {label = "type-case ℕ ∷ ★₀ return ★₀ of { ⋯ }"} - (TypeCase (Nat :# TYPE 0) (TYPE 0) empty Nat) + (^TypeCase (^Ann (^Nat) (^TYPE 0)) (^TYPE 0) empty (^Nat)) "type-case ℕ ∷ ★₀ return ★₀ of { _ ⇒ ℕ }" "type-case Nat :: Type0 return Type0 of { _ => Nat }" ], "annotations" :- [ - testPrettyE [<] [<] (FT "a" :# FT "A") "a ∷ A" "a :: A", testPrettyE [<] [<] - (FT "a" :# E (FT "A" :# FT "𝐀")) + (^Ann (^FT "a") (^FT "A")) + "a ∷ A" + "a :: A", + testPrettyE [<] [<] + (^Ann (^FT "a") (E $ ^Ann (^FT "A") (^FT "𝐀"))) "a ∷ A ∷ 𝐀" "a :: A :: 𝐀", testPrettyE [<] [<] - (E (FT "α" :# FT "a") :# FT "A") + (^Ann (E $ ^Ann (^FT "α") (^FT "a")) (^FT "A")) "(α ∷ a) ∷ A" "(α :: a) :: A", testPrettyE [<] [<] - (([< "x"] :\\ BVT 0) :# Arr One (FT "A") (FT "A")) + (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A"))) "(λ x ⇒ x) ∷ 1.A → A" "(fun x => x) :: 1.A -> A", testPrettyE [<] [<] - (Arr One (FT "A") (FT "A") :# TYPE 7) + (^Ann (^Arr One (^FT "A") (^FT "A")) (^TYPE 7)) "(1.A → A) ∷ ★₇" "(1.A -> A) :: Type7" ] diff --git a/tests/Tests/Reduce.idr b/tests/Tests/Reduce.idr index 3f20f3a..b81d564 100644 --- a/tests/Tests/Reduce.idr +++ b/tests/Tests/Reduce.idr @@ -3,7 +3,12 @@ module Tests.Reduce import Quox.Syntax as Lib import Quox.Equal import TypingImpls +import AstExtra import TAP +import Control.Eff + +%hide Prelude.App +%hide Pretty.App parameters {0 isRedex : RedexTest tm} {auto _ : Whnf tm isRedex} {d, n : Nat} @@ -12,7 +17,7 @@ parameters {0 isRedex : RedexTest tm} {auto _ : Whnf tm isRedex} {d, n : Nat} private testWhnf : String -> WhnfContext d n -> tm d n -> tm d n -> Test testWhnf label ctx from to = test "\{label} (whnf)" $ do - result <- bimap toInfo fst $ whnf defs ctx from + result <- mapFst toInfo $ runWhnf $ whnf0 defs ctx from unless (result == to) $ Left [("exp", show to), ("got", show result)] private @@ -20,7 +25,7 @@ parameters {0 isRedex : RedexTest tm} {auto _ : Whnf tm isRedex} {d, n : Nat} testNoStep label ctx e = testWhnf label ctx e e private -ctx : Context (\n => (BaseName, Term 0 n)) n -> WhnfContext 0 n +ctx : Context (\n => (BindName, Term 0 n)) n -> WhnfContext 0 n ctx xs = let (ns, ts) = unzip xs in MkWhnfContext [<] ns ts @@ -28,91 +33,101 @@ export tests : Test tests = "whnf" :- [ "head constructors" :- [ - testNoStep "★₀" empty $ TYPE 0, - testNoStep "[A] ⊸ [B]" empty $ - Arr One (FT "A") (FT "B"), - testNoStep "(x: [A]) ⊸ [B [x]]" empty $ - Pi One (FT "A") (S [< "x"] $ Y $ E $ F "B" :@ BVT 0), - testNoStep "λx. [x]" empty $ - Lam $ S [< "x"] $ Y $ BVT 0, - testNoStep "[f [a]]" empty $ - E $ F "f" :@ FT "a" + testNoStep "★₀" empty $ ^TYPE 0, + testNoStep "1.A → B" empty $ + ^Arr One (^FT "A") (^FT "B"), + testNoStep "(x: A) ⊸ B x" empty $ + ^PiY One "x" (^FT "A") (E $ ^App (^F "B") (^BVT 0)), + testNoStep "λ x ⇒ x" empty $ + ^LamY "x" (^BVT 0), + testNoStep "f a" empty $ + E $ ^App (^F "f") (^FT "a") ], "neutrals" :- [ - testNoStep "x" (ctx [< ("A", Nat)]) $ BV 0, - testNoStep "a" empty $ F "a", - testNoStep "f [a]" empty $ F "f" :@ FT "a", - testNoStep "★₀ ∷ ★₁" empty $ TYPE 0 :# TYPE 1 + testNoStep "x" (ctx [< ("A", ^Nat)]) $ ^BV 0, + testNoStep "a" empty $ ^F "a", + testNoStep "f a" empty $ ^App (^F "f") (^FT "a"), + testNoStep "★₀ ∷ ★₁" empty $ ^Ann (^TYPE 0) (^TYPE 1) ], "redexes" :- [ - testWhnf "[a] ∷ [A]" empty - (FT "a" :# FT "A") - (F "a"), - testWhnf "[★₁ ∷ ★₃]" empty - (E (TYPE 1 :# TYPE 3)) - (TYPE 1), - testWhnf "(λx. [x] ∷ [A] ⊸ [A]) [a]" empty - ((([< "x"] :\\ BVT 0) :# Arr One (FT "A") (FT "A")) :@ FT "a") - (F "a") + testWhnf "a ∷ A" empty + (^Ann (^FT "a") (^FT "A")) + (^F "a"), + testWhnf "★₁ ∷ ★₃" empty + (E $ ^Ann (^TYPE 1) (^TYPE 3)) + (^TYPE 1), + testWhnf "(λ x ⇒ x ∷ 1.A → A) a" empty + (^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A"))) + (^FT "a")) + (^F "a") ], "definitions" :- [ testWhnf "a (transparent)" empty - {defs = fromList [("a", mkDef gzero (TYPE 1) (TYPE 0))]} - (F "a") (TYPE 0 :# TYPE 1) + {defs = fromList [("a", ^mkDef gzero (^TYPE 1) (^TYPE 0))]} + (^F "a") (^Ann (^TYPE 0) (^TYPE 1)), + testNoStep "a (opaque)" empty + {defs = fromList [("a", ^mkPostulate gzero (^TYPE 1))]} + (^F "a") ], "elim closure" :- [ - testWhnf "x{}" (ctx [< ("A", Nat)]) - (CloE (Sub (BV 0) id)) - (BV 0), + testWhnf "x{}" (ctx [< ("x", ^Nat)]) + (CloE (Sub (^BV 0) id)) + (^BV 0), testWhnf "x{a/x}" empty - (CloE (Sub (BV 0) (F "a" ::: id))) - (F "a"), - testWhnf "x{x/x,a/y}" (ctx [< ("A", Nat)]) - (CloE (Sub (BV 0) (BV 0 ::: F "a" ::: id))) - (BV 0), + (CloE (Sub (^BV 0) (^F "a" ::: id))) + (^F "a"), + testWhnf "x{a/y}" (ctx [< ("x", ^Nat)]) + (CloE (Sub (^BV 0) (^BV 0 ::: ^F "a" ::: id))) + (^BV 0), testWhnf "x{(y{a/y})/x}" empty - (CloE (Sub (BV 0) ((CloE (Sub (BV 0) (F "a" ::: id))) ::: id))) - (F "a"), + (CloE (Sub (^BV 0) ((CloE (Sub (^BV 0) (^F "a" ::: id))) ::: id))) + (^F "a"), testWhnf "(x y){f/x,a/y}" empty - (CloE (Sub (BV 0 :@ BVT 1) (F "f" ::: F "a" ::: id))) - (F "f" :@ FT "a"), - testWhnf "([y] ∷ [x]){A/x}" (ctx [< ("A", Nat)]) - (CloE (Sub (BVT 1 :# BVT 0) (F "A" ::: id))) - (BV 0), - testWhnf "([y] ∷ [x]){A/x,a/y}" empty - (CloE (Sub (BVT 1 :# BVT 0) (F "A" ::: F "a" ::: id))) - (F "a") + (CloE (Sub (^App (^BV 0) (^BVT 1)) (^F "f" ::: ^F "a" ::: id))) + (^App (^F "f") (^FT "a")), + testWhnf "(y ∷ x){A/x}" (ctx [< ("x", ^Nat)]) + (CloE (Sub (^Ann (^BVT 1) (^BVT 0)) (^F "A" ::: id))) + (^BV 0), + testWhnf "(y ∷ x){A/x,a/y}" empty + (CloE (Sub (^Ann (^BVT 1) (^BVT 0)) (^F "A" ::: ^F "a" ::: id))) + (^F "a") ], "term closure" :- [ - testWhnf "(λy. x){a/x}" empty - (CloT (Sub (Lam $ S [< "y"] $ N $ BVT 0) (F "a" ::: id))) - (Lam $ S [< "y"] $ N $ FT "a"), + testWhnf "(λ y ⇒ x){a/x}" empty + (CloT (Sub (^LamN (^BVT 0)) (^F "a" ::: id))) + (^LamN (^FT "a")), testWhnf "(λy. y){a/x}" empty - (CloT (Sub ([< "y"] :\\ BVT 0) (F "a" ::: id))) - ([< "y"] :\\ BVT 0) + (CloT (Sub (^LamY "y" (^BVT 0)) (^F "a" ::: id))) + (^LamY "y" (^BVT 0)) ], - "looking inside […]" :- [ - testWhnf "[(λx. x ∷ A ⊸ A) [a]]" empty - (E $ (([< "x"] :\\ BVT 0) :# Arr One (FT "A") (FT "A")) :@ FT "a") - (FT "a") + "looking inside `E`" :- [ + testWhnf "(λx. x ∷ A ⊸ A) a" empty + (E $ ^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A"))) + (^FT "a")) + (^FT "a") ], "nested redex" :- [ - note "whnf only looks at top level redexes", - testNoStep "λy. [(λx. [x] ∷ [A] ⊸ [A]) [y]]" empty $ - [< "y"] :\\ E ((([< "x"] :\\ BVT 0) :# Arr One (FT "A") (FT "A")) :@ BVT 0), - testNoStep "f [(λx. [x] ∷ [A] ⊸ [A]) [a]]" empty $ - F "a" :@ - E ((([< "x"] :\\ BVT 0) :# Arr One (FT "A") (FT "A")) :@ FT "a"), - testNoStep "λx. [y [x]]{x/x,a/y}" (ctx [< ("A", Nat)]) $ - [< "x"] :\\ CloT (Sub (E $ BV 1 :@ BVT 0) (BV 0 ::: F "a" ::: id)), - testNoStep "f ([y [x]]{x/x,a/y})" (ctx [< ("A", Nat)]) $ - F "f" :@ CloT (Sub (E $ BV 1 :@ BVT 0) (BV 0 ::: F "a" ::: id)) + testNoStep "λ y ⇒ ((λ x ⇒ x) ∷ 1.A → A) y" empty $ + ^LamY "y" (E $ + ^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A"))) + (^BVT 0)), + testNoStep "f (((λ x ⇒ x) ∷ 1.A → A) a)" empty $ + ^App (^F "f") + (E $ ^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A"))) + (^FT "a")), + testNoStep "λx. (y x){x/x,a/y}" (ctx [< ("y", ^Nat)]) $ + ^LamY "x" (CloT $ Sub (E $ ^App (^BV 1) (^BVT 0)) + (^BV 0 ::: ^F "a" ::: id)), + testNoStep "f (y x){x/x,a/y}" (ctx [< ("y", ^Nat)]) $ + ^App (^F "f") + (CloT (Sub (E $ ^App (^BV 1) (^BVT 0)) + (^BV 0 ::: ^F "a" ::: id))) ] ] diff --git a/tests/Tests/Typechecker.idr b/tests/Tests/Typechecker.idr index 370862d..e4a1f4a 100644 --- a/tests/Tests/Typechecker.idr +++ b/tests/Tests/Typechecker.idr @@ -5,6 +5,11 @@ import Quox.Typechecker as Lib import public TypingImpls import TAP import Quox.EffExtra +import AstExtra + + +%hide Prelude.App +%hide Pretty.App data Error' @@ -28,64 +33,75 @@ ToInfo Error' where M = Eff [Except Error', DefsReader] inj : TC a -> M a -inj = rethrow . mapFst TCError <=< lift . runExcept +inj act = rethrow $ mapFst TCError $ runTC !defs act reflTy : Term d n reflTy = - PiY Zero "A" (TYPE 0) $ - PiY One "x" (BVT 0) $ - Eq0 (BVT 1) (BVT 0) (BVT 0) + ^PiY Zero "A" (^TYPE 0) + (^PiY One "x" (^BVT 0) + (^Eq0 (^BVT 1) (^BVT 0) (^BVT 0))) reflDef : Term d n -reflDef = [< "A","x"] :\\ [< "i"] :\\% BVT 0 +reflDef = ^LamY "A" (^LamY "x" (^DLamY "i" (^BVT 0))) fstTy : Term d n fstTy = - (PiY Zero "A" (TYPE 1) $ - PiY Zero "B" (Arr Any (BVT 0) (TYPE 1)) $ - Arr Any (SigY "x" (BVT 1) $ E $ BV 1 :@ BVT 0) (BVT 1)) + ^PiY Zero "A" (^TYPE 1) + (^PiY Zero "B" (^Arr Any (^BVT 0) (^TYPE 1)) + (^Arr Any (^SigY "x" (^BVT 1) (E $ ^App (^BV 1) (^BVT 0))) (^BVT 1))) fstDef : Term d n fstDef = - ([< "A","B","p"] :\\ - E (CasePair Any (BV 0) (SN $ BVT 2) (SY [< "x","y"] $ BVT 1))) + ^LamY "A" (^LamY "B" (^LamY "p" + (E $ ^CasePair Any (^BV 0) (SN $ ^BVT 2) + (SY [< "x", "y"] $ ^BVT 1)))) sndTy : Term d n sndTy = - (PiY Zero "A" (TYPE 1) $ - PiY Zero "B" (Arr Any (BVT 0) (TYPE 1)) $ - PiY Any "p" (SigY "x" (BVT 1) $ E $ BV 1 :@ BVT 0) $ - E (BV 1 :@ E (F "fst" :@@ [BVT 2, BVT 1, BVT 0]))) + ^PiY Zero "A" (^TYPE 1) + (^PiY Zero "B" (^Arr Any (^BVT 0) (^TYPE 1)) + (^PiY Any "p" (^SigY "x" (^BVT 1) (E $ ^App (^BV 1) (^BVT 0))) + (E $ ^App (^BV 1) + (E $ ^App (^App (^App (^F "fst") (^BVT 2)) (^BVT 1)) (^BVT 0))))) sndDef : Term d n sndDef = - ([< "A","B","p"] :\\ - E (CasePair Any (BV 0) - (SY [< "p"] $ E $ BV 2 :@ E (F "fst" :@@ [BVT 3, BVT 2, BVT 0])) - (SY [< "x","y"] $ BVT 0))) + -- λ A B p ⇒ caseω p return p' ⇒ B (fst A B p') of { (x, y) ⇒ y } + ^LamY "A" (^LamY "B" (^LamY "p" + (E $ ^CasePair Any (^BV 0) + (SY [< "p"] $ E $ + ^App (^BV 2) + (E $ ^App (^App (^App (^F "fst") (^BVT 3)) (^BVT 2)) (^BVT 0))) + (SY [< "x", "y"] $ ^BVT 0)))) + +nat : Term d n +nat = ^Nat defGlobals : Definitions defGlobals = fromList - [("A", mkPostulate gzero $ TYPE 0), - ("B", mkPostulate gzero $ TYPE 0), - ("C", mkPostulate gzero $ TYPE 1), - ("D", mkPostulate gzero $ TYPE 1), - ("P", mkPostulate gzero $ Arr Any (FT "A") (TYPE 0)), - ("a", mkPostulate gany $ FT "A"), - ("a'", mkPostulate gany $ FT "A"), - ("b", mkPostulate gany $ FT "B"), - ("f", mkPostulate gany $ Arr One (FT "A") (FT "A")), - ("fω", mkPostulate gany $ Arr Any (FT "A") (FT "A")), - ("g", mkPostulate gany $ Arr One (FT "A") (FT "B")), - ("f2", mkPostulate gany $ Arr One (FT "A") $ Arr One (FT "A") (FT "B")), - ("p", mkPostulate gany $ PiY One "x" (FT "A") $ E $ F "P" :@ BVT 0), - ("q", mkPostulate gany $ PiY One "x" (FT "A") $ E $ F "P" :@ BVT 0), - ("refl", mkDef gany reflTy reflDef), - ("fst", mkDef gany fstTy fstDef), - ("snd", mkDef gany sndTy sndDef)] + [("A", ^mkPostulate gzero (^TYPE 0)), + ("B", ^mkPostulate gzero (^TYPE 0)), + ("C", ^mkPostulate gzero (^TYPE 1)), + ("D", ^mkPostulate gzero (^TYPE 1)), + ("P", ^mkPostulate gzero (^Arr Any (^FT "A") (^TYPE 0))), + ("a", ^mkPostulate gany (^FT "A")), + ("a'", ^mkPostulate gany (^FT "A")), + ("b", ^mkPostulate gany (^FT "B")), + ("f", ^mkPostulate gany (^Arr One (^FT "A") (^FT "A"))), + ("fω", ^mkPostulate gany (^Arr Any (^FT "A") (^FT "A"))), + ("g", ^mkPostulate gany (^Arr One (^FT "A") (^FT "B"))), + ("f2", ^mkPostulate gany + (^Arr One (^FT "A") (^Arr One (^FT "A") (^FT "B")))), + ("p", ^mkPostulate gany + (^PiY One "x" (^FT "A") (E $ ^App (^F "P") (^BVT 0)))), + ("q", ^mkPostulate gany + (^PiY One "x" (^FT "A") (E $ ^App (^F "P") (^BVT 0)))), + ("refl", ^mkDef gany reflTy reflDef), + ("fst", ^mkDef gany fstTy fstDef), + ("snd", ^mkDef gany sndTy sndDef)] parameters (label : String) (act : Lazy (M ())) {default defGlobals globals : Definitions} @@ -98,23 +114,10 @@ parameters (label : String) (act : Lazy (M ())) (extract $ runExcept $ runReaderAt DEFS globals act) $> "()" -anys : {n : Nat} -> QContext n -anys {n = 0} = [<] -anys {n = S n} = anys :< Any - -ctx, ctx01 : {n : Nat} -> Context (\n => (BaseName, Term 0 n)) n -> - TyContext 0 n -ctx tel = let (ns, ts) = unzip tel in - MkTyContext new [<] ts ns anys -ctx01 tel = let (ns, ts) = unzip tel in - MkTyContext ZeroIsOne [<] ts ns anys - -empty01 : TyContext 0 0 -empty01 = eqDim (K Zero) (K One) empty - inferredTypeEq : TyContext d n -> (exp, got : Term d n) -> M () inferredTypeEq ctx exp got = - wrapErr (const $ WrongInfer exp got) $ inj $ equalType ctx exp got + wrapErr (const $ WrongInfer exp got) $ inj $ lift $ + equalType noLoc ctx exp got qoutEq : (exp, got : QOutput n) -> M () qoutEq qout res = unless (qout == res) $ throw $ WrongQOut qout res @@ -156,153 +159,168 @@ tests : Test tests = "typechecker" :- [ "universes" :- [ testTC "0 · ★₀ ⇐ ★₁ # by checkType" $ - checkType_ empty (TYPE 0) (Just 1), + checkType_ empty (^TYPE 0) (Just 1), testTC "0 · ★₀ ⇐ ★₁ # by check" $ - check_ empty szero (TYPE 0) (TYPE 1), + check_ empty szero (^TYPE 0) (^TYPE 1), testTC "0 · ★₀ ⇐ ★₂" $ - checkType_ empty (TYPE 0) (Just 2), + checkType_ empty (^TYPE 0) (Just 2), testTC "0 · ★₀ ⇐ ★_" $ - checkType_ empty (TYPE 0) Nothing, + checkType_ empty (^TYPE 0) Nothing, testTCFail "0 · ★₁ ⇍ ★₀" $ - checkType_ empty (TYPE 1) (Just 0), + checkType_ empty (^TYPE 1) (Just 0), testTCFail "0 · ★₀ ⇍ ★₀" $ - checkType_ empty (TYPE 0) (Just 0), + checkType_ empty (^TYPE 0) (Just 0), testTC "0=1 ⊢ 0 · ★₁ ⇐ ★₀" $ - checkType_ empty01 (TYPE 1) (Just 0), + checkType_ empty01 (^TYPE 1) (Just 0), testTCFail "1 · ★₀ ⇍ ★₁ # by check" $ - check_ empty sone (TYPE 0) (TYPE 1) + check_ empty sone (^TYPE 0) (^TYPE 1) ], "function types" :- [ - note "A, B : ★₀; C, D : ★₁; P : A ⇾ ★₀", - testTC "0 · A ⊸ B ⇐ ★₀" $ - check_ empty szero (Arr One (FT "A") (FT "B")) (TYPE 0), + note "A, B : ★₀; C, D : ★₁; P : 0.A → ★₀", + testTC "0 · 1.A → B ⇐ ★₀" $ + check_ empty szero (^Arr One (^FT "A") (^FT "B")) (^TYPE 0), note "subtyping", - testTC "0 · A ⊸ B ⇐ ★₁" $ - check_ empty szero (Arr One (FT "A") (FT "B")) (TYPE 1), - testTC "0 · C ⊸ D ⇐ ★₁" $ - check_ empty szero (Arr One (FT "C") (FT "D")) (TYPE 1), - testTCFail "0 · C ⊸ D ⇍ ★₀" $ - check_ empty szero (Arr One (FT "C") (FT "D")) (TYPE 0), - testTC "0 · (1·x : A) → P x ⇐ ★₀" $ + testTC "0 · 1.A → B ⇐ ★₁" $ + check_ empty szero (^Arr One (^FT "A") (^FT "B")) (^TYPE 1), + testTC "0 · 1.C → D ⇐ ★₁" $ + check_ empty szero (^Arr One (^FT "C") (^FT "D")) (^TYPE 1), + testTCFail "0 · 1.C → D ⇍ ★₀" $ + check_ empty szero (^Arr One (^FT "C") (^FT "D")) (^TYPE 0), + testTC "0 · 1.(x : A) → P x ⇐ ★₀" $ check_ empty szero - (PiY One "x" (FT "A") $ E $ F "P" :@ BVT 0) - (TYPE 0), - testTCFail "0 · A ⊸ P ⇍ ★₀" $ - check_ empty szero (Arr One (FT "A") $ FT "P") (TYPE 0), - testTC "0=1 ⊢ 0 · A ⊸ P ⇐ ★₀" $ - check_ empty01 szero (Arr One (FT "A") $ FT "P") (TYPE 0) + (^PiY One "x" (^FT "A") (E $ ^App (^F "P") (^BVT 0))) + (^TYPE 0), + testTCFail "0 · 1.A → P ⇍ ★₀" $ + check_ empty szero (^Arr One (^FT "A") (^FT "P")) (^TYPE 0), + testTC "0=1 ⊢ 0 · 1.A → P ⇐ ★₀" $ + check_ empty01 szero (^Arr One (^FT "A") (^FT "P")) (^TYPE 0) ], "pair types" :- [ - note #""A × B" for "(_ : A) × B""#, testTC "0 · A × A ⇐ ★₀" $ - check_ empty szero (FT "A" `And` FT "A") (TYPE 0), + check_ empty szero (^And (^FT "A") (^FT "A")) (^TYPE 0), testTCFail "0 · A × P ⇍ ★₀" $ - check_ empty szero (FT "A" `And` FT "P") (TYPE 0), + check_ empty szero (^And (^FT "A") (^FT "P")) (^TYPE 0), testTC "0 · (x : A) × P x ⇐ ★₀" $ check_ empty szero - (SigY "x" (FT "A") $ E $ F "P" :@ BVT 0) (TYPE 0), + (^SigY "x" (^FT "A") (E $ ^App (^F "P") (^BVT 0))) + (^TYPE 0), testTC "0 · (x : A) × P x ⇐ ★₁" $ check_ empty szero - (SigY "x" (FT "A") $ E $ F "P" :@ BVT 0) (TYPE 1), + (^SigY "x" (^FT "A") (E $ ^App (^F "P") (^BVT 0))) + (^TYPE 1), testTC "0 · (A : ★₀) × A ⇐ ★₁" $ - check_ empty szero (SigY "A" (TYPE 0) $ BVT 0) (TYPE 1), + check_ empty szero + (^SigY "A" (^TYPE 0) (^BVT 0)) + (^TYPE 1), testTCFail "0 · (A : ★₀) × A ⇍ ★₀" $ - check_ empty szero (SigY "A" (TYPE 0) $ BVT 0) (TYPE 0), + check_ empty szero + (^SigY "A" (^TYPE 0) (^BVT 0)) + (^TYPE 0), testTCFail "1 · A × A ⇍ ★₀" $ - check_ empty sone (FT "A" `And` FT "A") (TYPE 0) + check_ empty sone + (^And (^FT "A") (^FT "A")) + (^TYPE 0) ], "enum types" :- [ - testTC "0 · {} ⇐ ★₀" $ check_ empty szero (enum []) (TYPE 0), - testTC "0 · {} ⇐ ★₃" $ check_ empty szero (enum []) (TYPE 3), + testTC "0 · {} ⇐ ★₀" $ check_ empty szero (^enum []) (^TYPE 0), + testTC "0 · {} ⇐ ★₃" $ check_ empty szero (^enum []) (^TYPE 3), testTC "0 · {a,b,c} ⇐ ★₀" $ - check_ empty szero (enum ["a", "b", "c"]) (TYPE 0), + check_ empty szero (^enum ["a", "b", "c"]) (^TYPE 0), testTC "0 · {a,b,c} ⇐ ★₃" $ - check_ empty szero (enum ["a", "b", "c"]) (TYPE 3), - testTCFail "1 · {} ⇍ ★₀" $ check_ empty sone (enum []) (TYPE 0), - testTC "0=1 ⊢ 1 · {} ⇐ ★₀" $ check_ empty01 sone (enum []) (TYPE 0) + check_ empty szero (^enum ["a", "b", "c"]) (^TYPE 3), + testTCFail "1 · {} ⇍ ★₀" $ check_ empty sone (^enum []) (^TYPE 0), + testTC "0=1 ⊢ 1 · {} ⇐ ★₀" $ check_ empty01 sone (^enum []) (^TYPE 0) ], "free vars" :- [ note "A : ★₀", testTC "0 · A ⇒ ★₀" $ - inferAs empty szero (F "A") (TYPE 0), + inferAs empty szero (^F "A") (^TYPE 0), testTC "0 · [A] ⇐ ★₀" $ - check_ empty szero (FT "A") (TYPE 0), + check_ empty szero (^FT "A") (^TYPE 0), note "subtyping", testTC "0 · [A] ⇐ ★₁" $ - check_ empty szero (FT "A") (TYPE 1), + check_ empty szero (^FT "A") (^TYPE 1), note "(fail) runtime-relevant type", testTCFail "1 · A ⇏ ★₀" $ - infer_ empty sone (F "A"), + infer_ empty sone (^F "A"), testTC "1 . f ⇒ 1.A → A" $ - inferAs empty sone (F "f") (Arr One (FT "A") (FT "A")), + inferAs empty sone (^F "f") (^Arr One (^FT "A") (^FT "A")), testTC "1 . f ⇐ 1.A → A" $ - check_ empty sone (FT "f") (Arr One (FT "A") (FT "A")), + check_ empty sone (^FT "f") (^Arr One (^FT "A") (^FT "A")), testTCFail "1 . f ⇍ 0.A → A" $ - check_ empty sone (FT "f") (Arr Zero (FT "A") (FT "A")), + check_ empty sone (^FT "f") (^Arr Zero (^FT "A") (^FT "A")), testTCFail "1 . f ⇍ ω.A → A" $ - check_ empty sone (FT "f") (Arr Any (FT "A") (FT "A")), + check_ empty sone (^FT "f") (^Arr Any (^FT "A") (^FT "A")), testTC "1 . (λ x ⇒ f x) ⇐ 1.A → A" $ check_ empty sone - ([< "x"] :\\ E (F "f" :@ BVT 0)) - (Arr One (FT "A") (FT "A")), + (^LamY "x" (E $ ^App (^F "f") (^BVT 0))) + (^Arr One (^FT "A") (^FT "A")), testTC "1 . (λ x ⇒ f x) ⇐ ω.A → A" $ check_ empty sone - ([< "x"] :\\ E (F "f" :@ BVT 0)) - (Arr Any (FT "A") (FT "A")), + (^LamY "x" (E $ ^App (^F "f") (^BVT 0))) + (^Arr Any (^FT "A") (^FT "A")), testTCFail "1 . (λ x ⇒ f x) ⇍ 0.A → A" $ check_ empty sone - ([< "x"] :\\ E (F "f" :@ BVT 0)) - (Arr Zero (FT "A") (FT "A")), + (^LamY "x" (E $ ^App (^F "f") (^BVT 0))) + (^Arr Zero (^FT "A") (^FT "A")), testTC "1 . fω ⇒ ω.A → A" $ - inferAs empty sone (F "fω") (Arr Any (FT "A") (FT "A")), + inferAs empty sone (^F "fω") (^Arr Any (^FT "A") (^FT "A")), testTC "1 . (λ x ⇒ fω x) ⇐ ω.A → A" $ check_ empty sone - ([< "x"] :\\ E (F "fω" :@ BVT 0)) - (Arr Any (FT "A") (FT "A")), + (^LamY "x" (E $ ^App (^F "fω") (^BVT 0))) + (^Arr Any (^FT "A") (^FT "A")), testTCFail "1 . (λ x ⇒ fω x) ⇍ 0.A → A" $ check_ empty sone - ([< "x"] :\\ E (F "fω" :@ BVT 0)) - (Arr Zero (FT "A") (FT "A")), + (^LamY "x" (E $ ^App (^F "fω") (^BVT 0))) + (^Arr Zero (^FT "A") (^FT "A")), testTCFail "1 . (λ x ⇒ fω x) ⇍ 1.A → A" $ check_ empty sone - ([< "x"] :\\ E (F "fω" :@ BVT 0)) - (Arr One (FT "A") (FT "A")), + (^LamY "x" (E $ ^App (^F "fω") (^BVT 0))) + (^Arr One (^FT "A") (^FT "A")), note "refl : (0·A : ★₀) → (1·x : A) → (x ≡ x : A) ≔ (λ A x ⇒ δ _ ⇒ x)", - testTC "1 · refl ⇒ ⋯" $ inferAs empty sone (F "refl") reflTy, - testTC "1 · [refl] ⇐ ⋯" $ check_ empty sone (FT "refl") reflTy + testTC "1 · refl ⇒ ⋯" $ inferAs empty sone (^F "refl") reflTy, + testTC "1 · [refl] ⇐ ⋯" $ check_ empty sone (^FT "refl") reflTy ], "bound vars" :- [ testTC "x : A ⊢ 1 · x ⇒ A ⊳ 1·x" $ - inferAsQ {n = 1} (ctx [< ("x", FT "A")]) sone - (BV 0) (FT "A") [< One], - testTC "x : A ⊢ 1 · [x] ⇐ A ⊳ 1·x" $ - checkQ {n = 1} (ctx [< ("x", FT "A")]) sone (BVT 0) (FT "A") [< One], - note "f2 : A ⊸ A ⊸ B", - testTC "x : A ⊢ 1 · f2 [x] [x] ⇒ B ⊳ ω·x" $ - inferAsQ {n = 1} (ctx [< ("x", FT "A")]) sone - (F "f2" :@@ [BVT 0, BVT 0]) (FT "B") [< Any] + inferAsQ (ctx [< ("x", ^FT "A")]) sone + (^BV 0) (^FT "A") [< One], + testTC "x : A ⊢ 1 · x ⇐ A ⊳ 1·x" $ + checkQ (ctx [< ("x", ^FT "A")]) sone (^BVT 0) (^FT "A") [< One], + note "f2 : 1.A → 1.A → B", + testTC "x : A ⊢ 1 · f2 x x ⇒ B ⊳ ω·x" $ + inferAsQ (ctx [< ("x", ^FT "A")]) sone + (^App (^App (^F "f2") (^BVT 0)) (^BVT 0)) (^FT "B") [< Any] ], "lambda" :- [ note "linear & unrestricted identity", - testTC "1 · (λ x ⇒ x) ⇐ A ⊸ A" $ - check_ empty sone ([< "x"] :\\ BVT 0) (Arr One (FT "A") (FT "A")), testTC "1 · (λ x ⇒ x) ⇐ A → A" $ - check_ empty sone ([< "x"] :\\ BVT 0) (Arr Any (FT "A") (FT "A")), + check_ empty sone + (^LamY "x" (^BVT 0)) + (^Arr One (^FT "A") (^FT "A")), + testTC "1 · (λ x ⇒ x) ⇐ ω.A → A" $ + check_ empty sone + (^LamY "x" (^BVT 0)) + (^Arr Any (^FT "A") (^FT "A")), note "(fail) zero binding used relevantly", - testTCFail "1 · (λ x ⇒ x) ⇍ A ⇾ A" $ - check_ empty sone ([< "x"] :\\ BVT 0) (Arr Zero (FT "A") (FT "A")), + testTCFail "1 · (λ x ⇒ x) ⇍ 0.A → A" $ + check_ empty sone + (^LamY "x" (^BVT 0)) + (^Arr Zero (^FT "A") (^FT "A")), note "(but ok in overall erased context)", testTC "0 · (λ x ⇒ x) ⇐ A ⇾ A" $ - check_ empty szero ([< "x"] :\\ BVT 0) (Arr Zero (FT "A") (FT "A")), + check_ empty szero + (^LamY "x" (^BVT 0)) + (^Arr Zero (^FT "A") (^FT "A")), testTC "1 · (λ A x ⇒ refl A x) ⇐ ⋯ # (type of refl)" $ check_ empty sone - ([< "A", "x"] :\\ E (F "refl" :@@ [BVT 1, BVT 0])) + (^LamY "A" (^LamY "x" (E $ ^App (^App (^F "refl") (^BVT 1)) (^BVT 0)))) reflTy, testTC "1 · (λ A x ⇒ δ i ⇒ x) ⇐ ⋯ # (def. and type of refl)" $ check_ empty sone reflDef reflTy @@ -310,148 +328,153 @@ tests = "typechecker" :- [ "pairs" :- [ testTC "1 · (a, a) ⇐ A × A" $ - check_ empty sone (Pair (FT "a") (FT "a")) (FT "A" `And` FT "A"), + check_ empty sone + (^Pair (^FT "a") (^FT "a")) (^And (^FT "A") (^FT "A")), testTC "x : A ⊢ 1 · (x, x) ⇐ A × A ⊳ ω·x" $ - checkQ (ctx [< ("x", FT "A")]) sone - (Pair (BVT 0) (BVT 0)) (FT "A" `And` FT "A") [< Any], + checkQ (ctx [< ("x", ^FT "A")]) sone + (^Pair (^BVT 0) (^BVT 0)) (^And (^FT "A") (^FT "A")) [< Any], testTC "1 · (a, δ i ⇒ a) ⇐ (x : A) × (x ≡ a)" $ check_ empty sone - (Pair (FT "a") ([< "i"] :\\% FT "a")) - (SigY "x" (FT "A") $ Eq0 (FT "A") (BVT 0) (FT "a")) + (^Pair (^FT "a") (^DLamN (^FT "a"))) + (^SigY "x" (^FT "A") (^Eq0 (^FT "A") (^BVT 0) (^FT "a"))) ], "unpairing" :- [ testTC "x : A × A ⊢ 1 · (case1 x return B of (l,r) ⇒ f2 l r) ⇒ B ⊳ 1·x" $ - inferAsQ (ctx [< ("x", FT "A" `And` FT "A")]) sone - (CasePair One (BV 0) (SN $ FT "B") - (SY [< "l", "r"] $ E $ F "f2" :@@ [BVT 1, BVT 0])) - (FT "B") [< One], + inferAsQ (ctx [< ("x", ^And (^FT "A") (^FT "A"))]) sone + (^CasePair One (^BV 0) (SN $ ^FT "B") + (SY [< "l", "r"] $ E $ ^App (^App (^F "f2") (^BVT 1)) (^BVT 0))) + (^FT "B") [< One], testTC "x : A × A ⊢ 1 · (caseω x return B of (l,r) ⇒ f2 l r) ⇒ B ⊳ ω·x" $ - inferAsQ (ctx [< ("x", FT "A" `And` FT "A")]) sone - (CasePair Any (BV 0) (SN $ FT "B") - (SY [< "l", "r"] $ E $ F "f2" :@@ [BVT 1, BVT 0])) - (FT "B") [< Any], + inferAsQ (ctx [< ("x", ^And (^FT "A") (^FT "A"))]) sone + (^CasePair Any (^BV 0) (SN $ ^FT "B") + (SY [< "l", "r"] $ E $ ^App (^App (^F "f2") (^BVT 1)) (^BVT 0))) + (^FT "B") [< Any], testTC "x : A × A ⊢ 0 · (caseω x return B of (l,r) ⇒ f2 l r) ⇒ B ⊳ 0·x" $ - inferAsQ (ctx [< ("x", FT "A" `And` FT "A")]) szero - (CasePair Any (BV 0) (SN $ FT "B") - (SY [< "l", "r"] $ E $ F "f2" :@@ [BVT 1, BVT 0])) - (FT "B") [< Zero], + inferAsQ (ctx [< ("x", ^And (^FT "A") (^FT "A"))]) szero + (^CasePair Any (^BV 0) (SN $ ^FT "B") + (SY [< "l", "r"] $ E $ ^App (^App (^F "f2") (^BVT 1)) (^BVT 0))) + (^FT "B") [< Zero], testTCFail "x : A × A ⊢ 1 · (case0 x return B of (l,r) ⇒ f2 l r) ⇏" $ - infer_ (ctx [< ("x", FT "A" `And` FT "A")]) sone - (CasePair Zero (BV 0) (SN $ FT "B") - (SY [< "l", "r"] $ E $ F "f2" :@@ [BVT 1, BVT 0])), + infer_ (ctx [< ("x", ^And (^FT "A") (^FT "A"))]) sone + (^CasePair Zero (^BV 0) (SN $ ^FT "B") + (SY [< "l", "r"] $ E $ ^App (^App (^F "f2") (^BVT 1)) (^BVT 0))), testTC "x : A × B ⊢ 1 · (caseω x return A of (l,r) ⇒ l) ⇒ A ⊳ ω·x" $ - inferAsQ (ctx [< ("x", FT "A" `And` FT "B")]) sone - (CasePair Any (BV 0) (SN $ FT "A") - (SY [< "l", "r"] $ BVT 1)) - (FT "A") [< Any], + inferAsQ (ctx [< ("x", ^And (^FT "A") (^FT "B"))]) sone + (^CasePair Any (^BV 0) (SN $ ^FT "A") + (SY [< "l", "r"] $ ^BVT 1)) + (^FT "A") [< Any], testTC "x : A × B ⊢ 0 · (case1 x return A of (l,r) ⇒ l) ⇒ A ⊳ 0·x" $ - inferAsQ (ctx [< ("x", FT "A" `And` FT "B")]) szero - (CasePair One (BV 0) (SN $ FT "A") - (SY [< "l", "r"] $ BVT 1)) - (FT "A") [< Zero], + inferAsQ (ctx [< ("x", ^And (^FT "A") (^FT "B"))]) szero + (^CasePair One (^BV 0) (SN $ ^FT "A") + (SY [< "l", "r"] $ ^BVT 1)) + (^FT "A") [< Zero], testTCFail "x : A × B ⊢ 1 · (case1 x return A of (l,r) ⇒ l) ⇏" $ - infer_ (ctx [< ("x", FT "A" `And` FT "B")]) sone - (CasePair One (BV 0) (SN $ FT "A") - (SY [< "l", "r"] $ BVT 1)), + infer_ (ctx [< ("x", ^And (^FT "A") (^FT "B"))]) sone + (^CasePair One (^BV 0) (SN $ ^FT "A") + (SY [< "l", "r"] $ ^BVT 1)), note "fst : (0·A : ★₁) → (0·B : A ↠ ★₁) → ((x : A) × B x) ↠ A", note " ≔ (λ A B p ⇒ caseω p return A of (x, y) ⇒ x)", testTC "0 · ‹type of fst› ⇐ ★₂" $ - check_ empty szero fstTy (TYPE 2), + check_ empty szero fstTy (^TYPE 2), testTC "1 · ‹def of fst› ⇐ ‹type of fst›" $ check_ empty sone fstDef fstTy, note "snd : (0·A : ★₁) → (0·B : A ↠ ★₁) → (ω·p : (x : A) × B x) → B (fst A B p)", note " ≔ (λ A B p ⇒ caseω p return p ⇒ B (fst A B p) of (x, y) ⇒ y)", testTC "0 · ‹type of snd› ⇐ ★₂" $ - check_ empty szero sndTy (TYPE 2), + check_ empty szero sndTy (^TYPE 2), testTC "1 · ‹def of snd› ⇐ ‹type of snd›" $ check_ empty sone sndDef sndTy, testTC "0 · snd ★₀ (λ x ⇒ x) ⇒ (ω·p : (A : ★₀) × A) → fst ★₀ (λ x ⇒ x) p" $ inferAs empty szero - (F "snd" :@@ [TYPE 0, [< "x"] :\\ BVT 0]) - (PiY Any "A" (SigY "A" (TYPE 0) $ BVT 0) $ - (E $ F "fst" :@@ [TYPE 0, [< "x"] :\\ BVT 0, BVT 0])) + (^App (^App (^F "snd") (^TYPE 0)) (^LamY "x" (^BVT 0))) + (^PiY Any "p" (^SigY "A" (^TYPE 0) (^BVT 0)) + (E $ ^App (^App (^App (^F "fst") (^TYPE 0)) (^LamY "x" (^BVT 0))) + (^BVT 0))) ], "enums" :- [ testTC "1 · 'a ⇐ {a}" $ - check_ empty sone (Tag "a") (enum ["a"]), + check_ empty sone (^Tag "a") (^enum ["a"]), testTC "1 · 'a ⇐ {a, b, c}" $ - check_ empty sone (Tag "a") (enum ["a", "b", "c"]), + check_ empty sone (^Tag "a") (^enum ["a", "b", "c"]), testTCFail "1 · 'a ⇍ {b, c}" $ - check_ empty sone (Tag "a") (enum ["b", "c"]), + check_ empty sone (^Tag "a") (^enum ["b", "c"]), testTC "0=1 ⊢ 1 · 'a ⇐ {b, c}" $ - check_ empty01 sone (Tag "a") (enum ["b", "c"]) + 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"]), + 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")) + infer_ (ctx [< ("x", ^enum ["tt"])]) sone + (^CaseEnum One (^BV 0) (SN (^enum ["tt"])) + (singleton "ff" (^Tag "tt"))) ], "equality types" :- [ testTC "0 · ℕ ≡ ℕ : ★₀ ⇐ Type" $ - checkType_ empty (Eq0 (TYPE 0) Nat Nat) Nothing, + checkType_ empty (^Eq0 (^TYPE 0) nat nat) Nothing, testTC "0 · ℕ ≡ ℕ : ★₀ ⇐ ★₁" $ - check_ empty szero (Eq0 (TYPE 0) Nat Nat) (TYPE 1), + check_ empty szero (^Eq0 (^TYPE 0) nat nat) (^TYPE 1), testTCFail "1 · ℕ ≡ ℕ : ★₀ ⇍ ★₁" $ - check_ empty sone (Eq0 (TYPE 0) Nat Nat) (TYPE 1), + check_ empty sone (^Eq0 (^TYPE 0) nat nat) (^TYPE 1), testTC "0 · ℕ ≡ ℕ : ★₀ ⇐ ★₂" $ - check_ empty szero (Eq0 (TYPE 0) Nat Nat) (TYPE 2), + check_ empty szero (^Eq0 (^TYPE 0) nat nat) (^TYPE 2), testTC "0 · ℕ ≡ ℕ : ★₁ ⇐ ★₂" $ - check_ empty szero (Eq0 (TYPE 1) Nat Nat) (TYPE 2), + check_ empty szero (^Eq0 (^TYPE 1) nat nat) (^TYPE 2), testTCFail "0 · ℕ ≡ ℕ : ★₁ ⇍ ★₁" $ - check_ empty szero (Eq0 (TYPE 1) Nat Nat) (TYPE 1), + check_ empty szero (^Eq0 (^TYPE 1) nat nat) (^TYPE 1), testTCFail "0 ≡ 'beep : {beep} ⇍ Type" $ - checkType_ empty (Eq0 (enum ["beep"]) Zero (Tag "beep")) Nothing, + checkType_ empty + (^Eq0 (^enum ["beep"]) (^Zero) (^Tag "beep")) + Nothing, testTC "ab : A ≡ B : ★₀, x : A, y : B ⊢ 0 · Eq [i ⇒ ab i] x y ⇐ ★₀" $ - check_ (ctx [< ("ab", Eq0 (TYPE 0) (FT "A") (FT "B")), - ("x", FT "A"), ("y", FT "B")]) szero - (Eq (SY [< "i"] $ E $ BV 2 :% BV 0) (BVT 1) (BVT 0)) - (TYPE 0), + check_ (ctx [< ("ab", ^Eq0 (^TYPE 0) (^FT "A") (^FT "B")), + ("x", ^FT "A"), ("y", ^FT "B")]) szero + (^EqY "i" (E $ ^DApp (^BV 2) (^BV 0)) (^BVT 1) (^BVT 0)) + (^TYPE 0), testTCFail "ab : A ≡ B : ★₀, x : A, y : B ⊢ Eq [i ⇒ ab i] y x ⇍ Type" $ - checkType_ (ctx [< ("ab", Eq0 (TYPE 0) (FT "A") (FT "B")), - ("x", FT "A"), ("y", FT "B")]) - (Eq (SY [< "i"] $ E $ BV 2 :% BV 0) (BVT 0) (BVT 1)) - Nothing + check_ (ctx [< ("ab", ^Eq0 (^TYPE 0) (^FT "A") (^FT "B")), + ("x", ^FT "A"), ("y", ^FT "B")]) szero + (^EqY "i" (E $ ^DApp (^BV 2) (^BV 0)) (^BVT 0) (^BVT 1)) + (^TYPE 0) ], "equalities" :- [ testTC "1 · (δ i ⇒ a) ⇐ a ≡ a" $ - check_ empty sone (DLam $ SN $ FT "a") - (Eq0 (FT "A") (FT "a") (FT "a")), - testTC "0 · (λ p q ⇒ δ i ⇒ p) ⇐ (ω·p q : a ≡ a') → p ≡ q" $ + check_ empty sone (^DLamN (^FT "a")) + (^Eq0 (^FT "A") (^FT "a") (^FT "a")), + testTC "0 · (λ p q ⇒ δ i ⇒ p) ⇐ (ω·p q : a ≡ a') → p ≡ q # uip" $ check_ empty szero - ([< "p","q"] :\\ [< "i"] :\\% BVT 1) - (PiY Any "p" (Eq0 (FT "A") (FT "a") (FT "a")) $ - PiY Any "q" (Eq0 (FT "A") (FT "a") (FT "a")) $ - Eq0 (Eq0 (FT "A") (FT "a") (FT "a")) (BVT 1) (BVT 0)), - testTC "0 · (λ p q ⇒ δ i ⇒ q) ⇐ (ω·p q : a ≡ a') → p ≡ q" $ + (^LamY "p" (^LamY "q" (^DLamN (^BVT 1)))) + (^PiY Any "p" (^Eq0 (^FT "A") (^FT "a") (^FT "a")) + (^PiY Any "q" (^Eq0 (^FT "A") (^FT "a") (^FT "a")) + (^Eq0 (^Eq0 (^FT "A") (^FT "a") (^FT "a")) (^BVT 1) (^BVT 0)))), + testTC "0 · (λ p q ⇒ δ i ⇒ q) ⇐ (ω·p q : a ≡ a') → p ≡ q # uip(2)" $ check_ empty szero - ([< "p","q"] :\\ [< "i"] :\\% BVT 0) - (PiY Any "p" (Eq0 (FT "A") (FT "a") (FT "a")) $ - PiY Any "q" (Eq0 (FT "A") (FT "a") (FT "a")) $ - Eq0 (Eq0 (FT "A") (FT "a") (FT "a")) (BVT 1) (BVT 0)) + (^LamY "p" (^LamY "q" (^DLamN (^BVT 0)))) + (^PiY Any "p" (^Eq0 (^FT "A") (^FT "a") (^FT "a")) + (^PiY Any "q" (^Eq0 (^FT "A") (^FT "a") (^FT "a")) + (^Eq0 (^Eq0 (^FT "A") (^FT "a") (^FT "a")) (^BVT 1) (^BVT 0)))) ], "natural numbers" :- [ - testTC "0 · ℕ ⇐ ★₀" $ check_ empty szero Nat (TYPE 0), - testTC "0 · ℕ ⇐ ★₇" $ check_ empty szero Nat (TYPE 7), - testTCFail "1 · ℕ ⇍ ★₀" $ check_ empty sone Nat (TYPE 0), - testTC "1 · zero ⇐ ℕ" $ check_ empty sone Zero Nat, - testTCFail "1 · zero ⇍ ℕ×ℕ" $ check_ empty sone Zero (Nat `And` Nat), + testTC "0 · ℕ ⇐ ★₀" $ check_ empty szero nat (^TYPE 0), + testTC "0 · ℕ ⇐ ★₇" $ check_ empty szero nat (^TYPE 7), + testTCFail "1 · ℕ ⇍ ★₀" $ check_ empty sone nat (^TYPE 0), + testTC "1 · zero ⇐ ℕ" $ check_ empty sone (^Zero) nat, + testTCFail "1 · zero ⇍ ℕ×ℕ" $ check_ empty sone (^Zero) (^And nat nat), testTC "ω·n : ℕ ⊢ 1 · succ n ⇐ ℕ" $ - check_ (ctx [< ("n", Nat)]) sone (Succ (BVT 0)) Nat, + check_ (ctx [< ("n", nat)]) sone (^Succ (^BVT 0)) nat, testTC "1 · λ n ⇒ succ n ⇐ 1.ℕ → ℕ" $ - check_ empty sone ([< "n"] :\\ Succ (BVT 0)) (Arr One Nat Nat), - todo "nat elim" + check_ empty sone + (^LamY "n" (^Succ (^BVT 0))) + (^Arr One nat nat) ], "natural elim" :- [ @@ -459,25 +482,28 @@ tests = "typechecker" :- [ note " ⇐ 1.ℕ → ℕ", testTC "pred" $ check_ empty sone - ([< "n"] :\\ E (CaseNat One Zero (BV 0) (SN Nat) - Zero (SY [< "n", Unused] $ BVT 1))) - (Arr One Nat Nat), + (^LamY "n" (E $ + ^CaseNat One Zero (^BV 0) (SN nat) + (^Zero) (SY [< "n", ^BN Unused] $ ^BVT 1))) + (^Arr One nat nat), note "1 · λ m n ⇒ case1 m return ℕ of { zero ⇒ n; succ _, 1.p ⇒ succ p }", note " ⇐ 1.ℕ → 1.ℕ → 1.ℕ", testTC "plus" $ check_ empty sone - ([< "m", "n"] :\\ E (CaseNat One One (BV 1) (SN Nat) - (BVT 0) (SY [< Unused, "p"] $ Succ $ BVT 0))) - (Arr One Nat $ Arr One Nat Nat) + (^LamY "m" (^LamY "n" (E $ + ^CaseNat One One (^BV 1) (SN nat) + (^BVT 0) + (SY [< ^BN Unused, "p"] $ ^Succ (^BVT 0))))) + (^Arr One nat (^Arr One nat nat)) ], "box types" :- [ testTC "0 · [0.ℕ] ⇐ ★₀" $ - check_ empty szero (BOX Zero Nat) (TYPE 0), + check_ empty szero (^BOX Zero nat) (^TYPE 0), testTC "0 · [0.★₀] ⇐ ★₁" $ - check_ empty szero (BOX Zero (TYPE 0)) (TYPE 1), + check_ empty szero (^BOX Zero (^TYPE 0)) (^TYPE 1), testTCFail "0 · [0.★₀] ⇍ ★₀" $ - check_ empty szero (BOX Zero (TYPE 0)) (TYPE 0) + check_ empty szero (^BOX Zero (^TYPE 0)) (^TYPE 0) ], todo "box values", @@ -486,10 +512,14 @@ tests = "typechecker" :- [ "type-case" :- [ testTC "0 · type-case ℕ ∷ ★₀ return ★₀ of { _ ⇒ ℕ } ⇒ ★₀" $ inferAs empty szero - (TypeCase (Nat :# TYPE 0) (TYPE 0) empty Nat) - (TYPE 0) + (^TypeCase (^Ann nat (^TYPE 0)) (^TYPE 0) empty nat) + (^TYPE 0) ], + todo "add the examples dir to the tests" +] + +{- "misc" :- [ note "0·A : Type, 0·P : A → Type, ω·p : (1·x : A) → P x", note "⊢", @@ -524,4 +554,4 @@ tests = "typechecker" :- [ -- return A -- of { } ] -] +-} diff --git a/tests/quox-tests.ipkg b/tests/quox-tests.ipkg index 589c8a3..c98b60d 100644 --- a/tests/quox-tests.ipkg +++ b/tests/quox-tests.ipkg @@ -5,6 +5,7 @@ depends = base, contrib, elab-util, snocvect, quox-lib, tap, eff executable = quox-tests main = Tests modules = + AstExtra, TypingImpls, PrettyExtra, Tests.DimEq,