quox/src/Quox/Equal.idr

module Quox.Equal

import public Quox.Syntax
import Quox.Error

%default total


public export
data Error
= Clash  SomeTerm SomeTerm
| ClashU Universe Universe
| ClashQ Qty      Qty

private %inline
clashT' : Term d n -> Term d n -> Error
clashT' = Clash `on` some2

private %inline
clashE' : Elim d n -> Elim d n -> Error
clashE' = clashT' `on` E

parameters {auto _ : MonadThrow Error m}
  private %inline
  clashT : Term d n -> Term d n -> m a
  clashT = throw .: clashT'

  private %inline
  clashE : Elim d n -> Elim d n -> m a
  clashE = clashT `on` E

  private %inline
  eq : Eq a => (a -> a -> Error) -> a -> a -> m ()
  eq err a b = unless (a == b) $ throw $ err a b

  mutual
    private covering
    equalTN' : (s, t : Term 0 n) ->
               (0 _ : NotRedexT s) -> (0 _ : NotRedexT t) -> m ()

    equalTN' (TYPE k) (TYPE l) _ _ =
      eq ClashU k l
    equalTN' s@(TYPE _) t _ _ = clashT s t

    equalTN' (Pi qtm1 qty1 _ arg1 res1) (Pi qtm2 qty2 _ arg2 res2) _ _ = do
      eq ClashQ qtm1 qtm2
      eq ClashQ qty1 qty2
      equalT0 arg1 arg2
      equalT0 res1 res2
    equalTN' s@(Pi {}) t _ _ = clashT s t

    -- [todo] eta
    equalTN' (Lam _ body1) (Lam _ body2) _ _ =
      equalT0 body1 body2
    equalTN' s@(Lam {}) t _ _ = clashT s t

    equalTN' (E e) (E f) ps pt = equalE0 e f
    equalTN' s@(E _) t _ _ = clashT s t

    equalTN' (CloT  {}) _ ps _ = void $ ps IsCloT
    equalTN' (DCloT {}) _ ps _ = void $ ps IsDCloT

    private covering
    equalEN' : (e, f : Elim 0 n) ->
               (0 _ : NotRedexE e) -> (0 _ : NotRedexE f) -> m ()

    equalEN' (F x) (F y) _ _ = do
      eq (clashE' `on` F {d = 0, n = 0}) x y
    equalEN' e@(F _) f _ _ = clashE e f

    equalEN' (B i) (B j) _ _ = do
      eq (clashE' `on` B {d = 0}) i j
    equalEN' e@(B _) f _ _ = clashE e f

    equalEN' (fun1 :@ arg1) (fun2 :@ arg2) _ _ = do
      equalE0 fun1 fun2
      equalT0 arg1 arg2
    equalEN' e@(_ :@ _) f _ _ = clashE e f

    equalEN' (tm1 :# ty1) (tm2 :# ty2) _ _ = do
      equalT0 tm1 tm2
      equalT0 ty1 ty2
    equalEN' e@(_ :# _) f _ _ = clashE e f

    equalEN' (CloE  {}) _ pe _ = void $ pe IsCloE
    equalEN' (DCloE {}) _ pe _ = void $ pe IsDCloE


    private covering %inline
    equalTN : NonRedexTerm 0 n -> NonRedexTerm 0 n -> m ()
    equalTN s t = equalTN' s.fst t.fst s.snd t.snd

    private covering %inline
    equalEN : NonRedexElim 0 n -> NonRedexElim 0 n -> m ()
    equalEN e f = equalEN' e.fst f.fst e.snd f.snd


    export covering %inline
    equalT : DimEq d -> Term d n -> Term d n -> m ()
    equalT eqs s t =
      for_ (splits eqs) $ \th => (s /// th) `equalT0` (t /// th)

    export covering %inline
    equalE : DimEq d -> Elim d n -> Elim d n -> m ()
    equalE eqs e f =
      for_ (splits eqs) $ \th => (e /// th) `equalE0` (f /// th)


    export covering %inline
    equalT0 : Term 0 n -> Term 0 n -> m ()
    equalT0 s t = whnfT s `equalTN` whnfT t

    export covering %inline
    equalE0 : Elim 0 n -> Elim 0 n -> m ()
    equalE0 e f = whnfE e `equalEN` whnfE f