{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Unsafe #-}
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 qualified Data.List as List
import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size)
import Data.Maybe
import Language.Haskell.TH.Datatype as 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
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
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
Ord, ReadPrec [Options]
ReadPrec Options
Int -> ReadS Options
ReadS [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
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 { 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 = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Options -> Name -> Q Exp
makeBifoldMapOptions Options
opts Name
name
, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
idValName
, forall (m :: * -> *). Quote m => Name -> m 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
Name
g <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"g"
Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
Name
t <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
g, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
appEndoValName
, forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
getDualValName
, forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Options -> Name -> Q Exp
makeBifoldMapOptions Options
opts Name
name
, Name -> Q Exp
foldFun Name
f
, Name -> Q Exp
foldFun Name
g
, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t]
]
, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z
]
where
foldFun :: Name -> Q Exp
foldFun :: Name -> Q Exp
foldFun Name
n = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
dualDataName)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
(forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
endoDataName)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
flipValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Options -> Name -> Q Exp
makeBitraverseOptions Options
opts Name
name
, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
idValName
, forall (m :: * -> *). Quote m => Name -> m 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
Name
g <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"g"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
g] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unwrapMonadValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => [m Exp] -> m 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 = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
wrapMonadDataName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName) (forall (m :: * -> *). Quote m => Name -> m 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 = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Options -> Name -> Q Exp
makeBimapMOptions Options
opts Name
name
, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
idValName
, forall (m :: * -> *). Quote m => Name -> m 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 -> [Type]
datatypeContext = [Type]
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTys
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
([Type]
instanceCxt, Type
instanceType)
<- BiClass
-> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
buildTypeInstance BiClass
biClass Name
parentName [Type]
ctxt [Type]
instTys DatatypeVariant
variant
(forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
instanceCxt)
(forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(BiClass
-> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
biFunDecs BiClass
biClass Options
opts Name
parentName [Type]
instTys [ConstructorInfo]
cons)
biFunDecs :: BiClass -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
biFunDecs :: BiClass
-> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
biFunDecs BiClass
biClass Options
opts Name
parentName [Type]
instTys [ConstructorInfo]
cons =
forall a b. (a -> b) -> [a] -> [b]
map BiFun -> Q Dec
makeFunD forall a b. (a -> b) -> a -> b
$ BiClass -> [BiFun]
biClassToFuns BiClass
biClass
where
makeFunD :: BiFun -> Q Dec
makeFunD :: BiFun -> Q Dec
makeFunD BiFun
biFun =
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (BiFun -> Name
biFunName BiFun
biFun)
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
parentName [Type]
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 -> [Type]
datatypeContext = [Type]
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTys
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} ->
BiClass
-> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
buildTypeInstance (BiFun -> BiClass
biFunToClass BiFun
biFun) Name
parentName [Type]
ctxt [Type]
instTys DatatypeVariant
variant
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
parentName [Type]
instTys [ConstructorInfo]
cons
makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
_parentName [Type]
instTys [ConstructorInfo]
cons = do
Name
map1 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
Name
map2 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"g"
Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
Name
value <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
let argNames :: [Name]
argNames = forall a. [Maybe a] -> [a]
catMaybes [ forall a. a -> Maybe a
Just Name
map1
, forall a. a -> Maybe a
Just Name
map2
, forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BiFun
biFun forall a. Eq a => a -> a -> Bool
== BiFun
Bifoldr) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just Name
z
, forall a. a -> Maybe a
Just Name
value
]
lastTyVars :: [Name]
lastTyVars = forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
instTys forall a. Num a => a -> a -> a
- Int
2) [Type]
instTys
tvMap :: Map Name Name
tvMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [Name
map1, Name
map2]
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
argNames)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE 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
] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m 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
[Role]
roles <- Name -> Q [Role]
reifyRoles Name
_parentName
case () of
()
_ | Just ([Role]
rs, Role
PhantomR) <- forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
roles
, Just ([Role]
_, Role
PhantomR) <- forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
rs
-> Name -> Name -> Q Exp
biFunPhantom Name
z Name
value
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& Options -> Bool
emptyCaseBehavior Options
opts
-> BiFun -> Name -> Name -> Q Exp
biFunEmptyCase BiFun
biFun Name
z Name
value
| 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
-> forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value)
(forall a b. (a -> b) -> [a] -> [b]
map (BiFun -> Name -> Map Name Name -> ConstructorInfo -> Q Match
makeBiFunForCon BiFun
biFun Name
z Map Name Name
tvMap) [ConstructorInfo]
cons)
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
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
coerce)
BiFun
biFun Name
z
where
coerce :: Q Exp
coerce :: Q Exp
coerce = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
coerceValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value
makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match
makeBiFunForCon :: BiFun -> Name -> Map Name Name -> ConstructorInfo -> Q Match
makeBiFunForCon BiFun
biFun Name
z Map Name Name
tvMap
con :: ConstructorInfo
con@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt }) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` forall k a. Map k a -> [k]
Map.keys Map Name Name
tvMap) [Type]
ctxt
Bool -> Bool -> Bool
|| forall k a. Map k a -> Int
Map.size Map Name Name
tvMap forall a. Ord a => a -> a -> Bool
< Int
2)
Bool -> Bool -> Bool
&& Bool -> Bool
not (BiClass -> Bool
allowExQuant (BiFun -> BiClass
biFunToClass BiFun
biFun))) forall a b. (a -> b) -> a -> b
$
forall a. Name -> Q a
existentialContextError Name
conName
case BiFun
biFun of
BiFun
Bimap -> Map Name Name -> ConstructorInfo -> Q Match
makeBimapMatch Map Name Name
tvMap ConstructorInfo
con
BiFun
Bifoldr -> Name -> Map Name Name -> ConstructorInfo -> Q Match
makeBifoldrMatch Name
z Map Name Name
tvMap ConstructorInfo
con
BiFun
BifoldMap -> Map Name Name -> ConstructorInfo -> Q Match
makeBifoldMapMatch Map Name Name
tvMap ConstructorInfo
con
BiFun
Bitraverse -> Map Name Name -> ConstructorInfo -> Q Match
makeBitraverseMatch Map Name Name
tvMap ConstructorInfo
con
makeBimapMatch :: TyVarMap -> ConstructorInfo -> Q Match
makeBimapMatch :: Map Name Name -> ConstructorInfo -> Q Match
makeBimapMatch Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Exp -> Q Exp]
parts <- 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] -> Q Match
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 { ft_triv :: Exp -> Q Exp
ft_triv = forall (m :: * -> *) a. Monad m => a -> m a
return
, ft_var :: Name -> Exp -> Q Exp
ft_var = \Name
v Exp
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (Map Name Name
tvMap 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 forall a b. (a -> b) -> a -> b
$ \Exp
b -> do
Exp
gg <- Exp -> Q Exp
g Exp
b
Exp -> Q Exp
h 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 = forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> Q Match
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 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name Name
tvMap
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
f
| Bool
otherwise
= (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
g
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> Name
fmapArity (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Exp -> Q Exp)]
argGs))
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Type, Exp -> Q Exp) -> Q Exp
inspect [(Type, Exp -> Q Exp)]
argGs
forall a. [a] -> [a] -> [a]
++ [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
_ -> forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
, ft_co_var :: Name -> Exp -> Q Exp
ft_co_var = \Name
_ 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] -> Q Match
match_for_con = forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match
mkSimpleConMatch forall a b. (a -> b) -> a -> b
$ \Name
conName' [Q Exp]
xs ->
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName'forall a. a -> [a] -> [a]
:[Q Exp]
xs)
makeBifoldrMatch :: Name -> TyVarMap -> ConstructorInfo -> Q Match
makeBifoldrMatch :: Name -> Map Name Name -> ConstructorInfo -> Q Match
makeBifoldrMatch Name
z Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- 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' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Exp -> Name -> [(Bool, Exp)] -> Q Match
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 {
ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 forall a b. (a -> b) -> a -> b
$ \Exp
_ Exp
z' -> forall (m :: * -> *) a. Monad m => a -> m a
return Exp
z'
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
, ft_var :: Name -> Q (Bool, Exp)
ft_var = \Name
v -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ Map Name Name
tvMap 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 <- 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 forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' ->
forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase (Exp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con Exp
z') TupleSort
t [(Bool, Exp)]
gg Exp
x
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 forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' ->
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> Name
foldrArity (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Q (Bool, Exp))]
gs))
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\(Type
_, Q (Bool, Exp)
hs) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Q (Bool, Exp)
hs) [(Type, Q (Bool, Exp))]
gs
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return [Exp
z', Exp
x]
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
_ -> 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)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
}
match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con Exp
zExp = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkBifoldr [Exp]
xs
where
mkBifoldr :: [Exp] -> Exp
mkBifoldr :: [Exp] -> Exp
mkBifoldr = 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 -> Q Match
makeBifoldMapMatch Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- 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' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Name -> [(Bool, Exp)] -> Q Match
match_for_con Name
conName [(Bool, Exp)]
parts'
where
ft_bifoldMap :: FFoldType (Q (Bool, Exp))
ft_bifoldMap :: FFoldType (Q (Bool, Exp))
ft_bifoldMap = FT {
ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam forall a b. (a -> b) -> a -> b
$ \Exp
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
memptyValName
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
, ft_var :: Name -> Q (Bool, Exp)
ft_var = \Name
v -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ Map Name Name
tvMap 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 <- 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 forall a b. (a -> b) -> a -> b
$ forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> Q Match
match_for_con TupleSort
t [(Bool, Exp)]
gg
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 <- forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> Name
foldMapArity (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Q (Bool, Exp))]
gs))
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\(Type
_, Q (Bool, Exp)
hs) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Q (Bool, Exp)
hs) [(Type, Q (Bool, Exp))]
gs
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
_ -> 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)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
}
match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Exp -> Exp -> Exp
AppE 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 -> Q Match
makeBitraverseMatch Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- 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' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Name -> [(Bool, Exp)] -> Q Match
match_for_con Name
conName [(Bool, Exp)]
parts'
where
ft_bitrav :: FFoldType (Q (Bool, Exp))
ft_bitrav :: FFoldType (Q (Bool, Exp))
ft_bitrav = FT {
ft_triv :: Q (Bool, Exp)
ft_triv = 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ Map Name Name
tvMap 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 <- 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 forall a b. (a -> b) -> a -> b
$ forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> Q Match
match_for_con TupleSort
t [(Bool, Exp)]
gg
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 <- forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> Name
traverseArity (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Q (Bool, Exp))]
gs))
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\(Type
_, Q (Bool, Exp)
hs) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Q (Bool, Exp)
hs) [(Type, Q (Bool, Exp))]
gs
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
_ -> 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)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
}
match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 forall a b. (a -> b) -> a -> b
$ \Exp
conExp [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return 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) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.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 (forall a. a -> Maybe a
Just Exp
se1) (Name -> Exp
VarE Name
apValName) (forall a. a -> Maybe a
Just Exp
se2)
buildTypeInstance :: BiClass
-> Name
-> Cxt
-> [Type]
-> DatatypeVariant
-> Q (Cxt, Type)
buildTypeInstance :: BiClass
-> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
buildTypeInstance BiClass
biClass Name
tyConName [Type]
dataCxt [Type]
instTysOrig DatatypeVariant
variant = do
[Type]
varTysExp <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
instTysOrig
let remainingLength :: Int
remainingLength :: Int
remainingLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
instTysOrig forall a. Num a => a -> a -> a
- Int
2
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. BiClass -> Name -> Q a
derivingKindError BiClass
biClass 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. BiClass -> Name -> Q a
derivingKindError BiClass
biClass 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 (BiClass -> Type -> (Maybe Type, [Name])
deriveConstraint BiClass
biClass) [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]
instTysOrig
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 b. (a -> b) -> a -> b
$ BiClass -> Name
biClassName BiClass
biClass)
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 :: BiClass -> Type -> (Maybe Pred, [Name])
deriveConstraint :: BiClass -> Type -> (Maybe Type, [Name])
deriveConstraint BiClass
biClass Type
t
| Bool -> Bool
not (Type -> Bool
isTyVar Type
t) = (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) 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) 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]
_ -> (forall a. Maybe a
Nothing, [])
where
tName :: Name
tName :: Name
tName = Type -> Name
varTToName Type
t
derivingKindError :: BiClass -> Name -> Q a
derivingKindError :: forall a. BiClass -> Name -> Q a
derivingKindError BiClass
biClass 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 a b. (a -> b) -> a -> b
$ String
""
where
className :: String
className :: String
className = Name -> String
nameBase forall a b. (a -> b) -> a -> b
$ BiClass -> Name
biClassName BiClass
biClass
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(s) 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
""
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 :: Name -> Q a
outOfPlaceTyVarError :: forall a. Name -> Q a
outOfPlaceTyVarError 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 two type variable(s) within"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" the last two argument(s) of a data type"
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
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
""
data BiClass = Bifunctor | Bifoldable | Bitraversable
data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse
deriving BiFun -> BiFun -> Bool
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 = forall a. a -> Maybe a
Just Name
functorTypeName
biClassConstraint BiClass
Bifoldable Int
1 = forall a. a -> Maybe a
Just Name
foldableTypeName
biClassConstraint BiClass
Bitraversable Int
1 = forall a. a -> Maybe a
Just Name
traversableTypeName
biClassConstraint BiClass
biClass Int
2 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ BiClass -> Name
biClassName BiClass
biClass
biClassConstraint BiClass
_ Int
_ = forall a. Maybe a
Nothing
fmapArity :: Int -> Name
fmapArity :: Int -> Name
fmapArity Int
1 = Name
fmapValName
fmapArity Int
2 = Name
bimapValName
fmapArity Int
n = 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 = 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 = 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 = forall a. Int -> a
arityErr Int
n
arityErr :: Int -> a
arityErr :: forall a. Int -> a
arityErr Int
n = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unsupported arity: " forall a. [a] -> [a] -> [a]
++ 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
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
emptyCase)
BiFun
biFun Name
z
where
emptyCase :: Q Exp
emptyCase :: Q Exp
emptyCase = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m 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
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
seqAndError)
BiFun
biFun Name
z
where
seqAndError :: Q Exp
seqAndError :: Q Exp
seqAndError = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
seqValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorValName)
(forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$ String
"Void " 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 = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z
go BiFun
BifoldMap = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
memptyValName
go BiFun
Bitraverse = Q Exp
bitraverseE
data FFoldType a
= FT { forall a. FFoldType a -> a
ft_triv :: a
, forall a. FFoldType a -> Name -> a
ft_var :: Name -> a
, forall a. FFoldType a -> Name -> a
ft_co_var :: Name -> a
, forall a. FFoldType a -> a -> a -> a
ft_fun :: a -> a -> a
, forall a. FFoldType a -> TupleSort -> [a] -> a
ft_tup :: TupleSort -> [a] -> a
, forall a. FFoldType a -> [(Type, a)] -> a
ft_ty_app :: [(Type, a)] -> a
, forall a. FFoldType a -> a
ft_bad_app :: a
, forall a. FFoldType a -> [TyVarBndrSpec] -> a -> a
ft_forall :: [TyVarBndrSpec] -> a -> a
}
functorLikeTraverse :: forall a.
TyVarMap
-> FFoldType a
-> Type
-> Q a
functorLikeTraverse :: forall a. 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 -> Q Type
resolveTypeSynonyms Type
ty
(a
res, Bool
_) <- Bool -> Type -> Q (a, Bool)
go Bool
False Type
ty'
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, [Type])
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 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, [Type]
args) = Type -> (Type, [Type])
unapplyTy Type
t
(a
_, Bool
fc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
f
([a]
xrs, [Bool]
xcs) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ 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) [Type]
args
let numLastArgs, numFirstArgs :: Int
numLastArgs :: Int
numLastArgs = forall a. Ord a => a -> a -> a
min Int
2 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args
numFirstArgs :: Int
numFirstArgs = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args forall a. Num a => a -> a -> a
- Int
numLastArgs
tuple :: TupleSort -> Q (a, Bool)
tuple :: TupleSort -> Q (a, Bool)
tuple TupleSort
tupSort = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseWrongArg, Bool
True)
case () of
()
_ | Bool -> Bool
not (forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xcs)
-> Q (a, Bool)
trivial
| TupleT Int
len <- Type
f
-> TupleSort -> Q (a, Bool)
tuple forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Boxed Int
len
| UnboxedTupleT Int
len <- Type
f
-> TupleSort -> Q (a, Bool)
tuple forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Unboxed Int
len
| Bool
fc Bool -> Bool -> Bool
|| forall (t :: * -> *). Foldable t => t Bool -> Bool
or (forall a. Int -> [a] -> [a]
take Int
numFirstArgs [Bool]
xcs)
-> Q (a, Bool)
wrongArg
| Bool
otherwise
-> do Bool
itf <- [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
f [Type]
args
if Bool
itf
then Q (a, Bool)
wrongArg
else forall (m :: * -> *) a. Monad m => a -> m a
return ( [(Type, a)] -> a
caseTyApp forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
numFirstArgs forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
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 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)
| forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
v Map Name Name
tvMap
= 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 [Type]
_ Type
t) = do
(a
tr, Bool
tc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
t
let tvbNames :: [Name]
tvbNames = forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndrSpec]
tvbs
if Bool -> Bool
not Bool
tc Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
tvbNames) [Name]
tyVarNames
then Q (a, Bool)
trivial
else 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)
go_kind :: Bool -> Type -> Q (a, Bool)
go_kind = Bool -> Type -> Q (a, Bool)
go
trivial :: Q (a, Bool)
trivial :: Q (a, Bool)
trivial = forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseTrivial, Bool
False)
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = forall k a. Map k a -> [k]
Map.keys Map Name Name
tvMap
foldDataConArgs :: forall a. TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs :: forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType a
ft ConstructorInfo
con = do
[Type]
fieldTys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q a
foldArg [Type]
fieldTys
where
foldArg :: Type -> Q a
foldArg :: Type -> Q a
foldArg = 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_n"
Exp
body <- Exp -> Q Exp
lam (Name -> Exp
VarE Name
n)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_n1"
Name
n2 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"n2"
Exp
body <- Exp -> Exp -> Q Exp
lam (Name -> Exp
VarE Name
n1) (Name -> Exp
VarE Name
n2)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match
mkSimpleConMatch Name -> [a] -> Q Exp
fold Name
conName [Exp -> a]
insides = do
[Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList String
"_arg" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp -> a]
insides
let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat Name
conName (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
Exp
rhs <- Name -> [a] -> Q Exp
fold Name
conName (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Exp -> a
i Name
v -> Exp -> a
i forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
v) [Exp -> a]
insides [Name]
varsNeeded)
forall (m :: * -> *) a. Monad m => a -> m a
return 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)] -> Q Match
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
conPCompat Name
conName (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
exps :: [Exp]
exps = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Bool
m, Exp
i) Name
v -> if Bool
m then forall a. a -> Maybe a
Just (Exp
i Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
v)
else forall a. Maybe a
Nothing)
[(Bool, Exp)]
insides [Name]
varsNeeded
argTysTyVarInfo :: [Bool]
argTysTyVarInfo = forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
m, Exp
_) -> Bool
m) [(Bool, Exp)]
insides
([Name]
asWithTyVar, [Name]
asWithoutTyVar) = forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo [Name]
varsNeeded
conExpQ :: Q Exp
conExpQ
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
asWithTyVar = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conNameforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
asWithoutTyVar)
| Bool
otherwise = do
[Name]
bs <- String -> Int -> Q [Name]
newNameList String
"b" Int
lengthInsides
let bs' :: [Name]
bs' = forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
argTysTyVarInfo [Name]
bs
vars :: [Q Exp]
vars = forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
argTysTyVarInfo
(forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
bs) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varsNeeded)
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
bs') (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conNameforall a. a -> [a] -> [a]
:[Q Exp]
vars))
Exp
conExp <- Q Exp
conExpQ
Exp
rhs <- Exp -> [Exp] -> Q Exp
fold Exp
conExp [Exp]
exps
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
rhs) []
where
lengthInsides :: Int
lengthInsides = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Exp)]
insides
data TupleSort
= Boxed Int
| Unboxed Int
mkSimpleTupleCase :: (Name -> [a] -> Q Match)
-> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase :: forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [a] -> Q Match
matchForCon TupleSort
tupSort [a]
insides Exp
x = do
let tupDataName :: Name
tupDataName = case TupleSort
tupSort of
Boxed Int
len -> Int -> Name
tupleDataName Int
len
Unboxed Int
len -> Int -> Name
unboxedTupleDataName Int
len
Match
m <- Name -> [a] -> Q Match
matchForCon Name
tupDataName [a]
insides
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
x [Match
m]
conPCompat :: Name -> [Pat] -> Pat
conPCompat :: Name -> [Pat] -> Pat
conPCompat Name
n [Pat]
pats = Name -> [Type] -> [Pat] -> Pat
ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
[Pat]
pats