{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Derive.Ordering
(
OrdF(..),
makeOrdF
) where
import Data.Comp.Derive.Equality
import Data.Comp.Derive.Utils
import Data.List
import Data.Maybe
import Language.Haskell.TH hiding (Cxt)
class EqF f => OrdF f where
compareF :: Ord a => f a -> f a -> Ordering
compList :: [Ordering] -> Ordering
compList :: [Ordering] -> Ordering
compList = Ordering -> Maybe Ordering -> Ordering
forall a. a -> Maybe a -> a
fromMaybe Ordering
EQ (Maybe Ordering -> Ordering)
-> ([Ordering] -> Maybe Ordering) -> [Ordering] -> Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ordering -> Bool) -> [Ordering] -> Maybe Ordering
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
EQ)
makeOrdF :: Name -> Q [Dec]
makeOrdF :: Name -> Q [Dec]
makeOrdF Name
fname = do
Just (DataInfo Cxt
_cxt Name
name [TyVarBndr]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
let argNames :: Cxt
argNames = (TyVarBndr -> Type) -> [TyVarBndr] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarBndrName) ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
args)
complType :: Type
complType = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
argNames
preCond :: Cxt
preCond = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Cxt -> Type
mkClassP ''Ord (Cxt -> Type) -> (Type -> Cxt) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: [])) Cxt
argNames
classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''OrdF) Type
complType
Dec
eqAlgDecl <- Name -> [ClauseQ] -> DecQ
funD 'compareF ([Con] -> [ClauseQ]
compareFClauses [Con]
constrs)
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD Cxt
preCond Type
classType [Dec
eqAlgDecl]]
where compareFClauses :: [Con] -> [ClauseQ]
compareFClauses [] = []
compareFClauses [Con]
constrs =
let constrs' :: [((Name, Int), Integer)]
constrs' = (Con -> (Name, Int)) -> [Con] -> [(Name, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, Int)
abstractConType [Con]
constrs [(Name, Int)] -> [Integer] -> [((Name, Int), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Integer
1..]
constPairs :: [(((Name, Int), Integer), ((Name, Int), Integer))]
constPairs = [(((Name, Int), Integer)
x,((Name, Int), Integer)
y)| ((Name, Int), Integer)
x<-[((Name, Int), Integer)]
constrs', ((Name, Int), Integer)
y <- [((Name, Int), Integer)]
constrs']
in ((((Name, Int), Integer), ((Name, Int), Integer)) -> ClauseQ)
-> [(((Name, Int), Integer), ((Name, Int), Integer))] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (((Name, Int), Integer), ((Name, Int), Integer)) -> ClauseQ
forall a b. Ord a => (((Name, Int), a), ((Name, b), a)) -> ClauseQ
genClause [(((Name, Int), Integer), ((Name, Int), Integer))]
constPairs
genClause :: (((Name, Int), a), ((Name, b), a)) -> ClauseQ
genClause (((Name, Int)
c,a
n),((Name, b)
d,a
m))
| a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
m = (Name, Int) -> ClauseQ
genEqClause (Name, Int)
c
| a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
m = (Name, Int) -> (Name, b) -> ClauseQ
forall b b. (Name, b) -> (Name, b) -> ClauseQ
genLtClause (Name, Int)
c (Name, b)
d
| Bool
otherwise = (Name, Int) -> (Name, b) -> ClauseQ
forall b b. (Name, b) -> (Name, b) -> ClauseQ
genGtClause (Name, Int)
c (Name, b)
d
genEqClause :: (Name, Int) -> ClauseQ
genEqClause (Name
constr, Int
n) = do
[Name]
varNs <- Int -> String -> Q [Name]
newNames Int
n String
"x"
[Name]
varNs' <- Int -> String -> Q [Name]
newNames Int
n String
"y"
let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP Name
constr ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs
pat' :: Pat
pat' = Name -> [Pat] -> Pat
ConP Name
constr ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs'
vars :: [Exp]
vars = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
varNs
vars' :: [Exp]
vars' = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
varNs'
mkEq :: Exp -> Exp -> ExpQ
mkEq Exp
x Exp
y = let (ExpQ
x',ExpQ
y') = (Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x,Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
y)
in [| compare $x' $y'|]
eqs :: ExpQ
eqs = [ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> ExpQ) -> [Exp] -> [Exp] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Exp -> Exp -> ExpQ
mkEq [Exp]
vars [Exp]
vars'
Exp
body <- [|compList $eqs|]
Clause -> ClauseQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> ClauseQ) -> Clause -> ClauseQ
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat, Pat
pat'] (Exp -> Body
NormalB Exp
body) []
genLtClause :: (Name, b) -> (Name, b) -> ClauseQ
genLtClause (Name
c, b
_) (Name
d, b
_) = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [FieldPatQ] -> PatQ
recP Name
c [], Name -> [FieldPatQ] -> PatQ
recP Name
d []] (ExpQ -> BodyQ
normalB [| LT |]) []
genGtClause :: (Name, b) -> (Name, b) -> ClauseQ
genGtClause (Name
c, b
_) (Name
d, b
_) = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [FieldPatQ] -> PatQ
recP Name
c [], Name -> [FieldPatQ] -> PatQ
recP Name
d []] (ExpQ -> BodyQ
normalB [| GT |]) []