make uses of eff more consistent
This commit is contained in:
parent
8264a1bb81
commit
4b6b3853a1
5 changed files with 81 additions and 76 deletions
|
|
@ -13,15 +13,16 @@ EqModeState : Type -> Type
|
|||
EqModeState = State EqMode
|
||||
|
||||
public export
|
||||
Equal : Type -> Type
|
||||
Equal = Eff [ErrorEff, DefsReader, NameGen]
|
||||
Equal : List (Type -> Type)
|
||||
Equal = [ErrorEff, DefsReader, NameGen]
|
||||
|
||||
public export
|
||||
Equal_ : Type -> Type
|
||||
Equal_ = Eff [ErrorEff, NameGen, EqModeState]
|
||||
EqualInner : List (Type -> Type)
|
||||
EqualInner = [ErrorEff, NameGen, EqModeState]
|
||||
|
||||
export
|
||||
runEqualWith_ : EqMode -> NameSuf -> Equal_ a -> (Either Error a, NameSuf)
|
||||
runEqualWith_ : EqMode -> NameSuf ->
|
||||
Eff EqualInner a -> (Either Error a, NameSuf)
|
||||
runEqualWith_ mode suf act =
|
||||
extract $
|
||||
runNameGenWith suf $
|
||||
|
|
@ -29,12 +30,13 @@ runEqualWith_ mode suf act =
|
|||
evalState mode act
|
||||
|
||||
export
|
||||
runEqual_ : EqMode -> Equal_ a -> Either Error a
|
||||
runEqual_ mode act = fst $ runEqualWith_ mode 0 act
|
||||
runEqualInner : EqMode -> Eff EqualInner a -> Either Error a
|
||||
runEqualInner mode act = fst $ runEqualWith_ mode 0 act
|
||||
|
||||
|
||||
export
|
||||
runEqualWith : NameSuf -> Definitions -> Equal a -> (Either Error a, NameSuf)
|
||||
runEqualWith : NameSuf -> Definitions ->
|
||||
Eff Equal a -> (Either Error a, NameSuf)
|
||||
runEqualWith suf defs act =
|
||||
extract $
|
||||
runStateAt GEN suf $
|
||||
|
|
@ -42,7 +44,7 @@ runEqualWith suf defs act =
|
|||
runExcept act
|
||||
|
||||
export
|
||||
runEqual : Definitions -> Equal a -> Either Error a
|
||||
runEqual : Definitions -> Eff Equal a -> Either Error a
|
||||
runEqual defs act = fst $ runEqualWith 0 defs act
|
||||
|
||||
|
||||
|
|
@ -53,19 +55,19 @@ mode = get
|
|||
|
||||
parameters (loc : Loc) (ctx : EqContext n)
|
||||
private %inline
|
||||
clashT : Term 0 n -> Term 0 n -> Term 0 n -> Equal_ a
|
||||
clashT : Term 0 n -> Term 0 n -> Term 0 n -> Eff EqualInner a
|
||||
clashT ty s t = throw $ ClashT loc ctx !mode ty s t
|
||||
|
||||
private %inline
|
||||
clashTy : Term 0 n -> Term 0 n -> Equal_ a
|
||||
clashTy : Term 0 n -> Term 0 n -> Eff EqualInner a
|
||||
clashTy s t = throw $ ClashTy loc ctx !mode s t
|
||||
|
||||
private %inline
|
||||
clashE : Elim 0 n -> Elim 0 n -> Equal_ a
|
||||
clashE : Elim 0 n -> Elim 0 n -> Eff EqualInner a
|
||||
clashE e f = throw $ ClashE loc ctx !mode e f
|
||||
|
||||
private %inline
|
||||
wrongType : Term 0 n -> Term 0 n -> Equal_ a
|
||||
wrongType : Term 0 n -> Term 0 n -> Eff EqualInner a
|
||||
wrongType ty s = throw $ WrongType loc ctx ty s
|
||||
|
||||
|
||||
|
|
@ -101,7 +103,8 @@ sameTyCon (E {}) _ = False
|
|||
||| * an enum type is a subsingleton if it has zero or one tags.
|
||||
||| * a box type is a subsingleton if its content is
|
||||
public export covering
|
||||
isSubSing : {n : Nat} -> Definitions -> EqContext n -> Term 0 n -> Equal_ Bool
|
||||
isSubSing : {n : Nat} -> Definitions -> EqContext n -> Term 0 n ->
|
||||
Eff EqualInner Bool
|
||||
isSubSing defs ctx ty0 = do
|
||||
Element ty0 nc <- whnf defs ctx ty0.loc ty0
|
||||
case ty0 of
|
||||
|
|
@ -141,7 +144,7 @@ ensureTyCon loc ctx t = case nchoose $ isTyConE t of
|
|||
private covering
|
||||
computeElimTypeE : (defs : Definitions) -> EqContext n ->
|
||||
(e : Elim 0 n) -> (0 ne : NotRedex defs e) =>
|
||||
Equal_ (Term 0 n)
|
||||
Eff EqualInner (Term 0 n)
|
||||
computeElimTypeE defs ectx e =
|
||||
let Val n = ectx.termLen in
|
||||
lift $ computeElimType defs (toWhnfContext ectx) e
|
||||
|
|
@ -154,7 +157,7 @@ parameters (defs : Definitions)
|
|||
|||
|
||||
||| ⚠ **assumes that `s`, `t` have already been checked against `ty`**. ⚠
|
||||
export covering %inline
|
||||
compare0 : EqContext n -> (ty, s, t : Term 0 n) -> Equal_ ()
|
||||
compare0 : EqContext n -> (ty, s, t : Term 0 n) -> Eff EqualInner ()
|
||||
compare0 ctx ty s t =
|
||||
wrapErr (WhileComparingT ctx !mode ty s t) $ do
|
||||
let Val n = ctx.termLen
|
||||
|
|
@ -175,7 +178,7 @@ parameters (defs : Definitions)
|
|||
(ty, s, t : Term 0 n) ->
|
||||
(0 _ : NotRedex defs ty) => (0 _ : So (isTyConE ty)) =>
|
||||
(0 _ : NotRedex defs s) => (0 _ : NotRedex defs t) =>
|
||||
Equal_ ()
|
||||
Eff EqualInner ()
|
||||
compare0' ctx (TYPE {}) s t = compareType ctx s t
|
||||
|
||||
compare0' ctx ty@(Pi {qty, arg, res, _}) s t {n} = local_ Equal $
|
||||
|
|
@ -201,7 +204,7 @@ parameters (defs : Definitions)
|
|||
ctx' : EqContext (S n)
|
||||
ctx' = extendTy qty res.name arg ctx
|
||||
|
||||
eta : Loc -> Elim 0 n -> ScopeTerm 0 n -> Equal_ ()
|
||||
eta : Loc -> Elim 0 n -> ScopeTerm 0 n -> Eff EqualInner ()
|
||||
eta _ e (S _ (Y b)) = compare0 ctx' res.term (toLamBody e) b
|
||||
eta loc e (S _ (N _)) = clashT loc ctx ty s t
|
||||
|
||||
|
|
@ -297,7 +300,7 @@ parameters (defs : Definitions)
|
|||
||| compares two types, using the current variance `mode` for universes.
|
||||
||| fails if they are not types, even if they would happen to be equal.
|
||||
export covering %inline
|
||||
compareType : EqContext n -> (s, t : Term 0 n) -> Equal_ ()
|
||||
compareType : EqContext n -> (s, t : Term 0 n) -> Eff EqualInner ()
|
||||
compareType ctx s t = do
|
||||
let Val n = ctx.termLen
|
||||
Element s' _ <- whnf defs ctx s.loc s
|
||||
|
|
@ -313,7 +316,7 @@ parameters (defs : Definitions)
|
|||
(0 _ : NotRedex defs s) => (0 _ : So (isTyConE s)) =>
|
||||
(0 _ : NotRedex defs t) => (0 _ : So (isTyConE t)) =>
|
||||
(0 _ : So (sameTyCon s t)) =>
|
||||
Equal_ ()
|
||||
Eff EqualInner ()
|
||||
-- equality is the same as subtyping, except with the
|
||||
-- "≤" in the TYPE rule being replaced with "="
|
||||
compareType' ctx a@(TYPE k {}) (TYPE l {}) =
|
||||
|
|
@ -384,7 +387,7 @@ parameters (defs : Definitions)
|
|||
||| ⚠ **assumes that they have both been typechecked, and have
|
||||
||| equal types.** ⚠
|
||||
export covering %inline
|
||||
compare0 : EqContext n -> (e, f : Elim 0 n) -> Equal_ ()
|
||||
compare0 : EqContext n -> (e, f : Elim 0 n) -> Eff EqualInner ()
|
||||
compare0 ctx e f =
|
||||
wrapErr (WhileComparingE ctx !mode e f) $ do
|
||||
let Val n = ctx.termLen
|
||||
|
|
@ -397,7 +400,7 @@ parameters (defs : Definitions)
|
|||
compare0' : EqContext n ->
|
||||
(e, f : Elim 0 n) ->
|
||||
(0 ne : NotRedex defs e) -> (0 nf : NotRedex defs f) ->
|
||||
Equal_ ()
|
||||
Eff EqualInner ()
|
||||
|
||||
compare0' ctx e@(F x u _) f@(F y v _) _ _ =
|
||||
unless (x == y && u == v) $ clashE e.loc ctx e f
|
||||
|
|
@ -457,7 +460,8 @@ parameters (defs : Definitions)
|
|||
compare0 ctx (sub1 eret $ Ann (Tag t l.loc) ety l.loc) l r
|
||||
expectEqualQ eloc epi fpi
|
||||
where
|
||||
lookupArm : Loc -> TagVal -> CaseEnumArms d n -> Equal_ (Term d n)
|
||||
lookupArm : Loc -> TagVal -> CaseEnumArms d n ->
|
||||
Eff EqualInner (Term d n)
|
||||
lookupArm loc t arms = case lookup t arms of
|
||||
Just arm => pure arm
|
||||
Nothing => throw $ TagNotIn loc t (fromList $ keys arms)
|
||||
|
|
@ -570,7 +574,7 @@ parameters (defs : Definitions)
|
|||
(ret : Term 0 n) -> (u : Universe) ->
|
||||
(b1, b2 : Maybe (TypeCaseArmBody k 0 n)) ->
|
||||
(def : Term 0 n) ->
|
||||
Equal_ ()
|
||||
Eff EqualInner ()
|
||||
compareArm {b1 = Nothing, b2 = Nothing, _} = pure ()
|
||||
compareArm ctx k ret u b1 b2 def =
|
||||
let def = SN def in
|
||||
|
|
@ -580,7 +584,7 @@ parameters (defs : Definitions)
|
|||
compareArm_ : EqContext n -> (k : TyConKind) ->
|
||||
(ret : Term 0 n) -> (u : Universe) ->
|
||||
(b1, b2 : TypeCaseArmBody k 0 n) ->
|
||||
Equal_ ()
|
||||
Eff EqualInner ()
|
||||
compareArm_ ctx KTYPE ret u b1 b2 =
|
||||
compare0 ctx ret b1.term b2.term
|
||||
|
||||
|
|
@ -626,8 +630,8 @@ parameters (loc : Loc) (ctx : TyContext d n)
|
|||
|
||||
parameters (mode : EqMode)
|
||||
private
|
||||
fromEqual_ : Equal_ a -> Equal a
|
||||
fromEqual_ act = lift $ evalState mode act
|
||||
fromInner : Eff EqualInner a -> Eff Equal a
|
||||
fromInner act = lift $ evalState mode act
|
||||
|
||||
private
|
||||
eachFace : Applicative f => (EqContext n -> DSubst d 0 -> f ()) -> f ()
|
||||
|
|
@ -635,18 +639,22 @@ parameters (loc : Loc) (ctx : TyContext d n)
|
|||
for_ (splits loc ctx.dctx) $ \th => act (makeEqContext ctx th) th
|
||||
|
||||
private
|
||||
runCompare : (Definitions -> EqContext n -> DSubst d 0 -> Equal_ ()) ->
|
||||
Equal ()
|
||||
runCompare act = fromEqual_ $ eachFace $ act !(askAt DEFS)
|
||||
CompareAction : Nat -> Nat -> Type
|
||||
CompareAction d n =
|
||||
Definitions -> EqContext n -> DSubst d 0 -> Eff EqualInner ()
|
||||
|
||||
private
|
||||
runCompare : CompareAction d n -> Eff Equal ()
|
||||
runCompare act = fromInner $ eachFace $ act !(askAt DEFS)
|
||||
|
||||
namespace Term
|
||||
export covering
|
||||
compare : (ty, s, t : Term d n) -> Equal ()
|
||||
compare : (ty, s, t : Term d n) -> Eff Equal ()
|
||||
compare ty s t = runCompare $ \defs, ectx, th =>
|
||||
compare0 defs ectx (ty // th) (s // th) (t // th)
|
||||
|
||||
export covering
|
||||
compareType : (s, t : Term d n) -> Equal ()
|
||||
compareType : (s, t : Term d n) -> Eff Equal ()
|
||||
compareType s t = runCompare $ \defs, ectx, th =>
|
||||
compareType defs ectx (s // th) (t // th)
|
||||
|
||||
|
|
@ -654,26 +662,26 @@ parameters (loc : Loc) (ctx : TyContext d n)
|
|||
||| you don't have to pass the type in but the arguments must still be
|
||||
||| of the same type!!
|
||||
export covering
|
||||
compare : (e, f : Elim d n) -> Equal ()
|
||||
compare : (e, f : Elim d n) -> Eff Equal ()
|
||||
compare e f = runCompare $ \defs, ectx, th =>
|
||||
compare0 defs ectx (e // th) (f // th)
|
||||
|
||||
namespace Term
|
||||
export covering %inline
|
||||
equal, sub, super : (ty, s, t : Term d n) -> Equal ()
|
||||
equal, sub, super : (ty, s, t : Term d n) -> Eff Equal ()
|
||||
equal = compare Equal
|
||||
sub = compare Sub
|
||||
super = compare Super
|
||||
|
||||
export covering %inline
|
||||
equalType, subtype, supertype : (s, t : Term d n) -> Equal ()
|
||||
equalType, subtype, supertype : (s, t : Term d n) -> Eff Equal ()
|
||||
equalType = compareType Equal
|
||||
subtype = compareType Sub
|
||||
supertype = compareType Super
|
||||
|
||||
namespace Elim
|
||||
export covering %inline
|
||||
equal, sub, super : (e, f : Elim d n) -> Equal ()
|
||||
equal, sub, super : (e, f : Elim d n) -> Eff Equal ()
|
||||
equal = compare Equal
|
||||
sub = compare Sub
|
||||
super = compare Super
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue