{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiWayIf #-}

module GHC.Rename.Splice (
        rnTopSpliceDecls,

        -- Typed splices
        rnTypedSplice,
        -- Untyped splices
        rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceTyPat, rnSpliceDecl,

        -- Brackets
        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, 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
import qualified Data.Set as Set

{-
************************************************************************
*                                                                      *
        Template Haskell brackets
*                                                                      *
************************************************************************
-}

-- Check that -XTemplateHaskellQuotes is enabled and available
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

{-

Note [Untyped quotes in typed splices and vice versa]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this typed splice
   $$(f [| x |])

Is there anything wrong with that /typed/ splice containing an /untyped/
quote [| x |]?   One could ask the same about an /untyped/ slice containing a
/typed/ quote.

In fact, both are fine (#24190). Presumably f's type looks something like:
   f :: Q Expr -> Code Q Int

It is pretty hard for `f` to use its (untyped code) argument to build a typed
syntax tree, but not impossible:
* `f` could use `unsafeCodeCoerce :: Q Exp -> Code Q a`
* `f` could just perform case analysis on the tree

But in the end all that matters is that in $$( e ), the expression `e` has the
right type.  It doesn't matter how `e` is built.  To put it another way, the
untyped quote `[| x |]` could also be written `varE 'x`, which is an ordinary
expression.

Moreover the ticked variable, 'x :: Name, is itself treated as an untyped quote;
but it is a perfectly fine sub-expression to have in a typed splice.

(Historical note: GHC used to unnecessarily  check that a typed quote only
occurred in a typed splice: #24190.)

-}

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

         -- Check for nested brackets
       ; 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 ()
               -- See Note [Untyped quotes in typed splices and vice versa]
           ; RunSplice TcRef [ForeignRef (Q ())]
_    ->
               -- See Note [RunSplice ThLevel] in GHC.Tc.Types.
               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
           }

         -- Brackets are desugared to code that mentions the TH package
       ; 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

         -- Check for nested brackets
       ; 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 ()
               -- See Note [Untyped quotes in typed splices and vice versa]
           ; RunSplice TcRef [ForeignRef (Q ())]
_    ->
               -- See Note [RunSplice ThLevel] in GHC.Tc.Types.
               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
           }

         -- Brackets are desugared to code that mentions the TH package
       ; recordThUse

       ; traceRn "Renaming untyped TH bracket" empty
       ; ps_var <- newMutVar []
       ; (body', fvs_e) <-
         -- See Note [Rebindable syntax and Template Haskell]
         unsetXOptM LangExt.RebindableSyntax $
         setThLevel (Brack cur_level (RnPendingUntyped 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)
       ; if flg then checkThLocalNameNoLift 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 }
                          -- The emptyDUs is so that we just collect uses for this
                          -- group alone in the call to rnSrcDecls below
       ; (tcg_env, group') <- setGblEnv new_gbl_env $
                              rnSrcDecls group

              -- Discard the tcg_env; it contains only extra info about fixity
        ; 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"


-- | Ensure that we are not using a term-level name in a type-level namespace
-- or vice-versa. Throws a 'TcRnIncorrectNameSpace' error if there is a problem.
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

{-
*********************************************************
*                                                      *
                Splices
*                                                      *
*********************************************************

Note [Free variables of typed splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider renaming this:
        f = ...
        h = ...$(thing "f")...

where the splice is a *typed* splice.  The splice can expand into
literally anything, so when we do dependency analysis we must assume
that it might mention 'f'.  So we simply treat all locally-defined
names as mentioned by any splice.  This is terribly brutal, but I
don't see what else to do.  For example, it'll mean that every
locally-defined thing will appear to be used, so no unused-binding
warnings.  But if we miss the dependency, then we might typecheck 'h'
before 'f', and that will crash the type checker because 'f' isn't in
scope.

Currently, I'm not treating a splice as also mentioning every import,
which is a bit inconsistent -- but there are a lot of them.  We might
thereby get some bogus unused-import warnings, but we won't crash the
type checker.  Not very satisfactory really.

Note [Renamer errors]
~~~~~~~~~~~~~~~~~~~~~
It's important to wrap renamer calls in checkNoErrs, because the
renamer does not fail for out of scope variables etc. Instead it
returns a bogus term/type, so that it can report more than one error.
We don't want the type checker to see these bogus unbound variables.
-}

rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars))
                                                    -- Outside brackets, run splice
                   -> (Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, a))
                                                   -- Inside brackets, make it pending
                   -> 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
    { level <- TcM ThLevel
getThLevel
    ; case level of
        Brack ThLevel
_ 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 ThLevel
pop_level (RnPendingUntyped 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
-> 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) }

        ThLevel
_ ->  do { HsUntypedSplice GhcPs -> RnM ()
checkTopSpliceAllowed HsUntypedSplice GhcPs
splice
                 ; cur_level <- TcM ThLevel
getThLevel
                 ; (splice', fvs1) <- checkNoErrs $
                                      setThLevel (Splice Untyped cur_level) $
                                      rnUntypedSplice splice
                   -- checkNoErrs: don't attempt to run the splice if
                   -- renaming it failed; otherwise we get a cascade of
                   -- errors from e.g. unbound variables
                 ; (result, fvs2) <- run_splice splice'
                 ; return (result, fvs1 `plusFV` fvs2) } }


-- Nested splices are fine without TemplateHaskell because they
-- are not executed until the top-level splice is run.
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)

------------------

-- | Returns the result of running a splice and the modFinalizers collected
-- during the execution.
--
-- See Note [Delaying modFinalizers in untyped splices].
runRnSplice :: UntypedSpliceFlavour
            -> (LHsExpr GhcTc -> TcRn res)
            -> (res -> SDoc)    -- How to pretty-print res
                                -- Usually just ppr, but not for [Decl]
            -> 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

             -- Typecheck the expression
       ; meta_exp_ty   <- tcMetaTy meta_ty_name
       ; zonked_q_expr <- zonkTopLExpr =<<
                            tcTopSpliceExpr Untyped
                              (tcCheckPolyExpr the_expr meta_exp_ty)

             -- Run the expression
       ; 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

------------------
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
-- Return the expression (quoter "...quote...")
-- which is what we must run in a quasi-quote
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
-- The RdrName for a SplicePointName.  See GHC.Hs.Expr
-- Note [Lifecycle of an untyped splice, and PendingRnSplice]
-- We use "spn" (which is arbitrary) because it is brief but grepable-for.
unqualSplice :: RdrName
unqualSplice = OccName -> RdrName
mkRdrUnqual (FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"spn"))

rnUntypedSplice :: HsUntypedSplice GhcPs -> RnM (HsUntypedSplice GhcRn, FreeVars)
-- Not exported...used for all
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  { -- Rename the quoter; akin to the HsVar case of rnExpr
        ; quoter' <- WhatLooking -> RdrName -> RnM Name
lookupOccRn WhatLooking
WL_TermVariable IdP GhcPs
RdrName
quoter
        ; this_mod <- getModule
        ; when (nameIsLocalOrFrom this_mod quoter') $
          checkThLocalNameNoLift quoter'

        ; return (HsQuasiQuote ext quoter' quote, unitFV quoter') }

---------------------
rnTypedSplice :: LHsExpr GhcPs -- Typed splice expression
              -> 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
    { level <- TcM ThLevel
getThLevel
    ; case level of
        Brack ThLevel
pop_level PendingStuff
RnPendingTyped
          -> ThLevel
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
-> RnM (HsExpr (GhcPass 'Renamed), Uses)
forall a. ThLevel -> TcM a -> TcM a
setThLevel ThLevel
pop_level RnM (HsExpr (GhcPass 'Renamed), Uses)
rn_splice

        Brack ThLevel
_ (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

        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
                  -- checkNoErrs: don't attempt to run the splice if
                  -- renaming it failed; otherwise we get a cascade of
                  -- errors from e.g. unbound variables

                  -- Run typed splice later, in the type checker
                  -- Ugh!  See Note [Free variables of typed splices] above
                ; 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
         -- The renamer allocates a splice-point name to every typed splice
         -- (incl the top level ones for which it will not ultimately be used)
         ; 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

           -- Run the splice here, see Note [Running splices in the Renamer]
           ; (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
                -- mod_finalizers: See Note [Delaying modFinalizers in untyped splices].

           -- Rename the expanded expression
           ; (L l expr_rn, fvs) <- checkNoErrs (rnLExpr expr_ps)

           -- rn_splice :: HsUntypedSplice GhcRn is the original TH expression,
           --                                       before expansion
           -- expr_ps   :: LHsExpr GhcPs is the result of running the splice
           -- expr_rn   :: HsExpr GhcRn is the result of renaming ps_expr
           ; 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

{- Note [Running splices in the Renamer]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Splices used to be run in the typechecker, which led to (#4364). Since the
renamer must decide which expressions depend on which others, and it cannot
reliably do this for arbitrary splices, we used to conservatively say that
splices depend on all other expressions in scope. Unfortunately, this led to
the problem of cyclic type declarations seen in (#4364). Instead, by
running splices in the renamer, we side-step the problem of determining
dependencies: by the time the dependency analysis happens, any splices have
already been run, and expression dependencies can be determined as usual.

However, see (#9813), for an example where we would like to run splices
*after* performing dependency analysis (that is, after renaming). It would be
desirable to typecheck "non-splicy" expressions (those expressions that do not
contain splices directly or via dependence on an expression that does) before
"splicy" expressions, such that types/expressions within the same declaration
group would be available to `reify` calls, for example consider the following:

> module M where
>   data D = C
>   f = 1
>   g = $(mapM reify ['f, 'D, ''C] ...)

Compilation of this example fails since D/C/f are not in the type environment
and thus cannot be reified as they have not been typechecked by the time the
splice is renamed and thus run.

These requirements are at odds: we do not want to run splices in the renamer as
we wish to first determine dependencies and typecheck certain expressions,
making them available to reify, but cannot accurately determine dependencies
without running splices in the renamer!

Indeed, the conclusion of (#9813) was that it is not worth the complexity
to try and
 a) implement and maintain the code for renaming/typechecking non-splicy
    expressions before splicy expressions,
 b) explain to TH users which expressions are/not available to reify at any
    given point.

-}

{- Note [Rebindable syntax and Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When processing Template Haskell quotes with Rebindable Syntax (RS) enabled,
there are two possibilities: apply the RS rules to the quotes or don't.

One might expect that with {-# LANGUAGE RebindableSyntax #-} at the top of a
module, any 'if' expression would end up being turned into a call to whatever
'ifThenElse' function is in scope, regardless of whether the said if expression
appears in "normal" Haskell code or in a TH quote. This however comes with its
problems. Consider the following code:

  {-# LANGUAGE TemplateHaskell, RebindableSyntax #-}

  module X where

  import Prelude ( Monad(..), Bool(..), print, ($) )
  import Language.Haskell.TH.Syntax

  $( do stuff <- [| if True then 10 else 15 |]
        runIO $ print stuff
        return [] )

If we apply the RS rules, then GHC would complain about not having suitable
fromInteger/ifThenElse functions in scope. But this quote is just a bit of
Haskell syntax that has yet to be used, or, to put it differently, placed
(spliced) in some context where the said functions might be available. More
generally, untyped TH quotes are meant to work with yet-unbound identifiers.
This tends to show that untyped TH and Rebindable Syntax overall don't play
well together. Users still have the option to splice "normal" if expressions
into modules where RS is enabled, to turn them into applications of
an 'ifThenElse' function of their choice.

Typed TH (TTH) quotes, on the other hand, come with different constraints. They
don't quite have this "delayed" nature: we typecheck them while processing
them, and TTH users expect RS to Just Work in their quotes, exactly like it does
outside of the quotes. There, we do not have to accept unbound identifiers and
we can apply the RS rules both in the typechecking and desugaring of the quotes
without triggering surprising/bad behaviour for users. For instance, the
following code is expected to be rejected (because of the lack of suitable
'fromInteger'/'ifThenElse' functions in scope):

  {-# LANGUAGE TemplateHaskell, RebindableSyntax #-}

  module X where

  import Prelude ( Monad(..), Bool(..), print, ($) )
  import Language.Haskell.TH.Syntax

  $$( do stuff <- [|| if True then 10 else 15 ||]
         runIO $ print stuff
         return [] )

The conclusion is that even if RS is enabled for a given module, GHC disables it
when processing untyped TH quotes from that module, to avoid the aforementioned
problems, but keeps it on while processing typed TH quotes.

This note and approach originated in #18102.

-}

{- Note [Delaying modFinalizers in untyped splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When splices run in the renamer, 'reify' does not have access to the local
type environment (#11832, [1]).

For instance, in

> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |])

'reify' cannot find @x@, because the local type environment is not yet
populated. To address this, we allow 'reify' execution to be deferred with
'addModFinalizer'.

> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print)
                    [| return () |]
                )

The finalizer is run with the local type environment when type checking is
complete.

Since the local type environment is not available in the renamer, we annotate
the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where
@e@ is the result of splicing and @finalizers@ are the finalizers that have been
collected during evaluation of the splice [3]. In our example,

> HsLet
>   (x = e)
>   (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print]
>                          (HsSplicedExpr $ return ())
>   )

When the typechecker finds the annotation, it inserts the finalizers in the
global environment and exposes the current local environment to them [4, 5, 6].

> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print]

References:

[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify
[2] 'rnSpliceExpr'
[3] 'GHC.Tc.Gen.Splice.qAddModFinalizer'
[4] 'GHC.Tc.Gen.Expr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))
[5] 'GHC.Tc.Gen.HsType.tcHsType' ('HsSpliceTy' ('HsSpliced' ...))
[6] 'GHC.Tc.Gen.Pat.tc_pat' ('SplicePat' ('HsSpliced' ...))

-}

----------------------
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 }
                                         -- checkNoErrs: see Note [Renamer errors]

             -- See Note [Delaying modFinalizers in untyped splices].
           ; return ( HsSpliceTy (HsUntypedSpliceTop (ThModFinalizers mod_finalizers)
                                                     (mb_paren hs_ty3))
                                 rn_splice
                    , fvs
                    ) }
              -- Wrap the result of the splice in parens so that we don't
              -- lose the outermost location set by runQuasiQuote (#7918)

    -- Wrap a non-atomic result in HsParTy parens;
    -- but not if it's atomic to avoid double parens for operators
    -- This is to account for, say  foo :: $(blah) -> Int
    -- when we want $(blah) to expand to (this -> that), with parens.
    -- Sadly, it's awkward add precisely the correct parens, because
    -- that depends on the context.
    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

{- Note [Partial Type Splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Partial Type Signatures are partially supported in TH type splices: only
anonymous wild cards are allowed.

  -- ToDo: SLPJ says: I don't understand all this

Normally, named wild cards are collected before renaming a (partial) type
signature. However, TH type splices are run during renaming, i.e. after the
initial traversal, leading to out of scope errors for named wild cards. We
can't just extend the initial traversal to collect the named wild cards in TH
type splices, as we'd need to expand them, which is supposed to happen only
once, during renaming.

Similarly, the extra-constraints wild card is handled right before renaming
too, and is therefore also not supported in a TH type splice. Another reason
to forbid extra-constraints wild cards in TH type splices is that a single
signature can contain many TH type splices, whereas it mustn't contain more
than one extra-constraints wild card. Enforcing would this be hard the way
things are currently organised.

Anonymous wild cards pose no problem, because they start out without names and
are given names during renaming. These names are collected right after
renaming. The names generated for anonymous wild cards in TH type splices will
thus be collected as well.

For more details about renaming wild cards, see GHC.Rename.HsType.rnHsSigWcType

Note that partial type signatures are fully supported in TH declaration
splices, e.g.:

     [d| foo :: _ => _
         foo x y = x == y |]

This is because in this case, the partial type signature can be treated as a
whole signature, instead of as an arbitrary type.

-}


----------------------
-- | Rename a splice pattern. See Note [rnSplicePat]
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)) -- Pat splice is nested and thus simply renamed

    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
             -- See Note [Delaying modFinalizers in untyped splices].
           ; 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) }
              -- Wrap the result of the quasi-quoter in parens so that we don't
              -- lose the outermost location set by runQuasiQuote (#7918)

-- | Rename a splice type pattern. Much the same as `rnSplicePat`, but works with LHsType instead of LPat
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)) -- HsType splice is nested and thus simply renamed

    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
             -- See Note [Delaying modFinalizers in untyped splices].
           ; 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) }
              -- Wrap the result of the quasi-quoter in parens so that we don't
              -- lose the outermost location set by runQuasiQuote (#7918)

----------------------
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)
-- Declaration splice at the very top level of the module
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
           -- As always, be sure to checkNoErrs above lest we end up with
           -- holes making it to typechecking, hence #12584.
           --
           -- Note that we cannot call checkNoErrs for the whole duration
           -- of rnTopSpliceDecls. The reason is that checkNoErrs changes
           -- the local environment to temporarily contain a new
           -- reference to store errors, and add_mod_finalizers would
           -- cause this reference to be stored after checkNoErrs finishes.
           -- This is checked by test TH_finalizer.
         ; 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)

     -- Adds finalizers to the global environment instead of delaying them
     -- to the type checker.
     --
     -- Declaration splices do not have an interesting local environment so
     -- there is no point in delaying them.
     --
     -- See Note [Delaying modFinalizers in untyped splices].
     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


{-
Note [rnSplicePat]
~~~~~~~~~~~~~~~~~~
Renaming a pattern splice is a bit tricky, because we need the variables
bound in the pattern to be in scope in the RHS of the pattern. This scope
management is effectively done by using continuation-passing style in
GHC.Rename.Pat, through the CpsRn monad. We don't wish to be in that monad here
(it would create import cycles and generally conflict with renaming other
splices), so we really want to return a (Pat GhcPs) -- the result of
running the splice -- which can then be further renamed in GHC.Rename.Pat, in
the CpsRn monad.

The problem is that if we're renaming a splice within a bracket, we
*don't* want to run the splice now. We really do just want to rename
it to an HsUntypedSplice Name. Of course, then we can't know what variables
are bound within the splice. So we accept any unbound variables and
rename them again when the bracket is spliced in.  If a variable is brought
into scope by a pattern splice all is fine.  If it is not then an error is
reported.

In any case, when we're done in rnSplicePat, we'll have both the renamed
splice, and either a Pat RdrName and ThModFinalizers (the result of running a
top-level splice) or a splice point name. Thus, rnSplicePat returns both
HsUntypedSplice GhcRn, and HsUntypedSpliceResult (Pat GhcPs) -- which models
the existence of either the result of running the splice (HsUntypedSpliceTop),
or its splice point name if nested (HsUntypedSpliceNested)
-}

-- | The splice data to be logged
data SpliceInfo
  = SpliceInfo
    { SpliceInfo -> String
spliceDescription  :: String
    , SpliceInfo -> Maybe (LHsExpr (GhcPass 'Renamed))
spliceSource       :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls
                                                  --        added by addTopDecls
    , SpliceInfo -> Bool
spliceIsDecl       :: Bool    -- True <=> put the generate code in a file
                                    --          when -dth-dec-file is on
    , SpliceInfo -> SDoc
spliceGenerated    :: SDoc
    }
        -- Note that 'spliceSource' is *renamed* but not *typechecked*
        -- Reason (a) less typechecking crap
        --        (b) data constructors after type checking have been
        --            changed to their *wrappers*, and that makes them
        --            print always fully qualified

-- | outputs splice information for 2 flags which have different output formats:
-- `-ddump-splices` and `-dth-dec-file`
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 -- Raw material for -dth-dec-file
        logger <- getLogger
        liftIO $ putDumpFileMaybe logger Opt_D_th_dec_file "" FormatHaskell (spliceCodeDoc loc)
  where
    -- `-ddump-splices`
    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)

    -- `-dth-dec-file`
    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   -- Do not report two errors for
  = () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()            --   $(not_in_scope args)

  | 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 () ;  -- Not a locally-bound thing
             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
        -- We don't check the well levelledness of name here.
        -- this would break test for #20969
        --
        -- Consequently there is no check&restiction for top level splices.
        -- But it's annoying anyway.
        --
        -- Therefore checkCrossLevelLiftingTy shouldn't assume anything
        -- about bind_lvl and use_lvl relation.
        --
        ; 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 } } }

-- | Check whether we are allowed to use a Name in this context (for TH purposes)
-- In the case of a level incorrect program, attempt to fix it by using
-- a Lift constraint.
checkThLocalNameWithLift :: Name -> RnM ()
checkThLocalNameWithLift :: Name -> RnM ()
checkThLocalNameWithLift = Bool -> Name -> RnM ()
checkThLocalName Bool
True

-- | Check whether we are allowed to use a Name in this context (for TH purposes)
-- In the case of a level incorrect program, do not attempt to fix it by using
-- a Lift constraint.
checkThLocalNameNoLift :: Name -> RnM ()
checkThLocalNameNoLift :: Name -> RnM ()
checkThLocalNameNoLift = Bool -> Name -> RnM ()
checkThLocalName Bool
False

checkThLocalName :: Bool -> Name -> RnM ()
checkThLocalName :: Bool -> Name -> RnM ()
checkThLocalName Bool
allow_lifting Name
name
  | Name -> Bool
isUnboundName Name
name   -- Do not report two errors for
  = () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()            --   $(not_in_scope args)

  | Name -> Bool
isWiredInName Name
name
  = () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  | 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 -> () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () ;  -- Not a locally-bound thing
             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 } } }

--------------------------------------
checkCrossLevelLifting :: DynFlags
                       -> LevelCheckReason
                       -> TopLevelFlag
                       -> Bool
                       -> Bool
                       -> Set.Set ThLevelIndex
                       -> ThLevel
                       -> ThLevelIndex
                       -> Name -> TcM ()
checkCrossLevelLifting :: DynFlags
-> LevelCheckReason
-> TopLevelFlag
-> Bool
-> Bool
-> Set ThLevelIndex
-> ThLevel
-> ThLevelIndex
-> Name
-> RnM ()
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 Name
name
  -- 1. If name is in-scope, at the correct level.
  | ThLevelIndex
use_lvl_idx ThLevelIndex -> Set ThLevelIndex -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ThLevelIndex
bind_lvl = () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  -- 2. Name is imported with -XImplicitStagePersistence
  | Bool -> Bool
not Bool
is_local
  , 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 ()
  -- 3. Name is top-level, with -XImplicitStagePersistence, and needs
  -- to be persisted into the future.
  | 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)
  -- 4. Name is in an untyped bracket, and lifting is allowed.
  | Brack ThLevel
_ (RnPendingUntyped IORef [PendingRnSplice]
ps_var) <- ThLevel
use_lvl   -- Only for untyped brackets
  , (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
      dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      check_cross_level_lifting dflags top_lvl name ps_var
  -- 5. For a typed bracket, these checks happen again later on (checkThLocalId)
  -- In the future we should do all the level checks here.
  | Brack ThLevel
_ PendingStuff
RnPendingTyped <- ThLevel
use_lvl  -- Lift for typed brackets is inserted later.
  , (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)
    = () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  -- Otherwise, we have a level error, report.
  | Bool
otherwise = TcRnMessage -> RnM ()
addErrTc (LevelCheckReason -> Set ThLevelIndex -> ThLevelIndex -> TcRnMessage
TcRnBadlyLevelled LevelCheckReason
reason Set ThLevelIndex
bind_lvl ThLevelIndex
use_lvl_idx)

check_cross_level_lifting :: DynFlags -> TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
check_cross_level_lifting :: DynFlags
-> TopLevelFlag -> Name -> IORef [PendingRnSplice] -> RnM ()
check_cross_level_lifting DynFlags
dflags TopLevelFlag
top_lvl Name
name IORef [PendingRnSplice]
ps_var
  | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
  , Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitStagePersistence DynFlags
dflags
        -- Top-level identifiers in this module,
        -- (which have External Names)
        -- are just like the imported case:
        -- no need for the 'lifting' treatment
        -- E.g.  this is fine:
        --   f x = x
        --   g y = [| f 3 |]
  = Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
name) (Name -> RnM ()
keepAlive Name
name)
    -- See Note [Keeping things alive for Template Haskell]

  | Bool
otherwise
  =     -- Nested identifiers, such as 'x' in
        -- E.g. \x -> [| h x |]
        -- We must behave as if the reference to x was
        --      h $(lift x)
        -- We use 'x' itself as the SplicePointName, used by
        -- the desugarer to stitch it all back together.
        -- If 'x' occurs many times we may get many identical
        -- bindings of the same SplicePointName, but that doesn't
        -- matter, although it's a mite untidy.
    do  { String -> SDoc -> RnM ()
traceRn String
"checkCrossLevelLifting" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)

          -- Construct the (lift x) expression
        ; 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

          -- Warning for implicit lift (#17804)
        ; ([ErrCtxtMsg] -> TcRnMessage) -> RnM ()
addDetailedDiagnostic (Name -> [ErrCtxtMsg] -> TcRnMessage
TcRnImplicitLift Name
name)

          -- Update the pending splices
        ; 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) }

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 ()

  -- There is no liftType (yet), so we could error, or more conservatively, just warn.
  --
  -- For now, we check here for both untyped and typed splices, as we don't create splices.

  -- Can also happen for negative cases
  -- See comment in checkThLocalTyName:
  | 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 ()

{-
Note [Keeping things alive for Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  f x = x+1
  g y = [| f 3 |]

Here 'f' is referred to from inside the bracket, which turns into data
and mentions only f's *name*, not 'f' itself. So we need some other
way to keep 'f' alive, lest it get dropped as dead code.  That's what
keepAlive does. It puts it in the keep-alive set, which subsequently
ensures that 'f' stays as a top level binding.

This must be done by the renamer, not the type checker (as of old),
because the type checker doesn't typecheck the body of untyped
brackets (#8540).

A thing can have a bind_lvl of outerLevel, but have an internal name:
   foo = [d| op = 3
             bop = op + 1 |]
Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is
bound inside a bracket.  That is because we don't even record
binding levels for top-level things; the binding levels are in the
LocalRdrEnv.

So the occurrence of 'op' in the rhs of 'bop' looks a bit like a
cross-stage thing, but it isn't really.  And in fact we never need
to do anything here for top-level bound things, so all is fine, if
a bit hacky.

For these chaps (which have Internal Names) we don't want to put
them in the keep-alive set.

Note [Quoting names]
~~~~~~~~~~~~~~~~~~~~
A quoted name 'n is a bit like a quoted expression [| n |], except that we
have no cross-level lifting (c.f. GHC.Tc.Gen.Expr.thBrackId).  So, after incrementing
the use-level to account for the brackets, the cases are:

        bind > use                      Error
        bind = use+1                    OK
        bind < use
                Imported things         OK
                Top-level things        OK
                Non-top-level           Error

where 'use' is the binding level of the 'n quote. (So inside the implied
bracket the level would be use+1.)

Examples:

  f 'map        -- OK; also for top-level defns of this module

  \x. f 'x      -- Not ok (bind = 1, use = 1)
                -- (whereas \x. f [| x |] might have been ok, by
                --                               cross-level lifting

  \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)

  [| \x. $(f 'x) |]     -- OK (bind = 2, use = 1)
-}