type-case
This commit is contained in:
parent
868550327c
commit
a42e82c355
12 changed files with 334 additions and 93 deletions
|
|
@ -48,34 +48,9 @@ parameters (ctx : EqContext n)
|
|||
wrongType ty s = throw $ WrongType ctx ty s
|
||||
|
||||
|
||||
||| true if a term is syntactically a type, or is neutral.
|
||||
|||
|
||||
||| this function *doesn't* push substitutions, because its main use is as a
|
||||
||| `So` argument to skip cases that are already known to be nonsense. and
|
||||
||| the substitutions have already been pushed.
|
||||
public export %inline
|
||||
isTyCon : (t : Term {}) -> Bool
|
||||
isTyCon (TYPE {}) = True
|
||||
isTyCon (Pi {}) = True
|
||||
isTyCon (Lam {}) = False
|
||||
isTyCon (Sig {}) = True
|
||||
isTyCon (Pair {}) = False
|
||||
isTyCon (Enum {}) = True
|
||||
isTyCon (Tag {}) = False
|
||||
isTyCon (Eq {}) = True
|
||||
isTyCon (DLam {}) = False
|
||||
isTyCon Nat = True
|
||||
isTyCon Zero = False
|
||||
isTyCon (Succ {}) = False
|
||||
isTyCon (BOX {}) = True
|
||||
isTyCon (Box {}) = False
|
||||
isTyCon (E {}) = True
|
||||
isTyCon (CloT {}) = False
|
||||
isTyCon (DCloT {}) = False
|
||||
|
||||
public export %inline
|
||||
sameTyCon : (s, t : Term d n) ->
|
||||
(0 ts : So (isTyCon s)) => (0 tt : So (isTyCon t)) =>
|
||||
(0 ts : So (isTyConE s)) => (0 tt : So (isTyConE t)) =>
|
||||
Bool
|
||||
sameTyCon (TYPE {}) (TYPE {}) = True
|
||||
sameTyCon (TYPE {}) _ = False
|
||||
|
|
@ -132,8 +107,8 @@ parameters (defs : Definitions)
|
|||
export
|
||||
ensureTyCon : Has ErrorEff fs =>
|
||||
(ctx : EqContext n) -> (t : Term 0 n) ->
|
||||
Eff fs (So (isTyCon t))
|
||||
ensureTyCon ctx t = case nchoose $ isTyCon t of
|
||||
Eff fs (So (isTyConE t))
|
||||
ensureTyCon ctx t = case nchoose $ isTyConE t of
|
||||
Left y => pure y
|
||||
Right n => throw $ NotType (toTyContext ctx) (t // shift0 ctx.dimLen)
|
||||
|
||||
|
|
@ -164,7 +139,7 @@ parameters (defs : Definitions)
|
|||
private covering
|
||||
compare0' : EqContext n ->
|
||||
(ty, s, t : Term 0 n) ->
|
||||
(0 nty : NotRedex defs ty) => (0 tty : So (isTyCon ty)) =>
|
||||
(0 nty : NotRedex defs ty) => (0 tty : So (isTyConE ty)) =>
|
||||
(0 ns : NotRedex defs s) => (0 nt : NotRedex defs t) =>
|
||||
Equal ()
|
||||
compare0' ctx (TYPE _) s t = compareType ctx s t
|
||||
|
|
@ -298,8 +273,8 @@ parameters (defs : Definitions)
|
|||
|
||||
private covering
|
||||
compareType' : EqContext n -> (s, t : Term 0 n) ->
|
||||
(0 ns : NotRedex defs s) => (0 ts : So (isTyCon s)) =>
|
||||
(0 nt : NotRedex defs t) => (0 tt : So (isTyCon t)) =>
|
||||
(0 ns : NotRedex defs s) => (0 ts : So (isTyConE s)) =>
|
||||
(0 nt : NotRedex defs t) => (0 tt : So (isTyConE t)) =>
|
||||
(0 st : So (sameTyCon s t)) =>
|
||||
Equal ()
|
||||
-- equality is the same as subtyping, except with the
|
||||
|
|
@ -369,8 +344,9 @@ parameters (defs : Definitions)
|
|||
(0 ne : NotRedex defs e) ->
|
||||
Equal (Term 0 n)
|
||||
computeElimType ctx (F x) _ = do
|
||||
defs <- lookupFree' defs x
|
||||
pure $ injectT ctx defs.type
|
||||
def <- lookupFree x defs
|
||||
let Val n = ctx.termLen
|
||||
pure $ def.type
|
||||
computeElimType ctx (B i) _ = pure $ ctx.tctx !! i
|
||||
computeElimType ctx (f :@ s) ne = do
|
||||
(_, arg, res) <- expectPiE defs ctx !(computeElimType ctx f (noOr1 ne))
|
||||
|
|
@ -382,6 +358,7 @@ parameters (defs : Definitions)
|
|||
computeElimType ctx (f :% p) ne = do
|
||||
(ty, _, _) <- expectEqE defs ctx !(computeElimType ctx f (noOr1 ne))
|
||||
pure $ dsub1 ty p
|
||||
computeElimType ctx (TypeCase {ret, _}) _ = pure ret
|
||||
computeElimType ctx (_ :# ty) _ = pure ty
|
||||
|
||||
private covering
|
||||
|
|
@ -503,6 +480,41 @@ parameters (defs : Definitions)
|
|||
bigger : forall a. a -> a -> Equal a
|
||||
bigger l r = mode <&> \case Super => l; _ => r
|
||||
|
||||
compare0' ctx (TypeCase ty1 ret1 univ1 pi1 sig1 enum1 eq1 nat1 box1)
|
||||
(TypeCase ty2 ret2 univ2 pi2 sig2 enum2 eq2 nat2 box2)
|
||||
ne _ =
|
||||
local_ Equal $ do
|
||||
compare0 ctx ty1 ty2
|
||||
u <- expectTYPEE defs ctx =<< computeElimType ctx ty1 (noOr1 ne)
|
||||
compareType ctx ret1 ret2
|
||||
compare0 ctx univ1 univ2 ret1
|
||||
let [< piA, piB] = pi1.names
|
||||
piCtx = extendTyN
|
||||
[< (Zero, piA, TYPE u),
|
||||
(Zero, piB, Arr Zero (BVT 0) (TYPE u))] ctx
|
||||
ret1_2 = weakT ret1 {by = 2}
|
||||
compare0 piCtx pi1.term pi2.term ret1_2
|
||||
let [< sigA, sigB] = sig1.names
|
||||
sigCtx = extendTyN
|
||||
[< (Zero, sigA, TYPE u),
|
||||
(Zero, sigB, Arr Zero (BVT 0) (TYPE u))] ctx
|
||||
compare0 sigCtx sig1.term sig2.term ret1_2
|
||||
compare0 ctx enum1 enum2 ret1
|
||||
let [< eqA0, eqA1, eqA, eqL, eqR] = eq1.names
|
||||
eqCtx = extendTyN
|
||||
[< (Zero, eqA0, TYPE u),
|
||||
(Zero, eqA1, TYPE u),
|
||||
(Zero, eqA, Eq0 (TYPE u) (BVT 1) (BVT 0)),
|
||||
(Zero, eqL, BVT 2),
|
||||
(Zero, eqR, BVT 2)] ctx
|
||||
ret1_5 = weakT ret1 {by = 5}
|
||||
compare0 eqCtx eq1.term eq2.term ret1_5
|
||||
compare0 ctx nat1 nat2 ret1
|
||||
let boxCtx = extendTy Zero box1.name (TYPE u) ctx
|
||||
ret1_1 = weakT ret1
|
||||
compare0 boxCtx box1.term box2.term ret1_1
|
||||
compare0' ctx e@(TypeCase {}) f _ _ = clashE ctx e f
|
||||
|
||||
compare0' ctx (s :# a) f _ _ = Term.compare0 ctx a s (E f)
|
||||
compare0' ctx e (t :# b) _ _ = Term.compare0 ctx b (E e) t
|
||||
compare0' ctx e@(_ :# _) f _ _ = clashE ctx e f
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue