{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Unsafe #-}
#endif
#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(x,y,z) 1
#endif
module Data.Bifunctor.TH (
deriveBifunctor
, deriveBifunctorOptions
, makeBimap
, makeBimapOptions
, deriveBifoldable
, deriveBifoldableOptions
, makeBifold
, makeBifoldOptions
, makeBifoldMap
, makeBifoldMapOptions
, makeBifoldr
, makeBifoldrOptions
, makeBifoldl
, makeBifoldlOptions
, deriveBitraversable
, deriveBitraversableOptions
, makeBitraverse
, makeBitraverseOptions
, makeBisequenceA
, makeBisequenceAOptions
, makeBimapM
, makeBimapMOptions
, makeBisequence
, makeBisequenceOptions
, Options(..)
, defaultOptions
) where
import Control.Monad (guard, unless, when)
import Data.Bifunctor.TH.Internal
import Data.List
import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size)
import Data.Maybe
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax
newtype Options = Options
{ Options -> Bool
emptyCaseBehavior :: Bool
} deriving (Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c== :: Options -> Options -> Bool
Eq, Eq Options
Eq Options
-> (Options -> Options -> Ordering)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Options)
-> (Options -> Options -> Options)
-> Ord Options
Options -> Options -> Bool
Options -> Options -> Ordering
Options -> Options -> Options
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Options -> Options -> Options
$cmin :: Options -> Options -> Options
max :: Options -> Options -> Options
$cmax :: Options -> Options -> Options
>= :: Options -> Options -> Bool
$c>= :: Options -> Options -> Bool
> :: Options -> Options -> Bool
$c> :: Options -> Options -> Bool
<= :: Options -> Options -> Bool
$c<= :: Options -> Options -> Bool
< :: Options -> Options -> Bool
$c< :: Options -> Options -> Bool
compare :: Options -> Options -> Ordering
$ccompare :: Options -> Options -> Ordering
$cp1Ord :: Eq Options
Ord, ReadPrec [Options]
ReadPrec Options
Int -> ReadS Options
ReadS [Options]
(Int -> ReadS Options)
-> ReadS [Options]
-> ReadPrec Options
-> ReadPrec [Options]
-> Read Options
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Options]
$creadListPrec :: ReadPrec [Options]
readPrec :: ReadPrec Options
$creadPrec :: ReadPrec Options
readList :: ReadS [Options]
$creadList :: ReadS [Options]
readsPrec :: Int -> ReadS Options
$creadsPrec :: Int -> ReadS Options
Read, Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show)
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options :: Bool -> Options
Options { emptyCaseBehavior :: Bool
emptyCaseBehavior = Bool
False }
deriveBifunctor :: Name -> Q [Dec]
deriveBifunctor :: Name -> Q [Dec]
deriveBifunctor = Options -> Name -> Q [Dec]
deriveBifunctorOptions Options
defaultOptions
deriveBifunctorOptions :: Options -> Name -> Q [Dec]
deriveBifunctorOptions :: Options -> Name -> Q [Dec]
deriveBifunctorOptions = BiClass -> Options -> Name -> Q [Dec]
deriveBiClass BiClass
Bifunctor
makeBimap :: Name -> Q Exp
makeBimap :: Name -> Q Exp
makeBimap = Options -> Name -> Q Exp
makeBimapOptions Options
defaultOptions
makeBimapOptions :: Options -> Name -> Q Exp
makeBimapOptions :: Options -> Name -> Q Exp
makeBimapOptions = BiFun -> Options -> Name -> Q Exp
makeBiFun BiFun
Bimap
deriveBifoldable :: Name -> Q [Dec]
deriveBifoldable :: Name -> Q [Dec]
deriveBifoldable = Options -> Name -> Q [Dec]
deriveBifoldableOptions Options
defaultOptions
deriveBifoldableOptions :: Options -> Name -> Q [Dec]
deriveBifoldableOptions :: Options -> Name -> Q [Dec]
deriveBifoldableOptions = BiClass -> Options -> Name -> Q [Dec]
deriveBiClass BiClass
Bifoldable
makeBifold :: Name -> Q Exp
makeBifold :: Name -> Q Exp
makeBifold = Options -> Name -> Q Exp
makeBifoldOptions Options
defaultOptions
makeBifoldOptions :: Options -> Name -> Q Exp
makeBifoldOptions :: Options -> Name -> Q Exp
makeBifoldOptions Options
opts Name
name = [Q Exp] -> Q Exp
appsE [ Options -> Name -> Q Exp
makeBifoldMapOptions Options
opts Name
name
, Name -> Q Exp
varE Name
idValName
, Name -> Q Exp
varE Name
idValName
]
makeBifoldMap :: Name -> Q Exp
makeBifoldMap :: Name -> Q Exp
makeBifoldMap = Options -> Name -> Q Exp
makeBifoldMapOptions Options
defaultOptions
makeBifoldMapOptions :: Options -> Name -> Q Exp
makeBifoldMapOptions :: Options -> Name -> Q Exp
makeBifoldMapOptions = BiFun -> Options -> Name -> Q Exp
makeBiFun BiFun
BifoldMap
makeBifoldr :: Name -> Q Exp
makeBifoldr :: Name -> Q Exp
makeBifoldr = Options -> Name -> Q Exp
makeBifoldrOptions Options
defaultOptions
makeBifoldrOptions :: Options -> Name -> Q Exp
makeBifoldrOptions :: Options -> Name -> Q Exp
makeBifoldrOptions = BiFun -> Options -> Name -> Q Exp
makeBiFun BiFun
Bifoldr
makeBifoldl :: Name -> Q Exp
makeBifoldl :: Name -> Q Exp
makeBifoldl = Options -> Name -> Q Exp
makeBifoldlOptions Options
defaultOptions
makeBifoldlOptions :: Options -> Name -> Q Exp
makeBifoldlOptions :: Options -> Name -> Q Exp
makeBifoldlOptions Options
opts Name
name = do
Name
f <- String -> Q Name
newName String
"f"
Name
g <- String -> Q Name
newName String
"g"
Name
z <- String -> Q Name
newName String
"z"
Name
t <- String -> Q Name
newName String
"t"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
g, Name -> PatQ
varP Name
z, Name -> PatQ
varP Name
t] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[Q Exp] -> Q Exp
appsE [ Name -> Q Exp
varE Name
appEndoValName
, [Q Exp] -> Q Exp
appsE [ Name -> Q Exp
varE Name
getDualValName
, [Q Exp] -> Q Exp
appsE [ Options -> Name -> Q Exp
makeBifoldMapOptions Options
opts Name
name
, Name -> Q Exp
foldFun Name
f
, Name -> Q Exp
foldFun Name
g
, Name -> Q Exp
varE Name
t]
]
, Name -> Q Exp
varE Name
z
]
where
foldFun :: Name -> Q Exp
foldFun :: Name -> Q Exp
foldFun Name
n = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
conE Name
dualDataName)
(Name -> Q Exp
varE Name
composeValName)
(Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
conE Name
endoDataName)
(Name -> Q Exp
varE Name
composeValName)
(Name -> Q Exp
varE Name
flipValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
n)
)
deriveBitraversable :: Name -> Q [Dec]
deriveBitraversable :: Name -> Q [Dec]
deriveBitraversable = Options -> Name -> Q [Dec]
deriveBitraversableOptions Options
defaultOptions
deriveBitraversableOptions :: Options -> Name -> Q [Dec]
deriveBitraversableOptions :: Options -> Name -> Q [Dec]
deriveBitraversableOptions = BiClass -> Options -> Name -> Q [Dec]
deriveBiClass BiClass
Bitraversable
makeBitraverse :: Name -> Q Exp
makeBitraverse :: Name -> Q Exp
makeBitraverse = Options -> Name -> Q Exp
makeBitraverseOptions Options
defaultOptions
makeBitraverseOptions :: Options -> Name -> Q Exp
makeBitraverseOptions :: Options -> Name -> Q Exp
makeBitraverseOptions = BiFun -> Options -> Name -> Q Exp
makeBiFun BiFun
Bitraverse
makeBisequenceA :: Name -> Q Exp
makeBisequenceA :: Name -> Q Exp
makeBisequenceA = Options -> Name -> Q Exp
makeBisequenceAOptions Options
defaultOptions
makeBisequenceAOptions :: Options -> Name -> Q Exp
makeBisequenceAOptions :: Options -> Name -> Q Exp
makeBisequenceAOptions Options
opts Name
name = [Q Exp] -> Q Exp
appsE [ Options -> Name -> Q Exp
makeBitraverseOptions Options
opts Name
name
, Name -> Q Exp
varE Name
idValName
, Name -> Q Exp
varE Name
idValName
]
makeBimapM :: Name -> Q Exp
makeBimapM :: Name -> Q Exp
makeBimapM = Options -> Name -> Q Exp
makeBimapMOptions Options
defaultOptions
makeBimapMOptions :: Options -> Name -> Q Exp
makeBimapMOptions :: Options -> Name -> Q Exp
makeBimapMOptions Options
opts Name
name = do
Name
f <- String -> Q Name
newName String
"f"
Name
g <- String -> Q Name
newName String
"g"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
g] (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
unwrapMonadValName) (Name -> Q Exp
varE Name
composeValName) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[Q Exp] -> Q Exp
appsE [ Options -> Name -> Q Exp
makeBitraverseOptions Options
opts Name
name
, Name -> Q Exp
wrapMonadExp Name
f
, Name -> Q Exp
wrapMonadExp Name
g
]
where
wrapMonadExp :: Name -> Q Exp
wrapMonadExp :: Name -> Q Exp
wrapMonadExp Name
n = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
conE Name
wrapMonadDataName) (Name -> Q Exp
varE Name
composeValName) (Name -> Q Exp
varE Name
n)
makeBisequence :: Name -> Q Exp
makeBisequence :: Name -> Q Exp
makeBisequence = Options -> Name -> Q Exp
makeBisequenceOptions Options
defaultOptions
makeBisequenceOptions :: Options -> Name -> Q Exp
makeBisequenceOptions :: Options -> Name -> Q Exp
makeBisequenceOptions Options
opts Name
name = [Q Exp] -> Q Exp
appsE [ Options -> Name -> Q Exp
makeBimapMOptions Options
opts Name
name
, Name -> Q Exp
varE Name
idValName
, Name -> Q Exp
varE Name
idValName
]
deriveBiClass :: BiClass -> Options -> Name -> Q [Dec]
deriveBiClass :: BiClass -> Options -> Name -> Q [Dec]
deriveBiClass BiClass
biClass Options
opts Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(Cxt
instanceCxt, Type
instanceType)
<- BiClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance BiClass
biClass Name
parentName Cxt
ctxt Cxt
instTys DatatypeVariant
variant
(Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(BiClass -> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
biFunDecs BiClass
biClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons)
biFunDecs :: BiClass -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
biFunDecs :: BiClass -> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
biFunDecs BiClass
biClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons =
(BiFun -> Q Dec) -> [BiFun] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map BiFun -> Q Dec
makeFunD ([BiFun] -> [Q Dec]) -> [BiFun] -> [Q Dec]
forall a b. (a -> b) -> a -> b
$ BiClass -> [BiFun]
biClassToFuns BiClass
biClass
where
makeFunD :: BiFun -> Q Dec
makeFunD :: BiFun -> Q Dec
makeFunD BiFun
biFun =
Name -> [ClauseQ] -> Q Dec
funD (BiFun -> Name
biFunName BiFun
biFun)
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ BiFun -> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons)
[]
]
makeBiFun :: BiFun -> Options -> Name -> Q Exp
makeBiFun :: BiFun -> Options -> Name -> Q Exp
makeBiFun BiFun
biFun Options
opts Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} ->
BiClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance (BiFun -> BiClass
biFunToClass BiFun
biFun) Name
parentName Cxt
ctxt Cxt
instTys DatatypeVariant
variant
Q (Cxt, Type) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BiFun -> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons
makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
makeBiFunForCons :: BiFun -> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
_parentName Cxt
instTys [ConstructorInfo]
cons = do
Name
map1 <- String -> Q Name
newName String
"f"
Name
map2 <- String -> Q Name
newName String
"g"
Name
z <- String -> Q Name
newName String
"z"
Name
value <- String -> Q Name
newName String
"value"
let argNames :: [Name]
argNames = [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes [ Name -> Maybe Name
forall a. a -> Maybe a
Just Name
map1
, Name -> Maybe Name
forall a. a -> Maybe a
Just Name
map2
, Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BiFun
biFun BiFun -> BiFun -> Bool
forall a. Eq a => a -> a -> Bool
== BiFun
Bifoldr) Maybe () -> Maybe Name -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
z
, Name -> Maybe Name
forall a. a -> Maybe a
Just Name
value
]
lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTys Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Cxt
instTys
tvMap :: Map Name Name
tvMap = [(Name, Name)] -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Name)] -> Map Name Name)
-> [(Name, Name)] -> Map Name Name
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [Name
map1, Name
map2]
[PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
argNames)
(Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE
([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ BiFun -> Name
biFunConstName BiFun
biFun
, Name -> Name -> Map Name Name -> Q Exp
makeFun Name
z Name
value Map Name Name
tvMap
] [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
argNames
where
makeFun :: Name -> Name -> TyVarMap -> Q Exp
makeFun :: Name -> Name -> Map Name Name -> Q Exp
makeFun Name
z Name
value Map Name Name
tvMap = do
#if MIN_VERSION_template_haskell(2,9,0)
[Role]
roles <- Name -> Q [Role]
reifyRoles Name
_parentName
#endif
case () of
()
_
#if MIN_VERSION_template_haskell(2,9,0)
| Just ([Role]
rs, Role
PhantomR) <- [Role] -> Maybe ([Role], Role)
forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
roles
, Just ([Role]
_, Role
PhantomR) <- [Role] -> Maybe ([Role], Role)
forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
rs
-> Name -> Name -> Q Exp
biFunPhantom Name
z Name
value
#endif
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& Options -> Bool
emptyCaseBehavior Options
opts Bool -> Bool -> Bool
&& Bool
ghc7'8OrLater
-> BiFun -> Name -> Name -> Q Exp
biFunEmptyCase BiFun
biFun Name
z Name
value
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
-> BiFun -> Name -> Name -> Q Exp
biFunNoCons BiFun
biFun Name
z Name
value
| Bool
otherwise
-> Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value)
((ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (BiFun -> Name -> Map Name Name -> ConstructorInfo -> MatchQ
makeBiFunForCon BiFun
biFun Name
z Map Name Name
tvMap) [ConstructorInfo]
cons)
ghc7'8OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 708
ghc7'8OrLater :: Bool
ghc7'8OrLater = Bool
True
#else
ghc7'8OrLater = False
#endif
#if MIN_VERSION_template_haskell(2,9,0)
biFunPhantom :: Name -> Name -> Q Exp
biFunPhantom :: Name -> Name -> Q Exp
biFunPhantom Name
z Name
value =
Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial Q Exp
coerce
(Name -> Q Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
coerce)
BiFun
biFun Name
z
where
coerce :: Q Exp
coerce :: Q Exp
coerce = Name -> Q Exp
varE Name
coerceValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
value
#endif
makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match
makeBiFunForCon :: BiFun -> Name -> Map Name Name -> ConstructorInfo -> MatchQ
makeBiFunForCon BiFun
biFun Name
z Map Name Name
tvMap
con :: ConstructorInfo
con@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt }) = do
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` Map Name Name -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name Name
tvMap) Cxt
ctxt
Bool -> Bool -> Bool
|| Map Name Name -> Int
forall k a. Map k a -> Int
Map.size Map Name Name
tvMap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2)
Bool -> Bool -> Bool
&& Bool -> Bool
not (BiClass -> Bool
allowExQuant (BiFun -> BiClass
biFunToClass BiFun
biFun))) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
Name -> Q ()
forall a. Name -> Q a
existentialContextError Name
conName
case BiFun
biFun of
BiFun
Bimap -> Map Name Name -> ConstructorInfo -> MatchQ
makeBimapMatch Map Name Name
tvMap ConstructorInfo
con
BiFun
Bifoldr -> Name -> Map Name Name -> ConstructorInfo -> MatchQ
makeBifoldrMatch Name
z Map Name Name
tvMap ConstructorInfo
con
BiFun
BifoldMap -> Map Name Name -> ConstructorInfo -> MatchQ
makeBifoldMapMatch Map Name Name
tvMap ConstructorInfo
con
BiFun
Bitraverse -> Map Name Name -> ConstructorInfo -> MatchQ
makeBitraverseMatch Map Name Name
tvMap ConstructorInfo
con
makeBimapMatch :: TyVarMap -> ConstructorInfo -> Q Match
makeBimapMatch :: Map Name Name -> ConstructorInfo -> MatchQ
makeBimapMatch Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Exp -> Q Exp]
parts <- Map Name Name
-> FFoldType (Exp -> Q Exp) -> ConstructorInfo -> Q [Exp -> Q Exp]
forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType (Exp -> Q Exp)
ft_bimap ConstructorInfo
con
Name -> [Exp -> Q Exp] -> MatchQ
match_for_con Name
conName [Exp -> Q Exp]
parts
where
ft_bimap :: FFoldType (Exp -> Q Exp)
ft_bimap :: FFoldType (Exp -> Q Exp)
ft_bimap = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> ([(Type, a)] -> a)
-> a
-> ([TyVarBndrSpec] -> a -> a)
-> FFoldType a
FT { ft_triv :: Exp -> Q Exp
ft_triv = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return
, ft_var :: Name -> Exp -> Q Exp
ft_var = \Name
v Exp
x -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (Map Name Name
tvMap Map Name Name -> Name -> Name
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v) Exp -> Exp -> Exp
`AppE` Exp
x
, ft_fun :: (Exp -> Q Exp) -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_fun = \Exp -> Q Exp
g Exp -> Q Exp
h Exp
x -> (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
b -> do
Exp
gg <- Exp -> Q Exp
g Exp
b
Exp -> Q Exp
h (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
x Exp -> Exp -> Exp
`AppE` Exp
gg
, ft_tup :: TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
ft_tup = (Name -> [Exp -> Q Exp] -> MatchQ)
-> TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> MatchQ
match_for_con
, ft_ty_app :: [(Type, Exp -> Q Exp)] -> Exp -> Q Exp
ft_ty_app = \[(Type, Exp -> Q Exp)]
argGs Exp
x -> do
let inspect :: (Type, Exp -> Q Exp) -> Q Exp
inspect :: (Type, Exp -> Q Exp) -> Q Exp
inspect (Type
argTy, Exp -> Q Exp
g)
| Just Name
argVar <- Type -> Maybe Name
varTToName_maybe Type
argTy
, Just Name
f <- Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name Name
tvMap
= Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
f
| Bool
otherwise
= (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
g
[Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE (Int -> Name
fmapArity ([(Type, Exp -> Q Exp)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Exp -> Q Exp)]
argGs))
Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Type, Exp -> Q Exp) -> Q Exp)
-> [(Type, Exp -> Q Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Exp -> Q Exp) -> Q Exp
inspect [(Type, Exp -> Q Exp)]
argGs
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x]
, ft_forall :: [TyVarBndrSpec] -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_forall = \[TyVarBndrSpec]
_ Exp -> Q Exp
g Exp
x -> Exp -> Q Exp
g Exp
x
, ft_bad_app :: Exp -> Q Exp
ft_bad_app = \Exp
_ -> Name -> Q Exp
forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
, ft_co_var :: Name -> Exp -> Q Exp
ft_co_var = \Name
_ Exp
_ -> Name -> Q Exp
forall a. Name -> Q a
contravarianceError Name
conName
}
match_for_con :: Name -> [Exp -> Q Exp] -> Q Match
match_for_con :: Name -> [Exp -> Q Exp] -> MatchQ
match_for_con = (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ
forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> MatchQ
mkSimpleConMatch ((Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ)
-> (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \Name
conName' [Q Exp]
xs ->
[Q Exp] -> Q Exp
appsE (Name -> Q Exp
conE Name
conName'Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
xs)
makeBifoldrMatch :: Name -> TyVarMap -> ConstructorInfo -> Q Match
makeBifoldrMatch :: Name -> Map Name Name -> ConstructorInfo -> MatchQ
makeBifoldrMatch Name
z Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- Map Name Name
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType (Q (Bool, Exp))
ft_bifoldr ConstructorInfo
con
[(Bool, Exp)]
parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Exp -> Name -> [(Bool, Exp)] -> MatchQ
match_for_con (Name -> Exp
VarE Name
z) Name
conName [(Bool, Exp)]
parts'
where
ft_bifoldr :: FFoldType (Q (Bool, Exp))
ft_bifoldr :: FFoldType (Q (Bool, Exp))
ft_bifoldr = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> ([(Type, a)] -> a)
-> a
-> ([TyVarBndrSpec] -> a -> a)
-> FFoldType a
FT {
ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
_ Exp
z' -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
z'
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
, ft_var :: Name -> Q (Bool, Exp)
ft_var = \Name
v -> (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Map Name Name
tvMap Map Name Name -> Name -> Name
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v)
, ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup = \TupleSort
t [Q (Bool, Exp)]
gs -> do
[(Bool, Exp)]
gg <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' ->
(Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase (Exp -> Name -> [(Bool, Exp)] -> MatchQ
match_for_con Exp
z') TupleSort
t [(Bool, Exp)]
gg Exp
x
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
, ft_ty_app :: [(Type, Q (Bool, Exp))] -> Q (Bool, Exp)
ft_ty_app = \[(Type, Q (Bool, Exp))]
gs -> do
Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' ->
[Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE (Int -> Name
foldrArity ([(Type, Q (Bool, Exp))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Q (Bool, Exp))]
gs))
Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Type, Q (Bool, Exp)) -> Q Exp)
-> [(Type, Q (Bool, Exp))] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Type
_, Q (Bool, Exp)
hs) -> ((Bool, Exp) -> Exp) -> Q (Bool, Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Exp) -> Exp
forall a b. (a, b) -> b
snd Q (Bool, Exp)
hs) [(Type, Q (Bool, Exp))]
gs
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [Exp
z', Exp
x]
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
, ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall = \[TyVarBndrSpec]
_ Q (Bool, Exp)
g -> Q (Bool, Exp)
g
, ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var = \Name
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
, ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun = \Q (Bool, Exp)
_ Q (Bool, Exp)
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = Name -> Q (Bool, Exp)
forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
}
match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con :: Exp -> Name -> [(Bool, Exp)] -> MatchQ
match_for_con Exp
zExp = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkBifoldr [Exp]
xs
where
mkBifoldr :: [Exp] -> Exp
mkBifoldr :: [Exp] -> Exp
mkBifoldr = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
AppE Exp
zExp
makeBifoldMapMatch :: TyVarMap -> ConstructorInfo -> Q Match
makeBifoldMapMatch :: Map Name Name -> ConstructorInfo -> MatchQ
makeBifoldMapMatch Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- Map Name Name
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType (Q (Bool, Exp))
ft_bifoldMap ConstructorInfo
con
[(Bool, Exp)]
parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Name -> [(Bool, Exp)] -> MatchQ
match_for_con Name
conName [(Bool, Exp)]
parts'
where
ft_bifoldMap :: FFoldType (Q (Bool, Exp))
ft_bifoldMap :: FFoldType (Q (Bool, Exp))
ft_bifoldMap = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> ([(Type, a)] -> a)
-> a
-> ([TyVarBndrSpec] -> a -> a)
-> FFoldType a
FT {
ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
_ -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
memptyValName
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
, ft_var :: Name -> Q (Bool, Exp)
ft_var = \Name
v -> (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Map Name Name
tvMap Map Name Name -> Name -> Name
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v)
, ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup = \TupleSort
t [Q (Bool, Exp)]
gs -> do
[(Bool, Exp)]
gg <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
match_for_con TupleSort
t [(Bool, Exp)]
gg
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
, ft_ty_app :: [(Type, Q (Bool, Exp))] -> Q (Bool, Exp)
ft_ty_app = \[(Type, Q (Bool, Exp))]
gs -> do
Exp
e <- [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE (Int -> Name
foldMapArity ([(Type, Q (Bool, Exp))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Q (Bool, Exp))]
gs))
Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Type, Q (Bool, Exp)) -> Q Exp)
-> [(Type, Q (Bool, Exp))] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Type
_, Q (Bool, Exp)
hs) -> ((Bool, Exp) -> Exp) -> Q (Bool, Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Exp) -> Exp
forall a b. (a, b) -> b
snd Q (Bool, Exp)
hs) [(Type, Q (Bool, Exp))]
gs
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
e)
, ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall = \[TyVarBndrSpec]
_ Q (Bool, Exp)
g -> Q (Bool, Exp)
g
, ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var = \Name
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
, ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun = \Q (Bool, Exp)
_ Q (Bool, Exp)
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = Name -> Q (Bool, Exp)
forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
}
match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con :: Name -> [(Bool, Exp)] -> MatchQ
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkBifoldMap [Exp]
xs
where
mkBifoldMap :: [Exp] -> Exp
mkBifoldMap :: [Exp] -> Exp
mkBifoldMap [] = Name -> Exp
VarE Name
memptyValName
mkBifoldMap [Exp]
es = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
mappendValName)) [Exp]
es
makeBitraverseMatch :: TyVarMap -> ConstructorInfo -> Q Match
makeBitraverseMatch :: Map Name Name -> ConstructorInfo -> MatchQ
makeBitraverseMatch Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- Map Name Name
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType (Q (Bool, Exp))
ft_bitrav ConstructorInfo
con
[(Bool, Exp)]
parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Name -> [(Bool, Exp)] -> MatchQ
match_for_con Name
conName [(Bool, Exp)]
parts'
where
ft_bitrav :: FFoldType (Q (Bool, Exp))
ft_bitrav :: FFoldType (Q (Bool, Exp))
ft_bitrav = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> ([(Type, a)] -> a)
-> a
-> ([TyVarBndrSpec] -> a -> a)
-> FFoldType a
FT {
ft_triv :: Q (Bool, Exp)
ft_triv = (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Name -> Exp
VarE Name
pureValName)
, ft_var :: Name -> Q (Bool, Exp)
ft_var = \Name
v -> (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Map Name Name
tvMap Map Name Name -> Name -> Name
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v)
, ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup = \TupleSort
t [Q (Bool, Exp)]
gs -> do
[(Bool, Exp)]
gg <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
match_for_con TupleSort
t [(Bool, Exp)]
gg
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
, ft_ty_app :: [(Type, Q (Bool, Exp))] -> Q (Bool, Exp)
ft_ty_app = \[(Type, Q (Bool, Exp))]
gs -> do
Exp
e <- [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE (Int -> Name
traverseArity ([(Type, Q (Bool, Exp))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Q (Bool, Exp))]
gs))
Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Type, Q (Bool, Exp)) -> Q Exp)
-> [(Type, Q (Bool, Exp))] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Type
_, Q (Bool, Exp)
hs) -> ((Bool, Exp) -> Exp) -> Q (Bool, Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Exp) -> Exp
forall a b. (a, b) -> b
snd Q (Bool, Exp)
hs) [(Type, Q (Bool, Exp))]
gs
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
e)
, ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall = \[TyVarBndrSpec]
_ Q (Bool, Exp)
g -> Q (Bool, Exp)
g
, ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var = \Name
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
, ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun = \Q (Bool, Exp)
_ Q (Bool, Exp)
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = Name -> Q (Bool, Exp)
forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
}
match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con :: Name -> [(Bool, Exp)] -> MatchQ
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \Exp
conExp [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Exp] -> Exp
mkApCon Exp
conExp [Exp]
xs
where
mkApCon :: Exp -> [Exp] -> Exp
mkApCon :: Exp -> [Exp] -> Exp
mkApCon Exp
conExp [] = Name -> Exp
VarE Name
pureValName Exp -> Exp -> Exp
`AppE` Exp
conExp
mkApCon Exp
conExp [Exp
e] = Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
conExp Exp -> Exp -> Exp
`AppE` Exp
e
mkApCon Exp
conExp (Exp
e1:Exp
e2:[Exp]
es) = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
appAp
(Name -> Exp
VarE Name
liftA2ValName Exp -> Exp -> Exp
`AppE` Exp
conExp Exp -> Exp -> Exp
`AppE` Exp
e1 Exp -> Exp -> Exp
`AppE` Exp
e2) [Exp]
es
where appAp :: Exp -> Exp -> Exp
appAp Exp
se1 Exp
se2 = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
se1) (Name -> Exp
VarE Name
apValName) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
se2)
buildTypeInstance :: BiClass
-> Name
-> Cxt
-> [Type]
-> DatatypeVariant
-> Q (Cxt, Type)
buildTypeInstance :: BiClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance BiClass
biClass Name
tyConName Cxt
dataCxt Cxt
instTysOrig DatatypeVariant
variant = do
Cxt
varTysExp <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
instTysOrig
let remainingLength :: Int
remainingLength :: Int
remainingLength = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2
droppedTysExp :: [Type]
droppedTysExp :: Cxt
droppedTysExp = Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop Int
remainingLength Cxt
varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> Cxt -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Type -> 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
< Int
0 Bool -> Bool -> Bool
|| (StarKindStatus -> Bool) -> [StarKindStatus] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (StarKindStatus -> StarKindStatus -> Bool
forall a. Eq a => a -> a -> Bool
== StarKindStatus
NotKindStar) [StarKindStatus]
droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
BiClass -> Name -> Q ()
forall a. BiClass -> Name -> Q a
derivingKindError BiClass
biClass Name
tyConName
let droppedKindVarNames :: [Name]
droppedKindVarNames :: [Name]
droppedKindVarNames = [StarKindStatus] -> [Name]
catKindVarNames [StarKindStatus]
droppedStarKindStati
varTysExpSubst :: [Type]
varTysExpSubst :: Cxt
varTysExpSubst = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
droppedKindVarNames) Cxt
varTysExp
remainingTysExpSubst, droppedTysExpSubst :: [Type]
(Cxt
remainingTysExpSubst, Cxt
droppedTysExpSubst) =
Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength Cxt
varTysExpSubst
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 ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasKindStar Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
BiClass -> Name -> Q ()
forall a. BiClass -> Name -> Q a
derivingKindError BiClass
biClass Name
tyConName
let preds :: [Maybe Pred]
kvNames :: [[Name]]
kvNames' :: [Name]
([Maybe Type]
preds, [[Name]]
kvNames) = [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Type, [Name])] -> ([Maybe Type], [[Name]]))
-> [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. (a -> b) -> a -> b
$ (Type -> (Maybe Type, [Name])) -> Cxt -> [(Maybe Type, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (BiClass -> Type -> (Maybe Type, [Name])
deriveConstraint BiClass
biClass) Cxt
remainingTysExpSubst
kvNames' :: [Name]
kvNames' = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
kvNames
remainingTysExpSubst' :: [Type]
remainingTysExpSubst' :: Cxt
remainingTysExpSubst' =
(Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
kvNames') Cxt
remainingTysExpSubst
remainingTysOrigSubst :: [Type]
remainingTysOrigSubst :: Cxt
remainingTysOrigSubst =
(Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
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
instTysOrig
isDataFamily :: Bool
isDataFamily :: Bool
isDataFamily = case DatatypeVariant
variant of
DatatypeVariant
Datatype -> Bool
False
DatatypeVariant
Newtype -> Bool
False
DatatypeVariant
DataInstance -> Bool
True
DatatypeVariant
NewtypeInstance -> Bool
True
remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' :: Cxt
remainingTysOrigSubst' =
if Bool
isDataFamily
then Cxt
remainingTysOrigSubst
else (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT Cxt
remainingTysOrigSubst
instanceCxt :: Cxt
instanceCxt :: Cxt
instanceCxt = [Maybe Type] -> Cxt
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
preds
instanceType :: Type
instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ BiClass -> Name
biClassName BiClass
biClass)
(Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Type
applyTyCon Name
tyConName Cxt
remainingTysOrigSubst'
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) Cxt
dataCxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
Name -> Type -> Q ()
forall a. Name -> Type -> Q a
datatypeContextError Name
tyConName Type
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
$
Type -> Q ()
forall a. Type -> Q a
etaReductionError Type
instanceType
(Cxt, Type) -> Q (Cxt, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt
instanceCxt, Type
instanceType)
deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name])
deriveConstraint :: BiClass -> Type -> (Maybe Type, [Name])
deriveConstraint BiClass
biClass Type
t
| Bool -> Bool
not (Type -> Bool
isTyVar Type
t) = (Maybe Type
forall a. Maybe a
Nothing, [])
| Bool
otherwise = case Int -> Type -> Maybe [Name]
hasKindVarChain Int
1 Type
t of
Just [Name]
ns -> ((Name -> Name -> Type
`applyClass` Name
tName) (Name -> Type) -> Maybe Name -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` BiClass -> Int -> Maybe Name
biClassConstraint BiClass
biClass Int
1, [Name]
ns)
Maybe [Name]
_ -> case Int -> Type -> Maybe [Name]
hasKindVarChain Int
2 Type
t of
Just [Name]
ns -> ((Name -> Name -> Type
`applyClass` Name
tName) (Name -> Type) -> Maybe Name -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` BiClass -> Int -> Maybe Name
biClassConstraint BiClass
biClass Int
2, [Name]
ns)
Maybe [Name]
_ -> (Maybe Type
forall a. Maybe a
Nothing, [])
where
tName :: Name
tName :: Name
tName = Type -> Name
varTToName Type
t
derivingKindError :: BiClass -> Name -> Q a
derivingKindError :: BiClass -> Name -> Q a
derivingKindError BiClass
biClass Name
tyConName = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Cannot derive well-kinded instance of form ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS -> ShowS
showParen Bool
True
( String -> ShowS
showString (Name -> String
nameBase Name
tyConName)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ..."
)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘\n\tClass "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" expects an argument of kind * -> * -> *"
(String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
where
className :: String
className :: String
className = Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ BiClass -> Name
biClassName BiClass
biClass
contravarianceError :: Name -> Q a
contravarianceError :: Name -> Q a
contravarianceError Name
conName = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must not use the last type variable(s) in a function argument"
(String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
noFunctionsError :: Name -> Q a
noFunctionsError :: Name -> Q a
noFunctionsError Name
conName = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must not contain function types"
(String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
datatypeContextError :: Name -> Type -> Q a
datatypeContextError :: Name -> Type -> Q a
datatypeContextError Name
dataName Type
instanceType = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Can't make a derived instance of ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceType)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘:\n\tData type ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
dataName)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must not have a class context involving the last type argument(s)"
(String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
existentialContextError :: Name -> Q a
existentialContextError :: Name -> Q a
existentialContextError Name
conName = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must be truly polymorphic in the last argument(s) of the data type"
(String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
outOfPlaceTyVarError :: Name -> Q a
outOfPlaceTyVarError :: Name -> Q a
outOfPlaceTyVarError Name
conName = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must only use its last two type variable(s) within"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" the last two argument(s) of a data type"
(String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
etaReductionError :: Type -> Q a
etaReductionError :: Type -> Q a
etaReductionError Type
instanceType = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$
String
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceType
data BiClass = Bifunctor | Bifoldable | Bitraversable
data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse
deriving BiFun -> BiFun -> Bool
(BiFun -> BiFun -> Bool) -> (BiFun -> BiFun -> Bool) -> Eq BiFun
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BiFun -> BiFun -> Bool
$c/= :: BiFun -> BiFun -> Bool
== :: BiFun -> BiFun -> Bool
$c== :: BiFun -> BiFun -> Bool
Eq
biFunConstName :: BiFun -> Name
biFunConstName :: BiFun -> Name
biFunConstName BiFun
Bimap = Name
bimapConstValName
biFunConstName BiFun
Bifoldr = Name
bifoldrConstValName
biFunConstName BiFun
BifoldMap = Name
bifoldMapConstValName
biFunConstName BiFun
Bitraverse = Name
bitraverseConstValName
biClassName :: BiClass -> Name
biClassName :: BiClass -> Name
biClassName BiClass
Bifunctor = Name
bifunctorTypeName
biClassName BiClass
Bifoldable = Name
bifoldableTypeName
biClassName BiClass
Bitraversable = Name
bitraversableTypeName
biFunName :: BiFun -> Name
biFunName :: BiFun -> Name
biFunName BiFun
Bimap = Name
bimapValName
biFunName BiFun
Bifoldr = Name
bifoldrValName
biFunName BiFun
BifoldMap = Name
bifoldMapValName
biFunName BiFun
Bitraverse = Name
bitraverseValName
biClassToFuns :: BiClass -> [BiFun]
biClassToFuns :: BiClass -> [BiFun]
biClassToFuns BiClass
Bifunctor = [BiFun
Bimap]
biClassToFuns BiClass
Bifoldable = [BiFun
Bifoldr, BiFun
BifoldMap]
biClassToFuns BiClass
Bitraversable = [BiFun
Bitraverse]
biFunToClass :: BiFun -> BiClass
biFunToClass :: BiFun -> BiClass
biFunToClass BiFun
Bimap = BiClass
Bifunctor
biFunToClass BiFun
Bifoldr = BiClass
Bifoldable
biFunToClass BiFun
BifoldMap = BiClass
Bifoldable
biFunToClass BiFun
Bitraverse = BiClass
Bitraversable
biClassConstraint :: BiClass -> Int -> Maybe Name
biClassConstraint :: BiClass -> Int -> Maybe Name
biClassConstraint BiClass
Bifunctor Int
1 = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
functorTypeName
biClassConstraint BiClass
Bifoldable Int
1 = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
foldableTypeName
biClassConstraint BiClass
Bitraversable Int
1 = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
traversableTypeName
biClassConstraint BiClass
biClass Int
2 = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ BiClass -> Name
biClassName BiClass
biClass
biClassConstraint BiClass
_ Int
_ = Maybe Name
forall a. Maybe a
Nothing
fmapArity :: Int -> Name
fmapArity :: Int -> Name
fmapArity Int
1 = Name
fmapValName
fmapArity Int
2 = Name
bimapValName
fmapArity Int
n = Int -> Name
forall a. Int -> a
arityErr Int
n
foldrArity :: Int -> Name
foldrArity :: Int -> Name
foldrArity Int
1 = Name
foldrValName
foldrArity Int
2 = Name
bifoldrValName
foldrArity Int
n = Int -> Name
forall a. Int -> a
arityErr Int
n
foldMapArity :: Int -> Name
foldMapArity :: Int -> Name
foldMapArity Int
1 = Name
foldMapValName
foldMapArity Int
2 = Name
bifoldMapValName
foldMapArity Int
n = Int -> Name
forall a. Int -> a
arityErr Int
n
traverseArity :: Int -> Name
traverseArity :: Int -> Name
traverseArity Int
1 = Name
traverseValName
traverseArity Int
2 = Name
bitraverseValName
traverseArity Int
n = Int -> Name
forall a. Int -> a
arityErr Int
n
arityErr :: Int -> a
arityErr :: Int -> a
arityErr Int
n = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Unsupported arity: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
allowExQuant :: BiClass -> Bool
allowExQuant :: BiClass -> Bool
allowExQuant BiClass
Bifoldable = Bool
True
allowExQuant BiClass
_ = Bool
False
biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
biFunEmptyCase BiFun
biFun Name
z Name
value =
Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial Q Exp
emptyCase
(Name -> Q Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
emptyCase)
BiFun
biFun Name
z
where
emptyCase :: Q Exp
emptyCase :: Q Exp
emptyCase = Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value) []
biFunNoCons :: BiFun -> Name -> Name -> Q Exp
biFunNoCons :: BiFun -> Name -> Name -> Q Exp
biFunNoCons BiFun
biFun Name
z Name
value =
Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial Q Exp
seqAndError
(Name -> Q Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
seqAndError)
BiFun
biFun Name
z
where
seqAndError :: Q Exp
seqAndError :: Q Exp
seqAndError = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
seqValName) (Name -> Q Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
`appE`
Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
errorValName)
(String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Void " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (BiFun -> Name
biFunName BiFun
biFun))
biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial Q Exp
bimapE Q Exp
bitraverseE BiFun
biFun Name
z = BiFun -> Q Exp
go BiFun
biFun
where
go :: BiFun -> Q Exp
go :: BiFun -> Q Exp
go BiFun
Bimap = Q Exp
bimapE
go BiFun
Bifoldr = Name -> Q Exp
varE Name
z
go BiFun
BifoldMap = Name -> Q Exp
varE Name
memptyValName
go BiFun
Bitraverse = Q Exp
bitraverseE
data FFoldType a
= FT { FFoldType a -> a
ft_triv :: a
, FFoldType a -> Name -> a
ft_var :: Name -> a
, FFoldType a -> Name -> a
ft_co_var :: Name -> a
, FFoldType a -> a -> a -> a
ft_fun :: a -> a -> a
, FFoldType a -> TupleSort -> [a] -> a
ft_tup :: TupleSort -> [a] -> a
, FFoldType a -> [(Type, a)] -> a
ft_ty_app :: [(Type, a)] -> a
, FFoldType a -> a
ft_bad_app :: a
, FFoldType a -> [TyVarBndrSpec] -> a -> a
ft_forall :: [TyVarBndrSpec] -> a -> a
}
functorLikeTraverse :: forall a.
TyVarMap
-> FFoldType a
-> Type
-> Q a
functorLikeTraverse :: Map Name Name -> FFoldType a -> Type -> Q a
functorLikeTraverse Map Name Name
tvMap (FT { ft_triv :: forall a. FFoldType a -> a
ft_triv = a
caseTrivial, ft_var :: forall a. FFoldType a -> Name -> a
ft_var = Name -> a
caseVar
, ft_co_var :: forall a. FFoldType a -> Name -> a
ft_co_var = Name -> a
caseCoVar, ft_fun :: forall a. FFoldType a -> a -> a -> a
ft_fun = a -> a -> a
caseFun
, ft_tup :: forall a. FFoldType a -> TupleSort -> [a] -> a
ft_tup = TupleSort -> [a] -> a
caseTuple, ft_ty_app :: forall a. FFoldType a -> [(Type, a)] -> a
ft_ty_app = [(Type, a)] -> a
caseTyApp
, ft_bad_app :: forall a. FFoldType a -> a
ft_bad_app = a
caseWrongArg, ft_forall :: forall a. FFoldType a -> [TyVarBndrSpec] -> a -> a
ft_forall = [TyVarBndrSpec] -> a -> a
caseForAll })
Type
ty
= do Type
ty' <- Type -> TypeQ
resolveTypeSynonyms Type
ty
(a
res, Bool
_) <- Bool -> Type -> Q (a, Bool)
go Bool
False Type
ty'
a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
where
go :: Bool
-> Type
-> Q (a, Bool)
go :: Bool -> Type -> Q (a, Bool)
go Bool
co t :: Type
t@AppT{}
| (Type
ArrowT, [Type
funArg, Type
funRes]) <- Type -> (Type, Cxt)
unapplyTy Type
t
= do (a
funArgR, Bool
funArgC) <- Bool -> Type -> Q (a, Bool)
go (Bool -> Bool
not Bool
co) Type
funArg
(a
funResR, Bool
funResC) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
funRes
if Bool
funArgC Bool -> Bool -> Bool
|| Bool
funResC
then (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a -> a
caseFun a
funArgR a
funResR, Bool
True)
else Q (a, Bool)
trivial
go Bool
co t :: Type
t@AppT{} = do
let (Type
f, Cxt
args) = Type -> (Type, Cxt)
unapplyTy Type
t
(a
_, Bool
fc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
f
([a]
xrs, [Bool]
xcs) <- ([(a, Bool)] -> ([a], [Bool])) -> Q [(a, Bool)] -> Q ([a], [Bool])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, Bool)] -> ([a], [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(a, Bool)] -> Q ([a], [Bool]))
-> Q [(a, Bool)] -> Q ([a], [Bool])
forall a b. (a -> b) -> a -> b
$ (Type -> Q (a, Bool)) -> Cxt -> Q [(a, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Type -> Q (a, Bool)
go Bool
co) Cxt
args
let numLastArgs, numFirstArgs :: Int
numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
2 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
args
numFirstArgs :: Int
numFirstArgs = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs
tuple :: TupleSort -> Q (a, Bool)
tuple :: TupleSort -> Q (a, Bool)
tuple TupleSort
tupSort = (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (TupleSort -> [a] -> a
caseTuple TupleSort
tupSort [a]
xrs, Bool
True)
wrongArg :: Q (a, Bool)
wrongArg :: Q (a, Bool)
wrongArg = (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseWrongArg, Bool
True)
case () of
()
_ | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xcs)
-> Q (a, Bool)
trivial
| TupleT Int
len <- Type
f
-> TupleSort -> Q (a, Bool)
tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Boxed Int
len
#if MIN_VERSION_template_haskell(2,6,0)
| UnboxedTupleT Int
len <- Type
f
-> TupleSort -> Q (a, Bool)
tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Unboxed Int
len
#endif
| Bool
fc Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
take Int
numFirstArgs [Bool]
xcs)
-> Q (a, Bool)
wrongArg
| Bool
otherwise
-> do Bool
itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
f Cxt
args
if Bool
itf
then Q (a, Bool)
wrongArg
else (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [(Type, a)] -> a
caseTyApp ([(Type, a)] -> a) -> [(Type, a)] -> a
forall a b. (a -> b) -> a -> b
$ Int -> [(Type, a)] -> [(Type, a)]
forall a. Int -> [a] -> [a]
drop Int
numFirstArgs ([(Type, a)] -> [(Type, a)]) -> [(Type, a)] -> [(Type, a)]
forall a b. (a -> b) -> a -> b
$ Cxt -> [a] -> [(Type, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
args [a]
xrs
, Bool
True )
go Bool
co (SigT Type
t Type
k) = do
(a
_, Bool
kc) <- Bool -> Type -> Q (a, Bool)
go_kind Bool
co Type
k
if Bool
kc
then (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseWrongArg, Bool
True)
else Bool -> Type -> Q (a, Bool)
go Bool
co Type
t
go Bool
co (VarT Name
v)
| Name -> Map Name Name -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
v Map Name Name
tvMap
= (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
co then Name -> a
caseCoVar Name
v else Name -> a
caseVar Name
v, Bool
True)
| Bool
otherwise
= Q (a, Bool)
trivial
go Bool
co (ForallT [TyVarBndrSpec]
tvbs Cxt
_ Type
t) = do
(a
tr, Bool
tc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
t
let tvbNames :: [Name]
tvbNames = (TyVarBndrSpec -> Name) -> [TyVarBndrSpec] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrSpec -> Name
forall flag. TyVarBndrSpec -> Name
tvName [TyVarBndrSpec]
tvbs
if Bool -> Bool
not Bool
tc Bool -> Bool -> Bool
|| (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
tvbNames) [Name]
tyVarNames
then Q (a, Bool)
trivial
else (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndrSpec] -> a -> a
caseForAll [TyVarBndrSpec]
tvbs a
tr, Bool
True)
go Bool
_ Type
_ = Q (a, Bool)
trivial
go_kind :: Bool
-> Kind
-> Q (a, Bool)
#if MIN_VERSION_template_haskell(2,9,0)
go_kind :: Bool -> Type -> Q (a, Bool)
go_kind = Bool -> Type -> Q (a, Bool)
go
#else
go_kind _ _ = trivial
#endif
trivial :: Q (a, Bool)
trivial :: Q (a, Bool)
trivial = (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseTrivial, Bool
False)
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = Map Name Name -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name Name
tvMap
foldDataConArgs :: forall a. TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs :: Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType a
ft ConstructorInfo
con = do
Cxt
fieldTys <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms (Cxt -> CxtQ) -> Cxt -> CxtQ
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Cxt
constructorFields ConstructorInfo
con
(Type -> Q a) -> Cxt -> Q [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q a
foldArg Cxt
fieldTys
where
foldArg :: Type -> Q a
foldArg :: Type -> Q a
foldArg = Map Name Name -> FFoldType a -> Type -> Q a
forall a. Map Name Name -> FFoldType a -> Type -> Q a
functorLikeTraverse Map Name Name
tvMap FFoldType a
ft
mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
lam = do
Name
n <- String -> Q Name
newName String
"_n"
Exp
body <- Exp -> Q Exp
lam (Name -> Exp
VarE Name
n)
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
n] Exp
body
mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 Exp -> Exp -> Q Exp
lam = do
Name
n1 <- String -> Q Name
newName String
"_n1"
Name
n2 <- String -> Q Name
newName String
"n2"
Exp
body <- Exp -> Exp -> Q Exp
lam (Name -> Exp
VarE Name
n1) (Name -> Exp
VarE Name
n2)
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
n1, Name -> Pat
VarP Name
n2] Exp
body
mkSimpleConMatch :: (Name -> [a] -> Q Exp)
-> Name
-> [Exp -> a]
-> Q Match
mkSimpleConMatch :: (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> MatchQ
mkSimpleConMatch Name -> [a] -> Q Exp
fold Name
conName [Exp -> a]
insides = do
[Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList String
"_arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Exp -> a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp -> a]
insides
let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
Exp
rhs <- Name -> [a] -> Q Exp
fold Name
conName (((Exp -> a) -> Name -> a) -> [Exp -> a] -> [Name] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Exp -> a
i Name
v -> Exp -> a
i (Exp -> a) -> Exp -> a
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
v) [Exp -> a]
insides [Name]
varsNeeded)
Match -> MatchQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> MatchQ) -> Match -> MatchQ
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
rhs) []
mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp)
-> Name
-> [(Bool, Exp)]
-> Q Match
mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 Exp -> [Exp] -> Q Exp
fold Name
conName [(Bool, Exp)]
insides = do
[Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList String
"_arg" Int
lengthInsides
let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
exps :: [Exp]
exps = [Maybe Exp] -> [Exp]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Exp] -> [Exp]) -> [Maybe Exp] -> [Exp]
forall a b. (a -> b) -> a -> b
$ ((Bool, Exp) -> Name -> Maybe Exp)
-> [(Bool, Exp)] -> [Name] -> [Maybe Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Bool
m, Exp
i) Name
v -> if Bool
m then Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp
i Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
v)
else Maybe Exp
forall a. Maybe a
Nothing)
[(Bool, Exp)]
insides [Name]
varsNeeded
argTysTyVarInfo :: [Bool]
argTysTyVarInfo = ((Bool, Exp) -> Bool) -> [(Bool, Exp)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
m, Exp
_) -> Bool
m) [(Bool, Exp)]
insides
([Name]
asWithTyVar, [Name]
asWithoutTyVar) = [Bool] -> [Name] -> ([Name], [Name])
forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo [Name]
varsNeeded
conExpQ :: Q Exp
conExpQ
| [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
asWithTyVar = [Q Exp] -> Q Exp
appsE (Name -> Q Exp
conE Name
conNameQ Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:(Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
asWithoutTyVar)
| Bool
otherwise = do
[Name]
bs <- String -> Int -> Q [Name]
newNameList String
"b" Int
lengthInsides
let bs' :: [Name]
bs' = [Bool] -> [Name] -> [Name]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
argTysTyVarInfo [Name]
bs
vars :: [Q Exp]
vars = [Bool] -> [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
argTysTyVarInfo
((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
bs) ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
varsNeeded)
[PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
bs') ([Q Exp] -> Q Exp
appsE (Name -> Q Exp
conE Name
conNameQ Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
vars))
Exp
conExp <- Q Exp
conExpQ
Exp
rhs <- Exp -> [Exp] -> Q Exp
fold Exp
conExp [Exp]
exps
Match -> MatchQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> MatchQ) -> Match -> MatchQ
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
rhs) []
where
lengthInsides :: Int
lengthInsides = [(Bool, Exp)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Exp)]
insides
data TupleSort
= Boxed Int
#if MIN_VERSION_template_haskell(2,6,0)
| Unboxed Int
#endif
mkSimpleTupleCase :: (Name -> [a] -> Q Match)
-> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase :: (Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [a] -> MatchQ
matchForCon TupleSort
tupSort [a]
insides Exp
x = do
let tupDataName :: Name
tupDataName = case TupleSort
tupSort of
Boxed Int
len -> Int -> Name
tupleDataName Int
len
#if MIN_VERSION_template_haskell(2,6,0)
Unboxed Int
len -> Int -> Name
unboxedTupleDataName Int
len
#endif
Match
m <- Name -> [a] -> MatchQ
matchForCon Name
tupDataName [a]
insides
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
x [Match
m]