{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE ScopedTypeVariables        #-}

module Generics.MultiRec.ShallowEq where

import Generics.MultiRec
import Data.Foldable ( toList )
import Data.Traversable ( Traversable )

--------------------------------------------------------------------------------
-- Shallow equality
--------------------------------------------------------------------------------

class SEq phi (f :: (* -> *) -> * -> *) where
  shallowEq :: phi ix -> f r ix  -> f r ix -> Bool

instance SEq phi (I xi) where
  shallowEq _ _ _ = True

instance SEq phi U where
  shallowEq _ _ _ = True

instance Eq a => SEq phi (K a) where
  shallowEq p (K a) (K b) = a == b

instance (SEq phi f, SEq phi g) => SEq phi (f :+: g) where
  shallowEq p (L a) (L b) = shallowEq p a b
  shallowEq p (R a) (R b) = shallowEq p a b
  shallowEq _ _     _     = False

instance (SEq phi f, SEq phi g) => SEq phi (f :*: g) where
  shallowEq p (a :*: b) (c :*: d) = shallowEq p a c && shallowEq p b d

instance SEq phi f => SEq phi (f :>: ix) where
  shallowEq p (Tag a) (Tag b) = shallowEq p a b

instance SEq phi f => SEq phi (C c f) where
  shallowEq p (C a) (C b) = shallowEq p a b

instance (Traversable t, Eq (t ()), SEq phi f) => SEq phi (t :.: f) where
  shallowEq p (D a) (D b) = fmap (const ()) a == fmap (const ()) b
                            && and (zipWith (shallowEq p) (toList a) (toList b))