{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
module Data.Deriving.Internal where
import qualified Control.Applicative as App
import Control.Monad (when, unless)
import qualified Data.Foldable as F
import Data.Functor.Classes
( Eq1(..), Ord1(..), Read1(..), Show1(..)
#if MIN_VERSION_base(4,10,0)
, liftReadListPrecDefault
#endif
)
#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)
import Data.Functor.Classes
( Eq2(..), Ord2(..), Read2(..), Show2(..)
#if MIN_VERSION_base(4,10,0)
, liftReadListPrec2Default
#endif
)
#endif
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import Data.Monoid (Dual(..), Endo(..))
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Traversable as T
import GHC.Arr (Ix(..))
import GHC.Base (getTag)
import GHC.Exts
import GHC.Read (choose, list, paren)
import GHC.Show (showSpace)
import Text.ParserCombinators.ReadPrec
( ReadPrec, (+++), pfail, prec, readPrec_to_S, readS_to_Prec
, reset, step
)
import Text.Read (Read(..), parens, readListPrecDefault)
import qualified Text.Read.Lex as L
import Text.Show (showListWith)
#if MIN_VERSION_base(4,7,0)
import GHC.Read (expectP)
#else
import GHC.Read (lexP)
import Text.Read.Lex (Lexeme)
#endif
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative (Applicative(..))
import Data.Foldable (Foldable(..))
import Data.Functor (Functor(..))
import Data.Monoid (Monoid(..))
import Data.Traversable (Traversable(..))
#endif
#if MIN_VERSION_base(4,10,0)
import GHC.Show (showCommaSpace)
#endif
#if MIN_VERSION_base(4,11,0)
import GHC.Read (readField, readSymField)
#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 as Datatype
import Language.Haskell.TH.Datatype.TyVarBndr
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 ()
applySubstitutionKind :: Map Name Kind -> Type -> Type
#if MIN_VERSION_template_haskell(2,8,0)
applySubstitutionKind :: Map Name Type -> Type -> Type
applySubstitutionKind = forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution
#else
applySubstitutionKind _ t = t
#endif
substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind :: Name -> Type -> Type -> Type
substNameWithKind Name
n Type
k = Map Name Type -> Type -> Type
applySubstitutionKind (forall k a. k -> a -> Map k a
Map.singleton Name
n Type
k)
substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar [Name]
ns Type
t = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr' (forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Type -> Type -> Type
substNameWithKind Type
starK) Type
t [Name]
ns
data a `Via` b
infix 0 `Via`
fmapConst :: f b -> (a -> b) -> f a -> f b
fmapConst :: forall (f :: * -> *) b a. 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 :: forall (f :: * -> *) a b. 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 :: forall b a (t :: * -> *). 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 :: forall m a (t :: * -> *). m -> (a -> m) -> t a -> m
foldMapConst m
x a -> m
_ t a
_ = m
x
{-# INLINE foldMapConst #-}
nullConst :: Bool -> t a -> Bool
nullConst :: forall (t :: * -> *) a. 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 :: forall (f :: * -> *) (t :: * -> *) b a.
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 :: forall a. Bool -> a -> a -> Bool
eqConst Bool
x a
_ a
_ = Bool
x
{-# INLINE eqConst #-}
eq1Const :: Bool
-> f a -> f a-> Bool
eq1Const :: forall (f :: * -> *) a. 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 :: forall a b (f :: * -> *).
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 :: forall a b c d (f :: * -> * -> *).
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 :: forall a. Ordering -> a -> a -> Ordering
compareConst Ordering
x a
_ a
_ = Ordering
x
{-# INLINE compareConst #-}
ltConst :: Bool -> a -> a -> Bool
ltConst :: forall a. Bool -> a -> a -> Bool
ltConst Bool
x a
_ a
_ = Bool
x
{-# INLINE ltConst #-}
compare1Const :: Ordering -> f a -> f a -> Ordering
compare1Const :: forall (f :: * -> *) a. 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 :: forall a b (f :: * -> *).
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 :: forall a b c d (f :: * -> * -> *).
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 :: forall a. ReadS a -> Int -> ReadS a
readsPrecConst ReadS a
x Int
_ = ReadS a
x
{-# INLINE readsPrecConst #-}
readPrecConst :: ReadPrec a -> ReadPrec a
readPrecConst :: forall a. ReadPrec a -> ReadPrec a
readPrecConst ReadPrec a
x = ReadPrec a
x
{-# INLINE readPrecConst #-}
readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a)
readsPrec1Const :: forall (f :: * -> *) a. 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 :: forall (f :: * -> *) a.
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 :: forall (f :: * -> *) a.
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 :: forall (f :: * -> * -> *) a b.
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 :: forall (f :: * -> * -> *) a b.
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 :: forall a. ShowS -> Int -> a -> ShowS
showsPrecConst ShowS
x Int
_ a
_ = ShowS
x
{-# INLINE showsPrecConst #-}
showsPrec1Const :: ShowS
-> Int -> f a -> ShowS
showsPrec1Const :: forall (f :: * -> *) a. 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 :: forall a (f :: * -> *).
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 :: forall a b (f :: * -> * -> *).
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 #-}
data StarKindStatus = NotKindStar
| KindStar
| IsKindVar Name
deriving StarKindStatus -> StarKindStatus -> Bool
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 :: Type -> StarKindStatus
canRealizeKindStar Type
t
| Type -> Bool
hasKindStar Type
t = StarKindStatus
KindStar
| Bool
otherwise = case Type
t of
#if MIN_VERSION_template_haskell(2,8,0)
SigT Type
_ (VarT Name
k) -> Name -> StarKindStatus
IsKindVar Name
k
#endif
Type
_ -> StarKindStatus
NotKindStar
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar Name
n) = forall a. a -> Maybe a
Just Name
n
starKindStatusToName StarKindStatus
_ = forall a. Maybe a
Nothing
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames = 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 :: forall a.
ClassRep a =>
a
-> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
buildTypeInstance a
cRep Name
tyConName [Type]
dataCxt [Type]
varTysOrig DatatypeVariant
variant = do
[Type]
varTysExp <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM Type -> Q Type
resolveTypeSynonyms [Type]
varTysOrig
let remainingLength :: Int
remainingLength :: Int
remainingLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
varTysOrig forall a. Num a => a -> a -> a
- forall a. ClassRep a => a -> Int
arity a
cRep
droppedTysExp :: [Type]
droppedTysExp :: [Type]
droppedTysExp = forall a. Int -> [a] -> [a]
drop Int
remainingLength [Type]
varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar [Type]
droppedTysExp
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== StarKindStatus
NotKindStar) [StarKindStatus]
droppedStarKindStati) forall a b. (a -> b) -> a -> b
$
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 :: [Type]
varTysExpSubst = forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
droppedKindVarNames) [Type]
varTysExp
remainingTysExpSubst, droppedTysExpSubst :: [Type]
([Type]
remainingTysExpSubst, [Type]
droppedTysExpSubst) =
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysExpSubst
droppedTyVarNames :: [Name]
droppedTyVarNames :: [Name]
droppedTyVarNames = forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
droppedTysExpSubst
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasKindStar [Type]
droppedTysExpSubst) forall a b. (a -> b) -> a -> b
$
forall a b. ClassRep a => a -> Name -> Q b
derivingKindError a
cRep Name
tyConName
let preds :: [Maybe Pred]
kvNames :: [[Name]]
kvNames' :: [Name]
([Maybe Type]
preds, [[Name]]
kvNames) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. ClassRep a => a -> Type -> (Maybe Type, [Name])
deriveConstraint a
cRep) [Type]
remainingTysExpSubst
kvNames' :: [Name]
kvNames' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
kvNames
remainingTysExpSubst' :: [Type]
remainingTysExpSubst' :: [Type]
remainingTysExpSubst' =
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
kvNames') [Type]
remainingTysExpSubst
remainingTysOrigSubst :: [Type]
remainingTysOrigSubst :: [Type]
remainingTysOrigSubst =
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar (forall a. Eq a => [a] -> [a] -> [a]
List.union [Name]
droppedKindVarNames [Name]
kvNames'))
forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
remainingLength [Type]
varTysOrig
Bool
isDataFamily <-
case DatatypeVariant
variant of
DatatypeVariant
Datatype -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
DatatypeVariant
Newtype -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
DatatypeVariant
DataInstance -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
DatatypeVariant
NewtypeInstance -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#if MIN_VERSION_th_abstraction(0,5,0)
DatatypeVariant
Datatype.TypeData -> forall a. Name -> Q a
typeDataError Name
tyConName
#endif
let remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' =
if Bool
isDataFamily
then [Type]
remainingTysOrigSubst
else forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT [Type]
remainingTysOrigSubst
instanceCxt :: Cxt
instanceCxt :: [Type]
instanceCxt = forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
preds
instanceType :: Type
instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT (forall a. ClassRep a => a -> Name
fullClassName a
cRep))
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
applyTyCon Name
tyConName [Type]
remainingTysOrigSubst'
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) [Type]
dataCxt) forall a b. (a -> b) -> a -> b
$
forall a. Name -> Type -> Q a
datatypeContextError Name
tyConName Type
instanceType
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type] -> [Type] -> Bool
canEtaReduce [Type]
remainingTysExpSubst' [Type]
droppedTysExpSubst) forall a b. (a -> b) -> a -> b
$
forall a. Type -> Q a
etaReductionError Type
instanceType
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
instanceCxt, Type
instanceType)
deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name])
deriveConstraint :: forall a. ClassRep a => a -> Type -> (Maybe Type, [Name])
deriveConstraint a
cRep Type
t
| Bool -> Bool
not (Type -> Bool
isTyVar Type
t) = (forall a. Maybe a
Nothing, [])
| Type -> Bool
hasKindStar Type
t = ((Name -> Name -> Type
`applyClass` Name
tName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. ClassRep a => a -> Int -> Maybe Name
classConstraint a
cRep Int
0, [])
| Bool
otherwise = case Int -> Type -> Maybe [Name]
hasKindVarChain Int
1 Type
t of
Just [Name]
ns | Int
cRepArity forall a. Ord a => a -> a -> Bool
>= Int
1
-> ((Name -> Name -> Type
`applyClass` Name
tName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. ClassRep a => a -> Int -> Maybe Name
classConstraint a
cRep Int
1, [Name]
ns)
Maybe [Name]
_ -> case Int -> Type -> Maybe [Name]
hasKindVarChain Int
2 Type
t of
Just [Name]
ns | Int
cRepArity forall a. Eq a => a -> a -> Bool
== Int
2
-> ((Name -> Name -> Type
`applyClass` Name
tName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. ClassRep a => a -> Int -> Maybe Name
classConstraint a
cRep Int
2, [Name]
ns)
Maybe [Name]
_ -> (forall a. Maybe a
Nothing, [])
where
tName :: Name
tName :: Name
tName = Type -> Name
varTToName Type
t
cRepArity :: Int
cRepArity :: Int
cRepArity = forall a. ClassRep a => a -> Int
arity a
cRep
checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name
-> Q c -> Q c
checkExistentialContext :: forall a b c.
ClassRep a =>
a -> TyVarMap b -> [Type] -> Name -> Q c -> Q c
checkExistentialContext a
cRep TyVarMap b
tvMap [Type]
ctxt Name
conName Q c
q =
if (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` forall k a. Map k a -> [k]
Map.keys TyVarMap b
tvMap) [Type]
ctxt
Bool -> Bool -> Bool
|| forall k a. Map k a -> Int
Map.size TyVarMap b
tvMap forall a. Ord a => a -> a -> Bool
< forall a. ClassRep a => a -> Int
arity a
cRep)
Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. ClassRep a => a -> Bool
allowExQuant a
cRep)
then forall a. Name -> Q a
existentialContextError Name
conName
else Q c
q
noConstructorsError :: Q a
noConstructorsError :: forall a. Q a
noConstructorsError = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Must have at least one data constructor"
derivingKindError :: ClassRep a => a -> Name -> Q b
derivingKindError :: forall a b. ClassRep a => a -> Name -> Q b
derivingKindError a
cRep Name
tyConName = forall (m :: * -> *) a. MonadFail m => String -> m a
fail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Cannot derive well-kinded instance of form ‘"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS -> ShowS
showParen Bool
True
( String -> ShowS
showString (Name -> String
nameBase Name
tyConName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ..."
)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘\n\tClass "
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" expects an argument of kind "
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (forall a. Ppr a => a -> String
pprint forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
createKindChain forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Int
arity a
cRep)
forall a b. (a -> b) -> a -> b
$ String
""
where
className :: String
className :: String
className = Name -> String
nameBase forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Name
fullClassName a
cRep
contravarianceError :: Name -> Q a
contravarianceError :: forall a. Name -> Q a
contravarianceError Name
conName = forall (m :: * -> *) a. MonadFail m => String -> m a
fail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
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"
forall a b. (a -> b) -> a -> b
$ String
""
noFunctionsError :: Name -> Q a
noFunctionsError :: forall a. Name -> Q a
noFunctionsError Name
conName = forall (m :: * -> *) a. MonadFail m => String -> m a
fail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must not contain function types"
forall a b. (a -> b) -> a -> b
$ String
""
etaReductionError :: Type -> Q a
etaReductionError :: forall a. Type -> Q a
etaReductionError Type
instanceType = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
instanceType
datatypeContextError :: Name -> Type -> Q a
datatypeContextError :: forall a. Name -> Type -> Q a
datatypeContextError Name
dataName Type
instanceType = forall (m :: * -> *) a. MonadFail m => String -> m a
fail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Can't make a derived instance of ‘"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (forall a. Ppr a => a -> String
pprint Type
instanceType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘:\n\tData type ‘"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
dataName)
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)"
forall a b. (a -> b) -> a -> b
$ String
""
existentialContextError :: Name -> Q a
existentialContextError :: forall a. Name -> Q a
existentialContextError Name
conName = forall (m :: * -> *) a. MonadFail m => String -> m a
fail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
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"
forall a b. (a -> b) -> a -> b
$ String
""
outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError :: forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError a
cRep Name
conName = forall (m :: * -> *) a. MonadFail m => String -> m a
fail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must only use its last "
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows Int
n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" type variable(s) within the last "
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows Int
n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" argument(s) of a data type"
forall a b. (a -> b) -> a -> b
$ String
""
where
n :: Int
n :: Int
n = forall a. ClassRep a => a -> Int
arity a
cRep
enumerationError :: String -> Q a
enumerationError :: forall a. String -> Q a
enumerationError = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
enumerationErrorStr
enumerationOrProductError :: String -> Q a
enumerationOrProductError :: forall a. String -> Q a
enumerationOrProductError String
nb = forall (m :: * -> *) a. MonadFail m => String -> m a
fail 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
'\''forall a. a -> [a] -> [a]
:String
nb forall a. [a] -> [a] -> [a]
++ String
"’ must be an enumeration type"
forall a. [a] -> [a] -> [a]
++ String
" (one or more nullary, non-GADT constructors)"
typeDataError :: Name -> Q a
typeDataError :: forall a. Name -> Q a
typeDataError Name
dataName = forall (m :: * -> *) a. MonadFail m => String -> m a
fail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Cannot derive instance for ‘"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
dataName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘, which is a ‘type data‘ declaration"
forall a b. (a -> b) -> a -> b
$ String
""
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 :: forall a. [a] -> [a] -> [a]
interleave (a
a1:[a]
a1s) (a
a2:[a]
a2s) = a
a1forall a. a -> [a] -> [a]
:a
a2forall 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# :: Bool -> Bool
isTrue# x = x
{-# INLINE isTrue# #-}
#endif
filterByList :: [Bool] -> [a] -> [a]
filterByList :: forall a. [Bool] -> [a] -> [a]
filterByList (Bool
True:[Bool]
bs) (a
x:[a]
xs) = a
x forall a. a -> [a] -> [a]
: forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList (Bool
False:[Bool]
bs) (a
_:[a]
xs) = forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList [Bool]
_ [a]
_ = []
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists :: forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists (Bool
True:[Bool]
bs) (a
x:[a]
xs) (a
_:[a]
ys) = a
x forall a. 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 forall a. a -> [a] -> [a]
: forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
bs [a]
xs [a]
ys
filterByLists [Bool]
_ [a]
_ [a]
_ = []
partitionByList :: [Bool] -> [a] -> ([a], [a])
partitionByList :: forall a. [Bool] -> [a] -> ([a], [a])
partitionByList = 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
xforall 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
xforall a. a -> [a] -> [a]
:[a]
falses) [Bool]
bs [a]
xs
go [a]
trues [a]
falses [Bool]
_ [a]
_ = (forall a. [a] -> [a]
reverse [a]
trues, forall a. [a] -> [a]
reverse [a]
falses)
integerE :: Int -> Q Exp
integerE :: Int -> Q Exp
integerE = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
hasKindStar :: Type -> Bool
hasKindStar :: Type -> Bool
hasKindStar VarT{} = Bool
True
#if MIN_VERSION_template_haskell(2,8,0)
hasKindStar (SigT Type
_ Type
StarT) = Bool
True
#else
hasKindStar (SigT _ StarK) = True
#endif
hasKindStar Type
_ = Bool
False
isStarOrVar :: Kind -> Bool
#if MIN_VERSION_template_haskell(2,8,0)
isStarOrVar :: Type -> Bool
isStarOrVar Type
StarT = Bool
True
isStarOrVar VarT{} = Bool
True
#else
isStarOrVar StarK = True
#endif
isStarOrVar Type
_ = Bool
False
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain Int
kindArrows Type
t =
let uk :: [Type]
uk = Type -> [Type]
uncurryKind (Type -> Type
tyKind Type
t)
in if (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
uk forall a. Num a => a -> a -> a
- Int
1 forall a. Eq a => a -> a -> Bool
== Int
kindArrows) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isStarOrVar [Type]
uk
then forall a. a -> Maybe a
Just (forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
uk)
else forall a. Maybe a
Nothing
tyKind :: Type -> Kind
tyKind :: Type -> Type
tyKind (SigT Type
_ Type
k) = Type
k
tyKind Type
_ = Type
starK
zipWithAndUnzipM :: Monad m
=> (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
zipWithAndUnzipM :: 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
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) <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return (c
cforall a. a -> [a] -> [a]
:[c]
cs, d
dforall a. a -> [a] -> [a]
:[d]
ds)
zipWithAndUnzipM a -> b -> m (c, d)
_ [a]
_ [b]
_ = 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 :: 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
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) <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return (d
dforall a. a -> [a] -> [a]
:[d]
ds, e
eforall a. a -> [a] -> [a]
:[e]
es)
zipWith3AndUnzipM a -> b -> c -> m (d, e)
_ [a]
_ [b]
_ [c]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
{-# INLINE zipWith3AndUnzipM #-}
thd3 :: (a, b, c) -> c
thd3 :: forall a b c. (a, b, c) -> c
thd3 (a
_, b
_, c
c) = c
c
unsnoc :: [a] -> Maybe ([a], a)
unsnoc :: forall a. [a] -> Maybe ([a], a)
unsnoc [] = forall a. Maybe a
Nothing
unsnoc (a
x:[a]
xs) = case forall a. [a] -> Maybe ([a], a)
unsnoc [a]
xs of
Maybe ([a], a)
Nothing -> forall a. a -> Maybe a
Just ([], a
x)
Just ([a]
a,a
b) -> forall a. a -> Maybe a
Just (a
xforall a. a -> [a] -> [a]
:[a]
a, a
b)
isNullaryCon :: ConstructorInfo -> Bool
isNullaryCon :: ConstructorInfo -> Bool
isNullaryCon (ConstructorInfo { constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
tys }) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys
conArity :: ConstructorInfo -> Int
conArity :: ConstructorInfo -> Int
conArity (ConstructorInfo { constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
tys }) = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys
isProductType :: NonEmpty ConstructorInfo -> Bool
isProductType :: NonEmpty ConstructorInfo -> Bool
isProductType (ConstructorInfo
con :| []) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
con)
isProductType NonEmpty ConstructorInfo
_ = Bool
False
isEnumerationType :: NonEmpty ConstructorInfo -> Bool
isEnumerationType :: NonEmpty ConstructorInfo -> Bool
isEnumerationType NonEmpty ConstructorInfo
cons = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
App.liftA2 Bool -> Bool -> Bool
(&&) ConstructorInfo -> Bool
isNullaryCon ConstructorInfo -> Bool
isVanillaCon) NonEmpty ConstructorInfo
cons
isVanillaCon :: ConstructorInfo -> Bool
isVanillaCon :: ConstructorInfo -> Bool
isVanillaCon (ConstructorInfo { constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt, constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars = [TyVarBndrUnit]
vars }) =
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctxt Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
vars
newNameList :: String -> Int -> Q [Name]
newNameList :: String -> Int -> Q [Name]
newNameList String
prefix Int
n = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
n]
tvbKind :: TyVarBndr_ flag -> Kind
tvbKind :: forall flag. TyVarBndr_ flag -> Type
tvbKind = forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
_ -> Type
starK) (\Name
_ Type
k -> Type
k)
tvbToType :: TyVarBndr_ flag -> Type
tvbToType :: forall flag. TyVarBndr_ flag -> Type
tvbToType = forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
elimTV Name -> Type
VarT (\Name
n Type
k -> Type -> Type -> Type
SigT (Name -> Type
VarT Name
n) Type
k)
applyClass :: Name -> Name -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
applyClass :: Name -> Name -> Type
applyClass Name
con Name
t = Type -> Type -> Type
AppT (Name -> Type
ConT Name
con) (Name -> Type
VarT Name
t)
#else
applyClass con t = ClassP con [VarT t]
#endif
createKindChain :: Int -> Kind
createKindChain :: Int -> Type
createKindChain = Type -> Int -> Type
go Type
starK
where
go :: Kind -> Int -> Kind
go :: Type -> Int -> Type
go Type
k !Int
0 = Type
k
#if MIN_VERSION_template_haskell(2,8,0)
go Type
k !Int
n = Type -> Int -> Type
go (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
StarT) Type
k) (Int
n forall a. Num a => a -> a -> a
- Int
1)
#else
go k !n = go (ArrowK StarK k) (n - 1)
#endif
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce [Type]
remaining [Type]
dropped =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVar [Type]
dropped
Bool -> Bool -> Bool
&& forall a. Ord a => [a] -> Bool
allDistinct [Name]
droppedNames
Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
droppedNames) [Type]
remaining)
where
droppedNames :: [Name]
droppedNames :: [Name]
droppedNames = forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName [Type]
dropped
conTToName :: Type -> Name
conTToName :: Type -> Name
conTToName (ConT Name
n) = Name
n
conTToName (SigT Type
t Type
_) = Type -> Name
conTToName Type
t
conTToName Type
_ = forall a. HasCallStack => String -> a
error String
"Not a type constructor!"
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe (VarT Name
n) = forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT Type
t Type
_) = Type -> Maybe Name
varTToName_maybe Type
t
varTToName_maybe Type
_ = forall a. Maybe a
Nothing
varTToName :: Type -> Name
varTToName :: Type -> Name
varTToName = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Not a type variable!") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Name
varTToName_maybe
unSigT :: Type -> Type
unSigT :: Type -> Type
unSigT (SigT Type
t Type
_) = Type
t
unSigT Type
t = Type
t
isTyVar :: Type -> Bool
isTyVar :: Type -> Bool
isTyVar (VarT Name
_) = Bool
True
isTyVar (SigT Type
t Type
_) = Type -> Bool
isTyVar Type
t
isTyVar Type
_ = Bool
False
isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp [Name]
names Type
tyFun [Type]
tyArgs =
case Type
tyFun of
ConT Name
tcName -> Name -> Q Bool
go Name
tcName
Type
_ -> 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]
_
-> 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]
_
-> forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndrUnit]
bndrs
#elif MIN_VERSION_template_haskell(2,9,0)
FamilyI (ClosedTypeFamilyD _ bndrs _ _) _
-> withinFirstArgs bndrs
#endif
Info
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where
withinFirstArgs :: [a] -> Q Bool
withinFirstArgs :: forall a. [a] -> Q Bool
withinFirstArgs [a]
bndrs =
let firstArgs :: [Type]
firstArgs = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) [Type]
tyArgs
argFVs :: [Name]
argFVs = forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
firstArgs
in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
argFVs) [Name]
names
allDistinct :: Ord a => [a] -> Bool
allDistinct :: forall a. Ord a => [a] -> Bool
allDistinct = forall a. Ord a => Set a -> [a] -> Bool
allDistinct' forall a. Set a
Set.empty
where
allDistinct' :: Ord a => Set a -> [a] -> Bool
allDistinct' :: forall a. Ord a => Set a -> [a] -> Bool
allDistinct' Set a
uniqs (a
x:[a]
xs)
| a
x forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
uniqs = Bool
False
| Bool
otherwise = forall a. Ord a => Set a -> [a] -> Bool
allDistinct' (forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
uniqs) [a]
xs
allDistinct' Set a
_ [a]
_ = Bool
True
mentionsName :: Type -> [Name] -> Bool
mentionsName :: Type -> [Name] -> Bool
mentionsName = Type -> [Name] -> Bool
go
where
go :: Type -> [Name] -> Bool
go :: Type -> [Name] -> Bool
go (AppT Type
t1 Type
t2) [Name]
names = Type -> [Name] -> Bool
go Type
t1 [Name]
names Bool -> Bool -> Bool
|| Type -> [Name] -> Bool
go Type
t2 [Name]
names
go (SigT Type
t Type
_k) [Name]
names = Type -> [Name] -> Bool
go Type
t [Name]
names
#if MIN_VERSION_template_haskell(2,8,0)
Bool -> Bool -> Bool
|| Type -> [Name] -> Bool
go Type
_k [Name]
names
#endif
go (VarT Name
n) [Name]
names = Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
go Type
_ [Name]
_ = Bool
False
predMentionsName :: Pred -> [Name] -> Bool
#if MIN_VERSION_template_haskell(2,10,0)
predMentionsName :: Type -> [Name] -> Bool
predMentionsName = Type -> [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 :: Type -> [Type] -> Type
applyTy = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Type -> Type -> Type
AppT
applyTyCon :: Name -> [Type] -> Type
applyTyCon :: Name -> [Type] -> Type
applyTyCon = Type -> [Type] -> Type
applyTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
ConT
unapplyTy :: Type -> (Type, [Type])
unapplyTy :: Type -> (Type, [Type])
unapplyTy Type
ty = Type -> Type -> [Type] -> (Type, [Type])
go Type
ty Type
ty []
where
go :: Type -> Type -> [Type] -> (Type, [Type])
go :: Type -> Type -> [Type] -> (Type, [Type])
go Type
_ (AppT Type
ty1 Type
ty2) [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
go Type
ty1 Type
ty1 (Type
ty2forall a. a -> [a] -> [a]
:[Type]
args)
go Type
origTy (SigT Type
ty' Type
_) [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
go Type
origTy Type
ty' [Type]
args
#if MIN_VERSION_template_haskell(2,11,0)
go Type
origTy (InfixT Type
ty1 Name
n Type
ty2) [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
go Type
origTy (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2) [Type]
args
go Type
origTy (ParensT Type
ty') [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
go Type
origTy Type
ty' [Type]
args
#endif
go Type
origTy Type
_ [Type]
args = (Type
origTy, [Type]
args)
uncurryTy :: Type -> (Cxt, [Type])
uncurryTy :: Type -> ([Type], [Type])
uncurryTy (AppT (AppT Type
ArrowT Type
t1) Type
t2) =
let ([Type]
ctxt, [Type]
tys) = Type -> ([Type], [Type])
uncurryTy Type
t2
in ([Type]
ctxt, Type
t1forall a. a -> [a] -> [a]
:[Type]
tys)
uncurryTy (SigT Type
t Type
_) = Type -> ([Type], [Type])
uncurryTy Type
t
uncurryTy (ForallT [TyVarBndr Specificity]
_ [Type]
ctxt Type
t) =
let ([Type]
ctxt', [Type]
tys) = Type -> ([Type], [Type])
uncurryTy Type
t
in ([Type]
ctxt forall a. [a] -> [a] -> [a]
++ [Type]
ctxt', [Type]
tys)
uncurryTy Type
t = ([], [Type
t])
uncurryKind :: Kind -> [Kind]
#if MIN_VERSION_template_haskell(2,8,0)
uncurryKind :: Type -> [Type]
uncurryKind = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Type], [Type])
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 =
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
getTagValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
untagThis)
[forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
putTagHere)
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB 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 :: Type -> Q Exp
tag2ConExpr Type
ty = do
Name
iHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"i#"
Type
ty' <- Type -> Q Type
freshenType Type
ty
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
iHashDataName [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
iHash]) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tagToEnumHashValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
iHash
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`sigE` forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type
quantifyType Type
ty')
primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name)
primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name)
primOrdFunTbl = 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)
, (Name
int32HashTypeName, ( Name
ltInt32HashValName
, Name
leInt32HashValName
, Name
eqInt32HashValName
, Name
geInt32HashValName
, Name
gtInt32HashValName
))
, (Name
word32HashTypeName, ( Name
ltWord32HashValName
, Name
leWord32HashValName
, Name
eqWord32HashValName
, Name
geWord32HashValName
, Name
gtWord32HashValName
))
#endif
]
removeClassApp :: Type -> Type
removeClassApp :: Type -> Type
removeClassApp (AppT Type
_ Type
t2) = Type
t2
removeClassApp Type
t = Type
t
freshen :: Name -> Q Name
freshen :: Name -> Q Name
freshen Name
n = forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
n forall a. [a] -> [a] -> [a]
++ String
"_'")
freshenType :: Type -> Q Type
freshenType :: Type -> Q Type
freshenType Type
t =
do let xs :: [(Name, Q Type)]
xs = [(Name
n, Name -> Type
VarT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q Name
freshen Name
n) | Name
n <- forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t]
Map Name Type
subst <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
T.sequence (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, Q Type)]
xs)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst Type
t)
enumFromToExpr :: Q Exp -> Q Exp -> Q Exp
enumFromToExpr :: Q Exp -> Q Exp -> Q Exp
enumFromToExpr Q Exp
f Q Exp
t = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
enumFromToValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
f forall (m :: * -> *). Quote m => m Exp -> m Exp -> m 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 = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
isTrueHashValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
e1 (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
op) Q Exp
e2
isNonUnitTuple :: Name -> Bool
isNonUnitTuple :: Name -> Bool
isNonUnitTuple = String -> Bool
isNonUnitTupleString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
isNonUnitTupleString :: String -> Bool
isNonUnitTupleString :: String -> Bool
isNonUnitTupleString (Char
'(':Char
',':String
_) = Bool
True
isNonUnitTupleString String
_ = Bool
False
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)
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
isTrueHashValName :: Name
isTrueHashValName :: Name
isTrueHashValName = 'isTrue#
fmapConstValName :: Name
fmapConstValName :: Name
fmapConstValName = 'fmapConst
replaceConstValName :: Name
replaceConstValName :: Name
replaceConstValName = 'replaceConst
foldrConstValName :: Name
foldrConstValName :: Name
foldrConstValName = 'foldrConst
foldMapConstValName :: Name
foldMapConstValName :: Name
foldMapConstValName = 'foldMapConst
nullConstValName :: Name
nullConstValName :: Name
nullConstValName = 'nullConst
traverseConstValName :: Name
traverseConstValName :: Name
traverseConstValName = 'traverseConst
eqConstValName :: Name
eqConstValName :: Name
eqConstValName = 'eqConst
eq1ConstValName :: Name
eq1ConstValName :: Name
eq1ConstValName = 'eq1Const
liftEqConstValName :: Name
liftEqConstValName :: Name
liftEqConstValName = 'liftEqConst
liftEq2ConstValName :: Name
liftEq2ConstValName :: Name
liftEq2ConstValName = 'liftEq2Const
compareConstValName :: Name
compareConstValName :: Name
compareConstValName = 'compareConst
ltConstValName :: Name
ltConstValName :: Name
ltConstValName = 'ltConst
compare1ConstValName :: Name
compare1ConstValName :: Name
compare1ConstValName = 'compare1Const
liftCompareConstValName :: Name
liftCompareConstValName :: Name
liftCompareConstValName = 'liftCompareConst
liftCompare2ConstValName :: Name
liftCompare2ConstValName :: Name
liftCompare2ConstValName = 'liftCompare2Const
readsPrecConstValName :: Name
readsPrecConstValName :: Name
readsPrecConstValName = 'readsPrecConst
readPrecConstValName :: Name
readPrecConstValName :: Name
readPrecConstValName = 'readPrecConst
readsPrec1ConstValName :: Name
readsPrec1ConstValName :: Name
readsPrec1ConstValName = 'readsPrec1Const
liftReadsPrecConstValName :: Name
liftReadsPrecConstValName :: Name
liftReadsPrecConstValName = 'liftReadsPrecConst
liftReadPrecConstValName :: Name
liftReadPrecConstValName :: Name
liftReadPrecConstValName = 'liftReadPrecConst
liftReadsPrec2ConstValName :: Name
liftReadsPrec2ConstValName :: Name
liftReadsPrec2ConstValName = 'liftReadsPrec2Const
liftReadPrec2ConstValName :: Name
liftReadPrec2ConstValName :: Name
liftReadPrec2ConstValName = 'liftReadPrec2Const
showsPrecConstValName :: Name
showsPrecConstValName :: Name
showsPrecConstValName = 'showsPrecConst
showsPrec1ConstValName :: Name
showsPrec1ConstValName :: Name
showsPrec1ConstValName = 'showsPrec1Const
liftShowsPrecConstValName :: Name
liftShowsPrecConstValName :: Name
liftShowsPrecConstValName = 'liftShowsPrecConst
liftShowsPrec2ConstValName :: Name
liftShowsPrec2ConstValName :: Name
liftShowsPrec2ConstValName = 'liftShowsPrec2Const
viaTypeName :: Name
viaTypeName :: Name
viaTypeName = ''Via
cHashDataName :: Name
cHashDataName :: Name
cHashDataName = 'C#
dHashDataName :: Name
dHashDataName :: Name
dHashDataName = 'D#
fHashDataName :: Name
fHashDataName :: Name
fHashDataName = 'F#
identDataName :: Name
identDataName :: Name
identDataName = 'L.Ident
iHashDataName :: Name
iHashDataName :: Name
iHashDataName = 'I#
puncDataName :: Name
puncDataName :: Name
puncDataName = 'L.Punc
symbolDataName :: Name
symbolDataName :: Name
symbolDataName = 'L.Symbol
wrapMonadDataName :: Name
wrapMonadDataName :: Name
wrapMonadDataName = 'App.WrapMonad
addrHashTypeName :: Name
addrHashTypeName :: Name
addrHashTypeName = ''Addr#
boundedTypeName :: Name
boundedTypeName :: Name
boundedTypeName = ''Bounded
charHashTypeName :: Name
charHashTypeName :: Name
charHashTypeName = ''Char#
doubleHashTypeName :: Name
doubleHashTypeName :: Name
doubleHashTypeName = ''Double#
enumTypeName :: Name
enumTypeName :: Name
enumTypeName = ''Enum
floatHashTypeName :: Name
floatHashTypeName :: Name
floatHashTypeName = ''Float#
foldableTypeName :: Name
foldableTypeName :: Name
foldableTypeName = ''Foldable
functorTypeName :: Name
functorTypeName :: Name
functorTypeName = ''Functor
intTypeName :: Name
intTypeName :: Name
intTypeName = ''Int
intHashTypeName :: Name
intHashTypeName :: Name
intHashTypeName = ''Int#
ixTypeName :: Name
ixTypeName :: Name
ixTypeName = ''Ix
readTypeName :: Name
readTypeName :: Name
readTypeName = ''Read
showTypeName :: Name
showTypeName :: Name
showTypeName = ''Show
traversableTypeName :: Name
traversableTypeName :: Name
traversableTypeName = ''Traversable
wordHashTypeName :: Name
wordHashTypeName :: Name
wordHashTypeName = ''Word#
altValName :: Name
altValName :: Name
altValName = '(+++)
appendValName :: Name
appendValName :: Name
appendValName = '(++)
chooseValName :: Name
chooseValName :: Name
chooseValName = 'choose
composeValName :: Name
composeValName :: Name
composeValName = '(.)
constValName :: Name
constValName :: Name
constValName = 'const
enumFromValName :: Name
enumFromValName :: Name
enumFromValName = 'enumFrom
enumFromThenValName :: Name
enumFromThenValName :: Name
enumFromThenValName = 'enumFromThen
enumFromThenToValName :: Name
enumFromThenToValName :: Name
enumFromThenToValName = 'enumFromThenTo
enumFromToValName :: Name
enumFromToValName :: Name
enumFromToValName = 'enumFromTo
eqAddrHashValName :: Name
eqAddrHashValName :: Name
eqAddrHashValName = 'eqAddr#
eqCharHashValName :: Name
eqCharHashValName :: Name
eqCharHashValName = 'eqChar#
eqDoubleHashValName :: Name
eqDoubleHashValName :: Name
eqDoubleHashValName = '(==##)
eqFloatHashValName :: Name
eqFloatHashValName :: Name
eqFloatHashValName = 'eqFloat#
eqIntHashValName :: Name
eqIntHashValName :: Name
eqIntHashValName = '(==#)
eqWordHashValName :: Name
eqWordHashValName :: Name
eqWordHashValName = 'eqWord#
errorValName :: Name
errorValName :: Name
errorValName = 'error
flipValName :: Name
flipValName :: Name
flipValName = 'flip
fmapValName :: Name
fmapValName :: Name
fmapValName = 'fmap
foldrValName :: Name
foldrValName :: Name
foldrValName = 'F.foldr
foldMapValName :: Name
foldMapValName :: Name
foldMapValName = 'foldMap
fromEnumValName :: Name
= 'fromEnum
geAddrHashValName :: Name
geAddrHashValName :: Name
geAddrHashValName = 'geAddr#
geCharHashValName :: Name
geCharHashValName :: Name
geCharHashValName = 'geChar#
geDoubleHashValName :: Name
geDoubleHashValName :: Name
geDoubleHashValName = '(>=##)
geFloatHashValName :: Name
geFloatHashValName :: Name
geFloatHashValName = 'geFloat#
geIntHashValName :: Name
geIntHashValName :: Name
geIntHashValName = '(>=#)
getTagValName :: Name
getTagValName :: Name
getTagValName = 'getTag
geWordHashValName :: Name
geWordHashValName :: Name
geWordHashValName = 'geWord#
gtAddrHashValName :: Name
gtAddrHashValName :: Name
gtAddrHashValName = 'gtAddr#
gtCharHashValName :: Name
gtCharHashValName :: Name
gtCharHashValName = 'gtChar#
gtDoubleHashValName :: Name
gtDoubleHashValName :: Name
gtDoubleHashValName = '(>##)
gtFloatHashValName :: Name
gtFloatHashValName :: Name
gtFloatHashValName = 'gtFloat#
gtIntHashValName :: Name
gtIntHashValName :: Name
gtIntHashValName = '(>#)
gtWordHashValName :: Name
gtWordHashValName :: Name
gtWordHashValName = 'gtWord#
idValName :: Name
idValName :: Name
idValName = 'id
indexValName :: Name
indexValName :: Name
indexValName = 'index
inRangeValName :: Name
inRangeValName :: Name
inRangeValName = 'inRange
leAddrHashValName :: Name
leAddrHashValName :: Name
leAddrHashValName = 'leAddr#
leCharHashValName :: Name
leCharHashValName :: Name
leCharHashValName = 'leChar#
leDoubleHashValName :: Name
leDoubleHashValName :: Name
leDoubleHashValName = '(<=##)
leFloatHashValName :: Name
leFloatHashValName :: Name
leFloatHashValName = 'leFloat#
leIntHashValName :: Name
leIntHashValName :: Name
leIntHashValName = '(<=#)
leWordHashValName :: Name
leWordHashValName :: Name
leWordHashValName = 'leWord#
listValName :: Name
listValName :: Name
listValName = 'list
ltAddrHashValName :: Name
ltAddrHashValName :: Name
ltAddrHashValName = 'ltAddr#
ltCharHashValName :: Name
ltCharHashValName :: Name
ltCharHashValName = 'ltChar#
ltDoubleHashValName :: Name
ltDoubleHashValName :: Name
ltDoubleHashValName = '(<##)
ltFloatHashValName :: Name
ltFloatHashValName :: Name
ltFloatHashValName = 'ltFloat#
ltIntHashValName :: Name
ltIntHashValName :: Name
ltIntHashValName = '(<#)
ltWordHashValName :: Name
ltWordHashValName :: Name
ltWordHashValName = 'ltWord#
minBoundValName :: Name
minBoundValName :: Name
minBoundValName = 'minBound
mapValName :: Name
mapValName :: Name
mapValName = 'map
maxBoundValName :: Name
maxBoundValName :: Name
maxBoundValName = 'maxBound
minusIntHashValName :: Name
minusIntHashValName :: Name
minusIntHashValName = '(-#)
neqIntHashValName :: Name
neqIntHashValName :: Name
neqIntHashValName = '(/=#)
parenValName :: Name
parenValName :: Name
parenValName = 'paren
parensValName :: Name
parensValName :: Name
parensValName = 'parens
pfailValName :: Name
pfailValName :: Name
pfailValName = 'pfail
plusValName :: Name
plusValName :: Name
plusValName = '(+)
precValName :: Name
precValName :: Name
precValName = 'prec
predValName :: Name
predValName :: Name
predValName = 'pred
rangeSizeValName :: Name
rangeSizeValName :: Name
rangeSizeValName = 'rangeSize
rangeValName :: Name
rangeValName :: Name
rangeValName = 'range
readFieldHash :: String -> ReadPrec a -> ReadPrec a
readFieldHash :: forall a. 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 = 'readFieldHash
readListValName :: Name
readListValName :: Name
readListValName = 'readList
readListPrecDefaultValName :: Name
readListPrecDefaultValName :: Name
readListPrecDefaultValName = 'readListPrecDefault
readListPrecValName :: Name
readListPrecValName :: Name
readListPrecValName = 'readListPrec
readPrec_to_SValName :: Name
readPrec_to_SValName :: Name
readPrec_to_SValName = 'readPrec_to_S
readPrecValName :: Name
readPrecValName :: Name
readPrecValName = 'readPrec
readS_to_PrecValName :: Name
readS_to_PrecValName :: Name
readS_to_PrecValName = 'readS_to_Prec
readsPrecValName :: Name
readsPrecValName :: Name
readsPrecValName = 'readsPrec
replaceValName :: Name
replaceValName :: Name
replaceValName = '(<$)
resetValName :: Name
resetValName :: Name
resetValName = 'reset
returnValName :: Name
returnValName :: Name
returnValName = 'return
seqValName :: Name
seqValName :: Name
seqValName = 'seq
showCharValName :: Name
showCharValName :: Name
showCharValName = 'showChar
showListValName :: Name
showListValName :: Name
showListValName = 'showList
showListWithValName :: Name
showListWithValName :: Name
showListWithValName = 'showListWith
showParenValName :: Name
showParenValName :: Name
showParenValName = 'showParen
showsPrecValName :: Name
showsPrecValName :: Name
showsPrecValName = 'showsPrec
showSpaceValName :: Name
showSpaceValName :: Name
showSpaceValName = 'showSpace
showStringValName :: Name
showStringValName :: Name
showStringValName = 'showString
stepValName :: Name
stepValName :: Name
stepValName = 'step
succValName :: Name
succValName :: Name
succValName = 'succ
tagToEnumHashValName :: Name
tagToEnumHashValName :: Name
tagToEnumHashValName = 'tagToEnum#
timesValName :: Name
timesValName :: Name
timesValName = '(*)
toEnumValName :: Name
toEnumValName :: Name
toEnumValName = 'toEnum
traverseValName :: Name
traverseValName :: Name
traverseValName = 'traverse
unsafeIndexValName :: Name
unsafeIndexValName :: Name
unsafeIndexValName = 'unsafeIndex
unsafeRangeSizeValName :: Name
unsafeRangeSizeValName :: Name
unsafeRangeSizeValName = 'unsafeRangeSize
unwrapMonadValName :: Name
unwrapMonadValName :: Name
unwrapMonadValName = 'App.unwrapMonad
boolTypeName :: Name
boolTypeName :: Name
boolTypeName = ''Bool
falseDataName :: Name
falseDataName :: Name
falseDataName = 'False
trueDataName :: Name
trueDataName :: Name
trueDataName = 'True
eqDataName :: Name
eqDataName :: Name
eqDataName = 'EQ
gtDataName :: Name
gtDataName :: Name
gtDataName = 'GT
ltDataName :: Name
ltDataName :: Name
ltDataName = 'LT
eqTypeName :: Name
eqTypeName :: Name
eqTypeName = ''Eq
ordTypeName :: Name
ordTypeName :: Name
ordTypeName = ''Ord
andValName :: Name
andValName :: Name
andValName = '(&&)
compareValName :: Name
compareValName :: Name
compareValName = 'compare
eqValName :: Name
eqValName :: Name
eqValName = '(==)
geValName :: Name
geValName :: Name
geValName = '(>=)
gtValName :: Name
gtValName :: Name
gtValName = '(>)
leValName :: Name
leValName :: Name
leValName = '(<=)
ltValName :: Name
ltValName :: Name
ltValName = '(<)
notValName :: Name
notValName :: Name
notValName = 'not
wHashDataName :: Name
wHashDataName :: Name
wHashDataName = 'W#
#if !(MIN_VERSION_base(4,7,0))
expectP :: Lexeme -> ReadPrec ()
expectP lexeme = do
thing <- lexP
if thing == lexeme then return () else pfail
#endif
expectPValName :: Name
expectPValName :: Name
expectPValName = 'expectP
allValName :: Name
allValName :: Name
allValName = 'all
apValName :: Name
apValName :: Name
apValName = '(<*>)
pureValName :: Name
pureValName :: Name
pureValName = 'pure
liftA2ValName :: Name
liftA2ValName :: Name
liftA2ValName = 'App.liftA2
mappendValName :: Name
mappendValName :: Name
mappendValName = 'mappend
memptyValName :: Name
memptyValName :: Name
memptyValName = 'mempty
nullValName :: Name
nullValName :: Name
nullValName = 'null
eq1TypeName :: Name
eq1TypeName :: Name
eq1TypeName = ''Eq1
ord1TypeName :: Name
ord1TypeName :: Name
ord1TypeName = ''Ord1
read1TypeName :: Name
read1TypeName :: Name
read1TypeName = ''Read1
show1TypeName :: Name
show1TypeName :: Name
show1TypeName = ''Show1
#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)
eq2TypeName :: Name
eq2TypeName :: Name
eq2TypeName = ''Eq2
ord2TypeName :: Name
ord2TypeName :: Name
ord2TypeName = ''Ord2
read2TypeName :: Name
read2TypeName :: Name
read2TypeName = ''Read2
show2TypeName :: Name
show2TypeName :: Name
show2TypeName = ''Show2
liftEqValName :: Name
liftEqValName :: Name
liftEqValName = 'liftEq
liftEq2ValName :: Name
liftEq2ValName :: Name
liftEq2ValName = 'liftEq2
liftCompareValName :: Name
liftCompareValName :: Name
liftCompareValName = 'liftCompare
liftCompare2ValName :: Name
liftCompare2ValName :: Name
liftCompare2ValName = 'liftCompare2
liftReadsPrecValName :: Name
liftReadsPrecValName :: Name
liftReadsPrecValName = 'liftReadsPrec
liftReadListValName :: Name
liftReadListValName :: Name
liftReadListValName = 'liftReadList
liftReadsPrec2ValName :: Name
liftReadsPrec2ValName :: Name
liftReadsPrec2ValName = 'liftReadsPrec2
liftReadList2ValName :: Name
liftReadList2ValName :: Name
liftReadList2ValName = 'liftReadList2
liftShowListValName :: Name
liftShowListValName :: Name
liftShowListValName = 'liftShowList
liftShowsPrecValName :: Name
liftShowsPrecValName :: Name
liftShowsPrecValName = 'liftShowsPrec
liftShowList2ValName :: Name
liftShowList2ValName :: Name
liftShowList2ValName = 'liftShowList2
liftShowsPrec2ValName :: Name
liftShowsPrec2ValName :: Name
liftShowsPrec2ValName = 'liftShowsPrec2
#else
eq1ValName :: Name
eq1ValName = 'eq1
compare1ValName :: Name
compare1ValName = 'compare1
readsPrec1ValName :: Name
readsPrec1ValName = 'readsPrec1
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 = 'Apply
unApplyValName :: Name
unApplyValName = 'unApply
#endif
#if MIN_VERSION_base(4,7,0)
coerceValName :: Name
coerceValName :: Name
coerceValName = 'coerce
#endif
#if MIN_VERSION_base(4,10,0)
liftReadListPrecDefaultValName :: Name
liftReadListPrecDefaultValName :: Name
liftReadListPrecDefaultValName = 'liftReadListPrecDefault
liftReadListPrec2DefaultValName :: Name
liftReadListPrec2DefaultValName :: Name
liftReadListPrec2DefaultValName = 'liftReadListPrec2Default
liftReadListPrecValName :: Name
liftReadListPrecValName :: Name
liftReadListPrecValName = 'liftReadListPrec
liftReadListPrec2ValName :: Name
liftReadListPrec2ValName :: Name
liftReadListPrec2ValName = 'liftReadListPrec2
liftReadPrecValName :: Name
liftReadPrecValName :: Name
liftReadPrecValName = 'liftReadPrec
liftReadPrec2ValName :: Name
liftReadPrec2ValName :: Name
liftReadPrec2ValName = 'liftReadPrec2
#else
liftReadListPrecDefaultValName :: Name
liftReadListPrecDefaultValName =
error "using liftReadListPrecDefault before base-4.10.*"
liftReadListPrec2DefaultValName :: Name
liftReadListPrec2DefaultValName =
error "using liftReadListPrec2Default before base-4.10.*"
liftReadListPrecValName :: Name
liftReadListPrecValName =
error "using liftReadListPrec before base-4.10.*"
liftReadListPrec2ValName :: Name
liftReadListPrec2ValName =
error "using liftReadListPrec2 before base-4.10.*"
liftReadPrecValName :: Name
liftReadPrecValName =
error "using liftReadPrec before base-4.10.*"
liftReadPrec2ValName :: Name
liftReadPrec2ValName =
error "using liftReadPrec2 before base-4.10.*"
#endif
#if !(MIN_VERSION_base(4,10,0))
showCommaSpace :: ShowS
showCommaSpace = showString ", "
#endif
showCommaSpaceValName :: Name
showCommaSpaceValName :: Name
showCommaSpaceValName = 'showCommaSpace
appEndoValName :: Name
appEndoValName :: Name
appEndoValName = 'appEndo
dualDataName :: Name
dualDataName :: Name
dualDataName = 'Dual
endoDataName :: Name
endoDataName :: Name
endoDataName = 'Endo
getDualValName :: Name
getDualValName :: Name
getDualValName = 'getDual
#if !(MIN_VERSION_base(4,11,0))
readField :: String -> ReadPrec a -> ReadPrec a
readField fieldName readVal = do
expectP (L.Ident fieldName)
expectP (L.Punc "=")
readVal
{-# NOINLINE 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 #-}
#endif
readFieldValName :: Name
readFieldValName :: Name
readFieldValName = 'readField
readSymFieldValName :: Name
readSymFieldValName :: Name
readSymFieldValName = 'readSymField
#if MIN_VERSION_base(4,13,0)
eqInt8HashValName :: Name
eqInt8HashValName :: Name
eqInt8HashValName = 'eqInt8#
eqInt16HashValName :: Name
eqInt16HashValName :: Name
eqInt16HashValName = 'eqInt16#
eqWord8HashValName :: Name
eqWord8HashValName :: Name
eqWord8HashValName = 'eqWord8#
eqWord16HashValName :: Name
eqWord16HashValName :: Name
eqWord16HashValName = 'eqWord16#
geInt8HashValName :: Name
geInt8HashValName :: Name
geInt8HashValName = 'geInt8#
geInt16HashValName :: Name
geInt16HashValName :: Name
geInt16HashValName = 'geInt16#
geWord8HashValName :: Name
geWord8HashValName :: Name
geWord8HashValName = 'geWord8#
geWord16HashValName :: Name
geWord16HashValName :: Name
geWord16HashValName = 'geWord16#
gtInt8HashValName :: Name
gtInt8HashValName :: Name
gtInt8HashValName = 'gtInt8#
gtInt16HashValName :: Name
gtInt16HashValName :: Name
gtInt16HashValName = 'gtInt16#
gtWord8HashValName :: Name
gtWord8HashValName :: Name
gtWord8HashValName = 'gtWord8#
gtWord16HashValName :: Name
gtWord16HashValName :: Name
gtWord16HashValName = 'gtWord16#
int8HashTypeName :: Name
int8HashTypeName :: Name
int8HashTypeName = ''Int8#
int8ToIntHashValName :: Name
int8ToIntHashValName :: Name
int8ToIntHashValName =
# if MIN_VERSION_base(4,16,0)
'int8ToInt#
# else
'extendInt8#
# endif
int16HashTypeName :: Name
int16HashTypeName :: Name
int16HashTypeName = ''Int16#
int16ToIntHashValName :: Name
int16ToIntHashValName :: Name
int16ToIntHashValName =
# if MIN_VERSION_base(4,16,0)
'int16ToInt#
# else
'extendInt16#
# endif
intToInt8HashValName :: Name
intToInt8HashValName :: Name
intToInt8HashValName =
# if MIN_VERSION_base(4,16,0)
'intToInt8#
# else
'narrowInt8#
# endif
intToInt16HashValName :: Name
intToInt16HashValName :: Name
intToInt16HashValName =
# if MIN_VERSION_base(4,16,0)
'intToInt16#
# else
'narrowInt16#
# endif
leInt8HashValName :: Name
leInt8HashValName :: Name
leInt8HashValName = 'leInt8#
leInt16HashValName :: Name
leInt16HashValName :: Name
leInt16HashValName = 'leInt16#
leWord8HashValName :: Name
leWord8HashValName :: Name
leWord8HashValName = 'leWord8#
leWord16HashValName :: Name
leWord16HashValName :: Name
leWord16HashValName = 'leWord16#
ltInt8HashValName :: Name
ltInt8HashValName :: Name
ltInt8HashValName = 'ltInt8#
ltInt16HashValName :: Name
ltInt16HashValName :: Name
ltInt16HashValName = 'ltInt16#
ltWord8HashValName :: Name
ltWord8HashValName :: Name
ltWord8HashValName = 'ltWord8#
ltWord16HashValName :: Name
ltWord16HashValName :: Name
ltWord16HashValName = 'ltWord16#
word8HashTypeName :: Name
word8HashTypeName :: Name
word8HashTypeName = ''Word8#
word8ToWordHashValName :: Name
word8ToWordHashValName :: Name
word8ToWordHashValName =
# if MIN_VERSION_base(4,16,0)
'word8ToWord#
# else
'extendWord8#
# endif
word16HashTypeName :: Name
word16HashTypeName :: Name
word16HashTypeName = ''Word16#
word16ToWordHashValName :: Name
word16ToWordHashValName :: Name
word16ToWordHashValName =
# if MIN_VERSION_base(4,16,0)
'word16ToWord#
# else
'extendWord16#
# endif
wordToWord8HashValName :: Name
wordToWord8HashValName :: Name
wordToWord8HashValName =
# if MIN_VERSION_base(4,16,0)
'wordToWord8#
# else
'narrowWord8#
# endif
wordToWord16HashValName :: Name
wordToWord16HashValName :: Name
wordToWord16HashValName =
# if MIN_VERSION_base(4,16,0)
'wordToWord16#
# else
'narrowWord16#
# endif
#endif
#if MIN_VERSION_base(4,16,0)
eqInt32HashValName :: Name
eqInt32HashValName :: Name
eqInt32HashValName = 'eqInt32#
eqWord32HashValName :: Name
eqWord32HashValName :: Name
eqWord32HashValName = 'eqWord32#
geInt32HashValName :: Name
geInt32HashValName :: Name
geInt32HashValName = 'geInt32#
geWord32HashValName :: Name
geWord32HashValName :: Name
geWord32HashValName = 'geWord32#
gtInt32HashValName :: Name
gtInt32HashValName :: Name
gtInt32HashValName = 'gtInt32#
gtWord32HashValName :: Name
gtWord32HashValName :: Name
gtWord32HashValName = 'gtWord32#
int32HashTypeName :: Name
int32HashTypeName :: Name
int32HashTypeName = ''Int32#
int32ToIntHashValName :: Name
int32ToIntHashValName :: Name
int32ToIntHashValName = 'int32ToInt#
intToInt32HashValName :: Name
intToInt32HashValName :: Name
intToInt32HashValName = 'intToInt32#
leInt32HashValName :: Name
leInt32HashValName :: Name
leInt32HashValName = 'leInt32#
leWord32HashValName :: Name
leWord32HashValName :: Name
leWord32HashValName = 'leWord32#
ltInt32HashValName :: Name
ltInt32HashValName :: Name
ltInt32HashValName = 'ltInt32#
ltWord32HashValName :: Name
ltWord32HashValName :: Name
ltWord32HashValName = 'ltWord32#
word32HashTypeName :: Name
word32HashTypeName :: Name
word32HashTypeName = ''Word32#
word32ToWordHashValName :: Name
word32ToWordHashValName :: Name
word32ToWordHashValName = 'word32ToWord#
wordToWord32HashValName :: Name
wordToWord32HashValName :: Name
wordToWord32HashValName = 'wordToWord32#
#endif