{-# language CPP #-}
{-# language ExplicitNamespaces #-}
{-# language MultiWayIf #-}
{-# language TemplateHaskellQuotes #-}
module Generics.Kind.TH
( deriveGenericK
, deriveGenericKQuiet
, preDeriveGenericK
, postDeriveGenericK
) where
import Control.Applicative
import Control.Monad
import qualified Data.Kind as Kind
import Data.List
import Data.Maybe
import Data.Type.Equality (type (~~))
import Fcf.Family.TH (fcfify, isTypeFamilyOrSynonym, promoteNDFamily)
import GHC.Generics as Generics hiding (conIsRecord, conName,
datatypeName)
import Generics.Kind
import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Datatype as THAbs
import Language.Haskell.TH.Datatype.TyVarBndr
#if MIN_VERSION_template_haskell(2,15,0)
import GHC.Classes (IP)
#endif
deriveGenericK :: Name -> Q [Dec]
deriveGenericK :: Name -> Q [Dec]
deriveGenericK = Bool -> Name -> Q [Dec]
deriveGenericKWarnIf Bool
True
deriveGenericKQuiet :: Name -> Q [Dec]
deriveGenericKQuiet :: Name -> Q [Dec]
deriveGenericKQuiet = Bool -> Name -> Q [Dec]
deriveGenericKWarnIf Bool
False
deriveGenericKWarnIf :: Bool -> Name -> Q [Dec]
deriveGenericKWarnIf :: Bool -> Name -> Q [Dec]
deriveGenericKWarnIf Bool
warn Name
name = ([Dec] -> [Dec] -> [Dec]) -> ([Dec], [Dec]) -> [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) (([Dec], [Dec]) -> [Dec]) -> Q ([Dec], [Dec]) -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FamilyFriendliness -> Name -> Q ([Dec], [Dec])
deriveGenericK' (Bool -> FamilyFriendliness
NoFamilies Bool
warn) Name
name
preDeriveGenericK :: Name -> Q [Dec]
preDeriveGenericK :: Name -> Q [Dec]
preDeriveGenericK Name
n = do
([Dec]
pre, [Dec]
post) <- FamilyFriendliness -> Name -> Q ([Dec], [Dec])
deriveGenericK' FamilyFriendliness
YesFamilies Name
n
[Dec] -> Q ()
pushGenericKQueue [Dec]
post
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
pre
postDeriveGenericK :: Q [Dec]
postDeriveGenericK :: Q [Dec]
postDeriveGenericK = Q [Dec]
takeGenericKQueue
data FamilyFriendliness
= NoFamilies Bool
| YesFamilies
deriveGenericK' :: FamilyFriendliness -> Name -> Q ([Dec], [Dec])
deriveGenericK' :: FamilyFriendliness -> Name -> Q ([Dec], [Dec])
deriveGenericK' FamilyFriendliness
familyFriendliness Name
n = do
DatatypeInfo{ datatypeName :: DatatypeInfo -> Name
datatypeName = Name
dataName
, datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
univVars
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} <- Name -> Q DatatypeInfo
reifyDatatype Name
n
[ConstructorInfo]
cons' <- (ConstructorInfo -> Q ConstructorInfo)
-> [ConstructorInfo] -> Q [ConstructorInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ConstructorInfo -> Q ConstructorInfo
resolveConSynonyms [ConstructorInfo]
cons
let deriveInsts :: [Type] -> [Type] -> Q [Dec]
deriveInsts :: [Type] -> [Type] -> Q [Dec]
deriveInsts [Type]
argsToKeep [Type]
argsToDrop = do
Dec
inst <- [Type] -> [Type] -> Q Dec
deriveGenericKFor [Type]
argsToKeep [Type]
argsToDrop
case [Type]
argsToKeep of
[] -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
inst]
(Type
argToDrop:[Type]
argsToKeep') -> do
Type
argToDrop' <- Type -> Q Type
resolveTypeSynonyms Type
argToDrop
if |
Just Name
argNameToDrop <- [Name] -> Type -> Maybe Name
distinctTyVarType ([Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
argsToKeep')
Type
argToDrop'
, Name
argNameToDrop Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
[Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
typeKind [Type]
argsToDrop
[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ (TyVarBndr_ () -> Type) -> [TyVarBndr_ ()] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind ([ConstructorInfo] -> [TyVarBndr_ ()]
gatherExistentials [ConstructorInfo]
cons'))
-> do let allInnerTypes :: [Type]
allInnerTypes = [ConstructorInfo] -> [Type]
gatherConstraints [ConstructorInfo]
cons' [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [ConstructorInfo] -> [Type]
gatherFields [ConstructorInfo]
cons'
Bool
inTyFamApp <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Bool) -> [Type] -> Q [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Name -> Type -> Q Bool
isInTypeFamilyApp Name
argNameToDrop)
[Type]
allInnerTypes
case FamilyFriendliness
familyFriendliness of
NoFamilies Bool
warn | Bool
inTyFamApp -> do
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn (String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ Name -> Name -> [Type] -> [Type] -> String
tyFamWarning Name
n Name
dataName [Type]
argsToKeep [Type]
argsToDrop)
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
inst]
FamilyFriendliness
_ -> (Dec
instDec -> [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
<$> [Type] -> [Type] -> Q [Dec]
deriveInsts [Type]
argsToKeep' (Type
argToDrop'Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
argsToDrop)
| Bool
otherwise
-> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
inst]
deriveGenericKFor :: [Type] -> [Type] -> Q Dec
deriveGenericKFor :: [Type] -> [Type] -> Q Dec
deriveGenericKFor [Type]
argsToKeep [Type]
argsToDrop = do
let argNamesToDrop :: [Name]
argNamesToDrop = (Type -> Name) -> [Type] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName [Type]
argsToDrop
kind :: Type
kind = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((\Type
x Type
y -> Type
ArrowT Type -> Type -> Type
`AppT` Type
x Type -> Type -> Type
`AppT` Type
y) (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
typeKind)
(Name -> Type
ConT ''Kind.Type) [Type]
argsToDrop
dataApp :: Q Type
dataApp = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
SigT ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type) -> Type -> Type -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
ConT Name
dataName) [Type]
argsToKeep) Type
kind
Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Type] -> Q [Type]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''GenericK Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
dataApp)
[ Name -> Maybe [Q (TyVarBndr_ ())] -> [Q Type] -> Q Type -> Q Dec
tySynInstDCompat ''RepK Maybe [Q (TyVarBndr_ ())]
forall a. Maybe a
Nothing [Q Type
dataApp] (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
Name -> [Name] -> DatatypeVariant -> [ConstructorInfo] -> Q Type
deriveRepK Name
dataName [Name]
argNamesToDrop DatatypeVariant
variant [ConstructorInfo]
cons'
, [ConstructorInfo] -> Q Dec
deriveFromK [ConstructorInfo]
cons'
, [ConstructorInfo] -> Q Dec
deriveToK [ConstructorInfo]
cons'
]
[Dec]
insts <- [Type] -> [Type] -> Q [Dec]
deriveInsts ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
univVars) []
[Dec]
fcfInsts <- Q [Dec]
takeFcfifyQueue
([Dec], [Dec]) -> Q ([Dec], [Dec])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
fcfInsts, [Dec]
insts)
tyFamWarning :: Name -> Name -> [Type] -> [Type] -> String
tyFamWarning :: Name -> Name -> [Type] -> [Type] -> String
tyFamWarning Name
name Name
dataName [Type]
argsToKeep' [Type]
argsToDrop' =
let argsToKeep :: [String]
argsToKeep = Type -> String
getVarTName (Type -> String) -> [Type] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
argsToKeep'
argsToDrop :: [String]
argsToDrop = Type -> String
getVarTName (Type -> String) -> [Type] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
argsToDrop'
in Name -> Name -> [String] -> [String] -> String
tyFamWarning' Name
name Name
dataName [String]
argsToKeep [String]
argsToDrop
tyFamWarning' :: Name -> Name -> [String] -> [String] -> String
tyFamWarning' :: Name -> Name -> [String] -> [String] -> String
tyFamWarning' Name
name Name
dataName [String]
argsToKeep [String]
argsToDrop = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
(String
"Found type family in definition of "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
quoteName Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Some instances have been skipped.") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (
String
"Declared instances:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
Name -> [String] -> [String] -> [String]
showDeclaredInstances Name
dataName [String]
argsToKeep [String]
argsToDrop [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
String
"Skipped instances:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
Name -> [String] -> [String]
showSkippedInstances Name
dataName [String]
argsToKeep [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
String
"To enable type family support and obtain those skipped instances:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
(String
"\t$(preDeriveGenericK " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
quoteName Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
(String
"\t$(postDeriveGenericK " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
quoteName Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
String
"To silence this warning:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
(String
"\t$(deriveGenericKQuiet " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
quoteName Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
[])
quoteName :: Name -> String
quoteName :: Name -> String
quoteName name :: Name
name@(Name OccName
_ (NameG NameSpace
DataName PkgName
_ ModName
_)) = String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
quoteName Name
name = String
"''" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
showDeclaredInstances :: Name -> [String] -> [String] -> [String]
showDeclaredInstances :: Name -> [String] -> [String] -> [String]
showDeclaredInstances Name
name [String]
argsToKeep [String]
argsToDrop =
(\[String]
args -> String
"\tinstance GenericK " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> [String] -> String
showConArgs Name
name ([String]
argsToKeep [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args)) ([String] -> String) -> [[String]] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> [[String]]
forall a. [a] -> [[a]]
inits [String]
argsToDrop
showSkippedInstances :: Name -> [String] -> [String]
showSkippedInstances :: Name -> [String] -> [String]
showSkippedInstances Name
name [String]
argsToKeep =
(\[String]
args -> String
"\tinstance GenericK " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> [String] -> String
showConArgs Name
name [String]
args) ([String] -> String) -> [[String]] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[String]] -> [[String]]
forall a. HasCallStack => [a] -> [a]
init ([String] -> [[String]]
forall a. [a] -> [[a]]
inits [String]
argsToKeep)
showConArgs :: Name -> [String] -> String
showConArgs :: Name -> [String] -> String
showConArgs Name
name [] = Name -> String
nameBase Name
name
showConArgs Name
name [String]
args = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " (Name -> String
nameBase Name
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
getVarTName :: Type -> String
getVarTName :: Type -> String
getVarTName (SigT Type
t Type
_) = Type -> String
getVarTName Type
t
getVarTName (VarT Name
name) = Name -> String
nameBase Name
name
getVarTName Type
_ = String
"_a"
distinctTyVarType :: [Name] -> Type -> Maybe Name
distinctTyVarType :: [Name] -> Type -> Maybe Name
distinctTyVarType [Name]
tvSet Type
ty = do
Name
tvTy <- Type -> Maybe Name
varTToName_maybe Type
ty
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Name
tvTy Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
tvSet
Name -> Maybe Name
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
tvTy
deriveRepK :: Name -> [Name]
-> DatatypeVariant -> [ConstructorInfo] -> Q Type
deriveRepK :: Name -> [Name] -> DatatypeVariant -> [ConstructorInfo] -> Q Type
deriveRepK Name
dataName [Name]
univVarNames DatatypeVariant
dataVariant [ConstructorInfo]
cons = do
[Type]
cons' <- (ConstructorInfo -> Q Type) -> [ConstructorInfo] -> Q [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ConstructorInfo -> Q Type
constructor [ConstructorInfo]
cons
Type -> Q Type
metaData (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\Type
x Type
y -> Type -> Name -> Type -> Type
InfixT Type
x ''(:+:) Type
y) (Name -> Type
ConT ''V1) [Type]
cons'
where
metaData :: Type -> Q Type
metaData :: Type -> Q Type
metaData Type
t = do
String
m <- Q String -> (String -> Q String) -> Maybe String -> Q String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q String
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot fetch module name!") String -> Q String
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe String
nameModule Name
dataName)
String
pkg <- Q String -> (String -> Q String) -> Maybe String -> Q String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q String
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot fetch package name!") String -> Q String
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe String
namePackage Name
dataName)
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''D1
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'MetaData Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (Name -> String
nameBase Name
dataName)) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
m) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
pkg) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
Bool -> Q Type
promoteBool (DatatypeVariant -> Bool
isNewtypeVariant DatatypeVariant
dataVariant))
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
constructor :: ConstructorInfo -> Q Type
constructor :: ConstructorInfo -> Q Type
constructor ConstructorInfo{ constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVars :: ConstructorInfo -> [TyVarBndr_ ()]
constructorVars = [TyVarBndr_ ()]
exTvbs
, constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
conCtxt
, constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
fields
, constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
fieldStricts
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
conVariant
} = do
Maybe Fixity
mbFi <- Name -> Q (Maybe Fixity)
reifyFixity Name
conName
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''C1
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'MetaCons Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (Name -> String
nameBase Name
conName)) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
Maybe Fixity -> Bool -> Q Type
fixityIPromotedType Maybe Fixity
mbFi Bool
conIsInfix Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
Bool -> Q Type
promoteBool Bool
conIsRecord)
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` do Type
prod <- (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\Type
x Type
y -> Type -> Name -> Type -> Type
InfixT Type
x ''(:*:) Type
y) (Name -> Type
ConT ''U1) ([Type] -> Type) -> Q [Type] -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type]
selectors
Type
ctxtProd <- Type -> Q Type
context Type
prod
Type -> Q Type
existentials Type
ctxtProd
where
conIsRecord :: Bool
conIsRecord :: Bool
conIsRecord =
case ConstructorVariant
conVariant of
ConstructorVariant
NormalConstructor -> Bool
False
ConstructorVariant
InfixConstructor -> Bool
False
RecordConstructor{} -> Bool
True
conIsInfix :: Bool
conIsInfix :: Bool
conIsInfix =
case ConstructorVariant
conVariant of
ConstructorVariant
NormalConstructor -> Bool
False
ConstructorVariant
InfixConstructor -> Bool
True
RecordConstructor{} -> Bool
False
context :: Type -> Q Type
context :: Type -> Q Type
context = Name -> [Name] -> [Type] -> Type -> Q Type
ntext ''(:=>:) [Name]
allTvbNames [Type]
conCtxt
cocontext :: [Name] -> Cxt -> Type -> Q Type
cocontext :: [Name] -> [Type] -> Type -> Q Type
cocontext = Name -> [Name] -> [Type] -> Type -> Q Type
ntext '(:=>>:)
ntext :: Name -> [Name] -> Cxt -> Type -> Q Type
ntext :: Name -> [Name] -> [Type] -> Type -> Q Type
ntext Name
(==>) [Name]
tvbNames [Type]
ctxt Type
ty =
case [Type]
ctxt of
[] -> Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
[Type]
_ -> Q Type -> Name -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> Name -> m Type -> m Type
infixT ([Name] -> [Type] -> Q Type
atomizeContext [Name]
tvbNames [Type]
ctxt) Name
(==>) (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty)
existentials :: Type -> Q Type
existentials :: Type -> Q Type
existentials Type
ty =
(Q Type -> TyVarBndr_ () -> Q Type)
-> Q Type -> [TyVarBndr_ ()] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Type
x TyVarBndr_ ()
tvb -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Exists Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyVarBndr_ () -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr_ ()
tvb) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
x)
(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty) [TyVarBndr_ ()]
exTvbs
selectors :: Q [Type]
selectors :: Q [Type]
selectors =
case ConstructorVariant
conVariant of
ConstructorVariant
NormalConstructor -> Q [Type]
nonRecordCase
ConstructorVariant
InfixConstructor -> Q [Type]
nonRecordCase
RecordConstructor [Name]
records -> [Name] -> Q [Type]
recordCase [Name]
records
where
nonRecordCase :: Q [Type]
nonRecordCase :: Q [Type]
nonRecordCase = [Maybe Name] -> Q [Type]
mkCase ((Type -> Maybe Name) -> [Type] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Name -> Type -> Maybe Name
forall a b. a -> b -> a
const Maybe Name
forall a. Maybe a
Nothing) [Type]
fields)
recordCase :: [Name] -> Q [Type]
recordCase :: [Name] -> Q [Type]
recordCase [Name]
records = [Maybe Name] -> Q [Type]
mkCase ((Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Maybe Name
forall a. a -> Maybe a
Just [Name]
records)
mkCase :: [Maybe Name] -> Q [Type]
mkCase :: [Maybe Name] -> Q [Type]
mkCase [Maybe Name]
mbRecords = do
[DecidedStrictness]
dcdStricts <- Name -> Q [DecidedStrictness]
reifyConStrictness Name
conName
(Maybe Name
-> FieldStrictness -> DecidedStrictness -> Type -> Q Type)
-> [Maybe Name]
-> [FieldStrictness]
-> [DecidedStrictness]
-> [Type]
-> Q [Type]
forall (m :: * -> *) a b c d e.
Monad m =>
(a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e]
zipWith4M Maybe Name
-> FieldStrictness -> DecidedStrictness -> Type -> Q Type
selector [Maybe Name]
mbRecords [FieldStrictness]
fieldStricts [DecidedStrictness]
dcdStricts [Type]
fields
selector :: Maybe Name -> FieldStrictness -> TH.DecidedStrictness -> Type -> Q Type
selector :: Maybe Name
-> FieldStrictness -> DecidedStrictness -> Type -> Q Type
selector Maybe Name
mbRecord (FieldStrictness Unpackedness
fu Strictness
fs) DecidedStrictness
ds Type
field = do
let mbSelNameT :: Q Type
mbSelNameT =
case Maybe Name
mbRecord of
Just Name
record -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Just Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (Name -> String
nameBase Name
record))
Maybe Name
Nothing -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Nothing
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''S1
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'MetaSel Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
Q Type
mbSelNameT Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
SourceUnpackedness -> Q Type
promoteSourceUnpackedness (Unpackedness -> SourceUnpackedness
generifyUnpackedness Unpackedness
fu) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
SourceStrictness -> Q Type
promoteSourceStrictness (Strictness -> SourceStrictness
generifyStrictness Strictness
fs) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
DecidedStrictness -> Q Type
promoteDecidedStrictness (DecidedStrictness -> DecidedStrictness
generifyDecidedStrictness DecidedStrictness
ds))
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Field Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` [Name] -> Type -> Q Type
prenex [Name]
allTvbNames Type
field)
atomizeContext :: [Name] -> Cxt -> Q Type
atomizeContext :: [Name] -> [Type] -> Q Type
atomizeContext [Name]
tvbNames =
(Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\Q Type
x Q Type
y -> Q Type -> Name -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> Name -> m Type -> m Type
infixT Q Type
x '(:&:) Q Type
y)
(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Kon Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Int -> Q Type
forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
0)
([Q Type] -> Q Type) -> ([Type] -> [Q Type]) -> [Type] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Q Type
atomize [Name]
tvbNames)
#if MIN_VERSION_template_haskell(2,17,0)
foralls :: [TyVarBndr Specificity] -> Q Type -> Q Type
#else
foralls :: [TyVarBndr] -> Q Type -> Q Type
#endif
foralls :: [TyVarBndr Specificity] -> Q Type -> Q Type
foralls [TyVarBndr Specificity]
vs Q Type
ty =
(TyVarBndr Specificity -> Q Type -> Q Type)
-> Q Type -> [TyVarBndr Specificity] -> Q Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TyVarBndr Specificity
_ Q Type
x -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'ForAll Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
x) Q Type
ty [TyVarBndr Specificity]
vs
prenex :: [Name] -> Type -> Q Type
prenex :: [Name] -> Type -> Q Type
prenex [Name]
tvbNames (ForallT [TyVarBndr Specificity]
vars [Type]
ctxt Type
ty) =
let tvbNames' :: [Name]
tvbNames' = [Name] -> [Name]
forall a. [a] -> [a]
reverse ((TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> Name
forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr Specificity]
vars) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
tvbNames in
([TyVarBndr Specificity] -> Q Type -> Q Type
foralls [TyVarBndr Specificity]
vars (Q Type -> Q Type) -> (Type -> Q Type) -> Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name] -> [Type] -> Type -> Q Type
cocontext [Name]
tvbNames' [Type]
ctxt (Type -> Q Type) -> Q Type -> Q Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Q Type -> Q Type) -> (Type -> Q Type) -> Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Type -> Q Type
prenex [Name]
tvbNames') Type
ty
prenex [Name]
tvbNames Type
ty = [Name] -> Type -> Q Type
atomize [Name]
tvbNames Type
ty
atomize :: [Name] -> Type -> Q Type
atomize :: [Name] -> Type -> Q Type
atomize [Name]
tvbNames = (Type -> [Q Type] -> Q Type) -> [Q Type] -> Type -> Q Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> [Q Type] -> Q Type
go []
where
go :: Type -> [Q Type] -> Q Type
go :: Type -> [Q Type] -> Q Type
go ty :: Type
ty@(VarT Name
n) =
case Name -> [Name] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Name
n [Name]
tvbNames of
Just Int
idx -> Type -> [Q Type] -> Q Type
appsT (Type -> [Q Type] -> Q Type) -> Type -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
enumerateTyVar Int
idx
Maybe Int
Nothing -> Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@(ConT Name
n) = \[Q Type]
args -> do
Bool
isTFS <- Name -> Q Bool
isTypeFamilyOrSynonym Name
n
if Bool
isTFS
then do (Type
fam, Int
arity) <- Name -> Q (Type, Int)
promoteNDFamily Name
n
([Type]
args1, [Type]
args2) <- Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
arity ([Type] -> ([Type], [Type])) -> Q [Type] -> Q ([Type], [Type])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q Type]
args
let saturated :: Bool
saturated = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isKonApp [Type]
args1
if Bool
saturated then Type -> [Q Type] -> Q Type
kon Type
ty [Q Type]
args
else do
Name -> Q [Dec]
fcfify Name
n Q [Dec] -> ([Dec] -> Q ()) -> Q ()
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> Q ()
pushFcfifyQueue
Name -> Type
PromotedT 'Eval
Type -> Type -> Type
`AppT` (Name -> Type
PromotedT 'Kon Type -> Type -> Type
`AppT` Type
fam Type -> Type -> Type
`appAtom` [Type] -> Type
consTupleAtom [Type]
args1)
Type -> [Q Type] -> Q Type
`appsT` (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
args2)
else Type -> [Q Type] -> Q Type
kon Type
ty [Q Type]
args
go ty :: Type
ty@PromotedT{} = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@TupleT{} = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@Type
ArrowT = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@Type
ListT = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@PromotedTupleT{} = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@Type
PromotedNilT = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@Type
PromotedConsT = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@Type
StarT = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@Type
ConstraintT = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@LitT{} = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@Type
WildCardT = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@UnboxedTupleT{} = Type -> [Q Type] -> Q Type
kon Type
ty
go ty :: Type
ty@UnboxedSumT{} = Type -> [Q Type] -> Q Type
kon Type
ty
go Type
EqualityT = Type -> [Q Type] -> Q Type
kon (Name -> Type
ConT ''(~~))
#if MIN_VERSION_template_haskell(2,17,0)
go ty :: Type
ty@MulArrowT{} = Type -> [Q Type] -> Q Type
kon Type
ty
#endif
go (AppT Type
ty1 Type
ty2) = Type -> [Q Type] -> Q Type
go Type
ty1 ([Q Type] -> Q Type)
-> ([Q Type] -> [Q Type]) -> [Q Type] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [Q Type] -> Q Type
go Type
ty2 [] Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
:)
go (InfixT Type
ty1 Name
n Type
ty2) = Type -> [Q Type] -> Q Type
go (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2)
go (UInfixT Type
ty1 Name
n Type
ty2) = Type -> [Q Type] -> Q Type
go (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2)
#if MIN_VERSION_template_haskell(2,19,0)
go (PromotedInfixT Type
ty1 Name
n Type
ty2) = Type -> [Q Type] -> Q Type
go (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2)
go (PromotedUInfixT Type
ty1 Name
n Type
ty2) = Type -> [Q Type] -> Q Type
go (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2)
#endif
go (SigT Type
ty Type
_) = Type -> [Q Type] -> Q Type
go Type
ty
go (ParensT Type
ty) = (Type -> Type) -> Q Type -> Q Type
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
ParensT (Q Type -> Q Type) -> ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Q Type] -> Q Type
go Type
ty
#if MIN_VERSION_template_haskell(2,15,0)
go (AppKindT Type
ty Type
_) = Type -> [Q Type] -> Q Type
go Type
ty
go (ImplicitParamT String
n Type
ty) = Type -> [Q Type] -> Q Type
go (Name -> Type
ConT ''IP Type -> Type -> Type
`AppT` TyLit -> Type
LitT (String -> TyLit
StrTyLit String
n) Type -> Type -> Type
`AppT` Type
ty)
#endif
go ty :: Type
ty@ForallT{} = \[Q Type]
_ -> String -> Type -> Q Type
forall a. String -> Type -> Q a
can'tRepresent String
"rank-n type" Type
ty
#if MIN_VERSION_template_haskell(2,16,0)
go ty :: Type
ty@ForallVisT{} = \[Q Type]
_ -> String -> Type -> Q Type
forall a. String -> Type -> Q a
can'tRepresent String
"rank-n type" Type
ty
#endif
kon :: Type -> [Q Type] -> Q Type
kon :: Type -> [Q Type] -> Q Type
kon Type
ty [Q Type]
tys = do Type
ty' <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Kon Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
Type -> [Q Type] -> Q Type
appsT Type
ty' [Q Type]
tys
appsT :: Type -> [Q Type] -> Q Type
appsT :: Type -> [Q Type] -> Q Type
appsT Type
ty1 [] = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty1
appsT Type
ty1 (Q Type
ty2' : [Q Type]
tys) = do Type
ty2 <- Q Type
ty2'
case (Type
ty1, Type
ty2) of
(PromotedT Name
kon1 `AppT` Type
tyArg1,
PromotedT Name
kon2 `AppT` Type
tyArg2)
| Name
kon1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Kon, Name
kon2 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Kon
-> Type -> [Q Type] -> Q Type
kon (Type -> Type -> Type
AppT Type
tyArg1 Type
tyArg2) [Q Type]
tys
(Type
_, Type
_) -> Type -> [Q Type] -> Q Type
appsT (Type
ty1 Type -> Type -> Type
`appAtom` Type
ty2) [Q Type]
tys
can'tRepresent :: String -> Type -> Q a
can'tRepresent :: forall a. String -> Type -> Q a
can'tRepresent String
thing Type
ty = String -> Q a
forall a. 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
"Unsupported " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
thing String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
ty
allTvbNames :: [Name]
allTvbNames :: [Name]
allTvbNames = (TyVarBndr_ () -> Name) -> [TyVarBndr_ ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr_ ()]
exTvbs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
univVarNames
fixityIPromotedType :: Maybe TH.Fixity -> Bool -> Q Type
fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type
fixityIPromotedType Maybe Fixity
mbFi Bool
True =
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'InfixI
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Associativity -> Q Type
promoteAssociativity (FixityDirection -> Associativity
fdToAssociativity FixityDirection
fd)
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Integer -> Q TyLit
forall (m :: * -> *). Quote m => Integer -> m TyLit
numTyLit (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n))
where
Fixity Int
n FixityDirection
fd = Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity Maybe Fixity
mbFi
fixityIPromotedType Maybe Fixity
_ Bool
False = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'PrefixI
isKonApp :: Type -> Bool
isKonApp :: Type -> Bool
isKonApp (PromotedT Name
kon `AppT` Type
_) = Name
kon Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Kon
isKonApp Type
_ = Bool
False
appAtom :: Type -> Type -> Type
appAtom :: Type -> Type -> Type
appAtom Type
t Type
t' = Type -> Name -> Type -> Type
InfixT Type
t '(:@:) Type
t'
consTupleAtom :: [Type] -> Type
consTupleAtom :: [Type] -> Type
consTupleAtom [] = Name -> Type
PromotedT 'Kon Type -> Type -> Type
`AppT` Name -> Type
PromotedT '()
consTupleAtom (Type
t : [Type]
ts) =
(Name -> Type
PromotedT 'Kon Type -> Type -> Type
`AppT` Name -> Type
PromotedT '(,)) Type -> Type -> Type
`appAtom` Type
t Type -> Type -> Type
`appAtom` [Type] -> Type
consTupleAtom [Type]
ts
deriveFromK :: [ConstructorInfo] -> Q Dec
deriveFromK :: [ConstructorInfo] -> Q Dec
deriveFromK [ConstructorInfo]
cons = do
Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'fromK
[[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'M1 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) [Q Match]
cases)
[]]
where
cases :: [Q Match]
cases :: [Q Match]
cases = (Int -> ConstructorInfo -> Q Match)
-> [Int] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> ConstructorInfo -> Q Match
fromCon ([ConstructorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons)) [Int
1..] [ConstructorInfo]
cons
fromCon :: Int
-> Int
-> ConstructorInfo -> Q Match
fromCon :: Int -> Int -> ConstructorInfo -> Q Match
fromCon Int
n Int
i ConstructorInfo{ constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVars :: ConstructorInfo -> [TyVarBndr_ ()]
constructorVars = [TyVarBndr_ ()]
exTvbs
, constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
conCtxt
, constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
fields
} = do
[Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fields
Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fNames))
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
n (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'M1 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
do Exp
prod <- (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\Q Exp
x Q Exp
y -> Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
x) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE '(:*:)) (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
y))
(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'U1)
((Name -> Type -> Q Exp) -> [Name] -> [Type] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Type -> Q Exp
fromField [Name]
fNames [Type]
fields)
Exp
ctxtProd <- Exp -> Q Exp
context Exp
prod
Exp -> Q Exp
existentials Exp
ctxtProd)
[]
where
fromField :: Name -> Type -> Q Exp
fromField :: Name -> Type -> Q Exp
fromField Name
fName Type
fty = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'M1 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Field Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Type -> Q Exp -> Q Exp
prenex Type
fty (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName))
prenex :: Type -> Q Exp -> Q Exp
prenex :: Type -> Q Exp -> Q Exp
prenex (ForallT [TyVarBndr Specificity]
vars [Type]
ctxt Type
ty) Q Exp
e =
(TyVarBndr Specificity -> Q Exp -> Q Exp)
-> Q Exp -> [TyVarBndr Specificity] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TyVarBndr Specificity
_ -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'ForAllI)) ([Type] -> Exp -> Q Exp
cocontext [Type]
ctxt (Exp -> Q Exp) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Q Exp -> Q Exp
prenex Type
ty Q Exp
e) [TyVarBndr Specificity]
vars
prenex Type
_ Q Exp
e = Q Exp
e
context :: Exp -> Q Exp
context :: Exp -> Q Exp
context = Name -> [Type] -> Exp -> Q Exp
ntext 'SuchThat [Type]
conCtxt
cocontext :: Cxt -> Exp -> Q Exp
cocontext :: [Type] -> Exp -> Q Exp
cocontext = Name -> [Type] -> Exp -> Q Exp
ntext 'SuchThatI
ntext :: Name -> Cxt -> Exp -> Q Exp
ntext :: Name -> [Type] -> Exp -> Q Exp
ntext Name
suchThat [Type]
ctxt Exp
e =
case [Type]
ctxt of
[] -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
[Type]
_ -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
suchThat Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
existentials :: Exp -> Q Exp
existentials :: Exp -> Q Exp
existentials Exp
e = (Q Exp -> TyVarBndr_ () -> Q Exp)
-> Q Exp -> [TyVarBndr_ ()] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Exp
x TyVarBndr_ ()
_ -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Exists Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x) (Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e) [TyVarBndr_ ()]
exTvbs
deriveToK :: [ConstructorInfo] -> Q Dec
deriveToK :: [ConstructorInfo] -> Q Dec
deriveToK [ConstructorInfo]
cons = do
Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'toK
[[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'M1 [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]]
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) [Q Match]
cases)
[]]
where
cases :: [Q Match]
cases :: [Q Match]
cases = (Int -> ConstructorInfo -> Q Match)
-> [Int] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> ConstructorInfo -> Q Match
toCon ([ConstructorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons)) [Int
1..] [ConstructorInfo]
cons
toCon :: Int
-> Int
-> ConstructorInfo -> Q Match
toCon :: Int -> Int -> ConstructorInfo -> Q Match
toCon Int
n Int
i ConstructorInfo{ constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVars :: ConstructorInfo -> [TyVarBndr_ ()]
constructorVars = [TyVarBndr_ ()]
exTvbs
, constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
conCtxt
, constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
fields
} = do
[Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fields
Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
n (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'M1
[ do Pat
prod <- (Q Pat -> Q Pat -> Q Pat) -> Q Pat -> [Q Pat] -> Q Pat
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\Q Pat
x Q Pat
y -> Q Pat -> Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP Q Pat
x '(:*:) Q Pat
y)
(Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'U1 [])
((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
x -> Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'M1 [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Field [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]]) [Name]
fNames)
Pat
ctxtProd <- Pat -> Q Pat
context Pat
prod
Pat -> Q Pat
existentials Pat
ctxtProd
] )
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName) ((Name -> Type -> Q Exp) -> [Name] -> [Type] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Type -> Q Exp
toField [Name]
fNames [Type]
fields))
[]
where
toField :: Name -> Type -> Q Exp
toField :: Name -> Type -> Q Exp
toField Name
fName Type
ty = Type -> Q Exp -> Q Exp
prenex Type
ty (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName)
prenex :: Type -> Q Exp -> Q Exp
prenex :: Type -> Q Exp -> Q Exp
prenex (ForallT [TyVarBndr Specificity]
vars [Type]
ctxt Type
ty) Q Exp
e =
Type -> Q Exp -> Q Exp
prenex Type
ty ([Type] -> Exp -> Q Exp
cocontext [Type]
ctxt (Exp -> Q Exp) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Q Exp -> TyVarBndr Specificity -> Q Exp)
-> Q Exp -> [TyVarBndr Specificity] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x TyVarBndr Specificity
_ -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'unwrapI Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toWrappedI Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x)) Q Exp
e [TyVarBndr Specificity]
vars)
prenex Type
_ Q Exp
e = Q Exp
e
context :: Pat -> Q Pat
context :: Pat -> Q Pat
context = (Q Pat -> Q Pat) -> [Type] -> Pat -> Q Pat
forall a. (Q a -> Q a) -> [Type] -> a -> Q a
ntext (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'SuchThat ([Q Pat] -> Q Pat) -> (Q Pat -> [Q Pat]) -> Q Pat -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
:[])) [Type]
conCtxt
cocontext :: Cxt -> Exp -> Q Exp
cocontext :: [Type] -> Exp -> Q Exp
cocontext = (Q Exp -> Q Exp) -> [Type] -> Exp -> Q Exp
forall a. (Q a -> Q a) -> [Type] -> a -> Q a
ntext (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'unSuchThatI Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`)
ntext :: (Q a -> Q a) -> Cxt -> a -> Q a
ntext :: forall a. (Q a -> Q a) -> [Type] -> a -> Q a
ntext Q a -> Q a
suchThat [Type]
ctxt a
p =
case [Type]
ctxt of
[] -> a -> Q a
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
p
[Type]
_ -> Q a -> Q a
suchThat (a -> Q a
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
p)
existentials :: Pat -> Q Pat
existentials :: Pat -> Q Pat
existentials Pat
p = (Q Pat -> TyVarBndr_ () -> Q Pat)
-> Q Pat -> [TyVarBndr_ ()] -> Q Pat
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Pat
x TyVarBndr_ ()
_ -> Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Exists [Q Pat
x]) (Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
p) [TyVarBndr_ ()]
exTvbs
typeKind :: Type -> Kind
typeKind :: Type -> Type
typeKind (SigT Type
_ Type
k) = Type
k
typeKind Type
_ = Name -> Type
ConT ''Kind.Type
fdToAssociativity :: FixityDirection -> Associativity
fdToAssociativity :: FixityDirection -> Associativity
fdToAssociativity FixityDirection
InfixL = Associativity
LeftAssociative
fdToAssociativity FixityDirection
InfixR = Associativity
RightAssociative
fdToAssociativity FixityDirection
InfixN = Associativity
NotAssociative
generifyUnpackedness :: Unpackedness -> Generics.SourceUnpackedness
generifyUnpackedness :: Unpackedness -> SourceUnpackedness
generifyUnpackedness Unpackedness
UnspecifiedUnpackedness = SourceUnpackedness
Generics.NoSourceUnpackedness
generifyUnpackedness Unpackedness
NoUnpack = SourceUnpackedness
Generics.SourceNoUnpack
generifyUnpackedness Unpackedness
Unpack = SourceUnpackedness
Generics.SourceUnpack
generifyStrictness :: Strictness -> Generics.SourceStrictness
generifyStrictness :: Strictness -> SourceStrictness
generifyStrictness Strictness
UnspecifiedStrictness = SourceStrictness
Generics.NoSourceStrictness
generifyStrictness Strictness
Lazy = SourceStrictness
Generics.SourceLazy
generifyStrictness Strictness
THAbs.Strict = SourceStrictness
Generics.SourceStrict
generifyDecidedStrictness :: TH.DecidedStrictness -> Generics.DecidedStrictness
generifyDecidedStrictness :: DecidedStrictness -> DecidedStrictness
generifyDecidedStrictness DecidedStrictness
TH.DecidedLazy = DecidedStrictness
Generics.DecidedLazy
generifyDecidedStrictness DecidedStrictness
TH.DecidedStrict = DecidedStrictness
Generics.DecidedStrict
generifyDecidedStrictness DecidedStrictness
TH.DecidedUnpack = DecidedStrictness
Generics.DecidedUnpack
promoteSourceUnpackedness :: Generics.SourceUnpackedness -> Q Type
promoteSourceUnpackedness :: SourceUnpackedness -> Q Type
promoteSourceUnpackedness SourceUnpackedness
Generics.NoSourceUnpackedness = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.NoSourceUnpackedness
promoteSourceUnpackedness SourceUnpackedness
Generics.SourceNoUnpack = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.SourceNoUnpack
promoteSourceUnpackedness SourceUnpackedness
Generics.SourceUnpack = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.SourceUnpack
promoteSourceStrictness :: Generics.SourceStrictness -> Q Type
promoteSourceStrictness :: SourceStrictness -> Q Type
promoteSourceStrictness SourceStrictness
Generics.NoSourceStrictness = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.NoSourceStrictness
promoteSourceStrictness SourceStrictness
Generics.SourceLazy = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.SourceLazy
promoteSourceStrictness SourceStrictness
Generics.SourceStrict = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.SourceStrict
promoteDecidedStrictness :: Generics.DecidedStrictness -> Q Type
promoteDecidedStrictness :: DecidedStrictness -> Q Type
promoteDecidedStrictness DecidedStrictness
Generics.DecidedLazy = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.DecidedLazy
promoteDecidedStrictness DecidedStrictness
Generics.DecidedStrict = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.DecidedStrict
promoteDecidedStrictness DecidedStrictness
Generics.DecidedUnpack = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.DecidedUnpack
promoteAssociativity :: Associativity -> Q Type
promoteAssociativity :: Associativity -> Q Type
promoteAssociativity Associativity
LeftAssociative = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'LeftAssociative
promoteAssociativity Associativity
RightAssociative = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'RightAssociative
promoteAssociativity Associativity
NotAssociative = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'NotAssociative
promoteBool :: Bool -> Q Type
promoteBool :: Bool -> Q Type
promoteBool Bool
True = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'True
promoteBool Bool
False = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'False
enumerateTyVar :: Int -> Type
enumerateTyVar :: Int -> Type
enumerateTyVar Int
0 = Name -> Type
ConT ''Var0
enumerateTyVar Int
1 = Name -> Type
ConT ''Var1
enumerateTyVar Int
2 = Name -> Type
ConT ''Var2
enumerateTyVar Int
3 = Name -> Type
ConT ''Var3
enumerateTyVar Int
4 = Name -> Type
ConT ''Var4
enumerateTyVar Int
5 = Name -> Type
ConT ''Var5
enumerateTyVar Int
6 = Name -> Type
ConT ''Var6
enumerateTyVar Int
7 = Name -> Type
ConT ''Var7
enumerateTyVar Int
8 = Name -> Type
ConT ''Var8
enumerateTyVar Int
9 = Name -> Type
ConT ''Var9
enumerateTyVar Int
n = Name -> Type
PromotedT 'Var Type -> Type -> Type
`AppT` Int -> (Type -> Type) -> Type -> Type
forall a. Int -> (a -> a) -> a -> a
nTimes Int
n (Type -> Type -> Type
AppT (Name -> Type
PromotedT 'VS)) (Name -> Type
PromotedT 'VZ)
foldBal :: (a -> a -> a) -> a -> [a] -> a
foldBal :: forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
_ a
x [] = a
x
foldBal a -> a -> a
_ a
_ [a
y] = a
y
foldBal a -> a -> a
op a
x [a]
l = let ([a]
a,[a]
b) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [a]
l
in (a -> a -> a) -> a -> [a] -> a
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
op a
x [a]
a a -> a -> a
`op` (a -> a -> a) -> a -> [a] -> a
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
op a
x [a]
b
lrP :: Int
-> Int
-> Q Pat -> Q Pat
lrP :: Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
n Q Pat
p
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrP: impossible"
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Q Pat
p
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2 = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'L1 [Int -> Int -> Q Pat -> Q Pat
lrP Int
i (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Pat
p]
| Bool
otherwise = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'R1 [Int -> Int -> Q Pat -> Q Pat
lrP (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) Q Pat
p]
where m :: Int
m = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2
lrE :: Int
-> Int
-> Q Exp -> Q Exp
lrE :: Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
n Q Exp
e
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrE: impossible"
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Q Exp
e
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2 = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'L1 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE Int
i (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Exp
e
| Bool
otherwise = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'R1 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) Q Exp
e
where m :: Int
m = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2
isNewtypeVariant :: DatatypeVariant -> Bool
isNewtypeVariant :: DatatypeVariant -> Bool
isNewtypeVariant DatatypeVariant
Datatype = Bool
False
isNewtypeVariant DatatypeVariant
Newtype = Bool
True
isNewtypeVariant DatatypeVariant
DataInstance = Bool
False
isNewtypeVariant DatatypeVariant
NewtypeInstance = Bool
True
#if MIN_VERSION_th_abstraction(0,5,0)
isNewtypeVariant DatatypeVariant
THAbs.TypeData = Bool
False
#endif
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe (VarT Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT Type
t Type
_) = Type -> Maybe Name
varTToName_maybe Type
t
varTToName_maybe Type
_ = Maybe Name
forall a. Maybe a
Nothing
varTToName :: Type -> Name
varTToName :: Type -> Name
varTToName = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (String -> Name
forall a. HasCallStack => String -> a
error String
"Not a type variable!") (Maybe Name -> Name) -> (Type -> Maybe Name) -> Type -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Name
varTToName_maybe
zipWith4M :: Monad m => (a -> b -> c -> d -> m e)
-> [a] -> [b] -> [c] -> [d] -> m [e]
zipWith4M :: forall (m :: * -> *) a b c d e.
Monad m =>
(a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e]
zipWith4M a -> b -> c -> d -> m e
_ [] [b]
_ [c]
_ [d]
_ = [e] -> m [e]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
_ [a]
_ [] [c]
_ [d]
_ = [e] -> m [e]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
_ [a]
_ [b]
_ [] [d]
_ = [e] -> m [e]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
_ [a]
_ [b]
_ [c]
_ [] = [e] -> m [e]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
f (a
x:[a]
xs) (b
y:[b]
ys) (c
z:[c]
zs) (d
a:[d]
as)
= do e
r <- a -> b -> c -> d -> m e
f a
x b
y c
z d
a
[e]
rs <- (a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e]
forall (m :: * -> *) a b c d e.
Monad m =>
(a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e]
zipWith4M a -> b -> c -> d -> m e
f [a]
xs [b]
ys [c]
zs [d]
as
[e] -> m [e]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([e] -> m [e]) -> [e] -> m [e]
forall a b. (a -> b) -> a -> b
$ e
re -> [e] -> [e]
forall a. a -> [a] -> [a]
:[e]
rs
nTimes :: Int -> (a -> a) -> (a -> a)
nTimes :: forall a. Int -> (a -> a) -> a -> a
nTimes Int
0 a -> a
_ = a -> a
forall a. a -> a
id
nTimes Int
1 a -> a
f = a -> a
f
nTimes Int
n a -> a
f = a -> a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (a -> a) -> a -> a
forall a. Int -> (a -> a) -> a -> a
nTimes (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) a -> a
f
newNameList :: String -> Int -> Q [Name]
newNameList :: String -> Int -> Q [Name]
newNameList String
prefix Int
n = (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
n]
gatherExistentials :: [ConstructorInfo] -> [TyVarBndrUnit]
gatherExistentials :: [ConstructorInfo] -> [TyVarBndr_ ()]
gatherExistentials = (ConstructorInfo -> [TyVarBndr_ ()])
-> [ConstructorInfo] -> [TyVarBndr_ ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorInfo -> [TyVarBndr_ ()]
constructorVars
gatherConstraints :: [ConstructorInfo] -> [Pred]
gatherConstraints :: [ConstructorInfo] -> [Type]
gatherConstraints = (ConstructorInfo -> [Type]) -> [ConstructorInfo] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorInfo -> [Type]
constructorContext
gatherFields :: [ConstructorInfo] -> [Type]
gatherFields :: [ConstructorInfo] -> [Type]
gatherFields = (ConstructorInfo -> [Type]) -> [ConstructorInfo] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorInfo -> [Type]
constructorFields
isInTypeFamilyApp :: Name -> Type -> Q Bool
isInTypeFamilyApp :: Name -> Type -> Q Bool
isInTypeFamilyApp Name
name = Type -> Q Bool
go
where
go :: Type -> Q Bool
go :: Type -> Q Bool
go ty :: Type
ty@AppT{} = case Type -> (Type, [Type])
splitAppTs Type
ty of
(Type
tyFun, [Type]
tyArgs)
| ConT Name
tcName <- Type
tyFun
-> Name -> [Type] -> Q Bool
goTyConApp Name
tcName [Type]
tyArgs
| Bool
otherwise
-> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Bool) -> [Type] -> Q [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Q Bool
go (Type
tyFunType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
tyArgs)
go (InfixT Type
ty1 Name
n Type
ty2) = Type -> Q Bool
go (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2)
go (SigT Type
ty Type
ki) = (Bool -> Bool -> Bool) -> Q Bool -> Q Bool -> Q Bool
forall a b c. (a -> b -> c) -> Q a -> Q b -> Q c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||) (Type -> Q Bool
go Type
ty) (Type -> Q Bool
go Type
ki)
go (ParensT Type
ty) = Type -> Q Bool
go Type
ty
go Type
_ = Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
goTyConApp :: Name -> [Type] -> Q Bool
goTyConApp :: Name -> [Type] -> Q Bool
goTyConApp Name
tcName [Type]
tcArgs = do
Info
info <- Name -> Q Info
reify Name
tcName
case Info
info of
FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr_ ()]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_
-> [TyVarBndr_ ()] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr_ ()]
bndrs
FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr_ ()]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
-> [TyVarBndr_ ()] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr_ ()]
bndrs
Info
_ -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
where
withinFirstArgs :: [a] -> Q Bool
withinFirstArgs :: forall a. [a] -> Q Bool
withinFirstArgs [a]
bndrs =
let firstArgs :: [Type]
firstArgs = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) [Type]
tcArgs
in Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
firstArgs
splitAppTs :: Type -> (Type, [Type])
splitAppTs :: Type -> (Type, [Type])
splitAppTs Type
ty = Type -> Type -> [Type] -> (Type, [Type])
split Type
ty Type
ty []
where
split :: Type -> Type -> [Type] -> (Type, [Type])
split :: Type -> Type -> [Type] -> (Type, [Type])
split Type
_ (AppT Type
ty1 Type
ty2) [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
split Type
ty1 Type
ty1 (Type
ty2Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args)
split Type
origTy (InfixT Type
ty1 Name
n Type
ty2) [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
split Type
origTy (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2) [Type]
args
split Type
origTy (SigT Type
ty' Type
_) [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
split Type
origTy Type
ty' [Type]
args
split Type
origTy (ParensT Type
ty') [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
split Type
origTy Type
ty' [Type]
args
split Type
origTy Type
_ [Type]
args = (Type
origTy, [Type]
args)
resolveConSynonyms :: ConstructorInfo -> Q ConstructorInfo
resolveConSynonyms :: ConstructorInfo -> Q ConstructorInfo
resolveConSynonyms con :: ConstructorInfo
con@ConstructorInfo{ constructorVars :: ConstructorInfo -> [TyVarBndr_ ()]
constructorVars = [TyVarBndr_ ()]
vars
, constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
context
, constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
fields
} = do
[TyVarBndr_ ()]
vars' <- (TyVarBndr_ () -> Q (TyVarBndr_ ()))
-> [TyVarBndr_ ()] -> Q [TyVarBndr_ ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\TyVarBndr_ ()
tvb ->
(Name -> Q (TyVarBndr_ ()))
-> (Name -> Type -> Q (TyVarBndr_ ()))
-> TyVarBndr_ ()
-> Q (TyVarBndr_ ())
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
_n -> TyVarBndr_ () -> Q (TyVarBndr_ ())
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyVarBndr_ ()
tvb)
(\Name
n Type
k -> Name -> Type -> TyVarBndr_ ()
kindedTV Name
n (Type -> TyVarBndr_ ()) -> Q Type -> Q (TyVarBndr_ ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveTypeSynonyms Type
k) TyVarBndr_ ()
tvb) [TyVarBndr_ ()]
vars
[Type]
context' <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Q Type
resolveTypeSynonyms [Type]
context
[Type]
fields' <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Q Type
resolveTypeSynonyms [Type]
fields
ConstructorInfo -> Q ConstructorInfo
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorInfo -> Q ConstructorInfo)
-> ConstructorInfo -> Q ConstructorInfo
forall a b. (a -> b) -> a -> b
$ ConstructorInfo
con{ constructorVars = vars'
, constructorContext = context'
, constructorFields = fields'
}
newtype GenericKQueue = GenericKQueue [Dec]
pushGenericKQueue :: [Dec] -> Q ()
pushGenericKQueue :: [Dec] -> Q ()
pushGenericKQueue [Dec]
d = do
GenericKQueue [Dec]
decs <- GenericKQueue -> Maybe GenericKQueue -> GenericKQueue
forall a. a -> Maybe a -> a
fromMaybe ([Dec] -> GenericKQueue
GenericKQueue []) (Maybe GenericKQueue -> GenericKQueue)
-> Q (Maybe GenericKQueue) -> Q GenericKQueue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe GenericKQueue)
forall a. Typeable a => Q (Maybe a)
TH.getQ
GenericKQueue -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ ([Dec] -> GenericKQueue
GenericKQueue ([Dec]
d [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decs))
takeGenericKQueue :: Q [Dec]
takeGenericKQueue :: Q [Dec]
takeGenericKQueue = do
GenericKQueue [Dec]
decs <- GenericKQueue -> Maybe GenericKQueue -> GenericKQueue
forall a. a -> Maybe a -> a
fromMaybe ([Dec] -> GenericKQueue
GenericKQueue []) (Maybe GenericKQueue -> GenericKQueue)
-> Q (Maybe GenericKQueue) -> Q GenericKQueue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe GenericKQueue)
forall a. Typeable a => Q (Maybe a)
TH.getQ
GenericKQueue -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ ([Dec] -> GenericKQueue
GenericKQueue [])
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
decs
newtype FcfifyQueue = FcfifyQueue [Dec]
pushFcfifyQueue :: [Dec] -> Q ()
pushFcfifyQueue :: [Dec] -> Q ()
pushFcfifyQueue [Dec]
d = do
FcfifyQueue [Dec]
decs <- FcfifyQueue -> Maybe FcfifyQueue -> FcfifyQueue
forall a. a -> Maybe a -> a
fromMaybe ([Dec] -> FcfifyQueue
FcfifyQueue []) (Maybe FcfifyQueue -> FcfifyQueue)
-> Q (Maybe FcfifyQueue) -> Q FcfifyQueue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe FcfifyQueue)
forall a. Typeable a => Q (Maybe a)
TH.getQ
FcfifyQueue -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ ([Dec] -> FcfifyQueue
FcfifyQueue ([Dec]
d [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decs))
takeFcfifyQueue :: Q [Dec]
takeFcfifyQueue :: Q [Dec]
takeFcfifyQueue = do
FcfifyQueue [Dec]
decs <- FcfifyQueue -> Maybe FcfifyQueue -> FcfifyQueue
forall a. a -> Maybe a -> a
fromMaybe ([Dec] -> FcfifyQueue
FcfifyQueue []) (Maybe FcfifyQueue -> FcfifyQueue)
-> Q (Maybe FcfifyQueue) -> Q FcfifyQueue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe FcfifyQueue)
forall a. Typeable a => Q (Maybe a)
TH.getQ
FcfifyQueue -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ ([Dec] -> FcfifyQueue
FcfifyQueue [])
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
decs