diff --git a/lib/Quox/Loc.idr b/lib/Quox/Loc.idr index cd63e2f..7256fed 100644 --- a/lib/Quox/Loc.idr +++ b/lib/Quox/Loc.idr @@ -113,6 +113,10 @@ public export 0 Located1 : (a -> Type) -> Type Located1 f = forall x. Located (f x) +public export +0 Located2 : (a -> b -> Type) -> Type +Located2 f = forall x, y. Located (f x y) + public export interface Located a => Relocatable a where setLoc : Loc -> a -> a diff --git a/lib/Quox/Reduce.idr b/lib/Quox/Reduce.idr index 557a6ec..f9b1857 100644 --- a/lib/Quox/Reduce.idr +++ b/lib/Quox/Reduce.idr @@ -215,14 +215,14 @@ tycaseRhsDef0 def k arms = fromMaybe def $ tycaseRhs0 k arms export -weakAtT : CanTSubst f => (by, at : Nat) -> +weakAtT : (CanTSubst f, Located2 f) => (by, at : Nat) -> f d (at + n) -> f d (at + (by + n)) -weakAtT by at t = t `CanTSubst.(//)` pushN at (shift by) +weakAtT by at t = t `CanTSubst.(//)` pushN at (shift by) t.loc export -weakAtD : CanDSubst f => (by, at : Nat) -> +weakAtD : (CanDSubst f, Located2 f) => (by, at : Nat) -> f (at + d) n -> f (at + (by + d)) n -weakAtD by at t = t `CanDSubst.(//)` pushN at (shift by) +weakAtD by at t = t `CanDSubst.(//)` pushN at (shift by) t.loc parameters {s : Nat} export diff --git a/lib/Quox/Syntax/Dim.idr b/lib/Quox/Syntax/Dim.idr index 363e082..2b2b7c1 100644 --- a/lib/Quox/Syntax/Dim.idr +++ b/lib/Quox/Syntax/Dim.idr @@ -83,7 +83,7 @@ DSubst : Nat -> Nat -> Type DSubst = Subst Dim -public export FromVar Dim where fromVarLoc = B +public export FromVar Dim where fromVar = B export diff --git a/lib/Quox/Syntax/DimEq.idr b/lib/Quox/Syntax/DimEq.idr index c8079d8..0f47bd0 100644 --- a/lib/Quox/Syntax/DimEq.idr +++ b/lib/Quox/Syntax/DimEq.idr @@ -70,13 +70,13 @@ toMaybe (Just x) = Just x export -fromGround' : Context' DimConst d -> DimEq' d -fromGround' [<] = [<] -fromGround' (ctx :< e) = fromGround' ctx :< Just (K e noLoc) +fromGround' : BContext d -> Context' DimConst d -> DimEq' d +fromGround' [<] [<] = [<] +fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc) export -fromGround : Context' DimConst d -> DimEq d -fromGround = C . fromGround' +fromGround : BContext d -> Context' DimConst d -> DimEq d +fromGround = C .: fromGround' public export %inline @@ -243,7 +243,7 @@ prettyCsts : {opts : _} -> BContext d -> DimEq' d -> prettyCsts [<] [<] = pure [<] prettyCsts dnames (eqs :< Nothing) = prettyCsts (tail dnames) eqs prettyCsts dnames (eqs :< Just q) = - [|prettyCsts (tail dnames) eqs :< prettyCst dnames (BV 0 noLoc) (weakD 1 q)|] + [|prettyCsts (tail dnames) eqs :< prettyCst dnames (BV 0 q.loc) (weakD 1 q)|] export prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts) diff --git a/lib/Quox/Syntax/Subst.idr b/lib/Quox/Syntax/Subst.idr index 976f7bb..0615879 100644 --- a/lib/Quox/Syntax/Subst.idr +++ b/lib/Quox/Syntax/Subst.idr @@ -49,7 +49,7 @@ interface FromVar term => CanSubstSelf term where public export getLoc : FromVar term => Subst term from to -> Var from -> Loc -> term to -getLoc (Shift by) i loc = fromVarLoc (shift by i) loc +getLoc (Shift by) i loc = fromVar (shift by i) loc getLoc (t ::: th) VZ _ = t getLoc (t ::: th) (VS i) loc = getLoc th i loc @@ -95,18 +95,18 @@ map f (t ::: th) = f t ::: map f th public export %inline -push : CanSubstSelf f => Subst f from to -> Subst f (S from) (S to) -push th = fromVar VZ ::: (th . shift 1) +push : CanSubstSelf f => Subst f from to -> Loc -> Subst f (S from) (S to) +push th loc = fromVar VZ loc ::: (th . shift 1) -- [fixme] a better way to do this? public export pushN : CanSubstSelf f => (s : Nat) -> - Subst f from to -> Subst f (s + from) (s + to) -pushN 0 th = th -pushN (S s) th = + Subst f from to -> Loc -> Subst f (s + from) (s + to) +pushN 0 th _ = th +pushN (S s) th loc = rewrite plusSuccRightSucc s from in rewrite plusSuccRightSucc s to in - pushN s $ fromVar VZ ::: (th . shift 1) + pushN s (fromVar VZ loc ::: (th . shift 1)) loc public export drop1 : Subst f (S from) to -> Subst f from to diff --git a/lib/Quox/Syntax/Term/Subst.idr b/lib/Quox/Syntax/Term/Subst.idr index 5c736a7..112588c 100644 --- a/lib/Quox/Syntax/Term/Subst.idr +++ b/lib/Quox/Syntax/Term/Subst.idr @@ -56,12 +56,12 @@ namespace DSubst.DScopeTermN (//) : {s : Nat} -> DScopeTermN s d1 n -> Lazy (DSubst d1 d2) -> DScopeTermN s d2 n - S ns (Y body) // th = S ns $ Y $ body // pushN s th + S ns (Y body) // th = S ns $ Y $ body // pushN s th body.loc S ns (N body) // th = S ns $ N $ body // th -export %inline FromVar (Elim d) where fromVarLoc = B -export %inline FromVar (Term d) where fromVarLoc = E .: fromVar +export %inline FromVar (Elim d) where fromVar = B +export %inline FromVar (Term d) where fromVar = E .: fromVar ||| does the minimal reasonable work: @@ -104,7 +104,7 @@ namespace ScopeTermN (//) : {s : Nat} -> ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) -> ScopeTermN s d n2 - S ns (Y body) // th = S ns $ Y $ body // pushN s th + S ns (Y body) // th = S ns $ Y $ body // pushN s th body.loc S ns (N body) // th = S ns $ N $ body // th namespace DScopeTermN @@ -189,12 +189,12 @@ dsub1 t p = dsubN t [< p] public export %inline -(.zero) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n -body.zero = dsub1 body $ K Zero loc +(.zero) : DScopeTerm d n -> Term d n +body.zero = dsub1 body $ K Zero body.loc public export %inline -(.one) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n -body.one = dsub1 body $ K One loc +(.one) : DScopeTerm d n -> Term d n +body.one = dsub1 body $ K One body.loc public export diff --git a/lib/Quox/Syntax/Var.idr b/lib/Quox/Syntax/Var.idr index f9a648e..28cac7a 100644 --- a/lib/Quox/Syntax/Var.idr +++ b/lib/Quox/Syntax/Var.idr @@ -139,13 +139,9 @@ weakIsSpec p i = toNatInj $ trans (weakCorrect p i) (sym $ weakSpecCorrect p i) public export -interface FromVar f where %inline fromVarLoc : Var n -> Loc -> f n +interface FromVar f where %inline fromVar : Var n -> Loc -> f n -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 +public export FromVar Var where fromVar 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 d5b2df8..03119fb 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -347,7 +347,7 @@ mutual infres <- inferC ctx szero e -- if Ψ | Γ ⊢ Type ℓ <: Type 𝓀 case u of - Just u => lift $ subtype e.loc ctx infres.type (TYPE u noLoc) + Just u => lift $ subtype e.loc ctx infres.type (TYPE u e.loc) Nothing => ignore $ expectTYPE !(askAt DEFS) ctx e.loc infres.type -- then Ψ | Γ ⊢₀ E ⇐ Type 𝓀 diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index 38a0fec..20aa27d 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -62,7 +62,7 @@ substCaseWRet [< x, y, ih] dty retty = public export 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 + let arg = Ann (Succ (BVT 1 p.loc) p.loc) (Nat p.loc) $ p.loc `extendL` ih.loc in retty.term // (arg ::: shift 2) diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index c1db5fe..8447a9a 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -197,7 +197,7 @@ namespace EqContext toTyContext : (e : EqContext n) -> TyContext e.dimLen n toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) = MkTyContext { - dctx = fromGround dassign, + dctx = fromGround dnames dassign, tctx = map (// shift0 dimLen) tctx, dnames, tnames, qtys } diff --git a/tests/Tests/DimEq.idr b/tests/Tests/DimEq.idr index 7f0a847..b96f7c4 100644 --- a/tests/Tests/DimEq.idr +++ b/tests/Tests/DimEq.idr @@ -97,7 +97,7 @@ tests = "dimension constraints" :- [ testPrettyD iijj ZeroIsOne "𝑖, 𝑗, 0 = 1", testPrettyD [<] new "" {label = "[empty output from empty context]"}, testPrettyD ii new "𝑖", - testPrettyD iijj (fromGround [< Zero, One]) + testPrettyD iijj (fromGround iijj [< Zero, One]) "𝑖, 𝑗, 𝑖 = 0, 𝑗 = 1", testPrettyD iijj (C [< Just (^K Zero), Nothing]) "𝑖, 𝑗, 𝑖 = 0",