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

add displacement to Definition

Browse source
This commit is contained in:
rhiannon morris 2023-08-28 19:59:36 +02:00
parent 6dcd3332c1
commit 6f9d31aa0a
5 changed files with 19 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
lib/Quox/Definition.idr
View file

@ -2,6 +2,7 @@ module Quox.Definition
import public Quox.No import public Quox.No
import public Quox.Syntax import public Quox.Syntax
import Quox.Displace
import public Data.SortedMap import public Data.SortedMap
import public Quox.Loc import public Quox.Loc
import Control.Eff import Control.Eff
@ -45,13 +46,21 @@ parameters {d, n : Nat}
(.type) : Definition -> Term d n (.type) : Definition -> Term d n
g.type = g.type0 // shift0 d // shift0 n g.type = g.type0 // shift0 d // shift0 n
public export %inline
(.typeAt) : Definition -> Universe -> Term d n
g.typeAt u = displace u g.type
public export %inline public export %inline
(.term) : Definition -> Maybe (Term d n) (.term) : Definition -> Maybe (Term d n)
g.term = g.body0.term0 <&> \t => t // shift0 d // shift0 n g.term = g.body0.term0 <&> \t => t // shift0 d // shift0 n
public export %inline public export %inline
toElim : Definition -> Maybe $ Elim d n (.termAt) : Definition -> Universe -> Maybe (Term d n)
toElim def = pure $ Ann !def.term def.type def.loc g.termAt u = displace u <$> g.term
public export %inline
toElim : Definition -> Universe -> Maybe $ Elim d n
toElim def u = pure $ Ann !(def.termAt u) (def.typeAt u) def.loc
public export %inline public export %inline
@ -76,5 +85,5 @@ DefsState = StateL DEFS Definitions
public export %inline public export %inline
lookupElim : {d, n : Nat} -> Name -> Definitions -> Maybe (Elim d n) lookupElim : {d, n : Nat} -> Name -> Universe -> Definitions -> Maybe (Elim d n)
lookupElim x defs = toElim !(lookup x defs) lookupElim x u defs = toElim !(lookup x defs) u

2
lib/Quox/Typechecker.idr
View file

@ -327,7 +327,7 @@ mutual
expectCompatQ loc sg.fst g.qty.fst expectCompatQ loc sg.fst g.qty.fst
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎 -- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎
let Val d = ctx.dimLen; Val n = ctx.termLen let Val d = ctx.dimLen; Val n = ctx.termLen
pure $ InfRes {type = displace u g.type, qout = zeroFor ctx} pure $ InfRes {type = g.typeAt u, qout = zeroFor ctx}
infer' ctx sg (B i _) = infer' ctx sg (B i _) =
-- if x : A ∈ Γ -- if x : A ∈ Γ

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

@ -22,7 +22,7 @@ computeElimType defs ctx e {ne} =
F {x, u, loc} => do F {x, u, loc} => do
let Just def = lookup x defs let Just def = lookup x defs
| Nothing => throw $ NotInScope loc x | Nothing => throw $ NotInScope loc x
pure $ displace u def.type pure $ def.typeAt u
B {i, _} => B {i, _} =>
pure $ ctx.tctx !! i pure $ ctx.tctx !! i

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

@ -193,8 +193,8 @@ mutual
||| 7. a closure ||| 7. a closure
public export public export
isRedexE : RedexTest Elim isRedexE : RedexTest Elim
isRedexE defs (F {x, _}) {d, n} = isRedexE defs (F {x, u, _}) {d, n} =
isJust $ lookupElim x defs {d, n} isJust $ lookupElim x u defs {d, n}
isRedexE _ (B {}) = False isRedexE _ (B {}) = False
isRedexE defs (App {fun, _}) = isRedexE defs (App {fun, _}) =
isRedexE defs fun || isLamHead fun isRedexE defs fun || isLamHead fun

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

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