pass the subject quantity through equality etc
in preparation for non-linear η laws
This commit is contained in:
parent
3fe9b96f05
commit
e6c06a5c81
17 changed files with 654 additions and 605 deletions
|
|
@ -18,14 +18,14 @@ Whnf = [NameGen, Except Error]
|
|||
|
||||
public export
|
||||
0 RedexTest : TermLike -> Type
|
||||
RedexTest tm = {d, n : Nat} -> Definitions -> tm d n -> Bool
|
||||
RedexTest tm = {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) ->
|
||||
tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs))
|
||||
(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.
|
||||
-- but none of the alternatives i've thought of so far work. e.g. in some
|
||||
|
|
@ -33,23 +33,24 @@ where
|
|||
|
||||
public export %inline
|
||||
whnf0 : {d, n : Nat} -> {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
|
||||
(defs : Definitions) -> WhnfContext d n -> tm d n -> Eff Whnf (tm d n)
|
||||
whnf0 defs ctx t = fst <$> whnf defs ctx t
|
||||
Definitions -> WhnfContext d n -> SQty -> tm d n -> Eff Whnf (tm d n)
|
||||
whnf0 defs ctx q t = fst <$> whnf defs ctx q t
|
||||
|
||||
public export
|
||||
0 IsRedex, NotRedex : {isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
|
||||
Definitions -> Pred (tm d n)
|
||||
IsRedex defs = So . isRedex defs
|
||||
NotRedex defs = No . isRedex defs
|
||||
Definitions -> SQty -> Pred (tm d n)
|
||||
IsRedex defs q = So . isRedex defs q
|
||||
NotRedex defs q = No . isRedex defs q
|
||||
|
||||
public export
|
||||
0 NonRedex : (tm : TermLike) -> {isRedex : RedexTest tm} ->
|
||||
CanWhnf tm isRedex => (d, n : Nat) -> (defs : Definitions) -> Type
|
||||
NonRedex tm d n defs = Subset (tm d n) (NotRedex defs)
|
||||
CanWhnf tm isRedex => (d, n : Nat) ->
|
||||
(defs : Definitions) -> SQty -> Type
|
||||
NonRedex tm d n defs q = Subset (tm d n) (NotRedex defs q)
|
||||
|
||||
public export %inline
|
||||
nred : {0 isRedex : RedexTest tm} -> (0 _ : CanWhnf tm isRedex) =>
|
||||
(t : tm d n) -> (0 nr : NotRedex defs t) => NonRedex tm d n defs
|
||||
(t : tm d n) -> (0 nr : NotRedex defs q t) => NonRedex tm d n defs q
|
||||
nred t = Element t nr
|
||||
|
||||
|
||||
|
|
@ -153,25 +154,25 @@ isK _ = False
|
|||
||| - `ty` has η
|
||||
||| - `val` is a constructor form
|
||||
public export %inline
|
||||
canPushCoe : (ty, val : Term {}) -> Bool
|
||||
canPushCoe (TYPE {}) _ = True
|
||||
canPushCoe (Pi {}) _ = True
|
||||
canPushCoe (Lam {}) _ = False
|
||||
canPushCoe (Sig {}) (Pair {}) = True
|
||||
canPushCoe (Sig {}) _ = False
|
||||
canPushCoe (Pair {}) _ = False
|
||||
canPushCoe (Enum {}) _ = True
|
||||
canPushCoe (Tag {}) _ = False
|
||||
canPushCoe (Eq {}) _ = True
|
||||
canPushCoe (DLam {}) _ = False
|
||||
canPushCoe (Nat {}) _ = True
|
||||
canPushCoe (Zero {}) _ = False
|
||||
canPushCoe (Succ {}) _ = False
|
||||
canPushCoe (BOX {}) _ = True
|
||||
canPushCoe (Box {}) _ = False
|
||||
canPushCoe (E {}) _ = False
|
||||
canPushCoe (CloT {}) _ = False
|
||||
canPushCoe (DCloT {}) _ = False
|
||||
canPushCoe : SQty -> (ty, val : Term {}) -> Bool
|
||||
canPushCoe pi (TYPE {}) _ = True
|
||||
canPushCoe pi (Pi {}) _ = True
|
||||
canPushCoe pi (Lam {}) _ = False
|
||||
canPushCoe pi (Sig {}) (Pair {}) = True
|
||||
canPushCoe pi (Sig {}) _ = False
|
||||
canPushCoe pi (Pair {}) _ = False
|
||||
canPushCoe pi (Enum {}) _ = True
|
||||
canPushCoe pi (Tag {}) _ = False
|
||||
canPushCoe pi (Eq {}) _ = True
|
||||
canPushCoe pi (DLam {}) _ = False
|
||||
canPushCoe pi (Nat {}) _ = True
|
||||
canPushCoe pi (Zero {}) _ = False
|
||||
canPushCoe pi (Succ {}) _ = False
|
||||
canPushCoe pi (BOX {}) _ = True
|
||||
canPushCoe pi (Box {}) _ = False
|
||||
canPushCoe pi (E {}) _ = False
|
||||
canPushCoe pi (CloT {}) _ = False
|
||||
canPushCoe pi (DCloT {}) _ = False
|
||||
|
||||
|
||||
mutual
|
||||
|
|
@ -183,42 +184,42 @@ mutual
|
|||
||| an application whose head is an annotated lambda,
|
||||
||| a case expression whose head is an annotated constructor form, etc
|
||||
||| 4. a redundant annotation, or one whose term or type is reducible
|
||||
||| 5. a coercion `coe (𝑖 ⇒ A) @p @q s` where:
|
||||
||| 5. a coercion `coe (𝑖 ⇒ A) @p @pi s` where:
|
||||
||| a. `A` is reducible or a type constructor, or
|
||||
||| b. `𝑖` is not mentioned in `A`
|
||||
||| ([fixme] should be A‹0/𝑖› = A‹1/𝑖›), or
|
||||
||| c. `p = q`
|
||||
||| 6. a composition `comp A @p @q s @r {⋯}`
|
||||
||| where `p = q`, `r = 0`, or `r = 1`
|
||||
||| c. `p = pi`
|
||||
||| 6. a composition `comp A @p @pi s @r {⋯}`
|
||||
||| where `p = pi`, `r = 0`, or `r = 1`
|
||||
||| 7. a closure
|
||||
public export
|
||||
isRedexE : RedexTest Elim
|
||||
isRedexE defs (F {x, u, _}) {d, n} =
|
||||
isRedexE defs pi (F {x, u, _}) {d, n} =
|
||||
isJust $ lookupElim x u defs {d, n}
|
||||
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, _}) =
|
||||
isRedexE defs tag || isTagHead tag
|
||||
isRedexE defs (CaseNat {nat, _}) =
|
||||
isRedexE defs nat || isNatHead nat
|
||||
isRedexE defs (CaseBox {box, _}) =
|
||||
isRedexE defs box || isBoxHead box
|
||||
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 {ty = S _ (N _), _}) = True
|
||||
isRedexE defs (Coe {ty = S _ (Y ty), p, q, val, _}) =
|
||||
isRedexT defs ty || canPushCoe ty val || isYes (p `decEqv` q)
|
||||
isRedexE defs (Comp {ty, p, q, r, _}) =
|
||||
isRedexE _ pi (B {}) = False
|
||||
isRedexE defs pi (App {fun, _}) =
|
||||
isRedexE defs pi fun || isLamHead fun
|
||||
isRedexE defs pi (CasePair {pair, _}) =
|
||||
isRedexE defs pi pair || isPairHead pair
|
||||
isRedexE defs pi (CaseEnum {tag, _}) =
|
||||
isRedexE defs pi tag || isTagHead tag
|
||||
isRedexE defs pi (CaseNat {nat, _}) =
|
||||
isRedexE defs pi nat || isNatHead nat
|
||||
isRedexE defs pi (CaseBox {box, _}) =
|
||||
isRedexE defs pi box || isBoxHead box
|
||||
isRedexE defs pi (DApp {fun, arg, _}) =
|
||||
isRedexE defs pi fun || isDLamHead fun || isK arg
|
||||
isRedexE defs pi (Ann {tm, ty, _}) =
|
||||
isE tm || isRedexT defs pi tm || isRedexT defs SZero ty
|
||||
isRedexE defs pi (Coe {ty = S _ (N _), _}) = True
|
||||
isRedexE defs pi (Coe {ty = S _ (Y ty), p, q, val, _}) =
|
||||
isRedexT defs SZero ty || canPushCoe pi ty val || isYes (p `decEqv` q)
|
||||
isRedexE defs pi (Comp {ty, p, q, r, _}) =
|
||||
isYes (p `decEqv` q) || isK r
|
||||
isRedexE defs (TypeCase {ty, ret, _}) =
|
||||
isRedexE defs ty || isRedexT defs ret || isAnnTyCon ty
|
||||
isRedexE _ (CloE {}) = True
|
||||
isRedexE _ (DCloE {}) = True
|
||||
isRedexE defs pi (TypeCase {ty, ret, _}) =
|
||||
isRedexE defs pi ty || isRedexT defs pi ret || isAnnTyCon ty
|
||||
isRedexE _ _ (CloE {}) = True
|
||||
isRedexE _ _ (DCloE {}) = True
|
||||
|
||||
||| a reducible term
|
||||
|||
|
||||
|
|
@ -228,7 +229,7 @@ mutual
|
|||
||| 3. a closure
|
||||
public export
|
||||
isRedexT : RedexTest Term
|
||||
isRedexT _ (CloT {}) = True
|
||||
isRedexT _ (DCloT {}) = True
|
||||
isRedexT defs (E {e, _}) = isAnn e || isRedexE defs e
|
||||
isRedexT _ _ = False
|
||||
isRedexT _ _ (CloT {}) = True
|
||||
isRedexT _ _ (DCloT {}) = True
|
||||
isRedexT defs pi (E {e, _}) = isAnn e || isRedexE defs pi e
|
||||
isRedexT _ _ _ = False
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue