{-# 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 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 Data.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.Lib
import Language.Haskell.TH.Ppr (pprint)
import Language.Haskell.TH.Syntax
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
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 n :: Name
n k :: 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 ns :: [Name]
ns t :: 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
data a `Via` b
infix 0 `Via`
fmapConst :: f b -> (a -> b) -> f a -> f b
fmapConst :: f b -> (a -> b) -> f a -> f b
fmapConst x :: f b
x _ _ = f b
x
{-# INLINE fmapConst #-}
foldrConst :: b -> (a -> b -> b) -> b -> t a -> b
foldrConst :: b -> (a -> b -> b) -> b -> t a -> b
foldrConst x :: b
x _ _ _ = b
x
{-# INLINE foldrConst #-}
foldMapConst :: m -> (a -> m) -> t a -> m
foldMapConst :: m -> (a -> m) -> t a -> m
foldMapConst x :: m
x _ _ = m
x
{-# INLINE foldMapConst #-}
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 x :: f (t b)
x _ _ = f (t b)
x
{-# INLINE traverseConst #-}
eqConst :: Bool
-> a -> a -> Bool
eqConst :: Bool -> a -> a -> Bool
eqConst x :: Bool
x _ _ = Bool
x
{-# INLINE eqConst #-}
eq1Const :: Bool
-> f a -> f a-> Bool
eq1Const :: Bool -> f a -> f a -> Bool
eq1Const x :: Bool
x _ _ = 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 x :: Bool
x _ _ _ = 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 x :: Bool
x _ _ _ _ = Bool
x
{-# INLINE liftEq2Const #-}
compareConst :: Ordering -> a -> a -> Ordering
compareConst :: Ordering -> a -> a -> Ordering
compareConst x :: Ordering
x _ _ = Ordering
x
{-# INLINE compareConst #-}
ltConst :: Bool -> a -> a -> Bool
ltConst :: Bool -> a -> a -> Bool
ltConst x :: Bool
x _ _ = Bool
x
{-# INLINE ltConst #-}
compare1Const :: Ordering -> f a -> f a -> Ordering
compare1Const :: Ordering -> f a -> f a -> Ordering
compare1Const x :: Ordering
x _ _ = 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 x :: Ordering
x _ _ _ = 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 x :: Ordering
x _ _ _ _ = Ordering
x
{-# INLINE liftCompare2Const #-}
readsPrecConst :: ReadS a -> Int -> ReadS a
readsPrecConst :: ReadS a -> Int -> ReadS a
readsPrecConst x :: ReadS a
x _ = ReadS a
x
{-# INLINE readsPrecConst #-}
readPrecConst :: ReadPrec a -> ReadPrec a
readPrecConst :: ReadPrec a -> ReadPrec a
readPrecConst x :: 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 x :: ReadS (f a)
x _ = 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 x :: ReadS (f a)
x _ _ _ = 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 x :: ReadPrec (f a)
x _ _ = 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 x :: ReadS (f a b)
x _ _ _ _ _ = 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 x :: ReadPrec (f a b)
x _ _ _ _ = ReadPrec (f a b)
x
{-# INLINE liftReadPrec2Const #-}
showsPrecConst :: ShowS
-> Int -> a -> ShowS
showsPrecConst :: ShowS -> Int -> a -> ShowS
showsPrecConst x :: ShowS
x _ _ = ShowS
x
{-# INLINE showsPrecConst #-}
showsPrec1Const :: ShowS
-> Int -> f a -> ShowS
showsPrec1Const :: ShowS -> Int -> f a -> ShowS
showsPrec1Const x :: ShowS
x _ _ = 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 x :: ShowS
x _ _ _ _ = 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 x :: ShowS
x _ _ _ _ _ _ = ShowS
x
{-# INLINE liftShowsPrec2Const #-}
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
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar :: Kind -> StarKindStatus
canRealizeKindStar t :: Kind
t
| Kind -> Bool
hasKindStar Kind
t = StarKindStatus
KindStar
| Bool
otherwise = case Kind
t of
#if MIN_VERSION_template_haskell(2,8,0)
SigT _ (VarT k :: Name
k) -> Name -> StarKindStatus
IsKindVar Name
k
#endif
_ -> StarKindStatus
NotKindStar
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
starKindStatusToName _ = Maybe Name
forall a. Maybe a
Nothing
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
class ClassRep a where
arity :: a -> Int
allowExQuant :: a -> Bool
fullClassName :: a -> Name
classConstraint :: a -> Int -> Maybe Name
buildTypeInstance :: ClassRep a
=> a
-> Name
-> Cxt
-> [Type]
-> DatatypeVariant
-> Q (Cxt, Type)
buildTypeInstance :: a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Kind)
buildTypeInstance cRep :: a
cRep tyConName :: Name
tyConName dataCxt :: Cxt
dataCxt varTysOrig :: Cxt
varTysOrig variant :: DatatypeVariant
variant = do
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
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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
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]
(remainingTysExpSubst :: Cxt
remainingTysExpSubst, droppedTysExpSubst :: Cxt
droppedTysExpSubst) =
Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength Cxt
varTysExpSubst
droppedTyVarNames :: [Name]
droppedTyVarNames :: [Name]
droppedTyVarNames = Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
droppedTysExpSubst
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]
(preds :: [Maybe Kind]
preds, kvNames :: [[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
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
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]
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
Datatype -> Bool
False
Newtype -> Bool
False
DataInstance -> Bool
True
NewtypeInstance -> Bool
True
remainingTysOrigSubst' :: [Type]
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'
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
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)
deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name])
deriveConstraint :: a -> Kind -> (Maybe Kind, [Name])
deriveConstraint cRep :: a
cRep t :: 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 0, [])
| Bool
otherwise = case Int -> Kind -> Maybe [Name]
hasKindVarChain 1 Kind
t of
Just ns :: [Name]
ns | Int
cRepArity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 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 1, [Name]
ns)
_ -> case Int -> Kind -> Maybe [Name]
hasKindVarChain 2 Kind
t of
Just ns :: [Name]
ns | Int
cRepArity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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 2, [Name]
ns)
_ -> (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
checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name
-> Q c -> Q c
checkExistentialContext :: a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
checkExistentialContext cRep :: a
cRep tvMap :: TyVarMap b
tvMap ctxt :: Cxt
ctxt conName :: Name
conName q :: 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
noConstructorsError :: Q a
noConstructorsError :: Q a
noConstructorsError = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Must have at least one data constructor"
derivingKindError :: ClassRep a => a -> Name -> Q b
derivingKindError :: a -> Name -> Q b
derivingKindError cRep :: a
cRep tyConName :: 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 "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 ' '
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 " ..."
)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "‘\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 " 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
$ ""
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
contravarianceError :: Name -> Q a
contravarianceError :: Name -> Q a
contravarianceError conName :: 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 "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 "‘ must not use the last type variable in a function argument"
(String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ ""
noFunctionsError :: Name -> Q a
noFunctionsError :: Name -> Q a
noFunctionsError conName :: 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 "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 "‘ must not contain function types"
(String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ ""
etaReductionError :: Type -> Q a
etaReductionError :: Kind -> Q a
etaReductionError instanceType :: 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
$
"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
datatypeContextError :: Name -> Type -> Q a
datatypeContextError :: Name -> Kind -> Q a
datatypeContextError dataName :: Name
dataName instanceType :: 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 "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 "‘:\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 "‘ 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
$ ""
existentialContextError :: Name -> Q a
existentialContextError :: Name -> Q a
existentialContextError conName :: 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 "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 "‘ 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
$ ""
outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError :: a -> Name -> Q b
outOfPlaceTyVarError cRep :: a
cRep conName :: 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 "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 "‘ 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 " 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 " argument(s) of a data type"
(String -> Q b) -> String -> Q b
forall a b. (a -> b) -> a -> b
$ ""
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 nb :: 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
, "\tor a product type (precisely one constructor)"
]
enumerationErrorStr :: String -> String
enumerationErrorStr :: ShowS
enumerationErrorStr nb :: String
nb =
'\''Char -> ShowS
forall a. a -> [a] -> [a]
:String
nb String -> ShowS
forall a. [a] -> [a] -> [a]
++ "’ must be an enumeration type"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (one or more nullary, non-GADT constructors)"
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 (a1 :: a
a1:a1s :: [a]
a1s) (a2 :: a
a2:a2s :: [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 _ _ = []
#if MIN_VERSION_ghc_prim(0,3,1)
isTrue# :: Int# -> Bool
isTrue# :: Int# -> Bool
isTrue# x :: Int#
x = Int# -> Bool
forall a. Int# -> a
tagToEnum# Int#
x
#else
isTrue# :: Bool -> Bool
isTrue# x = x
#endif
{-# INLINE isTrue# #-}
isRight :: Either l r -> Bool
isRight :: Either l r -> Bool
isRight Right{} = Bool
True; isRight _ = Bool
False
fromEither :: Either a a -> a
fromEither :: Either a a -> a
fromEither = (a -> a) -> (a -> a) -> Either a a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall a. a -> a
id a -> a
forall a. a -> a
id
filterByList :: [Bool] -> [a] -> [a]
filterByList :: [Bool] -> [a] -> [a]
filterByList (True:bs :: [Bool]
bs) (x :: a
x:xs :: [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 (False:bs :: [Bool]
bs) (_:xs :: [a]
xs) = [Bool] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList _ _ = []
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists (True:bs :: [Bool]
bs) (x :: a
x:xs :: [a]
xs) (_:ys :: [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 (False:bs :: [Bool]
bs) (_:xs :: [a]
xs) (y :: a
y:ys :: [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 _ _ _ = []
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 trues :: [a]
trues falses :: [a]
falses (True : bs :: [Bool]
bs) (x :: a
x : xs :: [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 trues :: [a]
trues falses :: [a]
falses (False : bs :: [Bool]
bs) (x :: a
x : xs :: [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 trues :: [a]
trues falses :: [a]
falses _ _ = ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
trues, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
falses)
appEitherE :: Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
appEitherE :: Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
appEitherE e1Q :: Q (Either Exp Exp)
e1Q e2Q :: Q Exp
e2Q = do
Exp
e2 <- Q Exp
e2Q
let e2' :: Exp -> Exp
e2' :: Exp -> Exp
e2' = (Exp -> Exp -> Exp
`AppE` Exp
e2)
(Exp -> Either Exp Exp)
-> (Exp -> Either Exp Exp) -> Either Exp Exp -> Either Exp Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Exp -> Either Exp Exp
forall a b. a -> Either a b
Left (Exp -> Either Exp Exp) -> (Exp -> Exp) -> Exp -> Either Exp Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
e2') (Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Exp -> Either Exp Exp) -> (Exp -> Exp) -> Exp -> Either Exp Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
e2') (Either Exp Exp -> Either Exp Exp)
-> Q (Either Exp Exp) -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Q (Either Exp Exp)
e1Q
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
hasKindStar :: Type -> Bool
hasKindStar :: Kind -> Bool
hasKindStar VarT{} = Bool
True
#if MIN_VERSION_template_haskell(2,8,0)
hasKindStar (SigT _ StarT) = Bool
True
#else
hasKindStar (SigT _ StarK) = True
#endif
hasKindStar _ = Bool
False
isStarOrVar :: Kind -> Bool
#if MIN_VERSION_template_haskell(2,8,0)
isStarOrVar :: Kind -> Bool
isStarOrVar StarT = Bool
True
isStarOrVar VarT{} = Bool
True
#else
isStarOrVar StarK = True
#endif
isStarOrVar _ = Bool
False
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain :: Int -> Kind -> Maybe [Name]
hasKindVarChain kindArrows :: Int
kindArrows t :: 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
- 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
tyKind :: Type -> Kind
tyKind :: Kind -> Kind
tyKind (SigT _ k :: Kind
k) = Kind
k
tyKind _ = 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 f :: a -> b -> m (c, d)
f (x :: a
x:xs :: [a]
xs) (y :: b
y:ys :: [b]
ys) = do
(c :: c
c, d :: d
d) <- a -> b -> m (c, d)
f a
x b
y
(cs :: [c]
cs, ds :: [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 _ _ _ = ([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 f :: a -> b -> c -> m (d, e)
f (x :: a
x:xs :: [a]
xs) (y :: b
y:ys :: [b]
ys) (z :: c
z:zs :: [c]
zs) = do
(d :: d
d, e :: e
e) <- a -> b -> c -> m (d, e)
f a
x b
y c
z
(ds :: [d]
ds, es :: [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 _ _ _ _ = ([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 (_, _, c :: c
c) = c
c
unsnoc :: [a] -> Maybe ([a], a)
unsnoc :: [a] -> Maybe ([a], a)
unsnoc [] = Maybe ([a], a)
forall a. Maybe a
Nothing
unsnoc (x :: a
x:xs :: [a]
xs) = case [a] -> Maybe ([a], a)
forall a. [a] -> Maybe ([a], a)
unsnoc [a]
xs of
Nothing -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([], a
x)
Just (a :: [a]
a,b :: 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
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
isProductType :: [ConstructorInfo] -> Bool
isProductType :: [ConstructorInfo] -> Bool
isProductType [con :: ConstructorInfo
con] = [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ConstructorInfo -> [TyVarBndr]
constructorVars ConstructorInfo
con)
isProductType _ = Bool
False
isEnumerationType :: [ConstructorInfo] -> Bool
isEnumerationType :: [ConstructorInfo] -> Bool
isEnumerationType cons :: [ConstructorInfo]
cons@(_:_) = (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 _ = Bool
False
isVanillaCon :: ConstructorInfo -> Bool
isVanillaCon :: ConstructorInfo -> Bool
isVanillaCon (ConstructorInfo { constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt, constructorVars :: ConstructorInfo -> [TyVarBndr]
constructorVars = [TyVarBndr]
vars }) =
Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
ctxt Bool -> Bool -> Bool
&& [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr]
vars
newNameList :: String -> Int -> Q [Name]
newNameList :: String -> Int -> Q [Name]
newNameList prefix :: String
prefix n :: 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) [1..Int
n]
tvbKind :: TyVarBndr -> Kind
tvbKind :: TyVarBndr -> Kind
tvbKind (PlainTV _) = Kind
starK
tvbKind (KindedTV _ k :: Kind
k) = Kind
k
tvbToType :: TyVarBndr -> Type
tvbToType :: TyVarBndr -> Kind
tvbToType (PlainTV n :: Name
n) = Name -> Kind
VarT Name
n
tvbToType (KindedTV n :: Name
n k :: Kind
k) = Kind -> Kind -> Kind
SigT (Name -> Kind
VarT Name
n) Kind
k
applyClass :: Name -> Name -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
applyClass :: Name -> Name -> Kind
applyClass con :: Name
con t :: 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 k :: Kind
k !Int
0 = Kind
k
#if MIN_VERSION_template_haskell(2,8,0)
go k :: 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
- 1)
#else
go k !n = go (ArrowK StarK k) (n - 1)
#endif
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce :: Cxt -> Cxt -> Bool
canEtaReduce remaining :: Cxt
remaining dropped :: 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
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
conTToName :: Type -> Name
conTToName :: Kind -> Name
conTToName (ConT n :: Name
n) = Name
n
conTToName (SigT t :: Kind
t _) = Kind -> Name
conTToName Kind
t
conTToName _ = String -> Name
forall a. HasCallStack => String -> a
error "Not a type constructor!"
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe :: Kind -> Maybe Name
varTToName_maybe (VarT n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT t :: Kind
t _) = Kind -> Maybe Name
varTToName_maybe Kind
t
varTToName_maybe _ = Maybe Name
forall a. Maybe a
Nothing
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 "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
unSigT :: Type -> Type
unSigT :: Kind -> Kind
unSigT (SigT t :: Kind
t _) = Kind
t
unSigT t :: Kind
t = Kind
t
isTyVar :: Type -> Bool
isTyVar :: Kind -> Bool
isTyVar (VarT _) = Bool
True
isTyVar (SigT t :: Kind
t _) = Kind -> Bool
isTyVar Kind
t
isTyVar _ = Bool
False
isTyFamily :: Type -> Q Bool
isTyFamily :: Kind -> Q Bool
isTyFamily (ConT n :: Name
n) = do
Info
info <- Name -> Q Info
reify Name
n
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
$ case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI OpenTypeFamilyD{} _ -> Bool
True
#elif MIN_VERSION_template_haskell(2,7,0)
FamilyI (FamilyD TypeFam _ _ _) _ -> True
#else
TyConI (FamilyD TypeFam _ _ _) -> True
#endif
#if MIN_VERSION_template_haskell(2,9,0)
FamilyI ClosedTypeFamilyD{} _ -> Bool
True
#endif
_ -> Bool
False
isTyFamily _ = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
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' uniqs :: Set a
uniqs (x :: a
x:xs :: [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' _ _ = Bool
True
mentionsName :: Type -> [Name] -> Bool
mentionsName :: Kind -> [Name] -> Bool
mentionsName = Kind -> [Name] -> Bool
go
where
go :: Type -> [Name] -> Bool
go :: Kind -> [Name] -> Bool
go (AppT t1 :: Kind
t1 t2 :: Kind
t2) names :: [Name]
names = Kind -> [Name] -> Bool
go Kind
t1 [Name]
names Bool -> Bool -> Bool
|| Kind -> [Name] -> Bool
go Kind
t2 [Name]
names
go (SigT t :: Kind
t _k :: Kind
_k) names :: [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 n :: Name
n) names :: [Name]
names = Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
go _ _ = Bool
False
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
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
foldl' Kind -> Kind -> Kind
AppT
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
unapplyTy :: Type -> [Type]
unapplyTy :: Kind -> Cxt
unapplyTy = Cxt -> Cxt
forall a. [a] -> [a]
reverse (Cxt -> Cxt) -> (Kind -> Cxt) -> Kind -> Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Cxt
go
where
go :: Type -> [Type]
go :: Kind -> Cxt
go (AppT t1 :: Kind
t1 t2 :: Kind
t2) = Kind
t2Kind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:Kind -> Cxt
go Kind
t1
go (SigT t :: Kind
t _) = Kind -> Cxt
go Kind
t
go (ForallT _ _ t :: Kind
t) = Kind -> Cxt
go Kind
t
go t :: Kind
t = [Kind
t]
uncurryTy :: Type -> (Cxt, [Type])
uncurryTy :: Kind -> (Cxt, Cxt)
uncurryTy (AppT (AppT ArrowT t1 :: Kind
t1) t2 :: Kind
t2) =
let (ctxt :: Cxt
ctxt, tys :: Cxt
tys) = Kind -> (Cxt, Cxt)
uncurryTy Kind
t2
in (Cxt
ctxt, Kind
t1Kind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:Cxt
tys)
uncurryTy (SigT t :: Kind
t _) = Kind -> (Cxt, Cxt)
uncurryTy Kind
t
uncurryTy (ForallT _ ctxt :: Cxt
ctxt t :: Kind
t) =
let (ctxt' :: Cxt
ctxt', tys :: Cxt
tys) = Kind -> (Cxt, Cxt)
uncurryTy Kind
t
in (Cxt
ctxt Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
ctxt', Cxt
tys)
uncurryTy t :: Kind
t = ([], [Kind
t])
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 [] e :: Q Exp
e = Q Exp
e
untagExpr ((untagThis :: Name
untagThis, putTagHere :: Name
putTagHere) : more :: [(Name, Name)]
more) e :: 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 ty :: Kind
ty = do
Name
iHash <- String -> Q Name
newName "i#"
Kind
ty' <- Kind -> Q Kind
freshenType Kind
ty
let tvbs :: [TyVarBndr]
tvbs = [TyVarBndr] -> [TyVarBndr]
avoidTypeInType ([TyVarBndr] -> [TyVarBndr]) -> [TyVarBndr] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ Cxt -> [TyVarBndr]
freeVariablesWellScoped [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 ([TyVarBndr] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr]
tvbs [] Kind
ty')
where
avoidTypeInType :: [TyVarBndr] -> [TyVarBndr]
#if __GLASGOW_HASKELL__ >= 806
avoidTypeInType :: [TyVarBndr] -> [TyVarBndr]
avoidTypeInType = [TyVarBndr] -> [TyVarBndr]
forall a. a -> a
id
#else
avoidTypeInType = go . map attachFreeKindVars
where
attachFreeKindVars :: TyVarBndr -> (TyVarBndr, [Name])
attachFreeKindVars tvb = (tvb, freeVariables (tvKind tvb))
go :: [(TyVarBndr, [Name])] -> [TyVarBndr]
go [] = []
go ((tvb, _):tvbsAndFVs)
| any (\(_, kindVars) -> tvName tvb `elem` kindVars) tvbsAndFVs
= tvbs'
| otherwise
= tvb:tvbs'
where
tvbs' = go tvbsAndFVs
#endif
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
]
removeClassApp :: Type -> Type
removeClassApp :: Kind -> Kind
removeClassApp (AppT _ t2 :: Kind
t2) = Kind
t2
removeClassApp t :: Kind
t = Kind
t
freshen :: Name -> Q Name
freshen :: Name -> Q Name
freshen n :: Name
n = String -> Q Name
newName (Name -> String
nameBase Name
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ "_'")
freshenType :: Type -> Q Type
freshenType :: Kind -> Q Kind
freshenType t :: 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)
requiredTyVarsOfType :: Type -> [TyVarBndr]
requiredTyVarsOfType :: Kind -> [TyVarBndr]
requiredTyVarsOfType = Kind -> [TyVarBndr]
go
where
go :: Type -> [TyVarBndr]
go :: Kind -> [TyVarBndr]
go (AppT t1 :: Kind
t1 t2 :: Kind
t2) = Kind -> [TyVarBndr]
go Kind
t1 [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ Kind -> [TyVarBndr]
go Kind
t2
go (SigT t :: Kind
t _) = Kind -> [TyVarBndr]
go Kind
t
go (VarT n :: Name
n) = [Name -> TyVarBndr
PlainTV Name
n]
go _ = []
enumFromToExpr :: Q Exp -> Q Exp -> Q Exp
enumFromToExpr :: Q Exp -> Q Exp -> Q Exp
enumFromToExpr f :: Q Exp
f t :: 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 e1 :: Q Exp
e1 op :: Name
op e2 :: 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
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
isNonUnitTupleString :: String -> Bool
isNonUnitTupleString :: String -> Bool
isNonUnitTupleString ('(':',':_) = Bool
True
isNonUnitTupleString _ = Bool
False
isInfixDataCon :: String -> Bool
isInfixDataCon :: String -> Bool
isInfixDataCon (':':_) = Bool
True
isInfixDataCon _ = Bool
False
isSym :: String -> Bool
isSym :: String -> Bool
isSym "" = Bool
False
isSym (c :: Char
c : _) = 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)
startsConSym c = c == ':'
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
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 = "GHC.Ix"
#else
gHC_IX :: String
gHC_IX = "GHC.Arr"
#endif
mkDerivingCompatName_v :: String -> Name
mkDerivingCompatName_v :: String -> Name
mkDerivingCompatName_v = String -> String -> String -> Name
mkNameG_v String
derivingCompatPackageKey "Data.Deriving.Internal"
mkDerivingCompatName_tc :: String -> Name
mkDerivingCompatName_tc :: String -> Name
mkDerivingCompatName_tc = String -> String -> String -> Name
mkNameG_tc String
derivingCompatPackageKey "Data.Deriving.Internal"
isTrueHashValName :: Name
isTrueHashValName :: Name
isTrueHashValName = String -> Name
mkDerivingCompatName_v "isTrue#"
fmapConstValName :: Name
fmapConstValName :: Name
fmapConstValName = String -> Name
mkDerivingCompatName_v "fmapConst"
foldrConstValName :: Name
foldrConstValName :: Name
foldrConstValName = String -> Name
mkDerivingCompatName_v "foldrConst"
foldMapConstValName :: Name
foldMapConstValName :: Name
foldMapConstValName = String -> Name
mkDerivingCompatName_v "foldMapConst"
traverseConstValName :: Name
traverseConstValName :: Name
traverseConstValName = String -> Name
mkDerivingCompatName_v "traverseConst"
eqConstValName :: Name
eqConstValName :: Name
eqConstValName = String -> Name
mkDerivingCompatName_v "eqConst"
eq1ConstValName :: Name
eq1ConstValName :: Name
eq1ConstValName = String -> Name
mkDerivingCompatName_v "eq1Const"
liftEqConstValName :: Name
liftEqConstValName :: Name
liftEqConstValName = String -> Name
mkDerivingCompatName_v "liftEqConst"
liftEq2ConstValName :: Name
liftEq2ConstValName :: Name
liftEq2ConstValName = String -> Name
mkDerivingCompatName_v "liftEq2Const"
compareConstValName :: Name
compareConstValName :: Name
compareConstValName = String -> Name
mkDerivingCompatName_v "compareConst"
ltConstValName :: Name
ltConstValName :: Name
ltConstValName = String -> Name
mkDerivingCompatName_v "ltConst"
compare1ConstValName :: Name
compare1ConstValName :: Name
compare1ConstValName = String -> Name
mkDerivingCompatName_v "compare1Const"
liftCompareConstValName :: Name
liftCompareConstValName :: Name
liftCompareConstValName = String -> Name
mkDerivingCompatName_v "liftCompareConst"
liftCompare2ConstValName :: Name
liftCompare2ConstValName :: Name
liftCompare2ConstValName = String -> Name
mkDerivingCompatName_v "liftCompare2Const"
readsPrecConstValName :: Name
readsPrecConstValName :: Name
readsPrecConstValName = String -> Name
mkDerivingCompatName_v "readsPrecConst"
readPrecConstValName :: Name
readPrecConstValName :: Name
readPrecConstValName = String -> Name
mkDerivingCompatName_v "readPrecConst"
readsPrec1ConstValName :: Name
readsPrec1ConstValName :: Name
readsPrec1ConstValName = String -> Name
mkDerivingCompatName_v "readsPrec1Const"
liftReadsPrecConstValName :: Name
liftReadsPrecConstValName :: Name
liftReadsPrecConstValName = String -> Name
mkDerivingCompatName_v "liftReadsPrecConst"
liftReadPrecConstValName :: Name
liftReadPrecConstValName :: Name
liftReadPrecConstValName = String -> Name
mkDerivingCompatName_v "liftReadPrecConst"
liftReadsPrec2ConstValName :: Name
liftReadsPrec2ConstValName :: Name
liftReadsPrec2ConstValName = String -> Name
mkDerivingCompatName_v "liftReadsPrec2Const"
liftReadPrec2ConstValName :: Name
liftReadPrec2ConstValName :: Name
liftReadPrec2ConstValName = String -> Name
mkDerivingCompatName_v "liftReadPrec2Const"
showsPrecConstValName :: Name
showsPrecConstValName :: Name
showsPrecConstValName = String -> Name
mkDerivingCompatName_v "showsPrecConst"
showsPrec1ConstValName :: Name
showsPrec1ConstValName :: Name
showsPrec1ConstValName = String -> Name
mkDerivingCompatName_v "showsPrec1Const"
liftShowsPrecConstValName :: Name
liftShowsPrecConstValName :: Name
liftShowsPrecConstValName = String -> Name
mkDerivingCompatName_v "liftShowsPrecConst"
liftShowsPrec2ConstValName :: Name
liftShowsPrec2ConstValName :: Name
liftShowsPrec2ConstValName = String -> Name
mkDerivingCompatName_v "liftShowsPrec2Const"
viaTypeName :: Name
viaTypeName :: Name
viaTypeName = String -> Name
mkDerivingCompatName_tc "Via"
cHashDataName :: Name
cHashDataName :: Name
cHashDataName = String -> String -> String -> Name
mkNameG_d "ghc-prim" "GHC.Types" "C#"
dHashDataName :: Name
dHashDataName :: Name
dHashDataName = String -> String -> String -> Name
mkNameG_d "ghc-prim" "GHC.Types" "D#"
fHashDataName :: Name
fHashDataName :: Name
fHashDataName = String -> String -> String -> Name
mkNameG_d "ghc-prim" "GHC.Types" "F#"
identDataName :: Name
identDataName :: Name
identDataName = String -> String -> String -> Name
mkNameG_d "base" "Text.Read.Lex" "Ident"
iHashDataName :: Name
iHashDataName :: Name
iHashDataName = String -> String -> String -> Name
mkNameG_d "ghc-prim" "GHC.Types" "I#"
puncDataName :: Name
puncDataName :: Name
puncDataName = String -> String -> String -> Name
mkNameG_d "base" "Text.Read.Lex" "Punc"
symbolDataName :: Name
symbolDataName :: Name
symbolDataName = String -> String -> String -> Name
mkNameG_d "base" "Text.Read.Lex" "Symbol"
wrapMonadDataName :: Name
wrapMonadDataName :: Name
wrapMonadDataName = String -> String -> String -> Name
mkNameG_d "base" "Control.Applicative" "WrapMonad"
addrHashTypeName :: Name
addrHashTypeName :: Name
addrHashTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#"
boundedTypeName :: Name
boundedTypeName :: Name
boundedTypeName = String -> String -> String -> Name
mkNameG_tc "base" "GHC.Enum" "Bounded"
charHashTypeName :: Name
charHashTypeName :: Name
charHashTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Prim" "Char#"
doubleHashTypeName :: Name
doubleHashTypeName :: Name
doubleHashTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Prim" "Double#"
enumTypeName :: Name
enumTypeName :: Name
enumTypeName = String -> String -> String -> Name
mkNameG_tc "base" "GHC.Enum" "Enum"
floatHashTypeName :: Name
floatHashTypeName :: Name
floatHashTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Prim" "Float#"
foldableTypeName :: Name
foldableTypeName :: Name
foldableTypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Foldable" "Foldable"
functorTypeName :: Name
functorTypeName :: Name
functorTypeName = String -> String -> String -> Name
mkNameG_tc "base" "GHC.Base" "Functor"
intTypeName :: Name
intTypeName :: Name
intTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Types" "Int"
intHashTypeName :: Name
intHashTypeName :: Name
intHashTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Prim" "Int#"
ixTypeName :: Name
ixTypeName :: Name
ixTypeName = String -> String -> String -> Name
mkNameG_tc "base" String
gHC_IX "Ix"
readTypeName :: Name
readTypeName :: Name
readTypeName = String -> String -> String -> Name
mkNameG_tc "base" "GHC.Read" "Read"
showTypeName :: Name
showTypeName :: Name
showTypeName = String -> String -> String -> Name
mkNameG_tc "base" "GHC.Show" "Show"
traversableTypeName :: Name
traversableTypeName :: Name
traversableTypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Traversable" "Traversable"
wordHashTypeName :: Name
wordHashTypeName :: Name
wordHashTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Prim" "Word#"
altValName :: Name
altValName :: Name
altValName = String -> String -> String -> Name
mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "+++"
appendValName :: Name
appendValName :: Name
appendValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "++"
chooseValName :: Name
chooseValName :: Name
chooseValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "choose"
coerceValName :: Name
coerceValName :: Name
coerceValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "coerce"
composeValName :: Name
composeValName :: Name
composeValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "."
constValName :: Name
constValName :: Name
constValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "const"
enumFromValName :: Name
enumFromValName :: Name
enumFromValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Enum" "enumFrom"
enumFromThenValName :: Name
enumFromThenValName :: Name
enumFromThenValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Enum" "enumFromThen"
enumFromThenToValName :: Name
enumFromThenToValName :: Name
enumFromThenToValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Enum" "enumFromThenTo"
enumFromToValName :: Name
enumFromToValName :: Name
enumFromToValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Enum" "enumFromTo"
eqAddrHashValName :: Name
eqAddrHashValName :: Name
eqAddrHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "eqAddr#"
eqCharHashValName :: Name
eqCharHashValName :: Name
eqCharHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "eqChar#"
eqDoubleHashValName :: Name
eqDoubleHashValName :: Name
eqDoubleHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "==##"
eqFloatHashValName :: Name
eqFloatHashValName :: Name
eqFloatHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "eqFloat#"
eqIntHashValName :: Name
eqIntHashValName :: Name
eqIntHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "==#"
eqWordHashValName :: Name
eqWordHashValName :: Name
eqWordHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "eqWord#"
errorValName :: Name
errorValName :: Name
errorValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Err" "error"
flipValName :: Name
flipValName :: Name
flipValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "flip"
fmapValName :: Name
fmapValName :: Name
fmapValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "fmap"
foldrValName :: Name
foldrValName :: Name
foldrValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Foldable" "foldr"
foldMapValName :: Name
foldMapValName :: Name
foldMapValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Foldable" "foldMap"
fromEnumValName :: Name
= String -> String -> String -> Name
mkNameG_v "base" "GHC.Enum" "fromEnum"
geAddrHashValName :: Name
geAddrHashValName :: Name
geAddrHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "geAddr#"
geCharHashValName :: Name
geCharHashValName :: Name
geCharHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "geChar#"
geDoubleHashValName :: Name
geDoubleHashValName :: Name
geDoubleHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" ">=##"
geFloatHashValName :: Name
geFloatHashValName :: Name
geFloatHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "geFloat#"
geIntHashValName :: Name
geIntHashValName :: Name
geIntHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" ">=#"
getTagValName :: Name
getTagValName :: Name
getTagValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "getTag"
geWordHashValName :: Name
geWordHashValName :: Name
geWordHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "geWord#"
gtAddrHashValName :: Name
gtAddrHashValName :: Name
gtAddrHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "gtAddr#"
gtCharHashValName :: Name
gtCharHashValName :: Name
gtCharHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "gtChar#"
gtDoubleHashValName :: Name
gtDoubleHashValName :: Name
gtDoubleHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" ">##"
gtFloatHashValName :: Name
gtFloatHashValName :: Name
gtFloatHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "gtFloat#"
gtIntHashValName :: Name
gtIntHashValName :: Name
gtIntHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" ">#"
gtWordHashValName :: Name
gtWordHashValName :: Name
gtWordHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "gtWord#"
idValName :: Name
idValName :: Name
idValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "id"
indexValName :: Name
indexValName :: Name
indexValName = String -> String -> String -> Name
mkNameG_v "base" String
gHC_IX "index"
inRangeValName :: Name
inRangeValName :: Name
inRangeValName = String -> String -> String -> Name
mkNameG_v "base" String
gHC_IX "inRange"
leAddrHashValName :: Name
leAddrHashValName :: Name
leAddrHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "leAddr#"
leCharHashValName :: Name
leCharHashValName :: Name
leCharHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "leChar#"
leDoubleHashValName :: Name
leDoubleHashValName :: Name
leDoubleHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "<=##"
leFloatHashValName :: Name
leFloatHashValName :: Name
leFloatHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "leFloat#"
leIntHashValName :: Name
leIntHashValName :: Name
leIntHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "<=#"
leWordHashValName :: Name
leWordHashValName :: Name
leWordHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "leWord#"
liftReadListPrecDefaultValName :: Name
liftReadListPrecDefaultValName :: Name
liftReadListPrecDefaultValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrecDefault"
liftReadListPrec2DefaultValName :: Name
liftReadListPrec2DefaultValName :: Name
liftReadListPrec2DefaultValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2Default"
liftReadListPrecValName :: Name
liftReadListPrecValName :: Name
liftReadListPrecValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec"
liftReadListPrec2ValName :: Name
liftReadListPrec2ValName :: Name
liftReadListPrec2ValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2"
liftReadPrecValName :: Name
liftReadPrecValName :: Name
liftReadPrecValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec"
liftReadPrec2ValName :: Name
liftReadPrec2ValName :: Name
liftReadPrec2ValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec2"
listValName :: Name
listValName :: Name
listValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "list"
ltAddrHashValName :: Name
ltAddrHashValName :: Name
ltAddrHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "ltAddr#"
ltCharHashValName :: Name
ltCharHashValName :: Name
ltCharHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "ltChar#"
ltDoubleHashValName :: Name
ltDoubleHashValName :: Name
ltDoubleHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "<##"
ltFloatHashValName :: Name
ltFloatHashValName :: Name
ltFloatHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "ltFloat#"
ltIntHashValName :: Name
ltIntHashValName :: Name
ltIntHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "<#"
ltWordHashValName :: Name
ltWordHashValName :: Name
ltWordHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "ltWord#"
minBoundValName :: Name
minBoundValName :: Name
minBoundValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Enum" "minBound"
mapValName :: Name
mapValName :: Name
mapValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "map"
maxBoundValName :: Name
maxBoundValName :: Name
maxBoundValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Enum" "maxBound"
minusIntHashValName :: Name
minusIntHashValName :: Name
minusIntHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "-#"
parenValName :: Name
parenValName :: Name
parenValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "paren"
parensValName :: Name
parensValName :: Name
parensValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "parens"
pfailValName :: Name
pfailValName :: Name
pfailValName = String -> String -> String -> Name
mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "pfail"
plusValName :: Name
plusValName :: Name
plusValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Num" "+"
precValName :: Name
precValName :: Name
precValName = String -> String -> String -> Name
mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "prec"
predValName :: Name
predValName :: Name
predValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Enum" "pred"
rangeSizeValName :: Name
rangeSizeValName :: Name
rangeSizeValName = String -> String -> String -> Name
mkNameG_v "base" String
gHC_IX "rangeSize"
rangeValName :: Name
rangeValName :: Name
rangeValName = String -> String -> String -> Name
mkNameG_v "base" String
gHC_IX "range"
readFieldHash :: String -> ReadPrec a -> ReadPrec a
readFieldHash :: String -> ReadPrec a -> ReadPrec a
readFieldHash fieldName :: String
fieldName readVal :: ReadPrec a
readVal = do
Lexeme -> ReadPrec ()
expectP (String -> Lexeme
L.Ident String
fieldName)
Lexeme -> ReadPrec ()
expectP (String -> Lexeme
L.Symbol "#")
Lexeme -> ReadPrec ()
expectP (String -> Lexeme
L.Punc "=")
ReadPrec a
readVal
{-# NOINLINE readFieldHash #-}
readFieldHashValName :: Name
readFieldHashValName :: Name
readFieldHashValName = String -> String -> String -> Name
mkNameG_v String
derivingCompatPackageKey "Data.Deriving.Internal" "readFieldHash"
readListValName :: Name
readListValName :: Name
readListValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "readList"
readListPrecDefaultValName :: Name
readListPrecDefaultValName :: Name
readListPrecDefaultValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "readListPrecDefault"
readListPrecValName :: Name
readListPrecValName :: Name
readListPrecValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "readListPrec"
readPrec_to_SValName :: Name
readPrec_to_SValName :: Name
readPrec_to_SValName = String -> String -> String -> Name
mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readPrec_to_S"
readPrecValName :: Name
readPrecValName :: Name
readPrecValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "readPrec"
readS_to_PrecValName :: Name
readS_to_PrecValName :: Name
readS_to_PrecValName = String -> String -> String -> Name
mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readS_to_Prec"
readsPrecValName :: Name
readsPrecValName :: Name
readsPrecValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "readsPrec"
resetValName :: Name
resetValName :: Name
resetValName = String -> String -> String -> Name
mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "reset"
returnValName :: Name
returnValName :: Name
returnValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "return"
seqValName :: Name
seqValName :: Name
seqValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "seq"
showCharValName :: Name
showCharValName :: Name
showCharValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Show" "showChar"
showListValName :: Name
showListValName :: Name
showListValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Show" "showList"
showListWithValName :: Name
showListWithValName :: Name
showListWithValName = String -> String -> String -> Name
mkNameG_v "base" "Text.Show" "showListWith"
showParenValName :: Name
showParenValName :: Name
showParenValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Show" "showParen"
showsPrecValName :: Name
showsPrecValName :: Name
showsPrecValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Show" "showsPrec"
showSpaceValName :: Name
showSpaceValName :: Name
showSpaceValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Show" "showSpace"
showStringValName :: Name
showStringValName :: Name
showStringValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Show" "showString"
stepValName :: Name
stepValName :: Name
stepValName = String -> String -> String -> Name
mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "step"
succValName :: Name
succValName :: Name
succValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Enum" "succ"
tagToEnumHashValName :: Name
tagToEnumHashValName :: Name
tagToEnumHashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "tagToEnum#"
timesValName :: Name
timesValName :: Name
timesValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Num" "*"
toEnumValName :: Name
toEnumValName :: Name
toEnumValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Enum" "toEnum"
traverseValName :: Name
traverseValName :: Name
traverseValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Traversable" "traverse"
unsafeIndexValName :: Name
unsafeIndexValName :: Name
unsafeIndexValName = String -> String -> String -> Name
mkNameG_v "base" String
gHC_IX "unsafeIndex"
unsafeRangeSizeValName :: Name
unsafeRangeSizeValName :: Name
unsafeRangeSizeValName = String -> String -> String -> Name
mkNameG_v "base" String
gHC_IX "unsafeRangeSize"
unwrapMonadValName :: Name
unwrapMonadValName :: Name
unwrapMonadValName = String -> String -> String -> Name
mkNameG_v "base" "Control.Applicative" "unwrapMonad"
#if MIN_VERSION_base(4,4,0)
boolTypeName :: Name
boolTypeName :: Name
boolTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Types" "Bool"
falseDataName :: Name
falseDataName :: Name
falseDataName = String -> String -> String -> Name
mkNameG_d "ghc-prim" "GHC.Types" "False"
trueDataName :: Name
trueDataName :: Name
trueDataName = String -> String -> String -> Name
mkNameG_d "ghc-prim" "GHC.Types" "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 "ghc-prim" "GHC.Types" "EQ"
gtDataName :: Name
gtDataName :: Name
gtDataName = String -> String -> String -> Name
mkNameG_d "ghc-prim" "GHC.Types" "GT"
ltDataName :: Name
ltDataName :: Name
ltDataName = String -> String -> String -> Name
mkNameG_d "ghc-prim" "GHC.Types" "LT"
eqTypeName :: Name
eqTypeName :: Name
eqTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Classes" "Eq"
ordTypeName :: Name
ordTypeName :: Name
ordTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Classes" "Ord"
andValName :: Name
andValName :: Name
andValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Classes" "&&"
compareValName :: Name
compareValName :: Name
compareValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Classes" "compare"
eqValName :: Name
eqValName :: Name
eqValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Classes" "=="
geValName :: Name
geValName :: Name
geValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Classes" ">="
gtValName :: Name
gtValName :: Name
gtValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Classes" ">"
leValName :: Name
leValName :: Name
leValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Classes" "<="
ltValName :: Name
ltValName :: Name
ltValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Classes" "<"
notValName :: Name
notValName :: Name
notValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Classes" "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 "ghc-prim" "GHC.Types" "W#"
#else
wHashDataName :: Name
wHashDataName = mkNameG_d "base" "GHC.Word" "W#"
#endif
#if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0))
starKindName :: Name
starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"
#endif
#if MIN_VERSION_base(4,7,0)
expectPValName :: Name
expectPValName :: Name
expectPValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "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)
pureValName :: Name
pureValName :: Name
pureValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "pure"
apValName :: Name
apValName :: Name
apValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "<*>"
liftA2ValName :: Name
liftA2ValName :: Name
liftA2ValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "liftA2"
mappendValName :: Name
mappendValName :: Name
mappendValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "mappend"
memptyValName :: Name
memptyValName :: Name
memptyValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "mempty"
#else
pureValName :: Name
pureValName = mkNameG_v "base" "Control.Applicative" "pure"
apValName :: Name
apValName = mkNameG_v "base" "Control.Applicative" "<*>"
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"
#endif
#if MIN_VERSION_base(4,9,0)
eq1TypeName :: Name
eq1TypeName :: Name
eq1TypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Functor.Classes" "Eq1"
eq2TypeName :: Name
eq2TypeName :: Name
eq2TypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Functor.Classes" "Eq2"
liftEqValName :: Name
liftEqValName :: Name
liftEqValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftEq"
liftEq2ValName :: Name
liftEq2ValName :: Name
liftEq2ValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftEq2"
ord1TypeName :: Name
ord1TypeName :: Name
ord1TypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Functor.Classes" "Ord1"
ord2TypeName :: Name
ord2TypeName :: Name
ord2TypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Functor.Classes" "Ord2"
liftCompareValName :: Name
liftCompareValName :: Name
liftCompareValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftCompare"
liftCompare2ValName :: Name
liftCompare2ValName :: Name
liftCompare2ValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftCompare2"
read1TypeName :: Name
read1TypeName :: Name
read1TypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Functor.Classes" "Read1"
read2TypeName :: Name
read2TypeName :: Name
read2TypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Functor.Classes" "Read2"
liftReadsPrecValName :: Name
liftReadsPrecValName :: Name
liftReadsPrecValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec"
liftReadListValName :: Name
liftReadListValName :: Name
liftReadListValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftReadList"
liftReadsPrec2ValName :: Name
liftReadsPrec2ValName :: Name
liftReadsPrec2ValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec2"
liftReadList2ValName :: Name
liftReadList2ValName :: Name
liftReadList2ValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftReadList2"
show1TypeName :: Name
show1TypeName :: Name
show1TypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Functor.Classes" "Show1"
show2TypeName :: Name
show2TypeName :: Name
show2TypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Functor.Classes" "Show2"
liftShowListValName :: Name
liftShowListValName :: Name
liftShowListValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftShowList"
liftShowsPrecValName :: Name
liftShowsPrecValName :: Name
liftShowsPrecValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec"
liftShowList2ValName :: Name
liftShowList2ValName :: Name
liftShowList2ValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftShowList2"
liftShowsPrec2ValName :: Name
liftShowsPrec2ValName :: Name
liftShowsPrec2ValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec2"
#else
# 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 <- isTyFamily tyCon
if any (`mentionsName` [name]) lhsArgs
|| itf && any (`mentionsName` [name]) tyArgs
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 "base" "GHC.Show" "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 "base" "Data.Semigroup.Internal" "appEndo"
dualDataName :: Name
dualDataName :: Name
dualDataName = String -> String -> String -> Name
mkNameG_d "base" "Data.Semigroup.Internal" "Dual"
endoDataName :: Name
endoDataName :: Name
endoDataName = String -> String -> String -> Name
mkNameG_d "base" "Data.Semigroup.Internal" "Endo"
getDualValName :: Name
getDualValName :: Name
getDualValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Semigroup.Internal" "getDual"
readFieldValName :: Name
readFieldValName :: Name
readFieldValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "readField"
readSymFieldValName :: Name
readSymFieldValName :: Name
readSymFieldValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Read" "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 "ghc-prim" "GHC.Prim" "eqInt8#"
eqInt16HashValName :: Name
eqInt16HashValName :: Name
eqInt16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "eqInt16#"
eqWord8HashValName :: Name
eqWord8HashValName :: Name
eqWord8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "eqWord8#"
eqWord16HashValName :: Name
eqWord16HashValName :: Name
eqWord16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "eqWord16#"
extendInt8HashValName :: Name
extendInt8HashValName :: Name
extendInt8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "extendInt8#"
extendInt16HashValName :: Name
extendInt16HashValName :: Name
extendInt16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "extendInt16#"
extendWord8HashValName :: Name
extendWord8HashValName :: Name
extendWord8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "extendWord8#"
extendWord16HashValName :: Name
extendWord16HashValName :: Name
extendWord16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "extendWord16#"
geInt8HashValName :: Name
geInt8HashValName :: Name
geInt8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "geInt8#"
geInt16HashValName :: Name
geInt16HashValName :: Name
geInt16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "geInt16#"
geWord8HashValName :: Name
geWord8HashValName :: Name
geWord8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "geWord8#"
geWord16HashValName :: Name
geWord16HashValName :: Name
geWord16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "geWord16#"
gtInt8HashValName :: Name
gtInt8HashValName :: Name
gtInt8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "gtInt8#"
gtInt16HashValName :: Name
gtInt16HashValName :: Name
gtInt16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "gtInt16#"
gtWord8HashValName :: Name
gtWord8HashValName :: Name
gtWord8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "gtWord8#"
gtWord16HashValName :: Name
gtWord16HashValName :: Name
gtWord16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "gtWord16#"
int8HashTypeName :: Name
int8HashTypeName :: Name
int8HashTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Prim" "Int8#"
int16HashTypeName :: Name
int16HashTypeName :: Name
int16HashTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Prim" "Int16#"
leInt8HashValName :: Name
leInt8HashValName :: Name
leInt8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "leInt8#"
leInt16HashValName :: Name
leInt16HashValName :: Name
leInt16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "leInt16#"
leWord8HashValName :: Name
leWord8HashValName :: Name
leWord8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "leWord8#"
leWord16HashValName :: Name
leWord16HashValName :: Name
leWord16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "leWord16#"
ltInt8HashValName :: Name
ltInt8HashValName :: Name
ltInt8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "ltInt8#"
ltInt16HashValName :: Name
ltInt16HashValName :: Name
ltInt16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "ltInt16#"
ltWord8HashValName :: Name
ltWord8HashValName :: Name
ltWord8HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "ltWord8#"
ltWord16HashValName :: Name
ltWord16HashValName :: Name
ltWord16HashValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "ltWord16#"
word8HashTypeName :: Name
word8HashTypeName :: Name
word8HashTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Prim" "Word8#"
word16HashTypeName :: Name
word16HashTypeName :: Name
word16HashTypeName = String -> String -> String -> Name
mkNameG_tc "ghc-prim" "GHC.Prim" "Word16#"
#endif