{-# 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 (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 [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ltDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName)  []
                          , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP                (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName) []
                          ]

-- | 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 [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
gtDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName) []
                          , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP                (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName)  []
                          ]

-- | 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 [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
gtDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName)  []
                          , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP                (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName) []
                          ]

-- | 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 [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ltDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName) []
                          , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP                (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName)  []
                          ]

-- | 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 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 forall a. a -> a
id

makeMinMax :: ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp)
           -> Name -> Q Exp
makeMinMax :: ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp)
-> Name -> Q Exp
makeMinMax (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
f Name
name = do
    Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
    Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
    let xExpr :: Q Exp
xExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x
        yExpr :: Q Exp
yExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] forall a b. (a -> b) -> a -> b
$
        (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
f (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
makeLE Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
xExpr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
yExpr) Q Exp
xExpr Q Exp
yExpr

-- | 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 (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 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 (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
             forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
compareValName
             forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
compareValName
#endif

-------------------------------------------------------------------------------

-- 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)
          <- forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance OrdClass
oClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
      (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
                             (forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
                             (OrdClass -> Cxt -> [ConstructorInfo] -> [Q Dec]
ordFunDecs OrdClass
oClass Cxt
instTypes [ConstructorInfo]
cons)

-- | 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] -> [Q Dec]
ordFunDecs OrdClass
oClass Cxt
instTypes [ConstructorInfo]
cons =
    forall a b. (a -> b) -> [a] -> [b]
map OrdFun -> Q Dec
makeFunD forall a b. (a -> b) -> a -> b
$ OrdClass -> OrdFun
ordClassToCompare OrdClass
oClass forall a. a -> [a] -> [a]
: OrdClass -> [ConstructorInfo] -> [OrdFun]
otherFuns OrdClass
oClass [ConstructorInfo]
cons
  where
    makeFunD :: OrdFun -> Q Dec
    makeFunD :: OrdFun -> Q Dec
makeFunD OrdFun
oFun =
      forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (OrdFun -> Int -> Name
ordFunName OrdFun
oFun forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Int
arity OrdClass
oClass)
           [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                    (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
dispatchFun OrdFun
oFun)
                    []
           ]

    negateExpr :: Q Exp -> Q Exp
    negateExpr :: Q Exp -> Q Exp
negateExpr = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
notValName)

    dispatchLT :: (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
    dispatchLT :: (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
dispatchLT Q Exp -> Q Exp -> Q Exp -> Q Exp
f = do
        Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
        Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
        forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
f (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
ltValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y)

    dispatchFun :: OrdFun -> Q Exp
    dispatchFun :: OrdFun -> Q Exp
dispatchFun OrdFun
oFun | OrdFun
oFun forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ OrdFun
OrdCompare, OrdFun
OrdLT
                                     -- 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 forall a b. (a -> b) -> a -> b
$ \Q Exp
lt Q Exp
x Q Exp
y -> Q Exp -> Q Exp
negateExpr forall a b. (a -> b) -> a -> b
$ Q Exp
lt forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
y forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x
    dispatchFun OrdFun
OrdGT = (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
dispatchLT forall a b. (a -> b) -> a -> b
$ \Q Exp
lt Q Exp
x Q Exp
y ->              Q Exp
lt forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
y forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x
    dispatchFun OrdFun
OrdGE = (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
dispatchLT forall a b. (a -> b) -> a -> b
$ \Q Exp
lt Q Exp
x Q Exp
y -> Q Exp -> Q Exp
negateExpr forall a b. (a -> b) -> a -> b
$ Q Exp
lt forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
y
    dispatchFun OrdFun
_     = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"ordFunDecs"

-- | 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.

      forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance OrdClass
oClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
        if OrdFun
oFun forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OrdFun]
compareFuns Bool -> Bool -> Bool
|| OrdFun
oFun forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OrdFun]
others
           then OrdFun -> Cxt -> [ConstructorInfo] -> Q Exp
makeOrdFunForCons OrdFun
oFun Cxt
instTypes [ConstructorInfo]
cons
           else do
             Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
             Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
             forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] forall a b. (a -> b) -> a -> b
$
                  forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (OrdFun -> Cxt -> [ConstructorInfo] -> Q Exp
makeOrdFunForCons (OrdClass -> OrdFun
ordClassToCompare OrdClass
oClass) Cxt
instTypes [ConstructorInfo]
cons
                             forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y)
                        [Q Match]
matches
  where
    compareFuns :: [OrdFun]
    compareFuns :: [OrdFun]
compareFuns = [ OrdFun
OrdCompare
#if defined(NEW_FUNCTOR_CLASSES)
                  , OrdFun
Ord1LiftCompare
                  , OrdFun
Ord2LiftCompare2
#else
                  , Ord1Compare1
#endif
                  ]

-- | 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     <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"v1"
    Name
v2     <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"v2"
    Name
v1Hash <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"v1#"
    Name
v2Hash <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"v2#"
    [Name]
ords   <- [Char] -> Int -> Q [Name]
newNameList [Char]
"ord" forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Int
arity OrdClass
oClass

    let lastTyVars :: [Name]
        lastTyVars :: [Name]
lastTyVars = forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTypes forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum OrdClass
oClass) Cxt
instTypes

        tvMap :: TyVarMap1
        tvMap :: TyVarMap1
tvMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
x Name
y -> (Name
x, Name -> OneOrTwoNames One
OneName Name
y)) [Name]
lastTyVars [Name]
ords

        nullaryCons, nonNullaryCons :: [ConstructorInfo]
        ([ConstructorInfo]
nullaryCons, [ConstructorInfo]
nonNullaryCons) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons

        singleConType :: Bool
        singleConType :: Bool
singleConType = forall a. [a] -> Bool
isSingleton [ConstructorInfo]
cons

        firstConName, lastConName :: Name
        firstConName :: Name
firstConName = ConstructorInfo -> Name
constructorName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [ConstructorInfo]
cons
        lastConName :: Name
lastConName  = ConstructorInfo -> Name
constructorName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [ConstructorInfo]
cons

        -- 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  = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons forall a. Num a => a -> a -> a
- Int
1

        dataConTagMap :: Map Name Int
        dataConTagMap :: Map Name Int
dataConTagMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Name
constructorName [ConstructorInfo]
cons) [Int
0..]

        ordMatches :: ConstructorInfo -> Q Match
        ordMatches :: ConstructorInfo -> Q Match
ordMatches = OrdFun
-> Name
-> Name
-> TyVarMap1
-> Bool
-> Int
-> Name
-> Int
-> Name
-> Map Name Int
-> ConstructorInfo
-> Q Match
makeOrdFunForCon OrdFun
oFun Name
v2 Name
v2Hash TyVarMap1
tvMap Bool
singleConType
                                      Int
firstTag Name
firstConName Int
lastTag Name
lastConName
                                      Map Name Int
dataConTagMap

        ordFunRhs :: Q Exp
        ordFunRhs :: Q Exp
ordFunRhs
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
          = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
eqDataName
          | forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
nullaryCons forall a. Ord a => a -> a -> Bool
<= Int
2
          = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v1) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Match
ordMatches [ConstructorInfo]
cons
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
nonNullaryCons
          = Q Exp
mkTagCmp
          | Bool
otherwise
          = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v1) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Match
ordMatches [ConstructorInfo]
nonNullaryCons
                forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
mkTagCmp) []]

        mkTagCmp :: Q Exp
        mkTagCmp :: Q Exp
mkTagCmp = [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
v1, Name
v1Hash), (Name
v2, Name
v2Hash)] forall a b. (a -> b) -> a -> b
$
                       Name -> OrdFun -> Name -> Name -> Q Exp
unliftedOrdFun Name
intHashTypeName OrdFun
oFun Name
v1Hash Name
v2Hash

    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$
#if defined(NEW_FUNCTOR_CLASSES)
                     [Name]
ords forall a. [a] -> [a] -> [a]
++
#endif
                     [Name
v1, Name
v2])
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
        forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ OrdFun -> Name
compareConstName OrdFun
oFun
          , Q Exp
ordFunRhs
          ]
#if defined(NEW_FUNCTOR_CLASSES)
            forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
ords
#endif
            forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v1, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2]

makeOrdFunForCon :: OrdFun
                 -> Name
                 -> Name
                 -> TyVarMap1
                 -> Bool
                 -> Int -> Name
                 -> Int -> Name
                 -> Map Name Int
                 -> ConstructorInfo -> Q Match
makeOrdFunForCon :: OrdFun
-> Name
-> Name
-> TyVarMap1
-> Bool
-> Int
-> Name
-> Int
-> Name
-> Map Name Int
-> ConstructorInfo
-> Q Match
makeOrdFunForCon OrdFun
oFun Name
v2 Name
v2Hash TyVarMap1
tvMap Bool
singleConType
                 Int
firstTag Name
firstConName Int
lastTag Name
lastConName Map Name Int
dataConTagMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
ts }) = do
    Cxt
ts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms Cxt
ts
    let tsLen :: Int
tsLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts'
    [Name]
as <- [Char] -> Int -> Q [Name]
newNameList [Char]
"a" Int
tsLen
    [Name]
bs <- [Char] -> Int -> Q [Name]
newNameList [Char]
"b" Int
tsLen

    let innerRhs :: Q Exp
        innerRhs :: Q Exp
innerRhs
          | Bool
singleConType
          = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [Q Match
innerEqAlt]

          | Int
tag forall a. Eq a => a -> a -> Bool
== Int
firstTag
          = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [Q Match
innerEqAlt, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []]

          | Int
tag forall a. Eq a => a -> a -> Bool
== Int
lastTag
          = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [Q Match
innerEqAlt, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []]

          | Int
tag forall a. Eq a => a -> a -> Bool
== Int
firstTag forall a. Num a => a -> a -> a
+ Int
1
          = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
firstConName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []
                            , Q Match
innerEqAlt
                            , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []
                            ]

          | Int
tag forall a. Eq a => a -> a -> Bool
== Int
lastTag forall a. Num a => a -> a -> a
- Int
1
          = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
lastConName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []
                            , Q Match
innerEqAlt
                            , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []
                            ]

          | Int
tag forall a. Ord a => a -> a -> Bool
> Int
lastTag forall a. Integral a => a -> a -> a
`div` Int
2
          = [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
v2, Name
v2Hash)] forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE (Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2Hash) Name
ltIntHashValName Q Exp
tagLit)
                  (OrdFun -> Q Exp
gtResult OrdFun
oFun) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [Q Match
innerEqAlt, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
ltResult OrdFun
oFun) []]

          | Bool
otherwise
          = [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
v2, Name
v2Hash)] forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE (Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2Hash) Name
gtIntHashValName Q Exp
tagLit)
                  (OrdFun -> Q Exp
ltResult OrdFun
oFun) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v2) [Q Match
innerEqAlt, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> Q Exp
gtResult OrdFun
oFun) []]

        innerEqAlt :: Q Match
        innerEqAlt :: Q Match
innerEqAlt = forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
bs)
                           (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ OrdFun -> TyVarMap1 -> Name -> Cxt -> [Name] -> [Name] -> Q Exp
makeOrdFunForFields OrdFun
oFun TyVarMap1
tvMap Name
conName Cxt
ts' [Name]
as [Name]
bs)
                           []

        tagLit :: Q Exp
        tagLit :: Q Exp
tagLit = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
intPrimL forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tag

    forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
as)
          (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
innerRhs)
          []
  where
    tag :: Int
tag = Map Name Int
dataConTagMap forall k a. Ord k => Map k a -> k -> a
Map.! Name
conName

makeOrdFunForFields :: OrdFun
                    -> TyVarMap1
                    -> Name
                    -> [Type]
                    -> [Name]
                    -> [Name]
                    -> Q Exp
makeOrdFunForFields :: OrdFun -> TyVarMap1 -> Name -> Cxt -> [Name] -> [Name] -> Q Exp
makeOrdFunForFields OrdFun
oFun TyVarMap1
tvMap Name
conName = Cxt -> [Name] -> [Name] -> Q Exp
go
  where
    go :: [Type] -> [Name] -> [Name] -> Q Exp
    go :: Cxt -> [Name] -> [Name] -> Q Exp
go [] [Name]
_ [Name]
_ = OrdFun -> Q Exp
eqResult OrdFun
oFun
    go [Type
ty] [Name
a] [Name
b]
      | Type -> Bool
isSupportedUnliftedType Type
ty = Name -> OrdFun -> Name -> Name -> Q Exp
unliftedOrdFun (Type -> Name
conTToName Type
ty) OrdFun
oFun Name
a Name
b
      | Bool
otherwise = OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName Type
ty
                        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
b
    go (Type
ty:Cxt
tys) (Name
a:[Name]
as) (Name
b:[Name]
bs) =
        Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp
mkCompare Type
ty Name
a Name
b (OrdFun -> Q Exp
ltResult OrdFun
oFun) (Cxt -> [Name] -> [Name] -> Q Exp
go Cxt
tys [Name]
as [Name]
bs) (OrdFun -> Q Exp
gtResult OrdFun
oFun)
    go Cxt
_ [Name]
_ [Name]
_ = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Data.Ord.Deriving.Internal.makeOrdFunForFields"

    mkCompare :: Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp
    mkCompare :: Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp
mkCompare Type
ty Name
a Name
b Q Exp
lt Q Exp
eq Q Exp
gt
      | Type -> Bool
isSupportedUnliftedType Type
ty =
          let (Name
ltFun, Name
_, Name
eqFun, Name
_, Name
_) = Name -> (Name, Name, Name, Name, Name)
primOrdFuns forall a b. (a -> b) -> a -> b
$ Type -> Name
conTToName Type
ty
          in Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp
unliftedCompare Name
ltFun Name
eqFun Q Exp
aExpr Q Exp
bExpr Q Exp
lt Q Exp
eq Q Exp
gt
      | Bool
otherwise
      = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType (OrdClass -> OrdFun
ordClassToCompare forall a b. (a -> b) -> a -> b
$ OrdFun -> OrdClass
ordFunToClass OrdFun
oFun)
                   TyVarMap1
tvMap Name
conName Type
ty forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
aExpr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
bExpr)
              [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ltDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
lt) []
              , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
eqDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
eq) []
              , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
gtDataName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
gt) []
              ]
      where
        aExpr, bExpr :: Q Exp
        aExpr :: Q Exp
aExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a
        bExpr :: Q Exp
bExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
b

makeOrdFunForType :: OrdFun
                  -> TyVarMap1
                  -> Name
                  -> Type
                  -> Q Exp
#if defined(NEW_FUNCTOR_CLASSES)
makeOrdFunForType :: OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
_ (VarT Name
tyName) =
    forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName TyVarMap1
tvMap of
      Just (OneName Name
ord) -> Name
ord
      Maybe (OneOrTwoNames One)
Nothing            -> OrdFun -> Int -> Name
ordFunName OrdFun
oFun Int
0
#else
makeOrdFunForType oFun _ _ VarT{} = varE $ ordFunName oFun 0
#endif
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName (SigT Type
ty Type
_)      = OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName Type
ty
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName Type
ty
#if defined(NEW_FUNCTOR_CLASSES)
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName Type
ty = do
    let oClass :: OrdClass
        oClass :: OrdClass
oClass = OrdFun -> OrdClass
ordFunToClass OrdFun
oFun

        tyCon :: Type
        tyArgs :: [Type]
        (Type
tyCon, Cxt
tyArgs) = Type -> (Type, Cxt)
unapplyTy Type
ty

        numLastArgs :: Int
        numLastArgs :: Int
numLastArgs = forall a. Ord a => a -> a -> a
min (forall a. ClassRep a => a -> Int
arity OrdClass
oClass) (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)

        lhsArgs, rhsArgs :: [Type]
        (Cxt
lhsArgs, Cxt
rhsArgs) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs

        tyVarNames :: [Name]
        tyVarNames :: [Name]
tyVarNames = forall k a. Map k a -> [k]
Map.keys TyVarMap1
tvMap

    Bool
itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon Cxt
tyArgs
    if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs
          Bool -> Bool -> Bool
|| Bool
itf Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
       then forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError OrdClass
oClass Name
conName
       else if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
               then forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdFun -> Int -> Name
ordFunName OrdFun
oFun forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum Int
numLastArgs]
                            forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp
makeOrdFunForType OrdFun
oFun TyVarMap1
tvMap Name
conName) Cxt
rhsArgs
               else forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ OrdFun -> Int -> Name
ordFunName OrdFun
oFun Int
0
#else
makeOrdFunForType oFun tvMap conName ty = do
  let varNames = Map.keys tvMap
      oClass   = ordFunToClass oFun

  a' <- newName "a'"
  b' <- newName "b'"
  case varNames of
    [] -> varE $ ordFunName oFun 0
    varName:_ ->
      if mentionsName ty varNames
         then lamE (map varP [a',b']) $ varE (ordFunName oFun 1)
                `appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE a')
                `appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE b')
         else varE $ ordFunName oFun 0
#endif

-------------------------------------------------------------------------------

-- 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
forall a. a -> a -> Bounded a
maxBound :: OrdClass
$cmaxBound :: OrdClass
minBound :: OrdClass
$cminBound :: OrdClass
Bounded, Int -> OrdClass
OrdClass -> Int
OrdClass -> [OrdClass]
OrdClass -> OrdClass
OrdClass -> OrdClass -> [OrdClass]
OrdClass -> OrdClass -> OrdClass -> [OrdClass]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: OrdClass -> OrdClass -> OrdClass -> [OrdClass]
$cenumFromThenTo :: OrdClass -> OrdClass -> OrdClass -> [OrdClass]
enumFromTo :: OrdClass -> OrdClass -> [OrdClass]
$cenumFromTo :: OrdClass -> OrdClass -> [OrdClass]
enumFromThen :: OrdClass -> OrdClass -> [OrdClass]
$cenumFromThen :: OrdClass -> OrdClass -> [OrdClass]
enumFrom :: OrdClass -> [OrdClass]
$cenumFrom :: OrdClass -> [OrdClass]
fromEnum :: OrdClass -> Int
$cfromEnum :: OrdClass -> Int
toEnum :: Int -> OrdClass
$ctoEnum :: Int -> OrdClass
pred :: OrdClass -> OrdClass
$cpred :: OrdClass -> OrdClass
succ :: OrdClass -> OrdClass
$csucc :: OrdClass -> OrdClass
Enum)

instance ClassRep OrdClass where
    arity :: OrdClass -> Int
arity = forall a. Enum a => a -> Int
fromEnum

    allowExQuant :: OrdClass -> Bool
allowExQuant OrdClass
_ = Bool
True

    fullClassName :: OrdClass -> Name
fullClassName OrdClass
Ord  = Name
ordTypeName
    fullClassName OrdClass
Ord1 = Name
ord1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
    fullClassName OrdClass
Ord2 = Name
ord2TypeName
#endif

    classConstraint :: OrdClass -> Int -> Maybe Name
classConstraint OrdClass
oClass Int
i
      | Int
oMin forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
<= Int
oMax = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Name
fullClassName (forall a. Enum a => Int -> a
toEnum Int
i :: OrdClass)
      | Bool
otherwise              = forall a. Maybe a
Nothing
      where
        oMin, oMax :: Int
        oMin :: Int
oMin = forall a. Enum a => a -> Int
fromEnum (forall a. Bounded a => a
minBound :: OrdClass)
        oMax :: Int
oMax = forall a. Enum a => a -> Int
fromEnum OrdClass
oClass

compareConstName :: OrdFun -> Name
compareConstName :: OrdFun -> Name
compareConstName OrdFun
OrdCompare       = Name
compareConstValName
compareConstName OrdFun
OrdLT            = Name
ltConstValName
compareConstName OrdFun
OrdLE            = Name
ltConstValName
compareConstName OrdFun
OrdGT            = Name
ltConstValName
compareConstName OrdFun
OrdGE            = Name
ltConstValName
#if defined(NEW_FUNCTOR_CLASSES)
compareConstName OrdFun
Ord1LiftCompare  = Name
liftCompareConstValName
compareConstName OrdFun
Ord2LiftCompare2 = Name
liftCompare2ConstValName
#else
compareConstName Ord1Compare1     = compare1ConstValName
#endif

ordClassToCompare :: OrdClass -> OrdFun
ordClassToCompare :: OrdClass -> OrdFun
ordClassToCompare OrdClass
Ord  = OrdFun
OrdCompare
#if defined(NEW_FUNCTOR_CLASSES)
ordClassToCompare OrdClass
Ord1 = OrdFun
Ord1LiftCompare
ordClassToCompare OrdClass
Ord2 = OrdFun
Ord2LiftCompare2
#else
ordClassToCompare Ord1 = Ord1Compare1
#endif

data OrdFun = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
#if defined(NEW_FUNCTOR_CLASSES)
            | Ord1LiftCompare | Ord2LiftCompare2
#else
            | Ord1Compare1
#endif
  deriving OrdFun -> OrdFun -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OrdFun -> OrdFun -> Bool
$c/= :: OrdFun -> OrdFun -> Bool
== :: OrdFun -> OrdFun -> Bool
$c== :: OrdFun -> OrdFun -> Bool
Eq

ordFunName :: OrdFun -> Int -> Name
ordFunName :: OrdFun -> Int -> Name
ordFunName OrdFun
OrdCompare       Int
0 = Name
compareValName
ordFunName OrdFun
OrdLT            Int
0 = Name
ltValName
ordFunName OrdFun
OrdLE            Int
0 = Name
leValName
ordFunName OrdFun
OrdGE            Int
0 = Name
geValName
ordFunName OrdFun
OrdGT            Int
0 = Name
gtValName
#if defined(NEW_FUNCTOR_CLASSES)
ordFunName OrdFun
Ord1LiftCompare  Int
0 = OrdFun -> Int -> Name
ordFunName OrdFun
OrdCompare Int
0
ordFunName OrdFun
Ord1LiftCompare  Int
1 = Name
liftCompareValName
ordFunName OrdFun
Ord2LiftCompare2 Int
0 = OrdFun -> Int -> Name
ordFunName OrdFun
OrdCompare Int
0
ordFunName OrdFun
Ord2LiftCompare2 Int
1 = OrdFun -> Int -> Name
ordFunName OrdFun
Ord1LiftCompare Int
1
ordFunName OrdFun
Ord2LiftCompare2 Int
2 = Name
liftCompare2ValName
#else
ordFunName Ord1Compare1     0 = ordFunName OrdCompare 0
ordFunName Ord1Compare1     1 = compare1ValName
#endif
ordFunName OrdFun
_                Int
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Data.Ord.Deriving.Internal.ordFunName"

ordFunToClass :: OrdFun -> OrdClass
ordFunToClass :: OrdFun -> OrdClass
ordFunToClass OrdFun
OrdCompare       = OrdClass
Ord
ordFunToClass OrdFun
OrdLT            = OrdClass
Ord
ordFunToClass OrdFun
OrdLE            = OrdClass
Ord
ordFunToClass OrdFun
OrdGE            = OrdClass
Ord
ordFunToClass OrdFun
OrdGT            = OrdClass
Ord
#if defined(NEW_FUNCTOR_CLASSES)
ordFunToClass OrdFun
Ord1LiftCompare  = OrdClass
Ord1
ordFunToClass OrdFun
Ord2LiftCompare2 = OrdClass
Ord2
#else
ordFunToClass Ord1Compare1     = Ord1
#endif

eqResult :: OrdFun -> Q Exp
eqResult :: OrdFun -> Q Exp
eqResult OrdFun
OrdCompare       = Q Exp
eqTagExpr
eqResult OrdFun
OrdLT            = Q Exp
falseExpr
eqResult OrdFun
OrdLE            = Q Exp
trueExpr
eqResult OrdFun
OrdGE            = Q Exp
trueExpr
eqResult OrdFun
OrdGT            = Q Exp
falseExpr
#if defined(NEW_FUNCTOR_CLASSES)
eqResult OrdFun
Ord1LiftCompare  = Q Exp
eqTagExpr
eqResult OrdFun
Ord2LiftCompare2 = Q Exp
eqTagExpr
#else
eqResult Ord1Compare1     = eqTagExpr
#endif

gtResult :: OrdFun -> Q Exp
gtResult :: OrdFun -> Q Exp
gtResult OrdFun
OrdCompare       = Q Exp
gtTagExpr
gtResult OrdFun
OrdLT            = Q Exp
falseExpr
gtResult OrdFun
OrdLE            = Q Exp
falseExpr
gtResult OrdFun
OrdGE            = Q Exp
trueExpr
gtResult OrdFun
OrdGT            = Q Exp
trueExpr
#if defined(NEW_FUNCTOR_CLASSES)
gtResult OrdFun
Ord1LiftCompare  = Q Exp
gtTagExpr
gtResult OrdFun
Ord2LiftCompare2 = Q Exp
gtTagExpr
#else
gtResult Ord1Compare1     = gtTagExpr
#endif

ltResult :: OrdFun -> Q Exp
ltResult :: OrdFun -> Q Exp
ltResult OrdFun
OrdCompare       = Q Exp
ltTagExpr
ltResult OrdFun
OrdLT            = Q Exp
trueExpr
ltResult OrdFun
OrdLE            = Q Exp
trueExpr
ltResult OrdFun
OrdGE            = Q Exp
falseExpr
ltResult OrdFun
OrdGT            = Q Exp
falseExpr
#if defined(NEW_FUNCTOR_CLASSES)
ltResult OrdFun
Ord1LiftCompare  = Q Exp
ltTagExpr
ltResult OrdFun
Ord2LiftCompare2 = Q Exp
ltTagExpr
#else
ltResult Ord1Compare1     = ltTagExpr
#endif

-------------------------------------------------------------------------------

-- Assorted utilities

-------------------------------------------------------------------------------


ltTagExpr, eqTagExpr, gtTagExpr, falseExpr, trueExpr :: Q Exp
ltTagExpr :: Q Exp
ltTagExpr = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
ltDataName
eqTagExpr :: Q Exp
eqTagExpr = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
eqDataName
gtTagExpr :: Q Exp
gtTagExpr = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
gtDataName
falseExpr :: Q Exp
falseExpr = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName
trueExpr :: Q Exp
trueExpr  = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName

-- 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 forall a. Num a => a -> a -> a
- Int
firstTag) forall a. Ord a => a -> a -> Bool
<= Int
2 Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
nonNullaryCons
       -> [OrdFun
OrdLT, OrdFun
OrdLE, OrdFun
OrdGE, OrdFun
OrdGT]
        | Bool
otherwise
       -> []
  where
    firstTag, lastTag :: Int
    firstTag :: Int
firstTag = Int
0
    lastTag :: Int
lastTag  = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons forall a. Num a => a -> a -> a
- Int
1

    nonNullaryCons :: [ConstructorInfo]
    nonNullaryCons :: [ConstructorInfo]
nonNullaryCons = forall a. (a -> Bool) -> [a] -> [a]
filterOut ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons

unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp
unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp
unliftedOrdFun Name
tyName OrdFun
oFun Name
a Name
b = case OrdFun
oFun of
    OrdFun
OrdCompare       -> Q Exp
unliftedCompareExpr
    OrdFun
OrdLT            -> Name -> Q Exp
wrap Name
ltFun
    OrdFun
OrdLE            -> Name -> Q Exp
wrap Name
leFun
    OrdFun
OrdGE            -> Name -> Q Exp
wrap Name
geFun
    OrdFun
OrdGT            -> Name -> Q Exp
wrap Name
gtFun
#if defined(NEW_FUNCTOR_CLASSES)
    OrdFun
Ord1LiftCompare  -> Q Exp
unliftedCompareExpr
    OrdFun
Ord2LiftCompare2 -> Q Exp
unliftedCompareExpr
#else
    Ord1Compare1     -> unliftedCompareExpr
#endif
  where
    unliftedCompareExpr :: Q Exp
    unliftedCompareExpr :: Q Exp
unliftedCompareExpr = Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp
unliftedCompare Name
ltFun Name
eqFun Q Exp
aExpr Q Exp
bExpr
                                          Q Exp
ltTagExpr Q Exp
eqTagExpr Q Exp
gtTagExpr

    ltFun, leFun, eqFun, geFun, gtFun :: Name
    (Name
ltFun, Name
leFun, Name
eqFun, Name
geFun, Name
gtFun) = Name -> (Name, Name, Name, Name, Name)
primOrdFuns Name
tyName

    wrap :: Name -> Q Exp
    wrap :: Name -> Q Exp
wrap Name
primFun = Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr Q Exp
aExpr Name
primFun Q Exp
bExpr

    aExpr, bExpr :: Q Exp
    aExpr :: Q Exp
aExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a
    bExpr :: Q Exp
bExpr = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
b

unliftedCompare :: Name -> Name
                -> Q Exp -> Q Exp          -- 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 =
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE (Q Exp -> Q Exp
ascribeBool forall a b. (a -> b) -> a -> b
$ Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr Q Exp
aExpr Name
ltFun Q Exp
bExpr) Q Exp
lt forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE (Q Exp -> Q Exp
ascribeBool forall a b. (a -> b) -> a -> b
$ Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr Q Exp
aExpr Name
eqFun Q Exp
bExpr) Q Exp
eq Q Exp
gt
  where
    ascribeBool :: Q Exp -> Q Exp
    ascribeBool :: Q Exp -> Q Exp
ascribeBool Q Exp
e = forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE Q Exp
e forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Type
conT Name
boolTypeName

primOrdFuns :: Name -> (Name, Name, Name, Name, Name)
primOrdFuns :: Name -> (Name, Name, Name, Name, Name)
primOrdFuns Name
tyName =
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (Name, Name, Name, Name, Name)
primOrdFunTbl of
    Just (Name, Name, Name, Name, Name)
names -> (Name, Name, Name, Name, Name)
names
    Maybe (Name, Name, Name, Name, Name)
Nothing    -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
tyName forall a. [a] -> [a] -> [a]
++ [Char]
" is not supported."

isSupportedUnliftedType :: Type -> Bool
isSupportedUnliftedType :: Type -> Bool
isSupportedUnliftedType (ConT Name
tyName) = forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
tyName Map Name (Name, Name, Name, Name, Name)
primOrdFunTbl
isSupportedUnliftedType Type
_             = Bool
False

isSingleton :: [a] -> Bool
isSingleton :: forall a. [a] -> Bool
isSingleton [a
_] = Bool
True
isSingleton [a]
_   = Bool
False

-- | Like 'filter', only it reverses the sense of the test

filterOut :: (a -> Bool) -> [a] -> [a]
filterOut :: forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
_ [] = []
filterOut a -> Bool
p (a
x:[a]
xs) | a -> Bool
p a
x       = forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
p [a]
xs
                   | Bool
otherwise = a
x forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
p [a]
xs