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 -> Elim q d n -> Elim q d n -> Error q ClashE mode = ClashT mode `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 -> 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 e f = throwError $ ClashE !mode e f export %inline 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 k l = unless !(compareU' k l) $ throwError $ ClashU !mode k l export %inline compareD : HasErr q m => Dim d -> Dim d -> m () compareD p q = unless (p == q) $ throwError $ ClashD p q 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 () compareN' (TYPE k) (TYPE l) _ _ = compareU k l compareN' s@(TYPE _) 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 compareN' (Lam _ body1) (Lam _ body2) _ _ = local {mode := Equal} $ compare0 body1 body2 compareN' s@(Lam {}) 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 compareN' (DLam _ body1) (DLam _ body2) _ _ = compare0 body1 body2 compareN' s@(DLam {}) t _ _ = clashT s t compareN' (E e) (E f) ne nf = compareN' e f (noOr2 ne) (noOr2 nf) compareN' s@(E e) t _ _ = clashT s t 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 () compareN' e@(F x) f@(F y) _ _ = unless (x == y) $ clashE e f compareN' e@(F _) 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 compareN' (fun1 :@ arg1) (fun2 :@ arg2) _ _ = local {mode := Equal} $ do compare0 fun1 fun2 compare0 arg1 arg2 compareN' 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 -- 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 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 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 ScopeTermN export covering %inline compare0 : {s : Nat} -> CanEqual q m => Eq q => ScopeTermN s q 0 n -> ScopeTermN s q 0 n -> m () compare0 (TUnused body0) (TUnused body1) = compare0 body0 body1 compare0 body0 body1 = compare0 body0.term body1.term -- [todo] extend to multi-var scopes 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 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 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 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