{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}

{-|
Module:      Data.Ord.Deriving.Internal
Copyright:   (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Template Haskell

Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances.

Note: this is an internal module, and as such, the API presented here is not
guaranteed to be stable, even between minor releases of this library.
-}
module Data.Ord.Deriving.Internal (
      -- * 'Ord'
      deriveOrd
    , makeCompare
    , makeLE
    , makeLT
    , makeGT
    , makeGE
    , makeMax
    , makeMin
      -- * 'Ord1'
    , deriveOrd1
#if defined(NEW_FUNCTOR_CLASSES)
    , makeLiftCompare
#endif
    , makeCompare1
#if defined(NEW_FUNCTOR_CLASSES)
      -- * 'Ord2'
    , 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

-- | Generates an 'Ord' instance declaration for the given data type or data
-- family instance.
deriveOrd :: Name -> Q [Dec]
deriveOrd :: Name -> Q [Dec]
deriveOrd = OrdClass -> Name -> Q [Dec]
deriveOrdClass OrdClass
Ord

-- | Generates a lambda expression which behaves like 'compare' (without
-- requiring an 'Ord' instance).
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")

-- | Generates a lambda expression which behaves like '(<)' (without
-- requiring an 'Ord' instance).
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) []
                          ]

-- | Generates a lambda expression which behaves like '(<=)' (without
-- requiring an 'Ord' instance).
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)  []
                          ]

-- | Generates a lambda expression which behaves like '(>)' (without
-- requiring an 'Ord' instance).
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) []
                          ]

-- | Generates a lambda expression which behaves like '(>=)' (without
-- requiring an 'Ord' instance).
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)  []
                          ]

-- | Generates a lambda expression which behaves like 'max' (without
-- requiring an 'Ord' instance).
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

-- | Generates a lambda expression which behaves like 'min' (without
-- requiring an 'Ord' instance).
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

-- | Generates an 'Ord1' instance declaration for the given data type or data
-- family instance.
deriveOrd1 :: Name -> Q [Dec]
deriveOrd1 :: Name -> Q [Dec]
deriveOrd1 = OrdClass -> Name -> Q [Dec]
deriveOrdClass OrdClass
Ord1

#if defined(NEW_FUNCTOR_CLASSES)
-- | Generates a lambda expression which behaves like 'liftCompare' (without
-- requiring an 'Ord1' instance).
--
-- This function is not available with @transformers-0.4@.
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")

-- | Generates a lambda expression which behaves like 'compare1' (without
-- requiring an 'Ord1' instance).
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
-- | Generates a lambda expression which behaves like 'compare1' (without
-- requiring an 'Ord1' instance).
makeCompare1 :: Name -> Q Exp
makeCompare1 = makeOrdFun Ord1Compare1 (error "This shouldn't happen")
#endif

#if defined(NEW_FUNCTOR_CLASSES)
-- | Generates an 'Ord2' instance declaration for the given data type or data
-- family instance.
--
-- This function is not available with @transformers-0.4@.
deriveOrd2 :: Name -> Q [Dec]
deriveOrd2 :: Name -> Q [Dec]
deriveOrd2 = OrdClass -> Name -> Q [Dec]
deriveOrdClass OrdClass
Ord2

-- | Generates a lambda expression which behaves like 'liftCompare2' (without
-- requiring an 'Ord2' instance).
--
-- This function is not available with @transformers-0.4@.
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")

-- | Generates a lambda expression which behaves like 'compare2' (without
-- requiring an 'Ord2' instance).
--
-- This function is not available with @transformers-0.4@.
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

-------------------------------------------------------------------------------
-- Code generation
-------------------------------------------------------------------------------

-- | Derive an Ord(1)(2) instance declaration (depending on the OrdClass
-- argument's value).
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)

-- | Generates a declaration defining the primary function(s) corresponding to a
-- particular class (compare for Ord, liftCompare for Ord1, and
-- liftCompare2 for Ord2).
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
                                     -- OrdLT is included to mirror the fix to
                                     -- GHC Trac #10858.
#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"

-- | Generates a lambda expression which behaves like the OrdFun value. This
-- function uses heuristics to determine whether to implement the OrdFun from
-- scratch or define it in terms of compare.
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
      -- We force buildTypeInstance here since it performs some checks for whether
      -- or not the provided datatype can actually have compare/liftCompare/etc.
      -- implemented for it, and produces errors if it can't.
      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
                  ]

-- | Generates a lambda expression for the given constructors.
-- All constructors must be from the same type.
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

        -- Alternatively, we could look these up from dataConTagMap, but this
        -- is slightly faster due to the lack of Map lookups.
        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

-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------

-- | A representation of which @Ord@ variant is being derived.
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

-------------------------------------------------------------------------------
-- Assorted utilities
-------------------------------------------------------------------------------

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

-- Besides compare, that is
otherFuns :: OrdClass -> [ConstructorInfo] -> [OrdFun]
otherFuns :: OrdClass -> [ConstructorInfo] -> [OrdFun]
otherFuns OrdClass
_ [] = [] -- We only need compare for empty data types.
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          -- What to compare
                -> Q Exp -> Q Exp -> Q Exp -- Three results
                -> 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

-- | Like 'filter', only it reverses the sense of the test
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