{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Multi.Derive.Ordering
(
OrdHF(..),
makeOrdHF
) where
import Data.Comp.Derive.Utils
import Data.Comp.Multi.Ordering
import Data.List
import Data.Maybe
import Language.Haskell.TH hiding (Cxt)
compList :: [Ordering] -> Ordering
compList :: [Ordering] -> Ordering
compList = forall a. a -> Maybe a -> a
fromMaybe Ordering
EQ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
/= Ordering
EQ)
makeOrdHF :: Name -> Q [Dec]
makeOrdHF :: Name -> Q [Dec]
makeOrdHF Name
fname = do
Just (DataInfo Cxt
_ Name
name [TyVarBndr flag]
args [Con]
constrs [DerivClause]
_) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
let args' :: [TyVarBndr flag]
args' = forall a. [a] -> [a]
init [TyVarBndr flag]
args
let Type
coArg :: Type = Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ forall {flag}. TyVarBndr flag -> Name
tyVarBndrName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [TyVarBndr flag]
args'
let argNames :: Cxt
argNames = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {flag}. TyVarBndr flag -> Name
tyVarBndrName) (forall a. [a] -> [a]
init [TyVarBndr flag]
args')
let complType :: Type
complType = 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
let classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''OrdHF) Type
complType
[(Name, Cxt, Maybe Type)]
constrs' :: [(Name,[Type],Maybe Type)] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q (Name, Cxt, Maybe Type)
normalConExp [Con]
constrs
Dec
compareHFDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'compareHF (Type -> [(Name, Cxt, Maybe Type)] -> [ClauseQ]
compareHFClauses Type
coArg [(Name, Cxt, Maybe Type)]
constrs')
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD [] Type
classType [Dec
compareHFDecl]]
where compareHFClauses :: Type -> [(Name,[Type],Maybe Type)] -> [ClauseQ]
compareHFClauses :: Type -> [(Name, Cxt, Maybe Type)] -> [ClauseQ]
compareHFClauses Type
_ [] = []
compareHFClauses Type
coArg [(Name, Cxt, Maybe Type)]
constrs =
let constrs' :: [((Name, Cxt, Maybe Type), Integer)]
constrs' = [(Name, Cxt, Maybe Type)]
constrs forall a b. [a] -> [b] -> [(a, b)]
`zip` [Integer
1..]
constPairs :: [(((Name, Cxt, Maybe Type), Integer),
((Name, Cxt, Maybe Type), Integer))]
constPairs = [(((Name, Cxt, Maybe Type), Integer)
x,((Name, Cxt, Maybe Type), Integer)
y)| ((Name, Cxt, Maybe Type), Integer)
x<-[((Name, Cxt, Maybe Type), Integer)]
constrs', ((Name, Cxt, Maybe Type), Integer)
y <- [((Name, Cxt, Maybe Type), Integer)]
constrs']
in forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {b} {c}.
Ord a =>
Type
-> (((Name, Cxt, Maybe Type), a), ((Name, b, c), a)) -> ClauseQ
genClause Type
coArg) [(((Name, Cxt, Maybe Type), Integer),
((Name, Cxt, Maybe Type), Integer))]
constPairs
genClause :: Type
-> (((Name, Cxt, Maybe Type), a), ((Name, b, c), a)) -> ClauseQ
genClause Type
coArg (((Name, Cxt, Maybe Type)
c,a
n),((Name, b, c)
d,a
m))
| a
n forall a. Eq a => a -> a -> Bool
== a
m = Type -> (Name, Cxt, Maybe Type) -> ClauseQ
genEqClause Type
coArg (Name, Cxt, Maybe Type)
c
| a
n forall a. Ord a => a -> a -> Bool
< a
m = forall {m :: * -> *} {b} {c} {b} {c}.
Quote m =>
(Name, b, c) -> (Name, b, c) -> m Clause
genLtClause (Name, Cxt, Maybe Type)
c (Name, b, c)
d
| Bool
otherwise = forall {m :: * -> *} {b} {c} {b} {c}.
Quote m =>
(Name, b, c) -> (Name, b, c) -> m Clause
genGtClause (Name, Cxt, Maybe Type)
c (Name, b, c)
d
genEqClause :: Type -> (Name,[Type],Maybe Type) -> ClauseQ
genEqClause :: Type -> (Name, Cxt, Maybe Type) -> ClauseQ
genEqClause Type
coArg (Name
constr, Cxt
args,Maybe Type
gadtTy) = do
[Name]
varXs <- Int -> String -> Q [Name]
newNames (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
args) String
"x"
[Name]
varYs <- Int -> String -> Q [Name]
newNames (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
args) String
"y"
let patX :: Pat
patX = Name -> Cxt -> [Pat] -> Pat
ConP Name
constr [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varXs
let patY :: Pat
patY = Name -> Cxt -> [Pat] -> Pat
ConP Name
constr [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varYs
Exp
body <- Type -> [(Name, Name, Type)] -> ExpQ
eqDBody (Type -> Maybe Type -> Type
getBinaryFArg Type
coArg Maybe Type
gadtTy) (forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
varXs [Name]
varYs Cxt
args)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
patX, Pat
patY] (Exp -> Body
NormalB Exp
body) []
eqDBody :: Type -> [(Name, Name, Type)] -> ExpQ
eqDBody :: Type -> [(Name, Name, Type)] -> ExpQ
eqDBody Type
coArg [(Name, Name, Type)]
x =
[|compList $(listE $ map (eqDB coArg) x)|]
eqDB :: Type -> (Name, Name, Type) -> ExpQ
eqDB :: Type -> (Name, Name, Type) -> ExpQ
eqDB Type
coArg (Name
x, Name
y, Type
tp)
| Bool -> Bool
not (Type -> Type -> Bool
containsType Type
tp Type
coArg) =
[| compare $(varE x) $(varE y) |]
| Bool
otherwise =
[| kcompare $(varE x) $(varE y) |]
genLtClause :: (Name, b, c) -> (Name, b, c) -> m Clause
genLtClause (Name
c, b
_, c
_) (Name
d, b
_, c
_) =
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
c [], forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
d []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| LT |]) []
genGtClause :: (Name, b, c) -> (Name, b, c) -> m Clause
genGtClause (Name
c, b
_, c
_) (Name
d, b
_, c
_) =
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
c [], forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
d []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| GT |]) []