quox/tests/TermImpls.idr

module TermImpls

import Quox.Syntax
import public Quox.Pretty


private
eqShiftLen : Shift from1 to -> Shift from2 to -> Maybe (from1 = from2)
eqShiftLen SZ      SZ      = Just Refl
eqShiftLen (SS by) (SS bz) = eqShiftLen by bz
eqShiftLen _       _       = Nothing

private
eqSubstLen : Subst tm1 from1 to -> Subst tm2 from2 to -> Maybe (from1 = from2)
eqSubstLen (Shift by) (Shift bz) = eqShiftLen by bz
eqSubstLen (_ ::: th) (_ ::: ph) = cong S <$> eqSubstLen th ph
eqSubstLen _          _          = Nothing
  -- maybe from1 = from2 in the last case, but this is for
  -- (==), and the substs aren't equal, so who cares

mutual
  export covering
  Eq q => Eq (Term q d n) where
    TYPE k == TYPE l = k == l
    TYPE _ == _ = False

    Pi qty1 arg1 res1 == Pi qty2 arg2 res2 =
      qty1 == qty2 && arg1 == arg2 && res1 == res2
    Pi {} == _ = False

    Lam body1 == Lam body2 = body1 == body2
    Lam {} == _ = False

    Sig fst1 snd1 == Sig fst2 snd2 = fst1 == fst2 && snd1 == snd2
    Sig {} == _ = False

    Pair fst1 snd1 == Pair fst2 snd2 = fst1 == fst2 && snd1 == snd2
    Pair {} == _ = False

    Enum ts1 == Enum ts2 = ts1 == ts2
    Enum _ == _ = False

    Tag t1 == Tag t2 = t1 == t2
    Tag _ == _ = False

    Eq ty1 l1 r1 == Eq ty2 l2 r2 =
      ty1 == ty2 && l1 == l2 && r1 == r2
    Eq {} == _ = False

    DLam body1 == DLam body2 = body1 == body2
    DLam {} == _ = False

    E e == E f = e == f
    E _ == _ = False

    CloT tm1 th1 == CloT tm2 th2 =
      case eqSubstLen th1 th2 of
           Just Refl => tm1 == tm2 && th1 == th2
           Nothing   => False
    CloT {} == _ = False

    DCloT tm1 th1 == DCloT tm2 th2 =
      case eqSubstLen th1 th2 of
           Just Refl => tm1 == tm2 && th1 == th2
           Nothing   => False
    DCloT {} == _ = False

  export covering
  Eq q => Eq (Elim q d n) where
    F x == F y = x == y
    F _ == _ = False

    B i == B j = i == j
    B _ == _ = False

    (fun1 :@ arg1) == (fun2 :@ arg2) = fun1 == fun2 && arg1 == arg2
    (_ :@ _) == _ = False

    CasePair q1 p1 r1 b1 == CasePair q2 p2 r2 b2 =
      q1 == q2 && p1 == p2 && r1 == r2 && b1 == b2
    CasePair {} == _ = False

    CaseEnum q1 t1 r1 a1 == CaseEnum q2 t2 r2 a2 =
      q1 == q2 && t1 == t2 && r1 == r2 && a1 == a2
    CaseEnum {} == _ = False

    (fun1 :% dim1) == (fun2 :% dim2) = fun1 == fun2 && dim1 == dim2
    (_ :% _) == _ = False

    (tm1 :# ty1) == (tm2 :# ty2) = tm1 == tm2 && ty1 == ty2
    (_ :# _) == _ = False

    CloE el1 th1 == CloE el2 th2 =
      case eqSubstLen th1 th2 of
           Just Refl => el1 == el2 && th1 == th2
           Nothing   => False
    CloE {} == _ = False

    DCloE el1 th1 == DCloE el2 th2 =
      case eqSubstLen th1 th2 of
           Just Refl => el1 == el2 && th1 == th2
           Nothing   => False
    DCloE {} == _ = False

  export covering
  (forall n. Eq (f n)) => Eq (ScopedBody s f n) where
    Y x == Y y = x == y
    N x == N y = x == y
    _   == _   = False

  export covering
  (forall n. Eq (f n)) => Eq (Scoped s f n) where
    S _ x == S _ y = x == y

export covering
PrettyHL q => Show (Term q d n) where
  showPrec d t = showParens (d /= Open) $ prettyStr True t

export covering
PrettyHL q => Show (Elim q d n) where
  showPrec d e = showParens (d /= Open) $ prettyStr True e