{-# 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', partition)
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 <- String -> Q Name
newName String
"x1"
    Name
x2 <- String -> Q Name
newName String
"x2"
    [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x1, Name -> PatQ
varP Name
x2] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
notValName Q Exp -> Q Exp -> Q Exp
`appE`
        (Name -> Q Exp
makeEq Name
name Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
x1 Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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 Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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 Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
eqValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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)
          <- EqClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance EqClass
eClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
      (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
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)
                             (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 =
    [ Name -> [ClauseQ] -> Q Dec
funD (EqClass -> Name
eqName EqClass
eClass)
           [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                    (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
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.
      EqClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance EqClass
eClass 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
>> 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 <- String -> Q Name
newName String
"value1"
    Name
value2 <- String -> Q Name
newName String
"value2"
    Name
eqDefn <- String -> Q Name
newName String
"eqDefn"
    [Name]
eqs    <- String -> Int -> Q [Name]
newNameList String
"eq" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ EqClass -> Int
forall a. ClassRep a => a -> Int
arity EqClass
eClass

    let 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
- EqClass -> Int
forall a. Enum a => a -> Int
fromEnum EqClass
eClass) Cxt
instTypes
        tvMap :: Map Name (OneOrTwoNames One)
tvMap      = [(Name, OneOrTwoNames One)] -> Map Name (OneOrTwoNames One)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, OneOrTwoNames One)] -> Map Name (OneOrTwoNames One))
-> [(Name, OneOrTwoNames One)] -> Map Name (OneOrTwoNames One)
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]
eqs

    [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]
eqs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
#endif
                     [Name
value1, Name
value2]
         ) (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
$ EqClass -> Name
eqConstName EqClass
eClass
           , [Q Dec] -> Q Exp -> Q Exp
letE [ Name -> [ClauseQ] -> Q Dec
funD Name
eqDefn ([ClauseQ] -> Q Dec) -> [ClauseQ] -> Q Dec
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> ClauseQ) -> [ConstructorInfo] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (EqClass
-> Map Name (OneOrTwoNames One) -> ConstructorInfo -> ClauseQ
makeCaseForCon EqClass
eClass Map Name (OneOrTwoNames One)
tvMap) [ConstructorInfo]
patMatchCons
                               [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. [a] -> [a] -> [a]
++ [ClauseQ]
fallThroughCase
                  ] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
eqDefn Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
value1 Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
value2
           ]
#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]
eqs
#endif
             [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Name -> Q Exp
varE Name
value1, Name -> Q Exp
varE Name
value2]
  where
    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

    tagMatchCons, patMatchCons :: [ConstructorInfo]
    ([ConstructorInfo]
tagMatchCons, [ConstructorInfo]
patMatchCons)
      | [ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
nullaryCons Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10 = ([ConstructorInfo]
nullaryCons, [ConstructorInfo]
nonNullaryCons)
      | Bool
otherwise               = ([],          [ConstructorInfo]
cons)

    fallThroughCase :: [Q Clause]
    fallThroughCase :: [ClauseQ]
fallThroughCase
      | [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
tagMatchCons = case [ConstructorInfo]
patMatchCons of
          []  -> [ClauseQ
makeFallThroughCaseTrue]  -- No constructors: _ == _ = True
          [ConstructorInfo
_] -> []                         -- One constructor: no fall-through case
          [ConstructorInfo]
_   -> [ClauseQ
makeFallThroughCaseFalse] -- Two or more constructors:
                                            --   _ == _ = False
      | Bool
otherwise = [ClauseQ
makeTagCase]

makeTagCase :: Q Clause
makeTagCase :: ClauseQ
makeTagCase = do
    Name
a     <- String -> Q Name
newName String
"a"
    Name
aHash <- String -> Q Name
newName String
"a#"
    Name
b     <- String -> Q Name
newName String
"b"
    Name
bHash <- String -> Q Name
newName String
"b#"
    [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name
a,Name
b])
           (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash), (Name
b, Name
bHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
               Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (Name -> Q Exp
varE Name
aHash) Name
eqIntHashValName (Name -> Q Exp
varE Name
bHash)) []

makeFallThroughCaseFalse, makeFallThroughCaseTrue :: Q Clause
makeFallThroughCaseFalse :: ClauseQ
makeFallThroughCaseFalse = Name -> ClauseQ
makeFallThroughCase Name
falseDataName
makeFallThroughCaseTrue :: ClauseQ
makeFallThroughCaseTrue  = Name -> ClauseQ
makeFallThroughCase Name
trueDataName

makeFallThroughCase :: Name -> Q Clause
makeFallThroughCase :: Name -> ClauseQ
makeFallThroughCase Name
dataName = [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP, PatQ
wildP] (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
dataName) []

makeCaseForCon :: EqClass -> TyVarMap1 -> ConstructorInfo -> Q Clause
makeCaseForCon :: EqClass
-> Map Name (OneOrTwoNames One) -> ConstructorInfo -> ClauseQ
makeCaseForCon EqClass
eClass Map Name (OneOrTwoNames One)
tvMap
  (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 <- String -> Int -> Q [Name]
newNameList String
"a" Int
tsLen
    [Name]
bs <- String -> Int -> Q [Name]
newNameList String
"b" Int
tsLen
    [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
as), Name -> [PatQ] -> PatQ
conP Name
conName ((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
$ 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)
           []

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
_ [] [] [] = Name -> Q Exp
conE Name
trueDataName
makeCaseForArgs EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName Cxt
tys [Name]
as [Name]
bs =
    (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
foldl1' (\Q Exp
q Q Exp
e -> Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
q (Name -> Q Exp
varE Name
andValName) Q Exp
e)
            ((Type -> Name -> Name -> Q Exp)
-> Cxt -> [Name] -> [Name] -> [Q Exp]
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 = Name -> Q Exp
varE Name
a
    bExpr :: Q Exp
bExpr = Name -> Q 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 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
eq, Name
_, Name
_) -> Name -> Q Exp
makePrimEqExpr Name
eq
        Maybe (Name, Name, Name, Name, Name)
Nothing               -> Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
aExpr (Name -> Q 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 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

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) =
    Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ case Name -> Map Name (OneOrTwoNames One) -> Maybe (OneOrTwoNames One)
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]
_ 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 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (EqClass -> Int
forall a. ClassRep a => a -> Int
arity EqClass
eClass) (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 = Map Name (OneOrTwoNames One) -> [Name]
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 (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 EqClass -> Name -> Q Exp
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError EqClass
eClass 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) -> (EqClass -> Name) -> EqClass -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EqClass -> Name
eqName (EqClass -> Q Exp) -> EqClass -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> EqClass
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 (EqClass -> Map Name (OneOrTwoNames One) -> Name -> Type -> Q Exp
makeCaseForType EqClass
eClass Map Name (OneOrTwoNames One)
tvMap Name
conName) Cxt
rhsArgs
               else Name -> Q 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
EqClass -> EqClass -> Bounded 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]
(EqClass -> EqClass)
-> (EqClass -> EqClass)
-> (Int -> EqClass)
-> (EqClass -> Int)
-> (EqClass -> [EqClass])
-> (EqClass -> EqClass -> [EqClass])
-> (EqClass -> EqClass -> [EqClass])
-> (EqClass -> EqClass -> EqClass -> [EqClass])
-> Enum 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 = EqClass -> Int
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 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
eMax = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ EqClass -> Name
forall a. ClassRep a => a -> Name
fullClassName (Int -> EqClass
forall a. Enum a => Int -> a
toEnum Int
i :: EqClass)
      | Bool
otherwise              = Maybe Name
forall a. Maybe a
Nothing
      where
        eMin, eMax :: Int
        eMin :: Int
eMin = EqClass -> Int
forall a. Enum a => a -> Int
fromEnum (EqClass
forall a. Bounded a => a
minBound :: EqClass)
        eMax :: Int
eMax = EqClass -> Int
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