{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module Data.Functor.Invariant.TH (
deriveInvariant
, deriveInvariantOptions
, deriveInvariant2
, deriveInvariant2Options
, makeInvmap
, makeInvmapOptions
, makeInvmap2
, makeInvmap2Options
, Options(..)
, defaultOptions
) where
import Control.Monad (unless, when)
import Data.Functor.Invariant.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
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 }
deriveInvariant :: Name -> Q [Dec]
deriveInvariant :: Name -> Q [Dec]
deriveInvariant = Options -> Name -> Q [Dec]
deriveInvariantOptions Options
defaultOptions
deriveInvariantOptions :: Options -> Name -> Q [Dec]
deriveInvariantOptions :: Options -> Name -> Q [Dec]
deriveInvariantOptions = InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass InvariantClass
Invariant
deriveInvariant2 :: Name -> Q [Dec]
deriveInvariant2 :: Name -> Q [Dec]
deriveInvariant2 = Options -> Name -> Q [Dec]
deriveInvariant2Options Options
defaultOptions
deriveInvariant2Options :: Options -> Name -> Q [Dec]
deriveInvariant2Options :: Options -> Name -> Q [Dec]
deriveInvariant2Options = InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass InvariantClass
Invariant2
makeInvmap :: Name -> Q Exp
makeInvmap :: Name -> Q Exp
makeInvmap = Options -> Name -> Q Exp
makeInvmapOptions Options
defaultOptions
makeInvmapOptions :: Options -> Name -> Q Exp
makeInvmapOptions :: Options -> Name -> Q Exp
makeInvmapOptions = InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass InvariantClass
Invariant
makeInvmap2 :: Name -> Q Exp
makeInvmap2 :: Name -> Q Exp
makeInvmap2 = Options -> Name -> Q Exp
makeInvmap2Options Options
defaultOptions
makeInvmap2Options :: Options -> Name -> Q Exp
makeInvmap2Options :: Options -> Name -> Q Exp
makeInvmap2Options = InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass InvariantClass
Invariant2
deriveInvariantClass :: InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass :: InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass InvariantClass
iClass 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)
<- InvariantClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance InvariantClass
iClass 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)
(InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
invmapDecs InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons)
invmapDecs :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo]
-> [Q Dec]
invmapDecs :: InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
invmapDecs InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons =
[ Name -> [ClauseQ] -> Q Dec
funD (InvariantClass -> Name
invmapName InvariantClass
iClass)
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeInvmapForCons InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons)
[]
]
]
makeInvmapClass :: InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass :: InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass InvariantClass
iClass 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
} ->
InvariantClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance InvariantClass
iClass 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
>> InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeInvmapForCons InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons
makeInvmapForCons :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo]
-> Q Exp
makeInvmapForCons :: InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeInvmapForCons InvariantClass
iClass Options
opts Name
_parentName Cxt
instTys [ConstructorInfo]
cons = do
Name
value <- String -> Q Name
newName String
"value"
[Name]
covMaps <- String -> Int -> Q [Name]
newNameList String
"covMap" Int
numNbs
[Name]
contraMaps <- String -> Int -> Q [Name]
newNameList String
"contraMap" Int
numNbs
let mapFuns :: [(Name, Name)]
mapFuns = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
covMaps [Name]
contraMaps
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
numNbs) Cxt
instTys
tvMap :: Map Name (Name, Name)
tvMap = [(Name, (Name, Name))] -> Map Name (Name, Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, (Name, Name))] -> Map Name (Name, Name))
-> [(Name, (Name, Name))] -> Map Name (Name, Name)
forall a b. (a -> b) -> a -> b
$ [Name] -> [(Name, Name)] -> [(Name, (Name, Name))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [(Name, Name)]
mapFuns
argNames :: [Name]
argNames = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [[Name]]
forall a. [[a]] -> [[a]]
List.transpose [[Name]
covMaps, [Name]
contraMaps]) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
value]
[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
$ InvariantClass -> Name
invmapConstName InvariantClass
iClass
, Name -> Map Name (Name, Name) -> Q Exp
makeFun Name
value Map Name (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
numNbs :: Int
numNbs :: Int
numNbs = InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass
makeFun :: Name -> TyVarMap -> Q Exp
makeFun :: Name -> Map Name (Name, Name) -> Q Exp
makeFun Name
value Map Name (Name, Name)
tvMap = do
#if MIN_VERSION_template_haskell(2,9,0)
[Role]
roles <- Name -> Q [Role]
reifyRoles Name
_parentName
let rroles :: [Role]
rroles = [Role]
roles
#endif
case () of
()
_
#if MIN_VERSION_template_haskell(2,9,0)
| ([Role] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Role]
rroles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numNbs) Bool -> Bool -> Bool
&&
((Role -> Bool) -> [Role] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
PhantomR) (Int -> [Role] -> [Role]
forall a. Int -> [a] -> [a]
drop ([Role] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Role]
rroles Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numNbs) [Role]
rroles))
-> Name -> Q Exp
varE Name
coerceValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE 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
-> Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value) []
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
-> 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 (InvariantClass -> Name
invmapName InvariantClass
iClass))
| 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 (InvariantClass
-> Map Name (Name, Name) -> ConstructorInfo -> MatchQ
makeInvmapForCon InvariantClass
iClass Map Name (Name, Name)
tvMap) [ConstructorInfo]
cons)
ghc7'8OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 708
ghc7'8OrLater :: Bool
ghc7'8OrLater = Bool
True
#else
ghc7'8OrLater = False
#endif
makeInvmapForCon :: InvariantClass -> TyVarMap -> ConstructorInfo -> Q Match
makeInvmapForCon :: InvariantClass
-> Map Name (Name, Name) -> ConstructorInfo -> MatchQ
makeInvmapForCon InvariantClass
iClass Map Name (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) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (Name, Name)
tvMap) Cxt
ctxt
Bool -> Bool -> Bool
|| Map Name (Name, Name) -> Int
forall k a. Map k a -> Int
Map.size Map Name (Name, Name)
tvMap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
Name -> Q ()
forall a. Name -> Q a
existentialContextError Name
conName
[Exp -> Q Exp]
parts <- InvariantClass
-> Map Name (Name, Name)
-> FFoldType (Exp -> Q Exp)
-> ConstructorInfo
-> Q [Exp -> Q Exp]
forall a.
InvariantClass
-> Map Name (Name, Name) -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs InvariantClass
iClass Map Name (Name, Name)
tvMap FFoldType (Exp -> Q Exp)
ft_invmap ConstructorInfo
con
Name -> [Exp -> Q Exp] -> MatchQ
match_for_con Name
conName [Exp -> Q Exp]
parts
where
ft_invmap :: FFoldType (Exp -> Q Exp)
ft_invmap :: FFoldType (Exp -> Q Exp)
ft_invmap = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Bool -> [(Type, a, 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 ((Name, Name) -> Name
forall a b. (a, b) -> a
fst (Map Name (Name, Name)
tvMap Map Name (Name, Name) -> Name -> (Name, Name)
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v)) Exp -> Exp -> Exp
`AppE` Exp
x
, ft_co_var :: Name -> Exp -> Q Exp
ft_co_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 ((Name, Name) -> Name
forall a b. (a, b) -> b
snd (Map Name (Name, Name)
tvMap Map Name (Name, 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 :: Bool -> [(Type, Exp -> Q Exp, Exp -> Q Exp)] -> Exp -> Q Exp
ft_ty_app = \Bool
contravariant [(Type, Exp -> Q Exp, Exp -> Q Exp)]
argGs Exp
x -> do
let inspect :: (Type, Exp -> Q Exp, Exp -> Q Exp) -> [Q Exp]
inspect :: (Type, Exp -> Q Exp, Exp -> Q Exp) -> [Q Exp]
inspect (Type
argTy, Exp -> Q Exp
g, Exp -> Q Exp
h)
| Just Name
argVar <- Type -> Maybe Name
varTToName_maybe Type
argTy
, Just (Name
covMap, Name
contraMap) <- Name -> Map Name (Name, Name) -> Maybe (Name, Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name (Name, Name)
tvMap
= (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> (Name -> Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) ([Name] -> [Q Exp]) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$
if Bool
contravariant
then [Name
contraMap, Name
covMap]
else [Name
covMap, Name
contraMap]
| Bool
otherwise
= [(Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
g, (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
h]
[Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE (InvariantClass -> Name
invmapName (Int -> InvariantClass
forall a. Enum a => Int -> a
toEnum ([(Type, Exp -> Q Exp, Exp -> Q Exp)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Exp -> Q Exp, Exp -> Q Exp)]
argGs)))
Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Type, Exp -> Q Exp, Exp -> Q Exp) -> [Q Exp])
-> [(Type, Exp -> Q Exp, Exp -> Q Exp)] -> [Q Exp]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Type, Exp -> Q Exp, Exp -> Q Exp) -> [Q Exp]
inspect [(Type, Exp -> Q Exp, 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
}
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)
buildTypeInstance :: InvariantClass
-> Name
-> Cxt
-> [Type]
-> DatatypeVariant
-> Q (Cxt, Type)
buildTypeInstance :: InvariantClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance InvariantClass
iClass Name
tyConName Cxt
dataCxt Cxt
varTysOrig 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
varTysOrig
let remainingLength :: Int
remainingLength :: Int
remainingLength = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
varTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass
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
$
InvariantClass -> Name -> Q ()
forall a. InvariantClass -> Name -> Q a
derivingKindError InvariantClass
iClass 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
$
InvariantClass -> Name -> Q ()
forall a. InvariantClass -> Name -> Q a
derivingKindError InvariantClass
iClass 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 (InvariantClass -> Type -> (Maybe Type, [Name])
deriveConstraint InvariantClass
iClass) 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]
List.union [Name]
droppedKindVarNames [Name]
kvNames'))
(Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
take Int
remainingLength Cxt
varTysOrig
isDataFamily :: Bool
isDataFamily :: Bool
isDataFamily = case DatatypeVariant
variant of
DatatypeVariant
Datatype -> Bool
False
DatatypeVariant
Newtype -> Bool
False
DatatypeVariant
DataInstance -> Bool
True
DatatypeVariant
NewtypeInstance -> Bool
True
remainingTysOrigSubst' :: [Type]
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
$ InvariantClass -> Name
invariantClassName InvariantClass
iClass)
(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 :: InvariantClass -> Type -> (Maybe Pred, [Name])
deriveConstraint :: InvariantClass -> Type -> (Maybe Type, [Name])
deriveConstraint InvariantClass
iClass 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 | InvariantClass
iClass InvariantClass -> InvariantClass -> Bool
forall a. Ord a => a -> a -> Bool
>= InvariantClass
Invariant
-> (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Name -> Type
applyClass Name
invariantTypeName Name
tName), [Name]
ns)
Maybe [Name]
_ -> case Int -> Type -> Maybe [Name]
hasKindVarChain Int
2 Type
t of
Just [Name]
ns | InvariantClass
iClass InvariantClass -> InvariantClass -> Bool
forall a. Eq a => a -> a -> Bool
== InvariantClass
Invariant2
-> (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Name -> Type
applyClass Name
invariant2TypeName Name
tName), [Name]
ns)
Maybe [Name]
_ -> (Maybe Type
forall a. Maybe a
Nothing, [])
where
tName :: Name
tName :: Name
tName = Type -> Name
varTToName Type
t
derivingKindError :: InvariantClass -> Name -> Q a
derivingKindError :: InvariantClass -> Name -> Q a
derivingKindError InvariantClass
iClass 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 "
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 -> String) -> (Int -> Type) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
createKindChain (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass)
(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
$ InvariantClass -> Name
invariantClassName InvariantClass
iClass
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 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 -> Bool -> [(Type, a, a)] -> a
ft_ty_app :: Bool -> [(Type, a, a)] -> a
, FFoldType a -> a
ft_bad_app :: a
, FFoldType a -> [TyVarBndrSpec] -> a -> a
ft_forall :: [TyVarBndrSpec] -> a -> a
}
functorLikeTraverse :: InvariantClass
-> TyVarMap
-> FFoldType a
-> Type
-> Q a
functorLikeTraverse :: InvariantClass
-> Map Name (Name, Name) -> FFoldType a -> Type -> Q a
functorLikeTraverse InvariantClass
iClass Map Name (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 -> Bool -> [(Type, a, a)] -> a
ft_ty_app = Bool -> [(Type, a, 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
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
([a]
contraXrs, [Bool]
_) <- ([(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 -> Bool
not Bool
co)) Cxt
args
let numLastArgs, numFirstArgs :: Int
numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass) (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 -> m (a, Bool)
tuple TupleSort
tupSort = (a, Bool) -> m (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 = (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)
forall (m :: * -> *). Monad m => TupleSort -> m (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)
forall (m :: * -> *). Monad m => TupleSort -> m (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 ( Bool -> [(Type, a, a)] -> a
caseTyApp Bool
co ([(Type, a, a)] -> a) -> [(Type, a, a)] -> a
forall a b. (a -> b) -> a -> b
$ Int -> [(Type, a, a)] -> [(Type, a, a)]
forall a. Int -> [a] -> [a]
drop Int
numFirstArgs
([(Type, a, a)] -> [(Type, a, a)])
-> [(Type, a, a)] -> [(Type, a, a)]
forall a b. (a -> b) -> a -> b
$ Cxt -> [a] -> [a] -> [(Type, a, a)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 Cxt
args [a]
xrs [a]
contraXrs
, 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, Name) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
v Map Name (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
#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 = (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) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (Name, Name)
tvMap
foldDataConArgs :: InvariantClass -> TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs :: InvariantClass
-> Map Name (Name, Name) -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs InvariantClass
iClass Map Name (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 = InvariantClass
-> Map Name (Name, Name) -> FFoldType a -> Type -> Q a
forall a.
InvariantClass
-> Map Name (Name, Name) -> FFoldType a -> Type -> Q a
functorLikeTraverse InvariantClass
iClass Map Name (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
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
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
((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) []
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]