{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Rename.Splice (
rnTopSpliceDecls,
rnTypedSplice,
rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceDecl,
rnTypedBracket, rnUntypedBracket,
checkThLocalName, traceSplice, SpliceInfo(..)
) where
import GHC.Prelude
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Driver.Env.Types
import GHC.Rename.Env
import GHC.Rename.Utils ( newLocalBndrRn )
import GHC.Rename.Unbound ( isUnboundName )
import GHC.Rename.Module ( rnSrcDecls, findSplice )
import GHC.Rename.Pat ( rnPat )
import GHC.Types.Error
import GHC.Types.Basic ( TopLevelFlag, isTopLevel, maxPrec )
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
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
checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM ()
checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM ()
checkForTemplateHaskellQuotes HsExpr GhcPs
e =
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. TcRnMessage -> TcRn a
failWith ( forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$ forall doc. IsDoc doc => [doc] -> doc
vcat
[ forall doc. IsLine doc => String -> doc
text String
"Syntax error on" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e
, forall doc. IsLine doc => String -> doc
text (String
"Perhaps you intended to use TemplateHaskell"
forall a. [a] -> [a] -> [a]
++ String
" or TemplateHaskellQuotes") ] )
}
rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnTypedBracket :: HsExpr GhcPs
-> LHsExpr GhcPs -> RnM (HsExpr (GhcPass 'Renamed), Uses)
rnTypedBracket HsExpr GhcPs
e LHsExpr GhcPs
br_body
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcPs -> SDoc
typedQuotationCtxtDoc LHsExpr GhcPs
br_body) forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcPs -> RnM ()
checkForTemplateHaskellQuotes HsExpr GhcPs
e
; ThStage
cur_stage <- TcM ThStage
getStage
; case ThStage
cur_stage of
{ Splice SpliceType
Typed -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Splice SpliceType
Untyped -> forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalTypedBracket
; RunSplice TcRef [ForeignRef (Q ())]
_ ->
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnTypedBracket: Renaming typed 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. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalBracket
}
; RnM ()
recordThUse
; String -> SDoc -> RnM ()
traceRn String
"Renaming typed TH bracket" forall doc. IsOutput doc => doc
empty
; (GenLocated SrcSpanAnnA (HsExpr (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
$ LHsExpr GhcPs -> TcRn (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
br_body
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XTypedBracket p -> LHsExpr p -> HsExpr p
HsTypedBracket NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
body', Uses
fvs_e)
}
rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnUntypedBracket :: HsExpr GhcPs
-> HsQuote GhcPs -> RnM (HsExpr (GhcPass 'Renamed), Uses)
rnUntypedBracket HsExpr GhcPs
e HsQuote GhcPs
br_body
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsQuote GhcPs -> SDoc
untypedQuotationCtxtDoc HsQuote GhcPs
br_body) forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcPs -> RnM ()
checkForTemplateHaskellQuotes HsExpr GhcPs
e
; ThStage
cur_stage <- TcM ThStage
getStage
; case ThStage
cur_stage of
{ Splice SpliceType
Typed -> forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalUntypedBracket
; Splice SpliceType
Untyped -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
; RunSplice TcRef [ForeignRef (Q ())]
_ ->
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnUntypedBracket: Renaming untyped 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. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalBracket
}
; RnM ()
recordThUse
; String -> SDoc -> RnM ()
traceRn String
"Renaming untyped TH bracket" forall doc. IsOutput doc => doc
empty
; IORef [PendingRnSplice]
ps_var <- forall a env. a -> IOEnv env (IORef a)
newMutVar []
; (HsQuote (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
-> HsQuote GhcPs
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
rn_utbracket ThStage
cur_stage HsQuote 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. XUntypedBracket p -> HsQuote p -> HsExpr p
HsUntypedBracket [PendingRnSplice]
pendings HsQuote (GhcPass 'Renamed)
body', Uses
fvs_e)
}
rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
rn_utbracket :: ThStage
-> HsQuote GhcPs
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
rn_utbracket ThStage
outer_stage br :: HsQuote 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)
; Bool -> Name -> RnM ()
check_namespace Bool
flg Name
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 -> RnM ()
keepAlive Name
name)
| Bool
otherwise
-> do { String -> SDoc -> RnM ()
traceRn String
"rn_utbracket VarBr"
(forall a. Outputable a => a -> SDoc
ppr Name
name forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ThLevel
bind_lvl
forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ThStage
outer_stage)
; Bool -> TcRnMessage -> RnM ()
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)
(HsQuote GhcPs -> TcRnMessage
quotedNameStageErr HsQuote GhcPs
br) }
}
}
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XVarBr p -> Bool -> LIdP p -> HsQuote p
VarBr XVarBr GhcPs
x Bool
flg (forall a an. a -> LocatedAn an a
noLocA Name
name), Name -> Uses
unitFV Name
name) }
rn_utbracket ThStage
_ (ExpBr XExpBr GhcPs
x LHsExpr GhcPs
e) = do { (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
e', Uses
fvs) <- LHsExpr GhcPs -> TcRn (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XExpBr p -> LHsExpr p -> HsQuote p
ExpBr XExpBr GhcPs
x GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
e', Uses
fvs) }
rn_utbracket 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 -> HsQuote p
PatBr XPatBr GhcPs
x LPat (GhcPass 'Renamed)
p', Uses
emptyFVs)
rn_utbracket 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 -> HsQuote p
TypBr XTypBr GhcPs
x GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
t', Uses
fvs) }
rn_utbracket 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.
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 -> RnM ()
traceRn String
"rn_utbracket dec" (forall a. Outputable a => a -> SDoc
ppr (TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env) forall doc. IsDoc doc => doc -> doc -> doc
$$
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 -> HsQuote 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_utbracket ThStage
_ (DecBrG {}) = forall a. HasCallStack => String -> a
panic String
"rn_ut_bracket: unexpected DecBrG"
check_namespace :: Bool -> Name -> RnM ()
check_namespace :: Bool -> Name -> RnM ()
check_namespace Bool
is_single_tick Name
nm
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NameSpace -> Bool
isValNameSpace NameSpace
ns forall a. Eq a => a -> a -> Bool
== Bool
is_single_tick) forall a b. (a -> b) -> a -> b
$
forall a. TcRnMessage -> TcRn a
failWithTc forall a b. (a -> b) -> a -> b
$ (Name -> Bool -> TcRnMessage
TcRnIncorrectNameSpace Name
nm Bool
True)
where
ns :: NameSpace
ns = Name -> NameSpace
nameNameSpace Name
nm
typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc
typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc
typedQuotationCtxtDoc LHsExpr GhcPs
br_body
= SDoc -> ThLevel -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"In the Template Haskell typed quotation")
ThLevel
2 (SDoc -> SDoc
thTyBrackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
br_body)
untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc
untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc
untypedQuotationCtxtDoc HsQuote GhcPs
br_body
= SDoc -> ThLevel -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"In the Template Haskell quotation")
ThLevel
2 (forall a. Outputable a => a -> SDoc
ppr HsQuote GhcPs
br_body)
illegalBracket :: TcRnMessage
illegalBracket :: TcRnMessage
illegalBracket = forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
"Template Haskell brackets cannot be nested" forall doc. IsLine doc => doc -> doc -> doc
<+>
forall doc. IsLine doc => String -> doc
text String
"(without intervening splices)"
illegalTypedBracket :: TcRnMessage
illegalTypedBracket :: TcRnMessage
illegalTypedBracket = forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
"Typed brackets may only appear in typed splices."
illegalUntypedBracket :: TcRnMessage
illegalUntypedBracket :: TcRnMessage
illegalUntypedBracket = forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
"Untyped brackets may only appear in untyped splices."
quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage
quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage
quotedNameStageErr HsQuote GhcPs
br
= forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => [doc] -> doc
sep [ forall doc. IsLine doc => String -> doc
text String
"Stage error: the non-top-level quoted name" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr HsQuote GhcPs
br
, forall doc. IsLine doc => String -> doc
text String
"must be used at the same stage at which it is bound" ]
rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars))
-> (Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, a))
-> HsUntypedSplice GhcPs
-> RnM (a, FreeVars)
rnUntypedSpliceGen :: forall a.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses)
run_splice Name -> HsUntypedSplice (GhcPass 'Renamed) -> (PendingRnSplice, a)
pend_splice HsUntypedSplice GhcPs
splice
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsUntypedSplice GhcPs -> SDoc
spliceCtxt HsUntypedSplice GhcPs
splice) forall a b. (a -> b) -> a -> b
$ do
{ ThStage
stage <- TcM ThStage
getStage
; case ThStage
stage of
Brack ThStage
_ PendingStuff
RnPendingTyped
-> forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalUntypedSplice
Brack ThStage
pop_stage (RnPendingUntyped IORef [PendingRnSplice]
ps_var)
-> do { (HsUntypedSplice (GhcPass 'Renamed)
splice', Uses
fvs) <- forall a. ThStage -> TcM a -> TcM a
setStage ThStage
pop_stage forall a b. (a -> b) -> a -> b
$
HsUntypedSplice GhcPs
-> TcRn (HsUntypedSplice (GhcPass 'Renamed), Uses)
rnUntypedSplice HsUntypedSplice GhcPs
splice
; 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) RdrName
unqualSplice)
; let (PendingRnSplice
pending_splice, a
result) = Name -> HsUntypedSplice (GhcPass 'Renamed) -> (PendingRnSplice, a)
pend_splice Name
splice_name HsUntypedSplice (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 { HsUntypedSplice GhcPs -> RnM ()
checkTopSpliceAllowed HsUntypedSplice GhcPs
splice
; (HsUntypedSplice (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
Untyped) forall a b. (a -> b) -> a -> b
$
HsUntypedSplice GhcPs
-> TcRn (HsUntypedSplice (GhcPass 'Renamed), Uses)
rnUntypedSplice HsUntypedSplice GhcPs
splice
; (a
result, Uses
fvs2) <- HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses)
run_splice HsUntypedSplice (GhcPass 'Renamed)
splice'
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Uses
fvs1 Uses -> Uses -> Uses
`plusFV` Uses
fvs2) } }
checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM ()
checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM ()
checkTopSpliceAllowed HsUntypedSplice GhcPs
splice = do
let (String
herald, Extension
ext) = HsUntypedSplice GhcPs -> (String, Extension)
spliceExtension HsUntypedSplice 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. TcRnMessage -> TcRn a
failWith forall a b. (a -> b) -> a -> b
$ forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
herald forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"are not permitted without" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Extension
ext)
where
spliceExtension :: HsUntypedSplice GhcPs -> (String, LangExt.Extension)
spliceExtension :: HsUntypedSplice GhcPs -> (String, Extension)
spliceExtension (HsQuasiQuote {}) = (String
"Quasi-quotes", Extension
LangExt.QuasiQuotes)
spliceExtension (HsUntypedSpliceExpr {}) = (String
"Top-level splices", Extension
LangExt.TemplateHaskell)
runRnSplice :: UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsUntypedSplice GhcRn
-> TcRn (res, [ForeignRef (TH.Q ())])
runRnSplice :: forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
flavour LHsExpr GhcTc -> TcRn res
run_meta res -> SDoc
ppr_res HsUntypedSplice (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
; HsUntypedSplice (GhcPass 'Renamed)
splice' <- case Hooks
-> Maybe
(HsUntypedSplice (GhcPass 'Renamed)
-> IOEnv
(Env TcGblEnv TcLclEnv) (HsUntypedSplice (GhcPass 'Renamed)))
runRnSpliceHook Hooks
hooks of
Maybe
(HsUntypedSplice (GhcPass 'Renamed)
-> IOEnv
(Env TcGblEnv TcLclEnv) (HsUntypedSplice (GhcPass 'Renamed)))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return HsUntypedSplice (GhcPass 'Renamed)
splice
Just HsUntypedSplice (GhcPass 'Renamed)
-> IOEnv
(Env TcGblEnv TcLclEnv) (HsUntypedSplice (GhcPass 'Renamed))
h -> HsUntypedSplice (GhcPass 'Renamed)
-> IOEnv
(Env TcGblEnv TcLclEnv) (HsUntypedSplice (GhcPass 'Renamed))
h HsUntypedSplice (GhcPass 'Renamed)
splice
; let the_expr :: LHsExpr (GhcPass 'Renamed)
the_expr = case HsUntypedSplice (GhcPass 'Renamed)
splice' of
HsUntypedSpliceExpr XUntypedSpliceExpr (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e -> LHsExpr (GhcPass 'Renamed)
e
HsQuasiQuote XQuasiQuote (GhcPass 'Renamed)
_ IdP (GhcPass 'Renamed)
q XRec (GhcPass 'Renamed) FastString
str -> UntypedSpliceFlavour
-> Name -> XRec GhcPs FastString -> LHsExpr (GhcPass 'Renamed)
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour IdP (GhcPass 'Renamed)
q XRec (GhcPass 'Renamed) FastString
str
; 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 -> RnM ()
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
-> Name
-> HsUntypedSplice GhcRn
-> PendingRnSplice
makePending :: UntypedSpliceFlavour
-> Name -> HsUntypedSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
flavour Name
n (HsUntypedSpliceExpr XUntypedSpliceExpr (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e)
= UntypedSpliceFlavour
-> Name -> LHsExpr (GhcPass 'Renamed) -> PendingRnSplice
PendingRnSplice UntypedSpliceFlavour
flavour Name
n LHsExpr (GhcPass 'Renamed)
e
makePending UntypedSpliceFlavour
flavour Name
n (HsQuasiQuote XQuasiQuote (GhcPass 'Renamed)
_ IdP (GhcPass 'Renamed)
quoter XRec (GhcPass 'Renamed) FastString
quote)
= UntypedSpliceFlavour
-> Name -> LHsExpr (GhcPass 'Renamed) -> PendingRnSplice
PendingRnSplice UntypedSpliceFlavour
flavour Name
n (UntypedSpliceFlavour
-> Name -> XRec GhcPs FastString -> LHsExpr (GhcPass 'Renamed)
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour IdP (GhcPass 'Renamed)
quoter XRec (GhcPass 'Renamed) FastString
quote)
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name
-> XRec GhcPs FastString
-> LHsExpr GhcRn
mkQuasiQuoteExpr :: UntypedSpliceFlavour
-> Name -> XRec GhcPs FastString -> LHsExpr (GhcPass 'Renamed)
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour Name
quoter (L SrcSpanAnn' (EpAnn NoEpAnns)
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 EpAnn NoEpAnns
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 EpAnn NoEpAnns
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 (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn NoEpAnns)
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 EpAnn NoEpAnns
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
unqualSplice :: RdrName
unqualSplice :: RdrName
unqualSplice = OccName -> RdrName
mkRdrUnqual (FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"spn"))
rnUntypedSplice :: HsUntypedSplice GhcPs -> RnM (HsUntypedSplice GhcRn, FreeVars)
rnUntypedSplice :: HsUntypedSplice GhcPs
-> TcRn (HsUntypedSplice (GhcPass 'Renamed), Uses)
rnUntypedSplice (HsUntypedSpliceExpr XUntypedSpliceExpr GhcPs
annCo LHsExpr GhcPs
expr)
= do { (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr', Uses
fvs) <- LHsExpr GhcPs -> TcRn (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XUntypedSpliceExpr id -> LHsExpr id -> HsUntypedSplice id
HsUntypedSpliceExpr XUntypedSpliceExpr GhcPs
annCo GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr', Uses
fvs) }
rnUntypedSplice (HsQuasiQuote XQuasiQuote GhcPs
ext IdP GhcPs
quoter XRec GhcPs FastString
quote)
= do {
; 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 -> RnM ()
checkThLocalName Name
quoter'
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XQuasiQuote id
-> IdP id -> XRec id FastString -> HsUntypedSplice id
HsQuasiQuote XQuasiQuote GhcPs
ext Name
quoter' XRec GhcPs FastString
quote, Name -> Uses
unitFV Name
quoter') }
rnTypedSplice :: LHsExpr GhcPs
-> RnM (HsExpr GhcRn, FreeVars)
rnTypedSplice :: LHsExpr GhcPs -> RnM (HsExpr (GhcPass 'Renamed), Uses)
rnTypedSplice LHsExpr GhcPs
expr
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> ThLevel -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"In the typed splice:") ThLevel
2 (forall (p :: Pass).
OutputableBndrId p =>
Maybe Name -> LHsExpr (GhcPass p) -> SDoc
pprTypedSplice forall a. Maybe a
Nothing LHsExpr GhcPs
expr)) forall a b. (a -> b) -> a -> b
$ do
{ ThStage
stage <- TcM ThStage
getStage
; case ThStage
stage of
Brack ThStage
pop_stage PendingStuff
RnPendingTyped
-> forall a. ThStage -> TcM a -> TcM a
setStage ThStage
pop_stage RnM (HsExpr (GhcPass 'Renamed), Uses)
rn_splice
Brack ThStage
_ (RnPendingUntyped IORef [PendingRnSplice]
_)
-> forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalTypedSplice
ThStage
_ -> do { Bool
extEnabled <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TemplateHaskell
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
extEnabled
(forall a. TcRnMessage -> TcRn a
failWith forall a b. (a -> b) -> a -> b
$ forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
"Top-level splices are not permitted without"
forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Extension
LangExt.TemplateHaskell)
; (HsExpr (GhcPass 'Renamed)
result, 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
Typed) RnM (HsExpr (GhcPass 'Renamed), Uses)
rn_splice
; String -> SDoc -> RnM ()
traceRn String
"rnTypedSplice: typed expression splice" forall doc. IsOutput doc => doc
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)
fvs2 :: Uses
fvs2 = Uses
lcl_names Uses -> Uses -> Uses
`plusFV` Uses
gbl_names
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr (GhcPass 'Renamed)
result, Uses
fvs1 Uses -> Uses -> Uses
`plusFV` Uses
fvs2) } }
where
rn_splice :: RnM (HsExpr GhcRn, FreeVars)
rn_splice :: RnM (HsExpr (GhcPass 'Renamed), Uses)
rn_splice =
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) RdrName
unqualSplice)
; (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr', Uses
fvs) <- LHsExpr GhcPs -> TcRn (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XTypedSplice p -> LHsExpr p -> HsExpr p
HsTypedSplice Name
n' GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr', Uses
fvs) }
rnUntypedSpliceExpr :: HsUntypedSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnUntypedSpliceExpr :: HsUntypedSplice GhcPs -> RnM (HsExpr (GhcPass 'Renamed), Uses)
rnUntypedSpliceExpr HsUntypedSplice GhcPs
splice
= forall a.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
run_expr_splice Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice, HsExpr (GhcPass 'Renamed))
pend_expr_splice HsUntypedSplice GhcPs
splice
where
pend_expr_splice :: Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
pend_expr_splice :: Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice, HsExpr (GhcPass 'Renamed))
pend_expr_splice Name
name HsUntypedSplice (GhcPass 'Renamed)
rn_splice
= (UntypedSpliceFlavour
-> Name -> HsUntypedSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedExpSplice Name
name HsUntypedSplice (GhcPass 'Renamed)
rn_splice, forall p. XUntypedSplice p -> HsUntypedSplice p -> HsExpr p
HsUntypedSplice (forall thing. Name -> HsUntypedSpliceResult thing
HsUntypedSpliceNested Name
name) HsUntypedSplice (GhcPass 'Renamed)
rn_splice)
run_expr_splice :: HsUntypedSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
run_expr_splice :: HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
run_expr_splice HsUntypedSplice (GhcPass 'Renamed)
rn_splice
= do { String -> SDoc -> RnM ()
traceRn String
"rnUntypedSpliceExpr: untyped expression splice" forall doc. IsOutput doc => doc
empty
; (GenLocated SrcSpanAnnA (HsExpr GhcPs)
rn_expr, [ForeignRef (Q ())]
mod_finalizers) <-
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedExpSplice LHsExpr GhcTc -> TcM (LHsExpr GhcPs)
runMetaE forall a. Outputable a => a -> SDoc
ppr HsUntypedSplice (GhcPass 'Renamed)
rn_splice
; (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
lexpr3, Uses
fvs) <- forall r. TcM r -> TcM r
checkNoErrs (LHsExpr GhcPs -> TcRn (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr GenLocated SrcSpanAnnA (HsExpr GhcPs)
rn_expr)
; let e :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
e = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall p. XUntypedSplice p -> HsUntypedSplice p -> HsExpr p
HsUntypedSplice HsUntypedSplice (GhcPass 'Renamed)
rn_splice
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall thing.
ThModFinalizers -> thing -> HsUntypedSpliceResult thing
HsUntypedSpliceTop ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
lexpr3
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
e, Uses
fvs)
}
rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType (GhcPass 'Renamed), Uses)
rnSpliceType HsUntypedSplice GhcPs
splice
= forall a.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsType (GhcPass 'Renamed), Uses)
run_type_splice Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice, HsType (GhcPass 'Renamed))
pend_type_splice HsUntypedSplice GhcPs
splice
where
pend_type_splice :: Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice, HsType (GhcPass 'Renamed))
pend_type_splice Name
name HsUntypedSplice (GhcPass 'Renamed)
rn_splice
= ( UntypedSpliceFlavour
-> Name -> HsUntypedSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedTypeSplice Name
name HsUntypedSplice (GhcPass 'Renamed)
rn_splice
, forall pass. XSpliceTy pass -> HsUntypedSplice pass -> HsType pass
HsSpliceTy (forall thing. Name -> HsUntypedSpliceResult thing
HsUntypedSpliceNested Name
name) HsUntypedSplice (GhcPass 'Renamed)
rn_splice)
run_type_splice :: HsUntypedSplice GhcRn -> RnM (HsType GhcRn, FreeVars)
run_type_splice :: HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsType (GhcPass 'Renamed), Uses)
run_type_splice HsUntypedSplice (GhcPass 'Renamed)
rn_splice
= do { String -> SDoc -> RnM ()
traceRn String
"rnSpliceType: untyped type splice" forall doc. IsOutput doc => doc
empty
; (GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ty2, [ForeignRef (Q ())]
mod_finalizers) <-
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedTypeSplice LHsExpr GhcTc -> TcM (LHsType GhcPs)
runMetaT forall a. Outputable a => a -> SDoc
ppr HsUntypedSplice (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. XSpliceTy pass -> HsUntypedSplice pass -> HsType pass
HsSpliceTy (forall thing.
ThModFinalizers -> thing -> HsUntypedSpliceResult thing
HsUntypedSpliceTop ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers)
(LHsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
mb_paren GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
hs_ty3))
HsUntypedSplice (GhcPass 'Renamed)
rn_splice
, Uses
fvs
) }
mb_paren :: LHsType GhcRn -> LHsType GhcRn
mb_paren :: LHsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
mb_paren lhs_ty :: LHsType (GhcPass 'Renamed)
lhs_ty@(L SrcSpanAnnA
loc HsType (GhcPass 'Renamed)
hs_ty)
| forall (p :: Pass). PprPrec -> HsType (GhcPass p) -> Bool
hsTypeNeedsParens PprPrec
maxPrec HsType (GhcPass 'Renamed)
hs_ty = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn LHsType (GhcPass 'Renamed)
lhs_ty)
| Bool
otherwise = LHsType (GhcPass 'Renamed)
lhs_ty
rnSplicePat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs))
, FreeVars)
rnSplicePat :: HsUntypedSplice GhcPs
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (LPat GhcPs)),
Uses)
rnSplicePat HsUntypedSplice GhcPs
splice
= forall a.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed)
-> IOEnv
(Env TcGblEnv TcLclEnv)
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))),
Uses)
run_pat_splice forall {thing}.
Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice,
(HsUntypedSplice (GhcPass 'Renamed), HsUntypedSpliceResult thing))
pend_pat_splice HsUntypedSplice GhcPs
splice
where
pend_pat_splice :: Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice,
(HsUntypedSplice (GhcPass 'Renamed), HsUntypedSpliceResult thing))
pend_pat_splice Name
name HsUntypedSplice (GhcPass 'Renamed)
rn_splice
= (UntypedSpliceFlavour
-> Name -> HsUntypedSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedPatSplice Name
name HsUntypedSplice (GhcPass 'Renamed)
rn_splice
, (HsUntypedSplice (GhcPass 'Renamed)
rn_splice, forall thing. Name -> HsUntypedSpliceResult thing
HsUntypedSpliceNested Name
name))
run_pat_splice :: HsUntypedSplice (GhcPass 'Renamed)
-> IOEnv
(Env TcGblEnv TcLclEnv)
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))),
Uses)
run_pat_splice HsUntypedSplice (GhcPass 'Renamed)
rn_splice
= do { String -> SDoc -> RnM ()
traceRn String
"rnSplicePat: untyped pattern splice" forall doc. IsOutput doc => doc
empty
; (GenLocated SrcSpanAnnA (Pat GhcPs)
pat, [ForeignRef (Q ())]
mod_finalizers) <-
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedPatSplice LHsExpr GhcTc -> TcM (LPat GhcPs)
runMetaP forall a. Outputable a => a -> SDoc
ppr HsUntypedSplice (GhcPass 'Renamed)
rn_splice
; let p :: HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))
p = forall thing.
ThModFinalizers -> thing -> HsUntypedSpliceResult thing
HsUntypedSpliceTop ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers) GenLocated SrcSpanAnnA (Pat GhcPs)
pat
; forall (m :: * -> *) a. Monad m => a -> m a
return ((HsUntypedSplice (GhcPass 'Renamed)
rn_splice, HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))
p), Uses
emptyFVs) }
rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl (GhcPass 'Renamed), Uses)
rnSpliceDecl (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpanAnnA
loc HsUntypedSplice GhcPs
splice) SpliceDecoration
flg)
= forall a.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen forall {p :: Pass} {a}.
(OutputableBndr (IdGhcP p),
OutputableBndr (IdGhcP (NoGhcTcPass p)), IsPass p,
Outputable (GenLocated (Anno (IdGhcP p)) (IdGhcP p)),
Outputable
(GenLocated
(Anno (IdGhcP (NoGhcTcPass p))) (IdGhcP (NoGhcTcPass p)))) =>
HsUntypedSplice (GhcPass p) -> a
run_decl_splice Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice, SpliceDecl (GhcPass 'Renamed))
pend_decl_splice HsUntypedSplice GhcPs
splice
where
pend_decl_splice :: Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice, SpliceDecl (GhcPass 'Renamed))
pend_decl_splice Name
name HsUntypedSplice (GhcPass 'Renamed)
rn_splice
= ( UntypedSpliceFlavour
-> Name -> HsUntypedSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedDeclSplice Name
name HsUntypedSplice (GhcPass 'Renamed)
rn_splice
, forall p.
XSpliceDecl p
-> XRec p (HsUntypedSplice p) -> SpliceDecoration -> SpliceDecl p
SpliceDecl NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsUntypedSplice (GhcPass 'Renamed)
rn_splice) SpliceDecoration
flg)
run_decl_splice :: HsUntypedSplice (GhcPass p) -> a
run_decl_splice HsUntypedSplice (GhcPass p)
rn_splice = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnSpliceDecl" (forall (p :: Pass).
OutputableBndrId p =>
Bool -> Maybe Name -> HsUntypedSplice (GhcPass p) -> SDoc
pprUntypedSplice Bool
True forall a. Maybe a
Nothing HsUntypedSplice (GhcPass p)
rn_splice)
rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], Uses)
rnTopSpliceDecls HsUntypedSplice GhcPs
splice
= do { HsUntypedSplice GhcPs -> RnM ()
checkTopSpliceAllowed HsUntypedSplice GhcPs
splice
; (HsUntypedSplice (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
$
HsUntypedSplice GhcPs
-> TcRn (HsUntypedSplice (GhcPass 'Renamed), Uses)
rnUntypedSplice HsUntypedSplice GhcPs
splice
; String -> SDoc -> RnM ()
traceRn String
"rnTopSpliceDecls: untyped declaration splice" forall doc. IsOutput doc => doc
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)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedDeclSplice LHsExpr GhcTc -> TcM [LHsDecl GhcPs]
runMetaD [LHsDecl GhcPs] -> SDoc
ppr_decls HsUntypedSplice (GhcPass 'Renamed)
rn_splice
; [ForeignRef (Q ())] -> RnM ()
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 = forall doc. IsDoc doc => [doc] -> doc
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 ())] -> RnM ()
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 :: HsUntypedSplice GhcPs -> SDoc
spliceCtxt :: HsUntypedSplice GhcPs -> SDoc
spliceCtxt HsUntypedSplice GhcPs
splice
= SDoc -> ThLevel -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"In the" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
what) ThLevel
2 (forall (p :: Pass).
OutputableBndrId p =>
Bool -> Maybe Name -> HsUntypedSplice (GhcPass p) -> SDoc
pprUntypedSplice Bool
True forall a. Maybe a
Nothing HsUntypedSplice GhcPs
splice)
where
what :: SDoc
what = case HsUntypedSplice GhcPs
splice of
HsUntypedSpliceExpr {} -> forall doc. IsLine doc => String -> doc
text String
"untyped splice:"
HsQuasiQuote {} -> forall doc. IsLine doc => String -> doc
text String
"quasi-quotation:"
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 -> RnM ()
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 -> RnM ()
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
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
$ Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger 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 = [ forall doc. IsLine doc => String -> doc
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 forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
colon forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"Splicing" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
sd)
ThLevel
2 (forall doc. IsLine doc => [doc] -> doc
sep [SDoc]
code)
spliceCodeDoc :: SrcSpan -> SDoc
spliceCodeDoc :: SrcSpan -> SDoc
spliceCodeDoc SrcSpan
loc
= forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"--" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
colon forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"Splicing" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
sd
, SDoc
gen ]
illegalTypedSplice :: TcRnMessage
illegalTypedSplice :: TcRnMessage
illegalTypedSplice = forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
"Typed splices may not appear in untyped brackets"
illegalUntypedSplice :: TcRnMessage
illegalUntypedSplice :: TcRnMessage
illegalUntypedSplice = forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
"Untyped splices may not appear in typed brackets"
checkThLocalName :: Name -> RnM ()
checkThLocalName :: Name -> RnM ()
checkThLocalName Name
name
| Name -> Bool
isUnboundName Name
name
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { String -> SDoc -> RnM ()
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 -> RnM ()
checkWellStaged (SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name)) ThLevel
bind_lvl ThLevel
use_lvl
; String -> SDoc -> RnM ()
traceRn String
"checkThLocalName" (forall a. Outputable a => a -> SDoc
ppr Name
name forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ThLevel
bind_lvl
forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ThStage
use_stage
forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ThLevel
use_lvl)
; TopLevelFlag -> ThLevel -> ThStage -> ThLevel -> Name -> RnM ()
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 -> RnM ()
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] -> RnM ()
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] -> RnM ()
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 -> RnM ()
keepAlive Name
name)
| Bool
otherwise
=
do { String -> SDoc -> RnM ()
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
; (ErrInfo -> TcRnMessage) -> RnM ()
addDetailedDiagnostic (Name -> ErrInfo -> TcRnMessage
TcRnImplicitLift Name
name)
; [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) }