module Data.Comp.Derive.Equality
(
EqF(..),
makeEqF
) where
import Data.Comp.Derive.Utils
import Language.Haskell.TH hiding (Cxt, match)
class EqF f where
eqF :: Eq a => f a -> f a -> Bool
makeEqF :: Name -> Q [Dec]
makeEqF fname = do
TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
let argNames = map (VarT . tyVarBndrName) (init args)
complType = foldl AppT (ConT name) argNames
preCond = map (ClassP ''Eq . (: [])) argNames
classType = AppT (ConT ''EqF) complType
eqFDecl <- funD 'eqF (eqFClauses constrs)
return [InstanceD preCond classType [eqFDecl]]
where eqFClauses constrs = map (genEqClause.abstractConType) constrs
++ defEqClause constrs
defEqClause constrs
| length constrs < 2 = []
| otherwise = [clause [wildP,wildP] (normalB [|False|]) []]
genEqClause (constr, n) = do
varNs <- newNames n "x"
varNs' <- newNames n "y"
let pat = ConP constr $ map VarP varNs
pat' = ConP constr $ map VarP varNs'
vars = map VarE varNs
vars' = map VarE varNs'
mkEq x y = let (x',y') = (return x,return y)
in [| $x' == $y'|]
eqs = listE $ zipWith mkEq vars vars'
body <- if n == 0
then [|True|]
else [|and $eqs|]
return $ Clause [pat, pat'] (NormalB body) []