296 lines
9.6 KiB
Idris
296 lines
9.6 KiB
Idris
module Quox.Equal
|
|
|
|
import public Quox.Syntax
|
|
import public Quox.Definition
|
|
import public Quox.Typing
|
|
import public Control.Monad.Either
|
|
import public Control.Monad.Reader
|
|
import Data.Maybe
|
|
|
|
|
|
private %inline
|
|
ClashE : EqMode -> Term q d n -> Elim q d n -> Elim q d n -> Error q
|
|
ClashE mode ty = ClashT mode ty `on` E
|
|
|
|
|
|
public export
|
|
record Env where
|
|
constructor MakeEnv
|
|
mode : EqMode
|
|
|
|
|
|
public export
|
|
0 HasEnv : (Type -> Type) -> Type
|
|
HasEnv = MonadReader Env
|
|
|
|
public export
|
|
0 CanEqual : (q : Type) -> (Type -> Type) -> Type
|
|
CanEqual q m = (HasErr q m, HasEnv m)
|
|
|
|
|
|
|
|
private %inline
|
|
mode : HasEnv m => m EqMode
|
|
mode = asks mode
|
|
|
|
private %inline
|
|
clashT : CanEqual q m => Term q d n -> Term q d n -> Term q d n -> m a
|
|
clashT ty s t = throwError $ ClashT !mode ty s t
|
|
|
|
private %inline
|
|
clashE : CanEqual q m => Elim q d n -> Elim q d n -> m a
|
|
clashE e f = throwError $ ClashE !mode e f
|
|
|
|
|
|
public export %inline
|
|
isType : (t : Term {}) -> Bool
|
|
isType (TYPE {}) = True
|
|
isType (Pi {}) = True
|
|
isType (Lam {}) = False
|
|
isType (Sig {}) = True
|
|
isType (Pair {}) = False
|
|
isType (Eq {}) = True
|
|
isType (DLam {}) = False
|
|
isType (E {}) = True
|
|
isType (CloT {}) = False
|
|
isType (DCloT {}) = False
|
|
|
|
|
|
parameters {auto _ : HasErr q m}
|
|
export %inline
|
|
ensure : (a -> Error q) -> (p : a -> Bool) -> (t : a) -> m (So (p t))
|
|
ensure e p t = case nchoose $ p t of
|
|
Left y => pure y
|
|
Right n => throwError $ e t
|
|
|
|
export %inline
|
|
ensureType : (t : Term q d n) -> m (So (isType t))
|
|
ensureType = ensure NotType isType
|
|
|
|
parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, Eq q)}
|
|
mutual
|
|
-- [todo] remove cumulativity & subtyping, it's too much of a pain
|
|
-- mugen might be good
|
|
namespace Term
|
|
export covering %inline
|
|
compare0 : TContext q 0 n -> (ty, s, t : Term q 0 n) -> m ()
|
|
compare0 ctx ty s t = do
|
|
let Element ty nty = whnfD defs ty
|
|
Element s ns = whnfD defs s
|
|
Element t nt = whnfD defs t
|
|
tty <- ensureType ty
|
|
compare0' ctx ty s t
|
|
|
|
private %inline
|
|
toLamBody : Elim q d n -> Term q d (S n)
|
|
toLamBody e = E $ weakE e :@ BVT 0
|
|
|
|
private covering
|
|
compare0' : TContext q 0 n ->
|
|
(ty, s, t : Term q 0 n) ->
|
|
(0 nty : NotRedex defs ty) => (0 tty : So (isType ty)) =>
|
|
(0 ns : NotRedex defs s) => (0 nt : NotRedex defs t) =>
|
|
m ()
|
|
compare0' ctx (TYPE _) s t = compareType ctx s t
|
|
|
|
compare0' ctx ty@(Pi {arg, res, _}) s t = local {mode := Equal} $
|
|
let ctx' = ctx :< arg
|
|
eta : Elim q 0 ? -> ScopeTerm q 0 ? -> m ()
|
|
eta e (TUsed b) = compare0 ctx' res.term (toLamBody e) b
|
|
eta e (TUnused _) = clashT ty s t
|
|
in
|
|
case (s, t) of
|
|
(Lam _ b1, Lam _ b2) => compare0 ctx' res.term b1.term b2.term
|
|
(E e, Lam _ b) => eta e b
|
|
(Lam _ b, E e) => eta e b
|
|
(E e, E f) => ignore $ compare0 ctx e f
|
|
_ => throwError $ WrongType ty s t
|
|
|
|
compare0' ctx ty@(Sig {fst, snd, _}) s t = local {mode := Equal} $
|
|
-- no η (no fst/snd for π ≱ 0), so…
|
|
-- [todo] η for π ≥ 0 maybe
|
|
case (s, t) of
|
|
(Pair sFst sSnd, Pair tFst tSnd) => do
|
|
compare0 ctx fst sFst tFst
|
|
compare0 ctx (sub1 snd (sFst :# fst)) sSnd tSnd
|
|
_ => throwError $ WrongType ty s t
|
|
|
|
-- ✨ uip ✨
|
|
compare0' _ (Eq {}) _ _ = pure ()
|
|
|
|
compare0' ctx ty@(E _) s t = do
|
|
-- a neutral type can only be inhabited by neutral values
|
|
-- e.g. an abstract value in an abstract type, bound variables, …
|
|
E e <- pure s | _ => throwError $ WrongType ty s t
|
|
E f <- pure t | _ => throwError $ WrongType ty s t
|
|
ignore $ compare0 ctx e f
|
|
|
|
export covering
|
|
compareType : TContext q 0 n -> (s, t : Term q 0 n) -> m ()
|
|
compareType ctx s t = do
|
|
let Element s ns = whnfD defs s
|
|
Element t nt = whnfD defs t
|
|
sok <- ensureType s
|
|
tok <- ensureType t
|
|
compareType' ctx s t
|
|
|
|
private covering
|
|
compareType' : TContext q 0 n -> (s, t : Term q 0 n) ->
|
|
(0 ns : NotRedex defs s) => (0 ts : So (isType s)) =>
|
|
(0 nt : NotRedex defs t) => (0 tt : So (isType t)) =>
|
|
m ()
|
|
compareType' ctx s t = do
|
|
let err : m () = clashT (TYPE UAny) s t
|
|
case s of
|
|
TYPE k => do
|
|
TYPE l <- pure t | _ => err
|
|
expectModeU !mode k l
|
|
|
|
Pi {qty = sQty, arg = sArg, res = sRes, _} => do
|
|
Pi {qty = tQty, arg = tArg, res = tRes, _} <- pure t | _ => err
|
|
expectEqualQ sQty tQty
|
|
compareType ctx tArg sArg -- contra
|
|
-- [todo] is using sArg also ok for subtyping?
|
|
compareType (ctx :< sArg) sRes.term tRes.term
|
|
|
|
Sig {fst = sFst, snd = sSnd, _} => do
|
|
Sig {fst = tFst, snd = tSnd, _} <- pure t | _ => err
|
|
compareType ctx sFst tFst
|
|
compareType (ctx :< sFst) sSnd.term tSnd.term
|
|
|
|
Eq {ty = sTy, l = sl, r = sr, _} => do
|
|
Eq {ty = tTy, l = tl, r = tr, _} <- pure t | _ => err
|
|
compareType ctx sTy.zero tTy.zero
|
|
compareType ctx sTy.one tTy.one
|
|
local {mode := Equal} $ do
|
|
compare0 ctx sTy.zero sl tl
|
|
compare0 ctx sTy.one sr tr
|
|
|
|
E e => do
|
|
E f <- pure t | _ => err
|
|
-- no fanciness needed here cos anything other than a neutral
|
|
-- has been inlined by whnfD
|
|
ignore $ compare0 ctx e f
|
|
|
|
namespace Elim
|
|
export covering %inline
|
|
compare0 : TContext q 0 n -> (e, f : Elim q 0 n) -> m (Term q 0 n)
|
|
compare0 ctx e f =
|
|
let Element e ne = whnfD defs e
|
|
Element f nf = whnfD defs f
|
|
in
|
|
compare0' ctx e f
|
|
|
|
private
|
|
isSubSing : Term {} -> Bool
|
|
isSubSing (TYPE _) = False
|
|
isSubSing (Pi {res, _}) = isSubSing res.term
|
|
isSubSing (Lam {}) = False
|
|
isSubSing (Sig {fst, snd, _}) = isSubSing fst && isSubSing snd.term
|
|
isSubSing (Pair {}) = False
|
|
isSubSing (Eq {}) = True
|
|
isSubSing (DLam {}) = False
|
|
isSubSing (E e) = False
|
|
isSubSing (CloT tm th) = False
|
|
isSubSing (DCloT tm th) = False
|
|
|
|
private covering
|
|
compare0' : TContext q 0 n ->
|
|
(e, f : Elim q 0 n) ->
|
|
(0 ne : NotRedex defs e) => (0 nf : NotRedex defs f) =>
|
|
m (Term q 0 n)
|
|
compare0' _ e@(F x) f@(F y) = do
|
|
d <- lookupFree' defs x
|
|
let ty = d.type
|
|
-- [fixme] there is a better way to do this for sure
|
|
unless (isSubSing ty.get0 || x == y) $ clashE e f
|
|
pure ty.get
|
|
compare0' _ e@(F _) f = clashE e f
|
|
|
|
compare0' ctx e@(B i) f@(B j) = do
|
|
let ty = ctx !! i
|
|
-- [fixme] there is a better way to do this for sure
|
|
unless (isSubSing ty || i == j) $ clashE e f
|
|
pure ty
|
|
compare0' _ e@(B _) f = clashE e f
|
|
|
|
compare0' ctx (e :@ s) (f :@ t) = local {mode := Equal} $ do
|
|
Pi {arg, res, _} <- compare0 ctx e f
|
|
| ty => throwError $ ExpectedPi ty
|
|
compare0 ctx arg s t
|
|
pure $ sub1 res (s :# arg)
|
|
compare0' _ e@(_ :@ _) f = clashE e f
|
|
|
|
compare0' ctx (CasePair epi e _ eret _ _ ebody)
|
|
(CasePair fpi f _ fret _ _ fbody) =
|
|
local {mode := Equal} $ do
|
|
ty@(Sig {fst, snd, _}) <- compare0 ctx e f
|
|
| ty => throwError $ ExpectedSig ty
|
|
unless (epi == fpi) $ throwError $ ClashQ epi fpi
|
|
compareType (ctx :< ty) eret.term fret.term
|
|
compare0 (ctx :< fst :< snd.term) (substCasePairRet ty eret)
|
|
ebody.term fbody.term
|
|
pure $ sub1 eret e
|
|
compare0' _ e@(CasePair {}) f = clashE e f
|
|
|
|
compare0' ctx (e :% p) (f :% q) = local {mode := Equal} $ do
|
|
Eq {ty, _} <- compare0 ctx e f
|
|
| ty => throwError $ ExpectedEq ty
|
|
unless (p == q) $ throwError $ ClashD p q
|
|
pure $ dsub1 ty p
|
|
compare0' _ e@(_ :% _) f = clashE e f
|
|
|
|
compare0' ctx (s :# a) (t :# b) = do
|
|
compareType ctx a b
|
|
compare0 ctx a s t
|
|
pure b
|
|
compare0' _ e@(_ :# _) f = clashE e f
|
|
|
|
|
|
parameters {auto _ : (HasDefs' q _ m, HasErr q m, Eq q)}
|
|
(eq : DimEq d) (ctx : TContext q d n)
|
|
parameters (mode : EqMode)
|
|
namespace Term
|
|
export covering
|
|
compare : (ty, s, t : Term q d n) -> m ()
|
|
compare ty s t = do
|
|
defs <- ask
|
|
runReaderT {m} (MakeEnv {mode}) $
|
|
for_ (splits eq) $ \th =>
|
|
compare0 defs (map (/// th) ctx) (ty /// th) (s /// th) (t /// th)
|
|
|
|
export covering
|
|
compareType : (s, t : Term q d n) -> m ()
|
|
compareType s t = do
|
|
defs <- ask
|
|
runReaderT {m} (MakeEnv {mode}) $
|
|
for_ (splits eq) $ \th =>
|
|
compareType defs (map (/// th) ctx) (s /// th) (t /// th)
|
|
|
|
namespace Elim
|
|
-- can't return the type since it might be different in each dsubst ☹
|
|
export covering %inline
|
|
compare : (e, f : Elim q d n) -> m ()
|
|
compare e f = do
|
|
defs <- ask
|
|
runReaderT {m} (MakeEnv {mode}) $
|
|
for_ (splits eq) $ \th =>
|
|
ignore $ compare0 defs (map (/// th) ctx) (e /// th) (f /// th)
|
|
|
|
namespace Term
|
|
export covering %inline
|
|
equal, sub : (ty, s, t : Term q d n) -> m ()
|
|
equal = compare Equal
|
|
sub = compare Sub
|
|
|
|
export covering %inline
|
|
equalType, subtype : (s, t : Term q d n) -> m ()
|
|
equalType = compareType Equal
|
|
subtype = compareType Sub
|
|
|
|
namespace Elim
|
|
export covering %inline
|
|
equal, sub : (e, f : Elim q d n) -> m ()
|
|
equal = compare Equal
|
|
sub = compare Sub
|