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

{-|
Module:      Data.Eq.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 'Eq', 'Eq1', and 'Eq2' 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.Eq.Deriving.Internal (
      -- * 'Eq'

      deriveEq
    , makeEq
    , makeNotEq
      -- * 'Eq1'

    , deriveEq1
#if defined(NEW_FUNCTOR_CLASSES)
    , makeLiftEq
#endif
    , makeEq1
#if defined(NEW_FUNCTOR_CLASSES)
      -- * 'Eq2'

    , deriveEq2
    , makeLiftEq2
    , makeEq2
#endif
    ) where

import           Data.Deriving.Internal
import           Data.List (foldl1')
import qualified Data.Map as Map

import           Language.Haskell.TH.Datatype
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Syntax

-- | Generates an 'Eq' instance declaration for the given data type or data

-- family instance.

deriveEq :: Name -> Q [Dec]
deriveEq :: Name -> Q [Dec]
deriveEq = EqClass -> Name -> Q [Dec]
deriveEqClass EqClass
Eq

-- | Generates a lambda expression which behaves like '(==)' (without

-- requiring an 'Eq' instance).

makeEq :: Name -> Q Exp
makeEq :: Name -> Q Exp
makeEq = EqClass -> Name -> Q Exp
makeEqClass EqClass
Eq

-- | Generates a lambda expression which behaves like '(/=)' (without

-- requiring an 'Eq' instance).

makeNotEq :: Name -> Q Exp
makeNotEq :: Name -> Q Exp
makeNotEq Name
name = do
    Name
x1 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x1"
    Name
x2 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x2"
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x1, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x2] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
notValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
        (Name -> Q Exp
makeEq Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x2)

-- | Generates an 'Eq1' instance declaration for the given data type or data

-- family instance.

deriveEq1 :: Name -> Q [Dec]
deriveEq1 :: Name -> Q [Dec]
deriveEq1 = EqClass -> Name -> Q [Dec]
deriveEqClass EqClass
Eq1

#if defined(NEW_FUNCTOR_CLASSES)
-- | Generates a lambda expression which behaves like 'liftEq' (without

-- requiring an 'Eq1' instance).

--

-- This function is not available with @transformers-0.4@.

makeLiftEq :: Name -> Q Exp
makeLiftEq :: Name -> Q Exp
makeLiftEq = EqClass -> Name -> Q Exp
makeEqClass EqClass
Eq1

-- | Generates a lambda expression which behaves like 'eq1' (without

-- requiring an 'Eq1' instance).

makeEq1 :: Name -> Q Exp
makeEq1 :: Name -> Q Exp
makeEq1 Name
name = Name -> Q Exp
makeLiftEq Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
eqValName
#else
-- | Generates a lambda expression which behaves like 'eq1' (without

-- requiring an 'Eq1' instance).

makeEq1 :: Name -> Q Exp
makeEq1 = makeEqClass Eq1
#endif

#if defined(NEW_FUNCTOR_CLASSES)
-- | Generates an 'Eq2' instance declaration for the given data type or data

-- family instance.

--

-- This function is not available with @transformers-0.4@.

deriveEq2 :: Name -> Q [Dec]
deriveEq2 :: Name -> Q [Dec]
deriveEq2 = EqClass -> Name -> Q [Dec]
deriveEqClass EqClass
Eq2

-- | Generates a lambda expression which behaves like 'liftEq2' (without

-- requiring an 'Eq2' instance).

--

-- This function is not available with @transformers-0.4@.

makeLiftEq2 :: Name -> Q Exp
makeLiftEq2 :: Name -> Q Exp
makeLiftEq2 = EqClass -> Name -> Q Exp
makeEqClass EqClass
Eq2

-- | Generates a lambda expression which behaves like 'eq2' (without

-- requiring an 'Eq2' instance).

--

-- This function is not available with @transformers-0.4@.

makeEq2 :: Name -> Q Exp
makeEq2 :: Name -> Q Exp
makeEq2 Name
name = Name -> Q Exp
makeLiftEq Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
eqValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
eqValName
#endif

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

-- Code generation

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


-- | Derive an Eq(1)(2) instance declaration (depending on the EqClass

-- argument's value).

deriveEqClass :: EqClass -> Name -> Q [Dec]
deriveEqClass :: EqClass -> Name -> Q [Dec]
deriveEqClass EqClass
eClass 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 EqClass
eClass 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)
                             (EqClass -> Cxt -> [ConstructorInfo] -> [Q Dec]
eqDecs EqClass
eClass Cxt
instTypes [ConstructorInfo]
cons)

-- | Generates a declaration defining the primary function corresponding to a

-- particular class ((==) for Eq, liftEq for Eq1, and

-- liftEq2 for Eq2).

eqDecs :: EqClass -> [Type] -> [ConstructorInfo] -> [Q Dec]
eqDecs :: EqClass -> Cxt -> [ConstructorInfo] -> [Q Dec]
eqDecs EqClass
eClass Cxt
instTypes [ConstructorInfo]
cons =
    [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (EqClass -> Name
eqName EqClass
eClass)
           [ 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
$ EqClass -> Cxt -> [ConstructorInfo] -> Q Exp
makeEqForCons EqClass
eClass Cxt
instTypes [ConstructorInfo]
cons)
                    []
           ]
    ]

-- | Generates a lambda expression which behaves like (==) (for Eq),

-- liftEq (for Eq1), or liftEq2 (for Eq2).

makeEqClass :: EqClass -> Name -> Q Exp
makeEqClass :: EqClass -> Name -> Q Exp
makeEqClass EqClass
eClass 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
      -- We force buildTypeInstance here since it performs some checks for whether

      -- or not the provided datatype can actually have (==)/liftEq/etc.

      -- implemented for it, and produces errors if it can't.

      forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance EqClass
eClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
        forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EqClass -> Cxt -> [ConstructorInfo] -> Q Exp
makeEqForCons EqClass
eClass Cxt
instTypes [ConstructorInfo]
cons

-- | Generates a lambda expression for (==)/liftEq/etc. for the

-- given constructors. All constructors must be from the same type.

makeEqForCons :: EqClass -> [Type] -> [ConstructorInfo] -> Q Exp
makeEqForCons :: EqClass -> Cxt -> [ConstructorInfo] -> Q Exp
makeEqForCons EqClass
eClass Cxt
instTypes [ConstructorInfo]
cons = do
    Name
value1 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"value1"
    Name
value2 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"value2"
    Name
eqDefn <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"eqDefn"
    [Name]
eqs    <- String -> Int -> Q [Name]
newNameList String
"eq" forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Int
arity EqClass
eClass

    let 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 EqClass
eClass) Cxt
instTypes
        tvMap :: Map Name (OneOrTwoNames One)
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]
eqs

    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]
eqs forall a. [a] -> [a] -> [a]
++
#endif
                     [Name
value1, Name
value2]
         ) 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
$ EqClass -> Name
eqConstName EqClass
eClass
           , forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
eqDefn [Map Name (OneOrTwoNames One) -> Q Clause
eqClause Map Name (OneOrTwoNames One)
tvMap]
                  ] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
eqDefn forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value2
           ]
#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]
eqs
#endif
             forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value1, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value2]
  where
    nonNullaryCons :: [ConstructorInfo]
    nonNullaryCons :: [ConstructorInfo]
nonNullaryCons = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> Bool
isNullaryCon) [ConstructorInfo]
cons

    numNonNullaryCons :: Int
    numNonNullaryCons :: Int
numNonNullaryCons = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
nonNullaryCons

    eqClause :: TyVarMap1 -> Q Clause
    eqClause :: Map Name (OneOrTwoNames One) -> Q Clause
eqClause Map Name (OneOrTwoNames One)
tvMap
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
      = Q Clause
makeFallThroughCaseTrue
      -- Tag checking is redundant when there is only one data constructor

      | [ConstructorInfo
con] <- [ConstructorInfo]
cons
      = EqClass
-> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Clause
makeCaseForCon EqClass
eClass Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
      -- This is an enum (all constructors are nullary) - just do a simple tag check

      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons
      = Q Clause
makeTagCase
      | Bool
otherwise
      = do abNames :: (Name, Name, Name, Name)
abNames@(Name
a, Name
_, Name
b, Name
_) <- Q (Name, Name, Name, Name)
newABNames
           forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name
a,Name
b])
                  (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ Map Name (OneOrTwoNames One) -> (Name, Name, Name, Name) -> Q Exp
eqExprWithTagCheck Map Name (OneOrTwoNames One)
tvMap (Name, Name, Name, Name)
abNames)
                  []

    eqExprWithTagCheck :: TyVarMap1 -> (Name, Name, Name, Name) ->  Q Exp
    eqExprWithTagCheck :: Map Name (OneOrTwoNames One) -> (Name, Name, Name, Name) -> Q Exp
eqExprWithTagCheck Map Name (OneOrTwoNames One)
tvMap (Name
a, Name
aHash, Name
b, Name
bHash) =
      forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE ([(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash), (Name
b, Name
bHash)]
                       (Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
aHash) Name
neqIntHashValName (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
bHash)))
            (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName)
            (forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a)
                   (forall a b. (a -> b) -> [a] -> [b]
map (EqClass
-> Map Name (OneOrTwoNames One)
-> Name
-> ConstructorInfo
-> Q Match
mkNestedMatchesForCon EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
b) [ConstructorInfo]
nonNullaryCons
                    forall a. [a] -> [a] -> [a]
++ [ Q Match
makeFallThroughMatchTrue
                       | Int
0 forall a. Ord a => a -> a -> Bool
< Int
numNonNullaryCons Bool -> Bool -> Bool
&& Int
numNonNullaryCons forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons
                       ]))

newABNames :: Q (Name, Name, Name, Name)
newABNames :: Q (Name, Name, Name, Name)
newABNames = do
    Name
a     <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
    Name
aHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a#"
    Name
b     <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"b"
    Name
bHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"b#"
    forall (m :: * -> *) a. Monad m => a -> m a
return (Name
a, Name
aHash, Name
b, Name
bHash)

makeTagCase :: Q Clause
makeTagCase :: Q Clause
makeTagCase = do
    (Name
a, Name
aHash, Name
b, Name
bHash) <- Q (Name, Name, Name, Name)
newABNames
    forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name
a,Name
b])
           (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash), (Name
b, Name
bHash)] forall a b. (a -> b) -> a -> b
$
               Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
aHash) Name
eqIntHashValName (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
bHash)) []

makeFallThroughCaseTrue :: Q Clause
makeFallThroughCaseTrue :: Q Clause
makeFallThroughCaseTrue = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => m Pat
wildP, 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) []

makeFallThroughMatchFalse, makeFallThroughMatchTrue :: Q Match
makeFallThroughMatchFalse :: Q Match
makeFallThroughMatchFalse = Name -> Q Match
makeFallThroughMatch Name
falseDataName
makeFallThroughMatchTrue :: Q Match
makeFallThroughMatchTrue  = Name -> Q Match
makeFallThroughMatch Name
trueDataName

makeFallThroughMatch :: Name -> Q Match
makeFallThroughMatch :: Name -> Q Match
makeFallThroughMatch Name
dataName = 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
dataName) []

makeCaseForCon :: EqClass -> TyVarMap1 -> ConstructorInfo -> Q Clause
makeCaseForCon :: EqClass
-> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Clause
makeCaseForCon EqClass
eClass Map Name (OneOrTwoNames One)
tvMap
  (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 <- String -> Int -> Q [Name]
newNameList String
"a" Int
tsLen
    [Name]
bs <- String -> Int -> Q [Name]
newNameList String
"b" Int
tsLen
    forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
as), forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName (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
$ EqClass
-> Map Name (OneOrTwoNames One)
-> Name
-> Cxt
-> [Name]
-> [Name]
-> Q Exp
makeCaseForArgs EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName Cxt
ts' [Name]
as [Name]
bs)
           []

mkNestedMatchesForCon :: EqClass -> TyVarMap1 -> Name -> ConstructorInfo -> Q Match
mkNestedMatchesForCon :: EqClass
-> Map Name (OneOrTwoNames One)
-> Name
-> ConstructorInfo
-> Q Match
mkNestedMatchesForCon EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
b
  (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 <- String -> Int -> Q [Name]
newNameList String
"a" Int
tsLen
    [Name]
bs <- String -> Int -> Q [Name]
newNameList String
"b" Int
tsLen
    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]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
as))
          (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB 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
b)
                           [ 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]
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
$ EqClass
-> Map Name (OneOrTwoNames One)
-> Name
-> Cxt
-> [Name]
-> [Name]
-> Q Exp
makeCaseForArgs EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName Cxt
ts' [Name]
as [Name]
bs)
                                   []
                           , Q Match
makeFallThroughMatchFalse
                           ])
          []

makeCaseForArgs :: EqClass
                -> TyVarMap1
                -> Name
                -> [Type]
                -> [Name]
                -> [Name]
                -> Q Exp
makeCaseForArgs :: EqClass
-> Map Name (OneOrTwoNames One)
-> Name
-> Cxt
-> [Name]
-> [Name]
-> Q Exp
makeCaseForArgs EqClass
_ Map Name (OneOrTwoNames One)
_ Name
_ [] [] [] = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName
makeCaseForArgs EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName Cxt
tys [Name]
as [Name]
bs =
    forall a. (a -> a -> a) -> [a] -> a
foldl1' (\Q Exp
q Q Exp
e -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
q (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
andValName) Q Exp
e)
            (forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (EqClass
-> Map Name (OneOrTwoNames One)
-> Name
-> Type
-> Name
-> Name
-> Q Exp
makeCaseForArg EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName) Cxt
tys [Name]
as [Name]
bs)

makeCaseForArg :: EqClass
               -> TyVarMap1
               -> Name
               -> Type
               -> Name
               -> Name
               -> Q Exp
makeCaseForArg :: EqClass
-> Map Name (OneOrTwoNames One)
-> Name
-> Type
-> Name
-> Name
-> Q Exp
makeCaseForArg EqClass
_ Map Name (OneOrTwoNames One)
_ Name
_ (ConT Name
tyName) Name
a Name
b = Q Exp
primEqExpr
  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

    makePrimEqExpr :: Name -> Q Exp
    makePrimEqExpr :: Name -> Q Exp
makePrimEqExpr Name
n = Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr Q Exp
aExpr Name
n Q Exp
bExpr

    primEqExpr :: Q Exp
    primEqExpr :: Q Exp
primEqExpr =
      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
eq, Name
_, Name
_) -> Name -> Q Exp
makePrimEqExpr Name
eq
        Maybe (Name, Name, Name, Name, Name)
Nothing               -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
aExpr (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
eqValName) Q Exp
bExpr
makeCaseForArg EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName Type
ty Name
a Name
b =
    EqClass -> Map Name (OneOrTwoNames One) -> Name -> Type -> Q Exp
makeCaseForType EqClass
eClass Map Name (OneOrTwoNames One)
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

makeCaseForType :: EqClass
                -> TyVarMap1
                -> Name
                -> Type
                -> Q Exp
#if defined(NEW_FUNCTOR_CLASSES)
makeCaseForType :: EqClass -> Map Name (OneOrTwoNames One) -> Name -> Type -> Q Exp
makeCaseForType EqClass
_ Map Name (OneOrTwoNames One)
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 Map Name (OneOrTwoNames One)
tvMap of
      Just (OneName Name
eq) -> Name
eq
      Maybe (OneOrTwoNames One)
Nothing           -> Name
eqValName
#else
makeCaseForType _ _ _ VarT{} = varE eqValName
#endif
makeCaseForType EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName (SigT Type
ty Type
_)      = EqClass -> Map Name (OneOrTwoNames One) -> Name -> Type -> Q Exp
makeCaseForType EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName Type
ty
makeCaseForType EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = EqClass -> Map Name (OneOrTwoNames One) -> Name -> Type -> Q Exp
makeCaseForType EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName Type
ty
#if defined(NEW_FUNCTOR_CLASSES)
makeCaseForType EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName Type
ty = do
    let 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 EqClass
eClass) (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 Map Name (OneOrTwoNames One)
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 EqClass
eClass 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
. EqClass -> Name
eqName 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 (EqClass -> Map Name (OneOrTwoNames One) -> Name -> Type -> Q Exp
makeCaseForType EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName) Cxt
rhsArgs
               else forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
eqValName
#else
makeCaseForType eClass tvMap conName ty = do
  let varNames = Map.keys tvMap

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

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

-- Class-specific constants

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


-- | A representation of which @Eq@ variant is being derived.

data EqClass = Eq
             | Eq1
#if defined(NEW_FUNCTOR_CLASSES)
             | Eq2
#endif
  deriving (EqClass
forall a. a -> a -> Bounded a
maxBound :: EqClass
$cmaxBound :: EqClass
minBound :: EqClass
$cminBound :: EqClass
Bounded, Int -> EqClass
EqClass -> Int
EqClass -> [EqClass]
EqClass -> EqClass
EqClass -> EqClass -> [EqClass]
EqClass -> EqClass -> EqClass -> [EqClass]
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 :: EqClass -> EqClass -> EqClass -> [EqClass]
$cenumFromThenTo :: EqClass -> EqClass -> EqClass -> [EqClass]
enumFromTo :: EqClass -> EqClass -> [EqClass]
$cenumFromTo :: EqClass -> EqClass -> [EqClass]
enumFromThen :: EqClass -> EqClass -> [EqClass]
$cenumFromThen :: EqClass -> EqClass -> [EqClass]
enumFrom :: EqClass -> [EqClass]
$cenumFrom :: EqClass -> [EqClass]
fromEnum :: EqClass -> Int
$cfromEnum :: EqClass -> Int
toEnum :: Int -> EqClass
$ctoEnum :: Int -> EqClass
pred :: EqClass -> EqClass
$cpred :: EqClass -> EqClass
succ :: EqClass -> EqClass
$csucc :: EqClass -> EqClass
Enum)

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

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

    fullClassName :: EqClass -> Name
fullClassName EqClass
Eq  = Name
eqTypeName
    fullClassName EqClass
Eq1 = Name
eq1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
    fullClassName EqClass
Eq2 = Name
eq2TypeName
#endif

    classConstraint :: EqClass -> Int -> Maybe Name
classConstraint EqClass
eClass Int
i
      | Int
eMin forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
<= Int
eMax = 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 :: EqClass)
      | Bool
otherwise              = forall a. Maybe a
Nothing
      where
        eMin, eMax :: Int
        eMin :: Int
eMin = forall a. Enum a => a -> Int
fromEnum (forall a. Bounded a => a
minBound :: EqClass)
        eMax :: Int
eMax = forall a. Enum a => a -> Int
fromEnum EqClass
eClass

eqConstName :: EqClass -> Name
eqConstName :: EqClass -> Name
eqConstName EqClass
Eq  = Name
eqConstValName
#if defined(NEW_FUNCTOR_CLASSES)
eqConstName EqClass
Eq1 = Name
liftEqConstValName
eqConstName EqClass
Eq2 = Name
liftEq2ConstValName
#else
eqConstName Eq1 = eq1ConstValName
#endif

eqName :: EqClass -> Name
eqName :: EqClass -> Name
eqName EqClass
Eq  = Name
eqValName
#if defined(NEW_FUNCTOR_CLASSES)
eqName EqClass
Eq1 = Name
liftEqValName
eqName EqClass
Eq2 = Name
liftEq2ValName
#else
eqName Eq1 = eq1ValName
#endif