quox/lib/Quox/Equal.idr

320 lines
11 KiB
Idris
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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
isTyCon : (t : Term {}) -> Bool
isTyCon (TYPE {}) = True
isTyCon (Pi {}) = True
isTyCon (Lam {}) = False
isTyCon (Sig {}) = True
isTyCon (Pair {}) = False
isTyCon (Eq {}) = True
isTyCon (DLam {}) = False
isTyCon (E {}) = True
isTyCon (CloT {}) = False
isTyCon (DCloT {}) = False
private
isSubSing : Term {} -> Bool
isSubSing ty =
let Element ty _ = pushSubsts ty in
case ty of
TYPE _ => False
Pi {res, _} => isSubSing res.term
Lam {} => False
Sig {fst, snd, _} => isSubSing fst && isSubSing snd.term
Pair {} => False
Eq {} => True
DLam {} => False
E e => 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 (isTyCon t))
ensureType = ensure NotType isTyCon
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 (isTyCon 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) => 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
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 (isTyCon s)) =>
(0 nt : NotRedex defs t) => (0 tt : So (isTyCon 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
compare0 ctx e f
||| assumes the elim is already typechecked! only does the work necessary
||| to calculate the overall type
private covering
computeElimType : TContext q 0 n -> (e : Elim q 0 n) ->
(0 ne : NotRedex defs e) =>
m (Term q 0 n)
computeElimType ctx (F x) = do
defs <- lookupFree' defs x
pure $ defs.type.get
computeElimType ctx (B i) = do
pure $ ctx !! i
computeElimType ctx (f :@ s) {ne} = do
(_, arg, res) <- computeElimType ctx f {ne = noOr1 ne} >>= expectPi defs
pure $ sub1 res (s :# arg)
computeElimType ctx (CasePair {pair, ret, _}) = do
pure $ sub1 ret pair
computeElimType ctx (f :% p) {ne} = do
(ty, _, _) <- computeElimType ctx f {ne = noOr1 ne} >>= expectEq defs
pure $ dsub1 ty p
computeElimType ctx (_ :# ty) = do
pure ty
private covering
replaceEnd : TContext q 0 n ->
(e : Elim q 0 n) -> DimConst -> (0 ne : NotRedex defs e) ->
m (Elim q 0 n)
replaceEnd ctx e p ne = do
(ty, l, r) <- computeElimType ctx e >>= expectEq defs
pure $ ends l r p :# dsub1 ty (K p)
namespace Elim
-- [fixme] the following code ends up repeating a lot of work in the
-- computeElimType calls. the results should be shared better
export covering %inline
compare0 : TContext q 0 n -> (e, f : Elim q 0 n) -> m ()
compare0 ctx e f =
let Element e ne = whnfD defs e
Element f nf = whnfD defs f
in
-- [fixme] there is a better way to do this "isSubSing" stuff for sure
unless (isSubSing !(computeElimType ctx e)) $ compare0' ctx e f
private covering
compare0' : TContext q 0 n ->
(e, f : Elim q 0 n) ->
(0 ne : NotRedex defs e) => (0 nf : NotRedex defs f) =>
m ()
-- replace applied equalities with the appropriate end first
-- e.g. e : Eq [i ⇒ A] s t ⊢ e 0 = s : A0/i
compare0' ctx (e :% K p) f {ne} =
compare0 ctx !(replaceEnd ctx e p $ noOr1 ne) f
compare0' ctx e (f :% K q) {nf} =
compare0 ctx e !(replaceEnd ctx f q $ noOr1 nf)
compare0' _ e@(F x) f@(F y) = unless (x == y) $ clashE e f
compare0' _ e@(F _) f = clashE e f
compare0' ctx e@(B i) f@(B j) = unless (i == j) $ clashE e f
compare0' _ e@(B _) f = clashE e f
compare0' ctx (e :@ s) (f :@ t) {ne} = local {mode := Equal} $ do
compare0 ctx e f
(_, arg, _) <- computeElimType ctx e {ne = noOr1 ne} >>= expectPi defs
compare0 ctx arg s t
compare0' _ e@(_ :@ _) f = clashE e f
compare0' ctx (CasePair epi e _ eret _ _ ebody)
(CasePair fpi f _ fret _ _ fbody) {ne} =
local {mode := Equal} $ do
compare0 ctx e f
ety <- computeElimType ctx e {ne = noOr1 ne}
compareType (ctx :< ety) eret.term fret.term
(fst, snd) <- expectSig defs ety
compare0 (ctx :< fst :< snd.term) (substCasePairRet ety eret)
ebody.term fbody.term
unless (epi == fpi) $ throwError $ ClashQ epi fpi
compare0' _ e@(CasePair {}) f = clashE e f
compare0' ctx (s :# a) (t :# b) = do
compareType ctx a b
compare0 ctx a s t
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
||| you don't have to pass the type in but the arguments must still be
||| of the same type!!
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 =>
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