rhi/quox
rhi/quox
1
0
Fork 0
Code Issues 15 Pull requests 1 Releases Wiki Activity

improve handling of context lengths

Browse source
This commit is contained in:
rhiannon morris 2023-10-15 16:23:38 +02:00
parent 2e9183bc14
commit 0c1df54d62
12 changed files with 64 additions and 47 deletions
Download patch file Download diff file Expand all files Collapse all files

2
lib/Quox/Whnf/Coercion.idr
View file

@ -23,7 +23,7 @@ where
parameters {auto _ : CanWhnf Term Interface.isRedexT}
{auto _ : CanWhnf Elim Interface.isRedexE}
{d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n) (sg : SQty)
(defs : Definitions) (ctx : WhnfContext d n) (sg : SQty)
||| reduce a function application `App (Coe ty p q val) s loc`
export covering
piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->

4
lib/Quox/Whnf/ComputeElimType.idr
View file

@ -14,7 +14,6 @@ export covering
computeElimType :
CanWhnf Term Interface.isRedexT =>
CanWhnf Elim Interface.isRedexE =>
{d, n : Nat} ->
(defs : Definitions) -> WhnfContext d n -> (0 sg : SQty) ->
(e : Elim d n) -> (0 ne : No (isRedexE defs sg e)) =>
Eff Whnf (Term d n)
@ -25,7 +24,6 @@ export covering
computeWhnfElimType0 :
CanWhnf Term Interface.isRedexT =>
CanWhnf Elim Interface.isRedexE =>
{d, n : Nat} ->
(defs : Definitions) -> WhnfContext d n -> (0 sg : SQty) ->
(e : Elim d n) -> (0 ne : No (isRedexE defs sg e)) =>
Eff Whnf (Term d n)
@ -35,7 +33,7 @@ computeElimType defs ctx sg e =
F x u loc => do
let Just def = lookup x defs
| Nothing => throw $ NotInScope loc x
pure $ def.typeAt u
pure $ def.typeWithAt ctx.dimLen ctx.termLen u
B i _ =>
pure $ ctx.tctx !! i

10
lib/Quox/Whnf/Interface.idr
View file

@ -18,13 +18,12 @@ Whnf = [NameGen, Except Error]
public export
0 RedexTest : TermLike -> Type
RedexTest tm = {d, n : Nat} -> Definitions -> SQty -> tm d n -> Bool
RedexTest tm = {0 d, n : Nat} -> Definitions -> SQty -> tm d n -> Bool
public export
interface CanWhnf (0 tm : TermLike) (0 isRedex : RedexTest tm) | tm
where
whnf : {d, n : Nat} -> (defs : Definitions) ->
(ctx : WhnfContext d n) -> (q : SQty) ->
whnf : (defs : Definitions) -> (ctx : WhnfContext d n) -> (q : SQty) ->
tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs q))
-- having isRedex be part of the class header, and needing to be explicitly
-- quantified on every use since idris can't infer its type, is a little ugly.
@ -32,7 +31,7 @@ where
-- cases idris can't tell that `isRedex` and `isRedexT` are the same thing
public export %inline
whnf0 : {d, n : Nat} -> {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
whnf0 : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
Definitions -> WhnfContext d n -> SQty -> tm d n -> Eff Whnf (tm d n)
whnf0 defs ctx q t = fst <$> whnf defs ctx q t
@ -194,8 +193,7 @@ mutual
||| 7. a closure
public export
isRedexE : RedexTest Elim
isRedexE defs sg (F {x, u, _}) {d, n} =
isJust $ lookupElim x u defs {d, n}
isRedexE defs sg (F {x, u, _}) = isJust $ lookupElim0 x u defs
isRedexE _ sg (B {}) = False
isRedexE defs sg (App {fun, _}) =
isRedexE defs sg fun || isLamHead fun

4
lib/Quox/Whnf/Main.idr
View file

@ -16,8 +16,8 @@ export covering CanWhnf Elim Interface.isRedexE
covering
CanWhnf Elim Interface.isRedexE where
whnf defs ctx sg (F x u loc) with (lookupElim x u defs) proof eq
_ | Just y = whnf defs ctx sg $ setLoc loc y
whnf defs ctx sg (F x u loc) with (lookupElim0 x u defs) proof eq
_ | Just y = whnf defs ctx sg $ setLoc loc $ injElim ctx y
_ | Nothing = pure $ Element (F x u loc) $ rewrite eq in Ah
whnf _ _ _ (B i loc) = pure $ nred $ B i loc

2
lib/Quox/Whnf/TypeCase.idr
View file

@ -30,7 +30,7 @@ tycaseRhsDef0 def k arms = fromMaybe def $ tycaseRhs0 k arms
parameters {auto _ : CanWhnf Term Interface.isRedexT}
{auto _ : CanWhnf Elim Interface.isRedexE}
{d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n)
(defs : Definitions) (ctx : WhnfContext 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