{-# 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 <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TemplateHaskellQuotes
; Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
thQuotesEnabled (RnM () -> RnM ()) -> RnM () -> RnM ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWith ( DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Syntax error on" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e
, String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"Perhaps you intended to use TemplateHaskell"
String -> String -> String
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
= SDoc
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcPs -> SDoc
typedQuotationCtxtDoc LHsExpr GhcPs
br_body) (RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses))
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
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 -> () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Splice SpliceType
Untyped -> TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalTypedBracket
; RunSplice TcRef [ForeignRef (Q ())]
_ ->
String -> SDoc -> RnM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnTypedBracket: Renaming typed bracket when running a splice"
(HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e)
; ThStage
Comp -> () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Brack {} -> TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalBracket
}
; RnM ()
recordThUse
; String -> SDoc -> RnM ()
traceRn String
"Renaming typed TH bracket" SDoc
forall doc. IsOutput doc => doc
empty
; (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
body', Uses
fvs_e) <- ThStage
-> TcM (LHsExpr (GhcPass 'Renamed), Uses)
-> TcM (LHsExpr (GhcPass 'Renamed), Uses)
forall a. ThStage -> TcM a -> TcM a
setStage (ThStage -> PendingStuff -> ThStage
Brack ThStage
cur_stage PendingStuff
RnPendingTyped) (TcM (LHsExpr (GhcPass 'Renamed), Uses)
-> TcM (LHsExpr (GhcPass 'Renamed), Uses))
-> TcM (LHsExpr (GhcPass 'Renamed), Uses)
-> TcM (LHsExpr (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> TcM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
br_body
; (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XTypedBracket (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XTypedBracket p -> LHsExpr p -> HsExpr p
HsTypedBracket XTypedBracket (GhcPass 'Renamed)
NoExtField
noExtField LHsExpr (GhcPass 'Renamed)
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
= SDoc
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsQuote GhcPs -> SDoc
untypedQuotationCtxtDoc HsQuote GhcPs
br_body) (RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses))
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
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 -> TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalUntypedBracket
; Splice SpliceType
Untyped -> () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; RunSplice TcRef [ForeignRef (Q ())]
_ ->
String -> SDoc -> RnM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnUntypedBracket: Renaming untyped bracket when running a splice"
(HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e)
; ThStage
Comp -> () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Brack {} -> TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalBracket
}
; RnM ()
recordThUse
; String -> SDoc -> RnM ()
traceRn String
"Renaming untyped TH bracket" SDoc
forall doc. IsOutput doc => doc
empty
; IORef [PendingRnSplice]
ps_var <- [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef [PendingRnSplice])
forall a env. a -> IOEnv env (IORef a)
newMutVar []
; (HsQuote (GhcPass 'Renamed)
body', Uses
fvs_e) <-
Extension
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetXOptM Extension
LangExt.RebindableSyntax (TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses))
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$
ThStage
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall a. ThStage -> TcM a -> TcM a
setStage (ThStage -> PendingStuff -> ThStage
Brack ThStage
cur_stage (IORef [PendingRnSplice] -> PendingStuff
RnPendingUntyped IORef [PendingRnSplice]
ps_var)) (TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses))
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
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 <- IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingRnSplice]
forall a env. IORef a -> IOEnv env a
readMutVar IORef [PendingRnSplice]
ps_var
; (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XUntypedBracket (GhcPass 'Renamed)
-> HsQuote (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XUntypedBracket p -> HsQuote p -> HsExpr p
HsUntypedBracket [PendingRnSplice]
XUntypedBracket (GhcPass 'Renamed)
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 (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
rdr_name)
; Bool -> Name -> RnM ()
check_namespace Bool
flg Name
name
; Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
flg Bool -> Bool -> Bool
&& Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name) (RnM () -> RnM ()) -> RnM () -> RnM ()
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 -> () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Just (TopLevelFlag
top_lvl, ThLevel
bind_lvl)
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
-> Bool -> RnM () -> RnM ()
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"
(Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThLevel
bind_lvl
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThStage -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThStage
outer_stage)
; Bool -> TcRnMessage -> RnM ()
checkTc (ThStage -> ThLevel
thLevel ThStage
outer_stage ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ ThLevel
1 ThLevel -> ThLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ThLevel
bind_lvl)
(HsQuote GhcPs -> TcRnMessage
quotedNameStageErr HsQuote GhcPs
br) }
}
}
; (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVarBr (GhcPass 'Renamed)
-> Bool -> LIdP (GhcPass 'Renamed) -> HsQuote (GhcPass 'Renamed)
forall p. XVarBr p -> Bool -> LIdP p -> HsQuote p
VarBr XVarBr GhcPs
XVarBr (GhcPass 'Renamed)
x Bool
flg (Name -> GenLocated SrcSpanAnnN Name
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 -> TcM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
e
; (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XExpBr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> HsQuote (GhcPass 'Renamed)
forall p. XExpBr p -> LHsExpr p -> HsQuote p
ExpBr XExpBr GhcPs
XExpBr (GhcPass 'Renamed)
x LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
e', Uses
fvs) }
rn_utbracket ThStage
_ (PatBr XPatBr GhcPs
x LPat GhcPs
p)
= HsMatchContext (GhcPass 'Renamed)
-> LPat GhcPs
-> (LPat (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses))
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall a.
HsMatchContext (GhcPass 'Renamed)
-> LPat GhcPs
-> (LPat (GhcPass 'Renamed) -> RnM (a, Uses))
-> RnM (a, Uses)
rnPat HsMatchContext (GhcPass 'Renamed)
forall p. HsMatchContext p
ThPatQuote LPat GhcPs
p ((LPat (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses))
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses))
-> (LPat (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses))
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$ \ LPat (GhcPass 'Renamed)
p' -> (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPatBr (GhcPass 'Renamed)
-> LPat (GhcPass 'Renamed) -> HsQuote (GhcPass 'Renamed)
forall p. XPatBr p -> LPat p -> HsQuote p
PatBr XPatBr GhcPs
XPatBr (GhcPass 'Renamed)
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
; (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XTypBr (GhcPass 'Renamed)
-> LHsType (GhcPass 'Renamed) -> HsQuote (GhcPass 'Renamed)
forall p. XTypBr p -> LHsType p -> HsQuote p
TypBr XTypBr GhcPs
XTypBr (GhcPass 'Renamed)
x LHsType (GhcPass 'Renamed)
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 <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let new_gbl_env :: TcGblEnv
new_gbl_env = TcGblEnv
gbl_env { tcg_dus = emptyDUs }
; (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
group') <- TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
new_gbl_env (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed)))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed))
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" (DefUses -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
Uses -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DefUses -> Uses
duUses (TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env)))
; (HsQuote (GhcPass 'Renamed), Uses)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecBrG (GhcPass 'Renamed)
-> HsGroup (GhcPass 'Renamed) -> HsQuote (GhcPass 'Renamed)
forall p. XDecBrG p -> HsGroup p -> HsQuote p
DecBrG XDecBrG (GhcPass 'Renamed)
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 -> HsGroup GhcPs -> RnM (HsGroup GhcPs)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
rest
; let group'' :: HsGroup GhcPs
group'' = HsGroup GhcPs -> HsGroup GhcPs -> HsGroup GhcPs
forall (p :: Pass).
HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p)
appendGroups HsGroup GhcPs
group HsGroup GhcPs
group'
; HsGroup GhcPs -> RnM (HsGroup GhcPs)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsGroup GhcPs
group'' { hs_splcds = noLocA splice : hs_splcds group' }
}
}}
rn_utbracket ThStage
_ (DecBrG {}) = String
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
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
= Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NameSpace -> Bool
isValNameSpace NameSpace
ns Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
is_single_tick) (RnM () -> RnM ()) -> RnM () -> RnM ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWithTc (TcRnMessage -> RnM ()) -> TcRnMessage -> RnM ()
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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the Template Haskell typed quotation")
ThLevel
2 (SDoc -> SDoc
thTyBrackets (SDoc -> SDoc) -> (LHsExpr GhcPs -> SDoc) -> LHsExpr GhcPs -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> SDoc
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsExpr GhcPs -> SDoc) -> LHsExpr GhcPs -> SDoc
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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the Template Haskell quotation")
ThLevel
2 (HsQuote GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsQuote GhcPs
br_body)
illegalBracket :: TcRnMessage
illegalBracket :: TcRnMessage
illegalBracket = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Template Haskell brackets cannot be nested" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(without intervening splices)"
illegalTypedBracket :: TcRnMessage
illegalTypedBracket :: TcRnMessage
illegalTypedBracket = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Typed brackets may only appear in typed splices."
illegalUntypedBracket :: TcRnMessage
illegalUntypedBracket :: TcRnMessage
illegalUntypedBracket = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
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
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Stage error: the non-top-level quoted name" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsQuote GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsQuote GhcPs
br
, String -> SDoc
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
= SDoc -> RnM (a, Uses) -> RnM (a, Uses)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsUntypedSplice GhcPs -> SDoc
spliceCtxt HsUntypedSplice GhcPs
splice) (RnM (a, Uses) -> RnM (a, Uses)) -> RnM (a, Uses) -> RnM (a, Uses)
forall a b. (a -> b) -> a -> b
$ do
{ ThStage
stage <- TcM ThStage
getStage
; case ThStage
stage of
Brack ThStage
_ PendingStuff
RnPendingTyped
-> TcRnMessage -> RnM (a, Uses)
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalUntypedSplice
Brack ThStage
pop_stage (RnPendingUntyped IORef [PendingRnSplice]
ps_var)
-> do { (HsUntypedSplice (GhcPass 'Renamed)
splice', Uses
fvs) <- ThStage
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a. ThStage -> TcM a -> TcM a
setStage ThStage
pop_stage (TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses))
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$
HsUntypedSplice GhcPs
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
rnUntypedSplice HsUntypedSplice GhcPs
splice
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; Name
splice_name <- GenLocated SrcSpanAnnN RdrName -> RnM Name
newLocalBndrRn (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
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 <- IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingRnSplice]
forall a env. IORef a -> IOEnv env a
readMutVar IORef [PendingRnSplice]
ps_var
; IORef [PendingRnSplice] -> [PendingRnSplice] -> RnM ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef [PendingRnSplice]
ps_var (PendingRnSplice
pending_splice PendingRnSplice -> [PendingRnSplice] -> [PendingRnSplice]
forall a. a -> [a] -> [a]
: [PendingRnSplice]
ps)
; (a, Uses) -> RnM (a, Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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) <- TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall r. TcM r -> TcM r
checkNoErrs (TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses))
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$
ThStage
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
Untyped) (TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses))
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$
HsUntypedSplice GhcPs
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
rnUntypedSplice HsUntypedSplice GhcPs
splice
; (a
result, Uses
fvs2) <- HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses)
run_splice HsUntypedSplice (GhcPass 'Renamed)
splice'
; (a, Uses) -> RnM (a, Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
ext
Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
extEnabled
(TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
herald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"are not permitted without" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Extension -> SDoc
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 (HscEnv -> Hooks)
-> IOEnv (Env TcGblEnv TcLclEnv) HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) Hooks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) HscEnv
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 -> HsUntypedSplice (GhcPass 'Renamed)
-> IOEnv
(Env TcGblEnv TcLclEnv) (HsUntypedSplice (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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)
Name
q XRec GhcPs FastString
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)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
zonkTopLExpr (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
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 <- [ForeignRef (Q ())]
-> TcRnIf TcGblEnv TcLclEnv (TcRef [ForeignRef (Q ())])
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef []
; res
result <- ThStage -> TcRn res -> TcRn res
forall a. ThStage -> TcM a -> TcM a
setStage (TcRef [ForeignRef (Q ())] -> ThStage
RunSplice TcRef [ForeignRef (Q ())]
mod_finalizers_ref) (TcRn res -> TcRn res) -> TcRn res -> TcRn res
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcTc -> TcRn res
run_meta LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
zonked_q_expr
; [ForeignRef (Q ())]
mod_finalizers <- TcRef [ForeignRef (Q ())]
-> TcRnIf TcGblEnv TcLclEnv [ForeignRef (Q ())]
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 = GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall a. a -> Maybe a
Just LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
the_expr
, spliceGenerated :: SDoc
spliceGenerated = res -> SDoc
ppr_res res
result })
; (res, [ForeignRef (Q ())]) -> TcRn (res, [ForeignRef (Q ())])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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)
Name
quoter XRec GhcPs FastString
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)
= SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
q_span (HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ XApp (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp (GhcPass 'Renamed)
EpAnn NoEpAnns
noComments (SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
q_span
(HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ XApp (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp (GhcPass 'Renamed)
EpAnn NoEpAnns
noComments (SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
q_span
(XVar (GhcPass 'Renamed)
-> LIdP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnN
forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
q_span) Name
quote_selector)))
LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
quoterExpr)
LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
quoteExpr
where
q_span :: SrcSpanAnnA
q_span = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan (SrcSpanAnn' (EpAnn NoEpAnns) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn NoEpAnns)
q_span')
quoterExpr :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
quoterExpr = SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
q_span (HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$! XVar (GhcPass 'Renamed)
-> LIdP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField (GenLocated SrcSpanAnnN Name -> HsExpr (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnN Name -> HsExpr (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$! (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnN
forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
q_span) Name
quoter)
quoteExpr :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
quoteExpr = SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
q_span (HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$! XLitE (GhcPass 'Renamed)
-> HsLit (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE (GhcPass 'Renamed)
EpAnn NoEpAnns
noComments (HsLit (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed))
-> HsLit (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$! XHsString (GhcPass 'Renamed)
-> FastString -> HsLit (GhcPass 'Renamed)
forall x. XHsString x -> FastString -> HsLit x
HsString XHsString (GhcPass 'Renamed)
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
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
rnUntypedSplice (HsUntypedSpliceExpr XUntypedSpliceExpr GhcPs
annCo LHsExpr GhcPs
expr)
= do { (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr', Uses
fvs) <- LHsExpr GhcPs -> TcM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
expr
; (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XUntypedSpliceExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> HsUntypedSplice (GhcPass 'Renamed)
forall id.
XUntypedSpliceExpr id -> LHsExpr id -> HsUntypedSplice id
HsUntypedSpliceExpr XUntypedSpliceExpr GhcPs
XUntypedSpliceExpr (GhcPass 'Renamed)
annCo LHsExpr (GhcPass 'Renamed)
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
RdrName
quoter
; Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
quoter') (RnM () -> RnM ()) -> RnM () -> RnM ()
forall a b. (a -> b) -> a -> b
$
Name -> RnM ()
checkThLocalName Name
quoter'
; (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XQuasiQuote (GhcPass 'Renamed)
-> IdP (GhcPass 'Renamed)
-> XRec (GhcPass 'Renamed) FastString
-> HsUntypedSplice (GhcPass 'Renamed)
forall id.
XQuasiQuote id
-> IdP id -> XRec id FastString -> HsUntypedSplice id
HsQuasiQuote XQuasiQuote GhcPs
XQuasiQuote (GhcPass 'Renamed)
ext IdP (GhcPass 'Renamed)
Name
quoter' XRec GhcPs FastString
XRec (GhcPass 'Renamed) 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
= SDoc
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the typed splice:") ThLevel
2 (Maybe Name -> LHsExpr GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
Maybe Name -> LHsExpr (GhcPass p) -> SDoc
pprTypedSplice Maybe Name
forall a. Maybe a
Nothing LHsExpr GhcPs
expr)) (RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses))
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$ do
{ ThStage
stage <- TcM ThStage
getStage
; case ThStage
stage of
Brack ThStage
pop_stage PendingStuff
RnPendingTyped
-> ThStage
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. ThStage -> TcM a -> TcM a
setStage ThStage
pop_stage RnM (HsExpr (GhcPass 'Renamed), Uses)
rn_splice
Brack ThStage
_ (RnPendingUntyped IORef [PendingRnSplice]
_)
-> TcRnMessage -> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
illegalTypedSplice
ThStage
_ -> do { Bool
extEnabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TemplateHaskell
; Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
extEnabled
(TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Top-level splices are not permitted without"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Extension -> SDoc
forall a. Outputable a => a -> SDoc
ppr Extension
LangExt.TemplateHaskell)
; (HsExpr (GhcPass 'Renamed)
result, Uses
fvs1) <- RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall r. TcM r -> TcM r
checkNoErrs (RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses))
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$ ThStage
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
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" SDoc
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
; (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
unqualSplice)
; (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr', Uses
fvs) <- LHsExpr GhcPs -> TcM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
expr
; (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XTypedSplice (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XTypedSplice p -> LHsExpr p -> HsExpr p
HsTypedSplice XTypedSplice (GhcPass 'Renamed)
Name
n' LHsExpr (GhcPass 'Renamed)
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
= (HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsExpr (GhcPass 'Renamed), Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice, HsExpr (GhcPass 'Renamed)))
-> HsUntypedSplice GhcPs
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
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, XUntypedSplice (GhcPass 'Renamed)
-> HsUntypedSplice (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XUntypedSplice p -> HsUntypedSplice p -> HsExpr p
HsUntypedSplice (Name -> HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
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" SDoc
forall doc. IsOutput doc => doc
empty
; (GenLocated SrcSpanAnnA (HsExpr GhcPs)
rn_expr, [ForeignRef (Q ())]
mod_finalizers) <-
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcPs), [ForeignRef (Q ())])
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedExpSplice LHsExpr GhcTc -> TcM (LHsExpr GhcPs)
LHsExpr GhcTc -> TcRn (GenLocated SrcSpanAnnA (HsExpr GhcPs))
runMetaE GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsUntypedSplice (GhcPass 'Renamed)
rn_splice
; (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
lexpr3, Uses
fvs) <- IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)), Uses)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)), Uses)
forall r. TcM r -> TcM r
checkNoErrs (LHsExpr GhcPs -> TcM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
rn_expr)
; let e :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
e = (HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
-> HsUntypedSplice (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed))
-> HsUntypedSplice (GhcPass 'Renamed)
-> HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall a b c. (a -> b -> c) -> b -> a -> c
flip XUntypedSplice (GhcPass 'Renamed)
-> HsUntypedSplice (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
-> HsUntypedSplice (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XUntypedSplice p -> HsUntypedSplice p -> HsExpr p
HsUntypedSplice HsUntypedSplice (GhcPass 'Renamed)
rn_splice
(HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed))
-> (HsExpr (GhcPass 'Renamed)
-> HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed)))
-> HsExpr (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThModFinalizers
-> HsExpr (GhcPass 'Renamed)
-> HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
forall thing.
ThModFinalizers -> thing -> HsUntypedSpliceResult thing
HsUntypedSpliceTop ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers)
(HsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
lexpr3
; (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar LHsExpr (GhcPass 'Renamed)
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
= (HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsType (GhcPass 'Renamed), Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice, HsType (GhcPass 'Renamed)))
-> HsUntypedSplice GhcPs
-> RnM (HsType (GhcPass 'Renamed), Uses)
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
, XSpliceTy (GhcPass 'Renamed)
-> HsUntypedSplice (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed)
forall pass. XSpliceTy pass -> HsUntypedSplice pass -> HsType pass
HsSpliceTy (Name
-> HsUntypedSpliceResult
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
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" SDoc
forall doc. IsOutput doc => doc
empty
; (GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ty2, [ForeignRef (Q ())]
mod_finalizers) <-
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn
(GenLocated SrcSpanAnnA (HsType GhcPs), [ForeignRef (Q ())])
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedTypeSplice LHsExpr GhcTc -> TcM (LHsType GhcPs)
LHsExpr GhcTc -> TcRn (GenLocated SrcSpanAnnA (HsType GhcPs))
runMetaT GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
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 LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ty2
; RnM (LHsType (GhcPass 'Renamed), Uses)
-> RnM (LHsType (GhcPass 'Renamed), Uses)
forall r. TcM r -> TcM r
checkNoErrs (RnM (LHsType (GhcPass 'Renamed), Uses)
-> RnM (LHsType (GhcPass 'Renamed), Uses))
-> RnM (LHsType (GhcPass 'Renamed), Uses)
-> RnM (LHsType (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$ HsDocContext
-> LHsType GhcPs -> RnM (LHsType (GhcPass 'Renamed), Uses)
rnLHsType HsDocContext
doc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ty2 }
; (HsType (GhcPass 'Renamed), Uses)
-> RnM (HsType (GhcPass 'Renamed), Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( XSpliceTy (GhcPass 'Renamed)
-> HsUntypedSplice (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed)
forall pass. XSpliceTy pass -> HsUntypedSplice pass -> HsType pass
HsSpliceTy (ThModFinalizers
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> HsUntypedSpliceResult
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall thing.
ThModFinalizers -> thing -> HsUntypedSpliceResult thing
HsUntypedSpliceTop ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers)
(LHsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
mb_paren LHsType (GhcPass 'Renamed)
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)
| PprPrec -> HsType (GhcPass 'Renamed) -> Bool
forall (p :: Pass). PprPrec -> HsType (GhcPass p) -> Bool
hsTypeNeedsParens PprPrec
maxPrec HsType (GhcPass 'Renamed)
hs_ty = SrcSpanAnnA
-> HsType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XParTy (GhcPass 'Renamed)
-> LHsType (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed)
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy (GhcPass 'Renamed)
EpAnn AnnParen
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
= (HsUntypedSplice (GhcPass 'Renamed)
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))),
Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice,
(HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs)))))
-> HsUntypedSplice GhcPs
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))),
Uses)
forall a.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed)
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))),
Uses)
run_pat_splice Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice,
(HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))))
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, Name -> HsUntypedSpliceResult thing
forall thing. Name -> HsUntypedSpliceResult thing
HsUntypedSpliceNested Name
name))
run_pat_splice :: HsUntypedSplice (GhcPass 'Renamed)
-> RnM
((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" SDoc
forall doc. IsOutput doc => doc
empty
; (GenLocated SrcSpanAnnA (Pat GhcPs)
pat, [ForeignRef (Q ())]
mod_finalizers) <-
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> (GenLocated SrcSpanAnnA (Pat GhcPs) -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn (GenLocated SrcSpanAnnA (Pat GhcPs), [ForeignRef (Q ())])
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedPatSplice LHsExpr GhcTc -> TcM (LPat GhcPs)
LHsExpr GhcTc -> TcRn (GenLocated SrcSpanAnnA (Pat GhcPs))
runMetaP GenLocated SrcSpanAnnA (Pat GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsUntypedSplice (GhcPass 'Renamed)
rn_splice
; let p :: HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))
p = ThModFinalizers
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))
forall thing.
ThModFinalizers -> thing -> HsUntypedSpliceResult thing
HsUntypedSpliceTop ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers) GenLocated SrcSpanAnnA (Pat GhcPs)
pat
; ((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))),
Uses)
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))),
Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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)
= (HsUntypedSplice (GhcPass 'Renamed)
-> RnM (SpliceDecl (GhcPass 'Renamed), Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice, SpliceDecl (GhcPass 'Renamed)))
-> HsUntypedSplice GhcPs
-> RnM (SpliceDecl (GhcPass 'Renamed), Uses)
forall a.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed) -> (PendingRnSplice, a))
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed)
-> RnM (SpliceDecl (GhcPass 'Renamed), Uses)
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
, XSpliceDecl (GhcPass 'Renamed)
-> XRec (GhcPass 'Renamed) (HsUntypedSplice (GhcPass 'Renamed))
-> SpliceDecoration
-> SpliceDecl (GhcPass 'Renamed)
forall p.
XSpliceDecl p
-> XRec p (HsUntypedSplice p) -> SpliceDecoration -> SpliceDecl p
SpliceDecl XSpliceDecl (GhcPass 'Renamed)
NoExtField
noExtField (SrcSpanAnnA
-> HsUntypedSplice (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsUntypedSplice (GhcPass 'Renamed))
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 = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnSpliceDecl" (Bool -> Maybe Name -> HsUntypedSplice (GhcPass p) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
Bool -> Maybe Name -> HsUntypedSplice (GhcPass p) -> SDoc
pprUntypedSplice Bool
True Maybe Name
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) <- TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall r. TcM r -> TcM r
checkNoErrs (TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses))
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$
ThStage
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
Untyped) (TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses))
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$
HsUntypedSplice GhcPs
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
rnUntypedSplice HsUntypedSplice GhcPs
splice
; String -> SDoc -> RnM ()
traceRn String
"rnTopSpliceDecls: untyped declaration splice" SDoc
forall doc. IsOutput doc => doc
empty
; ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls, [ForeignRef (Q ())]
mod_finalizers) <- TcM ([GenLocated SrcSpanAnnA (HsDecl GhcPs)], [ForeignRef (Q ())])
-> TcM
([GenLocated SrcSpanAnnA (HsDecl GhcPs)], [ForeignRef (Q ())])
forall r. TcM r -> TcM r
checkNoErrs (TcM ([GenLocated SrcSpanAnnA (HsDecl GhcPs)], [ForeignRef (Q ())])
-> TcM
([GenLocated SrcSpanAnnA (HsDecl GhcPs)], [ForeignRef (Q ())]))
-> TcM
([GenLocated SrcSpanAnnA (HsDecl GhcPs)], [ForeignRef (Q ())])
-> TcM
([GenLocated SrcSpanAnnA (HsDecl GhcPs)], [ForeignRef (Q ())])
forall a b. (a -> b) -> a -> b
$
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> ([GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcM
([GenLocated SrcSpanAnnA (HsDecl GhcPs)], [ForeignRef (Q ())])
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedDeclSplice LHsExpr GhcTc -> TcM [LHsDecl GhcPs]
LHsExpr GhcTc -> TcRn [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
runMetaD [LHsDecl GhcPs] -> SDoc
[GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> SDoc
ppr_decls HsUntypedSplice (GhcPass 'Renamed)
rn_splice
; [ForeignRef (Q ())] -> RnM ()
add_mod_finalizers_now [ForeignRef (Q ())]
mod_finalizers
; ([GenLocated SrcSpanAnnA (HsDecl GhcPs)], Uses)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsDecl GhcPs)], Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
forall doc. IsDoc doc => [doc] -> doc
vcat ((GenLocated SrcSpanAnnA (HsDecl GhcPs) -> SDoc)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsDecl GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds)
add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()
add_mod_finalizers_now :: [ForeignRef (Q ())] -> RnM ()
add_mod_finalizers_now [] = () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
add_mod_finalizers_now [ForeignRef (Q ())]
mod_finalizers = do
TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- (TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)])
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv
(Env TcGblEnv TcLclEnv) (TcRef [(TcLclEnv, ThModFinalizers)])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)]
tcg_th_modfinalizers TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
TcRef [(TcLclEnv, ThModFinalizers)]
-> ([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
-> RnM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var (([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
-> RnM ())
-> ([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
-> RnM ()
forall a b. (a -> b) -> a -> b
$ \[(TcLclEnv, ThModFinalizers)]
fins ->
(TcLclEnv
env, [ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers) (TcLclEnv, ThModFinalizers)
-> [(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)]
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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
what) ThLevel
2 (Bool -> Maybe Name -> HsUntypedSplice GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
Bool -> Maybe Name -> HsUntypedSplice (GhcPass p) -> SDoc
pprUntypedSplice Bool
True Maybe Name
forall a. Maybe a
Nothing HsUntypedSplice GhcPs
splice)
where
what :: SDoc
what = case HsUntypedSplice GhcPs
splice of
HsUntypedSpliceExpr {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"untyped splice:"
HsQuasiQuote {} -> String -> SDoc
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)
_) -> SrcSpan -> TcRn SrcSpan
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
DumpFlag -> SDoc -> RnM ()
traceOptTcRn DumpFlag
Opt_D_dump_splices (SrcSpan -> SDoc
spliceDebugDoc SrcSpan
loc)
Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_decl (RnM () -> RnM ()) -> RnM () -> RnM ()
forall a b. (a -> b) -> a -> b
$ do
Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
IO () -> RnM ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RnM ()) -> IO () -> RnM ()
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 (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass). LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
stripParensLHsExpr LHsExpr (GhcPass 'Renamed)
e)) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [SDoc]
ending
ending :: [SDoc]
ending = [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"======>", ThLevel -> SDoc -> SDoc
nest ThLevel
2 SDoc
gen ]
in SDoc -> ThLevel -> SDoc -> SDoc
hang (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Splicing" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
sd)
ThLevel
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [SDoc]
code)
spliceCodeDoc :: SrcSpan -> SDoc
spliceCodeDoc :: SrcSpan -> SDoc
spliceCodeDoc SrcSpan
loc
= [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"--" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Splicing" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
sd
, SDoc
gen ]
illegalTypedSplice :: TcRnMessage
illegalTypedSplice :: TcRnMessage
illegalTypedSplice = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Typed splices may not appear in untyped brackets"
illegalUntypedSplice :: TcRnMessage
illegalUntypedSplice :: TcRnMessage
illegalUntypedSplice = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
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
= () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { String -> SDoc -> RnM ()
traceRn String
"checkThLocalName" (Name -> SDoc
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 -> () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)) ThLevel
bind_lvl ThLevel
use_lvl
; String -> SDoc -> RnM ()
traceRn String
"checkThLocalName" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThLevel
bind_lvl
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThStage -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThStage
use_stage
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
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 ThLevel -> ThLevel -> Bool
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
= () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
= Bool -> RnM () -> RnM ()
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" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
; let lift_expr :: LHsExpr (GhcPass 'Renamed)
lift_expr = LHsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Renamed)
Name
liftName) (IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Renamed)
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 <- IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingRnSplice]
forall a env. IORef a -> IOEnv env a
readMutVar IORef [PendingRnSplice]
ps_var
; IORef [PendingRnSplice] -> [PendingRnSplice] -> RnM ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef [PendingRnSplice]
ps_var (PendingRnSplice
pend_splice PendingRnSplice -> [PendingRnSplice] -> [PendingRnSplice]
forall a. a -> [a] -> [a]
: [PendingRnSplice]
ps) }