{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,
ScopedTypeVariables #-}
module Data.Comp.Param.Derive.Ordering
(
OrdD(..),
makeOrdD
) where
import Data.Comp.Param.FreshM hiding (Name)
import Data.Comp.Param.Ordering
import Data.Comp.Derive.Utils
import Data.Comp.Param.Derive.Utils
import Language.Haskell.TH hiding (Cxt)
import Control.Monad (liftM)
makeOrdD :: Name -> Q [Dec]
makeOrdD fname = do
Just (DataInfo _ name args constrs _) <- abstractNewtypeQ $ reify fname
let coArg :: Type = VarT $ tyVarBndrName $ last args
let conArg :: Type = VarT $ tyVarBndrName $ last $ init args
let argNames = map (VarT . tyVarBndrName) (init $ init args)
let complType = foldl AppT (ConT name) argNames
let classType = AppT (ConT ''OrdD) complType
constrs' :: [(Name,[Type], Maybe Type)] <- mapM normalConExp constrs
compareDDecl <- funD 'compareD (compareDClauses conArg coArg constrs')
let context = map (\arg -> mkClassP ''Ord [arg]) argNames
return [mkInstanceD context classType [compareDDecl]]
where compareDClauses :: Type -> Type -> [(Name,[Type], Maybe Type)] -> [ClauseQ]
compareDClauses _ _ [] = []
compareDClauses conArg coArg constrs =
let constrs' = constrs `zip` [1..]
constPairs = [(x,y)| x<-constrs', y <- constrs']
in map (genClause conArg coArg) constPairs
genClause conArg coArg ((c,n),(d,m))
| n == m = genEqClause conArg coArg c
| n < m = genLtClause c d
| otherwise = genGtClause c d
genEqClause :: Type -> Type -> (Name,[Type], Maybe Type) -> ClauseQ
genEqClause conArg' coArg' (constr, args, gadtTy) = 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
let (conArg, coArg) = getBinaryFArgs conArg' coArg' gadtTy
body <- eqDBody conArg coArg (zip3 varXs varYs args)
return $ Clause [patX, patY] (NormalB body) []
eqDBody :: Type -> Type -> [(Name, Name, Type)] -> ExpQ
eqDBody conArg coArg x =
[|liftM compList (sequence $(listE $ map (eqDB conArg coArg) x))|]
eqDB :: Type -> Type -> (Name, Name, Type) -> ExpQ
eqDB conArg coArg (x, y, tp)
| not (containsType tp conArg) &&
not (containsType tp coArg) =
[| return $ compare $(varE x) $(varE y) |]
| otherwise =
case tp of
a
| a == coArg -> [| pcompare $(varE x) $(varE y) |]
AppT (AppT ArrowT a) _
| a == conArg ->
[| withName (\v -> pcompare ($(varE x) v) ($(varE y) v)) |]
SigT tp' _ ->
eqDB conArg coArg (x, y, tp')
_ ->
if containsType tp conArg then
[| compareD $(varE x) $(varE y) |]
else
[| pcompare $(varE x) $(varE y) |]
genLtClause (c, _, _) (d, _, _) =
clause [recP c [], recP d []] (normalB [| return LT |]) []
genGtClause (c, _, _) (d, _, _) =
clause [recP c [], recP d []] (normalB [| return GT |]) []