{-# 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
    , makeLiftEq
    , makeEq1
      -- * 'Eq2'
    , deriveEq2
    , makeLiftEq2
    , makeEq2
    ) 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
    x1 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x1"
    x2 <- newName "x2"
    lamE [varP x1, varP x2] $ varE notValName `appE`
        (makeEq name `appE` varE x1 `appE` varE 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

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

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

-------------------------------------------------------------------------------
-- 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
  info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case 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
      (instanceCxt, 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
      (:[]) `fmap` instanceD (return instanceCxt)
                             (return instanceType)
                             (eqDecs eClass instTypes 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 -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (EqClass -> Name
eqName EqClass
eClass)
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
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
  info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case 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 a b. Q a -> Q b -> Q b
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
    value1 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"value1"
    value2 <- newName "value2"
    eqDefn <- newName "eqDefn"
    eqs    <- newNameList "eq" $ arity eClass

    let 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 a. [a] -> 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      = [(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

    lamE (map varP $ eqs ++ [value1, value2]
         ) . appsE
         $ [ varE $ eqConstName eClass
           , letE [ funD eqDefn [eqClause tvMap]
                  ] $ varE eqDefn `appE` varE value1 `appE` varE value2
           ] ++ map varE eqs
             ++ [varE value1, varE value2]
  where
    nonNullaryCons :: [ConstructorInfo]
    nonNullaryCons :: [ConstructorInfo]
nonNullaryCons = (ConstructorInfo -> Bool) -> [ConstructorInfo] -> [ConstructorInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (ConstructorInfo -> Bool) -> ConstructorInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> Bool
isNullaryCon) [ConstructorInfo]
cons

    numNonNullaryCons :: Int
    numNonNullaryCons :: Int
numNonNullaryCons = [ConstructorInfo] -> Int
forall a. [a] -> Int
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
      | [ConstructorInfo] -> Bool
forall a. [a] -> Bool
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
      | (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons
      = Q Clause
makeTagCase
      | Bool
otherwise
      = do abNames@(a, _, b, _) <- Q (Name, Name, Name, Name)
newABNames
           clause (map varP [a,b])
                  (normalB $ eqExprWithTagCheck tvMap 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) =
      Q Exp -> Q Exp -> Q Exp -> Q Exp
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 (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
aHash) Name
neqIntHashValName (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
bHash)))
            (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseDataName)
            (Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a)
                   ((ConstructorInfo -> Q Match) -> [ConstructorInfo] -> [Q Match]
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
                    [Q Match] -> [Q Match] -> [Q Match]
forall a. [a] -> [a] -> [a]
++ [ Q Match
makeFallThroughMatchTrue
                       | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
numNonNullaryCons Bool -> Bool -> Bool
&& Int
numNonNullaryCons Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [ConstructorInfo] -> Int
forall a. [a] -> Int
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
    a     <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
    aHash <- newName "a#"
    b     <- newName "b"
    bHash <- newName "b#"
    return (a, aHash, b, bHash)

makeTagCase :: Q Clause
makeTagCase :: Q Clause
makeTagCase = do
    (a, aHash, b, bHash) <- Q (Name, Name, Name, Name)
newABNames
    clause (map varP [a,b])
           (normalB $ untagExpr [(a, aHash), (b, bHash)] $
               primOpAppExpr (varE aHash) eqIntHashValName (varE bHash)) []

makeFallThroughCaseTrue :: Q Clause
makeFallThroughCaseTrue :: Q Clause
makeFallThroughCaseTrue = [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP, Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
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 = Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
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
    ts' <- (Type -> Q Type) -> Cxt -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms Cxt
ts
    let tsLen = Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts'
    as <- newNameList "a" tsLen
    bs <- newNameList "b" tsLen
    clause [conP conName (map varP as), conP conName (map varP bs)]
           (normalB $ makeCaseForArgs eClass tvMap conName ts' as 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
    ts' <- (Type -> Q Type) -> Cxt -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms Cxt
ts
    let tsLen = Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts'
    as <- newNameList "a" tsLen
    bs <- newNameList "b" tsLen
    match (conP conName (map varP as))
          (normalB $ caseE (varE b)
                           [ match (conP conName (map varP bs))
                                   (normalB $ makeCaseForArgs eClass tvMap conName ts' as bs)
                                   []
                           , 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
_ [] [] [] = Name -> Q Exp
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 =
    (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' (\Q Exp
q Q Exp
e -> Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
q (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a
    bExpr :: Q Exp
bExpr = Name -> Q Exp
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 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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
aExpr (Name -> Q Exp
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 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
b

makeCaseForType :: EqClass
                -> TyVarMap1
                -> Name
                -> Type
                -> Q Exp
makeCaseForType :: EqClass -> Map Name (OneOrTwoNames One) -> Name -> Type -> Q Exp
makeCaseForType EqClass
_ Map Name (OneOrTwoNames One)
tvMap Name
_ (VarT Name
tyName) =
    Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
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
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 a. [a] -> 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 a. [a] -> 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

    itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon Cxt
tyArgs
    if any (`mentionsName` tyVarNames) lhsArgs
          || itf && any (`mentionsName` tyVarNames) tyArgs
       then outOfPlaceTyVarError eClass conName
       else if any (`mentionsName` tyVarNames) rhsArgs
               then appsE $ [ varE . eqName $ toEnum numLastArgs]
                            ++ map (makeCaseForType eClass tvMap conName) rhsArgs
               else varE eqValName

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

-- | A representation of which @Eq@ variant is being derived.
data EqClass = Eq
             | Eq1
             | Eq2
  deriving (EqClass
EqClass -> EqClass -> Bounded EqClass
forall a. a -> a -> Bounded a
$cminBound :: EqClass
minBound :: EqClass
$cmaxBound :: EqClass
maxBound :: 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
$csucc :: EqClass -> EqClass
succ :: EqClass -> EqClass
$cpred :: EqClass -> EqClass
pred :: EqClass -> EqClass
$ctoEnum :: Int -> EqClass
toEnum :: Int -> EqClass
$cfromEnum :: EqClass -> Int
fromEnum :: EqClass -> Int
$cenumFrom :: EqClass -> [EqClass]
enumFrom :: EqClass -> [EqClass]
$cenumFromThen :: EqClass -> EqClass -> [EqClass]
enumFromThen :: EqClass -> EqClass -> [EqClass]
$cenumFromTo :: EqClass -> EqClass -> [EqClass]
enumFromTo :: EqClass -> EqClass -> [EqClass]
$cenumFromThenTo :: EqClass -> EqClass -> EqClass -> [EqClass]
enumFromThenTo :: EqClass -> EqClass -> 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
    fullClassName EqClass
Eq2 = Name
eq2TypeName

    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
eqConstName EqClass
Eq1 = Name
liftEqConstValName
eqConstName EqClass
Eq2 = Name
liftEq2ConstValName

eqName :: EqClass -> Name
eqName :: EqClass -> Name
eqName EqClass
Eq  = Name
eqValName
eqName EqClass
Eq1 = Name
liftEqValName
eqName EqClass
Eq2 = Name
liftEq2ValName