diff --git a/lib/Quox/Syntax/DimEq.idr b/lib/Quox/Syntax/DimEq.idr index 9bb0cac..e8b9bdf 100644 --- a/lib/Quox/Syntax/DimEq.idr +++ b/lib/Quox/Syntax/DimEq.idr @@ -104,10 +104,10 @@ mutual export %inline setVar : (i, j : Var d) -> DimEq' d -> DimEq d - setVar i j eqs with (compareP i j) - _ | IsLT lt = setVar' i j lt eqs - setVar i i eqs | IsEQ = C eqs - _ | IsGT gt = setVar' j i gt eqs + setVar i j eqs = case compareP i j of + IsLT lt => setVar' i j lt eqs + IsEQ => C eqs + IsGT gt => setVar' j i gt eqs export %inline diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index cd57c76..fd17293 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -46,20 +46,23 @@ weakI : IsQty q => InferResult q d n -> InferResult q d (S n) weakI = {type $= weakT, qout $= (:< zero)} private -lookupBound : IsQty q => - {n : Nat} -> q -> Var n -> TyContext q d n -> InferResult q d n -lookupBound pi VZ (MkTyContext {tctx = _ :< ty, _}) = - InfRes {type = weakT ty, qout = zero :< pi} +lookupBound : IsQty q => q -> Var n -> TyContext q d n -> InferResult q d n +lookupBound pi VZ ctx@(MkTyContext {tctx = _ :< ty, _}) = + InfRes {type = weakT ty, qout = zeroFor (tail ctx) :< pi} lookupBound pi (VS i) ctx = weakI $ lookupBound pi i (tail ctx) private %inline subjMult : IsQty q => (sg : SQty q) -> q -> SQty q -subjMult (Element sg subj) qty = - if isYes (isZero sg) || isYes (isZero qty) - then Element zero zeroIsSubj - else Element sg subj +subjMult sg qty = if isYes $ isZero qty then szero else sg + + +export +makeDimEq : DContext d -> DimEq d +makeDimEq DNil = zeroEq +makeDimEq (DBind dctx) = makeDimEq dctx : - (ctx : TyContext q d n) -> (sg : SQty q) -> + check : (ctx : TyContext q d n) -> (sg : SQty q) -> (subj : Term q d n) -> (ty : Term q d n) -> m (CheckResult q n) check ctx sg subj ty = check' ctx sg (pushSubstsT subj) ty export covering %inline - infer : {d, n : Nat} -> - (ctx : TyContext q d n) -> (sg : SQty q) -> + infer : (ctx : TyContext q d n) -> (sg : SQty q) -> (subj : Elim q d n) -> m (InferResult q d n) infer ctx sg subj = infer' ctx sg (pushSubstsE subj) export covering - check' : {d, n : Nat} -> - (ctx : TyContext q d n) -> (sg : SQty q) -> + check' : (ctx : TyContext q d n) -> (sg : SQty q) -> (subj : NotCloTerm q d n) -> (ty : Term q d n) -> m (CheckResult q n) @@ -102,7 +102,7 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m} l' <- expectTYPE ty expectEqualQ zero sg.fst unless (l < l') $ throwError $ BadUniverse l l' - pure zero + pure $ zeroFor ctx check' ctx sg (Element (Pi qty x arg res) _) ty = do l <- expectTYPE ty @@ -113,7 +113,7 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m} ignore $ check (extendTy arg zero ctx) szero res (TYPE l) TUnused res => ignore $ check ctx szero res (TYPE l) - pure zero + pure $ zeroFor ctx check' ctx sg (Element (Lam x body) _) ty = do (qty, arg, res) <- expectPi ty @@ -125,19 +125,18 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m} check' ctx sg (Element (E e) _) ty = do infres <- infer ctx sg e ignore $ check ctx szero ty (TYPE UAny) - subT infres.type ty + subTWith (makeDimEq ctx.dctx) infres.type ty pure infres.qout export covering - infer' : {d, n : Nat} -> - (ctx : TyContext q d n) -> (sg : SQty q) -> + infer' : (ctx : TyContext q d n) -> (sg : SQty q) -> (subj : NotCloElim q d n) -> m (InferResult q d n) infer' ctx sg (Element (F x) _) = do Just g <- asks $ lookup x | Nothing => throwError $ NotInScope x when (isZero g) $ expectEqualQ sg.fst zero - pure $ InfRes {type = g.type.get, qout = zero} + pure $ InfRes {type = g.type.get, qout = zeroFor ctx} infer' ctx sg (Element (B i) _) = pure $ lookupBound sg.fst i ctx diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index 899d815..d3f3450 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -81,6 +81,10 @@ namespace QOutput zero : {n : Nat} -> QOutput q n zero = pure zero + export + zeroFor : TyContext q _ n -> QOutput q n + zeroFor ctx = const zero <$> ctx.qctx + public export CheckResult : Type -> Nat -> Type