{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE UnboxedTuples #-}
module Language.Haskell.TH.Syntax (
Quote (..),
Exp (..),
Match (..),
Clause (..),
Q (..),
Pat (..),
Stmt (..),
Con (..),
Type (..),
Dec (..),
BangType,
VarBangType,
FieldExp,
FieldPat,
Name (..),
FunDep (..),
Pred,
RuleBndr (..),
TySynEqn (..),
InjectivityAnn (..),
Kind,
Overlap (..),
DerivClause (..),
DerivStrategy (..),
Code (..),
ModName (..),
addCorePlugin,
addDependentFile,
addForeignFile,
addForeignFilePath,
addForeignSource,
addModFinalizer,
addTempFile,
addTopDecls,
badIO,
bindCode,
bindCode_,
cmpEq,
compareBytes,
counter,
defaultFixity,
eqBytes,
extsEnabled,
getDoc,
getPackageRoot,
getQ,
get_cons_names,
hoistCode,
isExtEnabled,
isInstance,
joinCode,
liftCode,
location,
lookupName,
lookupTypeName,
lookupValueName,
manyName,
maxPrecedence,
memcmp,
mkNameG,
mkNameU,
mkOccName,
mkPkgName,
mk_tup_name,
mkName,
mkNameG_v,
mkNameG_d,
mkNameG_tc,
mkNameL,
mkNameS,
unTypeCode,
mkModName,
unsafeCodeCoerce,
mkNameQ,
mkNameG_fld,
modString,
nameBase,
nameModule,
namePackage,
nameSpace,
newDeclarationGroup,
newNameIO,
occString,
oneName,
pkgString,
putDoc,
putQ,
recover,
reify,
reifyAnnotations,
reifyConStrictness,
reifyFixity,
reifyInstances,
reifyModule,
reifyRoles,
reifyType,
report,
reportError,
reportWarning,
runIO,
sequenceQ,
runQ,
showName,
showName',
thenCmp,
tupleDataName,
tupleTypeName,
unTypeQ,
unboxedSumDataName,
unboxedSumTypeName,
unboxedTupleDataName,
unboxedTupleTypeName,
unsafeTExpCoerce,
ForeignSrcLang (..),
Extension (..),
AnnLookup (..),
AnnTarget (..),
Arity,
Bang (..),
BndrVis (..),
Body (..),
Bytes (..),
Callconv (..),
CharPos,
Cxt,
DecidedStrictness (..),
DocLoc (..),
FamilyResultSig (..),
Fixity (..),
FixityDirection (..),
Foreign (..),
Guard (..),
Info (..),
Inline (..),
InstanceDec,
Lit (..),
Loc (..),
Module (..),
ModuleInfo (..),
NameFlavour (..),
NameIs (..),
NameSpace (..),
NamespaceSpecifier (..),
OccName (..),
ParentName,
PatSynArgs (..),
PatSynDir (..),
PatSynType,
Phases (..),
PkgName (..),
Pragma (..),
Quasi (..),
Range (..),
Role (..),
RuleMatch (..),
Safety (..),
SourceStrictness (..),
SourceUnpackedness (..),
Specificity (..),
Strict,
StrictType,
SumAlt,
SumArity,
TExp (..),
TyLit (..),
TyVarBndr (..),
TypeFamilyHead (..),
Uniq,
Unlifted,
VarStrictType,
makeRelativeToProject,
liftString,
Lift (..),
dataToCodeQ,
dataToExpQ,
dataToPatQ,
dataToQa,
falseName,
justName,
leftName,
liftData,
liftDataTyped,
nonemptyName,
nothingName,
rightName,
trueName,
)
where
import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
import System.FilePath
import Data.Data hiding (Fixity(..))
import Data.List.NonEmpty (NonEmpty(..))
import GHC.Lexeme ( startsVarSym, startsVarId )
addForeignFile :: ForeignSrcLang -> String -> Q ()
addForeignFile :: ForeignSrcLang -> String -> Q ()
addForeignFile = ForeignSrcLang -> String -> Q ()
addForeignSource
{-# DEPRECATED addForeignFile
"Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"
#-}
makeRelativeToProject :: FilePath -> Q FilePath
makeRelativeToProject :: String -> Q String
makeRelativeToProject String
fp | String -> Bool
isRelative String
fp = do
root <- Q String
getPackageRoot
return (root </> fp)
makeRelativeToProject String
fp = String -> Q String
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return String
fp
trueName, falseName :: Name
trueName :: Name
trueName = 'True
falseName :: Name
falseName = 'False
nothingName, justName :: Name
nothingName :: Name
nothingName = 'Nothing
justName :: Name
justName = 'Just
leftName, rightName :: Name
leftName :: Name
leftName = 'Left
rightName :: Name
rightName = 'Right
nonemptyName :: Name
nonemptyName :: Name
nonemptyName = '(:|)
dataToQa :: forall m a k q. (Quote m, Data a)
=> (Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b . Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa :: forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> k
mkCon Lit -> m q
mkLit k -> [m q] -> m q
appCon forall b. Data b => b -> Maybe (m q)
antiQ a
t =
case a -> Maybe (m q)
forall b. Data b => b -> Maybe (m q)
antiQ a
t of
Maybe (m q)
Nothing ->
case Constr -> ConstrRep
constrRep Constr
constr of
AlgConstr ConIndex
_ ->
k -> [m q] -> m q
appCon (Name -> k
mkCon Name
funOrConName) [m q]
conArgs
where
funOrConName :: Name
funOrConName :: Name
funOrConName =
case Constr -> String
showConstr Constr
constr of
String
"(:)" -> OccName -> NameFlavour -> Name
Name (String -> OccName
mkOccName String
":")
(NameSpace -> PkgName -> ModName -> NameFlavour
NameG NameSpace
DataName
(String -> PkgName
mkPkgName String
"ghc-internal")
(String -> ModName
mkModName String
"GHC.Internal.Types"))
con :: String
con@String
"[]" -> OccName -> NameFlavour -> Name
Name (String -> OccName
mkOccName String
con)
(NameSpace -> PkgName -> ModName -> NameFlavour
NameG NameSpace
DataName
(String -> PkgName
mkPkgName String
"ghc-internal")
(String -> ModName
mkModName String
"GHC.Internal.Types"))
con :: String
con@(Char
'(':String
_) -> OccName -> NameFlavour -> Name
Name (String -> OccName
mkOccName String
con)
(NameSpace -> PkgName -> ModName -> NameFlavour
NameG NameSpace
DataName
(String -> PkgName
mkPkgName String
"ghc-internal")
(String -> ModName
mkModName String
"GHC.Internal.Tuple"))
fun :: String
fun@(Char
x:String
_) | Char -> Bool
startsVarSym Char
x Bool -> Bool -> Bool
|| Char -> Bool
startsVarId Char
x
-> String -> String -> String -> Name
mkNameG_v String
tyconPkg String
tyconMod String
fun
String
con -> String -> String -> String -> Name
mkNameG_d String
tyconPkg String
tyconMod String
con
where
tycon :: TyCon
tycon :: TyCon
tycon = (TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> (a -> TypeRep) -> a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf) a
t
tyconPkg, tyconMod :: String
tyconPkg :: String
tyconPkg = TyCon -> String
tyConPackage TyCon
tycon
tyconMod :: String
tyconMod = TyCon -> String
tyConModule TyCon
tycon
conArgs :: [m q]
conArgs :: [m q]
conArgs = (forall d. Data d => d -> m q) -> a -> [m q]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> a -> [u]
gmapQ ((Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> d
-> m q
forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> k
mkCon Lit -> m q
mkLit k -> [m q] -> m q
appCon b -> Maybe (m q)
forall b. Data b => b -> Maybe (m q)
antiQ) a
t
IntConstr Integer
n ->
Lit -> m q
mkLit (Lit -> m q) -> Lit -> m q
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
n
FloatConstr Rational
n ->
Lit -> m q
mkLit (Lit -> m q) -> Lit -> m q
forall a b. (a -> b) -> a -> b
$ Rational -> Lit
RationalL Rational
n
CharConstr Char
c ->
Lit -> m q
mkLit (Lit -> m q) -> Lit -> m q
forall a b. (a -> b) -> a -> b
$ Char -> Lit
CharL Char
c
where
constr :: Constr
constr :: Constr
constr = a -> Constr
forall a. Data a => a -> Constr
toConstr a
t
Just m q
y -> m q
y
dataToCodeQ :: (Quote m, Data a)
=> (forall b . Data b => b -> Maybe (Code m b))
-> a -> Code m a
dataToCodeQ :: forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (Code m b)) -> a -> Code m a
dataToCodeQ forall b. Data b => b -> Maybe (Code m b)
f = m Exp -> Code m a
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (m Exp -> Code m a) -> (a -> m Exp) -> a -> Code m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ ((Code m b -> m Exp) -> Maybe (Code m b) -> Maybe (m Exp)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Code m b -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode (Maybe (Code m b) -> Maybe (m Exp))
-> (b -> Maybe (Code m b)) -> b -> Maybe (m Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe (Code m b)
forall b. Data b => b -> Maybe (Code m b)
f)
dataToExpQ :: (Quote m, Data a)
=> (forall b . Data b => b -> Maybe (m Exp))
-> a
-> m Exp
dataToExpQ :: forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ = (Name -> m Exp)
-> (Lit -> m Exp)
-> (m Exp -> [m Exp] -> m Exp)
-> (forall b. Data b => b -> Maybe (m Exp))
-> a
-> m Exp
forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> m Exp
forall {m :: * -> *}. Monad m => Name -> m Exp
varOrConE Lit -> m Exp
forall {m :: * -> *}. Monad m => Lit -> m Exp
litE ((m Exp -> m Exp -> m Exp) -> m Exp -> [m Exp] -> m Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Exp -> m Exp -> m Exp
forall {m :: * -> *}. Monad m => m Exp -> m Exp -> m Exp
appE)
where
varOrConE :: Name -> m Exp
varOrConE Name
s =
case Name -> Maybe NameSpace
nameSpace Name
s of
Just NameSpace
VarName -> Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
s)
Just (FldName {}) -> Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
s)
Just NameSpace
DataName -> Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
ConE Name
s)
Maybe NameSpace
_ -> String -> m Exp
forall a. HasCallStack => String -> a
error (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"Can't construct an expression from name "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
showName Name
s
appE :: m Exp -> m Exp -> m Exp
appE m Exp
x m Exp
y = do { a <- m Exp
x; b <- y; return (AppE a b)}
litE :: Lit -> m Exp
litE Lit
c = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE Lit
c)
liftDataTyped :: (Quote m, Data a) => a -> Code m a
liftDataTyped :: forall (m :: * -> *) a. (Quote m, Data a) => a -> Code m a
liftDataTyped = (forall b. Data b => b -> Maybe (Code m b)) -> a -> Code m a
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (Code m b)) -> a -> Code m a
dataToCodeQ (Maybe (Code m b) -> b -> Maybe (Code m b)
forall a b. a -> b -> a
const Maybe (Code m b)
forall a. Maybe a
Nothing)
liftData :: (Quote m, Data a) => a -> m Exp
liftData :: forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData = (forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ (Maybe (m Exp) -> b -> Maybe (m Exp)
forall a b. a -> b -> a
const Maybe (m Exp)
forall a. Maybe a
Nothing)
dataToPatQ :: (Quote m, Data a)
=> (forall b . Data b => b -> Maybe (m Pat))
-> a
-> m Pat
dataToPatQ :: forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Pat)) -> a -> m Pat
dataToPatQ = (Name -> Name)
-> (Lit -> m Pat)
-> (Name -> [m Pat] -> m Pat)
-> (forall b. Data b => b -> Maybe (m Pat))
-> a
-> m Pat
forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> Name
forall a. a -> a
id Lit -> m Pat
forall {m :: * -> *}. Monad m => Lit -> m Pat
litP Name -> [m Pat] -> m Pat
forall {m :: * -> *}. Monad m => Name -> [m Pat] -> m Pat
conP
where litP :: Lit -> m Pat
litP Lit
l = Pat -> m Pat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
LitP Lit
l)
conP :: Name -> [m Pat] -> m Pat
conP Name
n [m Pat]
ps =
case Name -> Maybe NameSpace
nameSpace Name
n of
Just NameSpace
DataName -> do
ps' <- [m Pat] -> m [Pat]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [m Pat]
ps
return (ConP n [] ps')
Maybe NameSpace
_ -> String -> m Pat
forall a. HasCallStack => String -> a
error (String -> m Pat) -> String -> m Pat
forall a b. (a -> b) -> a -> b
$ String
"Can't construct a pattern from name "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
showName Name
n