{-# 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.Boot.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
= ErrCtxtMsg
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcPs -> ErrCtxtMsg
forall (p :: Pass).
OutputableBndrId p =>
LHsExpr (GhcPass p) -> ErrCtxtMsg
TypedTHBracketCtxt 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
= ErrCtxtMsg
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (HsQuote GhcPs -> ErrCtxtMsg
UntypedTHBracketCtxt 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 <- WhatLooking -> RdrName -> RnM Name
lookupOccRn (if Bool
flg then WhatLooking
WL_Term else WhatLooking
WL_Type) (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
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
= ErrCtxtMsg -> RnM (a, Uses) -> RnM (a, Uses)
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (HsUntypedSplice GhcPs -> ErrCtxtMsg
UntypedSpliceCtxt 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
(LIdP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall (p :: Pass).
IsPass p =>
LIdP (GhcPass p) -> HsExpr (GhcPass p)
mkHsVar (Anno (IdGhcP 'Renamed)
-> Name -> GenLocated (Anno (IdGhcP 'Renamed)) Name
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> Anno (IdGhcP 'Renamed)
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
$! LIdP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
GenLocated (Anno (IdGhcP 'Renamed)) Name
-> HsExpr (GhcPass 'Renamed)
forall (p :: Pass).
IsPass p =>
LIdP (GhcPass p) -> HsExpr (GhcPass p)
mkHsVar (GenLocated (Anno (IdGhcP 'Renamed)) Name
-> HsExpr (GhcPass 'Renamed))
-> GenLocated (Anno (IdGhcP 'Renamed)) Name
-> HsExpr (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$! (Anno (IdGhcP 'Renamed)
-> Name -> GenLocated (Anno (IdGhcP 'Renamed)) Name
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> Anno (IdGhcP 'Renamed)
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' <- WhatLooking -> RdrName -> RnM Name
lookupOccRn WhatLooking
WL_TermVariable 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
= ErrCtxtMsg
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (Maybe Name -> LHsExpr GhcPs -> ErrCtxtMsg
forall (p :: Pass).
OutputableBndrId p =>
Maybe Name -> LHsExpr (GhcPass p) -> ErrCtxtMsg
TypedSpliceCtxt 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).
IsPass p =>
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)),
OutputableBndr (IdOccGhcP p),
OutputableBndr (IdOccGhcP (NoGhcTcPass p)), IsPass p,
Outputable (GenLocated (Anno (IdGhcP p)) (IdGhcP p)),
Outputable
(GenLocated
(Anno (IdGhcP (NoGhcTcPass p))) (IdGhcP (NoGhcTcPass p))),
Outputable (GenLocated (Anno (IdOccGhcP p)) (IdOccGhcP p)),
Outputable
(GenLocated
(Anno (IdOccGhcP (NoGhcTcPass p))) (IdOccGhcP (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
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
; ([ErrCtxtMsg] -> TcRnMessage) -> RnM ()
addDetailedDiagnostic (Name -> [ErrCtxtMsg] -> 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 ()