{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.Rename.Splice (
rnTopSpliceDecls,
rnTypedSplice,
rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceTyPat, rnSpliceDecl,
rnTypedBracket, rnUntypedBracket,
checkThLocalName, checkThLocalNameWithLift, checkThLocalNameNoLift, 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 ( 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
, 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
import qualified Data.Set as Set
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_level <- TcM ThLevel
getThLevel
; case cur_level of
{ Splice SpliceType
_ ThLevel
_ -> () -> 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)
; ThLevel
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) <- setThLevel (Brack cur_level 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_level <- TcM ThLevel
getThLevel
; case cur_level of
{ Splice SpliceType
_ ThLevel
_ -> () -> 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)
; ThLevel
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 $
setThLevel (UntypedBrack cur_level ps_var) $
rn_utbracket br_body
; pendings <- readMutVar ps_var
; return (HsUntypedBracket pendings body', fvs_e)
}
rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
rn_utbracket :: HsQuote GhcPs
-> TcRnIf TcGblEnv TcLclEnv (HsQuote (GhcPass 'Renamed), Uses)
rn_utbracket (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)
; let res_name = SrcSpanAnnN
-> WithUserRdr Name -> GenLocated SrcSpanAnnN (WithUserRdr Name)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l (GenLocated SrcSpanAnnN RdrName -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
rdr_name)) (RdrName -> Name -> WithUserRdr Name
forall a. RdrName -> a -> WithUserRdr a
WithUserRdr (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
rdr_name) Name
name)
; if flg then checkThLocalNameNoLift res_name else checkThLocalTyName name
; check_namespace flg name
; return (VarBr noExtField flg (noLocA name), unitFV name) }
rn_utbracket (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 (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 (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 (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 (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))
-> (UntypedSpliceFlavour, HsUntypedSpliceResult z -> HsUntypedSplice GhcRn -> RnM a)
-> HsUntypedSplice GhcPs
-> RnM (a, FreeVars)
rnUntypedSpliceGen :: forall a z.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult z
-> HsUntypedSplice (GhcPass 'Renamed) -> RnM a)
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses)
run_splice (UntypedSpliceFlavour
flavour, HsUntypedSpliceResult z
-> HsUntypedSplice (GhcPass 'Renamed) -> RnM a
run_pending) 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
{ level <- TcM ThLevel
getThLevel
; case level of
TypedBrack {}
-> 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
UntypedBrack ThLevel
pop_level IORef [PendingRnSplice]
ps_var
-> do { (splice', fvs) <- ThLevel
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
forall a. ThLevel -> TcM a -> TcM a
setThLevel ThLevel
pop_level (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
-> UntypedSpliceFlavour
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
rnUntypedSplice HsUntypedSplice GhcPs
splice UntypedSpliceFlavour
flavour
; loc <- getSrcSpanM
; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
; result <- run_pending (HsUntypedSpliceNested splice_name) splice'
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingRnSplice splice_name splice' : ps)
; return (result, fvs) }
ThLevel
_ -> do { HsUntypedSplice GhcPs -> RnM ()
checkTopSpliceAllowed HsUntypedSplice GhcPs
splice
; cur_level <- TcM ThLevel
getThLevel
; (splice', fvs1) <- checkNoErrs $
setThLevel (Splice Untyped cur_level) $
rnUntypedSplice splice flavour
; (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)
_ LIdP (GhcPass 'Renamed)
q XRec (GhcPass 'Renamed) FastString
str -> UntypedSpliceFlavour
-> LIdP (GhcPass 'Renamed)
-> XRec GhcPs FastString
-> LHsExpr (GhcPass 'Renamed)
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour LIdP (GhcPass 'Renamed)
q XRec GhcPs FastString
XRec (GhcPass 'Renamed) FastString
str
XUntypedSplice {} -> String
-> SDoc -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"runRnSplice: XUntypedSplice" (Bool -> Maybe Name -> HsUntypedSplice (GhcPass 'Renamed) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
Bool -> Maybe Name -> HsUntypedSplice (GhcPass p) -> SDoc
pprUntypedSplice Bool
False Maybe Name
forall a. Maybe a
Nothing HsUntypedSplice (GhcPass 'Renamed)
splice')
; meta_exp_ty <- tcMetaTy meta_ty_name
; zonked_q_expr <- zonkTopLExpr =<<
tcTopSpliceExpr Untyped
(tcCheckPolyExpr the_expr meta_exp_ty)
; mod_finalizers_ref <- newTcRef []
; result <- setThLevel (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
recordPendingSplice :: SplicePointName -> HsImplicitLiftSplice -> PendingStuff -> TcM (HsExpr GhcRn)
recordPendingSplice :: Name
-> HsImplicitLiftSplice
-> PendingStuff
-> TcM (HsExpr (GhcPass 'Renamed))
recordPendingSplice Name
sp HsImplicitLiftSplice
pn (RnPending IORef [PendingRnSplice]
ref) = do
let untyped_splice :: HsUntypedSplice (GhcPass 'Renamed)
untyped_splice = XXUntypedSplice (GhcPass 'Renamed)
-> HsUntypedSplice (GhcPass 'Renamed)
forall id. XXUntypedSplice id -> HsUntypedSplice id
XUntypedSplice XXUntypedSplice (GhcPass 'Renamed)
HsImplicitLiftSplice
pn
IORef [PendingRnSplice]
-> ([PendingRnSplice] -> [PendingRnSplice]) -> RnM ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> (a -> a) -> m ()
updTcRef IORef [PendingRnSplice]
ref (Name -> HsUntypedSplice (GhcPass 'Renamed) -> PendingRnSplice
PendingRnSplice Name
sp HsUntypedSplice (GhcPass 'Renamed)
untyped_splice PendingRnSplice -> [PendingRnSplice] -> [PendingRnSplice]
forall a. a -> [a] -> [a]
: )
HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (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
sp) HsUntypedSplice (GhcPass 'Renamed)
untyped_splice)
recordPendingSplice Name
sp HsImplicitLiftSplice
pn (PendingStuff
RnPendingTyped) = do
let typed_splice :: HsTypedSplice (GhcPass 'Renamed)
typed_splice = XXTypedSplice (GhcPass 'Renamed)
-> HsTypedSplice (GhcPass 'Renamed)
forall id. XXTypedSplice id -> HsTypedSplice id
XTypedSplice XXTypedSplice (GhcPass 'Renamed)
HsImplicitLiftSplice
pn
HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XTypedSplice (GhcPass 'Renamed)
-> HsTypedSplice (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XTypedSplice p -> HsTypedSplice p -> HsExpr p
HsTypedSplice (Name -> HsTypedSpliceResult
HsTypedSpliceNested Name
sp) HsTypedSplice (GhcPass 'Renamed)
typed_splice)
recordPendingSplice Name
_ HsImplicitLiftSplice
_ (TcPending TcRef [PendingTcSplice]
_ TcRef WantedConstraints
_ QuoteWrapper
_) = String -> TcM (HsExpr (GhcPass 'Renamed))
forall a. HasCallStack => String -> a
panic String
"impossible"
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> LIdP GhcRn
-> XRec GhcPs FastString
-> LHsExpr GhcRn
mkQuasiQuoteExpr :: UntypedSpliceFlavour
-> LIdP (GhcPass 'Renamed)
-> XRec GhcPs FastString
-> LHsExpr (GhcPass 'Renamed)
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour LIdP (GhcPass 'Renamed)
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 (GenLocated SrcSpanAnnN Name -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l LIdP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN Name
quoter) (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)) (IdGhcP 'Renamed)
-> HsExpr (GhcPass 'Renamed)
forall (p :: Pass).
IsPass p =>
LIdP (GhcPass p) -> HsExpr (GhcPass p)
mkHsVar (GenLocated (Anno (IdGhcP 'Renamed)) (IdGhcP 'Renamed)
-> HsExpr (GhcPass 'Renamed))
-> GenLocated (Anno (IdGhcP 'Renamed)) (IdGhcP 'Renamed)
-> HsExpr (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$! LIdP (GhcPass 'Renamed)
GenLocated (Anno (IdGhcP 'Renamed)) (IdGhcP 'Renamed)
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
-> UntypedSpliceFlavour
-> RnM ( HsUntypedSplice GhcRn
, FreeVars)
rnUntypedSplice :: HsUntypedSplice GhcPs
-> UntypedSpliceFlavour
-> TcM (HsUntypedSplice (GhcPass 'Renamed), Uses)
rnUntypedSplice (HsUntypedSpliceExpr XUntypedSpliceExpr GhcPs
_ LHsExpr GhcPs
expr) UntypedSpliceFlavour
flavour
= do { (expr', fvs) <- LHsExpr GhcPs -> TcM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
expr
; return (HsUntypedSpliceExpr (HsUserSpliceExt flavour) expr', fvs) }
rnUntypedSplice (HsQuasiQuote XQuasiQuote GhcPs
_ LIdP GhcPs
quoter XRec GhcPs FastString
quote) UntypedSpliceFlavour
flavour
= do {
; quoter' <- WhatLooking
-> GenLocated SrcSpanAnnN RdrName
-> TcRn (GenLocated SrcSpanAnnN Name)
forall ann.
WhatLooking
-> GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
lookupLocatedOccRn WhatLooking
WL_TermVariable LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
quoter
; let res_name = RdrName -> Name -> WithUserRdr Name
forall a. RdrName -> a -> WithUserRdr a
WithUserRdr (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
quoter) (Name -> WithUserRdr Name)
-> GenLocated SrcSpanAnnN Name
-> GenLocated SrcSpanAnnN (WithUserRdr Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnN Name
quoter'
; checkThLocalNameNoLift res_name
; return (HsQuasiQuote (HsQuasiQuoteExt flavour) quoter' quote, unitFV (unLoc quoter')) }
rnTypedSplice :: HsTypedSplice GhcPs
-> RnM (HsExpr GhcRn, FreeVars)
rnTypedSplice :: HsTypedSplice GhcPs -> RnM (HsExpr (GhcPass 'Renamed), Uses)
rnTypedSplice sp :: HsTypedSplice GhcPs
sp@(HsTypedSpliceExpr XTypedSpliceExpr GhcPs
_ LHsExpr GhcPs
expr)
= ErrCtxtMsg
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (Maybe Name -> HsTypedSplice GhcPs -> ErrCtxtMsg
forall (p :: Pass).
OutputableBndrId p =>
Maybe Name -> HsTypedSplice (GhcPass p) -> ErrCtxtMsg
TypedSpliceCtxt Maybe Name
forall a. Maybe a
Nothing HsTypedSplice GhcPs
sp) (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
{ level <- TcM ThLevel
getThLevel
; case level of
TypedBrack ThLevel
pop_level
-> do { loc <- TcRn SrcSpan
getSrcSpanM
; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
; (e, fvs) <- setThLevel pop_level rn_splice
; return (HsTypedSplice (HsTypedSpliceNested n') (HsTypedSpliceExpr noExtField e), fvs)
}
UntypedBrack {}
-> 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
ThLevel
_ -> 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)
; cur_level <- TcM ThLevel
getThLevel
; (result, fvs1) <- checkNoErrs $ setThLevel (Splice Typed cur_level) 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 (HsTypedSplice HsTypedSpliceTop (HsTypedSpliceExpr noExtField result), fvs1 `plusFV` fvs2) } }
where
rn_splice :: RnM (LHsExpr GhcRn, FreeVars)
rn_splice :: TcM (LHsExpr (GhcPass 'Renamed), Uses)
rn_splice = LHsExpr GhcPs -> TcM (LHsExpr (GhcPass 'Renamed), Uses)
rnLExpr LHsExpr GhcPs
expr
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))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Renamed)))
-> HsUntypedSplice GhcPs
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a z.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult z
-> HsUntypedSplice (GhcPass 'Renamed) -> RnM a)
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
run_expr_splice (UntypedSpliceFlavour,
HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Renamed)))
pend_expr_splice HsUntypedSplice GhcPs
splice
where
pend_expr_splice :: (UntypedSpliceFlavour, HsUntypedSpliceResult (HsExpr GhcRn) -> HsUntypedSplice GhcRn -> RnM (HsExpr GhcRn))
pend_expr_splice :: (UntypedSpliceFlavour,
HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
-> HsUntypedSplice (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Renamed)))
pend_expr_splice
= (UntypedSpliceFlavour
UntypedExpSplice, \HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
x HsUntypedSplice (GhcPass 'Renamed)
y -> HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed)))
-> HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ XUntypedSplice (GhcPass 'Renamed)
-> HsUntypedSplice (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XUntypedSplice p -> HsUntypedSplice p -> HsExpr p
HsUntypedSplice XUntypedSplice (GhcPass 'Renamed)
HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
x HsUntypedSplice (GhcPass 'Renamed)
y)
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))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsType (GhcPass 'Renamed)))
-> HsUntypedSplice GhcPs
-> RnM (HsType (GhcPass 'Renamed), Uses)
forall a z.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult z
-> HsUntypedSplice (GhcPass 'Renamed) -> RnM a)
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsType (GhcPass 'Renamed), Uses)
run_type_splice (UntypedSpliceFlavour,
XSpliceTy (GhcPass 'Renamed)
-> HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsType (GhcPass 'Renamed)))
(UntypedSpliceFlavour,
HsUntypedSpliceResult
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> HsUntypedSplice (GhcPass 'Renamed)
-> RnM (HsType (GhcPass 'Renamed)))
forall {pass}.
(UntypedSpliceFlavour,
XSpliceTy pass
-> HsUntypedSplice pass
-> IOEnv (Env TcGblEnv TcLclEnv) (HsType pass))
pend_type_splice HsUntypedSplice GhcPs
splice
where
pend_type_splice :: (UntypedSpliceFlavour,
XSpliceTy pass
-> HsUntypedSplice pass
-> IOEnv (Env TcGblEnv TcLclEnv) (HsType pass))
pend_type_splice
= ( UntypedSpliceFlavour
UntypedTypeSplice
, \XSpliceTy pass
x HsUntypedSplice pass
y -> HsType pass -> IOEnv (Env TcGblEnv TcLclEnv) (HsType pass)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType pass -> IOEnv (Env TcGblEnv TcLclEnv) (HsType pass))
-> HsType pass -> IOEnv (Env TcGblEnv TcLclEnv) (HsType pass)
forall a b. (a -> b) -> a -> b
$ XSpliceTy pass -> HsUntypedSplice pass -> HsType pass
forall pass. XSpliceTy pass -> HsUntypedSplice pass -> HsType pass
HsSpliceTy XSpliceTy pass
x HsUntypedSplice pass
y)
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))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))
-> HsUntypedSplice (GhcPass 'Renamed)
-> RnM
(HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))))
-> HsUntypedSplice GhcPs
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))),
Uses)
forall a z.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult z
-> HsUntypedSplice (GhcPass 'Renamed) -> RnM a)
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed)
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))),
Uses)
run_pat_splice (UntypedSpliceFlavour,
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))
-> HsUntypedSplice (GhcPass 'Renamed)
-> RnM
(HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs))))
forall {b} {a}.
(UntypedSpliceFlavour,
b -> a -> IOEnv (Env TcGblEnv TcLclEnv) (a, b))
pend_pat_splice HsUntypedSplice GhcPs
splice
where
pend_pat_splice :: (UntypedSpliceFlavour,
b -> a -> IOEnv (Env TcGblEnv TcLclEnv) (a, b))
pend_pat_splice
= (UntypedSpliceFlavour
UntypedPatSplice
, \b
x a
y -> (a, b) -> IOEnv (Env TcGblEnv TcLclEnv) (a, b)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
y, b
x))
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))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsUntypedSplice (GhcPass 'Renamed)
-> RnM
(HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs))))
-> HsUntypedSplice GhcPs
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs))),
Uses)
forall a z.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult z
-> HsUntypedSplice (GhcPass 'Renamed) -> RnM a)
-> HsUntypedSplice GhcPs
-> RnM (a, Uses)
rnUntypedSpliceGen HsUntypedSplice (GhcPass 'Renamed)
-> RnM
((HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs))),
Uses)
run_ty_pat_splice (UntypedSpliceFlavour,
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsUntypedSplice (GhcPass 'Renamed)
-> RnM
(HsUntypedSplice (GhcPass 'Renamed),
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (HsType GhcPs))))
forall {b} {a}.
(UntypedSpliceFlavour,
b -> a -> IOEnv (Env TcGblEnv TcLclEnv) (a, b))
pend_ty_pat_splice HsUntypedSplice GhcPs
splice
where
pend_ty_pat_splice :: (UntypedSpliceFlavour,
b -> a -> IOEnv (Env TcGblEnv TcLclEnv) (a, b))
pend_ty_pat_splice
= (UntypedSpliceFlavour
UntypedTypeSplice
, \b
x a
y -> (a, b) -> IOEnv (Env TcGblEnv TcLclEnv) (a, b)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
y, b
x))
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))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult (ZonkAny 0)
-> HsUntypedSplice (GhcPass 'Renamed)
-> RnM (SpliceDecl (GhcPass 'Renamed)))
-> HsUntypedSplice GhcPs
-> RnM (SpliceDecl (GhcPass 'Renamed), Uses)
forall a z.
(HsUntypedSplice (GhcPass 'Renamed) -> RnM (a, Uses))
-> (UntypedSpliceFlavour,
HsUntypedSpliceResult z
-> HsUntypedSplice (GhcPass 'Renamed) -> RnM 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 (UntypedSpliceFlavour,
HsUntypedSpliceResult (ZonkAny 0)
-> HsUntypedSplice (GhcPass 'Renamed)
-> RnM (SpliceDecl (GhcPass 'Renamed)))
pend_decl_splice HsUntypedSplice GhcPs
splice
where
pend_decl_splice :: (UntypedSpliceFlavour,
HsUntypedSpliceResult (ZonkAny 0)
-> HsUntypedSplice (GhcPass 'Renamed)
-> RnM (SpliceDecl (GhcPass 'Renamed)))
pend_decl_splice
= ( UntypedSpliceFlavour
UntypedDeclSplice
, \HsUntypedSpliceResult (ZonkAny 0)
_ HsUntypedSplice (GhcPass 'Renamed)
y -> SpliceDecl (GhcPass 'Renamed)
-> RnM (SpliceDecl (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpliceDecl (GhcPass 'Renamed)
-> RnM (SpliceDecl (GhcPass 'Renamed)))
-> SpliceDecl (GhcPass 'Renamed)
-> RnM (SpliceDecl (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ 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)
y) 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
; cur_level <- TcM ThLevel
getThLevel
; (rn_splice, fvs) <- checkNoErrs $
setThLevel (Splice Untyped cur_level) $
rnUntypedSplice splice UntypedDeclSplice
; 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 -> Int -> SDoc -> SDoc
nest Int
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
"======>", Int -> SDoc -> SDoc
nest Int
2 SDoc
gen ]
in SDoc -> Int -> 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)
Int
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, Set ThLevelIndex, ThLevel))
getCurrentAndBindLevel Name
name
; case mb_local_use of {
Maybe (TopLevelFlag, Set ThLevelIndex, ThLevel)
Nothing -> () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () ;
Just (TopLevelFlag
top_lvl, Set ThLevelIndex
bind_lvl, ThLevel
use_lvl) ->
do { let use_lvl_idx :: ThLevelIndex
use_lvl_idx = ThLevel -> ThLevelIndex
thLevelIndex ThLevel
use_lvl
; 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
<+> Set ThLevelIndex -> SDoc
forall a. Outputable a => a -> SDoc
ppr Set ThLevelIndex
bind_lvl
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThLevel
use_lvl
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThLevel
use_lvl)
; dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl use_lvl_idx name } } }
checkThLocalNameWithLift :: LIdOccP GhcRn -> RnM (HsExpr GhcRn)
checkThLocalNameWithLift :: LIdOccP (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
checkThLocalNameWithLift = Bool
-> LIdOccP (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
checkThLocalName Bool
True
checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM ()
checkThLocalNameNoLift :: LIdOccP (GhcPass 'Renamed) -> RnM ()
checkThLocalNameNoLift LIdOccP (GhcPass 'Renamed)
name = Bool
-> LIdOccP (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
checkThLocalName Bool
False LIdOccP (GhcPass 'Renamed)
name TcM (HsExpr (GhcPass 'Renamed)) -> RnM () -> RnM ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM (HsExpr GhcRn)
checkThLocalName :: Bool
-> LIdOccP (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
checkThLocalName Bool
allow_lifting LIdOccP (GhcPass 'Renamed)
name_var
| RdrName -> Bool
isExact (WithUserRdr Name -> RdrName
userRdrName (GenLocated SrcSpanAnnN (WithUserRdr Name) -> WithUserRdr Name
forall l e. GenLocated l e -> e
unLoc LIdOccP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN (WithUserRdr Name)
name_var)) Bool -> Bool -> Bool
|| RdrName -> Bool
isOrig (WithUserRdr Name -> RdrName
userRdrName (GenLocated SrcSpanAnnN (WithUserRdr Name) -> WithUserRdr Name
forall l e. GenLocated l e -> e
unLoc LIdOccP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN (WithUserRdr Name)
name_var))
= HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar (GhcPass 'Renamed)
-> LIdOccP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField LIdOccP (GhcPass 'Renamed)
name_var)
| Name -> Bool
isUnboundName Name
name
= HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar (GhcPass 'Renamed)
-> LIdOccP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField LIdOccP (GhcPass 'Renamed)
name_var)
| Name -> Bool
isWiredInName Name
name
= HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar (GhcPass 'Renamed)
-> LIdOccP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField LIdOccP (GhcPass 'Renamed)
name_var)
| Bool
otherwise
= do {
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, Set ThLevelIndex, ThLevel))
getCurrentAndBindLevel Name
name
; case mb_local_use of {
Maybe (TopLevelFlag, Set ThLevelIndex, ThLevel)
Nothing -> HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar (GhcPass 'Renamed)
-> LIdOccP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField LIdOccP (GhcPass 'Renamed)
name_var) ;
Just (TopLevelFlag
top_lvl, Set ThLevelIndex
bind_lvl, ThLevel
use_lvl) ->
do { let use_lvl_idx :: ThLevelIndex
use_lvl_idx = ThLevel -> ThLevelIndex
thLevelIndex ThLevel
use_lvl
; cur_mod <- TcGblEnv -> Module
forall t. ContainsModule t => t -> Module
extractModule (TcGblEnv -> Module)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let is_local
| Just Module
mod <- Name -> Maybe Module
nameModule_maybe Name
name = Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
cur_mod
| Bool
otherwise = Bool
True
; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl <+> ppr use_lvl)
; dflags <- getDynFlags
; env <- getGlobalRdrEnv
; let mgre = GlobalRdrEnv -> Name -> Maybe (GlobalRdrEltX GREInfo)
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name GlobalRdrEnv
env Name
name
; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var } } }
where
name :: Name
name = GenLocated SrcSpanAnnN (WithUserRdr Name) -> Name
forall a. NamedThing a => a -> Name
getName LIdOccP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN (WithUserRdr Name)
name_var
checkCrossLevelLifting :: DynFlags
-> LevelCheckReason
-> TopLevelFlag
-> Bool
-> Bool
-> Set.Set ThLevelIndex
-> ThLevel
-> ThLevelIndex
-> LIdOccP GhcRn
-> TcM (HsExpr GhcRn)
checkCrossLevelLifting :: DynFlags
-> LevelCheckReason
-> TopLevelFlag
-> Bool
-> Bool
-> Set ThLevelIndex
-> ThLevel
-> ThLevelIndex
-> LIdOccP (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Renamed))
checkCrossLevelLifting DynFlags
dflags LevelCheckReason
reason TopLevelFlag
top_lvl Bool
is_local Bool
allow_lifting Set ThLevelIndex
bind_lvl ThLevel
use_lvl ThLevelIndex
use_lvl_idx LIdOccP (GhcPass 'Renamed)
name_var
| ThLevelIndex
use_lvl_idx ThLevelIndex -> Set ThLevelIndex -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ThLevelIndex
bind_lvl = HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar (GhcPass 'Renamed)
-> LIdOccP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField LIdOccP (GhcPass 'Renamed)
name_var)
| Bool -> Bool
not Bool
is_local
, Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitStagePersistence DynFlags
dflags = HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar (GhcPass 'Renamed)
-> LIdOccP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField LIdOccP (GhcPass 'Renamed)
name_var)
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
, Bool
is_local
, (ThLevelIndex -> Bool) -> [ThLevelIndex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ThLevelIndex
use_lvl_idx ThLevelIndex -> ThLevelIndex -> Bool
forall a. Ord a => a -> a -> Bool
>=) (Set ThLevelIndex -> [ThLevelIndex]
forall a. Set a -> [a]
Set.toList Set ThLevelIndex
bind_lvl)
, Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitStagePersistence DynFlags
dflags = Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
name) (Name -> RnM ()
keepAlive Name
name) RnM ()
-> TcM (HsExpr (GhcPass 'Renamed))
-> TcM (HsExpr (GhcPass 'Renamed))
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar (GhcPass 'Renamed)
-> LIdOccP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField LIdOccP (GhcPass 'Renamed)
name_var)
| Brack ThLevel
_ PendingStuff
pending <- ThLevel
use_lvl
, (ThLevelIndex -> Bool) -> [ThLevelIndex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ThLevelIndex
use_lvl_idx ThLevelIndex -> ThLevelIndex -> Bool
forall a. Ord a => a -> a -> Bool
>=) (Set ThLevelIndex -> [ThLevelIndex]
forall a. Set a -> [a]
Set.toList Set ThLevelIndex
bind_lvl)
, Bool
allow_lifting
= do
let mgre :: Maybe (GlobalRdrEltX GREInfo)
mgre = case LevelCheckReason
reason of
LevelCheckSplice Name
_ Maybe (GlobalRdrEltX GREInfo)
gre -> Maybe (GlobalRdrEltX GREInfo)
gre
LevelCheckReason
_ -> Maybe (GlobalRdrEltX GREInfo)
forall a. Maybe a
Nothing
(splice_name :: Name) <- GenLocated SrcSpanAnnN RdrName -> RnM Name
newLocalBndrRn (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA RdrName
unqualSplice)
let pend_splice :: HsImplicitLiftSplice
pend_splice = Set ThLevelIndex
-> ThLevelIndex
-> Maybe (GlobalRdrEltX GREInfo)
-> LIdOccP (GhcPass 'Renamed)
-> HsImplicitLiftSplice
HsImplicitLiftSplice Set ThLevelIndex
bind_lvl ThLevelIndex
use_lvl_idx Maybe (GlobalRdrEltX GREInfo)
mgre LIdOccP (GhcPass 'Renamed)
name_var
addDetailedDiagnostic (TcRnImplicitLift name)
recordPendingSplice splice_name pend_splice pending
| Bool
otherwise = TcRnMessage -> RnM ()
addErrTc (LevelCheckReason
-> Set ThLevelIndex
-> ThLevelIndex
-> Maybe ErrorItem
-> DiagnosticReason
-> TcRnMessage
TcRnBadlyLevelled LevelCheckReason
reason Set ThLevelIndex
bind_lvl ThLevelIndex
use_lvl_idx Maybe ErrorItem
forall a. Maybe a
Nothing DiagnosticReason
ErrorWithoutFlag ) RnM ()
-> TcM (HsExpr (GhcPass 'Renamed))
-> TcM (HsExpr (GhcPass 'Renamed))
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HsExpr (GhcPass 'Renamed) -> TcM (HsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar (GhcPass 'Renamed)
-> LIdOccP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField LIdOccP (GhcPass 'Renamed)
name_var)
where
name :: Name
name = GenLocated SrcSpanAnnN (WithUserRdr Name) -> Name
forall a. NamedThing a => a -> Name
getName LIdOccP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN (WithUserRdr Name)
name_var
checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex -> Name -> TcM ()
checkCrossLevelLiftingTy :: DynFlags
-> TopLevelFlag
-> Set ThLevelIndex
-> ThLevel
-> ThLevelIndex
-> Name
-> RnM ()
checkCrossLevelLiftingTy DynFlags
dflags TopLevelFlag
top_lvl Set ThLevelIndex
bind_lvl ThLevel
_use_lvl ThLevelIndex
use_lvl_idx Name
name
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
, Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitStagePersistence DynFlags
dflags
= () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| ThLevelIndex
use_lvl_idx ThLevelIndex -> Set ThLevelIndex -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Set ThLevelIndex
bind_lvl
= TcRnMessage -> RnM ()
addDiagnostic (TcRnMessage -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$ Name -> Set ThLevelIndex -> ThLevelIndex -> TcRnMessage
TcRnBadlyLevelledType Name
name Set ThLevelIndex
bind_lvl ThLevelIndex
use_lvl_idx
| Bool
otherwise
= () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()