{-# 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 ([Char] -> [Q Match]
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 [ PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
ltDataName []) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
trueDataName) []
, PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
falseDataName) []
]
makeLE :: Name -> Q Exp
makeLE :: Name -> Q Exp
makeLE = OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
OrdLE [ PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
gtDataName []) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
falseDataName) []
, PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
trueDataName) []
]
makeGT :: Name -> Q Exp
makeGT :: Name -> Q Exp
makeGT = OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
OrdGT [ PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
gtDataName []) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
trueDataName) []
, PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
falseDataName) []
]
makeGE :: Name -> Q Exp
makeGE :: Name -> Q Exp
makeGE = OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun OrdFun
OrdGE [ PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
ltDataName []) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
falseDataName) []
, PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q 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 (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
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 (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
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 <- [Char] -> Q Name
newName [Char]
"x"
Name
y <- [Char] -> Q Name
newName [Char]
"y"
let xExpr :: Q Exp
xExpr = Name -> Q Exp
varE Name
x
yExpr :: Q Exp
yExpr = Name -> Q Exp
varE Name
y
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x, Name -> PatQ
varP Name
y] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
(Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
f (Q Exp -> Q Exp -> Q Exp -> Q Exp
condE (Q Exp -> Q Exp -> Q Exp -> Q Exp)
-> Q Exp -> Q Exp -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
makeLE Name
name Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
xExpr Q Exp -> Q Exp -> Q 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 ([Char] -> [Q Match]
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 Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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 ([Char] -> [Q Match]
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
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
compareValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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)
<- OrdClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance OrdClass
oClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> DecQ -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(OrdClass -> Cxt -> [ConstructorInfo] -> [DecQ]
ordFunDecs OrdClass
oClass Cxt
instTypes [ConstructorInfo]
cons)
ordFunDecs :: OrdClass -> [Type] -> [ConstructorInfo] -> [Q Dec]
ordFunDecs :: OrdClass -> Cxt -> [ConstructorInfo] -> [DecQ]
ordFunDecs OrdClass
oClass Cxt
instTypes [ConstructorInfo]
cons =
(OrdFun -> DecQ) -> [OrdFun] -> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map OrdFun -> DecQ
makeFunD ([OrdFun] -> [DecQ]) -> [OrdFun] -> [DecQ]
forall a b. (a -> b) -> a -> b
$ OrdClass -> OrdFun
ordClassToCompare OrdClass
oClass OrdFun -> [OrdFun] -> [OrdFun]
forall a. a -> [a] -> [a]
: OrdClass -> [ConstructorInfo] -> [OrdFun]
otherFuns OrdClass
oClass [ConstructorInfo]
cons
where
makeFunD :: OrdFun -> Q Dec
makeFunD :: OrdFun -> DecQ
makeFunD OrdFun
oFun =
Name -> [ClauseQ] -> DecQ
funD (OrdFun -> Int -> Name
ordFunName OrdFun
oFun (Int -> Name) -> Int -> Name
forall a b. (a -> b) -> a -> b
$ OrdClass -> Int
forall a. ClassRep a => a -> Int
arity OrdClass
oClass)
[ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
dispatchFun OrdFun
oFun)
[]
]
negateExpr :: Q Exp -> Q Exp
negateExpr :: Q Exp -> Q Exp
negateExpr = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q 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 <- [Char] -> Q Name
newName [Char]
"x"
Name
y <- [Char] -> Q Name
newName [Char]
"y"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x, Name -> PatQ
varP Name
y] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
f (Name -> Q Exp
varE Name
ltValName) (Name -> Q Exp
varE Name
x) (Name -> Q Exp
varE Name
y)
dispatchFun :: OrdFun -> Q Exp
dispatchFun :: OrdFun -> Q Exp
dispatchFun OrdFun
oFun | OrdFun
oFun OrdFun -> [OrdFun] -> Bool
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 ((Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
lt Q Exp
x Q Exp
y -> Q Exp -> Q Exp
negateExpr (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp
lt Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
y Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
x
dispatchFun OrdFun
OrdGT = (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
dispatchLT ((Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
lt Q Exp
x Q Exp
y -> Q Exp
lt Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
y Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
x
dispatchFun OrdFun
OrdGE = (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
dispatchLT ((Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
lt Q Exp
x Q Exp
y -> Q Exp -> Q Exp
negateExpr (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp
lt Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
x Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
y
dispatchFun OrdFun
_ = [Char] -> Q Exp
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
OrdClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance OrdClass
oClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant Q (Cxt, Type) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
if OrdFun
oFun OrdFun -> [OrdFun] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OrdFun]
compareFuns Bool -> Bool -> Bool
|| OrdFun
oFun OrdFun -> [OrdFun] -> Bool
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 <- [Char] -> Q Name
newName [Char]
"x"
Name
y <- [Char] -> Q Name
newName [Char]
"y"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x, Name -> PatQ
varP Name
y] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> [Q Match] -> Q Exp
caseE (OrdFun -> Cxt -> [ConstructorInfo] -> Q Exp
makeOrdFunForCons (OrdClass -> OrdFun
ordClassToCompare OrdClass
oClass) Cxt
instTypes [ConstructorInfo]
cons
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
x Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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 <- [Char] -> Q Name
newName [Char]
"v1"
Name
v2 <- [Char] -> Q Name
newName [Char]
"v2"
Name
v1Hash <- [Char] -> Q Name
newName [Char]
"v1#"
Name
v2Hash <- [Char] -> Q Name
newName [Char]
"v2#"
[Name]
ords <- [Char] -> Int -> Q [Name]
newNameList [Char]
"ord" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ OrdClass -> Int
forall a. ClassRep a => a -> Int
arity OrdClass
oClass
let lastTyVars :: [Name]
lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
- OrdClass -> Int
forall a. Enum a => a -> Int
fromEnum OrdClass
oClass) Cxt
instTypes
tvMap :: TyVarMap1
tvMap :: TyVarMap1
tvMap = [(Name, OneOrTwoNames One)] -> TyVarMap1
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, OneOrTwoNames One)] -> TyVarMap1)
-> [(Name, OneOrTwoNames One)] -> TyVarMap1
forall a b. (a -> b) -> a -> b
$ (Name -> Name -> (Name, OneOrTwoNames One))
-> [Name] -> [Name] -> [(Name, OneOrTwoNames One)]
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) = (ConstructorInfo -> Bool)
-> [ConstructorInfo] -> ([ConstructorInfo], [ConstructorInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons
singleConType :: Bool
singleConType :: Bool
singleConType = [ConstructorInfo] -> Bool
forall a. [a] -> Bool
isSingleton [ConstructorInfo]
cons
firstConName, lastConName :: Name
firstConName :: Name
firstConName = ConstructorInfo -> Name
constructorName (ConstructorInfo -> Name) -> ConstructorInfo -> Name
forall a b. (a -> b) -> a -> b
$ [ConstructorInfo] -> ConstructorInfo
forall a. [a] -> a
head [ConstructorInfo]
cons
lastConName :: Name
lastConName = ConstructorInfo -> Name
constructorName (ConstructorInfo -> Name) -> ConstructorInfo -> Name
forall a b. (a -> b) -> a -> b
$ [ConstructorInfo] -> ConstructorInfo
forall a. [a] -> a
last [ConstructorInfo]
cons
firstTag, lastTag :: Int
firstTag :: Int
firstTag = Int
0
lastTag :: Int
lastTag = [ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
dataConTagMap :: Map Name Int
dataConTagMap :: Map Name Int
dataConTagMap = [(Name, Int)] -> Map Name Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Int)] -> Map Name Int) -> [(Name, Int)] -> Map Name Int
forall a b. (a -> b) -> a -> b
$ [Name] -> [Int] -> [(Name, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((ConstructorInfo -> Name) -> [ConstructorInfo] -> [Name]
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
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
= Name -> Q Exp
conE Name
eqDataName
| [ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
nullaryCons Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2
= Q Exp -> [Q Match] -> Q Exp
caseE (Name -> Q Exp
varE Name
v1) ([Q Match] -> Q Exp) -> [Q Match] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> Q Match) -> [ConstructorInfo] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Match
ordMatches [ConstructorInfo]
cons
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
nonNullaryCons
= Q Exp
mkTagCmp
| Bool
otherwise
= Q Exp -> [Q Match] -> Q Exp
caseE (Name -> Q Exp
varE Name
v1) ([Q Match] -> Q Exp) -> [Q Match] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> Q Match) -> [ConstructorInfo] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Match
ordMatches [ConstructorInfo]
nonNullaryCons
[Q Match] -> [Q Match] -> [Q Match]
forall a. [a] -> [a] -> [a]
++ [PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
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)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Name -> OrdFun -> Name -> Name -> Q Exp
unliftedOrdFun Name
intHashTypeName OrdFun
oFun Name
v1Hash Name
v2Hash
[PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP ([Name] -> [PatQ]) -> [Name] -> [PatQ]
forall a b. (a -> b) -> a -> b
$
#if defined(NEW_FUNCTOR_CLASSES)
[Name]
ords [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
#endif
[Name
v1, Name
v2])
(Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE
([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ OrdFun -> Name
compareConstName OrdFun
oFun
, Q Exp
ordFunRhs
]
#if defined(NEW_FUNCTOR_CLASSES)
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
ords
#endif
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Name -> Q Exp
varE Name
v1, Name -> Q 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' <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
ts
let tsLen :: Int
tsLen = Cxt -> Int
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
= Q Exp -> [Q Match] -> Q Exp
caseE (Name -> Q Exp
varE Name
v2) [Q Match
innerEqAlt]
| Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
firstTag
= Q Exp -> [Q Match] -> Q Exp
caseE (Name -> Q Exp
varE Name
v2) [Q Match
innerEqAlt, PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []]
| Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lastTag
= Q Exp -> [Q Match] -> Q Exp
caseE (Name -> Q Exp
varE Name
v2) [Q Match
innerEqAlt, PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []]
| Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
firstTag Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
= Q Exp -> [Q Match] -> Q Exp
caseE (Name -> Q Exp
varE Name
v2) [ PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [FieldPatQ] -> PatQ
recP Name
firstConName []) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []
, Q Match
innerEqAlt
, PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []
]
| Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lastTag Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
= Q Exp -> [Q Match] -> Q Exp
caseE (Name -> Q Exp
varE Name
v2) [ PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [FieldPatQ] -> PatQ
recP Name
lastConName []) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []
, Q Match
innerEqAlt
, PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []
]
| Int
tag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastTag Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
= [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
v2, Name
v2Hash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> Q Exp -> Q Exp -> Q Exp
condE (Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (Name -> Q Exp
varE Name
v2Hash) Name
ltIntHashValName Q Exp
tagLit)
(OrdFun -> Q Exp
gtResult OrdFun
oFun) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> [Q Match] -> Q Exp
caseE (Name -> Q Exp
varE Name
v2) [Q Match
innerEqAlt, PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
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)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> Q Exp -> Q Exp -> Q Exp
condE (Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (Name -> Q Exp
varE Name
v2Hash) Name
gtIntHashValName Q Exp
tagLit)
(OrdFun -> Q Exp
ltResult OrdFun
oFun) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> [Q Match] -> Q Exp
caseE (Name -> Q Exp
varE Name
v2) [Q Match
innerEqAlt, PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []]
innerEqAlt :: Q Match
innerEqAlt :: Q Match
innerEqAlt = PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
bs)
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
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 = Lit -> Q Exp
litE (Lit -> Q Exp) -> (Integer -> Lit) -> Integer -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
intPrimL (Integer -> Q Exp) -> Integer -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tag
PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
as)
(Q Exp -> BodyQ
normalB Q Exp
innerRhs)
[]
where
tag :: Int
tag = Map Name Int
dataConTagMap Map Name Int -> Name -> Int
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
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
a Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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]
_ = [Char] -> Q Exp
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 (Name -> (Name, Name, Name, Name, Name))
-> Name -> (Name, Name, Name, Name, Name)
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
= Q Exp -> [Q Match] -> Q Exp
caseE (OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType (OrdClass -> OrdFun
ordClassToCompare (OrdClass -> OrdFun) -> OrdClass -> OrdFun
forall a b. (a -> b) -> a -> b
$ OrdFun -> OrdClass
ordFunToClass OrdFun
oFun)
TyVarMap1
tvMap Name
conName Type
ty Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
aExpr Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
bExpr)
[ PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
ltDataName []) (Q Exp -> BodyQ
normalB Q Exp
lt) []
, PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
eqDataName []) (Q Exp -> BodyQ
normalB Q Exp
eq) []
, PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
gtDataName []) (Q Exp -> BodyQ
normalB Q Exp
gt) []
]
where
aExpr, bExpr :: Q Exp
aExpr :: Q Exp
aExpr = Name -> Q Exp
varE Name
a
bExpr :: Q Exp
bExpr = Name -> Q 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) =
Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ case Name -> TyVarMap1 -> Maybe (OneOrTwoNames One)
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]
_ 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 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (OrdClass -> Int
forall a. ClassRep a => a -> Int
arity OrdClass
oClass) (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)
lhsArgs, rhsArgs :: [Type]
(Cxt
lhsArgs, Cxt
rhsArgs) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = TyVarMap1 -> [Name]
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 (Type -> Bool) -> Cxt -> Bool
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
&& (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
then OrdClass -> Name -> Q Exp
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError OrdClass
oClass Name
conName
else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
then [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> (Int -> Name) -> Int -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdFun -> Int -> Name
ordFunName OrdFun
oFun (Int -> Q Exp) -> Int -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => Int -> a
toEnum Int
numLastArgs]
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Type -> Q Exp) -> Cxt -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName) Cxt
rhsArgs
else Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
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
OrdClass -> OrdClass -> Bounded 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]
(OrdClass -> OrdClass)
-> (OrdClass -> OrdClass)
-> (Int -> OrdClass)
-> (OrdClass -> Int)
-> (OrdClass -> [OrdClass])
-> (OrdClass -> OrdClass -> [OrdClass])
-> (OrdClass -> OrdClass -> [OrdClass])
-> (OrdClass -> OrdClass -> OrdClass -> [OrdClass])
-> Enum 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 = OrdClass -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
oMax = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ OrdClass -> Name
forall a. ClassRep a => a -> Name
fullClassName (Int -> OrdClass
forall a. Enum a => Int -> a
toEnum Int
i :: OrdClass)
| Bool
otherwise = Maybe Name
forall a. Maybe a
Nothing
where
oMin, oMax :: Int
oMin :: Int
oMin = OrdClass -> Int
forall a. Enum a => a -> Int
fromEnum (OrdClass
forall a. Bounded a => a
minBound :: OrdClass)
oMax :: Int
oMax = OrdClass -> Int
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
(OrdFun -> OrdFun -> Bool)
-> (OrdFun -> OrdFun -> Bool) -> Eq OrdFun
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
_ = [Char] -> Name
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 = Name -> Q Exp
conE Name
ltDataName
eqTagExpr :: Q Exp
eqTagExpr = Name -> Q Exp
conE Name
eqDataName
gtTagExpr :: Q Exp
gtTagExpr = Name -> Q Exp
conE Name
gtDataName
falseExpr :: Q Exp
falseExpr = Name -> Q Exp
conE Name
falseDataName
trueExpr :: Q Exp
trueExpr = Name -> Q 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstTag) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 Bool -> Bool -> Bool
|| [ConstructorInfo] -> 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 = [ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
nonNullaryCons :: [ConstructorInfo]
nonNullaryCons :: [ConstructorInfo]
nonNullaryCons = (ConstructorInfo -> Bool) -> [ConstructorInfo] -> [ConstructorInfo]
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 = Name -> Q Exp
varE Name
a
bExpr :: Q Exp
bExpr = Name -> Q 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 =
Q Exp -> Q Exp -> Q Exp -> Q Exp
condE (Q Exp -> Q Exp
ascribeBool (Q Exp -> Q Exp) -> Q Exp -> Q Exp
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 (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> Q Exp -> Q Exp -> Q Exp
condE (Q Exp -> Q Exp
ascribeBool (Q Exp -> Q Exp) -> Q Exp -> Q Exp
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 = Q Exp -> TypeQ -> Q Exp
sigE Q Exp
e (TypeQ -> Q Exp) -> TypeQ -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> TypeQ
conT Name
boolTypeName
primOrdFuns :: Name -> (Name, Name, Name, Name, Name)
primOrdFuns :: Name -> (Name, Name, Name, Name, Name)
primOrdFuns Name
tyName =
case Name
-> Map Name (Name, Name, Name, Name, Name)
-> Maybe (Name, Name, Name, Name, Name)
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 -> [Char] -> (Name, Name, Name, Name, Name)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Name, Name, Name, Name, Name))
-> [Char] -> (Name, Name, Name, Name, Name)
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
tyName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not supported."
isSupportedUnliftedType :: Type -> Bool
isSupportedUnliftedType :: Type -> Bool
isSupportedUnliftedType (ConT Name
tyName) = Name -> Map Name (Name, Name, Name, Name, Name) -> Bool
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 :: [a] -> Bool
isSingleton [a
_] = Bool
True
isSingleton [a]
_ = Bool
False
filterOut :: (a -> Bool) -> [a] -> [a]
filterOut :: (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
_ [] = []
filterOut a -> Bool
p (a
x:[a]
xs) | a -> Bool
p a
x = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
p [a]
xs
| Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
p [a]
xs