{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}

#if !(MIN_VERSION_base(4,9,0))
# if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
# else
{-# LANGUAGE TemplateHaskell #-}
# endif
#endif

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

Template Haskell-related utilities.

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.Deriving.Internal where

import           Control.Applicative (liftA2)
import           Control.Monad (when, unless)

import           Data.Foldable (foldr')
#if !(MIN_VERSION_base(4,9,0))
import           Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..))
# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)
import           Data.Functor.Classes (Eq2(..), Ord2(..), Read2(..), Show2(..))
# endif
#endif
import qualified Data.List as List
import qualified Data.Map as Map
import           Data.Map (Map)
import           Data.Maybe
import qualified Data.Set as Set
import           Data.Set (Set)
import qualified Data.Traversable as T

import           Text.ParserCombinators.ReadPrec (ReadPrec)
import qualified Text.Read.Lex as L

#if MIN_VERSION_base(4,7,0)
import           GHC.Read (expectP)
#else
import           GHC.Read (lexP)

import           Text.Read (pfail)
import           Text.Read.Lex (Lexeme)
#endif

#if MIN_VERSION_ghc_prim(0,3,1)
import           GHC.Prim (Int#, tagToEnum#)
#endif

#if defined(MIN_VERSION_ghc_boot_th)
import           GHC.Lexeme (startsConSym, startsVarSym)
#else
import           Data.Char (isSymbol, ord)
#endif

import           Language.Haskell.TH.Datatype
import           Language.Haskell.TH.Datatype.TyVarBndr
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Ppr (pprint)
import           Language.Haskell.TH.Syntax

-- Ensure, beyond a shadow of a doubt, that the instances are in-scope
import           Data.Functor ()
import           Data.Functor.Classes ()
import           Data.Foldable ()
import           Data.Traversable ()

#ifndef CURRENT_PACKAGE_KEY
import           Data.Version (showVersion)
import           Paths_deriving_compat (version)
#endif

-------------------------------------------------------------------------------
-- Expanding type synonyms
-------------------------------------------------------------------------------

applySubstitutionKind :: Map Name Kind -> Type -> Type
#if MIN_VERSION_template_haskell(2,8,0)
applySubstitutionKind :: Map Name Kind -> Kind -> Kind
applySubstitutionKind = Map Name Kind -> Kind -> Kind
forall a. TypeSubstitution a => Map Name Kind -> a -> a
applySubstitution
#else
applySubstitutionKind _ t = t
#endif

substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind :: Name -> Kind -> Kind -> Kind
substNameWithKind Name
n Kind
k = Map Name Kind -> Kind -> Kind
applySubstitutionKind (Name -> Kind -> Map Name Kind
forall k a. k -> a -> Map k a
Map.singleton Name
n Kind
k)

substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar :: [Name] -> Kind -> Kind
substNamesWithKindStar [Name]
ns Kind
t = (Name -> Kind -> Kind) -> Kind -> [Name] -> Kind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' ((Name -> Kind -> Kind -> Kind) -> Kind -> Name -> Kind -> Kind
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Kind -> Kind -> Kind
substNameWithKind Kind
starK) Kind
t [Name]
ns

-------------------------------------------------------------------------------
-- Via
-------------------------------------------------------------------------------

-- | A type-level modifier intended to be used in conjunction with 'deriveVia'.
-- Refer to the documentation for 'deriveVia' for more details.
data a `Via` b
infix 0 `Via`

-------------------------------------------------------------------------------
-- Type-specialized const functions
-------------------------------------------------------------------------------

fmapConst :: f b -> (a -> b) -> f a -> f b
fmapConst :: f b -> (a -> b) -> f a -> f b
fmapConst f b
x a -> b
_ f a
_ = f b
x
{-# INLINE fmapConst #-}

replaceConst :: f a -> a -> f b -> f a
replaceConst :: f a -> a -> f b -> f a
replaceConst f a
x a
_ f b
_ = f a
x
{-# INLINE replaceConst #-}

foldrConst :: b -> (a -> b -> b) -> b -> t a -> b
foldrConst :: b -> (a -> b -> b) -> b -> t a -> b
foldrConst b
x a -> b -> b
_ b
_ t a
_ = b
x
{-# INLINE foldrConst #-}

foldMapConst :: m -> (a -> m) -> t a -> m
foldMapConst :: m -> (a -> m) -> t a -> m
foldMapConst m
x a -> m
_ t a
_ = m
x
{-# INLINE foldMapConst #-}

nullConst :: Bool -> t a -> Bool
nullConst :: Bool -> t a -> Bool
nullConst Bool
x t a
_ = Bool
x
{-# INLINE nullConst #-}

traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b)
traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b)
traverseConst f (t b)
x a -> f b
_ t a
_ = f (t b)
x
{-# INLINE traverseConst #-}

eqConst :: Bool
        -> a -> a -> Bool
eqConst :: Bool -> a -> a -> Bool
eqConst Bool
x a
_ a
_ = Bool
x
{-# INLINE eqConst #-}

eq1Const :: Bool
         -> f a -> f a-> Bool
eq1Const :: Bool -> f a -> f a -> Bool
eq1Const Bool
x f a
_ f a
_ = Bool
x
{-# INLINE eq1Const #-}

liftEqConst :: Bool
            -> (a -> b -> Bool) -> f a -> f b -> Bool
liftEqConst :: Bool -> (a -> b -> Bool) -> f a -> f b -> Bool
liftEqConst Bool
x a -> b -> Bool
_ f a
_ f b
_ = Bool
x
{-# INLINE liftEqConst #-}

liftEq2Const :: Bool
             -> (a -> b -> Bool) -> (c -> d -> Bool)
             -> f a c -> f b d -> Bool
liftEq2Const :: Bool
-> (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
liftEq2Const Bool
x a -> b -> Bool
_ c -> d -> Bool
_ f a c
_ f b d
_ = Bool
x
{-# INLINE liftEq2Const #-}

compareConst :: Ordering -> a -> a -> Ordering
compareConst :: Ordering -> a -> a -> Ordering
compareConst Ordering
x a
_ a
_ = Ordering
x
{-# INLINE compareConst #-}

ltConst :: Bool -> a -> a -> Bool
ltConst :: Bool -> a -> a -> Bool
ltConst Bool
x a
_ a
_ = Bool
x
{-# INLINE ltConst #-}

compare1Const :: Ordering -> f a -> f a -> Ordering
compare1Const :: Ordering -> f a -> f a -> Ordering
compare1Const Ordering
x f a
_ f a
_ = Ordering
x
{-# INLINE compare1Const #-}

liftCompareConst :: Ordering
                 -> (a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompareConst :: Ordering -> (a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompareConst Ordering
x a -> b -> Ordering
_ f a
_ f b
_ = Ordering
x
{-# INLINE liftCompareConst #-}

liftCompare2Const :: Ordering
                  -> (a -> b -> Ordering) -> (c -> d -> Ordering)
                  -> f a c -> f b d -> Ordering
liftCompare2Const :: Ordering
-> (a -> b -> Ordering)
-> (c -> d -> Ordering)
-> f a c
-> f b d
-> Ordering
liftCompare2Const Ordering
x a -> b -> Ordering
_ c -> d -> Ordering
_ f a c
_ f b d
_ = Ordering
x
{-# INLINE liftCompare2Const #-}

readsPrecConst :: ReadS a -> Int -> ReadS a
readsPrecConst :: ReadS a -> Int -> ReadS a
readsPrecConst ReadS a
x Int
_ = ReadS a
x
{-# INLINE readsPrecConst #-}

-- This isn't really necessary, but it makes for an easier implementation
readPrecConst :: ReadPrec a -> ReadPrec a
readPrecConst :: ReadPrec a -> ReadPrec a
readPrecConst ReadPrec a
x = ReadPrec a
x
{-# INLINE readPrecConst #-}

readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a)
readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a)
readsPrec1Const ReadS (f a)
x Int
_ = ReadS (f a)
x
{-# INLINE readsPrec1Const #-}

liftReadsPrecConst :: ReadS (f a)
                   -> (Int -> ReadS a) -> ReadS [a]
                   -> Int -> ReadS (f a)
liftReadsPrecConst :: ReadS (f a) -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrecConst ReadS (f a)
x Int -> ReadS a
_ ReadS [a]
_ Int
_ = ReadS (f a)
x
{-# INLINE liftReadsPrecConst #-}

liftReadPrecConst :: ReadPrec (f a)
                  -> ReadPrec a -> ReadPrec [a]
                  -> ReadPrec (f a)
liftReadPrecConst :: ReadPrec (f a) -> ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrecConst ReadPrec (f a)
x ReadPrec a
_ ReadPrec [a]
_ = ReadPrec (f a)
x
{-# INLINE liftReadPrecConst #-}

liftReadsPrec2Const :: ReadS (f a b)
                    -> (Int -> ReadS a) -> ReadS [a]
                    -> (Int -> ReadS b) -> ReadS [b]
                    -> Int -> ReadS (f a b)
liftReadsPrec2Const :: ReadS (f a b)
-> (Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (f a b)
liftReadsPrec2Const ReadS (f a b)
x Int -> ReadS a
_ ReadS [a]
_ Int -> ReadS b
_ ReadS [b]
_ Int
_ = ReadS (f a b)
x
{-# INLINE liftReadsPrec2Const #-}

liftReadPrec2Const :: ReadPrec (f a b)
                   -> ReadPrec a -> ReadPrec [a]
                   -> ReadPrec b -> ReadPrec [b]
                   -> ReadPrec (f a b)
liftReadPrec2Const :: ReadPrec (f a b)
-> ReadPrec a
-> ReadPrec [a]
-> ReadPrec b
-> ReadPrec [b]
-> ReadPrec (f a b)
liftReadPrec2Const ReadPrec (f a b)
x ReadPrec a
_ ReadPrec [a]
_ ReadPrec b
_ ReadPrec [b]
_ = ReadPrec (f a b)
x
{-# INLINE liftReadPrec2Const #-}

showsPrecConst :: ShowS
               -> Int -> a -> ShowS
showsPrecConst :: ShowS -> Int -> a -> ShowS
showsPrecConst ShowS
x Int
_ a
_ = ShowS
x
{-# INLINE showsPrecConst #-}

showsPrec1Const :: ShowS
                -> Int -> f a -> ShowS
showsPrec1Const :: ShowS -> Int -> f a -> ShowS
showsPrec1Const ShowS
x Int
_ f a
_ = ShowS
x
{-# INLINE showsPrec1Const #-}

liftShowsPrecConst :: ShowS
                   -> (Int -> a -> ShowS) -> ([a] -> ShowS)
                   -> Int -> f a -> ShowS
liftShowsPrecConst :: ShowS
-> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrecConst ShowS
x Int -> a -> ShowS
_ [a] -> ShowS
_ Int
_ f a
_ = ShowS
x
{-# INLINE liftShowsPrecConst #-}

liftShowsPrec2Const :: ShowS
                    -> (Int -> a -> ShowS) -> ([a] -> ShowS)
                    -> (Int -> b -> ShowS) -> ([b] -> ShowS)
                    -> Int -> f a b -> ShowS
liftShowsPrec2Const :: ShowS
-> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2Const ShowS
x Int -> a -> ShowS
_ [a] -> ShowS
_ Int -> b -> ShowS
_ [b] -> ShowS
_ Int
_ f a b
_ = ShowS
x
{-# INLINE liftShowsPrec2Const #-}

-------------------------------------------------------------------------------
-- StarKindStatus
-------------------------------------------------------------------------------

-- | Whether a type is not of kind *, is of kind *, or is a kind variable.
data StarKindStatus = NotKindStar
                    | KindStar
                    | IsKindVar Name
  deriving StarKindStatus -> StarKindStatus -> Bool
(StarKindStatus -> StarKindStatus -> Bool)
-> (StarKindStatus -> StarKindStatus -> Bool) -> Eq StarKindStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StarKindStatus -> StarKindStatus -> Bool
$c/= :: StarKindStatus -> StarKindStatus -> Bool
== :: StarKindStatus -> StarKindStatus -> Bool
$c== :: StarKindStatus -> StarKindStatus -> Bool
Eq

-- | Does a Type have kind * or k (for some kind variable k)?
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar :: Kind -> StarKindStatus
canRealizeKindStar Kind
t
  | Kind -> Bool
hasKindStar Kind
t = StarKindStatus
KindStar
  | Bool
otherwise = case Kind
t of
#if MIN_VERSION_template_haskell(2,8,0)
                     SigT Kind
_ (VarT Name
k) -> Name -> StarKindStatus
IsKindVar Name
k
#endif
                     Kind
_               -> StarKindStatus
NotKindStar

-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.
-- Otherwise, returns 'Nothing'.
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
starKindStatusToName StarKindStatus
_             = Maybe Name
forall a. Maybe a
Nothing

-- | Concat together all of the StarKindStatuses that are IsKindVar and extract
-- the kind variables' Names out.
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames = (StarKindStatus -> Maybe Name) -> [StarKindStatus] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe StarKindStatus -> Maybe Name
starKindStatusToName

-------------------------------------------------------------------------------
-- ClassRep
-------------------------------------------------------------------------------

class ClassRep a where
    arity           :: a -> Int
    allowExQuant    :: a -> Bool
    fullClassName   :: a -> Name
    classConstraint :: a -> Int -> Maybe Name

-------------------------------------------------------------------------------
-- Template Haskell reifying and AST manipulation
-------------------------------------------------------------------------------

-- For the given Types, generate an instance context and head. Coming up with
-- the instance type isn't as simple as dropping the last types, as you need to
-- be wary of kinds being instantiated with *.
-- See Note [Type inference in derived instances]
buildTypeInstance :: ClassRep a
                  => a
                  -- ^ The typeclass for which an instance should be derived
                  -> Name
                  -- ^ The type constructor or data family name
                  -> Cxt
                  -- ^ The datatype context
                  -> [Type]
                  -- ^ The types to instantiate the instance with
                  -> DatatypeVariant
                  -- ^ Are we dealing with a data family instance or not
                  -> Q (Cxt, Type)
buildTypeInstance :: a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Kind)
buildTypeInstance a
cRep Name
tyConName Cxt
dataCxt Cxt
varTysOrig DatatypeVariant
variant = do
    -- Make sure to expand through type/kind synonyms! Otherwise, the
    -- eta-reduction check might get tripped up over type variables in a
    -- synonym that are actually dropped.
    -- (See GHC Trac #11416 for a scenario where this actually happened.)
    Cxt
varTysExp <- (Kind -> Q Kind) -> Cxt -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Kind -> Q Kind
resolveTypeSynonyms Cxt
varTysOrig

    let remainingLength :: Int
        remainingLength :: Int
remainingLength = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
varTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall a. ClassRep a => a -> Int
arity a
cRep

        droppedTysExp :: [Type]
        droppedTysExp :: Cxt
droppedTysExp = Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop Int
remainingLength Cxt
varTysExp

        droppedStarKindStati :: [StarKindStatus]
        droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Kind -> StarKindStatus) -> Cxt -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> StarKindStatus
canRealizeKindStar Cxt
droppedTysExp

    -- Check there are enough types to drop and that all of them are either of
    -- kind * or kind k (for some kind variable k). If not, throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| (StarKindStatus -> Bool) -> [StarKindStatus] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (StarKindStatus -> StarKindStatus -> Bool
forall a. Eq a => a -> a -> Bool
== StarKindStatus
NotKindStar) [StarKindStatus]
droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      a -> Name -> Q ()
forall a b. ClassRep a => a -> Name -> Q b
derivingKindError a
cRep Name
tyConName

    let droppedKindVarNames :: [Name]
        droppedKindVarNames :: [Name]
droppedKindVarNames = [StarKindStatus] -> [Name]
catKindVarNames [StarKindStatus]
droppedStarKindStati

        -- Substitute kind * for any dropped kind variables
        varTysExpSubst :: [Type]
        varTysExpSubst :: Cxt
varTysExpSubst = (Kind -> Kind) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Kind -> Kind
substNamesWithKindStar [Name]
droppedKindVarNames) Cxt
varTysExp

        remainingTysExpSubst, droppedTysExpSubst :: [Type]
        (Cxt
remainingTysExpSubst, Cxt
droppedTysExpSubst) =
          Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength Cxt
varTysExpSubst

        -- All of the type variables mentioned in the dropped types
        -- (post-synonym expansion)
        droppedTyVarNames :: [Name]
        droppedTyVarNames :: [Name]
droppedTyVarNames = Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
droppedTysExpSubst

    -- If any of the dropped types were polykinded, ensure that they are of kind *
    -- after substituting * for the dropped kind variables. If not, throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Kind -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
hasKindStar Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      a -> Name -> Q ()
forall a b. ClassRep a => a -> Name -> Q b
derivingKindError a
cRep Name
tyConName

    let preds    :: [Maybe Pred]
        kvNames  :: [[Name]]
        kvNames' :: [Name]
        -- Derive instance constraints (and any kind variables which are specialized
        -- to * in those constraints)
        ([Maybe Kind]
preds, [[Name]]
kvNames) = [(Maybe Kind, [Name])] -> ([Maybe Kind], [[Name]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Kind, [Name])] -> ([Maybe Kind], [[Name]]))
-> [(Maybe Kind, [Name])] -> ([Maybe Kind], [[Name]])
forall a b. (a -> b) -> a -> b
$ (Kind -> (Maybe Kind, [Name])) -> Cxt -> [(Maybe Kind, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (a -> Kind -> (Maybe Kind, [Name])
forall a. ClassRep a => a -> Kind -> (Maybe Kind, [Name])
deriveConstraint a
cRep) Cxt
remainingTysExpSubst
        kvNames' :: [Name]
kvNames' = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
kvNames

        -- Substitute the kind variables specialized in the constraints with *
        remainingTysExpSubst' :: [Type]
        remainingTysExpSubst' :: Cxt
remainingTysExpSubst' =
          (Kind -> Kind) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Kind -> Kind
substNamesWithKindStar [Name]
kvNames') Cxt
remainingTysExpSubst

        -- We now substitute all of the specialized-to-* kind variable names with
        -- *, but in the original types, not the synonym-expanded types. The reason
        -- we do this is a superficial one: we want the derived instance to resemble
        -- the datatype written in source code as closely as possible. For example,
        -- for the following data family instance:
        --
        --   data family Fam a
        --   newtype instance Fam String = Fam String
        --
        -- We'd want to generate the instance:
        --
        --   instance C (Fam String)
        --
        -- Not:
        --
        --   instance C (Fam [Char])
        remainingTysOrigSubst :: [Type]
        remainingTysOrigSubst :: Cxt
remainingTysOrigSubst =
          (Kind -> Kind) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Kind -> Kind
substNamesWithKindStar ([Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
List.union [Name]
droppedKindVarNames [Name]
kvNames'))
            (Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
take Int
remainingLength Cxt
varTysOrig

        isDataFamily :: Bool
        isDataFamily :: Bool
isDataFamily = case DatatypeVariant
variant of
                         DatatypeVariant
Datatype        -> Bool
False
                         DatatypeVariant
Newtype         -> Bool
False
                         DatatypeVariant
DataInstance    -> Bool
True
                         DatatypeVariant
NewtypeInstance -> Bool
True

        remainingTysOrigSubst' :: [Type]
        -- See Note [Kind signatures in derived instances] for an explanation
        -- of the isDataFamily check.
        remainingTysOrigSubst' :: Cxt
remainingTysOrigSubst' =
          if Bool
isDataFamily
             then Cxt
remainingTysOrigSubst
             else (Kind -> Kind) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Kind
unSigT Cxt
remainingTysOrigSubst

        instanceCxt :: Cxt
        instanceCxt :: Cxt
instanceCxt = [Maybe Kind] -> Cxt
forall a. [Maybe a] -> [a]
catMaybes [Maybe Kind]
preds

        instanceType :: Type
        instanceType :: Kind
instanceType = Kind -> Kind -> Kind
AppT (Name -> Kind
ConT (a -> Name
forall a. ClassRep a => a -> Name
fullClassName a
cRep))
                     (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Kind
applyTyCon Name
tyConName Cxt
remainingTysOrigSubst'

    -- If the datatype context mentions any of the dropped type variables,
    -- we can't derive an instance, so throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Kind -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Kind -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) Cxt
dataCxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Name -> Kind -> Q ()
forall a. Name -> Kind -> Q a
datatypeContextError Name
tyConName Kind
instanceType
    -- Also ensure the dropped types can be safely eta-reduced. Otherwise,
    -- throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Cxt -> Cxt -> Bool
canEtaReduce Cxt
remainingTysExpSubst' Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Kind -> Q ()
forall a. Kind -> Q a
etaReductionError Kind
instanceType
    (Cxt, Kind) -> Q (Cxt, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt
instanceCxt, Kind
instanceType)

-- | Attempt to derive a constraint on a Type. If successful, return
-- Just the constraint and any kind variable names constrained to *.
-- Otherwise, return Nothing and the empty list.
--
-- See Note [Type inference in derived instances] for the heuristics used to
-- come up with constraints.
deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name])
deriveConstraint :: a -> Kind -> (Maybe Kind, [Name])
deriveConstraint a
cRep Kind
t
  | Bool -> Bool
not (Kind -> Bool
isTyVar Kind
t) = (Maybe Kind
forall a. Maybe a
Nothing, [])
  | Kind -> Bool
hasKindStar Kind
t   = ((Name -> Name -> Kind
`applyClass` Name
tName) (Name -> Kind) -> Maybe Name -> Maybe Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` a -> Int -> Maybe Name
forall a. ClassRep a => a -> Int -> Maybe Name
classConstraint a
cRep Int
0, [])
  | Bool
otherwise = case Int -> Kind -> Maybe [Name]
hasKindVarChain Int
1 Kind
t of
      Just [Name]
ns | Int
cRepArity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
              -> ((Name -> Name -> Kind
`applyClass` Name
tName) (Name -> Kind) -> Maybe Name -> Maybe Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` a -> Int -> Maybe Name
forall a. ClassRep a => a -> Int -> Maybe Name
classConstraint a
cRep Int
1, [Name]
ns)
      Maybe [Name]
_ -> case Int -> Kind -> Maybe [Name]
hasKindVarChain Int
2 Kind
t of
           Just [Name]
ns | Int
cRepArity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
                   -> ((Name -> Name -> Kind
`applyClass` Name
tName) (Name -> Kind) -> Maybe Name -> Maybe Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` a -> Int -> Maybe Name
forall a. ClassRep a => a -> Int -> Maybe Name
classConstraint a
cRep Int
2, [Name]
ns)
           Maybe [Name]
_ -> (Maybe Kind
forall a. Maybe a
Nothing, [])
  where
    tName :: Name
    tName :: Name
tName     = Kind -> Name
varTToName Kind
t

    cRepArity :: Int
    cRepArity :: Int
cRepArity = a -> Int
forall a. ClassRep a => a -> Int
arity a
cRep

{-
Note [Kind signatures in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

It is possible to put explicit kind signatures into the derived instances, e.g.,

  instance C a => C (Data (f :: * -> *)) where ...

But it is preferable to avoid this if possible. If we come up with an incorrect
kind signature (which is entirely possible, since our type inferencer is pretty
unsophisticated - see Note [Type inference in derived instances]), then GHC will
flat-out reject the instance, which is quite unfortunate.

Plain old datatypes have the advantage that you can avoid using any kind signatures
at all in their instances. This is because a datatype declaration uses all type
variables, so the types that we use in a derived instance uniquely determine their
kinds. As long as we plug in the right types, the kind inferencer can do the rest
of the work. For this reason, we use unSigT to remove all kind signatures before
splicing in the instance context and head.

Data family instances are trickier, since a data family can have two instances that
are distinguished by kind alone, e.g.,

  data family Fam (a :: k)
  data instance Fam (a :: * -> *)
  data instance Fam (a :: *)

If we dropped the kind signatures for C (Fam a), then GHC will have no way of
knowing which instance we are talking about. To avoid this scenario, we always
include explicit kind signatures in data family instances. There is a chance that
the inferred kind signatures will be incorrect, but if so, we can always fall back
on the make- functions.

Note [Type inference in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Type inference is can be tricky to get right, and we want to avoid recreating the
entirety of GHC's type inferencer in Template Haskell. For this reason, we will
probably never come up with derived instance contexts that are as accurate as
GHC's. But that doesn't mean we can't do anything! There are a couple of simple
things we can do to make instance contexts that work for 80% of use cases:

1. If one of the last type parameters is polykinded, then its kind will be
   specialized to * in the derived instance. We note what kind variable the type
   parameter had and substitute it with * in the other types as well. For example,
   imagine you had

     data Data (a :: k) (b :: k)

   Then you'd want to derived instance to be:

     instance C (Data (a :: *))

   Not:

     instance C (Data (a :: k))

2. We naïvely come up with instance constraints using the following criteria, using
   Show(1)(2) as the example typeclasses:

   (i)   If there's a type parameter n of kind *, generate a Show n constraint.
   (ii)  If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind
         variables), then generate a Show1 n constraint, and if k1/k2 are kind
         variables, then substitute k1/k2 with * elsewhere in the types. We must
         consider the case where they are kind variables because you might have a
         scenario like this:

           newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
             = Compose (f (g a))

         Which would have a derived Show1 instance of:

           instance (Show1 f, Show1 g) => Show1 (Compose f g) where ...
   (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are
         * or kind variables), then generate a Show2 constraint and perform
         kind substitution as in the other cases.
-}

checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name
                        -> Q c -> Q c
checkExistentialContext :: a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
checkExistentialContext a
cRep TyVarMap b
tvMap Cxt
ctxt Name
conName Q c
q =
  if ((Kind -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Kind -> [Name] -> Bool
`predMentionsName` TyVarMap b -> [Name]
forall k a. Map k a -> [k]
Map.keys TyVarMap b
tvMap) Cxt
ctxt
       Bool -> Bool -> Bool
|| TyVarMap b -> Int
forall k a. Map k a -> Int
Map.size TyVarMap b
tvMap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Int
forall a. ClassRep a => a -> Int
arity a
cRep)
       Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. ClassRep a => a -> Bool
allowExQuant a
cRep)
     then Name -> Q c
forall a. Name -> Q a
existentialContextError Name
conName
     else Q c
q

{-
Note [Matching functions with GADT type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When deriving category-2 classes like Show2, there is a tricky corner case to consider:

  data Both a b where
    BothCon :: x -> x -> Both x x

Which show functions should be applied to which arguments of BothCon? We have a
choice, since both the function of type (Int -> a -> ShowS) and of type
(Int -> b -> ShowS) can be applied to either argument. In such a scenario, the
second show function takes precedence over the first show function, so the
derived Show2 instance would be:

  instance Show2 Both where
    liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) =
      showsParen (p > appPrec) $
        showString "BothCon " . sp2 appPrec1 x1 . showSpace . sp2 appPrec1 x2

This is not an arbitrary choice, as this definition ensures that
liftShowsPrec2 showsPrec = liftShowsPrec for a derived Show1 instance for
Both.
-}

-------------------------------------------------------------------------------
-- Error messages
-------------------------------------------------------------------------------

-- | The given datatype has no constructors, and we don't know what to do with it.
noConstructorsError :: Q a
noConstructorsError :: Q a
noConstructorsError = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Must have at least one data constructor"

-- | Either the given data type doesn't have enough type variables, or one of
-- the type variables to be eta-reduced cannot realize kind *.
derivingKindError :: ClassRep a => a ->  Name -> Q b
derivingKindError :: a -> Name -> Q b
derivingKindError a
cRep Name
tyConName = String -> Q b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q b) -> ShowS -> String -> Q b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Cannot derive well-kinded instance of form ‘"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS -> ShowS
showParen Bool
True
    ( String -> ShowS
showString (Name -> String
nameBase Name
tyConName)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ..."
    )
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘\n\tClass "
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" expects an argument of kind "
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Kind -> String
forall a. Ppr a => a -> String
pprint (Kind -> String) -> (Int -> Kind) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Kind
createKindChain (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. ClassRep a => a -> Int
arity a
cRep)
  (String -> Q b) -> String -> Q b
forall a b. (a -> b) -> a -> b
$ String
""
  where
    className :: String
    className :: String
className = Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ a -> Name
forall a. ClassRep a => a -> Name
fullClassName a
cRep

-- | The last type variable appeared in a contravariant position
-- when deriving Functor.
contravarianceError :: Name -> Q a
contravarianceError :: Name -> Q a
contravarianceError Name
conName = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must not use the last type variable in a function argument"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | A constructor has a function argument in a derived Foldable or Traversable
-- instance.
noFunctionsError :: Name -> Q a
noFunctionsError :: Name -> Q a
noFunctionsError Name
conName = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must not contain function types"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
-- function for the criteria it would have to meet).
etaReductionError :: Type -> Q a
etaReductionError :: Kind -> Q a
etaReductionError Kind
instanceType = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$
  String
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Ppr a => a -> String
pprint Kind
instanceType

-- | The data type has a DatatypeContext which mentions one of the eta-reduced
-- type variables.
datatypeContextError :: Name -> Type -> Q a
datatypeContextError :: Name -> Kind -> Q a
datatypeContextError Name
dataName Kind
instanceType = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Can't make a derived instance of ‘"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Kind -> String
forall a. Ppr a => a -> String
pprint Kind
instanceType)
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘:\n\tData type ‘"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
dataName)
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must not have a class context involving the last type argument(s)"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | The data type has an existential constraint which mentions one of the
-- eta-reduced type variables.
existentialContextError :: Name -> Q a
existentialContextError :: Name -> Q a
existentialContextError Name
conName = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must be truly polymorphic in the last argument(s) of the data type"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | The data type mentions one of the n eta-reduced type variables in a place other
-- than the last nth positions of a data type in a constructor's field.
outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError :: a -> Name -> Q b
outOfPlaceTyVarError a
cRep Name
conName = String -> Q b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
    (String -> Q b) -> ShowS -> String -> Q b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must only use its last "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
n
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" type variable(s) within the last "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
n
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" argument(s) of a data type"
    (String -> Q b) -> String -> Q b
forall a b. (a -> b) -> a -> b
$ String
""
  where
    n :: Int
    n :: Int
n = a -> Int
forall a. ClassRep a => a -> Int
arity a
cRep

enumerationError :: String -> Q a
enumerationError :: String -> Q a
enumerationError = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
enumerationErrorStr

enumerationOrProductError :: String -> Q a
enumerationOrProductError :: String -> Q a
enumerationOrProductError String
nb = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ ShowS
enumerationErrorStr String
nb
    , String
"\tor a product type (precisely one constructor)"
    ]

enumerationErrorStr :: String -> String
enumerationErrorStr :: ShowS
enumerationErrorStr String
nb =
    Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
:String
nb String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"’ must be an enumeration type"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (one or more nullary, non-GADT constructors)"

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

-- | A mapping of type variable Names to their auxiliary function Names.
type TyVarMap a = Map Name (OneOrTwoNames a)
type TyVarMap1 = TyVarMap One
type TyVarMap2 = TyVarMap Two

data OneOrTwoNames a where
    OneName  :: Name         -> OneOrTwoNames One
    TwoNames :: Name -> Name -> OneOrTwoNames Two

data One
data Two

interleave :: [a] -> [a] -> [a]
interleave :: [a] -> [a] -> [a]
interleave (a
a1:[a]
a1s) (a
a2:[a]
a2s) = a
a1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
a2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
interleave [a]
a1s [a]
a2s
interleave [a]
_        [a]
_        = []

#if MIN_VERSION_ghc_prim(0,3,1)
isTrue# :: Int# -> Bool
isTrue# :: Int# -> Bool
isTrue# Int#
x = Int# -> Bool
forall a. Int# -> a
tagToEnum# Int#
x
#else
isTrue# :: Bool -> Bool
isTrue# x = x
#endif
{-# INLINE isTrue# #-}

-- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed)

-- | 'filterByList' takes a list of Bools and a list of some elements and
-- filters out these elements for which the corresponding value in the list of
-- Bools is False. This function does not check whether the lists have equal
-- length.
filterByList :: [Bool] -> [a] -> [a]
filterByList :: [Bool] -> [a] -> [a]
filterByList (Bool
True:[Bool]
bs)  (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Bool] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList (Bool
False:[Bool]
bs) (a
_:[a]
xs) =     [Bool] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList [Bool]
_          [a]
_      = []

-- | 'filterByLists' takes a list of Bools and two lists as input, and
-- outputs a new list consisting of elements from the last two input lists. For
-- each Bool in the list, if it is 'True', then it takes an element from the
-- former list. If it is 'False', it takes an element from the latter list.
-- The elements taken correspond to the index of the Bool in its list.
-- For example:
--
-- @
-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\"
-- @
--
-- This function does not check whether the lists have equal length.
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists (Bool
True:[Bool]
bs)  (a
x:[a]
xs) (a
_:[a]
ys) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Bool] -> [a] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
bs [a]
xs [a]
ys
filterByLists (Bool
False:[Bool]
bs) (a
_:[a]
xs) (a
y:[a]
ys) = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Bool] -> [a] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
bs [a]
xs [a]
ys
filterByLists [Bool]
_          [a]
_      [a]
_      = []

-- | 'partitionByList' takes a list of Bools and a list of some elements and
-- partitions the list according to the list of Bools. Elements corresponding
-- to 'True' go to the left; elements corresponding to 'False' go to the right.
-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@
-- This function does not check whether the lists have equal
-- length.
partitionByList :: [Bool] -> [a] -> ([a], [a])
partitionByList :: [Bool] -> [a] -> ([a], [a])
partitionByList = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
forall a. [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [] []
  where
    go :: [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [a]
trues [a]
falses (Bool
True  : [Bool]
bs) (a
x : [a]
xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
trues) [a]
falses [Bool]
bs [a]
xs
    go [a]
trues [a]
falses (Bool
False : [Bool]
bs) (a
x : [a]
xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [a]
trues (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
falses) [Bool]
bs [a]
xs
    go [a]
trues [a]
falses [Bool]
_ [a]
_ = ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
trues, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
falses)

integerE :: Int -> Q Exp
integerE :: Int -> Q Exp
integerE = Lit -> Q Exp
litE (Lit -> Q Exp) -> (Int -> Lit) -> Int -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (Int -> Integer) -> Int -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Returns True if a Type has kind *.
hasKindStar :: Type -> Bool
hasKindStar :: Kind -> Bool
hasKindStar VarT{}         = Bool
True
#if MIN_VERSION_template_haskell(2,8,0)
hasKindStar (SigT Kind
_ Kind
StarT) = Bool
True
#else
hasKindStar (SigT _ StarK) = True
#endif
hasKindStar Kind
_              = Bool
False

-- Returns True is a kind is equal to *, or if it is a kind variable.
isStarOrVar :: Kind -> Bool
#if MIN_VERSION_template_haskell(2,8,0)
isStarOrVar :: Kind -> Bool
isStarOrVar Kind
StarT  = Bool
True
isStarOrVar VarT{} = Bool
True
#else
isStarOrVar StarK  = True
#endif
isStarOrVar Kind
_      = Bool
False

-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
-- kind variables.
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain :: Int -> Kind -> Maybe [Name]
hasKindVarChain Int
kindArrows Kind
t =
  let uk :: Cxt
uk = Kind -> Cxt
uncurryKind (Kind -> Kind
tyKind Kind
t)
  in if (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
uk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
kindArrows) Bool -> Bool -> Bool
&& (Kind -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
isStarOrVar Cxt
uk
        then [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just (Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
uk)
        else Maybe [Name]
forall a. Maybe a
Nothing

-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
tyKind :: Type -> Kind
tyKind :: Kind -> Kind
tyKind (SigT Kind
_ Kind
k) = Kind
k
tyKind Kind
_ = Kind
starK

zipWithAndUnzipM :: Monad m
                 => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
zipWithAndUnzipM :: (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
zipWithAndUnzipM a -> b -> m (c, d)
f (a
x:[a]
xs) (b
y:[b]
ys) = do
    (c
c, d
d) <- a -> b -> m (c, d)
f a
x b
y
    ([c]
cs, [d]
ds) <- (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
zipWithAndUnzipM a -> b -> m (c, d)
f [a]
xs [b]
ys
    ([c], [d]) -> m ([c], [d])
forall (m :: * -> *) a. Monad m => a -> m a
return (c
cc -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
cs, d
dd -> [d] -> [d]
forall a. a -> [a] -> [a]
:[d]
ds)
zipWithAndUnzipM a -> b -> m (c, d)
_ [a]
_ [b]
_ = ([c], [d]) -> m ([c], [d])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
{-# INLINE zipWithAndUnzipM #-}

zipWith3AndUnzipM :: Monad m
                 => (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c]
                 -> m ([d], [e])
zipWith3AndUnzipM :: (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c] -> m ([d], [e])
zipWith3AndUnzipM a -> b -> c -> m (d, e)
f (a
x:[a]
xs) (b
y:[b]
ys) (c
z:[c]
zs) = do
    (d
d, e
e) <- a -> b -> c -> m (d, e)
f a
x b
y c
z
    ([d]
ds, [e]
es) <- (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c] -> m ([d], [e])
forall (m :: * -> *) a b c d e.
Monad m =>
(a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c] -> m ([d], [e])
zipWith3AndUnzipM a -> b -> c -> m (d, e)
f [a]
xs [b]
ys [c]
zs
    ([d], [e]) -> m ([d], [e])
forall (m :: * -> *) a. Monad m => a -> m a
return (d
dd -> [d] -> [d]
forall a. a -> [a] -> [a]
:[d]
ds, e
ee -> [e] -> [e]
forall a. a -> [a] -> [a]
:[e]
es)
zipWith3AndUnzipM a -> b -> c -> m (d, e)
_ [a]
_ [b]
_ [c]
_ = ([d], [e]) -> m ([d], [e])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
{-# INLINE zipWith3AndUnzipM #-}

thd3 :: (a, b, c) -> c
thd3 :: (a, b, c) -> c
thd3 (a
_, b
_, c
c) = c
c

unsnoc :: [a] -> Maybe ([a], a)
unsnoc :: [a] -> Maybe ([a], a)
unsnoc []     = Maybe ([a], a)
forall a. Maybe a
Nothing
unsnoc (a
x:[a]
xs) = case [a] -> Maybe ([a], a)
forall a. [a] -> Maybe ([a], a)
unsnoc [a]
xs of
                  Maybe ([a], a)
Nothing    -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([], a
x)
                  Just ([a]
a,a
b) -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
a, a
b)

isNullaryCon :: ConstructorInfo -> Bool
isNullaryCon :: ConstructorInfo -> Bool
isNullaryCon (ConstructorInfo { constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
tys }) = Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
tys

-- | Returns the number of fields for the constructor.
conArity :: ConstructorInfo -> Int
conArity :: ConstructorInfo -> Int
conArity (ConstructorInfo { constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
tys }) = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tys

-- | Returns 'True' if it's a datatype with exactly one, non-existential constructor.
isProductType :: [ConstructorInfo] -> Bool
isProductType :: [ConstructorInfo] -> Bool
isProductType [ConstructorInfo
con] = [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
con)
isProductType [ConstructorInfo]
_     = Bool
False

-- | Returns 'True' if it's a datatype with one or more nullary, non-GADT
-- constructors.
isEnumerationType :: [ConstructorInfo] -> Bool
isEnumerationType :: [ConstructorInfo] -> Bool
isEnumerationType cons :: [ConstructorInfo]
cons@(ConstructorInfo
_:[ConstructorInfo]
_) = (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Bool -> Bool -> Bool)
-> (ConstructorInfo -> Bool)
-> (ConstructorInfo -> Bool)
-> ConstructorInfo
-> Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) ConstructorInfo -> Bool
isNullaryCon ConstructorInfo -> Bool
isVanillaCon) [ConstructorInfo]
cons
isEnumerationType [ConstructorInfo]
_          = Bool
False

-- | Returns 'False' if we're dealing with existential quantification or GADTs.
isVanillaCon :: ConstructorInfo -> Bool
isVanillaCon :: ConstructorInfo -> Bool
isVanillaCon (ConstructorInfo { constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt, constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars = [TyVarBndrUnit]
vars }) =
  Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
ctxt Bool -> Bool -> Bool
&& [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
vars

-- | Generate a list of fresh names with a common prefix, and numbered suffixes.
newNameList :: String -> Int -> Q [Name]
newNameList :: String -> Int -> Q [Name]
newNameList String
prefix Int
n = (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
n]

-- | Extracts the kind from a TyVarBndr.
tvbKind :: TyVarBndr_ flag -> Kind
tvbKind :: TyVarBndrUnit -> Kind
tvbKind = (Name -> Kind) -> (Name -> Kind -> Kind) -> TyVarBndrUnit -> Kind
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndrUnit -> r
elimTV (\Name
_ -> Kind
starK) (\Name
_ Kind
k -> Kind
k)

-- | Convert a TyVarBndr to a Type.
tvbToType :: TyVarBndr_ flag -> Type
tvbToType :: TyVarBndrUnit -> Kind
tvbToType = (Name -> Kind) -> (Name -> Kind -> Kind) -> TyVarBndrUnit -> Kind
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndrUnit -> r
elimTV Name -> Kind
VarT (\Name
n Kind
k -> Kind -> Kind -> Kind
SigT (Name -> Kind
VarT Name
n) Kind
k)

-- | Applies a typeclass constraint to a type.
applyClass :: Name -> Name -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
applyClass :: Name -> Name -> Kind
applyClass Name
con Name
t = Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
con) (Name -> Kind
VarT Name
t)
#else
applyClass con t = ClassP con [VarT t]
#endif

createKindChain :: Int -> Kind
createKindChain :: Int -> Kind
createKindChain = Kind -> Int -> Kind
go Kind
starK
  where
    go :: Kind -> Int -> Kind
    go :: Kind -> Int -> Kind
go Kind
k !Int
0 = Kind
k
#if MIN_VERSION_template_haskell(2,8,0)
    go Kind
k !Int
n = Kind -> Int -> Kind
go (Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
ArrowT Kind
StarT) Kind
k) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
#else
    go k !n = go (ArrowK StarK k) (n - 1)
#endif

-- | Checks to see if the last types in a data family instance can be safely eta-
-- reduced (i.e., dropped), given the other types. This checks for three conditions:
--
-- (1) All of the dropped types are type variables
-- (2) All of the dropped types are distinct
-- (3) None of the remaining types mention any of the dropped types
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce :: Cxt -> Cxt -> Bool
canEtaReduce Cxt
remaining Cxt
dropped =
       (Kind -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
isTyVar Cxt
dropped
    Bool -> Bool -> Bool
&& [Name] -> Bool
forall a. Ord a => [a] -> Bool
allDistinct [Name]
droppedNames -- Make sure not to pass something of type [Type], since Type
                                -- didn't have an Ord instance until template-haskell-2.10.0.0
    Bool -> Bool -> Bool
&& Bool -> Bool
not ((Kind -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Kind -> [Name] -> Bool
`mentionsName` [Name]
droppedNames) Cxt
remaining)
  where
    droppedNames :: [Name]
    droppedNames :: [Name]
droppedNames = (Kind -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Name
varTToName Cxt
dropped

-- | Extract the Name from a type constructor. If the argument Type is not a
-- type variable, throw an error.
conTToName :: Type -> Name
conTToName :: Kind -> Name
conTToName (ConT Name
n)   = Name
n
conTToName (SigT Kind
t Kind
_) = Kind -> Name
conTToName Kind
t
conTToName Kind
_          = String -> Name
forall a. HasCallStack => String -> a
error String
"Not a type constructor!"

-- | Extract Just the Name from a type variable. If the argument Type is not a
-- type variable, return Nothing.
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe :: Kind -> Maybe Name
varTToName_maybe (VarT Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT Kind
t Kind
_) = Kind -> Maybe Name
varTToName_maybe Kind
t
varTToName_maybe Kind
_          = Maybe Name
forall a. Maybe a
Nothing

-- | Extract the Name from a type variable. If the argument Type is not a
-- type variable, throw an error.
varTToName :: Type -> Name
varTToName :: Kind -> Name
varTToName = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (String -> Name
forall a. HasCallStack => String -> a
error String
"Not a type variable!") (Maybe Name -> Name) -> (Kind -> Maybe Name) -> Kind -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Maybe Name
varTToName_maybe

-- | Peel off a kind signature from a Type (if it has one).
unSigT :: Type -> Type
unSigT :: Kind -> Kind
unSigT (SigT Kind
t Kind
_) = Kind
t
unSigT Kind
t          = Kind
t

-- | Is the given type a variable?
isTyVar :: Type -> Bool
isTyVar :: Kind -> Bool
isTyVar (VarT Name
_)   = Bool
True
isTyVar (SigT Kind
t Kind
_) = Kind -> Bool
isTyVar Kind
t
isTyVar Kind
_          = Bool
False

-- | Detect if a Name in a list of provided Names occurs as an argument to some
-- type family. This makes an effort to exclude /oversaturated/ arguments to
-- type families. For instance, if one declared the following type family:
--
-- @
-- type family F a :: Type -> Type
-- @
--
-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,
-- but not @b@.
isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp :: [Name] -> Kind -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
names Kind
tyFun Cxt
tyArgs =
  case Kind
tyFun of
    ConT Name
tcName -> Name -> Q Bool
go Name
tcName
    Kind
_           -> Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    go :: Name -> Q Bool
    go :: Name -> Q Bool
go Name
tcName = do
      Info
info <- Name -> Q Info
reify Name
tcName
      case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
        FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndrUnit]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_
          -> [TyVarBndrUnit] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndrUnit]
bndrs
#elif MIN_VERSION_template_haskell(2,7,0)
        FamilyI (FamilyD TypeFam _ bndrs _) _
          -> withinFirstArgs bndrs
#else
        TyConI (FamilyD TypeFam _ bndrs _)
          -> withinFirstArgs bndrs
#endif

#if MIN_VERSION_template_haskell(2,11,0)
        FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndrUnit]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
          -> [TyVarBndrUnit] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndrUnit]
bndrs
#elif MIN_VERSION_template_haskell(2,9,0)
        FamilyI (ClosedTypeFamilyD _ bndrs _ _) _
          -> withinFirstArgs bndrs
#endif

        Info
_ -> Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      where
        withinFirstArgs :: [a] -> Q Bool
        withinFirstArgs :: [a] -> Q Bool
withinFirstArgs [a]
bndrs =
          let firstArgs :: Cxt
firstArgs = Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) Cxt
tyArgs
              argFVs :: [Name]
argFVs    = Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
firstArgs
          in Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
argFVs) [Name]
names

-- | Are all of the items in a list (which have an ordering) distinct?
--
-- This uses Set (as opposed to nub) for better asymptotic time complexity.
allDistinct :: Ord a => [a] -> Bool
allDistinct :: [a] -> Bool
allDistinct = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
allDistinct' Set a
forall a. Set a
Set.empty
  where
    allDistinct' :: Ord a => Set a -> [a] -> Bool
    allDistinct' :: Set a -> [a] -> Bool
allDistinct' Set a
uniqs (a
x:[a]
xs)
        | a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
uniqs = Bool
False
        | Bool
otherwise            = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
allDistinct' (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
uniqs) [a]
xs
    allDistinct' Set a
_ [a]
_           = Bool
True

-- | Does the given type mention any of the Names in the list?
mentionsName :: Type -> [Name] -> Bool
mentionsName :: Kind -> [Name] -> Bool
mentionsName = Kind -> [Name] -> Bool
go
  where
    go :: Type -> [Name] -> Bool
    go :: Kind -> [Name] -> Bool
go (AppT Kind
t1 Kind
t2) [Name]
names = Kind -> [Name] -> Bool
go Kind
t1 [Name]
names Bool -> Bool -> Bool
|| Kind -> [Name] -> Bool
go Kind
t2 [Name]
names
    go (SigT Kind
t Kind
_k)  [Name]
names = Kind -> [Name] -> Bool
go Kind
t [Name]
names
#if MIN_VERSION_template_haskell(2,8,0)
                              Bool -> Bool -> Bool
|| Kind -> [Name] -> Bool
go Kind
_k [Name]
names
#endif
    go (VarT Name
n)     [Name]
names = Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
    go Kind
_            [Name]
_     = Bool
False

-- | Does an instance predicate mention any of the Names in the list?
predMentionsName :: Pred -> [Name] -> Bool
#if MIN_VERSION_template_haskell(2,10,0)
predMentionsName :: Kind -> [Name] -> Bool
predMentionsName = Kind -> [Name] -> Bool
mentionsName
#else
predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys
predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names
#endif

-- | Construct a type via curried application.
applyTy :: Type -> [Type] -> Type
applyTy :: Kind -> Cxt -> Kind
applyTy = (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Kind -> Kind -> Kind
AppT

-- | Fully applies a type constructor to its type variables.
applyTyCon :: Name -> [Type] -> Type
applyTyCon :: Name -> Cxt -> Kind
applyTyCon = Kind -> Cxt -> Kind
applyTy (Kind -> Cxt -> Kind) -> (Name -> Kind) -> Name -> Cxt -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Kind
ConT

-- | Split an applied type into its individual components. For example, this:
--
-- @
-- Either Int Char
-- @
--
-- would split to this:
--
-- @
-- [Either, Int, Char]
-- @
unapplyTy :: Type -> (Type, [Type])
unapplyTy :: Kind -> (Kind, Cxt)
unapplyTy Kind
ty = Kind -> Kind -> Cxt -> (Kind, Cxt)
go Kind
ty Kind
ty []
  where
    go :: Type -> Type -> [Type] -> (Type, [Type])
    go :: Kind -> Kind -> Cxt -> (Kind, Cxt)
go Kind
_      (AppT Kind
ty1 Kind
ty2)     Cxt
args = Kind -> Kind -> Cxt -> (Kind, Cxt)
go Kind
ty1 Kind
ty1 (Kind
ty2Kind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:Cxt
args)
    go Kind
origTy (SigT Kind
ty' Kind
_)       Cxt
args = Kind -> Kind -> Cxt -> (Kind, Cxt)
go Kind
origTy Kind
ty' Cxt
args
#if MIN_VERSION_template_haskell(2,11,0)
    go Kind
origTy (InfixT Kind
ty1 Name
n Kind
ty2) Cxt
args = Kind -> Kind -> Cxt -> (Kind, Cxt)
go Kind
origTy (Name -> Kind
ConT Name
n Kind -> Kind -> Kind
`AppT` Kind
ty1 Kind -> Kind -> Kind
`AppT` Kind
ty2) Cxt
args
    go Kind
origTy (ParensT Kind
ty')      Cxt
args = Kind -> Kind -> Cxt -> (Kind, Cxt)
go Kind
origTy Kind
ty' Cxt
args
#endif
    go Kind
origTy Kind
_                  Cxt
args = (Kind
origTy, Cxt
args)

-- | Split a type signature by the arrows on its spine. For example, this:
--
-- @
-- forall a b. (a ~ b) => (a -> b) -> Char -> ()
-- @
--
-- would split to this:
--
-- @
-- (a ~ b, [a -> b, Char, ()])
-- @
uncurryTy :: Type -> (Cxt, [Type])
uncurryTy :: Kind -> (Cxt, Cxt)
uncurryTy (AppT (AppT Kind
ArrowT Kind
t1) Kind
t2) =
  let (Cxt
ctxt, Cxt
tys) = Kind -> (Cxt, Cxt)
uncurryTy Kind
t2
  in (Cxt
ctxt, Kind
t1Kind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:Cxt
tys)
uncurryTy (SigT Kind
t Kind
_) = Kind -> (Cxt, Cxt)
uncurryTy Kind
t
uncurryTy (ForallT [TyVarBndrUnit]
_ Cxt
ctxt Kind
t) =
  let (Cxt
ctxt', Cxt
tys) = Kind -> (Cxt, Cxt)
uncurryTy Kind
t
  in (Cxt
ctxt Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
ctxt', Cxt
tys)
uncurryTy Kind
t = ([], [Kind
t])


-- | Like uncurryType, except on a kind level.
uncurryKind :: Kind -> [Kind]
#if MIN_VERSION_template_haskell(2,8,0)
uncurryKind :: Kind -> Cxt
uncurryKind = (Cxt, Cxt) -> Cxt
forall a b. (a, b) -> b
snd ((Cxt, Cxt) -> Cxt) -> (Kind -> (Cxt, Cxt)) -> Kind -> Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> (Cxt, Cxt)
uncurryTy
#else
uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2
uncurryKind k              = [k]
#endif

untagExpr :: [(Name, Name)] -> Q Exp -> Q Exp
untagExpr :: [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [] Q Exp
e = Q Exp
e
untagExpr ((Name
untagThis, Name
putTagHere) : [(Name, Name)]
more) Q Exp
e =
    Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
getTagValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
untagThis)
          [PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> PatQ
varP Name
putTagHere)
                 (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, Name)]
more Q Exp
e)
                 []]

tag2ConExpr :: Type -> Q Exp
tag2ConExpr :: Kind -> Q Exp
tag2ConExpr Kind
ty = do
    Name
iHash  <- String -> Q Name
newName String
"i#"
    Kind
ty' <- Kind -> Q Kind
freshenType Kind
ty
    PatQ -> Q Exp -> Q Exp
lam1E (Name -> [PatQ] -> PatQ
conP Name
iHashDataName [Name -> PatQ
varP Name
iHash]) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
        Name -> Q Exp
varE Name
tagToEnumHashValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
iHash
            Q Exp -> Q Kind -> Q Exp
`sigE` Kind -> Q Kind
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Kind
quantifyType Kind
ty')
            -- tagToEnum# is a hack, and won't typecheck unless it's in the
            -- immediate presence of a type ascription like so:
            --
            --   tagToEnum# x :: Foo
            --
            -- We have to be careful when dealing with datatypes with type
            -- variables, since Template Haskell might reject the type variables
            -- we use for being out-of-scope. To avoid this, we explicitly
            -- collect the type variable binders and shove them into a ForallT
            -- (using th-abstraction's quantifyType function). Also make sure
            -- to freshen the bound type variables to avoid shadowed variable
            -- warnings on old versions of GHC when -Wall is enabled.

primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name)
primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name)
primOrdFunTbl = [(Name, (Name, Name, Name, Name, Name))]
-> Map Name (Name, Name, Name, Name, Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Name
addrHashTypeName,   ( Name
ltAddrHashValName
                           , Name
leAddrHashValName
                           , Name
eqAddrHashValName
                           , Name
geAddrHashValName
                           , Name
gtAddrHashValName
                           ))
    , (Name
charHashTypeName,   ( Name
ltCharHashValName
                           , Name
leCharHashValName
                           , Name
eqCharHashValName
                           , Name
geCharHashValName
                           , Name
gtCharHashValName
                           ))
    , (Name
doubleHashTypeName, ( Name
ltDoubleHashValName
                           , Name
leDoubleHashValName
                           , Name
eqDoubleHashValName
                           , Name
geDoubleHashValName
                           , Name
gtDoubleHashValName
                           ))
    , (Name
floatHashTypeName,  ( Name
ltFloatHashValName
                           , Name
leFloatHashValName
                           , Name
eqFloatHashValName
                           , Name
geFloatHashValName
                           , Name
gtFloatHashValName
                           ))
    , (Name
intHashTypeName,    ( Name
ltIntHashValName
                           , Name
leIntHashValName
                           , Name
eqIntHashValName
                           , Name
geIntHashValName
                           , Name
gtIntHashValName
                           ))
    , (Name
wordHashTypeName,   ( Name
ltWordHashValName
                           , Name
leWordHashValName
                           , Name
eqWordHashValName
                           , Name
geWordHashValName
                           , Name
gtWordHashValName
                           ))
#if MIN_VERSION_base(4,13,0)
    , (Name
int8HashTypeName,   ( Name
ltInt8HashValName
                           , Name
leInt8HashValName
                           , Name
eqInt8HashValName
                           , Name
geInt8HashValName
                           , Name
gtInt8HashValName
                           ))
    , (Name
int16HashTypeName,  ( Name
ltInt16HashValName
                           , Name
leInt16HashValName
                           , Name
eqInt16HashValName
                           , Name
geInt16HashValName
                           , Name
gtInt16HashValName
                           ))
    , (Name
word8HashTypeName,  ( Name
ltWord8HashValName
                           , Name
leWord8HashValName
                           , Name
eqWord8HashValName
                           , Name
geWord8HashValName
                           , Name
gtWord8HashValName
                           ))
    , (Name
word16HashTypeName, ( Name
ltWord16HashValName
                           , Name
leWord16HashValName
                           , Name
eqWord16HashValName
                           , Name
geWord16HashValName
                           , Name
gtWord16HashValName
                           ))
#endif
#if MIN_VERSION_base(4,16,0)
    , (int32HashTypeName,  ( ltInt32HashValName
                           , leInt32HashValName
                           , eqInt32HashValName
                           , geInt32HashValName
                           , gtInt32HashValName
                           ))
    , (word32HashTypeName, ( ltWord32HashValName
                           , leWord32HashValName
                           , eqWord32HashValName
                           , geWord32HashValName
                           , gtWord32HashValName
                           ))
#endif
    ]

removeClassApp :: Type -> Type
removeClassApp :: Kind -> Kind
removeClassApp (AppT Kind
_ Kind
t2) = Kind
t2
removeClassApp Kind
t           = Kind
t

-- This is an ugly, but unfortunately necessary hack on older versions of GHC which
-- don't have a properly working newName. On those GHCs, even running newName on a
-- variable isn't enought to avoid shadowed variable warnings, so we "fix" the issue by
-- appending an uncommonly used string to the end of the name. This isn't foolproof,
-- since a user could freshen a variable named x and still have another x_' variable in
-- scope, but at least it's unlikely.
freshen :: Name -> Q Name
freshen :: Name -> Q Name
freshen Name
n = String -> Q Name
newName (Name -> String
nameBase Name
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_'")

freshenType :: Type -> Q Type
freshenType :: Kind -> Q Kind
freshenType Kind
t =
  do let xs :: [(Name, Q Kind)]
xs = [(Name
n, Name -> Kind
VarT (Name -> Kind) -> Q Name -> Q Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q Name
freshen Name
n) | Name
n <- Kind -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Kind
t]
     Map Name Kind
subst <- Map Name (Q Kind) -> Q (Map Name Kind)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
T.sequence ([(Name, Q Kind)] -> Map Name (Q Kind)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, Q Kind)]
xs)
     Kind -> Q Kind
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Kind -> Kind -> Kind
forall a. TypeSubstitution a => Map Name Kind -> a -> a
applySubstitution Map Name Kind
subst Kind
t)

enumFromToExpr :: Q Exp -> Q Exp -> Q Exp
enumFromToExpr :: Q Exp -> Q Exp -> Q Exp
enumFromToExpr Q Exp
f Q Exp
t = Name -> Q Exp
varE Name
enumFromToValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
f Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
t

primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr Q Exp
e1 Name
op Q Exp
e2 = Name -> Q Exp
varE Name
isTrueHashValName Q Exp -> Q Exp -> Q Exp
`appE`
                           Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
e1 (Name -> Q Exp
varE Name
op) Q Exp
e2

-- | Checks if a 'Name' represents a tuple type constructor (other than '()')
isNonUnitTuple :: Name -> Bool
isNonUnitTuple :: Name -> Bool
isNonUnitTuple = String -> Bool
isNonUnitTupleString (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

-- | Checks if a 'String' represents a tuple (other than '()')
isNonUnitTupleString :: String -> Bool
isNonUnitTupleString :: String -> Bool
isNonUnitTupleString (Char
'(':Char
',':String
_) = Bool
True
isNonUnitTupleString String
_           = Bool
False

-- | Checks if a 'String' names a valid Haskell infix data constructor (i.e., does
-- it begin with a colon?).
isInfixDataCon :: String -> Bool
isInfixDataCon :: String -> Bool
isInfixDataCon (Char
':':String
_) = Bool
True
isInfixDataCon String
_       = Bool
False

isSym :: String -> Bool
isSym :: String -> Bool
isSym String
""      = Bool
False
isSym (Char
c : String
_) = Char -> Bool
startsVarSym Char
c Bool -> Bool -> Bool
|| Char -> Bool
startsConSym Char
c

#if !defined(MIN_VERSION_ghc_boot_th)
startsVarSym, startsConSym :: Char -> Bool
startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids
startsConSym c = c == ':' -- Infix data constructors

startsVarSymASCII :: Char -> Bool
startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
#endif

ghc7'8OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 708
ghc7'8OrLater :: Bool
ghc7'8OrLater = Bool
True
#else
ghc7'8OrLater = False
#endif

-------------------------------------------------------------------------------
-- Manually quoted names
-------------------------------------------------------------------------------

-- By manually generating these names we avoid needing to use the
-- TemplateHaskell language extension when compiling the deriving-compat library.
-- This allows the library to be used in stage1 cross-compilers.

derivingCompatPackageKey :: String
#ifdef CURRENT_PACKAGE_KEY
derivingCompatPackageKey :: String
derivingCompatPackageKey = CURRENT_PACKAGE_KEY
#else
derivingCompatPackageKey = "deriving-compat-" ++ showVersion version
#endif

gHC_IX :: String
#if MIN_VERSION_base(4,14,0)
gHC_IX :: String
gHC_IX = String
"GHC.Ix"
#else
gHC_IX = "GHC.Arr"
#endif

mkDerivingCompatName_v :: String -> Name
mkDerivingCompatName_v :: String -> Name
mkDerivingCompatName_v = String -> String -> String -> Name
mkNameG_v String
derivingCompatPackageKey String
"Data.Deriving.Internal"

mkDerivingCompatName_tc :: String -> Name
mkDerivingCompatName_tc :: String -> Name
mkDerivingCompatName_tc = String -> String -> String -> Name
mkNameG_tc String
derivingCompatPackageKey String
"Data.Deriving.Internal"

isTrueHashValName :: Name
isTrueHashValName :: Name
isTrueHashValName = String -> Name
mkDerivingCompatName_v String
"isTrue#"

fmapConstValName :: Name
fmapConstValName :: Name
fmapConstValName = String -> Name
mkDerivingCompatName_v String
"fmapConst"

replaceConstValName :: Name
replaceConstValName :: Name
replaceConstValName = String -> Name
mkDerivingCompatName_v String
"replaceConst"

foldrConstValName :: Name
foldrConstValName :: Name
foldrConstValName = String -> Name
mkDerivingCompatName_v String
"foldrConst"

foldMapConstValName :: Name
foldMapConstValName :: Name
foldMapConstValName = String -> Name
mkDerivingCompatName_v String
"foldMapConst"

nullConstValName :: Name
nullConstValName :: Name
nullConstValName = String -> Name
mkDerivingCompatName_v String
"nullConst"

traverseConstValName :: Name
traverseConstValName :: Name
traverseConstValName = String -> Name
mkDerivingCompatName_v String
"traverseConst"

eqConstValName :: Name
eqConstValName :: Name
eqConstValName = String -> Name
mkDerivingCompatName_v String
"eqConst"

eq1ConstValName :: Name
eq1ConstValName :: Name
eq1ConstValName = String -> Name
mkDerivingCompatName_v String
"eq1Const"

liftEqConstValName :: Name
liftEqConstValName :: Name
liftEqConstValName = String -> Name
mkDerivingCompatName_v String
"liftEqConst"

liftEq2ConstValName :: Name
liftEq2ConstValName :: Name
liftEq2ConstValName = String -> Name
mkDerivingCompatName_v String
"liftEq2Const"

compareConstValName :: Name
compareConstValName :: Name
compareConstValName = String -> Name
mkDerivingCompatName_v String
"compareConst"

ltConstValName :: Name
ltConstValName :: Name
ltConstValName = String -> Name
mkDerivingCompatName_v String
"ltConst"

compare1ConstValName :: Name
compare1ConstValName :: Name
compare1ConstValName = String -> Name
mkDerivingCompatName_v String
"compare1Const"

liftCompareConstValName :: Name
liftCompareConstValName :: Name
liftCompareConstValName = String -> Name
mkDerivingCompatName_v String
"liftCompareConst"

liftCompare2ConstValName :: Name
liftCompare2ConstValName :: Name
liftCompare2ConstValName = String -> Name
mkDerivingCompatName_v String
"liftCompare2Const"

readsPrecConstValName :: Name
readsPrecConstValName :: Name
readsPrecConstValName = String -> Name
mkDerivingCompatName_v String
"readsPrecConst"

readPrecConstValName :: Name
readPrecConstValName :: Name
readPrecConstValName = String -> Name
mkDerivingCompatName_v String
"readPrecConst"

readsPrec1ConstValName :: Name
readsPrec1ConstValName :: Name
readsPrec1ConstValName = String -> Name
mkDerivingCompatName_v String
"readsPrec1Const"

liftReadsPrecConstValName :: Name
liftReadsPrecConstValName :: Name
liftReadsPrecConstValName = String -> Name
mkDerivingCompatName_v String
"liftReadsPrecConst"

liftReadPrecConstValName :: Name
liftReadPrecConstValName :: Name
liftReadPrecConstValName = String -> Name
mkDerivingCompatName_v String
"liftReadPrecConst"

liftReadsPrec2ConstValName :: Name
liftReadsPrec2ConstValName :: Name
liftReadsPrec2ConstValName = String -> Name
mkDerivingCompatName_v String
"liftReadsPrec2Const"

liftReadPrec2ConstValName :: Name
liftReadPrec2ConstValName :: Name
liftReadPrec2ConstValName = String -> Name
mkDerivingCompatName_v String
"liftReadPrec2Const"

showsPrecConstValName :: Name
showsPrecConstValName :: Name
showsPrecConstValName = String -> Name
mkDerivingCompatName_v String
"showsPrecConst"

showsPrec1ConstValName :: Name
showsPrec1ConstValName :: Name
showsPrec1ConstValName = String -> Name
mkDerivingCompatName_v String
"showsPrec1Const"

liftShowsPrecConstValName :: Name
liftShowsPrecConstValName :: Name
liftShowsPrecConstValName = String -> Name
mkDerivingCompatName_v String
"liftShowsPrecConst"

liftShowsPrec2ConstValName :: Name
liftShowsPrec2ConstValName :: Name
liftShowsPrec2ConstValName = String -> Name
mkDerivingCompatName_v String
"liftShowsPrec2Const"

viaTypeName :: Name
viaTypeName :: Name
viaTypeName = String -> Name
mkDerivingCompatName_tc String
"Via"

cHashDataName :: Name
cHashDataName :: Name
cHashDataName = String -> String -> String -> Name
mkNameG_d String
"ghc-prim" String
"GHC.Types" String
"C#"

dHashDataName :: Name
dHashDataName :: Name
dHashDataName = String -> String -> String -> Name
mkNameG_d String
"ghc-prim" String
"GHC.Types" String
"D#"

fHashDataName :: Name
fHashDataName :: Name
fHashDataName = String -> String -> String -> Name
mkNameG_d String
"ghc-prim" String
"GHC.Types" String
"F#"

identDataName :: Name
identDataName :: Name
identDataName = String -> String -> String -> Name
mkNameG_d String
"base" String
"Text.Read.Lex" String
"Ident"

iHashDataName :: Name
iHashDataName :: Name
iHashDataName = String -> String -> String -> Name
mkNameG_d String
"ghc-prim" String
"GHC.Types" String
"I#"

puncDataName :: Name
puncDataName :: Name
puncDataName = String -> String -> String -> Name
mkNameG_d String
"base" String
"Text.Read.Lex" String
"Punc"

symbolDataName :: Name
symbolDataName :: Name
symbolDataName = String -> String -> String -> Name
mkNameG_d String
"base" String
"Text.Read.Lex" String
"Symbol"

wrapMonadDataName :: Name
wrapMonadDataName :: Name
wrapMonadDataName = String -> String -> String -> Name
mkNameG_d String
"base" String
"Control.Applicative" String
"WrapMonad"

addrHashTypeName :: Name
addrHashTypeName :: Name
addrHashTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Prim" String
"Addr#"

boundedTypeName :: Name
boundedTypeName :: Name
boundedTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"GHC.Enum" String
"Bounded"

charHashTypeName :: Name
charHashTypeName :: Name
charHashTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Prim" String
"Char#"

doubleHashTypeName :: Name
doubleHashTypeName :: Name
doubleHashTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Prim" String
"Double#"

enumTypeName :: Name
enumTypeName :: Name
enumTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"GHC.Enum" String
"Enum"

floatHashTypeName :: Name
floatHashTypeName :: Name
floatHashTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Prim" String
"Float#"

foldableTypeName :: Name
foldableTypeName :: Name
foldableTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Foldable" String
"Foldable"

functorTypeName :: Name
functorTypeName :: Name
functorTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"GHC.Base" String
"Functor"

intTypeName :: Name
intTypeName :: Name
intTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Types" String
"Int"

intHashTypeName :: Name
intHashTypeName :: Name
intHashTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Prim" String
"Int#"

ixTypeName :: Name
ixTypeName :: Name
ixTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
gHC_IX String
"Ix"

readTypeName :: Name
readTypeName :: Name
readTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"GHC.Read" String
"Read"

showTypeName :: Name
showTypeName :: Name
showTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"GHC.Show" String
"Show"

traversableTypeName :: Name
traversableTypeName :: Name
traversableTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Traversable" String
"Traversable"

wordHashTypeName :: Name
wordHashTypeName :: Name
wordHashTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Prim" String
"Word#"

altValName :: Name
altValName :: Name
altValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Text.ParserCombinators.ReadPrec" String
"+++"

appendValName :: Name
appendValName :: Name
appendValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"++"

chooseValName :: Name
chooseValName :: Name
chooseValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"choose"

coerceValName :: Name
coerceValName :: Name
coerceValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"coerce"

composeValName :: Name
composeValName :: Name
composeValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"."

constValName :: Name
constValName :: Name
constValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"const"

enumFromValName :: Name
enumFromValName :: Name
enumFromValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Enum" String
"enumFrom"

enumFromThenValName :: Name
enumFromThenValName :: Name
enumFromThenValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Enum" String
"enumFromThen"

enumFromThenToValName :: Name
enumFromThenToValName :: Name
enumFromThenToValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Enum" String
"enumFromThenTo"

enumFromToValName :: Name
enumFromToValName :: Name
enumFromToValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Enum" String
"enumFromTo"

eqAddrHashValName :: Name
eqAddrHashValName :: Name
eqAddrHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"eqAddr#"

eqCharHashValName :: Name
eqCharHashValName :: Name
eqCharHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"eqChar#"

eqDoubleHashValName :: Name
eqDoubleHashValName :: Name
eqDoubleHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"==##"

eqFloatHashValName :: Name
eqFloatHashValName :: Name
eqFloatHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"eqFloat#"

eqIntHashValName :: Name
eqIntHashValName :: Name
eqIntHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"==#"

eqWordHashValName :: Name
eqWordHashValName :: Name
eqWordHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"eqWord#"

errorValName :: Name
errorValName :: Name
errorValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Err" String
"error"

flipValName :: Name
flipValName :: Name
flipValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"flip"

fmapValName :: Name
fmapValName :: Name
fmapValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"fmap"

foldrValName :: Name
foldrValName :: Name
foldrValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Foldable" String
"foldr"

foldMapValName :: Name
foldMapValName :: Name
foldMapValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Foldable" String
"foldMap"

fromEnumValName :: Name
fromEnumValName :: Name
fromEnumValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Enum" String
"fromEnum"

geAddrHashValName :: Name
geAddrHashValName :: Name
geAddrHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"geAddr#"

geCharHashValName :: Name
geCharHashValName :: Name
geCharHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"geChar#"

geDoubleHashValName :: Name
geDoubleHashValName :: Name
geDoubleHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
">=##"

geFloatHashValName :: Name
geFloatHashValName :: Name
geFloatHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"geFloat#"

geIntHashValName :: Name
geIntHashValName :: Name
geIntHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
">=#"

getTagValName :: Name
getTagValName :: Name
getTagValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"getTag"

geWordHashValName :: Name
geWordHashValName :: Name
geWordHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"geWord#"

gtAddrHashValName :: Name
gtAddrHashValName :: Name
gtAddrHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"gtAddr#"

gtCharHashValName :: Name
gtCharHashValName :: Name
gtCharHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"gtChar#"

gtDoubleHashValName :: Name
gtDoubleHashValName :: Name
gtDoubleHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
">##"

gtFloatHashValName :: Name
gtFloatHashValName :: Name
gtFloatHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"gtFloat#"

gtIntHashValName :: Name
gtIntHashValName :: Name
gtIntHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
">#"

gtWordHashValName :: Name
gtWordHashValName :: Name
gtWordHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"gtWord#"

idValName :: Name
idValName :: Name
idValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"id"

indexValName :: Name
indexValName :: Name
indexValName = String -> String -> String -> Name
mkNameG_v String
"base" String
gHC_IX String
"index"

inRangeValName :: Name
inRangeValName :: Name
inRangeValName = String -> String -> String -> Name
mkNameG_v String
"base" String
gHC_IX String
"inRange"

leAddrHashValName :: Name
leAddrHashValName :: Name
leAddrHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"leAddr#"

leCharHashValName :: Name
leCharHashValName :: Name
leCharHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"leChar#"

leDoubleHashValName :: Name
leDoubleHashValName :: Name
leDoubleHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"<=##"

leFloatHashValName :: Name
leFloatHashValName :: Name
leFloatHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"leFloat#"

leIntHashValName :: Name
leIntHashValName :: Name
leIntHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"<=#"

leWordHashValName :: Name
leWordHashValName :: Name
leWordHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"leWord#"

liftReadListPrecDefaultValName :: Name
liftReadListPrecDefaultValName :: Name
liftReadListPrecDefaultValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftReadListPrecDefault"

liftReadListPrec2DefaultValName :: Name
liftReadListPrec2DefaultValName :: Name
liftReadListPrec2DefaultValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftReadListPrec2Default"

liftReadListPrecValName :: Name
liftReadListPrecValName :: Name
liftReadListPrecValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftReadListPrec"

liftReadListPrec2ValName :: Name
liftReadListPrec2ValName :: Name
liftReadListPrec2ValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftReadListPrec2"

liftReadPrecValName :: Name
liftReadPrecValName :: Name
liftReadPrecValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftReadPrec"

liftReadPrec2ValName :: Name
liftReadPrec2ValName :: Name
liftReadPrec2ValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftReadPrec2"

listValName :: Name
listValName :: Name
listValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"list"

ltAddrHashValName :: Name
ltAddrHashValName :: Name
ltAddrHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"ltAddr#"

ltCharHashValName :: Name
ltCharHashValName :: Name
ltCharHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"ltChar#"

ltDoubleHashValName :: Name
ltDoubleHashValName :: Name
ltDoubleHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"<##"

ltFloatHashValName :: Name
ltFloatHashValName :: Name
ltFloatHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"ltFloat#"

ltIntHashValName :: Name
ltIntHashValName :: Name
ltIntHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"<#"

ltWordHashValName :: Name
ltWordHashValName :: Name
ltWordHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"ltWord#"

minBoundValName :: Name
minBoundValName :: Name
minBoundValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Enum" String
"minBound"

mapValName :: Name
mapValName :: Name
mapValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"map"

maxBoundValName :: Name
maxBoundValName :: Name
maxBoundValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Enum" String
"maxBound"

minusIntHashValName :: Name
minusIntHashValName :: Name
minusIntHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"-#"

parenValName :: Name
parenValName :: Name
parenValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"paren"

parensValName :: Name
parensValName :: Name
parensValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"parens"

pfailValName :: Name
pfailValName :: Name
pfailValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Text.ParserCombinators.ReadPrec" String
"pfail"

plusValName :: Name
plusValName :: Name
plusValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Num" String
"+"

precValName :: Name
precValName :: Name
precValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Text.ParserCombinators.ReadPrec" String
"prec"

predValName :: Name
predValName :: Name
predValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Enum" String
"pred"

rangeSizeValName :: Name
rangeSizeValName :: Name
rangeSizeValName = String -> String -> String -> Name
mkNameG_v String
"base" String
gHC_IX String
"rangeSize"

rangeValName :: Name
rangeValName :: Name
rangeValName = String -> String -> String -> Name
mkNameG_v String
"base" String
gHC_IX String
"range"

readFieldHash :: String -> ReadPrec a -> ReadPrec a
readFieldHash :: String -> ReadPrec a -> ReadPrec a
readFieldHash String
fieldName ReadPrec a
readVal = do
        Lexeme -> ReadPrec ()
expectP (String -> Lexeme
L.Ident String
fieldName)
        Lexeme -> ReadPrec ()
expectP (String -> Lexeme
L.Symbol String
"#")
        Lexeme -> ReadPrec ()
expectP (String -> Lexeme
L.Punc String
"=")
        ReadPrec a
readVal
{-# NOINLINE readFieldHash #-}

readFieldHashValName :: Name
readFieldHashValName :: Name
readFieldHashValName = String -> String -> String -> Name
mkNameG_v String
derivingCompatPackageKey String
"Data.Deriving.Internal" String
"readFieldHash"

readListValName :: Name
readListValName :: Name
readListValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"readList"

readListPrecDefaultValName :: Name
readListPrecDefaultValName :: Name
readListPrecDefaultValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"readListPrecDefault"

readListPrecValName :: Name
readListPrecValName :: Name
readListPrecValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"readListPrec"

readPrec_to_SValName :: Name
readPrec_to_SValName :: Name
readPrec_to_SValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Text.ParserCombinators.ReadPrec" String
"readPrec_to_S"

readPrecValName :: Name
readPrecValName :: Name
readPrecValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"readPrec"

readS_to_PrecValName :: Name
readS_to_PrecValName :: Name
readS_to_PrecValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Text.ParserCombinators.ReadPrec" String
"readS_to_Prec"

readsPrecValName :: Name
readsPrecValName :: Name
readsPrecValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"readsPrec"

replaceValName :: Name
replaceValName :: Name
replaceValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"<$"

resetValName :: Name
resetValName :: Name
resetValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Text.ParserCombinators.ReadPrec" String
"reset"

returnValName :: Name
returnValName :: Name
returnValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"return"

seqValName :: Name
seqValName :: Name
seqValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"seq"

showCharValName :: Name
showCharValName :: Name
showCharValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Show" String
"showChar"

showListValName :: Name
showListValName :: Name
showListValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Show" String
"showList"

showListWithValName :: Name
showListWithValName :: Name
showListWithValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Text.Show" String
"showListWith"

showParenValName :: Name
showParenValName :: Name
showParenValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Show" String
"showParen"

showsPrecValName :: Name
showsPrecValName :: Name
showsPrecValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Show" String
"showsPrec"

showSpaceValName :: Name
showSpaceValName :: Name
showSpaceValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Show" String
"showSpace"

showStringValName :: Name
showStringValName :: Name
showStringValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Show" String
"showString"

stepValName :: Name
stepValName :: Name
stepValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Text.ParserCombinators.ReadPrec" String
"step"

succValName :: Name
succValName :: Name
succValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Enum" String
"succ"

tagToEnumHashValName :: Name
tagToEnumHashValName :: Name
tagToEnumHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"tagToEnum#"

timesValName :: Name
timesValName :: Name
timesValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Num" String
"*"

toEnumValName :: Name
toEnumValName :: Name
toEnumValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Enum" String
"toEnum"

traverseValName :: Name
traverseValName :: Name
traverseValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Traversable" String
"traverse"

unsafeIndexValName :: Name
unsafeIndexValName :: Name
unsafeIndexValName = String -> String -> String -> Name
mkNameG_v String
"base" String
gHC_IX String
"unsafeIndex"

unsafeRangeSizeValName :: Name
unsafeRangeSizeValName :: Name
unsafeRangeSizeValName = String -> String -> String -> Name
mkNameG_v String
"base" String
gHC_IX String
"unsafeRangeSize"

unwrapMonadValName :: Name
unwrapMonadValName :: Name
unwrapMonadValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Control.Applicative" String
"unwrapMonad"

#if MIN_VERSION_base(4,4,0)
boolTypeName :: Name
boolTypeName :: Name
boolTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Types" String
"Bool"

falseDataName :: Name
falseDataName :: Name
falseDataName = String -> String -> String -> Name
mkNameG_d String
"ghc-prim" String
"GHC.Types" String
"False"

trueDataName :: Name
trueDataName :: Name
trueDataName = String -> String -> String -> Name
mkNameG_d String
"ghc-prim" String
"GHC.Types" String
"True"
#else
boolTypeName :: Name
boolTypeName = mkNameG_tc "ghc-prim" "GHC.Bool" "Bool"

falseDataName :: Name
falseDataName = mkNameG_d "ghc-prim" "GHC.Bool" "False"

trueDataName :: Name
trueDataName = mkNameG_d "ghc-prim" "GHC.Bool" "True"
#endif

#if MIN_VERSION_base(4,5,0)
eqDataName :: Name
eqDataName :: Name
eqDataName = String -> String -> String -> Name
mkNameG_d String
"ghc-prim" String
"GHC.Types" String
"EQ"

gtDataName :: Name
gtDataName :: Name
gtDataName = String -> String -> String -> Name
mkNameG_d String
"ghc-prim" String
"GHC.Types" String
"GT"

ltDataName :: Name
ltDataName :: Name
ltDataName = String -> String -> String -> Name
mkNameG_d String
"ghc-prim" String
"GHC.Types" String
"LT"

eqTypeName :: Name
eqTypeName :: Name
eqTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Classes" String
"Eq"

ordTypeName :: Name
ordTypeName :: Name
ordTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Classes" String
"Ord"

andValName :: Name
andValName :: Name
andValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Classes" String
"&&"

compareValName :: Name
compareValName :: Name
compareValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Classes" String
"compare"

eqValName :: Name
eqValName :: Name
eqValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Classes" String
"=="

geValName :: Name
geValName :: Name
geValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Classes" String
">="

gtValName :: Name
gtValName :: Name
gtValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Classes" String
">"

leValName :: Name
leValName :: Name
leValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Classes" String
"<="

ltValName :: Name
ltValName :: Name
ltValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Classes" String
"<"

notValName :: Name
notValName :: Name
notValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Classes" String
"not"
#else
eqDataName :: Name
eqDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "EQ"

gtDataName :: Name
gtDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "GT"

ltDataName :: Name
ltDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "LT"

eqTypeName :: Name
eqTypeName = mkNameG_tc "base" "GHC.Classes" "Eq"

ordTypeName :: Name
ordTypeName = mkNameG_tc "base" "GHC.Classes" "Ord"

andValName :: Name
andValName = mkNameG_v "base" "GHC.Classes" "&&"

compareValName :: Name
compareValName = mkNameG_v "base" "GHC.Classes" "compare"

eqValName :: Name
eqValName = mkNameG_v "base" "GHC.Classes" "=="

geValName :: Name
geValName = mkNameG_v "base" "GHC.Classes" ">="

gtValName :: Name
gtValName = mkNameG_v "base" "GHC.Classes" ">"

leValName :: Name
leValName = mkNameG_v "base" "GHC.Classes" "<="

ltValName :: Name
ltValName = mkNameG_v "base" "GHC.Classes" "<"

notValName :: Name
notValName = mkNameG_v "base" "GHC.Classes" "not"
#endif

#if MIN_VERSION_base(4,6,0)
wHashDataName :: Name
wHashDataName :: Name
wHashDataName = String -> String -> String -> Name
mkNameG_d String
"ghc-prim" String
"GHC.Types" String
"W#"
#else
wHashDataName :: Name
wHashDataName = mkNameG_d "base" "GHC.Word" "W#"
#endif

#if MIN_VERSION_base(4,7,0)
expectPValName :: Name
expectPValName :: Name
expectPValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"expectP"
#else
expectP :: Lexeme -> ReadPrec ()
expectP lexeme = do
  thing <- lexP
  if thing == lexeme then return () else pfail

expectPValName :: Name
expectPValName = mkDerivingCompatName_v "expectP"
#endif

#if MIN_VERSION_base(4,8,0)
allValName :: Name
allValName :: Name
allValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Foldable" String
"all"

apValName :: Name
apValName :: Name
apValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"<*>"

pureValName :: Name
pureValName :: Name
pureValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"pure"

liftA2ValName :: Name
liftA2ValName :: Name
liftA2ValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"liftA2"

mappendValName :: Name
mappendValName :: Name
mappendValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"mappend"

memptyValName :: Name
memptyValName :: Name
memptyValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"mempty"

nullValName :: Name
nullValName :: Name
nullValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Foldable" String
"null"
#else
allValName :: Name
allValName = mkNameG_v "base" "GHC.List" "all"

apValName :: Name
apValName = mkNameG_v "base" "Control.Applicative" "<*>"

pureValName :: Name
pureValName = mkNameG_v "base" "Control.Applicative" "pure"

liftA2ValName :: Name
liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2"

mappendValName :: Name
mappendValName = mkNameG_v "base" "Data.Monoid" "mappend"

memptyValName :: Name
memptyValName = mkNameG_v "base" "Data.Monoid" "mempty"

nullValName :: Name
nullValName = mkNameG_v "base" "GHC.List" "null"
#endif

#if MIN_VERSION_base(4,9,0)
eq1TypeName :: Name
eq1TypeName :: Name
eq1TypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Functor.Classes" String
"Eq1"

eq2TypeName :: Name
eq2TypeName :: Name
eq2TypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Functor.Classes" String
"Eq2"

liftEqValName :: Name
liftEqValName :: Name
liftEqValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftEq"

liftEq2ValName :: Name
liftEq2ValName :: Name
liftEq2ValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftEq2"

ord1TypeName :: Name
ord1TypeName :: Name
ord1TypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Functor.Classes" String
"Ord1"

ord2TypeName :: Name
ord2TypeName :: Name
ord2TypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Functor.Classes" String
"Ord2"

liftCompareValName :: Name
liftCompareValName :: Name
liftCompareValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftCompare"

liftCompare2ValName :: Name
liftCompare2ValName :: Name
liftCompare2ValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftCompare2"

read1TypeName :: Name
read1TypeName :: Name
read1TypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Functor.Classes" String
"Read1"

read2TypeName :: Name
read2TypeName :: Name
read2TypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Functor.Classes" String
"Read2"

liftReadsPrecValName :: Name
liftReadsPrecValName :: Name
liftReadsPrecValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftReadsPrec"

liftReadListValName :: Name
liftReadListValName :: Name
liftReadListValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftReadList"

liftReadsPrec2ValName :: Name
liftReadsPrec2ValName :: Name
liftReadsPrec2ValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftReadsPrec2"

liftReadList2ValName :: Name
liftReadList2ValName :: Name
liftReadList2ValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftReadList2"

show1TypeName :: Name
show1TypeName :: Name
show1TypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Functor.Classes" String
"Show1"

show2TypeName :: Name
show2TypeName :: Name
show2TypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Functor.Classes" String
"Show2"

liftShowListValName :: Name
liftShowListValName :: Name
liftShowListValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftShowList"

liftShowsPrecValName :: Name
liftShowsPrecValName :: Name
liftShowsPrecValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftShowsPrec"

liftShowList2ValName :: Name
liftShowList2ValName :: Name
liftShowList2ValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftShowList2"

liftShowsPrec2ValName :: Name
liftShowsPrec2ValName :: Name
liftShowsPrec2ValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Functor.Classes" String
"liftShowsPrec2"
#else
-- If Data.Functor.Classes isn't located in base, then sadly we can't refer to
-- Names from that module without using -XTemplateHaskell.
# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)
eq1TypeName :: Name
eq1TypeName = ''Eq1

eq2TypeName :: Name
eq2TypeName = ''Eq2

liftEqValName :: Name
liftEqValName = 'liftEq

liftEq2ValName :: Name
liftEq2ValName = 'liftEq2

ord1TypeName :: Name
ord1TypeName = ''Ord1

ord2TypeName :: Name
ord2TypeName = ''Ord2

liftCompareValName :: Name
liftCompareValName = 'liftCompare

liftCompare2ValName :: Name
liftCompare2ValName = 'liftCompare2

read1TypeName :: Name
read1TypeName = ''Read1

read2TypeName :: Name
read2TypeName = ''Read2

liftReadsPrecValName :: Name
liftReadsPrecValName = 'liftReadsPrec

liftReadListValName :: Name
liftReadListValName = 'liftReadList

liftReadsPrec2ValName :: Name
liftReadsPrec2ValName = 'liftReadsPrec2

liftReadList2ValName :: Name
liftReadList2ValName = 'liftReadList2

show1TypeName :: Name
show1TypeName = ''Show1

show2TypeName :: Name
show2TypeName = ''Show2

liftShowListValName :: Name
liftShowListValName = 'liftShowList

liftShowsPrecValName :: Name
liftShowsPrecValName = 'liftShowsPrec

liftShowList2ValName :: Name
liftShowList2ValName = 'liftShowList2

liftShowsPrec2ValName :: Name
liftShowsPrec2ValName = 'liftShowsPrec2
# else
eq1TypeName :: Name
eq1TypeName = ''Eq1

eq1ValName :: Name
eq1ValName = 'eq1

ord1TypeName :: Name
ord1TypeName = ''Ord1

compare1ValName :: Name
compare1ValName = 'compare1

read1TypeName :: Name
read1TypeName = ''Read1

readsPrec1ValName :: Name
readsPrec1ValName = 'readsPrec1

show1TypeName :: Name
show1TypeName = ''Show1

showsPrec1ValName :: Name
showsPrec1ValName = 'showsPrec1

newtype Apply f a = Apply { unApply :: f a }

instance (Eq1 f, Eq a) => Eq (Apply f a) where
    Apply x == Apply y = eq1 x y

instance (Ord1 g, Ord a) => Ord (Apply g a) where
    compare (Apply x) (Apply y) = compare1 x y

instance (Read1 f, Read a) => Read (Apply f a) where
    readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s]

instance (Show1 f, Show a) => Show (Apply f a) where
    showsPrec p (Apply x) = showsPrec1 p x

makeFmapApplyNeg :: ClassRep a => a -> Name -> Type -> Name -> Q Exp
makeFmapApplyNeg = makeFmapApply False

makeFmapApplyPos :: ClassRep a => a -> Name -> Type -> Name -> Q Exp
makeFmapApplyPos = makeFmapApply True

makeFmapApply :: ClassRep a => Bool -> a -> Name -> Type -> Name -> Q Exp
makeFmapApply pos cRep conName (SigT ty _) name = makeFmapApply pos cRep conName ty name
makeFmapApply pos cRep conName t name = do
    let tyCon :: Type
        tyArgs :: [Type]
        (tyCon, tyArgs) = unapplyTy t

        numLastArgs :: Int
        numLastArgs = min (arity cRep) (length tyArgs)

        lhsArgs, rhsArgs :: [Type]
        (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs

        inspectTy :: Type -> Q Exp
        inspectTy (SigT ty _) = inspectTy ty
        inspectTy (VarT a) | a == name = varE idValName
        inspectTy beta = varE fmapValName `appE`
                           infixApp (if pos then makeFmapApply pos cRep conName beta name
                                            else conE applyDataName)
                                    (varE composeValName)
                                    (if pos then varE unApplyValName
                                            else makeFmapApply pos cRep conName beta name)

    itf <- isInTypeFamilyApp [name] tyCon tyArgs
    if any (`mentionsName` [name]) lhsArgs || itf
       then outOfPlaceTyVarError cRep conName
       else inspectTy (head rhsArgs)

applyDataName :: Name
applyDataName = mkNameG_d derivingCompatPackageKey "Data.Deriving.Internal" "Apply"

unApplyValName :: Name
unApplyValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "unApply"
# endif
#endif

#if MIN_VERSION_base(4,10,0)
showCommaSpaceValName :: Name
showCommaSpaceValName :: Name
showCommaSpaceValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Show" String
"showCommaSpace"
#else
showCommaSpace :: ShowS
showCommaSpace = showString ", "

showCommaSpaceValName :: Name
showCommaSpaceValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "showCommaSpace"
#endif

#if MIN_VERSION_base(4,11,0)
appEndoValName :: Name
appEndoValName :: Name
appEndoValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Semigroup.Internal" String
"appEndo"

dualDataName :: Name
dualDataName :: Name
dualDataName = String -> String -> String -> Name
mkNameG_d String
"base" String
"Data.Semigroup.Internal" String
"Dual"

endoDataName :: Name
endoDataName :: Name
endoDataName = String -> String -> String -> Name
mkNameG_d String
"base" String
"Data.Semigroup.Internal" String
"Endo"

getDualValName :: Name
getDualValName :: Name
getDualValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"Data.Semigroup.Internal" String
"getDual"

readFieldValName :: Name
readFieldValName :: Name
readFieldValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"readField"

readSymFieldValName :: Name
readSymFieldValName :: Name
readSymFieldValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Read" String
"readSymField"
#else
appEndoValName :: Name
appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"

dualDataName :: Name
dualDataName = mkNameG_d "base" "Data.Monoid" "Dual"

endoDataName :: Name
endoDataName = mkNameG_d "base" "Data.Monoid" "Endo"

getDualValName :: Name
getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"

readField :: String -> ReadPrec a -> ReadPrec a
readField fieldName readVal = do
        expectP (L.Ident fieldName)
        expectP (L.Punc "=")
        readVal
{-# NOINLINE readField #-}

readFieldValName :: Name
readFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readField"

readSymField :: String -> ReadPrec a -> ReadPrec a
readSymField fieldName readVal = do
        expectP (L.Punc "(")
        expectP (L.Symbol fieldName)
        expectP (L.Punc ")")
        expectP (L.Punc "=")
        readVal
{-# NOINLINE readSymField #-}

readSymFieldValName :: Name
readSymFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readSymField"
#endif

#if MIN_VERSION_base(4,13,0)
eqInt8HashValName :: Name
eqInt8HashValName :: Name
eqInt8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"eqInt8#"

eqInt16HashValName :: Name
eqInt16HashValName :: Name
eqInt16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"eqInt16#"

eqWord8HashValName :: Name
eqWord8HashValName :: Name
eqWord8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"eqWord8#"

eqWord16HashValName :: Name
eqWord16HashValName :: Name
eqWord16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"eqWord16#"

geInt8HashValName :: Name
geInt8HashValName :: Name
geInt8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"geInt8#"

geInt16HashValName :: Name
geInt16HashValName :: Name
geInt16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"geInt16#"

geWord8HashValName :: Name
geWord8HashValName :: Name
geWord8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"geWord8#"

geWord16HashValName :: Name
geWord16HashValName :: Name
geWord16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"geWord16#"

gtInt8HashValName :: Name
gtInt8HashValName :: Name
gtInt8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"gtInt8#"

gtInt16HashValName :: Name
gtInt16HashValName :: Name
gtInt16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"gtInt16#"

gtWord8HashValName :: Name
gtWord8HashValName :: Name
gtWord8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"gtWord8#"

gtWord16HashValName :: Name
gtWord16HashValName :: Name
gtWord16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"gtWord16#"

int8HashTypeName :: Name
int8HashTypeName :: Name
int8HashTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Prim" String
"Int8#"

int8ToIntHashValName :: Name
int8ToIntHashValName :: Name
int8ToIntHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim"
# if MIN_VERSION_base(4,16,0)
  "int8ToInt#"
# else
  String
"extendInt8#"
# endif

int16HashTypeName :: Name
int16HashTypeName :: Name
int16HashTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Prim" String
"Int16#"

int16ToIntHashValName :: Name
int16ToIntHashValName :: Name
int16ToIntHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim"
# if MIN_VERSION_base(4,16,0)
  "int16ToInt#"
# else
  String
"extendInt16#"
# endif

intToInt8HashValName :: Name
intToInt8HashValName :: Name
intToInt8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim"
# if MIN_VERSION_base(4,16,0)
  "intToInt8#"
# else
  String
"narrowInt8#"
# endif

intToInt16HashValName :: Name
intToInt16HashValName :: Name
intToInt16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim"
# if MIN_VERSION_base(4,16,0)
  "intToInt16#"
# else
  String
"narrowInt16#"
# endif

leInt8HashValName :: Name
leInt8HashValName :: Name
leInt8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"leInt8#"

leInt16HashValName :: Name
leInt16HashValName :: Name
leInt16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"leInt16#"

leWord8HashValName :: Name
leWord8HashValName :: Name
leWord8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"leWord8#"

leWord16HashValName :: Name
leWord16HashValName :: Name
leWord16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"leWord16#"

ltInt8HashValName :: Name
ltInt8HashValName :: Name
ltInt8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"ltInt8#"

ltInt16HashValName :: Name
ltInt16HashValName :: Name
ltInt16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"ltInt16#"

ltWord8HashValName :: Name
ltWord8HashValName :: Name
ltWord8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"ltWord8#"

ltWord16HashValName :: Name
ltWord16HashValName :: Name
ltWord16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim" String
"ltWord16#"

word8HashTypeName :: Name
word8HashTypeName :: Name
word8HashTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Prim" String
"Word8#"

word8ToWordHashValName :: Name
word8ToWordHashValName :: Name
word8ToWordHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim"
# if MIN_VERSION_base(4,16,0)
  "word8ToWord#"
# else
  String
"extendWord8#"
# endif

word16HashTypeName :: Name
word16HashTypeName :: Name
word16HashTypeName = String -> String -> String -> Name
mkNameG_tc String
"ghc-prim" String
"GHC.Prim" String
"Word16#"

word16ToWordHashValName :: Name
word16ToWordHashValName :: Name
word16ToWordHashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim"
# if MIN_VERSION_base(4,16,0)
  "word16ToWord#"
# else
  String
"extendWord16#"
# endif

wordToWord8HashValName :: Name
wordToWord8HashValName :: Name
wordToWord8HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim"
# if MIN_VERSION_base(4,16,0)
  "wordToWord8#"
# else
  String
"narrowWord8#"
# endif

wordToWord16HashValName :: Name
wordToWord16HashValName :: Name
wordToWord16HashValName = String -> String -> String -> Name
mkNameG_v String
"ghc-prim" String
"GHC.Prim"
# if MIN_VERSION_base(4,16,0)
  "wordToWord16#"
# else
  String
"narrowWord16#"
# endif
#endif

#if MIN_VERSION_base(4,16,0)
eqInt32HashValName :: Name
eqInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt32#"

eqWord32HashValName :: Name
eqWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord32#"

geInt32HashValName :: Name
geInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt32#"

geWord32HashValName :: Name
geWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord32#"

gtInt32HashValName :: Name
gtInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt32#"

gtWord32HashValName :: Name
gtWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord32#"

int32HashTypeName :: Name
int32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int32#"

int32ToIntHashValName :: Name
int32ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "int32ToInt#"

intToInt32HashValName :: Name
intToInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "intToInt32#"

leInt32HashValName :: Name
leInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt32#"

leWord32HashValName :: Name
leWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord32#"

ltInt32HashValName :: Name
ltInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt32#"

ltWord32HashValName :: Name
ltWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord32#"

word32HashTypeName :: Name
word32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word32#"

word32ToWordHashValName :: Name
word32ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "word32ToWord#"

wordToWord32HashValName :: Name
wordToWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "wordToWord32#"
#endif