{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
module Data.Ord.Deriving.Internal (
deriveOrd
, makeCompare
, makeLE
, makeLT
, makeGT
, makeGE
, makeMax
, makeMin
, deriveOrd1
#if defined(NEW_FUNCTOR_CLASSES)
, makeLiftCompare
#endif
, makeCompare1
#if defined(NEW_FUNCTOR_CLASSES)
, deriveOrd2
, makeLiftCompare2
, makeCompare2
#endif
) where
import Data.Deriving.Internal
import Data.List (partition)
import qualified Data.Map as Map
import Data.Map (Map)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
deriveOrd :: Name -> Q [Dec]
deriveOrd :: Name -> Q [Dec]
deriveOrd = OrdClass -> Name -> Q [Dec]
deriveOrdClass OrdClass
Ord
makeCompare :: Name -> Q Exp
makeCompare :: Name -> Q Exp
makeCompare = OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
OrdCompare (forall a. HasCallStack => [Char] -> a
error [Char]
"This shouldn't happen")
makeLT :: Name -> Q Exp
makeLT :: Name -> Q Exp
makeLT = OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
OrdLT [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ltDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName) []
, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName) []
]
makeLE :: Name -> Q Exp
makeLE :: Name -> Q Exp
makeLE = OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
OrdLE [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
gtDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName) []
, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName) []
]
makeGT :: Name -> Q Exp
makeGT :: Name -> Q Exp
makeGT = OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
OrdGT [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
gtDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName) []
, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName) []
]
makeGE :: Name -> Q Exp
makeGE :: Name -> Q Exp
makeGE = OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
OrdGE [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ltDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName) []
, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName) []
]
makeMax :: Name -> Q Exp
makeMax :: Name -> Q Exp
makeMax = ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp)
-> Name -> Q Exp
makeMinMax forall a b c. (a -> b -> c) -> b -> a -> c
flip
makeMin :: Name -> Q Exp
makeMin :: Name -> Q Exp
makeMin = ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp)
-> Name -> Q Exp
makeMinMax forall a. a -> a
id
makeMinMax :: ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp)
-> Name -> Q Exp
makeMinMax :: ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp)
-> Name -> Q Exp
makeMinMax (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
f Name
name = do
Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
let xExpr :: Q Exp
xExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x
yExpr :: Q Exp
yExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] forall a b. (a -> b) -> a -> b
$
(Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
f (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
makeLE Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
xExpr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
yExpr) Q Exp
xExpr Q Exp
yExpr
deriveOrd1 :: Name -> Q [Dec]
deriveOrd1 :: Name -> Q [Dec]
deriveOrd1 = OrdClass -> Name -> Q [Dec]
deriveOrdClass OrdClass
Ord1
#if defined(NEW_FUNCTOR_CLASSES)
makeLiftCompare :: Name -> Q Exp
makeLiftCompare :: Name -> Q Exp
makeLiftCompare = OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
Ord1LiftCompare (forall a. HasCallStack => [Char] -> a
error [Char]
"This shouldn't happen")
makeCompare1 :: Name -> Q Exp
makeCompare1 :: Name -> Q Exp
makeCompare1 Name
name = Name -> Q Exp
makeLiftCompare Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
compareValName
#else
makeCompare1 :: Name -> Q Exp
makeCompare1 = makeOrdFun Ord1Compare1 (error "This shouldn't happen")
#endif
#if defined(NEW_FUNCTOR_CLASSES)
deriveOrd2 :: Name -> Q [Dec]
deriveOrd2 :: Name -> Q [Dec]
deriveOrd2 = OrdClass -> Name -> Q [Dec]
deriveOrdClass OrdClass
Ord2
makeLiftCompare2 :: Name -> Q Exp
makeLiftCompare2 :: Name -> Q Exp
makeLiftCompare2 = OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
Ord2LiftCompare2 (forall a. HasCallStack => [Char] -> a
error [Char]
"This shouldn't happen")
makeCompare2 :: Name -> Q Exp
makeCompare2 :: Name -> Q Exp
makeCompare2 Name
name = Name -> Q Exp
makeLiftCompare Name
name
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
compareValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
compareValName
#endif
deriveOrdClass :: OrdClass -> Name -> Q [Dec]
deriveOrdClass :: OrdClass -> Name -> Q [Dec]
deriveOrdClass OrdClass
oClass Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(Cxt
instanceCxt, Type
instanceType)
<- forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance OrdClass
oClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(OrdClass -> Cxt -> [ConstructorInfo] -> [Q Dec]
ordFunDecs OrdClass
oClass Cxt
instTypes [ConstructorInfo]
cons)
ordFunDecs :: OrdClass -> [Type] -> [ConstructorInfo] -> [Q Dec]
ordFunDecs :: OrdClass -> Cxt -> [ConstructorInfo] -> [Q Dec]
ordFunDecs OrdClass
oClass Cxt
instTypes [ConstructorInfo]
cons =
forall a b. (a -> b) -> [a] -> [b]
map OrdFun -> Q Dec
makeFunD forall a b. (a -> b) -> a -> b
$ OrdClass -> OrdFun
ordClassToCompare OrdClass
oClass forall a. a -> [a] -> [a]
: OrdClass -> [ConstructorInfo] -> [OrdFun]
otherFuns OrdClass
oClass [ConstructorInfo]
cons
where
makeFunD :: OrdFun -> Q Dec
makeFunD :: OrdFun -> Q Dec
makeFunD OrdFun
oFun =
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (OrdFun -> Int -> Name
ordFunName OrdFun
oFun forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Int
arity OrdClass
oClass)
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
dispatchFun OrdFun
oFun)
[]
]
negateExpr :: Q Exp -> Q Exp
negateExpr :: Q Exp -> Q Exp
negateExpr = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
notValName)
dispatchLT :: (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
dispatchLT :: (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
dispatchLT Q Exp -> Q Exp -> Q Exp -> Q Exp
f = do
Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
f (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
ltValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y)
dispatchFun :: OrdFun -> Q Exp
dispatchFun :: OrdFun -> Q Exp
dispatchFun OrdFun
oFun | OrdFun
oFun forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ OrdFun
OrdCompare, OrdFun
OrdLT
#if defined(NEW_FUNCTOR_CLASSES)
, OrdFun
Ord1LiftCompare, OrdFun
Ord2LiftCompare2
#else
, Ord1Compare1
#endif
]
= OrdFun -> Cxt -> [ConstructorInfo] -> Q Exp
makeOrdFunForCons OrdFun
oFun Cxt
instTypes [ConstructorInfo]
cons
dispatchFun OrdFun
OrdLE = (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
dispatchLT forall a b. (a -> b) -> a -> b
$ \Q Exp
lt Q Exp
x Q Exp
y -> Q Exp -> Q Exp
negateExpr forall a b. (a -> b) -> a -> b
$ Q Exp
lt forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
y forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x
dispatchFun OrdFun
OrdGT = (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
dispatchLT forall a b. (a -> b) -> a -> b
$ \Q Exp
lt Q Exp
x Q Exp
y -> Q Exp
lt forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
y forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x
dispatchFun OrdFun
OrdGE = (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
dispatchLT forall a b. (a -> b) -> a -> b
$ \Q Exp
lt Q Exp
x Q Exp
y -> Q Exp -> Q Exp
negateExpr forall a b. (a -> b) -> a -> b
$ Q Exp
lt forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
y
dispatchFun OrdFun
_ = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"ordFunDecs"
makeOrdFun :: OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun :: OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
oFun [Q Match]
matches Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
let oClass :: OrdClass
oClass = OrdFun -> OrdClass
ordFunToClass OrdFun
oFun
others :: [OrdFun]
others = OrdClass -> [ConstructorInfo] -> [OrdFun]
otherFuns OrdClass
oClass [ConstructorInfo]
cons
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance OrdClass
oClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
if OrdFun
oFun forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OrdFun]
compareFuns Bool -> Bool -> Bool
|| OrdFun
oFun forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OrdFun]
others
then OrdFun -> Cxt -> [ConstructorInfo] -> Q Exp
makeOrdFunForCons OrdFun
oFun Cxt
instTypes [ConstructorInfo]
cons
else do
Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (OrdFun -> Cxt -> [ConstructorInfo] -> Q Exp
makeOrdFunForCons (OrdClass -> OrdFun
ordClassToCompare OrdClass
oClass) Cxt
instTypes [ConstructorInfo]
cons
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y)
[Q Match]
matches
where
compareFuns :: [OrdFun]
compareFuns :: [OrdFun]
compareFuns = [ OrdFun
OrdCompare
#if defined(NEW_FUNCTOR_CLASSES)
, OrdFun
Ord1LiftCompare
, OrdFun
Ord2LiftCompare2
#else
, Ord1Compare1
#endif
]
makeOrdFunForCons :: OrdFun -> [Type] -> [ConstructorInfo] -> Q Exp
makeOrdFunForCons :: OrdFun -> Cxt -> [ConstructorInfo] -> Q Exp
makeOrdFunForCons OrdFun
oFun Cxt
instTypes [ConstructorInfo]
cons = do
let oClass :: OrdClass
oClass = OrdFun -> OrdClass
ordFunToClass OrdFun
oFun
Name
v1 <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"v1"
Name
v2 <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"v2"
Name
v1Hash <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"v1#"
Name
v2Hash <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"v2#"
[Name]
ords <- [Char] -> Int -> Q [Name]
newNameList [Char]
"ord" forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Int
arity OrdClass
oClass
let lastTyVars :: [Name]
lastTyVars :: [Name]
lastTyVars = forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTypes forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum OrdClass
oClass) Cxt
instTypes
tvMap :: TyVarMap1
tvMap :: TyVarMap1
tvMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
x Name
y -> (Name
x, Name -> OneOrTwoNames One
OneName Name
y)) [Name]
lastTyVars [Name]
ords
nullaryCons, nonNullaryCons :: [ConstructorInfo]
([ConstructorInfo]
nullaryCons, [ConstructorInfo]
nonNullaryCons) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons
singleConType :: Bool
singleConType :: Bool
singleConType = forall a. [a] -> Bool
isSingleton [ConstructorInfo]
cons
firstConName, lastConName :: Name
firstConName :: Name
firstConName = ConstructorInfo -> Name
constructorName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [ConstructorInfo]
cons
lastConName :: Name
lastConName = ConstructorInfo -> Name
constructorName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [ConstructorInfo]
cons
firstTag, lastTag :: Int
firstTag :: Int
firstTag = Int
0
lastTag :: Int
lastTag = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons forall a. Num a => a -> a -> a
- Int
1
dataConTagMap :: Map Name Int
dataConTagMap :: Map Name Int
dataConTagMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Name
constructorName [ConstructorInfo]
cons) [Int
0..]
ordMatches :: ConstructorInfo -> Q Match
ordMatches :: ConstructorInfo -> Q Match
ordMatches = OrdFun
-> Name
-> Name
-> TyVarMap1
-> Bool
-> Int
-> Name
-> Int
-> Name
-> Map Name Int
-> ConstructorInfo
-> Q Match
makeOrdFunForCon OrdFun
oFun Name
v2 Name
v2Hash TyVarMap1
tvMap Bool
singleConType
Int
firstTag Name
firstConName Int
lastTag Name
lastConName
Map Name Int
dataConTagMap
ordFunRhs :: Q Exp
ordFunRhs :: Q Exp
ordFunRhs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
= forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
eqDataName
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
nullaryCons forall a. Ord a => a -> a -> Bool
<= Int
2
= forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v1) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Match
ordMatches [ConstructorInfo]
cons
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
nonNullaryCons
= Q Exp
mkTagCmp
| Bool
otherwise
= forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v1) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Match
ordMatches [ConstructorInfo]
nonNullaryCons
forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
mkTagCmp) []]
mkTagCmp :: Q Exp
mkTagCmp :: Q Exp
mkTagCmp = [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
v1, Name
v1Hash), (Name
v2, Name
v2Hash)] forall a b. (a -> b) -> a -> b
$
Name -> OrdFun -> Name -> Name -> Q Exp
unliftedOrdFun Name
intHashTypeName OrdFun
oFun Name
v1Hash Name
v2Hash
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$
#if defined(NEW_FUNCTOR_CLASSES)
[Name]
ords forall a. [a] -> [a] -> [a]
++
#endif
[Name
v1, Name
v2])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ OrdFun -> Name
compareConstName OrdFun
oFun
, Q Exp
ordFunRhs
]
#if defined(NEW_FUNCTOR_CLASSES)
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
ords
#endif
forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v1, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2]
makeOrdFunForCon :: OrdFun
-> Name
-> Name
-> TyVarMap1
-> Bool
-> Int -> Name
-> Int -> Name
-> Map Name Int
-> ConstructorInfo -> Q Match
makeOrdFunForCon :: OrdFun
-> Name
-> Name
-> TyVarMap1
-> Bool
-> Int
-> Name
-> Int
-> Name
-> Map Name Int
-> ConstructorInfo
-> Q Match
makeOrdFunForCon OrdFun
oFun Name
v2 Name
v2Hash TyVarMap1
tvMap Bool
singleConType
Int
firstTag Name
firstConName Int
lastTag Name
lastConName Map Name Int
dataConTagMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
ts }) = do
Cxt
ts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms Cxt
ts
let tsLen :: Int
tsLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts'
[Name]
as <- [Char] -> Int -> Q [Name]
newNameList [Char]
"a" Int
tsLen
[Name]
bs <- [Char] -> Int -> Q [Name]
newNameList [Char]
"b" Int
tsLen
let innerRhs :: Q Exp
innerRhs :: Q Exp
innerRhs
| Bool
singleConType
= forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [Q Match
innerEqAlt]
| Int
tag forall a. Eq a => a -> a -> Bool
== Int
firstTag
= forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [Q Match
innerEqAlt, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []]
| Int
tag forall a. Eq a => a -> a -> Bool
== Int
lastTag
= forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [Q Match
innerEqAlt, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []]
| Int
tag forall a. Eq a => a -> a -> Bool
== Int
firstTag forall a. Num a => a -> a -> a
+ Int
1
= forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
firstConName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []
, Q Match
innerEqAlt
, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []
]
| Int
tag forall a. Eq a => a -> a -> Bool
== Int
lastTag forall a. Num a => a -> a -> a
- Int
1
= forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
lastConName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []
, Q Match
innerEqAlt
, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []
]
| Int
tag forall a. Ord a => a -> a -> Bool
> Int
lastTag forall a. Integral a => a -> a -> a
`div` Int
2
= [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
v2, Name
v2Hash)] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE (Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2Hash) Name
ltIntHashValName Q Exp
tagLit)
(OrdFun -> Q Exp
gtResult OrdFun
oFun) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [Q Match
innerEqAlt, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []]
| Bool
otherwise
= [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
v2, Name
v2Hash)] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE (Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2Hash) Name
gtIntHashValName Q Exp
tagLit)
(OrdFun -> Q Exp
ltResult OrdFun
oFun) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [Q Match
innerEqAlt, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []]
innerEqAlt :: Q Match
innerEqAlt :: Q Match
innerEqAlt = forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
bs)
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> TyVarMap1 -> Name -> Cxt -> [Name] -> [Name] -> Q Exp
makeOrdFunForFields OrdFun
oFun TyVarMap1
tvMap Name
conName Cxt
ts' [Name]
as [Name]
bs)
[]
tagLit :: Q Exp
tagLit :: Q Exp
tagLit = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
intPrimL forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tag
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
as)
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
innerRhs)
[]
where
tag :: Int
tag = Map Name Int
dataConTagMap forall k a. Ord k => Map k a -> k -> a
Map.! Name
conName
makeOrdFunForFields :: OrdFun
-> TyVarMap1
-> Name
-> [Type]
-> [Name]
-> [Name]
-> Q Exp
makeOrdFunForFields :: OrdFun -> TyVarMap1 -> Name -> Cxt -> [Name] -> [Name] -> Q Exp
makeOrdFunForFields OrdFun
oFun TyVarMap1
tvMap Name
conName = Cxt -> [Name] -> [Name] -> Q Exp
go
where
go :: [Type] -> [Name] -> [Name] -> Q Exp
go :: Cxt -> [Name] -> [Name] -> Q Exp
go [] [Name]
_ [Name]
_ = OrdFun -> Q Exp
eqResult OrdFun
oFun
go [Type
ty] [Name
a] [Name
b]
| Type -> Bool
isSupportedUnliftedType Type
ty = Name -> OrdFun -> Name -> Name -> Q Exp
unliftedOrdFun (Type -> Name
conTToName Type
ty) OrdFun
oFun Name
a Name
b
| Bool
otherwise = OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName Type
ty
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
b
go (Type
ty:Cxt
tys) (Name
a:[Name]
as) (Name
b:[Name]
bs) =
Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp
mkCompare Type
ty Name
a Name
b (OrdFun -> Q Exp
ltResult OrdFun
oFun) (Cxt -> [Name] -> [Name] -> Q Exp
go Cxt
tys [Name]
as [Name]
bs) (OrdFun -> Q Exp
gtResult OrdFun
oFun)
go Cxt
_ [Name]
_ [Name]
_ = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Data.Ord.Deriving.Internal.makeOrdFunForFields"
mkCompare :: Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp
mkCompare :: Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp
mkCompare Type
ty Name
a Name
b Q Exp
lt Q Exp
eq Q Exp
gt
| Type -> Bool
isSupportedUnliftedType Type
ty =
let (Name
ltFun, Name
_, Name
eqFun, Name
_, Name
_) = Name -> (Name, Name, Name, Name, Name)
primOrdFuns forall a b. (a -> b) -> a -> b
$ Type -> Name
conTToName Type
ty
in Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp
unliftedCompare Name
ltFun Name
eqFun Q Exp
aExpr Q Exp
bExpr Q Exp
lt Q Exp
eq Q Exp
gt
| Bool
otherwise
= forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType (OrdClass -> OrdFun
ordClassToCompare forall a b. (a -> b) -> a -> b
$ OrdFun -> OrdClass
ordFunToClass OrdFun
oFun)
TyVarMap1
tvMap Name
conName Type
ty forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
aExpr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
bExpr)
[ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ltDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
lt) []
, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
eqDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
eq) []
, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
gtDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
gt) []
]
where
aExpr, bExpr :: Q Exp
aExpr :: Q Exp
aExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a
bExpr :: Q Exp
bExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
b
makeOrdFunForType :: OrdFun
-> TyVarMap1
-> Name
-> Type
-> Q Exp
#if defined(NEW_FUNCTOR_CLASSES)
makeOrdFunForType :: OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
_ (VarT Name
tyName) =
forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName TyVarMap1
tvMap of
Just (OneName Name
ord) -> Name
ord
Maybe (OneOrTwoNames One)
Nothing -> OrdFun -> Int -> Name
ordFunName OrdFun
oFun Int
0
#else
makeOrdFunForType oFun _ _ VarT{} = varE $ ordFunName oFun 0
#endif
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName (SigT Type
ty Type
_) = OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName Type
ty
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName Type
ty
#if defined(NEW_FUNCTOR_CLASSES)
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName Type
ty = do
let oClass :: OrdClass
oClass :: OrdClass
oClass = OrdFun -> OrdClass
ordFunToClass OrdFun
oFun
tyCon :: Type
tyArgs :: [Type]
(Type
tyCon, Cxt
tyArgs) = Type -> (Type, Cxt)
unapplyTy Type
ty
numLastArgs :: Int
numLastArgs :: Int
numLastArgs = forall a. Ord a => a -> a -> a
min (forall a. ClassRep a => a -> Int
arity OrdClass
oClass) (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)
lhsArgs, rhsArgs :: [Type]
(Cxt
lhsArgs, Cxt
rhsArgs) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = forall k a. Map k a -> [k]
Map.keys TyVarMap1
tvMap
Bool
itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon Cxt
tyArgs
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs
Bool -> Bool -> Bool
|| Bool
itf Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
then forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError OrdClass
oClass Name
conName
else if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
then forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdFun -> Int -> Name
ordFunName OrdFun
oFun forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum Int
numLastArgs]
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName) Cxt
rhsArgs
else forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ OrdFun -> Int -> Name
ordFunName OrdFun
oFun Int
0
#else
makeOrdFunForType oFun tvMap conName ty = do
let varNames = Map.keys tvMap
oClass = ordFunToClass oFun
a' <- newName "a'"
b' <- newName "b'"
case varNames of
[] -> varE $ ordFunName oFun 0
varName:_ ->
if mentionsName ty varNames
then lamE (map varP [a',b']) $ varE (ordFunName oFun 1)
`appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE a')
`appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE b')
else varE $ ordFunName oFun 0
#endif
data OrdClass = Ord
| Ord1
#if defined(NEW_FUNCTOR_CLASSES)
| Ord2
#endif
deriving (OrdClass
forall a. a -> a -> Bounded a
maxBound :: OrdClass
$cmaxBound :: OrdClass
minBound :: OrdClass
$cminBound :: OrdClass
Bounded, Int -> OrdClass
OrdClass -> Int
OrdClass -> [OrdClass]
OrdClass -> OrdClass
OrdClass -> OrdClass -> [OrdClass]
OrdClass -> OrdClass -> OrdClass -> [OrdClass]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: OrdClass -> OrdClass -> OrdClass -> [OrdClass]
$cenumFromThenTo :: OrdClass -> OrdClass -> OrdClass -> [OrdClass]
enumFromTo :: OrdClass -> OrdClass -> [OrdClass]
$cenumFromTo :: OrdClass -> OrdClass -> [OrdClass]
enumFromThen :: OrdClass -> OrdClass -> [OrdClass]
$cenumFromThen :: OrdClass -> OrdClass -> [OrdClass]
enumFrom :: OrdClass -> [OrdClass]
$cenumFrom :: OrdClass -> [OrdClass]
fromEnum :: OrdClass -> Int
$cfromEnum :: OrdClass -> Int
toEnum :: Int -> OrdClass
$ctoEnum :: Int -> OrdClass
pred :: OrdClass -> OrdClass
$cpred :: OrdClass -> OrdClass
succ :: OrdClass -> OrdClass
$csucc :: OrdClass -> OrdClass
Enum)
instance ClassRep OrdClass where
arity :: OrdClass -> Int
arity = forall a. Enum a => a -> Int
fromEnum
allowExQuant :: OrdClass -> Bool
allowExQuant OrdClass
_ = Bool
True
fullClassName :: OrdClass -> Name
fullClassName OrdClass
Ord = Name
ordTypeName
fullClassName OrdClass
Ord1 = Name
ord1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
fullClassName OrdClass
Ord2 = Name
ord2TypeName
#endif
classConstraint :: OrdClass -> Int -> Maybe Name
classConstraint OrdClass
oClass Int
i
| Int
oMin forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
<= Int
oMax = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Name
fullClassName (forall a. Enum a => Int -> a
toEnum Int
i :: OrdClass)
| Bool
otherwise = forall a. Maybe a
Nothing
where
oMin, oMax :: Int
oMin :: Int
oMin = forall a. Enum a => a -> Int
fromEnum (forall a. Bounded a => a
minBound :: OrdClass)
oMax :: Int
oMax = forall a. Enum a => a -> Int
fromEnum OrdClass
oClass
compareConstName :: OrdFun -> Name
compareConstName :: OrdFun -> Name
compareConstName OrdFun
OrdCompare = Name
compareConstValName
compareConstName OrdFun
OrdLT = Name
ltConstValName
compareConstName OrdFun
OrdLE = Name
ltConstValName
compareConstName OrdFun
OrdGT = Name
ltConstValName
compareConstName OrdFun
OrdGE = Name
ltConstValName
#if defined(NEW_FUNCTOR_CLASSES)
compareConstName OrdFun
Ord1LiftCompare = Name
liftCompareConstValName
compareConstName OrdFun
Ord2LiftCompare2 = Name
liftCompare2ConstValName
#else
compareConstName Ord1Compare1 = compare1ConstValName
#endif
ordClassToCompare :: OrdClass -> OrdFun
ordClassToCompare :: OrdClass -> OrdFun
ordClassToCompare OrdClass
Ord = OrdFun
OrdCompare
#if defined(NEW_FUNCTOR_CLASSES)
ordClassToCompare OrdClass
Ord1 = OrdFun
Ord1LiftCompare
ordClassToCompare OrdClass
Ord2 = OrdFun
Ord2LiftCompare2
#else
ordClassToCompare Ord1 = Ord1Compare1
#endif
data OrdFun = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
#if defined(NEW_FUNCTOR_CLASSES)
| Ord1LiftCompare | Ord2LiftCompare2
#else
| Ord1Compare1
#endif
deriving OrdFun -> OrdFun -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OrdFun -> OrdFun -> Bool
$c/= :: OrdFun -> OrdFun -> Bool
== :: OrdFun -> OrdFun -> Bool
$c== :: OrdFun -> OrdFun -> Bool
Eq
ordFunName :: OrdFun -> Int -> Name
ordFunName :: OrdFun -> Int -> Name
ordFunName OrdFun
OrdCompare Int
0 = Name
compareValName
ordFunName OrdFun
OrdLT Int
0 = Name
ltValName
ordFunName OrdFun
OrdLE Int
0 = Name
leValName
ordFunName OrdFun
OrdGE Int
0 = Name
geValName
ordFunName OrdFun
OrdGT Int
0 = Name
gtValName
#if defined(NEW_FUNCTOR_CLASSES)
ordFunName OrdFun
Ord1LiftCompare Int
0 = OrdFun -> Int -> Name
ordFunName OrdFun
OrdCompare Int
0
ordFunName OrdFun
Ord1LiftCompare Int
1 = Name
liftCompareValName
ordFunName OrdFun
Ord2LiftCompare2 Int
0 = OrdFun -> Int -> Name
ordFunName OrdFun
OrdCompare Int
0
ordFunName OrdFun
Ord2LiftCompare2 Int
1 = OrdFun -> Int -> Name
ordFunName OrdFun
Ord1LiftCompare Int
1
ordFunName OrdFun
Ord2LiftCompare2 Int
2 = Name
liftCompare2ValName
#else
ordFunName Ord1Compare1 0 = ordFunName OrdCompare 0
ordFunName Ord1Compare1 1 = compare1ValName
#endif
ordFunName OrdFun
_ Int
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Data.Ord.Deriving.Internal.ordFunName"
ordFunToClass :: OrdFun -> OrdClass
ordFunToClass :: OrdFun -> OrdClass
ordFunToClass OrdFun
OrdCompare = OrdClass
Ord
ordFunToClass OrdFun
OrdLT = OrdClass
Ord
ordFunToClass OrdFun
OrdLE = OrdClass
Ord
ordFunToClass OrdFun
OrdGE = OrdClass
Ord
ordFunToClass OrdFun
OrdGT = OrdClass
Ord
#if defined(NEW_FUNCTOR_CLASSES)
ordFunToClass OrdFun
Ord1LiftCompare = OrdClass
Ord1
ordFunToClass OrdFun
Ord2LiftCompare2 = OrdClass
Ord2
#else
ordFunToClass Ord1Compare1 = Ord1
#endif
eqResult :: OrdFun -> Q Exp
eqResult :: OrdFun -> Q Exp
eqResult OrdFun
OrdCompare = Q Exp
eqTagExpr
eqResult OrdFun
OrdLT = Q Exp
falseExpr
eqResult OrdFun
OrdLE = Q Exp
trueExpr
eqResult OrdFun
OrdGE = Q Exp
trueExpr
eqResult OrdFun
OrdGT = Q Exp
falseExpr
#if defined(NEW_FUNCTOR_CLASSES)
eqResult OrdFun
Ord1LiftCompare = Q Exp
eqTagExpr
eqResult OrdFun
Ord2LiftCompare2 = Q Exp
eqTagExpr
#else
eqResult Ord1Compare1 = eqTagExpr
#endif
gtResult :: OrdFun -> Q Exp
gtResult :: OrdFun -> Q Exp
gtResult OrdFun
OrdCompare = Q Exp
gtTagExpr
gtResult OrdFun
OrdLT = Q Exp
falseExpr
gtResult OrdFun
OrdLE = Q Exp
falseExpr
gtResult OrdFun
OrdGE = Q Exp
trueExpr
gtResult OrdFun
OrdGT = Q Exp
trueExpr
#if defined(NEW_FUNCTOR_CLASSES)
gtResult OrdFun
Ord1LiftCompare = Q Exp
gtTagExpr
gtResult OrdFun
Ord2LiftCompare2 = Q Exp
gtTagExpr
#else
gtResult Ord1Compare1 = gtTagExpr
#endif
ltResult :: OrdFun -> Q Exp
ltResult :: OrdFun -> Q Exp
ltResult OrdFun
OrdCompare = Q Exp
ltTagExpr
ltResult OrdFun
OrdLT = Q Exp
trueExpr
ltResult OrdFun
OrdLE = Q Exp
trueExpr
ltResult OrdFun
OrdGE = Q Exp
falseExpr
ltResult OrdFun
OrdGT = Q Exp
falseExpr
#if defined(NEW_FUNCTOR_CLASSES)
ltResult OrdFun
Ord1LiftCompare = Q Exp
ltTagExpr
ltResult OrdFun
Ord2LiftCompare2 = Q Exp
ltTagExpr
#else
ltResult Ord1Compare1 = ltTagExpr
#endif
ltTagExpr, eqTagExpr, gtTagExpr, falseExpr, trueExpr :: Q Exp
ltTagExpr :: Q Exp
ltTagExpr = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
ltDataName
eqTagExpr :: Q Exp
eqTagExpr = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
eqDataName
gtTagExpr :: Q Exp
gtTagExpr = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
gtDataName
falseExpr :: Q Exp
falseExpr = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName
trueExpr :: Q Exp
trueExpr = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName
otherFuns :: OrdClass -> [ConstructorInfo] -> [OrdFun]
otherFuns :: OrdClass -> [ConstructorInfo] -> [OrdFun]
otherFuns OrdClass
_ [] = []
otherFuns OrdClass
oClass [ConstructorInfo]
cons = case OrdClass
oClass of
OrdClass
Ord1 -> []
#if defined(NEW_FUNCTOR_CLASSES)
OrdClass
Ord2 -> []
#endif
OrdClass
Ord | (Int
lastTag forall a. Num a => a -> a -> a
- Int
firstTag) forall a. Ord a => a -> a -> Bool
<= Int
2 Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
nonNullaryCons
-> [OrdFun
OrdLT, OrdFun
OrdLE, OrdFun
OrdGE, OrdFun
OrdGT]
| Bool
otherwise
-> []
where
firstTag, lastTag :: Int
firstTag :: Int
firstTag = Int
0
lastTag :: Int
lastTag = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons forall a. Num a => a -> a -> a
- Int
1
nonNullaryCons :: [ConstructorInfo]
nonNullaryCons :: [ConstructorInfo]
nonNullaryCons = forall a. (a -> Bool) -> [a] -> [a]
filterOut ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons
unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp
unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp
unliftedOrdFun Name
tyName OrdFun
oFun Name
a Name
b = case OrdFun
oFun of
OrdFun
OrdCompare -> Q Exp
unliftedCompareExpr
OrdFun
OrdLT -> Name -> Q Exp
wrap Name
ltFun
OrdFun
OrdLE -> Name -> Q Exp
wrap Name
leFun
OrdFun
OrdGE -> Name -> Q Exp
wrap Name
geFun
OrdFun
OrdGT -> Name -> Q Exp
wrap Name
gtFun
#if defined(NEW_FUNCTOR_CLASSES)
OrdFun
Ord1LiftCompare -> Q Exp
unliftedCompareExpr
OrdFun
Ord2LiftCompare2 -> Q Exp
unliftedCompareExpr
#else
Ord1Compare1 -> unliftedCompareExpr
#endif
where
unliftedCompareExpr :: Q Exp
unliftedCompareExpr :: Q Exp
unliftedCompareExpr = Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp
unliftedCompare Name
ltFun Name
eqFun Q Exp
aExpr Q Exp
bExpr
Q Exp
ltTagExpr Q Exp
eqTagExpr Q Exp
gtTagExpr
ltFun, leFun, eqFun, geFun, gtFun :: Name
(Name
ltFun, Name
leFun, Name
eqFun, Name
geFun, Name
gtFun) = Name -> (Name, Name, Name, Name, Name)
primOrdFuns Name
tyName
wrap :: Name -> Q Exp
wrap :: Name -> Q Exp
wrap Name
primFun = Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr Q Exp
aExpr Name
primFun Q Exp
bExpr
aExpr, bExpr :: Q Exp
aExpr :: Q Exp
aExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a
bExpr :: Q Exp
bExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
b
unliftedCompare :: Name -> Name
-> Q Exp -> Q Exp
-> Q Exp -> Q Exp -> Q Exp
-> Q Exp
unliftedCompare :: Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp
unliftedCompare Name
ltFun Name
eqFun Q Exp
aExpr Q Exp
bExpr Q Exp
lt Q Exp
eq Q Exp
gt =
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE (Q Exp -> Q Exp
ascribeBool forall a b. (a -> b) -> a -> b
$ Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr Q Exp
aExpr Name
ltFun Q Exp
bExpr) Q Exp
lt forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE (Q Exp -> Q Exp
ascribeBool forall a b. (a -> b) -> a -> b
$ Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr Q Exp
aExpr Name
eqFun Q Exp
bExpr) Q Exp
eq Q Exp
gt
where
ascribeBool :: Q Exp -> Q Exp
ascribeBool :: Q Exp -> Q Exp
ascribeBool Q Exp
e = forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE Q Exp
e forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Type
conT Name
boolTypeName
primOrdFuns :: Name -> (Name, Name, Name, Name, Name)
primOrdFuns :: Name -> (Name, Name, Name, Name, Name)
primOrdFuns Name
tyName =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (Name, Name, Name, Name, Name)
primOrdFunTbl of
Just (Name, Name, Name, Name, Name)
names -> (Name, Name, Name, Name, Name)
names
Maybe (Name, Name, Name, Name, Name)
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
tyName forall a. [a] -> [a] -> [a]
++ [Char]
" is not supported."
isSupportedUnliftedType :: Type -> Bool
isSupportedUnliftedType :: Type -> Bool
isSupportedUnliftedType (ConT Name
tyName) = forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
tyName Map Name (Name, Name, Name, Name, Name)
primOrdFunTbl
isSupportedUnliftedType Type
_ = Bool
False
isSingleton :: [a] -> Bool
isSingleton :: forall a. [a] -> Bool
isSingleton [a
_] = Bool
True
isSingleton [a]
_ = Bool
False
filterOut :: (a -> Bool) -> [a] -> [a]
filterOut :: forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
_ [] = []
filterOut a -> Bool
p (a
x:[a]
xs) | a -> Bool
p a
x = forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
p [a]
xs
| Bool
otherwise = a
x forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
p [a]
xs