module Data.Comp.Param.Derive.Equality
(
EqD(..),
makeEqD
) where
import Data.Comp.Derive.Utils
import Data.Comp.Param.FreshM hiding (Name)
import Data.Comp.Param.Equality
import Control.Monad
import Language.Haskell.TH hiding (Cxt, match)
makeEqD :: Name -> Q [Dec]
makeEqD fname = do
TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
let coArg :: Name = tyVarBndrName $ last args
let conArg :: Name = tyVarBndrName $ last $ init args
let argNames = map (VarT . tyVarBndrName) (init $ init args)
let complType = foldl AppT (ConT name) argNames
let classType = AppT (ConT ''EqD) complType
constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
let defC = if length constrs < 2 then
[]
else
[clause [wildP,wildP] (normalB [|return False|]) []]
eqDDecl <- funD 'eqD (map (eqDClause conArg coArg) constrs' ++ defC)
let context = map (\arg -> ClassP ''Eq [arg]) argNames
return [InstanceD context classType [eqDDecl]]
where eqDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ
eqDClause conArg coArg (constr, args) = do
varXs <- newNames (length args) "x"
varYs <- newNames (length args) "y"
let patx = ConP constr $ map VarP varXs
let paty = ConP constr $ map VarP varYs
body <- eqDBody conArg coArg (zip3 varXs varYs args)
return $ Clause [patx,paty] (NormalB body) []
eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ
eqDBody conArg coArg x =
[|liftM and (sequence $(listE $ map (eqDB conArg coArg) x))|]
eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ
eqDB conArg coArg (x, y, tp)
| not (containsType tp (VarT conArg)) &&
not (containsType tp (VarT coArg)) =
[| return $ $(varE x) == $(varE y) |]
| otherwise =
case tp of
VarT a
| a == coArg -> [| peq $(varE x) $(varE y) |]
AppT (AppT ArrowT (VarT a)) _
| a == conArg ->
[| withName (\v -> peq ($(varE x) v) ($(varE y) v)) |]
SigT tp' _ ->
eqDB conArg coArg (x, y, tp')
_ ->
if containsType tp (VarT conArg) then
[| eqD $(varE x) $(varE y) |]
else
[| peq $(varE x) $(varE y) |]