whnf actually reduces to whnf now (probably)
This commit is contained in:
parent
f097e1c091
commit
92617a2e4a
11 changed files with 693 additions and 679 deletions
|
|
@ -14,63 +14,40 @@ ClashE mode = ClashT mode `on` E
|
|||
|
||||
|
||||
public export
|
||||
record Env' q (isGlobal : q -> Type) where
|
||||
record Env where
|
||||
constructor MakeEnv
|
||||
defs : Definitions' q isGlobal
|
||||
mode : EqMode
|
||||
|
||||
public export
|
||||
0 Env : (q : Type) -> IsQty q => Type
|
||||
Env q = Env' q IsGlobal
|
||||
|
||||
public export
|
||||
0 HasEnv' : (q : Type) -> (q -> Type) -> (Type -> Type) -> Type
|
||||
HasEnv' q isGlobal = MonadReader (Env' q isGlobal)
|
||||
0 HasEnv : (Type -> Type) -> Type
|
||||
HasEnv = MonadReader Env
|
||||
|
||||
public export
|
||||
0 HasEnv : (q : Type) -> IsQty q => (Type -> Type) -> Type
|
||||
HasEnv q = HasEnv' q IsGlobal
|
||||
|
||||
|
||||
public export
|
||||
0 CanEqual' : (q : Type) -> (q -> Type) -> (Type -> Type) -> Type
|
||||
CanEqual' q isGlobal m = (HasErr q m, HasEnv' q isGlobal m)
|
||||
|
||||
public export
|
||||
0 CanEqual : (q : Type) -> IsQty q => (Type -> Type) -> Type
|
||||
CanEqual q = CanEqual' q IsGlobal
|
||||
0 CanEqual : (q : Type) -> (Type -> Type) -> Type
|
||||
CanEqual q m = (HasErr q m, HasEnv m)
|
||||
|
||||
|
||||
|
||||
private %inline
|
||||
mode : HasEnv' _ _ m => m EqMode
|
||||
mode : HasEnv m => m EqMode
|
||||
mode = asks mode
|
||||
|
||||
private %inline
|
||||
clashT : CanEqual' q _ m => Term q d n -> Term q d n -> m a
|
||||
clashT : CanEqual q m => Term q d n -> Term q d n -> m a
|
||||
clashT s t = throwError $ ClashT !mode s t
|
||||
|
||||
private %inline
|
||||
clashE : CanEqual' q _ m => Elim q d n -> Elim q d n -> m a
|
||||
clashE : CanEqual q m => Elim q d n -> Elim q d n -> m a
|
||||
clashE e f = throwError $ ClashE !mode e f
|
||||
|
||||
private %inline
|
||||
defE : HasEnv' q _ m => Name -> m (Maybe (Elim q d n))
|
||||
defE x = asks $ \env => do
|
||||
g <- lookup x env.defs
|
||||
pure $ (!g.term).get :# g.type.get
|
||||
|
||||
private %inline
|
||||
defT : HasEnv' q _ m => Name -> m (Maybe (Term q d n))
|
||||
defT x = map E <$> defE x
|
||||
|
||||
export %inline
|
||||
compareU' : HasEnv' q _ m => Universe -> Universe -> m Bool
|
||||
compareU' : HasEnv m => Universe -> Universe -> m Bool
|
||||
compareU' i j = pure $
|
||||
case !mode of Equal => i == j; Sub => i <= j
|
||||
|
||||
export %inline
|
||||
compareU : CanEqual' q _ m => Universe -> Universe -> m ()
|
||||
compareU : CanEqual q m => Universe -> Universe -> m ()
|
||||
compareU k l = unless !(compareU' k l) $
|
||||
throwError $ ClashU !mode k l
|
||||
|
||||
|
|
@ -79,185 +56,150 @@ compareD : HasErr q m => Dim d -> Dim d -> m ()
|
|||
compareD p q = unless (p == q) $
|
||||
throwError $ ClashD p q
|
||||
|
||||
mutual
|
||||
private covering
|
||||
compareTN' : CanEqual' q _ m => Eq q =>
|
||||
(s, t : Term q 0 n) ->
|
||||
(0 _ : NotRedexT s) -> (0 _ : NotRedexT t) -> m ()
|
||||
|
||||
compareTN' (E e) (E f) ps pt = compareE0 e f
|
||||
-- if either term is a def, try to unfold it
|
||||
compareTN' s@(E (F x)) t ps pt = do
|
||||
Just s' <- defT x | Nothing => clashT s t
|
||||
compareT0 s' t
|
||||
compareTN' s t@(E (F y)) ps pt = do
|
||||
Just t' <- defT y | Nothing => clashT s t
|
||||
compareT0 s t'
|
||||
compareTN' s@(E _) t _ _ = clashT s t
|
||||
parameters {0 isGlobal : _} (defs : Definitions' q isGlobal)
|
||||
mutual
|
||||
namespace Term
|
||||
export covering
|
||||
compareN' : CanEqual q m => Eq q =>
|
||||
(s, t : Term q 0 n) ->
|
||||
(0 _ : NotRedex defs s) -> (0 _ : NotRedex defs t) ->
|
||||
m ()
|
||||
|
||||
compareTN' (TYPE k) (TYPE l) _ _ = compareU k l
|
||||
compareTN' s@(TYPE _) t _ _ = clashT s t
|
||||
compareN' (TYPE k) (TYPE l) _ _ = compareU k l
|
||||
compareN' s@(TYPE _) t _ _ = clashT s t
|
||||
|
||||
compareTN' (Pi qty1 _ arg1 res1) (Pi qty2 _ arg2 res2) _ _ = do
|
||||
unless (qty1 == qty2) $ throwError $ ClashQ qty1 qty2
|
||||
compareT0 arg2 arg1 -- reversed for contravariant domain
|
||||
compareST0 res1 res2
|
||||
compareTN' s@(Pi {}) t _ _ = clashT s t
|
||||
compareN' (Pi qty1 _ arg1 res1) (Pi qty2 _ arg2 res2) _ _ = do
|
||||
unless (qty1 == qty2) $ throwError $ ClashQ qty1 qty2
|
||||
compare0 arg2 arg1 -- reversed for contravariant domain
|
||||
compare0 res1 res2
|
||||
compareN' s@(Pi {}) t _ _ = clashT s t
|
||||
|
||||
-- [todo] eta
|
||||
compareTN' (Lam _ body1) (Lam _ body2) _ _ =
|
||||
local {mode := Equal} $ compareST0 body1 body2
|
||||
compareTN' s@(Lam {}) t _ _ = clashT s t
|
||||
-- [todo] eta
|
||||
compareN' (Lam _ body1) (Lam _ body2) _ _ =
|
||||
local {mode := Equal} $ compare0 body1 body2
|
||||
compareN' s@(Lam {}) t _ _ = clashT s t
|
||||
|
||||
compareTN' (Eq _ ty1 l1 r1) (Eq _ ty2 l2 r2) _ _ = do
|
||||
compareDST0 ty1 ty2
|
||||
local {mode := Equal} $ do
|
||||
compareT0 l1 l2
|
||||
compareT0 r1 r2
|
||||
compareTN' s@(Eq {}) t _ _ = clashT s t
|
||||
compareN' (Eq _ ty1 l1 r1) (Eq _ ty2 l2 r2) _ _ = do
|
||||
compare0 ty1 ty2
|
||||
local {mode := Equal} $ do
|
||||
compare0 l1 l2
|
||||
compare0 r1 r2
|
||||
compareN' s@(Eq {}) t _ _ = clashT s t
|
||||
|
||||
compareTN' (DLam _ body1) (DLam _ body2) _ _ =
|
||||
compareDST0 body1 body2
|
||||
compareTN' s@(DLam {}) t _ _ = clashT s t
|
||||
compareN' (DLam _ body1) (DLam _ body2) _ _ =
|
||||
compare0 body1 body2
|
||||
compareN' s@(DLam {}) t _ _ = clashT s t
|
||||
|
||||
compareTN' (CloT {}) _ ps _ = void $ ps IsCloT
|
||||
compareTN' (DCloT {}) _ ps _ = void $ ps IsDCloT
|
||||
compareN' (E e) (E f) ne nf = compareN' e f (noOr2 ne) (noOr2 nf)
|
||||
compareN' s@(E e) t _ _ = clashT s t
|
||||
|
||||
private covering
|
||||
compareEN' : CanEqual' q _ m => Eq q =>
|
||||
(e, f : Elim q 0 n) ->
|
||||
(0 _ : NotRedexE e) -> (0 _ : NotRedexE f) -> m ()
|
||||
namespace Elim
|
||||
export covering
|
||||
compareN' : CanEqual q m => Eq q =>
|
||||
(e, f : Elim q 0 n) ->
|
||||
(0 _ : NotRedex defs e) -> (0 _ : NotRedex defs f) ->
|
||||
m ()
|
||||
|
||||
compareEN' e@(F x) f@(F y) _ _ =
|
||||
if x == y then pure () else
|
||||
case (!(defE x), !(defE y)) of
|
||||
(Nothing, Nothing) => clashE e f
|
||||
(s', t') => compareE0 (fromMaybe e s') (fromMaybe f t')
|
||||
compareEN' e@(F x) f _ _ = do
|
||||
Just e' <- defE x | Nothing => clashE e f
|
||||
compareE0 e' f
|
||||
compareEN' e f@(F y) _ _ = do
|
||||
Just f' <- defE y | Nothing => clashE e f
|
||||
compareE0 e f'
|
||||
compareN' e@(F x) f@(F y) _ _ =
|
||||
unless (x == y) $ clashE e f
|
||||
compareN' e@(F _) f _ _ = clashE e f
|
||||
|
||||
compareEN' e@(B i) f@(B j) _ _ =
|
||||
unless (i == j) $ clashE e f
|
||||
compareEN' e@(B _) f _ _ = clashE e f
|
||||
compareN' e@(B i) f@(B j) _ _ =
|
||||
unless (i == j) $ clashE e f
|
||||
compareN' e@(B _) f _ _ = clashE e f
|
||||
|
||||
-- [todo] tracking variance of functions? maybe???
|
||||
-- probably not
|
||||
compareEN' (fun1 :@ arg1) (fun2 :@ arg2) _ _ =
|
||||
local {mode := Equal} $ do
|
||||
compareE0 fun1 fun2
|
||||
compareT0 arg1 arg2
|
||||
compareEN' e@(_ :@ _) f _ _ = clashE e f
|
||||
-- [todo] tracking variance of functions? maybe???
|
||||
-- probably not
|
||||
compareN' (fun1 :@ arg1) (fun2 :@ arg2) _ _ =
|
||||
local {mode := Equal} $ do
|
||||
compare0 fun1 fun2
|
||||
compare0 arg1 arg2
|
||||
compareN' e@(_ :@ _) f _ _ = clashE e f
|
||||
|
||||
compareEN' (fun1 :% dim1) (fun2 :% dim2) _ _ = do
|
||||
compareE0 fun1 fun2
|
||||
compareD dim1 dim2
|
||||
compareEN' e@(_ :% _) f _ _ = clashE e f
|
||||
-- retain the mode unlike above because dimensions can't do
|
||||
-- anything that would mess up variance
|
||||
compareN' (fun1 :% dim1) (fun2 :% dim2) _ _ = do
|
||||
compare0 fun1 fun2
|
||||
compareD dim1 dim2
|
||||
compareN' e@(_ :% _) f _ _ = clashE e f
|
||||
|
||||
-- [todo] is always checking the types are equal correct?
|
||||
compareEN' (tm1 :# ty1) (tm2 :# ty2) _ _ = do
|
||||
compareT0 tm1 tm2
|
||||
local {mode := Equal} $ compareT0 ty1 ty2
|
||||
compareEN' e@(_ :# _) f _ _ = clashE e f
|
||||
|
||||
compareEN' (CloE {}) _ pe _ = void $ pe IsCloE
|
||||
compareEN' (DCloE {}) _ pe _ = void $ pe IsDCloE
|
||||
-- using the same mode for the type allows, e.g.
|
||||
-- A : ★₁ ≔ ★₀, B : ★₃ ≔ ★₂ ⊢ A <: B
|
||||
-- which, since A : ★₁ implies A : ★₃, should be fine
|
||||
compareN' (tm1 :# ty1) (tm2 :# ty2) _ _ = do
|
||||
compare0 tm1 tm2
|
||||
compare0 ty1 ty2
|
||||
compareN' e@(_ :# _) f _ _ = clashE e f
|
||||
|
||||
|
||||
private covering %inline
|
||||
compareTN : CanEqual' q _ m => Eq q =>
|
||||
NonRedexTerm q 0 n -> NonRedexTerm q 0 n -> m ()
|
||||
compareTN s t = compareTN' s.fst t.fst s.snd t.snd
|
||||
namespace Term
|
||||
export covering %inline
|
||||
compareN : CanEqual q m => Eq q =>
|
||||
NonRedexTerm q 0 n defs -> NonRedexTerm q 0 n defs -> m ()
|
||||
compareN s t = compareN' s.fst t.fst s.snd t.snd
|
||||
|
||||
private covering %inline
|
||||
compareEN : CanEqual' q _ m => Eq q =>
|
||||
NonRedexElim q 0 n -> NonRedexElim q 0 n -> m ()
|
||||
compareEN e f = compareEN' e.fst f.fst e.snd f.snd
|
||||
export covering %inline
|
||||
compare : CanEqual q m => Eq q =>
|
||||
DimEq d -> Term q d n -> Term q d n -> m ()
|
||||
compare eqs s t =
|
||||
for_ (splits eqs) $ \th => compare0 (s /// th) (t /// th)
|
||||
|
||||
export covering %inline
|
||||
compare0 : CanEqual q m => Eq q => Term q 0 n -> Term q 0 n -> m ()
|
||||
compare0 s t = compareN (whnf defs s) (whnf defs t)
|
||||
|
||||
namespace Elim
|
||||
covering %inline
|
||||
compareN : CanEqual q m => Eq q =>
|
||||
NonRedexElim q 0 n defs -> NonRedexElim q 0 n defs -> m ()
|
||||
compareN e f = compareN' e.fst f.fst e.snd f.snd
|
||||
|
||||
export covering %inline
|
||||
compare : CanEqual q m => Eq q =>
|
||||
DimEq d -> Elim q d n -> Elim q d n -> m ()
|
||||
compare eqs e f =
|
||||
for_ (splits eqs) $ \th => compare0 (e /// th) (f /// th)
|
||||
|
||||
export covering %inline
|
||||
compare0 : CanEqual q m => Eq q => Elim q 0 n -> Elim q 0 n -> m ()
|
||||
compare0 e f = compareN (whnf defs e) (whnf defs f)
|
||||
|
||||
namespace ScopeTerm
|
||||
export covering %inline
|
||||
compare0 : CanEqual q m => Eq q =>
|
||||
ScopeTerm q 0 n -> ScopeTerm q 0 n -> m ()
|
||||
compare0 (TUnused body0) (TUnused body1) = compare0 body0 body1
|
||||
compare0 body0 body1 = compare0 body0.term body1.term
|
||||
|
||||
namespace DScopeTerm
|
||||
export covering %inline
|
||||
compare0 : CanEqual q m => Eq q =>
|
||||
DScopeTerm q 0 n -> DScopeTerm q 0 n -> m ()
|
||||
compare0 (DUnused body0) (DUnused body1) = compare0 body0 body1
|
||||
compare0 body0 body1 = do
|
||||
compare0 body0.zero body1.zero
|
||||
compare0 body0.one body1.one
|
||||
|
||||
|
||||
export covering %inline
|
||||
compareT : CanEqual' q _ m => Eq q =>
|
||||
DimEq d -> Term q d n -> Term q d n -> m ()
|
||||
compareT eqs s t =
|
||||
for_ (splits eqs) $ \th => compareT0 (s /// th) (t /// th)
|
||||
namespace Term
|
||||
export covering %inline
|
||||
equal : HasErr q m => Eq q =>
|
||||
DimEq d -> Term q d n -> Term q d n -> m ()
|
||||
equal eqs s t {m} = runReaderT {m} (MakeEnv Equal) $ compare eqs s t
|
||||
|
||||
export covering %inline
|
||||
compareE : CanEqual' q _ m => Eq q =>
|
||||
DimEq d -> Elim q d n -> Elim q d n -> m ()
|
||||
compareE eqs e f =
|
||||
for_ (splits eqs) $ \th => compareE0 (e /// th) (f /// th)
|
||||
export covering %inline
|
||||
sub : HasErr q m => HasDefs' q _ m => Eq q =>
|
||||
DimEq d -> Term q d n -> Term q d n -> m ()
|
||||
sub eqs s t {m} = runReaderT {m} (MakeEnv Sub) $ compare eqs s t
|
||||
|
||||
namespace Elim
|
||||
export covering %inline
|
||||
equal : HasErr q m => Eq q =>
|
||||
DimEq d -> Elim q d n -> Elim q d n -> m ()
|
||||
equal eqs e f {m} = runReaderT {m} (MakeEnv Equal) $ compare eqs e f
|
||||
|
||||
export covering %inline
|
||||
compareT0 : CanEqual' q _ m => Eq q => Term q 0 n -> Term q 0 n -> m ()
|
||||
compareT0 s t = compareTN (whnfT s) (whnfT t)
|
||||
|
||||
export covering %inline
|
||||
compareE0 : CanEqual' q _ m => Eq q => Elim q 0 n -> Elim q 0 n -> m ()
|
||||
compareE0 e f = compareEN (whnfE e) (whnfE f)
|
||||
|
||||
export covering %inline
|
||||
compareST0 : CanEqual' q _ m => Eq q =>
|
||||
ScopeTerm q 0 n -> ScopeTerm q 0 n -> m ()
|
||||
compareST0 (TUnused body0) (TUnused body1) = compareT0 body0 body1
|
||||
compareST0 body0 body1 = compareT0 body0.term body1.term
|
||||
|
||||
export covering %inline
|
||||
compareDST0 : CanEqual' q _ m => Eq q =>
|
||||
DScopeTerm q 0 n -> DScopeTerm q 0 n -> m ()
|
||||
compareDST0 (DUnused body0) (DUnused body1) = compareT0 body0 body1
|
||||
compareDST0 body0 body1 = do
|
||||
compareT0 body0.zero body1.zero
|
||||
compareT0 body0.one body1.one
|
||||
|
||||
|
||||
private %inline
|
||||
into : HasErr q m => HasDefs' q isg m => Eq q =>
|
||||
(forall n. HasErr q n => HasEnv' q isg n => d -> a -> a -> n ()) ->
|
||||
EqMode -> d -> a -> a -> m ()
|
||||
into f mode eqs a b =
|
||||
runReaderT {m} (MakeEnv {mode, defs = !ask}) $ f eqs a b
|
||||
|
||||
export covering %inline
|
||||
equalTWith : HasErr q m => HasDefs' q _ m => Eq q =>
|
||||
DimEq d -> Term q d n -> Term q d n -> m ()
|
||||
equalTWith = into compareT Equal
|
||||
|
||||
export covering %inline
|
||||
equalEWith : HasErr q m => HasDefs' q _ m => Eq q =>
|
||||
DimEq d -> Elim q d n -> Elim q d n -> m ()
|
||||
equalEWith = into compareE Equal
|
||||
|
||||
export covering %inline
|
||||
subTWith : HasErr q m => HasDefs' q _ m => Eq q =>
|
||||
DimEq d -> Term q d n -> Term q d n -> m ()
|
||||
subTWith = into compareT Sub
|
||||
|
||||
export covering %inline
|
||||
subEWith : HasErr q m => HasDefs' q _ m => Eq q =>
|
||||
DimEq d -> Elim q d n -> Elim q d n -> m ()
|
||||
subEWith = into compareE Sub
|
||||
|
||||
|
||||
export covering %inline
|
||||
equalT : HasErr q m => HasDefs' q _ m => Eq q =>
|
||||
{d : Nat} -> Term q d n -> Term q d n -> m ()
|
||||
equalT = equalTWith DimEq.new
|
||||
|
||||
export covering %inline
|
||||
equalE : HasErr q m => HasDefs' q _ m => Eq q =>
|
||||
{d : Nat} -> Elim q d n -> Elim q d n -> m ()
|
||||
equalE = equalEWith DimEq.new
|
||||
|
||||
export covering %inline
|
||||
subT : HasErr q m => HasDefs' q _ m => Eq q =>
|
||||
{d : Nat} -> Term q d n -> Term q d n -> m ()
|
||||
subT = subTWith DimEq.new
|
||||
|
||||
export covering %inline
|
||||
subE : HasErr q m => HasDefs' q _ m => Eq q =>
|
||||
{d : Nat} -> Elim q d n -> Elim q d n -> m ()
|
||||
subE = subEWith DimEq.new
|
||||
export covering %inline
|
||||
sub : HasErr q m => HasDefs' q _ m => Eq q =>
|
||||
DimEq d -> Elim q d n -> Elim q d n -> m ()
|
||||
sub eqs e f {m} = runReaderT {m} (MakeEnv Sub) $ compare eqs e f
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue