{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Rename.Splice (
rnTopSpliceDecls,
rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
rnBracket,
checkThLocalName
, traceSplice, SpliceInfo(..)
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Tc.Utils.Monad
import GHC.Driver.Env.Types
import GHC.Rename.Env
import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn )
import GHC.Rename.Unbound ( isUnboundName )
import GHC.Rename.Module ( rnSrcDecls, findSplice )
import GHC.Rename.Pat ( rnPat )
import GHC.Types.Basic ( TopLevelFlag, isTopLevel )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Utils.Outputable
import GHC.Unit.Module
import GHC.Types.SrcLoc
import GHC.Rename.HsType ( rnLHsType )
import Control.Monad ( unless, when )
import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy )
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Utils.Logger ( dumpIfSet_dyn_printer, DumpFormat (..), getLogger )
import GHC.Utils.Panic
import GHC.Driver.Hooks
import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName
, patQTyConName, quoteDecName, quoteExpName
, quotePatName, quoteTypeName, typeQTyConName)
import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckPolyExpr )
import {-# SOURCE #-} GHC.Tc.Gen.Splice
( runMetaD
, runMetaE
, runMetaP
, runMetaT
, tcTopSpliceExpr
)
import GHC.Tc.Utils.Zonk
import GHCi.RemoteTypes ( ForeignRef )
import qualified Language.Haskell.TH as TH (Q)
import qualified GHC.LanguageExtensions as LangExt
rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnBracket :: HsExpr GhcPs
-> HsBracket GhcPs -> RnM (HsExpr (GhcPass 'Renamed), Uses)
rnBracket HsExpr GhcPs
e HsBracket GhcPs
br_body
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsBracket GhcPs -> SDoc
quotationCtxtDoc HsBracket GhcPs
br_body) forall a b. (a -> b) -> a -> b
$
do {
Bool
thQuotesEnabled <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TemplateHaskellQuotes
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
thQuotesEnabled forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcRn a
failWith ( [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Syntax error on" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e
, String -> SDoc
text (String
"Perhaps you intended to use TemplateHaskell"
forall a. [a] -> [a] -> [a]
++ String
" or TemplateHaskellQuotes") ] )
; ThStage
cur_stage <- TcM ThStage
getStage
; case ThStage
cur_stage of
{ Splice SpliceType
Typed -> Bool -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc (forall id. HsBracket id -> Bool
isTypedBracket HsBracket GhcPs
br_body)
SDoc
illegalUntypedBracket
; Splice SpliceType
Untyped -> Bool -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc (Bool -> Bool
not (forall id. HsBracket id -> Bool
isTypedBracket HsBracket GhcPs
br_body))
SDoc
illegalTypedBracket
; RunSplice TcRef [ForeignRef (Q ())]
_ ->
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnBracket: Renaming bracket when running a splice"
(forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e)
; ThStage
Comp -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Brack {} -> forall a. SDoc -> TcRn a
failWithTc SDoc
illegalBracket
}
; IOEnv (Env TcGblEnv TcLclEnv) ()
recordThUse
; case forall id. HsBracket id -> Bool
isTypedBracket HsBracket GhcPs
br_body of
Bool
True -> do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"Renaming typed TH bracket" SDoc
empty
; (HsBracket (GhcPass 'Renamed)
body', Uses
fvs_e) <-
forall a. ThStage -> TcM a -> TcM a
setStage (ThStage -> PendingStuff -> ThStage
Brack ThStage
cur_stage PendingStuff
RnPendingTyped) forall a b. (a -> b) -> a -> b
$
ThStage
-> HsBracket GhcPs -> TcRn (HsBracket (GhcPass 'Renamed), Uses)
rn_bracket ThStage
cur_stage HsBracket GhcPs
br_body
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XBracket p -> HsBracket p -> HsExpr p
HsBracket forall a. EpAnn a
noAnn HsBracket (GhcPass 'Renamed)
body', Uses
fvs_e) }
Bool
False -> do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"Renaming untyped TH bracket" SDoc
empty
; IORef [PendingRnSplice]
ps_var <- forall a env. a -> IOEnv env (IORef a)
newMutVar []
; (HsBracket (GhcPass 'Renamed)
body', Uses
fvs_e) <-
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetXOptM Extension
LangExt.RebindableSyntax forall a b. (a -> b) -> a -> b
$
forall a. ThStage -> TcM a -> TcM a
setStage (ThStage -> PendingStuff -> ThStage
Brack ThStage
cur_stage (IORef [PendingRnSplice] -> PendingStuff
RnPendingUntyped IORef [PendingRnSplice]
ps_var)) forall a b. (a -> b) -> a -> b
$
ThStage
-> HsBracket GhcPs -> TcRn (HsBracket (GhcPass 'Renamed), Uses)
rn_bracket ThStage
cur_stage HsBracket GhcPs
br_body
; [PendingRnSplice]
pendings <- forall a env. IORef a -> IOEnv env a
readMutVar IORef [PendingRnSplice]
ps_var
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XRnBracketOut p
-> HsBracket (HsBracketRn p) -> [PendingRnSplice' p] -> HsExpr p
HsRnBracketOut NoExtField
noExtField HsBracket (GhcPass 'Renamed)
body' [PendingRnSplice]
pendings, Uses
fvs_e) }
}
rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
rn_bracket :: ThStage
-> HsBracket GhcPs -> TcRn (HsBracket (GhcPass 'Renamed), Uses)
rn_bracket ThStage
outer_stage br :: HsBracket GhcPs
br@(VarBr XVarBr GhcPs
x Bool
flg LIdP GhcPs
rdr_name)
= do { Name
name <- RdrName -> RnM Name
lookupOccRn (forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
rdr_name)
; Module
this_mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
flg Bool -> Bool -> Bool
&& Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name) forall a b. (a -> b) -> a -> b
$
do { Maybe (TopLevelFlag, ThLevel)
mb_bind_lvl <- Name -> RnM (Maybe (TopLevelFlag, ThLevel))
lookupLocalOccThLvl_maybe Name
name
; case Maybe (TopLevelFlag, ThLevel)
mb_bind_lvl of
{ Maybe (TopLevelFlag, ThLevel)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Just (TopLevelFlag
top_lvl, ThLevel
bind_lvl)
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
-> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
name) (Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
keepAlive Name
name)
| Bool
otherwise
-> do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn_bracket VarBr"
(forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ThLevel
bind_lvl
SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ThStage
outer_stage)
; Bool -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc (ThStage -> ThLevel
thLevel ThStage
outer_stage forall a. Num a => a -> a -> a
+ ThLevel
1 forall a. Eq a => a -> a -> Bool
== ThLevel
bind_lvl)
(HsBracket GhcPs -> SDoc
quotedNameStageErr HsBracket GhcPs
br) }
}
}
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XVarBr p -> Bool -> LIdP p -> HsBracket p
VarBr XVarBr GhcPs
x Bool
flg (forall a an. a -> LocatedAn an a
noLocA Name
name), Name -> Uses
unitFV Name
name) }
rn_bracket ThStage
_ (ExpBr XExpBr GhcPs
x LHsExpr GhcPs
e) = do { (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
e', Uses
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XExpBr p -> LHsExpr p -> HsBracket p
ExpBr XExpBr GhcPs
x GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
e', Uses
fvs) }
rn_bracket ThStage
_ (PatBr XPatBr GhcPs
x LPat GhcPs
p)
= forall a.
HsMatchContext (GhcPass 'Renamed)
-> LPat GhcPs
-> (LPat (GhcPass 'Renamed) -> RnM (a, Uses))
-> RnM (a, Uses)
rnPat forall p. HsMatchContext p
ThPatQuote LPat GhcPs
p forall a b. (a -> b) -> a -> b
$ \ LPat (GhcPass 'Renamed)
p' -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XPatBr p -> LPat p -> HsBracket p
PatBr XPatBr GhcPs
x LPat (GhcPass 'Renamed)
p', Uses
emptyFVs)
rn_bracket ThStage
_ (TypBr XTypBr GhcPs
x LHsType GhcPs
t) = do { (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
t', Uses
fvs) <- HsDocContext
-> LHsType GhcPs -> RnM (LHsType (GhcPass 'Renamed), Uses)
rnLHsType HsDocContext
TypBrCtx LHsType GhcPs
t
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XTypBr p -> LHsType p -> HsBracket p
TypBr XTypBr GhcPs
x GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
t', Uses
fvs) }
rn_bracket ThStage
_ (DecBrL XDecBrL GhcPs
x [LHsDecl GhcPs]
decls)
= do { HsGroup GhcPs
group <- [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls [LHsDecl GhcPs]
decls
; TcGblEnv
gbl_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let new_gbl_env :: TcGblEnv
new_gbl_env = TcGblEnv
gbl_env { tcg_dus :: DefUses
tcg_dus = DefUses
emptyDUs }
; (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
group') <- forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
new_gbl_env forall a b. (a -> b) -> a -> b
$
HsGroup GhcPs
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnSrcDecls HsGroup GhcPs
group
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn_bracket dec" (forall a. Outputable a => a -> SDoc
ppr (TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env) SDoc -> SDoc -> SDoc
$$
forall a. Outputable a => a -> SDoc
ppr (DefUses -> Uses
duUses (TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env)))
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XDecBrG p -> HsGroup p -> HsBracket p
DecBrG XDecBrL GhcPs
x HsGroup (GhcPass 'Renamed)
group', DefUses -> Uses
duUses (TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env)) }
where
groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls [LHsDecl GhcPs]
decls
= do { (HsGroup GhcPs
group, Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
mb_splice) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
decls
; case Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
mb_splice of
{ Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return HsGroup GhcPs
group
; Just (SpliceDecl GhcPs
splice, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
rest) ->
do { HsGroup GhcPs
group' <- [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
rest
; let group'' :: HsGroup GhcPs
group'' = forall (p :: Pass).
HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p)
appendGroups HsGroup GhcPs
group HsGroup GhcPs
group'
; forall (m :: * -> *) a. Monad m => a -> m a
return HsGroup GhcPs
group'' { hs_splcds :: [LSpliceDecl GhcPs]
hs_splcds = forall a an. a -> LocatedAn an a
noLocA SpliceDecl GhcPs
splice forall a. a -> [a] -> [a]
: forall p. HsGroup p -> [LSpliceDecl p]
hs_splcds HsGroup GhcPs
group' }
}
}}
rn_bracket ThStage
_ (DecBrG {}) = forall a. String -> a
panic String
"rn_bracket: unexpected DecBrG"
rn_bracket ThStage
_ (TExpBr XTExpBr GhcPs
x LHsExpr GhcPs
e) = do { (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
e', Uses
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XTExpBr p -> LHsExpr p -> HsBracket p
TExpBr XTExpBr GhcPs
x GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
e', Uses
fvs) }
quotationCtxtDoc :: HsBracket GhcPs -> SDoc
quotationCtxtDoc :: HsBracket GhcPs -> SDoc
quotationCtxtDoc HsBracket GhcPs
br_body
= SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the Template Haskell quotation")
ThLevel
2 (forall a. Outputable a => a -> SDoc
ppr HsBracket GhcPs
br_body)
illegalBracket :: SDoc
illegalBracket :: SDoc
illegalBracket =
String -> SDoc
text String
"Template Haskell brackets cannot be nested" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"(without intervening splices)"
illegalTypedBracket :: SDoc
illegalTypedBracket :: SDoc
illegalTypedBracket =
String -> SDoc
text String
"Typed brackets may only appear in typed splices."
illegalUntypedBracket :: SDoc
illegalUntypedBracket :: SDoc
illegalUntypedBracket =
String -> SDoc
text String
"Untyped brackets may only appear in untyped splices."
quotedNameStageErr :: HsBracket GhcPs -> SDoc
quotedNameStageErr :: HsBracket GhcPs -> SDoc
quotedNameStageErr HsBracket GhcPs
br
= [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Stage error: the non-top-level quoted name" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsBracket GhcPs
br
, String -> SDoc
text String
"must be used at the same stage at which it is bound" ]
rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars))
-> (HsSplice GhcRn -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, FreeVars)
rnSpliceGen :: forall a.
(HsSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, Uses)
rnSpliceGen HsSplice (GhcPass 'Renamed) -> RnM (a, Uses)
run_splice HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a)
pend_splice HsSplice GhcPs
splice
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsSplice GhcPs -> SDoc
spliceCtxt HsSplice GhcPs
splice) forall a b. (a -> b) -> a -> b
$ do
{ ThStage
stage <- TcM ThStage
getStage
; case ThStage
stage of
Brack ThStage
pop_stage PendingStuff
RnPendingTyped
-> do { Bool -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc Bool
is_typed_splice SDoc
illegalUntypedSplice
; (HsSplice (GhcPass 'Renamed)
splice', Uses
fvs) <- forall a. ThStage -> TcM a -> TcM a
setStage ThStage
pop_stage forall a b. (a -> b) -> a -> b
$
HsSplice GhcPs -> TcRn (HsSplice (GhcPass 'Renamed), Uses)
rnSplice HsSplice GhcPs
splice
; let (PendingRnSplice
_pending_splice, a
result) = HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a)
pend_splice HsSplice (GhcPass 'Renamed)
splice'
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Uses
fvs) }
Brack ThStage
pop_stage (RnPendingUntyped IORef [PendingRnSplice]
ps_var)
-> do { Bool -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc (Bool -> Bool
not Bool
is_typed_splice) SDoc
illegalTypedSplice
; (HsSplice (GhcPass 'Renamed)
splice', Uses
fvs) <- forall a. ThStage -> TcM a -> TcM a
setStage ThStage
pop_stage forall a b. (a -> b) -> a -> b
$
HsSplice GhcPs -> TcRn (HsSplice (GhcPass 'Renamed), Uses)
rnSplice HsSplice GhcPs
splice
; let (PendingRnSplice
pending_splice, a
result) = HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a)
pend_splice HsSplice (GhcPass 'Renamed)
splice'
; [PendingRnSplice]
ps <- forall a env. IORef a -> IOEnv env a
readMutVar IORef [PendingRnSplice]
ps_var
; forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef [PendingRnSplice]
ps_var (PendingRnSplice
pending_splice forall a. a -> [a] -> [a]
: [PendingRnSplice]
ps)
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Uses
fvs) }
ThStage
_ -> do { HsSplice GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTopSpliceAllowed HsSplice GhcPs
splice
; (HsSplice (GhcPass 'Renamed)
splice', Uses
fvs1) <- forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
splice_type) forall a b. (a -> b) -> a -> b
$
HsSplice GhcPs -> TcRn (HsSplice (GhcPass 'Renamed), Uses)
rnSplice HsSplice GhcPs
splice
; (a
result, Uses
fvs2) <- HsSplice (GhcPass 'Renamed) -> RnM (a, Uses)
run_splice HsSplice (GhcPass 'Renamed)
splice'
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Uses
fvs1 Uses -> Uses -> Uses
`plusFV` Uses
fvs2) } }
where
is_typed_splice :: Bool
is_typed_splice = forall id. HsSplice id -> Bool
isTypedSplice HsSplice GhcPs
splice
splice_type :: SpliceType
splice_type = if Bool
is_typed_splice
then SpliceType
Typed
else SpliceType
Untyped
checkTopSpliceAllowed :: HsSplice GhcPs -> RnM ()
checkTopSpliceAllowed :: HsSplice GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTopSpliceAllowed HsSplice GhcPs
splice = do
let (String
herald, Extension
ext) = HsSplice GhcPs -> (String, Extension)
spliceExtension HsSplice GhcPs
splice
Bool
extEnabled <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
ext
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
extEnabled
(forall a. SDoc -> TcRn a
failWith forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
herald SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"are not permitted without" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Extension
ext)
where
spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension)
spliceExtension :: HsSplice GhcPs -> (String, Extension)
spliceExtension (HsQuasiQuote {}) = (String
"Quasi-quotes", Extension
LangExt.QuasiQuotes)
spliceExtension (HsTypedSplice {}) = (String
"Top-level splices", Extension
LangExt.TemplateHaskell)
spliceExtension (HsUntypedSplice {}) = (String
"Top-level splices", Extension
LangExt.TemplateHaskell)
spliceExtension s :: HsSplice GhcPs
s@(HsSpliced {}) = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"spliceExtension" (forall a. Outputable a => a -> SDoc
ppr HsSplice GhcPs
s)
runRnSplice :: UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsSplice GhcRn
-> TcRn (res, [ForeignRef (TH.Q ())])
runRnSplice :: forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
flavour LHsExpr GhcTc -> TcRn res
run_meta res -> SDoc
ppr_res HsSplice (GhcPass 'Renamed)
splice
= do { Hooks
hooks <- HscEnv -> Hooks
hsc_hooks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; HsSplice (GhcPass 'Renamed)
splice' <- case Hooks
-> Maybe
(HsSplice (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsSplice (GhcPass 'Renamed)))
runRnSpliceHook Hooks
hooks of
Maybe
(HsSplice (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsSplice (GhcPass 'Renamed)))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return HsSplice (GhcPass 'Renamed)
splice
Just HsSplice (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsSplice (GhcPass 'Renamed))
h -> HsSplice (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsSplice (GhcPass 'Renamed))
h HsSplice (GhcPass 'Renamed)
splice
; let the_expr :: LHsExpr (GhcPass 'Renamed)
the_expr = case HsSplice (GhcPass 'Renamed)
splice' of
HsUntypedSplice XUntypedSplice (GhcPass 'Renamed)
_ SpliceDecoration
_ IdP (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e -> LHsExpr (GhcPass 'Renamed)
e
HsQuasiQuote XQuasiQuote (GhcPass 'Renamed)
_ IdP (GhcPass 'Renamed)
_ IdP (GhcPass 'Renamed)
q SrcSpan
qs FastString
str -> UntypedSpliceFlavour
-> Name -> SrcSpan -> FastString -> LHsExpr (GhcPass 'Renamed)
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour IdP (GhcPass 'Renamed)
q SrcSpan
qs FastString
str
HsTypedSplice {} -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"runRnSplice" (forall a. Outputable a => a -> SDoc
ppr HsSplice (GhcPass 'Renamed)
splice)
HsSpliced {} -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"runRnSplice" (forall a. Outputable a => a -> SDoc
ppr HsSplice (GhcPass 'Renamed)
splice)
; Type
meta_exp_ty <- Name -> TcM Type
tcMetaTy Name
meta_ty_name
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
zonked_q_expr <- LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkTopLExpr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
tcTopSpliceExpr SpliceType
Untyped
(LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr (GhcPass 'Renamed)
the_expr Type
meta_exp_ty)
; TcRef [ForeignRef (Q ())]
mod_finalizers_ref <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef []
; res
result <- forall a. ThStage -> TcM a -> TcM a
setStage (TcRef [ForeignRef (Q ())] -> ThStage
RunSplice TcRef [ForeignRef (Q ())]
mod_finalizers_ref) forall a b. (a -> b) -> a -> b
$
LHsExpr GhcTc -> TcRn res
run_meta GenLocated SrcSpanAnnA (HsExpr GhcTc)
zonked_q_expr
; [ForeignRef (Q ())]
mod_finalizers <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef [ForeignRef (Q ())]
mod_finalizers_ref
; SpliceInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceSplice (SpliceInfo { spliceDescription :: String
spliceDescription = String
what
, spliceIsDecl :: Bool
spliceIsDecl = Bool
is_decl
, spliceSource :: Maybe (LHsExpr (GhcPass 'Renamed))
spliceSource = forall a. a -> Maybe a
Just LHsExpr (GhcPass 'Renamed)
the_expr
, spliceGenerated :: SDoc
spliceGenerated = res -> SDoc
ppr_res res
result })
; forall (m :: * -> *) a. Monad m => a -> m a
return (res
result, [ForeignRef (Q ())]
mod_finalizers) }
where
meta_ty_name :: Name
meta_ty_name = case UntypedSpliceFlavour
flavour of
UntypedSpliceFlavour
UntypedExpSplice -> Name
expQTyConName
UntypedSpliceFlavour
UntypedPatSplice -> Name
patQTyConName
UntypedSpliceFlavour
UntypedTypeSplice -> Name
typeQTyConName
UntypedSpliceFlavour
UntypedDeclSplice -> Name
decsQTyConName
what :: String
what = case UntypedSpliceFlavour
flavour of
UntypedSpliceFlavour
UntypedExpSplice -> String
"expression"
UntypedSpliceFlavour
UntypedPatSplice -> String
"pattern"
UntypedSpliceFlavour
UntypedTypeSplice -> String
"type"
UntypedSpliceFlavour
UntypedDeclSplice -> String
"declarations"
is_decl :: Bool
is_decl = case UntypedSpliceFlavour
flavour of
UntypedSpliceFlavour
UntypedDeclSplice -> Bool
True
UntypedSpliceFlavour
_ -> Bool
False
makePending :: UntypedSpliceFlavour
-> HsSplice GhcRn
-> PendingRnSplice
makePending :: UntypedSpliceFlavour
-> HsSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
flavour (HsUntypedSplice XUntypedSplice (GhcPass 'Renamed)
_ SpliceDecoration
_ IdP (GhcPass 'Renamed)
n LHsExpr (GhcPass 'Renamed)
e)
= UntypedSpliceFlavour
-> Name -> LHsExpr (GhcPass 'Renamed) -> PendingRnSplice
PendingRnSplice UntypedSpliceFlavour
flavour IdP (GhcPass 'Renamed)
n LHsExpr (GhcPass 'Renamed)
e
makePending UntypedSpliceFlavour
flavour (HsQuasiQuote XQuasiQuote (GhcPass 'Renamed)
_ IdP (GhcPass 'Renamed)
n IdP (GhcPass 'Renamed)
quoter SrcSpan
q_span FastString
quote)
= UntypedSpliceFlavour
-> Name -> LHsExpr (GhcPass 'Renamed) -> PendingRnSplice
PendingRnSplice UntypedSpliceFlavour
flavour IdP (GhcPass 'Renamed)
n (UntypedSpliceFlavour
-> Name -> SrcSpan -> FastString -> LHsExpr (GhcPass 'Renamed)
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour IdP (GhcPass 'Renamed)
quoter SrcSpan
q_span FastString
quote)
makePending UntypedSpliceFlavour
_ splice :: HsSplice (GhcPass 'Renamed)
splice@(HsTypedSplice {})
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"makePending" (forall a. Outputable a => a -> SDoc
ppr HsSplice (GhcPass 'Renamed)
splice)
makePending UntypedSpliceFlavour
_ splice :: HsSplice (GhcPass 'Renamed)
splice@(HsSpliced {})
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"makePending" (forall a. Outputable a => a -> SDoc
ppr HsSplice (GhcPass 'Renamed)
splice)
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
-> LHsExpr GhcRn
mkQuasiQuoteExpr :: UntypedSpliceFlavour
-> Name -> SrcSpan -> FastString -> LHsExpr (GhcPass 'Renamed)
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour Name
quoter SrcSpan
q_span' FastString
quote
= forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
q_span forall a b. (a -> b) -> a -> b
$ forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
q_span
forall a b. (a -> b) -> a -> b
$ forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
q_span
(forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
q_span) Name
quote_selector)))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
quoterExpr)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
quoteExpr
where
q_span :: SrcSpanAnnA
q_span = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
q_span'
quoterExpr :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
quoterExpr = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
q_span forall a b. (a -> b) -> a -> b
$! forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField forall a b. (a -> b) -> a -> b
$! (forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
q_span) Name
quoter)
quoteExpr :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
quoteExpr = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
q_span forall a b. (a -> b) -> a -> b
$! forall p. XLitE p -> HsLit p -> HsExpr p
HsLit EpAnnCO
noComments forall a b. (a -> b) -> a -> b
$! forall x. XHsString x -> FastString -> HsLit x
HsString SourceText
NoSourceText FastString
quote
quote_selector :: Name
quote_selector = case UntypedSpliceFlavour
flavour of
UntypedSpliceFlavour
UntypedExpSplice -> Name
quoteExpName
UntypedSpliceFlavour
UntypedPatSplice -> Name
quotePatName
UntypedSpliceFlavour
UntypedTypeSplice -> Name
quoteTypeName
UntypedSpliceFlavour
UntypedDeclSplice -> Name
quoteDecName
rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)
rnSplice :: HsSplice GhcPs -> TcRn (HsSplice (GhcPass 'Renamed), Uses)
rnSplice (HsTypedSplice XTypedSplice GhcPs
x SpliceDecoration
hasParen IdP GhcPs
splice_name LHsExpr GhcPs
expr)
= do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; Name
n' <- GenLocated SrcSpanAnnN RdrName -> RnM Name
newLocalBndrRn (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) IdP GhcPs
splice_name)
; (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr', Uses
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XTypedSplice id
-> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id
HsTypedSplice XTypedSplice GhcPs
x SpliceDecoration
hasParen Name
n' GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr', Uses
fvs) }
rnSplice (HsUntypedSplice XUntypedSplice GhcPs
x SpliceDecoration
hasParen IdP GhcPs
splice_name LHsExpr GhcPs
expr)
= do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; Name
n' <- GenLocated SrcSpanAnnN RdrName -> RnM Name
newLocalBndrRn (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) IdP GhcPs
splice_name)
; (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr', Uses
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XUntypedSplice id
-> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id
HsUntypedSplice XUntypedSplice GhcPs
x SpliceDecoration
hasParen Name
n' GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr', Uses
fvs) }
rnSplice (HsQuasiQuote XQuasiQuote GhcPs
x IdP GhcPs
splice_name IdP GhcPs
quoter SrcSpan
q_loc FastString
quote)
= do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; Name
splice_name' <- GenLocated SrcSpanAnnN RdrName -> RnM Name
newLocalBndrRn (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) IdP GhcPs
splice_name)
; Name
quoter' <- RdrName -> RnM Name
lookupOccRn IdP GhcPs
quoter
; Module
this_mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
quoter') forall a b. (a -> b) -> a -> b
$
Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkThLocalName Name
quoter'
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XQuasiQuote id
-> IdP id -> IdP id -> SrcSpan -> FastString -> HsSplice id
HsQuasiQuote XQuasiQuote GhcPs
x Name
splice_name' Name
quoter' SrcSpan
q_loc FastString
quote
, Name -> Uses
unitFV Name
quoter') }
rnSplice splice :: HsSplice GhcPs
splice@(HsSpliced {}) = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnSplice" (forall a. Outputable a => a -> SDoc
ppr HsSplice GhcPs
splice)
rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr (GhcPass 'Renamed), Uses)
rnSpliceExpr HsSplice GhcPs
splice
= forall a.
(HsSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, Uses)
rnSpliceGen HsSplice (GhcPass 'Renamed)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
run_expr_splice HsSplice (GhcPass 'Renamed)
-> (PendingRnSplice, HsExpr (GhcPass 'Renamed))
pend_expr_splice HsSplice GhcPs
splice
where
pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
pend_expr_splice :: HsSplice (GhcPass 'Renamed)
-> (PendingRnSplice, HsExpr (GhcPass 'Renamed))
pend_expr_splice HsSplice (GhcPass 'Renamed)
rn_splice
= (UntypedSpliceFlavour
-> HsSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedExpSplice HsSplice (GhcPass 'Renamed)
rn_splice, forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE forall a. EpAnn a
noAnn HsSplice (GhcPass 'Renamed)
rn_splice)
run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
run_expr_splice :: HsSplice (GhcPass 'Renamed)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
run_expr_splice HsSplice (GhcPass 'Renamed)
rn_splice
| forall id. HsSplice id -> Bool
isTypedSplice HsSplice (GhcPass 'Renamed)
rn_splice
= do {
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnSpliceExpr: typed expression splice" SDoc
empty
; LocalRdrEnv
lcl_rdr <- RnM LocalRdrEnv
getLocalRdrEnv
; GlobalRdrEnv
gbl_rdr <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; let gbl_names :: Uses
gbl_names = [Name] -> Uses
mkNameSet [GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre | GlobalRdrElt
gre <- GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts GlobalRdrEnv
gbl_rdr
, GlobalRdrElt -> Bool
isLocalGRE GlobalRdrElt
gre]
lcl_names :: Uses
lcl_names = [Name] -> Uses
mkNameSet (LocalRdrEnv -> [Name]
localRdrEnvElts LocalRdrEnv
lcl_rdr)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE forall a. EpAnn a
noAnn HsSplice (GhcPass 'Renamed)
rn_splice, Uses
lcl_names Uses -> Uses -> Uses
`plusFV` Uses
gbl_names) }
| Bool
otherwise
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnSpliceExpr: untyped expression splice" SDoc
empty
; (GenLocated SrcSpanAnnA (HsExpr GhcPs)
rn_expr, [ForeignRef (Q ())]
mod_finalizers) <-
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedExpSplice LHsExpr GhcTc -> TcM (LHsExpr GhcPs)
runMetaE forall a. Outputable a => a -> SDoc
ppr HsSplice (GhcPass 'Renamed)
rn_splice
; (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
lexpr3, Uses
fvs) <- forall r. TcM r -> TcM r
checkNoErrs (LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr GenLocated SrcSpanAnnA (HsExpr GhcPs)
rn_expr)
; forall (m :: * -> *) a. Monad m => a -> m a
return ( forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar forall a. EpAnn a
noAnn forall a b. (a -> b) -> a -> b
$ forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE forall a. EpAnn a
noAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id.
XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id
HsSpliced NoExtField
noExtField ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id. HsExpr id -> HsSplicedThing id
HsSplicedExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
lexpr3
, Uses
fvs)
}
rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSpliceType :: HsSplice GhcPs -> RnM (HsType (GhcPass 'Renamed), Uses)
rnSpliceType HsSplice GhcPs
splice
= forall a.
(HsSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, Uses)
rnSpliceGen HsSplice (GhcPass 'Renamed)
-> RnM (HsType (GhcPass 'Renamed), Uses)
run_type_splice HsSplice (GhcPass 'Renamed)
-> (PendingRnSplice, HsType (GhcPass 'Renamed))
pend_type_splice HsSplice GhcPs
splice
where
pend_type_splice :: HsSplice (GhcPass 'Renamed)
-> (PendingRnSplice, HsType (GhcPass 'Renamed))
pend_type_splice HsSplice (GhcPass 'Renamed)
rn_splice
= ( UntypedSpliceFlavour
-> HsSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedTypeSplice HsSplice (GhcPass 'Renamed)
rn_splice
, forall pass. XSpliceTy pass -> HsSplice pass -> HsType pass
HsSpliceTy NoExtField
noExtField HsSplice (GhcPass 'Renamed)
rn_splice)
run_type_splice :: HsSplice (GhcPass 'Renamed)
-> RnM (HsType (GhcPass 'Renamed), Uses)
run_type_splice HsSplice (GhcPass 'Renamed)
rn_splice
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnSpliceType: untyped type splice" SDoc
empty
; (GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ty2, [ForeignRef (Q ())]
mod_finalizers) <-
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedTypeSplice LHsExpr GhcTc -> TcM (LHsType GhcPs)
runMetaT forall a. Outputable a => a -> SDoc
ppr HsSplice (GhcPass 'Renamed)
rn_splice
; (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
hs_ty3, Uses
fvs) <- do { let doc :: HsDocContext
doc = LHsType GhcPs -> HsDocContext
SpliceTypeCtx GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ty2
; forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$ HsDocContext
-> LHsType GhcPs -> RnM (LHsType (GhcPass 'Renamed), Uses)
rnLHsType HsDocContext
doc GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ty2 }
; forall (m :: * -> *) a. Monad m => a -> m a
return ( forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn
forall a b. (a -> b) -> a -> b
$ forall pass. XSpliceTy pass -> HsSplice pass -> HsType pass
HsSpliceTy NoExtField
noExtField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id.
XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id
HsSpliced NoExtField
noExtField ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id. HsType id -> HsSplicedThing id
HsSplicedTy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
hs_ty3
, Uses
fvs
) }
rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)
, FreeVars)
rnSplicePat :: HsSplice GhcPs
-> RnM (Either (Pat GhcPs) (Pat (GhcPass 'Renamed)), Uses)
rnSplicePat HsSplice GhcPs
splice
= forall a.
(HsSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, Uses)
rnSpliceGen HsSplice (GhcPass 'Renamed)
-> RnM (Either (Pat GhcPs) (Pat (GhcPass 'Renamed)), Uses)
run_pat_splice forall b.
HsSplice (GhcPass 'Renamed)
-> (PendingRnSplice, Either b (Pat (GhcPass 'Renamed)))
pend_pat_splice HsSplice GhcPs
splice
where
pend_pat_splice :: HsSplice GhcRn ->
(PendingRnSplice, Either b (Pat GhcRn))
pend_pat_splice :: forall b.
HsSplice (GhcPass 'Renamed)
-> (PendingRnSplice, Either b (Pat (GhcPass 'Renamed)))
pend_pat_splice HsSplice (GhcPass 'Renamed)
rn_splice
= (UntypedSpliceFlavour
-> HsSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedPatSplice HsSplice (GhcPass 'Renamed)
rn_splice
, forall a b. b -> Either a b
Right (forall p. XSplicePat p -> HsSplice p -> Pat p
SplicePat NoExtField
noExtField HsSplice (GhcPass 'Renamed)
rn_splice))
run_pat_splice :: HsSplice GhcRn ->
RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
run_pat_splice :: HsSplice (GhcPass 'Renamed)
-> RnM (Either (Pat GhcPs) (Pat (GhcPass 'Renamed)), Uses)
run_pat_splice HsSplice (GhcPass 'Renamed)
rn_splice
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnSplicePat: untyped pattern splice" SDoc
empty
; (GenLocated SrcSpanAnnA (Pat GhcPs)
pat, [ForeignRef (Q ())]
mod_finalizers) <-
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedPatSplice LHsExpr GhcTc -> TcM (LPat GhcPs)
runMetaP forall a. Outputable a => a -> SDoc
ppr HsSplice (GhcPass 'Renamed)
rn_splice
; forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall p. XParPat p -> LPat p -> Pat p
ParPat forall a. EpAnn a
noAnn forall a b. (a -> b) -> a -> b
$ ((forall p. XSplicePat p -> HsSplice p -> Pat p
SplicePat NoExtField
noExtField)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id.
XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id
HsSpliced NoExtField
noExtField ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id. Pat id -> HsSplicedThing id
HsSplicedPat) forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
`mapLoc`
GenLocated SrcSpanAnnA (Pat GhcPs)
pat
, Uses
emptyFVs
) }
rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl (GhcPass 'Renamed), Uses)
rnSpliceDecl (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpanAnnA
loc HsSplice GhcPs
splice) SpliceExplicitFlag
flg)
= forall a.
(HsSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, Uses)
rnSpliceGen forall {a} {a}. Outputable a => a -> a
run_decl_splice HsSplice (GhcPass 'Renamed)
-> (PendingRnSplice, SpliceDecl (GhcPass 'Renamed))
pend_decl_splice HsSplice GhcPs
splice
where
pend_decl_splice :: HsSplice (GhcPass 'Renamed)
-> (PendingRnSplice, SpliceDecl (GhcPass 'Renamed))
pend_decl_splice HsSplice (GhcPass 'Renamed)
rn_splice
= ( UntypedSpliceFlavour
-> HsSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedDeclSplice HsSplice (GhcPass 'Renamed)
rn_splice
, forall p.
XSpliceDecl p
-> XRec p (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsSplice (GhcPass 'Renamed)
rn_splice) SpliceExplicitFlag
flg)
run_decl_splice :: a -> a
run_decl_splice a
rn_splice = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnSpliceDecl" (forall a. Outputable a => a -> SDoc
ppr a
rn_splice)
rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], Uses)
rnTopSpliceDecls HsSplice GhcPs
splice
= do { HsSplice GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTopSpliceAllowed HsSplice GhcPs
splice
; (HsSplice (GhcPass 'Renamed)
rn_splice, Uses
fvs) <- forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
Untyped) forall a b. (a -> b) -> a -> b
$
HsSplice GhcPs -> TcRn (HsSplice (GhcPass 'Renamed), Uses)
rnSplice HsSplice GhcPs
splice
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnTopSpliceDecls: untyped declaration splice" SDoc
empty
; ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls, [ForeignRef (Q ())]
mod_finalizers) <- forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedDeclSplice LHsExpr GhcTc -> TcM [LHsDecl GhcPs]
runMetaD [LHsDecl GhcPs] -> SDoc
ppr_decls HsSplice (GhcPass 'Renamed)
rn_splice
; [ForeignRef (Q ())] -> IOEnv (Env TcGblEnv TcLclEnv) ()
add_mod_finalizers_now [ForeignRef (Q ())]
mod_finalizers
; forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls,Uses
fvs) }
where
ppr_decls :: [LHsDecl GhcPs] -> SDoc
ppr_decls :: [LHsDecl GhcPs] -> SDoc
ppr_decls [LHsDecl GhcPs]
ds = [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [LHsDecl GhcPs]
ds)
add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()
add_mod_finalizers_now :: [ForeignRef (Q ())] -> IOEnv (Env TcGblEnv TcLclEnv) ()
add_mod_finalizers_now [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
add_mod_finalizers_now [ForeignRef (Q ())]
mod_finalizers = do
TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)]
tcg_th_modfinalizers forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var forall a b. (a -> b) -> a -> b
$ \[(TcLclEnv, ThModFinalizers)]
fins ->
(TcLclEnv
env, [ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers) forall a. a -> [a] -> [a]
: [(TcLclEnv, ThModFinalizers)]
fins
spliceCtxt :: HsSplice GhcPs -> SDoc
spliceCtxt :: HsSplice GhcPs -> SDoc
spliceCtxt HsSplice GhcPs
splice
= SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc
what) ThLevel
2 (forall a. Outputable a => a -> SDoc
ppr HsSplice GhcPs
splice)
where
what :: SDoc
what = case HsSplice GhcPs
splice of
HsUntypedSplice {} -> String -> SDoc
text String
"untyped splice:"
HsTypedSplice {} -> String -> SDoc
text String
"typed splice:"
HsQuasiQuote {} -> String -> SDoc
text String
"quasi-quotation:"
HsSpliced {} -> String -> SDoc
text String
"spliced expression:"
data SpliceInfo
= SpliceInfo
{ SpliceInfo -> String
spliceDescription :: String
, SpliceInfo -> Maybe (LHsExpr (GhcPass 'Renamed))
spliceSource :: Maybe (LHsExpr GhcRn)
, SpliceInfo -> Bool
spliceIsDecl :: Bool
, SpliceInfo -> SDoc
spliceGenerated :: SDoc
}
traceSplice :: SpliceInfo -> TcM ()
traceSplice :: SpliceInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceSplice (SpliceInfo { spliceDescription :: SpliceInfo -> String
spliceDescription = String
sd, spliceSource :: SpliceInfo -> Maybe (LHsExpr (GhcPass 'Renamed))
spliceSource = Maybe (LHsExpr (GhcPass 'Renamed))
mb_src
, spliceGenerated :: SpliceInfo -> SDoc
spliceGenerated = SDoc
gen, spliceIsDecl :: SpliceInfo -> Bool
spliceIsDecl = Bool
is_decl })
= do SrcSpan
loc <- case Maybe (LHsExpr (GhcPass 'Renamed))
mb_src of
Maybe (LHsExpr (GhcPass 'Renamed))
Nothing -> TcRn SrcSpan
getSrcSpanM
Just (L SrcSpanAnnA
loc HsExpr (GhcPass 'Renamed)
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
DumpFlag -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceOptTcRn DumpFlag
Opt_D_dump_splices (SrcSpan -> SDoc
spliceDebugDoc SrcSpan
loc)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_decl forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PrintUnqualified
-> Logger
-> DynFlags
-> DumpFlag
-> String
-> DumpFormat
-> SDoc
-> IO ()
dumpIfSet_dyn_printer PrintUnqualified
alwaysQualify Logger
logger DynFlags
dflags DumpFlag
Opt_D_th_dec_file
String
"" DumpFormat
FormatHaskell (SrcSpan -> SDoc
spliceCodeDoc SrcSpan
loc)
where
spliceDebugDoc :: SrcSpan -> SDoc
spliceDebugDoc :: SrcSpan -> SDoc
spliceDebugDoc SrcSpan
loc
= let code :: [SDoc]
code = case Maybe (LHsExpr (GhcPass 'Renamed))
mb_src of
Maybe (LHsExpr (GhcPass 'Renamed))
Nothing -> [SDoc]
ending
Just LHsExpr (GhcPass 'Renamed)
e -> ThLevel -> SDoc -> SDoc
nest ThLevel
2 (forall a. Outputable a => a -> SDoc
ppr (forall (p :: Pass). LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
stripParensLHsExpr LHsExpr (GhcPass 'Renamed)
e)) forall a. a -> [a] -> [a]
: [SDoc]
ending
ending :: [SDoc]
ending = [ String -> SDoc
text String
"======>", ThLevel -> SDoc -> SDoc
nest ThLevel
2 SDoc
gen ]
in SDoc -> ThLevel -> SDoc -> SDoc
hang (forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Splicing" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
sd)
ThLevel
2 ([SDoc] -> SDoc
sep [SDoc]
code)
spliceCodeDoc :: SrcSpan -> SDoc
spliceCodeDoc :: SrcSpan -> SDoc
spliceCodeDoc SrcSpan
loc
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"--" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Splicing" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
sd
, SDoc
gen ]
illegalTypedSplice :: SDoc
illegalTypedSplice :: SDoc
illegalTypedSplice = String -> SDoc
text String
"Typed splices may not appear in untyped brackets"
illegalUntypedSplice :: SDoc
illegalUntypedSplice :: SDoc
illegalUntypedSplice = String -> SDoc
text String
"Untyped splices may not appear in typed brackets"
checkThLocalName :: Name -> RnM ()
checkThLocalName :: Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkThLocalName Name
name
| Name -> Bool
isUnboundName Name
name
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"checkThLocalName" (forall a. Outputable a => a -> SDoc
ppr Name
name)
; Maybe (TopLevelFlag, ThLevel, ThStage)
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel Name
name
; case Maybe (TopLevelFlag, ThLevel, ThStage)
mb_local_use of {
Maybe (TopLevelFlag, ThLevel, ThStage)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return () ;
Just (TopLevelFlag
top_lvl, ThLevel
bind_lvl, ThStage
use_stage) ->
do { let use_lvl :: ThLevel
use_lvl = ThStage -> ThLevel
thLevel ThStage
use_stage
; SDoc -> ThLevel -> ThLevel -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkWellStaged (SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name)) ThLevel
bind_lvl ThLevel
use_lvl
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"checkThLocalName" (forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ThLevel
bind_lvl
SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ThStage
use_stage
SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ThLevel
use_lvl)
; TopLevelFlag
-> ThLevel
-> ThStage
-> ThLevel
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkCrossStageLifting TopLevelFlag
top_lvl ThLevel
bind_lvl ThStage
use_stage ThLevel
use_lvl Name
name } } }
checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel
-> Name -> TcM ()
checkCrossStageLifting :: TopLevelFlag
-> ThLevel
-> ThStage
-> ThLevel
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkCrossStageLifting TopLevelFlag
top_lvl ThLevel
bind_lvl ThStage
use_stage ThLevel
use_lvl Name
name
| Brack ThStage
_ (RnPendingUntyped IORef [PendingRnSplice]
ps_var) <- ThStage
use_stage
, ThLevel
use_lvl forall a. Ord a => a -> a -> Bool
> ThLevel
bind_lvl
= TopLevelFlag
-> Name
-> IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
check_cross_stage_lifting TopLevelFlag
top_lvl Name
name IORef [PendingRnSplice]
ps_var
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
check_cross_stage_lifting :: TopLevelFlag
-> Name
-> IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
check_cross_stage_lifting TopLevelFlag
top_lvl Name
name IORef [PendingRnSplice]
ps_var
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
name) (Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
keepAlive Name
name)
| Bool
otherwise
=
do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"checkCrossStageLifting" (forall a. Outputable a => a -> SDoc
ppr Name
name)
; let lift_expr :: LHsExpr (GhcPass 'Renamed)
lift_expr = forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Name
liftName) (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Name
name)
pend_splice :: PendingRnSplice
pend_splice = UntypedSpliceFlavour
-> Name -> LHsExpr (GhcPass 'Renamed) -> PendingRnSplice
PendingRnSplice UntypedSpliceFlavour
UntypedExpSplice Name
name LHsExpr (GhcPass 'Renamed)
lift_expr
; forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnImplicitLift forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addWarnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnImplicitLift)
(String -> SDoc
text String
"The variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"is implicitly lifted in the TH quotation")
; [PendingRnSplice]
ps <- forall a env. IORef a -> IOEnv env a
readMutVar IORef [PendingRnSplice]
ps_var
; forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef [PendingRnSplice]
ps_var (PendingRnSplice
pend_splice forall a. a -> [a] -> [a]
: [PendingRnSplice]
ps) }