{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.Rename.Splice (
rnTopSpliceDecls,
rnTypedSplice,
rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceTyPat, rnSpliceDecl,
rnTypedBracket, rnUntypedBracket,
checkThLocalName, traceSplice, SpliceInfo(..),
checkThLocalTyName,
) 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.DynFlags
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.Zonk.Type
import GHCi.RemoteTypes ( ForeignRef )
import qualified GHC.Internal.TH.Syntax as TH (Q)
import qualified GHC.LanguageExtensions as LangExt
checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM ()
checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM ()
checkForTemplateHaskellQuotes HsExpr GhcPs
e =
Extension -> RnM () -> RnM ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.TemplateHaskellQuotes (RnM () -> RnM ()) -> RnM () -> RnM ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$ THSyntaxError -> TcRnMessage
thSyntaxError (THSyntaxError -> TcRnMessage) -> THSyntaxError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> THSyntaxError
IllegalTHQuotes HsExpr GhcPs
e
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
; cur_stage <- TcM ThStage
getStage
; case cur_stage of
{ Splice SpliceType
_ -> () -> 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
"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 -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$ THSyntaxError -> TcRnMessage
thSyntaxError
(THSyntaxError -> TcRnMessage) -> THSyntaxError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ THSyntaxError
NestedTHBrackets
}
; recordThUse
; traceRn "Renaming typed TH bracket" empty
; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body
; return (HsTypedBracket noExtField body', 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
; cur_stage <- TcM ThStage
getStage
; case cur_stage of
{ Splice SpliceType
_ -> () -> 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 -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$ THSyntaxError -> TcRnMessage
thSyntaxError
(THSyntaxError -> TcRnMessage) -> THSyntaxError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ THSyntaxError
NestedTHBrackets
}
; recordThUse
; traceRn "Renaming untyped TH bracket" empty
; ps_var <- newMutVar []
; (body', fvs_e) <-
unsetXOptM LangExt.RebindableSyntax $
setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
rn_utbracket cur_stage br_body
; pendings <- readMutVar ps_var
; return (HsUntypedBracket pendings body', 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
_ Bool
flg LIdP GhcPs
rdr_name)
= do { name <- RdrName -> RnM Name
lookupOccRn (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
rdr_name)
; check_namespace flg name
; this_mod <- getModule
; when (flg && nameIsLocalOrFrom this_mod name) $
do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
; case 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) (TcRnMessage -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$
THError -> TcRnMessage
TcRnTHError (THError -> TcRnMessage) -> THError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ THNameError -> THError
THNameError (THNameError -> THError) -> THNameError -> THError
forall a b. (a -> b) -> a -> b
$ HsQuote GhcPs -> THNameError
QuotedNameWrongStage HsQuote GhcPs
br }
}
}
; return (VarBr noExtField flg (noLocA name), unitFV name) }
rn_utbracket ThStage
_ (ExpBr XExpBr GhcPs
_ LHsExpr GhcPs
e) = do { (e', fvs) <- LHsExpr GhcPs -> TcM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
e
; return (ExpBr noExtField e', fvs) }
rn_utbracket ThStage
_ (PatBr XPatBr GhcPs
_ LPat GhcPs
p)
= HsMatchContextRn
-> LPat GhcPs
-> (LPat (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses))
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
forall a.
HsMatchContextRn
-> LPat GhcPs
-> (LPat (GhcPass 'Renamed) -> RnM (a, Uses))
-> RnM (a, Uses)
rnPat HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
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 (GhcPass 'Renamed)
NoExtField
noExtField LPat (GhcPass 'Renamed)
p', Uses
emptyFVs)
rn_utbracket ThStage
_ (TypBr XTypBr GhcPs
_ LHsType GhcPs
t) = do { (t', fvs) <- HsDocContext
-> LHsType GhcPs -> RnM (LHsType (GhcPass 'Renamed), Uses)
rnLHsType HsDocContext
TypBrCtx LHsType GhcPs
t
; return (TypBr noExtField t', fvs) }
rn_utbracket ThStage
_ (DecBrL XDecBrL GhcPs
_ [LHsDecl GhcPs]
decls)
= do { group <- [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls [LHsDecl GhcPs]
decls
; gbl_env <- getGblEnv
; let new_gbl_env = TcGblEnv
gbl_env { tcg_dus = emptyDUs }
; (tcg_env, group') <- setGblEnv new_gbl_env $
rnSrcDecls group
; traceRn "rn_utbracket dec" (ppr (tcg_dus tcg_env) $$
ppr (duUses (tcg_dus tcg_env)))
; return (DecBrG noExtField group', duUses (tcg_dus tcg_env)) }
where
groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls [LHsDecl GhcPs]
decls
= do { (group, mb_splice) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
decls
; case 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 { group' <- [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
rest
; let 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'
; return 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)
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
{ stage <- TcM ThStage
getStage
; case stage of
Brack ThStage
_ PendingStuff
RnPendingTyped
-> TcRnMessage -> RnM (a, Uses)
forall a. TcRnMessage -> TcRn a
failWithTc (TcRnMessage -> RnM (a, Uses)) -> TcRnMessage -> RnM (a, Uses)
forall a b. (a -> b) -> a -> b
$ THSyntaxError -> TcRnMessage
thSyntaxError
(THSyntaxError -> TcRnMessage) -> THSyntaxError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ SpliceType -> SpliceOrBracket -> THSyntaxError
MismatchedSpliceType SpliceType
Untyped SpliceOrBracket
IsSplice
Brack ThStage
pop_stage (RnPendingUntyped IORef [PendingRnSplice]
ps_var)
-> do { (splice', 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
; loc <- getSrcSpanM
; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
; let (pending_splice, result) = pend_splice splice_name splice'
; ps <- readMutVar ps_var
; writeMutVar ps_var (pending_splice : ps)
; return (result, fvs) }
ThStage
_ -> do { HsUntypedSplice GhcPs -> RnM ()
checkTopSpliceAllowed HsUntypedSplice GhcPs
splice
; (splice', 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
; (result, fvs2) <- run_splice splice'
; return (result, fvs1 `plusFV` fvs2) } }
checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM ()
checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM ()
checkTopSpliceAllowed HsUntypedSplice GhcPs
splice = do
let (Extension
ext, TcRnMessage
err) = HsUntypedSplice GhcPs -> (Extension, TcRnMessage)
spliceExtension HsUntypedSplice GhcPs
splice
Extension -> RnM () -> RnM ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
ext (RnM () -> RnM ()) -> RnM () -> RnM ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWith TcRnMessage
err
where
spliceExtension :: HsUntypedSplice GhcPs -> (LangExt.Extension, TcRnMessage)
spliceExtension :: HsUntypedSplice GhcPs -> (Extension, TcRnMessage)
spliceExtension (HsQuasiQuote {}) =
(Extension
LangExt.QuasiQuotes, TcRnMessage
TcRnIllegalQuasiQuotes)
spliceExtension (HsUntypedSpliceExpr {}) =
(Extension
LangExt.TemplateHaskell, THSyntaxError -> TcRnMessage
thSyntaxError (THSyntaxError -> TcRnMessage) -> THSyntaxError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ THSyntaxError
IllegalTHSplice)
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 <- 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
; splice' <- case runRnSpliceHook 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 = 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
; meta_exp_ty <- tcMetaTy meta_ty_name
; zonked_q_expr <- zonkTopLExpr =<<
tcTopSpliceExpr Untyped
(tcCheckPolyExpr the_expr meta_exp_ty)
; mod_finalizers_ref <- newTcRef []
; result <- setStage (RunSplice mod_finalizers_ref) $
run_meta zonked_q_expr
; mod_finalizers <- readTcRef mod_finalizers_ref
; traceSplice (SpliceInfo { spliceDescription = what
, spliceIsDecl = is_decl
, spliceSource = Just the_expr
, spliceGenerated = ppr_res result })
; return (result, 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 EpAnnCO
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)
NoExtField
noExtField (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)
NoExtField
noExtField (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 b. (HasLoc a, HasAnnotation b) => a -> b
l2l 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 e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan (EpAnnCO -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnnCO
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 b. (HasLoc a, HasAnnotation b) => a -> b
l2l 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)
NoExtField
noExtField (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 { (expr', fvs) <- LHsExpr GhcPs -> TcM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
expr
; return (HsUntypedSpliceExpr annCo expr', fvs) }
rnUntypedSplice (HsQuasiQuote XQuasiQuote GhcPs
ext IdP GhcPs
quoter XRec GhcPs FastString
quote)
= do {
; quoter' <- RdrName -> RnM Name
lookupOccRn IdP GhcPs
RdrName
quoter
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod quoter') $
checkThLocalName quoter'
; return (HsQuasiQuote ext quoter' quote, unitFV 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
{ stage <- TcM ThStage
getStage
; case 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 -> RnM (HsExpr (GhcPass 'Renamed), Uses))
-> TcRnMessage -> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a b. (a -> b) -> a -> b
$ THSyntaxError -> TcRnMessage
thSyntaxError (THSyntaxError -> TcRnMessage) -> THSyntaxError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ SpliceType -> SpliceOrBracket -> THSyntaxError
MismatchedSpliceType SpliceType
Typed SpliceOrBracket
IsSplice
ThStage
_ -> do { Extension -> RnM () -> RnM ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.TemplateHaskell
(TcRnMessage -> RnM ()
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$ THSyntaxError -> TcRnMessage
thSyntaxError THSyntaxError
IllegalTHSplice)
; (result, 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
; traceRn "rnTypedSplice: typed expression splice" empty
; lcl_rdr <- getLocalRdrEnv
; gbl_rdr <- getGlobalRdrEnv
; let gbl_names = [Name] -> Uses
mkNameSet [ GlobalRdrEltX GREInfo -> Name
forall info. GlobalRdrEltX info -> Name
greName GlobalRdrEltX GREInfo
gre
| GlobalRdrEltX GREInfo
gre <- GlobalRdrEnv -> [GlobalRdrEltX GREInfo]
forall info. GlobalRdrEnvX info -> [GlobalRdrEltX info]
globalRdrEnvElts GlobalRdrEnv
gbl_rdr
, GlobalRdrEltX GREInfo -> Bool
forall info. GlobalRdrEltX info -> Bool
isLocalGRE GlobalRdrEltX GREInfo
gre]
lcl_names = [Name] -> Uses
mkNameSet (LocalRdrEnv -> [Name]
localRdrEnvElts LocalRdrEnv
lcl_rdr)
fvs2 = Uses
lcl_names Uses -> Uses -> Uses
`plusFV` Uses
gbl_names
; return (result, fvs1 `plusFV` fvs2) } }
where
rn_splice :: RnM (HsExpr GhcRn, FreeVars)
rn_splice :: RnM (HsExpr (GhcPass 'Renamed), Uses)
rn_splice =
do { loc <- TcRn SrcSpan
getSrcSpanM
; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
; (expr', fvs) <- rnLExpr expr
; return (HsTypedSplice n' expr', 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 (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
; (expr_ps, 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
; (L l expr_rn, fvs) <- checkNoErrs (rnLExpr expr_ps)
; let res :: HsUntypedSpliceResult (HsExpr GhcRn)
res = HsUntypedSpliceTop
{ utsplice_result_finalizers :: ThModFinalizers
utsplice_result_finalizers = [ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers
, utsplice_result :: HsExpr (GhcPass 'Renamed)
utsplice_result = HsExpr (GhcPass 'Renamed)
expr_rn }
; return (gHsPar (L l (HsUntypedSplice res rn_splice)), fvs)
}
thSyntaxError :: THSyntaxError -> TcRnMessage
thSyntaxError :: THSyntaxError -> TcRnMessage
thSyntaxError THSyntaxError
err = THError -> TcRnMessage
TcRnTHError (THError -> TcRnMessage) -> THError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ THSyntaxError -> THError
THSyntaxError THSyntaxError
err
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
; (hs_ty2, 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
; (hs_ty3, fvs) <- do { let doc = LHsType GhcPs -> HsDocContext
SpliceTypeCtx LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ty2
; checkNoErrs $ rnLHsType doc hs_ty2 }
; return ( HsSpliceTy (HsUntypedSpliceTop (ThModFinalizers mod_finalizers)
(mb_paren hs_ty3))
rn_splice
, 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 (EpToken "(", EpToken ")")
XParTy (GhcPass 'Renamed)
forall a. NoAnn a => 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
; (pat, 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 = 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
; return ((rn_splice, p), emptyFVs) }
rnSpliceTyPat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LHsType GhcPs))
, FreeVars)
rnSpliceTyPat :: HsUntypedSplice GhcPs
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (LHsType GhcPs)),
Uses)
rnSpliceTyPat HsUntypedSplice GhcPs
splice
= (HsUntypedSplice (GhcPass 'Renamed)
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs))),
Uses))
-> (Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice,
(HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs)))))
-> HsUntypedSplice GhcPs
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType 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 (HsType GhcPs))),
Uses)
run_ty_pat_splice Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice,
(HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs))))
forall {thing}.
Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice,
(HsUntypedSplice (GhcPass 'Renamed), HsUntypedSpliceResult thing))
pend_ty_pat_splice HsUntypedSplice GhcPs
splice
where
pend_ty_pat_splice :: Name
-> HsUntypedSplice (GhcPass 'Renamed)
-> (PendingRnSplice,
(HsUntypedSplice (GhcPass 'Renamed), HsUntypedSpliceResult thing))
pend_ty_pat_splice Name
name HsUntypedSplice (GhcPass 'Renamed)
rn_splice
= (UntypedSpliceFlavour
-> Name -> HsUntypedSplice (GhcPass 'Renamed) -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedTypeSplice Name
name HsUntypedSplice (GhcPass 'Renamed)
rn_splice
, (HsUntypedSplice (GhcPass 'Renamed)
rn_splice, Name -> HsUntypedSpliceResult thing
forall thing. Name -> HsUntypedSpliceResult thing
HsUntypedSpliceNested Name
name))
run_ty_pat_splice :: HsUntypedSplice (GhcPass 'Renamed)
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs))),
Uses)
run_ty_pat_splice HsUntypedSplice (GhcPass 'Renamed)
rn_splice
= do { String -> SDoc -> RnM ()
traceRn String
"rnSpliceTyPat: untyped pattern splice" SDoc
forall doc. IsOutput doc => doc
empty
; (ty, 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
; let t = ThModFinalizers
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs))
forall thing.
ThModFinalizers -> thing -> HsUntypedSpliceResult thing
HsUntypedSpliceTop ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers) GenLocated SrcSpanAnnA (HsType GhcPs)
ty
; return ((rn_splice, t), 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
; (rn_splice, 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
; traceRn "rnTopSpliceDecls: untyped declaration splice" empty
; (decls, mod_finalizers) <- checkNoErrs $
runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
; add_mod_finalizers_now mod_finalizers
; return (decls,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
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
env <- getLclEnv
updTcRef th_modfinalizers_var $ \[(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 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc)
traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)
when is_decl $ do
logger <- getLogger
liftIO $ putDumpFileMaybe logger Opt_D_th_dec_file "" FormatHaskell (spliceCodeDoc 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 ]
checkThLocalTyName :: Name -> RnM ()
checkThLocalTyName :: Name -> RnM ()
checkThLocalTyName 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
"checkThLocalTyName" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
; mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel Name
name
; case 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
; String -> SDoc -> RnM ()
traceRn String
"checkThLocalTyName" (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 ()
checkCrossStageLiftingTy TopLevelFlag
top_lvl ThLevel
bind_lvl ThStage
use_stage ThLevel
use_lvl Name
name } } }
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)
; mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel Name
name
; case 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
; StageCheckReason -> ThLevel -> ThLevel -> RnM ()
checkWellStaged (Name -> StageCheckReason
StageCheckSplice 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)
; ps <- IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingRnSplice]
forall a env. IORef a -> IOEnv env a
readMutVar IORef [PendingRnSplice]
ps_var
; writeMutVar ps_var (pend_splice : ps) }
checkCrossStageLiftingTy :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel -> Name -> TcM ()
checkCrossStageLiftingTy :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel -> Name -> RnM ()
checkCrossStageLiftingTy TopLevelFlag
top_lvl ThLevel
bind_lvl ThStage
_use_stage ThLevel
use_lvl Name
name
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
= () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| ThLevel
use_lvl ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
bind_lvl
= TcRnMessage -> RnM ()
addDiagnostic (TcRnMessage -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$ Name -> ThLevel -> ThLevel -> TcRnMessage
TcRnBadlyStagedType Name
name ThLevel
bind_lvl ThLevel
use_lvl
| ThLevel
bind_lvl ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
< ThLevel
use_lvl
= TcRnMessage -> RnM ()
addDiagnostic (TcRnMessage -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$ Name -> ThLevel -> ThLevel -> TcRnMessage
TcRnBadlyStagedType Name
name ThLevel
bind_lvl ThLevel
use_lvl
| Bool
otherwise
= () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()