{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module RnSplice (
        rnTopSpliceDecls,
        rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
        rnBracket,
        checkThLocalName
        , traceSplice, SpliceInfo(..)
  ) where

#include "HsVersions.h"

import GhcPrelude

import Name
import NameSet
import GHC.Hs
import RdrName
import TcRnMonad

import RnEnv
import RnUtils          ( HsDocContext(..), newLocalBndrRn )
import RnUnbound        ( isUnboundName )
import RnSource         ( rnSrcDecls, findSplice )
import RnPat            ( rnPat )
import BasicTypes       ( TopLevelFlag, isTopLevel, SourceText(..) )
import Outputable
import Module
import SrcLoc
import RnTypes          ( rnLHsType )

import Control.Monad    ( unless, when )

import {-# SOURCE #-} RnExpr   ( rnLExpr )

import TcEnv            ( checkWellStaged )
import THNames          ( liftName )

import DynFlags
import FastString
import ErrUtils         ( dumpIfSet_dyn_printer )
import TcEnv            ( tcMetaTy )
import Hooks
import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName
                        , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )

import {-# SOURCE #-} TcExpr   ( tcPolyExpr )
import {-# SOURCE #-} TcSplice
    ( runMetaD
    , runMetaE
    , runMetaP
    , runMetaT
    , tcTopSpliceExpr
    )

import TcHsSyn

import GHCi.RemoteTypes ( ForeignRef )
import qualified Language.Haskell.TH as TH (Q)

import qualified GHC.LanguageExtensions as LangExt

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

rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnBracket HsExpr GhcPs
e HsBracket GhcPs
br_body
  = MsgDoc
-> RnM (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsBracket GhcPs -> MsgDoc
quotationCtxtDoc HsBracket GhcPs
br_body) (RnM (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars))
-> RnM (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
    do { -- Check that -XTemplateHaskellQuotes is enabled and available
         Bool
thQuotesEnabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TemplateHaskellQuotes
       ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
thQuotesEnabled (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
           MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. MsgDoc -> TcRn a
failWith ( [MsgDoc] -> MsgDoc
vcat
                      [ String -> MsgDoc
text String
"Syntax error on" MsgDoc -> MsgDoc -> MsgDoc
<+> HsExpr GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsExpr GhcPs
e
                      , String -> MsgDoc
text (String
"Perhaps you intended to use TemplateHaskell"
                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" or TemplateHaskellQuotes") ] )

         -- Check for nested brackets
       ; ThStage
cur_stage <- TcM ThStage
getStage
       ; case ThStage
cur_stage of
           { Splice SpliceType
Typed   -> Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc (HsBracket GhcPs -> Bool
forall id. HsBracket id -> Bool
isTypedBracket HsBracket GhcPs
br_body)
                                       MsgDoc
illegalUntypedBracket
           ; Splice SpliceType
Untyped -> Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc (Bool -> Bool
not (HsBracket GhcPs -> Bool
forall id. HsBracket id -> Bool
isTypedBracket HsBracket GhcPs
br_body))
                                       MsgDoc
illegalTypedBracket
           ; RunSplice TcRef [ForeignRef (Q ())]
_    ->
               -- See Note [RunSplice ThLevel] in "TcRnTypes".
               String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rnBracket: Renaming bracket when running a splice"
                        (HsExpr GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsExpr GhcPs
e)
           ; ThStage
Comp           -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ; Brack {}       -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. MsgDoc -> TcRn a
failWithTc MsgDoc
illegalBracket
           }

         -- Brackets are desugared to code that mentions the TH package
       ; IOEnv (Env TcGblEnv TcLclEnv) ()
recordThUse

       ; case HsBracket GhcPs -> Bool
forall id. HsBracket id -> Bool
isTypedBracket HsBracket GhcPs
br_body of
            Bool
True  -> do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"Renaming typed TH bracket" MsgDoc
empty
                        ; (HsBracket GhcRn
body', FreeVars
fvs_e) <-
                          ThStage
-> TcM (HsBracket GhcRn, FreeVars)
-> TcM (HsBracket GhcRn, FreeVars)
forall a. ThStage -> TcM a -> TcM a
setStage (ThStage -> PendingStuff -> ThStage
Brack ThStage
cur_stage PendingStuff
RnPendingTyped) (TcM (HsBracket GhcRn, FreeVars)
 -> TcM (HsBracket GhcRn, FreeVars))
-> TcM (HsBracket GhcRn, FreeVars)
-> TcM (HsBracket GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                                   ThStage -> HsBracket GhcPs -> TcM (HsBracket GhcRn, FreeVars)
rn_bracket ThStage
cur_stage HsBracket GhcPs
br_body
                        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBracket GhcRn -> HsBracket GhcRn -> HsExpr GhcRn
forall p. XBracket p -> HsBracket p -> HsExpr p
HsBracket XBracket GhcRn
NoExtField
noExtField HsBracket GhcRn
body', FreeVars
fvs_e) }

            Bool
False -> do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"Renaming untyped TH bracket" MsgDoc
empty
                        ; IORef [PendingRnSplice]
ps_var <- [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef [PendingRnSplice])
forall a env. a -> IOEnv env (IORef a)
newMutVar []
                        ; (HsBracket GhcRn
body', FreeVars
fvs_e) <-
                          ThStage
-> TcM (HsBracket GhcRn, FreeVars)
-> TcM (HsBracket GhcRn, FreeVars)
forall a. ThStage -> TcM a -> TcM a
setStage (ThStage -> PendingStuff -> ThStage
Brack ThStage
cur_stage (IORef [PendingRnSplice] -> PendingStuff
RnPendingUntyped IORef [PendingRnSplice]
ps_var)) (TcM (HsBracket GhcRn, FreeVars)
 -> TcM (HsBracket GhcRn, FreeVars))
-> TcM (HsBracket GhcRn, FreeVars)
-> TcM (HsBracket GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                                   ThStage -> HsBracket GhcPs -> TcM (HsBracket GhcRn, FreeVars)
rn_bracket ThStage
cur_stage HsBracket GhcPs
br_body
                        ; [PendingRnSplice]
pendings <- IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingRnSplice]
forall a env. IORef a -> IOEnv env a
readMutVar IORef [PendingRnSplice]
ps_var
                        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XRnBracketOut GhcRn
-> HsBracket GhcRn -> [PendingRnSplice] -> HsExpr GhcRn
forall p.
XRnBracketOut p -> HsBracket GhcRn -> [PendingRnSplice] -> HsExpr p
HsRnBracketOut XRnBracketOut GhcRn
NoExtField
noExtField HsBracket GhcRn
body' [PendingRnSplice]
pendings, FreeVars
fvs_e) }
       }

rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
rn_bracket :: ThStage -> HsBracket GhcPs -> TcM (HsBracket GhcRn, FreeVars)
rn_bracket ThStage
outer_stage br :: HsBracket GhcPs
br@(VarBr XVarBr GhcPs
x Bool
flg IdP GhcPs
rdr_name)
  = do { Name
name <- RdrName -> RnM Name
lookupOccRn RdrName
IdP GhcPs
rdr_name
       ; Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule

       ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
flg Bool -> Bool -> Bool
&& Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
             -- Type variables can be quoted in TH. See #5721.
                 do { Maybe (TopLevelFlag, ThLevel)
mb_bind_lvl <- Name -> RnM (Maybe (TopLevelFlag, ThLevel))
lookupLocalOccThLvl_maybe Name
name
                    ; case Maybe (TopLevelFlag, ThLevel)
mb_bind_lvl of
                        { Maybe (TopLevelFlag, ThLevel)
Nothing -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()      -- Can happen for data constructors,
                                                    -- but nothing needs to be done for them

                        ; Just (TopLevelFlag
top_lvl, ThLevel
bind_lvl)  -- See Note [Quoting names]
                             | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
                             -> Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
name) (Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
keepAlive Name
name)
                             | Bool
otherwise
                             -> do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn_bracket VarBr"
                                      (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name MsgDoc -> MsgDoc -> MsgDoc
<+> ThLevel -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ThLevel
bind_lvl
                                                MsgDoc -> MsgDoc -> MsgDoc
<+> ThStage -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ThStage
outer_stage)
                                   ; Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc (ThStage -> ThLevel
thLevel ThStage
outer_stage ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ ThLevel
1 ThLevel -> ThLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ThLevel
bind_lvl)
                                             (HsBracket GhcPs -> MsgDoc
quotedNameStageErr HsBracket GhcPs
br) }
                        }
                    }
       ; (HsBracket GhcRn, FreeVars) -> TcM (HsBracket GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVarBr GhcRn -> Bool -> IdP GhcRn -> HsBracket GhcRn
forall p. XVarBr p -> Bool -> IdP p -> HsBracket p
VarBr XVarBr GhcPs
XVarBr GhcRn
x Bool
flg Name
IdP GhcRn
name, Name -> FreeVars
unitFV Name
name) }

rn_bracket ThStage
_ (ExpBr XExpBr GhcPs
x LHsExpr GhcPs
e) = do { (LHsExpr GhcRn
e', FreeVars
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
e
                            ; (HsBracket GhcRn, FreeVars) -> TcM (HsBracket GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExpBr GhcRn -> LHsExpr GhcRn -> HsBracket GhcRn
forall p. XExpBr p -> LHsExpr p -> HsBracket p
ExpBr XExpBr GhcPs
XExpBr GhcRn
x LHsExpr GhcRn
e', FreeVars
fvs) }

rn_bracket ThStage
_ (PatBr XPatBr GhcPs
x LPat GhcPs
p)
  = HsMatchContext Name
-> LPat GhcPs
-> (LPat GhcRn -> TcM (HsBracket GhcRn, FreeVars))
-> TcM (HsBracket GhcRn, FreeVars)
forall a.
HsMatchContext Name
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPat HsMatchContext Name
forall id. HsMatchContext id
ThPatQuote LPat GhcPs
p ((LPat GhcRn -> TcM (HsBracket GhcRn, FreeVars))
 -> TcM (HsBracket GhcRn, FreeVars))
-> (LPat GhcRn -> TcM (HsBracket GhcRn, FreeVars))
-> TcM (HsBracket GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ LPat GhcRn
p' -> (HsBracket GhcRn, FreeVars) -> TcM (HsBracket GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPatBr GhcRn -> LPat GhcRn -> HsBracket GhcRn
forall p. XPatBr p -> LPat p -> HsBracket p
PatBr XPatBr GhcPs
XPatBr GhcRn
x LPat GhcRn
p', FreeVars
emptyFVs)

rn_bracket ThStage
_ (TypBr XTypBr GhcPs
x LHsType GhcPs
t) = do { (LHsType GhcRn
t', FreeVars
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
TypBrCtx LHsType GhcPs
t
                              ; (HsBracket GhcRn, FreeVars) -> TcM (HsBracket GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTypBr GhcRn -> LHsType GhcRn -> HsBracket GhcRn
forall p. XTypBr p -> LHsType p -> HsBracket p
TypBr XTypBr GhcPs
XTypBr GhcRn
x LHsType GhcRn
t', FreeVars
fvs) }

rn_bracket ThStage
_ (DecBrL XDecBrL GhcPs
x [LHsDecl GhcPs]
decls)
  = do { HsGroup GhcPs
group <- [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls [LHsDecl GhcPs]
decls
       ; TcGblEnv
gbl_env  <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; let new_gbl_env :: TcGblEnv
new_gbl_env = TcGblEnv
gbl_env { tcg_dus :: DefUses
tcg_dus = DefUses
emptyDUs }
                          -- The emptyDUs is so that we just collect uses for this
                          -- group alone in the call to rnSrcDecls below
       ; (TcGblEnv
tcg_env, HsGroup GhcRn
group') <- TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup GhcRn)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup GhcRn)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
new_gbl_env (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup GhcRn)
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup GhcRn))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup GhcRn)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$
                              HsGroup GhcPs -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup GhcRn)
rnSrcDecls HsGroup GhcPs
group

              -- Discard the tcg_env; it contains only extra info about fixity
        ; String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn_bracket dec" (DefUses -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env) MsgDoc -> MsgDoc -> MsgDoc
$$
                   FreeVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (DefUses -> FreeVars
duUses (TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env)))
        ; (HsBracket GhcRn, FreeVars) -> TcM (HsBracket GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XDecBrG GhcRn -> HsGroup GhcRn -> HsBracket GhcRn
forall p. XDecBrG p -> HsGroup p -> HsBracket p
DecBrG XDecBrG GhcRn
XDecBrL GhcPs
x HsGroup GhcRn
group', DefUses -> FreeVars
duUses (TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env)) }
  where
    groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
    groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls [LHsDecl GhcPs]
decls
      = do { (HsGroup GhcPs
group, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
mb_splice) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
decls
           ; case Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
mb_splice of
           { Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
Nothing -> HsGroup GhcPs -> RnM (HsGroup GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return HsGroup GhcPs
group
           ; Just (SpliceDecl GhcPs
splice, [LHsDecl GhcPs]
rest) ->
               do { HsGroup GhcPs
group' <- [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls [LHsDecl GhcPs]
rest
                  ; let group'' :: HsGroup GhcPs
group'' = HsGroup GhcPs -> HsGroup GhcPs -> HsGroup GhcPs
forall (p :: Pass).
HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p)
appendGroups HsGroup GhcPs
group HsGroup GhcPs
group'
                  ; HsGroup GhcPs -> RnM (HsGroup GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return HsGroup GhcPs
group'' { hs_splcds :: [LSpliceDecl GhcPs]
hs_splcds = SrcSpanLess (LSpliceDecl GhcPs) -> LSpliceDecl GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LSpliceDecl GhcPs)
SpliceDecl GhcPs
splice LSpliceDecl GhcPs -> [LSpliceDecl GhcPs] -> [LSpliceDecl GhcPs]
forall a. a -> [a] -> [a]
: HsGroup GhcPs -> [LSpliceDecl GhcPs]
forall p. HsGroup p -> [LSpliceDecl p]
hs_splcds HsGroup GhcPs
group' }
                  }
           }}

rn_bracket ThStage
_ (DecBrG {}) = String -> TcM (HsBracket GhcRn, FreeVars)
forall a. String -> a
panic String
"rn_bracket: unexpected DecBrG"

rn_bracket ThStage
_ (TExpBr XTExpBr GhcPs
x LHsExpr GhcPs
e) = do { (LHsExpr GhcRn
e', FreeVars
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
e
                               ; (HsBracket GhcRn, FreeVars) -> TcM (HsBracket GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTExpBr GhcRn -> LHsExpr GhcRn -> HsBracket GhcRn
forall p. XTExpBr p -> LHsExpr p -> HsBracket p
TExpBr XTExpBr GhcPs
XTExpBr GhcRn
x LHsExpr GhcRn
e', FreeVars
fvs) }

rn_bracket ThStage
_ (XBracket XXBracket GhcPs
nec) = NoExtCon -> TcM (HsBracket GhcRn, FreeVars)
forall a. NoExtCon -> a
noExtCon XXBracket GhcPs
NoExtCon
nec

quotationCtxtDoc :: HsBracket GhcPs -> SDoc
quotationCtxtDoc :: HsBracket GhcPs -> MsgDoc
quotationCtxtDoc HsBracket GhcPs
br_body
  = MsgDoc -> ThLevel -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"In the Template Haskell quotation")
         ThLevel
2 (HsBracket GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsBracket GhcPs
br_body)

illegalBracket :: SDoc
illegalBracket :: MsgDoc
illegalBracket =
    String -> MsgDoc
text String
"Template Haskell brackets cannot be nested" MsgDoc -> MsgDoc -> MsgDoc
<+>
    String -> MsgDoc
text String
"(without intervening splices)"

illegalTypedBracket :: SDoc
illegalTypedBracket :: MsgDoc
illegalTypedBracket =
    String -> MsgDoc
text String
"Typed brackets may only appear in typed splices."

illegalUntypedBracket :: SDoc
illegalUntypedBracket :: MsgDoc
illegalUntypedBracket =
    String -> MsgDoc
text String
"Untyped brackets may only appear in untyped splices."

quotedNameStageErr :: HsBracket GhcPs -> SDoc
quotedNameStageErr :: HsBracket GhcPs -> MsgDoc
quotedNameStageErr HsBracket GhcPs
br
  = [MsgDoc] -> MsgDoc
sep [ String -> MsgDoc
text String
"Stage error: the non-top-level quoted name" MsgDoc -> MsgDoc -> MsgDoc
<+> HsBracket GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsBracket GhcPs
br
        , String -> MsgDoc
text String
"must be used at the same stage at which it is bound" ]


{-
*********************************************************
*                                                      *
                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.
-}

rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars))
                                            -- Outside brackets, run splice
            -> (HsSplice GhcRn -> (PendingRnSplice, a))
                                            -- Inside brackets, make it pending
            -> HsSplice GhcPs
            -> RnM (a, FreeVars)
rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars))
-> (HsSplice GhcRn -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, FreeVars)
rnSpliceGen HsSplice GhcRn -> RnM (a, FreeVars)
run_splice HsSplice GhcRn -> (PendingRnSplice, a)
pend_splice HsSplice GhcPs
splice
  = MsgDoc -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsSplice GhcPs -> MsgDoc
spliceCtxt HsSplice GhcPs
splice) (RnM (a, FreeVars) -> RnM (a, FreeVars))
-> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ do
    { ThStage
stage <- TcM ThStage
getStage
    ; case ThStage
stage of
        Brack ThStage
pop_stage PendingStuff
RnPendingTyped
          -> do { Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc Bool
is_typed_splice MsgDoc
illegalUntypedSplice
                ; (HsSplice GhcRn
splice', FreeVars
fvs) <- ThStage
-> TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall a. ThStage -> TcM a -> TcM a
setStage ThStage
pop_stage (TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars))
-> TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                                    HsSplice GhcPs -> TcM (HsSplice GhcRn, FreeVars)
rnSplice HsSplice GhcPs
splice
                ; let (PendingRnSplice
_pending_splice, a
result) = HsSplice GhcRn -> (PendingRnSplice, a)
pend_splice HsSplice GhcRn
splice'
                ; (a, FreeVars) -> RnM (a, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, FreeVars
fvs) }

        Brack ThStage
pop_stage (RnPendingUntyped IORef [PendingRnSplice]
ps_var)
          -> do { Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc (Bool -> Bool
not Bool
is_typed_splice) MsgDoc
illegalTypedSplice
                ; (HsSplice GhcRn
splice', FreeVars
fvs) <- ThStage
-> TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall a. ThStage -> TcM a -> TcM a
setStage ThStage
pop_stage (TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars))
-> TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                                    HsSplice GhcPs -> TcM (HsSplice GhcRn, FreeVars)
rnSplice HsSplice GhcPs
splice
                ; let (PendingRnSplice
pending_splice, a
result) = HsSplice GhcRn -> (PendingRnSplice, a)
pend_splice HsSplice GhcRn
splice'
                ; [PendingRnSplice]
ps <- IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingRnSplice]
forall a env. IORef a -> IOEnv env a
readMutVar IORef [PendingRnSplice]
ps_var
                ; IORef [PendingRnSplice]
-> [PendingRnSplice] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef [PendingRnSplice]
ps_var (PendingRnSplice
pending_splice PendingRnSplice -> [PendingRnSplice] -> [PendingRnSplice]
forall a. a -> [a] -> [a]
: [PendingRnSplice]
ps)
                ; (a, FreeVars) -> RnM (a, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, FreeVars
fvs) }

        ThStage
_ ->  do { (HsSplice GhcRn
splice', FreeVars
fvs1) <- TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall r. TcM r -> TcM r
checkNoErrs (TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars))
-> TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                                      ThStage
-> TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
splice_type) (TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars))
-> TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                                      HsSplice GhcPs -> TcM (HsSplice GhcRn, FreeVars)
rnSplice HsSplice GhcPs
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
                 ; (a
result, FreeVars
fvs2) <- HsSplice GhcRn -> RnM (a, FreeVars)
run_splice HsSplice GhcRn
splice'
                 ; (a, FreeVars) -> RnM (a, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) } }
   where
     is_typed_splice :: Bool
is_typed_splice = HsSplice GhcPs -> Bool
forall id. HsSplice id -> Bool
isTypedSplice HsSplice GhcPs
splice
     splice_type :: SpliceType
splice_type = if Bool
is_typed_splice
                   then SpliceType
Typed
                   else SpliceType
Untyped

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

-- | 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]
            -> HsSplice GhcRn   -- Always untyped
            -> TcRn (res, [ForeignRef (TH.Q ())])
runRnSplice :: UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> MsgDoc)
-> HsSplice GhcRn
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
flavour LHsExpr GhcTc -> TcRn res
run_meta res -> MsgDoc
ppr_res HsSplice GhcRn
splice
  = do { HsSplice GhcRn
splice' <- (Hooks -> Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)))
-> (HsSplice GhcRn -> RnM (HsSplice GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (HsSplice GhcRn -> RnM (HsSplice GhcRn))
forall (f :: * -> *) a.
(Functor f, HasDynFlags f) =>
(Hooks -> Maybe a) -> a -> f a
getHooked Hooks -> Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))
runRnSpliceHook HsSplice GhcRn -> RnM (HsSplice GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return IOEnv
  (Env TcGblEnv TcLclEnv) (HsSplice GhcRn -> RnM (HsSplice GhcRn))
-> ((HsSplice GhcRn -> RnM (HsSplice GhcRn))
    -> RnM (HsSplice GhcRn))
-> RnM (HsSplice GhcRn)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((HsSplice GhcRn -> RnM (HsSplice GhcRn))
-> HsSplice GhcRn -> RnM (HsSplice GhcRn)
forall a b. (a -> b) -> a -> b
$ HsSplice GhcRn
splice)

       ; let the_expr :: LHsExpr GhcRn
the_expr = case HsSplice GhcRn
splice' of
                HsUntypedSplice XUntypedSplice GhcRn
_ SpliceDecoration
_ IdP GhcRn
_ LHsExpr GhcRn
e   ->  LHsExpr GhcRn
e
                HsQuasiQuote XQuasiQuote GhcRn
_ IdP GhcRn
_ IdP GhcRn
q SrcSpan
qs FastString
str -> UntypedSpliceFlavour
-> Name -> SrcSpan -> FastString -> LHsExpr GhcRn
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour Name
IdP GhcRn
q SrcSpan
qs FastString
str
                HsTypedSplice {}          -> String -> MsgDoc -> LHsExpr GhcRn
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"runRnSplice" (HsSplice GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcRn
splice)
                HsSpliced {}              -> String -> MsgDoc -> LHsExpr GhcRn
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"runRnSplice" (HsSplice GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcRn
splice)
                HsSplicedT {}             -> String -> MsgDoc -> LHsExpr GhcRn
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"runRnSplice" (HsSplice GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcRn
splice)
                XSplice XXSplice GhcRn
nec               -> NoExtCon -> LHsExpr GhcRn
forall a. NoExtCon -> a
noExtCon XXSplice GhcRn
NoExtCon
nec

             -- Typecheck the expression
       ; Type
meta_exp_ty   <- Name -> TcM Type
tcMetaTy Name
meta_ty_name
       ; LHsExpr GhcTc
zonked_q_expr <- LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkTopLExpr (LHsExpr GhcTc -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                            SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
tcTopSpliceExpr SpliceType
Untyped
                              (LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcPolyExpr LHsExpr GhcRn
the_expr Type
meta_exp_ty)

             -- Run the expression
       ; TcRef [ForeignRef (Q ())]
mod_finalizers_ref <- [ForeignRef (Q ())]
-> TcRnIf TcGblEnv TcLclEnv (TcRef [ForeignRef (Q ())])
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef []
       ; res
result <- ThStage -> TcRn res -> TcRn res
forall a. ThStage -> TcM a -> TcM a
setStage (TcRef [ForeignRef (Q ())] -> ThStage
RunSplice TcRef [ForeignRef (Q ())]
mod_finalizers_ref) (TcRn res -> TcRn res) -> TcRn res -> TcRn res
forall a b. (a -> b) -> a -> b
$
                     LHsExpr GhcTc -> TcRn res
run_meta LHsExpr GhcTc
zonked_q_expr
       ; [ForeignRef (Q ())]
mod_finalizers <- TcRef [ForeignRef (Q ())]
-> TcRnIf TcGblEnv TcLclEnv [ForeignRef (Q ())]
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef [ForeignRef (Q ())]
mod_finalizers_ref
       ; SpliceInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceSplice (SpliceInfo :: String -> Maybe (LHsExpr GhcRn) -> Bool -> MsgDoc -> SpliceInfo
SpliceInfo { spliceDescription :: String
spliceDescription = String
what
                                 , spliceIsDecl :: Bool
spliceIsDecl      = Bool
is_decl
                                 , spliceSource :: Maybe (LHsExpr GhcRn)
spliceSource      = LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)
forall a. a -> Maybe a
Just LHsExpr GhcRn
the_expr
                                 , spliceGenerated :: MsgDoc
spliceGenerated   = res -> MsgDoc
ppr_res res
result })

       ; (res, [ForeignRef (Q ())]) -> TcRn (res, [ForeignRef (Q ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (res
result, [ForeignRef (Q ())]
mod_finalizers) }

  where
    meta_ty_name :: Name
meta_ty_name = case UntypedSpliceFlavour
flavour of
                       UntypedSpliceFlavour
UntypedExpSplice  -> Name
expQTyConName
                       UntypedSpliceFlavour
UntypedPatSplice  -> Name
patQTyConName
                       UntypedSpliceFlavour
UntypedTypeSplice -> Name
typeQTyConName
                       UntypedSpliceFlavour
UntypedDeclSplice -> Name
decsQTyConName
    what :: String
what = case UntypedSpliceFlavour
flavour of
                  UntypedSpliceFlavour
UntypedExpSplice  -> String
"expression"
                  UntypedSpliceFlavour
UntypedPatSplice  -> String
"pattern"
                  UntypedSpliceFlavour
UntypedTypeSplice -> String
"type"
                  UntypedSpliceFlavour
UntypedDeclSplice -> String
"declarations"
    is_decl :: Bool
is_decl = case UntypedSpliceFlavour
flavour of
                 UntypedSpliceFlavour
UntypedDeclSplice -> Bool
True
                 UntypedSpliceFlavour
_                 -> Bool
False

------------------
makePending :: UntypedSpliceFlavour
            -> HsSplice GhcRn
            -> PendingRnSplice
makePending :: UntypedSpliceFlavour -> HsSplice GhcRn -> PendingRnSplice
makePending UntypedSpliceFlavour
flavour (HsUntypedSplice XUntypedSplice GhcRn
_ SpliceDecoration
_ IdP GhcRn
n LHsExpr GhcRn
e)
  = UntypedSpliceFlavour -> Name -> LHsExpr GhcRn -> PendingRnSplice
PendingRnSplice UntypedSpliceFlavour
flavour Name
IdP GhcRn
n LHsExpr GhcRn
e
makePending UntypedSpliceFlavour
flavour (HsQuasiQuote XQuasiQuote GhcRn
_ IdP GhcRn
n IdP GhcRn
quoter SrcSpan
q_span FastString
quote)
  = UntypedSpliceFlavour -> Name -> LHsExpr GhcRn -> PendingRnSplice
PendingRnSplice UntypedSpliceFlavour
flavour Name
IdP GhcRn
n (UntypedSpliceFlavour
-> Name -> SrcSpan -> FastString -> LHsExpr GhcRn
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour Name
IdP GhcRn
quoter SrcSpan
q_span FastString
quote)
makePending UntypedSpliceFlavour
_ splice :: HsSplice GhcRn
splice@(HsTypedSplice {})
  = String -> MsgDoc -> PendingRnSplice
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"makePending" (HsSplice GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcRn
splice)
makePending UntypedSpliceFlavour
_ splice :: HsSplice GhcRn
splice@(HsSpliced {})
  = String -> MsgDoc -> PendingRnSplice
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"makePending" (HsSplice GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcRn
splice)
makePending UntypedSpliceFlavour
_ splice :: HsSplice GhcRn
splice@(HsSplicedT {})
  = String -> MsgDoc -> PendingRnSplice
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"makePending" (HsSplice GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcRn
splice)
makePending UntypedSpliceFlavour
_ (XSplice XXSplice GhcRn
nec)
  = NoExtCon -> PendingRnSplice
forall a. NoExtCon -> a
noExtCon XXSplice GhcRn
NoExtCon
nec

------------------
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
                 -> LHsExpr GhcRn
-- Return the expression (quoter "...quote...")
-- which is what we must run in a quasi-quote
mkQuasiQuoteExpr :: UntypedSpliceFlavour
-> Name -> SrcSpan -> FastString -> LHsExpr GhcRn
mkQuasiQuoteExpr UntypedSpliceFlavour
flavour Name
quoter SrcSpan
q_span FastString
quote
  = SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
q_span (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn)
-> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
NoExtField
noExtField (SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
q_span
              (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn)
-> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
NoExtField
noExtField (SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
q_span (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
q_span Name
SrcSpanLess (Located Name)
quote_selector)))
                                 LHsExpr GhcRn
quoterExpr)
                     LHsExpr GhcRn
quoteExpr
  where
    quoterExpr :: LHsExpr GhcRn
quoterExpr = SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
q_span (HsExpr GhcRn -> LHsExpr GhcRn) -> HsExpr GhcRn -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$! XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (Located Name -> HsExpr GhcRn) -> Located Name -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$! (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
q_span Name
SrcSpanLess (Located Name)
quoter)
    quoteExpr :: LHsExpr GhcRn
quoteExpr  = SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
q_span (HsExpr GhcRn -> LHsExpr GhcRn) -> HsExpr GhcRn -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$! XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
NoExtField
noExtField (HsLit GhcRn -> HsExpr GhcRn) -> HsLit GhcRn -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$! XHsString GhcRn -> FastString -> HsLit GhcRn
forall x. XHsString x -> FastString -> HsLit x
HsString SourceText
XHsString GhcRn
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

---------------------
rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)
-- Not exported...used for all
rnSplice :: HsSplice GhcPs -> TcM (HsSplice GhcRn, FreeVars)
rnSplice (HsTypedSplice XTypedSplice GhcPs
x SpliceDecoration
hasParen IdP GhcPs
splice_name LHsExpr GhcPs
expr)
  = do  { SrcSpan
loc  <- TcRn SrcSpan
getSrcSpanM
        ; Name
n' <- Located RdrName -> RnM Name
newLocalBndrRn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located RdrName)
IdP GhcPs
splice_name)
        ; (LHsExpr GhcRn
expr', FreeVars
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
        ; (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTypedSplice GhcRn
-> SpliceDecoration -> IdP GhcRn -> LHsExpr GhcRn -> HsSplice GhcRn
forall id.
XTypedSplice id
-> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id
HsTypedSplice XTypedSplice GhcPs
XTypedSplice GhcRn
x SpliceDecoration
hasParen Name
IdP GhcRn
n' LHsExpr GhcRn
expr', FreeVars
fvs) }

rnSplice (HsUntypedSplice XUntypedSplice GhcPs
x SpliceDecoration
hasParen IdP GhcPs
splice_name LHsExpr GhcPs
expr)
  = do  { SrcSpan
loc  <- TcRn SrcSpan
getSrcSpanM
        ; Name
n' <- Located RdrName -> RnM Name
newLocalBndrRn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located RdrName)
IdP GhcPs
splice_name)
        ; (LHsExpr GhcRn
expr', FreeVars
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
        ; (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XUntypedSplice GhcRn
-> SpliceDecoration -> IdP GhcRn -> LHsExpr GhcRn -> HsSplice GhcRn
forall id.
XUntypedSplice id
-> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id
HsUntypedSplice XUntypedSplice GhcPs
XUntypedSplice GhcRn
x SpliceDecoration
hasParen Name
IdP GhcRn
n' LHsExpr GhcRn
expr', FreeVars
fvs) }

rnSplice (HsQuasiQuote XQuasiQuote GhcPs
x IdP GhcPs
splice_name IdP GhcPs
quoter SrcSpan
q_loc FastString
quote)
  = do  { SrcSpan
loc  <- TcRn SrcSpan
getSrcSpanM
        ; Name
splice_name' <- Located RdrName -> RnM Name
newLocalBndrRn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located RdrName)
IdP GhcPs
splice_name)

          -- Rename the quoter; akin to the HsVar case of rnExpr
        ; Name
quoter' <- RdrName -> RnM Name
lookupOccRn RdrName
IdP GhcPs
quoter
        ; Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
        ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
quoter') (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
          Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkThLocalName Name
quoter'

        ; (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XQuasiQuote GhcRn
-> IdP GhcRn
-> IdP GhcRn
-> SrcSpan
-> FastString
-> HsSplice GhcRn
forall id.
XQuasiQuote id
-> IdP id -> IdP id -> SrcSpan -> FastString -> HsSplice id
HsQuasiQuote XQuasiQuote GhcPs
XQuasiQuote GhcRn
x Name
IdP GhcRn
splice_name' Name
IdP GhcRn
quoter' SrcSpan
q_loc FastString
quote
                                                             , Name -> FreeVars
unitFV Name
quoter') }

rnSplice splice :: HsSplice GhcPs
splice@(HsSpliced {}) = String -> MsgDoc -> TcM (HsSplice GhcRn, FreeVars)
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rnSplice" (HsSplice GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcPs
splice)
rnSplice splice :: HsSplice GhcPs
splice@(HsSplicedT {}) = String -> MsgDoc -> TcM (HsSplice GhcRn, FreeVars)
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rnSplice" (HsSplice GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcPs
splice)
rnSplice        (XSplice XXSplice GhcPs
nec)   = NoExtCon -> TcM (HsSplice GhcRn, FreeVars)
forall a. NoExtCon -> a
noExtCon XXSplice GhcPs
NoExtCon
nec

---------------------
rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSpliceExpr HsSplice GhcPs
splice
  = (HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars))
-> (HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn))
-> HsSplice GhcPs
-> RnM (HsExpr GhcRn, FreeVars)
forall a.
(HsSplice GhcRn -> RnM (a, FreeVars))
-> (HsSplice GhcRn -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, FreeVars)
rnSpliceGen HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
run_expr_splice HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
pend_expr_splice HsSplice GhcPs
splice
  where
    pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
    pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
pend_expr_splice HsSplice GhcRn
rn_splice
        = (UntypedSpliceFlavour -> HsSplice GhcRn -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedExpSplice HsSplice GhcRn
rn_splice, XSpliceE GhcRn -> HsSplice GhcRn -> HsExpr GhcRn
forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE XSpliceE GhcRn
NoExtField
noExtField HsSplice GhcRn
rn_splice)

    run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
    run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
run_expr_splice HsSplice GhcRn
rn_splice
      | HsSplice GhcRn -> Bool
forall id. HsSplice id -> Bool
isTypedSplice HsSplice GhcRn
rn_splice   -- Run it later, in the type checker
      = do {  -- Ugh!  See Note [Splices] above
             String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnSpliceExpr: typed expression splice" MsgDoc
empty
           ; LocalRdrEnv
lcl_rdr <- RnM LocalRdrEnv
getLocalRdrEnv
           ; GlobalRdrEnv
gbl_rdr <- TcRn GlobalRdrEnv
getGlobalRdrEnv
           ; let gbl_names :: FreeVars
gbl_names = [Name] -> FreeVars
mkNameSet [GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre | GlobalRdrElt
gre <- GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts GlobalRdrEnv
gbl_rdr
                                                     , GlobalRdrElt -> Bool
isLocalGRE GlobalRdrElt
gre]
                 lcl_names :: FreeVars
lcl_names = [Name] -> FreeVars
mkNameSet (LocalRdrEnv -> [Name]
localRdrEnvElts LocalRdrEnv
lcl_rdr)

           ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSpliceE GhcRn -> HsSplice GhcRn -> HsExpr GhcRn
forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE XSpliceE GhcRn
NoExtField
noExtField HsSplice GhcRn
rn_splice, FreeVars
lcl_names FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
gbl_names) }

      | Bool
otherwise  -- Run it here, see Note [Running splices in the Renamer]
      = do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnSpliceExpr: untyped expression splice" MsgDoc
empty
           ; (LHsExpr GhcPs
rn_expr, [ForeignRef (Q ())]
mod_finalizers) <-
                UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn (LHsExpr GhcPs))
-> (LHsExpr GhcPs -> MsgDoc)
-> HsSplice GhcRn
-> TcRn (LHsExpr GhcPs, [ForeignRef (Q ())])
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> MsgDoc)
-> HsSplice GhcRn
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedExpSplice LHsExpr GhcTc -> TcRn (LHsExpr GhcPs)
runMetaE LHsExpr GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcRn
rn_splice
           ; (LHsExpr GhcRn
lexpr3, FreeVars
fvs) <- RnM (LHsExpr GhcRn, FreeVars) -> RnM (LHsExpr GhcRn, FreeVars)
forall r. TcM r -> TcM r
checkNoErrs (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
rn_expr)
             -- See Note [Delaying modFinalizers in untyped splices].
           ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( XPar GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcRn
NoExtField
noExtField (LHsExpr GhcRn -> HsExpr GhcRn) -> LHsExpr GhcRn -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ XSpliceE GhcRn -> HsSplice GhcRn -> HsExpr GhcRn
forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE XSpliceE GhcRn
NoExtField
noExtField
                            (HsSplice GhcRn -> HsExpr GhcRn)
-> (HsExpr GhcRn -> HsSplice GhcRn) -> HsExpr GhcRn -> HsExpr GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XSpliced GhcRn
-> ThModFinalizers -> HsSplicedThing GhcRn -> HsSplice GhcRn
forall id.
XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id
HsSpliced XSpliced GhcRn
NoExtField
noExtField ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers)
                            (HsSplicedThing GhcRn -> HsSplice GhcRn)
-> (HsExpr GhcRn -> HsSplicedThing GhcRn)
-> HsExpr GhcRn
-> HsSplice GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcRn -> HsSplicedThing GhcRn
forall id. HsExpr id -> HsSplicedThing id
HsSplicedExpr (HsExpr GhcRn -> HsExpr GhcRn) -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            LHsExpr GhcRn
lexpr3
                    , FreeVars
fvs)
           }

{- 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 [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] 'TcSplice.qAddModFinalizer'
[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))
[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))
[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...))

-}

----------------------
rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSpliceType HsSplice GhcPs
splice
  = (HsSplice GhcRn -> RnM (HsType GhcRn, FreeVars))
-> (HsSplice GhcRn -> (PendingRnSplice, HsType GhcRn))
-> HsSplice GhcPs
-> RnM (HsType GhcRn, FreeVars)
forall a.
(HsSplice GhcRn -> RnM (a, FreeVars))
-> (HsSplice GhcRn -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, FreeVars)
rnSpliceGen HsSplice GhcRn -> RnM (HsType GhcRn, FreeVars)
run_type_splice HsSplice GhcRn -> (PendingRnSplice, HsType GhcRn)
pend_type_splice HsSplice GhcPs
splice
  where
    pend_type_splice :: HsSplice GhcRn -> (PendingRnSplice, HsType GhcRn)
pend_type_splice HsSplice GhcRn
rn_splice
       = ( UntypedSpliceFlavour -> HsSplice GhcRn -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedTypeSplice HsSplice GhcRn
rn_splice
         , XSpliceTy GhcRn -> HsSplice GhcRn -> HsType GhcRn
forall pass. XSpliceTy pass -> HsSplice pass -> HsType pass
HsSpliceTy XSpliceTy GhcRn
NoExtField
noExtField HsSplice GhcRn
rn_splice)

    run_type_splice :: HsSplice GhcRn -> RnM (HsType GhcRn, FreeVars)
run_type_splice HsSplice GhcRn
rn_splice
      = do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnSpliceType: untyped type splice" MsgDoc
empty
           ; (LHsType GhcPs
hs_ty2, [ForeignRef (Q ())]
mod_finalizers) <-
                UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn (LHsType GhcPs))
-> (LHsType GhcPs -> MsgDoc)
-> HsSplice GhcRn
-> TcRn (LHsType GhcPs, [ForeignRef (Q ())])
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> MsgDoc)
-> HsSplice GhcRn
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedTypeSplice LHsExpr GhcTc -> TcRn (LHsType GhcPs)
runMetaT LHsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcRn
rn_splice
           ; (LHsType GhcRn
hs_ty3, FreeVars
fvs) <- do { let doc :: HsDocContext
doc = LHsType GhcPs -> HsDocContext
SpliceTypeCtx LHsType GhcPs
hs_ty2
                                 ; RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall r. TcM r -> TcM r
checkNoErrs (RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars))
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
doc LHsType GhcPs
hs_ty2 }
                                    -- checkNoErrs: see Note [Renamer errors]
             -- See Note [Delaying modFinalizers in untyped splices].
           ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( XParTy GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcRn
NoExtField
noExtField
                              (LHsType GhcRn -> HsType GhcRn) -> LHsType GhcRn -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ XSpliceTy GhcRn -> HsSplice GhcRn -> HsType GhcRn
forall pass. XSpliceTy pass -> HsSplice pass -> HsType pass
HsSpliceTy XSpliceTy GhcRn
NoExtField
noExtField
                              (HsSplice GhcRn -> HsType GhcRn)
-> (HsType GhcRn -> HsSplice GhcRn) -> HsType GhcRn -> HsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XSpliced GhcRn
-> ThModFinalizers -> HsSplicedThing GhcRn -> HsSplice GhcRn
forall id.
XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id
HsSpliced XSpliced GhcRn
NoExtField
noExtField ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers)
                              (HsSplicedThing GhcRn -> HsSplice GhcRn)
-> (HsType GhcRn -> HsSplicedThing GhcRn)
-> HsType GhcRn
-> HsSplice GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcRn -> HsSplicedThing GhcRn
forall id. HsType id -> HsSplicedThing id
HsSplicedTy (HsType GhcRn -> HsType GhcRn) -> LHsType GhcRn -> LHsType GhcRn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                              LHsType GhcRn
hs_ty3
                    , FreeVars
fvs
                    ) }
              -- Wrap the result of the splice in parens so that we don't
              -- lose the outermost location set by runQuasiQuote (#7918)

{- 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 RnTypes.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 :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)
                                       , FreeVars)
rnSplicePat :: HsSplice GhcPs -> RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
rnSplicePat HsSplice GhcPs
splice
  = (HsSplice GhcRn -> RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars))
-> (HsSplice GhcRn
    -> (PendingRnSplice, Either (Pat GhcPs) (Pat GhcRn)))
-> HsSplice GhcPs
-> RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
forall a.
(HsSplice GhcRn -> RnM (a, FreeVars))
-> (HsSplice GhcRn -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, FreeVars)
rnSpliceGen HsSplice GhcRn -> RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
run_pat_splice HsSplice GhcRn -> (PendingRnSplice, Either (Pat GhcPs) (Pat GhcRn))
forall b. HsSplice GhcRn -> (PendingRnSplice, Either b (Pat GhcRn))
pend_pat_splice HsSplice GhcPs
splice
  where
    pend_pat_splice :: HsSplice GhcRn ->
                       (PendingRnSplice, Either b (Pat GhcRn))
    pend_pat_splice :: HsSplice GhcRn -> (PendingRnSplice, Either b (Pat GhcRn))
pend_pat_splice HsSplice GhcRn
rn_splice
      = (UntypedSpliceFlavour -> HsSplice GhcRn -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedPatSplice HsSplice GhcRn
rn_splice
        , Pat GhcRn -> Either b (Pat GhcRn)
forall a b. b -> Either a b
Right (XSplicePat GhcRn -> HsSplice GhcRn -> Pat GhcRn
forall p. XSplicePat p -> HsSplice p -> Pat p
SplicePat XSplicePat GhcRn
NoExtField
noExtField HsSplice GhcRn
rn_splice))

    run_pat_splice :: HsSplice GhcRn ->
                      RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
    run_pat_splice :: HsSplice GhcRn -> RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
run_pat_splice HsSplice GhcRn
rn_splice
      = do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnSplicePat: untyped pattern splice" MsgDoc
empty
           ; (Located (Pat GhcPs)
pat, [ForeignRef (Q ())]
mod_finalizers) <-
                UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn (Located (Pat GhcPs)))
-> (Located (Pat GhcPs) -> MsgDoc)
-> HsSplice GhcRn
-> TcRn (Located (Pat GhcPs), [ForeignRef (Q ())])
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> MsgDoc)
-> HsSplice GhcRn
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedPatSplice LHsExpr GhcTc -> TcRn (Located (Pat GhcPs))
LHsExpr GhcTc -> TcM (LPat GhcPs)
runMetaP Located (Pat GhcPs) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcRn
rn_splice
             -- See Note [Delaying modFinalizers in untyped splices].
           ; (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
-> RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Pat GhcPs -> Either (Pat GhcPs) (Pat GhcRn)
forall a b. a -> Either a b
Left (Pat GhcPs -> Either (Pat GhcPs) (Pat GhcRn))
-> Pat GhcPs -> Either (Pat GhcPs) (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ XParPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XParPat p -> LPat p -> Pat p
ParPat XParPat GhcPs
NoExtField
noExtField (LPat GhcPs -> Pat GhcPs) -> LPat GhcPs -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ ((XSplicePat GhcPs -> HsSplice GhcPs -> Pat GhcPs
forall p. XSplicePat p -> HsSplice p -> Pat p
SplicePat XSplicePat GhcPs
NoExtField
noExtField)
                              (HsSplice GhcPs -> Pat GhcPs)
-> (Pat GhcPs -> HsSplice GhcPs) -> Pat GhcPs -> Pat GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XSpliced GhcPs
-> ThModFinalizers -> HsSplicedThing GhcPs -> HsSplice GhcPs
forall id.
XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id
HsSpliced XSpliced GhcPs
NoExtField
noExtField ([ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers)
                              (HsSplicedThing GhcPs -> HsSplice GhcPs)
-> (Pat GhcPs -> HsSplicedThing GhcPs)
-> Pat GhcPs
-> HsSplice GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat GhcPs -> HsSplicedThing GhcPs
forall id. Pat id -> HsSplicedThing id
HsSplicedPat)  (SrcSpanLess (Located (Pat GhcPs))
 -> SrcSpanLess (Located (Pat GhcPs)))
-> Located (Pat GhcPs) -> Located (Pat GhcPs)
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> SrcSpanLess b) -> a -> b
`onHasSrcSpan`
                              Located (Pat GhcPs)
pat
                    , FreeVars
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 GhcRn, FreeVars)
rnSpliceDecl (SpliceDecl XSpliceDecl GhcPs
_ (Located (HsSplice GhcPs)
-> Located (SrcSpanLess (Located (HsSplice GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located (HsSplice GhcPs))
splice) SpliceExplicitFlag
flg)
  = (HsSplice GhcRn -> RnM (SpliceDecl GhcRn, FreeVars))
-> (HsSplice GhcRn -> (PendingRnSplice, SpliceDecl GhcRn))
-> HsSplice GhcPs
-> RnM (SpliceDecl GhcRn, FreeVars)
forall a.
(HsSplice GhcRn -> RnM (a, FreeVars))
-> (HsSplice GhcRn -> (PendingRnSplice, a))
-> HsSplice GhcPs
-> RnM (a, FreeVars)
rnSpliceGen HsSplice GhcRn -> RnM (SpliceDecl GhcRn, FreeVars)
forall a a. Outputable a => a -> a
run_decl_splice HsSplice GhcRn -> (PendingRnSplice, SpliceDecl GhcRn)
pend_decl_splice SrcSpanLess (Located (HsSplice GhcPs))
HsSplice GhcPs
splice
  where
    pend_decl_splice :: HsSplice GhcRn -> (PendingRnSplice, SpliceDecl GhcRn)
pend_decl_splice HsSplice GhcRn
rn_splice
       = ( UntypedSpliceFlavour -> HsSplice GhcRn -> PendingRnSplice
makePending UntypedSpliceFlavour
UntypedDeclSplice HsSplice GhcRn
rn_splice
         , XSpliceDecl GhcRn
-> Located (HsSplice GhcRn)
-> SpliceExplicitFlag
-> SpliceDecl GhcRn
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcRn
NoExtField
noExtField (SrcSpan
-> SrcSpanLess (Located (HsSplice GhcRn))
-> Located (HsSplice GhcRn)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located (HsSplice GhcRn))
HsSplice GhcRn
rn_splice) SpliceExplicitFlag
flg)

    run_decl_splice :: a -> a
run_decl_splice a
rn_splice  = String -> MsgDoc -> a
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rnSpliceDecl" (a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
rn_splice)
rnSpliceDecl (XSpliceDecl XXSpliceDecl GhcPs
nec) = NoExtCon -> RnM (SpliceDecl GhcRn, FreeVars)
forall a. NoExtCon -> a
noExtCon XXSpliceDecl GhcPs
NoExtCon
nec

rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
-- Declaration splice at the very top level of the module
rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls HsSplice GhcPs
splice
   = do  { (HsSplice GhcRn
rn_splice, FreeVars
fvs) <- TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall r. TcM r -> TcM r
checkNoErrs (TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars))
-> TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                               ThStage
-> TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
Untyped) (TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars))
-> TcM (HsSplice GhcRn, FreeVars) -> TcM (HsSplice GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                               HsSplice GhcPs -> TcM (HsSplice GhcRn, FreeVars)
rnSplice HsSplice GhcPs
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.
         ; String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnTopSpliceDecls: untyped declaration splice" MsgDoc
empty
         ; ([LHsDecl GhcPs]
decls, [ForeignRef (Q ())]
mod_finalizers) <- TcM ([LHsDecl GhcPs], [ForeignRef (Q ())])
-> TcM ([LHsDecl GhcPs], [ForeignRef (Q ())])
forall r. TcM r -> TcM r
checkNoErrs (TcM ([LHsDecl GhcPs], [ForeignRef (Q ())])
 -> TcM ([LHsDecl GhcPs], [ForeignRef (Q ())]))
-> TcM ([LHsDecl GhcPs], [ForeignRef (Q ())])
-> TcM ([LHsDecl GhcPs], [ForeignRef (Q ())])
forall a b. (a -> b) -> a -> b
$
               UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn [LHsDecl GhcPs])
-> ([LHsDecl GhcPs] -> MsgDoc)
-> HsSplice GhcRn
-> TcM ([LHsDecl GhcPs], [ForeignRef (Q ())])
forall res.
UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> MsgDoc)
-> HsSplice GhcRn
-> TcRn (res, [ForeignRef (Q ())])
runRnSplice UntypedSpliceFlavour
UntypedDeclSplice LHsExpr GhcTc -> TcRn [LHsDecl GhcPs]
runMetaD [LHsDecl GhcPs] -> MsgDoc
ppr_decls HsSplice GhcRn
rn_splice
         ; [ForeignRef (Q ())] -> IOEnv (Env TcGblEnv TcLclEnv) ()
add_mod_finalizers_now [ForeignRef (Q ())]
mod_finalizers
         ; ([LHsDecl GhcPs], FreeVars) -> RnM ([LHsDecl GhcPs], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsDecl GhcPs]
decls,FreeVars
fvs) }
   where
     ppr_decls :: [LHsDecl GhcPs] -> SDoc
     ppr_decls :: [LHsDecl GhcPs] -> MsgDoc
ppr_decls [LHsDecl GhcPs]
ds = [MsgDoc] -> MsgDoc
vcat ((LHsDecl GhcPs -> MsgDoc) -> [LHsDecl GhcPs] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map LHsDecl GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsDecl 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 ())] -> IOEnv (Env TcGblEnv TcLclEnv) ()
add_mod_finalizers_now []             = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     add_mod_finalizers_now [ForeignRef (Q ())]
mod_finalizers = do
       TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- (TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)])
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv
     (Env TcGblEnv TcLclEnv) (TcRef [(TcLclEnv, ThModFinalizers)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)]
tcg_th_modfinalizers TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       TcRef [(TcLclEnv, ThModFinalizers)]
-> ([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var (([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> ([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ \[(TcLclEnv, ThModFinalizers)]
fins ->
         (TcLclEnv
env, [ForeignRef (Q ())] -> ThModFinalizers
ThModFinalizers [ForeignRef (Q ())]
mod_finalizers) (TcLclEnv, ThModFinalizers)
-> [(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)]
forall a. a -> [a] -> [a]
: [(TcLclEnv, ThModFinalizers)]
fins


{-
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
RnPat, 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 RdrName) -- the result of
running the splice -- which can then be further renamed in RnPat, 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 HsSplice 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 either have a
Pat RdrName (the result of running a top-level splice) or a Pat Name
(the renamed nested splice). Thus, the awkward return type of
rnSplicePat.
-}

spliceCtxt :: HsSplice GhcPs -> SDoc
spliceCtxt :: HsSplice GhcPs -> MsgDoc
spliceCtxt HsSplice GhcPs
splice
  = MsgDoc -> ThLevel -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"In the" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
what) ThLevel
2 (HsSplice GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSplice GhcPs
splice)
  where
    what :: MsgDoc
what = case HsSplice GhcPs
splice of
             HsUntypedSplice {} -> String -> MsgDoc
text String
"untyped splice:"
             HsTypedSplice   {} -> String -> MsgDoc
text String
"typed splice:"
             HsQuasiQuote    {} -> String -> MsgDoc
text String
"quasi-quotation:"
             HsSpliced       {} -> String -> MsgDoc
text String
"spliced expression:"
             HsSplicedT      {} -> String -> MsgDoc
text String
"spliced expression:"
             XSplice         {} -> String -> MsgDoc
text String
"spliced expression:"

-- | The splice data to be logged
data SpliceInfo
  = SpliceInfo
    { SpliceInfo -> String
spliceDescription  :: String
    , SpliceInfo -> Maybe (LHsExpr GhcRn)
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 -> MsgDoc
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceSplice (SpliceInfo { spliceDescription :: SpliceInfo -> String
spliceDescription = String
sd, spliceSource :: SpliceInfo -> Maybe (LHsExpr GhcRn)
spliceSource = Maybe (LHsExpr GhcRn)
mb_src
                        , spliceGenerated :: SpliceInfo -> MsgDoc
spliceGenerated = MsgDoc
gen, spliceIsDecl :: SpliceInfo -> Bool
spliceIsDecl = Bool
is_decl })
  = do { SrcSpan
loc <- case Maybe (LHsExpr GhcRn)
mb_src of
                   Maybe (LHsExpr GhcRn)
Nothing           -> TcRn SrcSpan
getSrcSpanM
                   Just (LHsExpr GhcRn -> Located (SrcSpanLess (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsExpr GhcRn)
_) -> SrcSpan -> TcRn SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return SrcSpan
loc
       ; DumpFlag -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceOptTcRn DumpFlag
Opt_D_dump_splices (SrcSpan -> MsgDoc
spliceDebugDoc SrcSpan
loc)

       ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_decl (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$  -- Raw material for -dth-dec-file
         do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            ; IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ PrintUnqualified -> DynFlags -> DumpFlag -> MsgDoc -> IO ()
dumpIfSet_dyn_printer PrintUnqualified
alwaysQualify DynFlags
dflags DumpFlag
Opt_D_th_dec_file
                                             (SrcSpan -> MsgDoc
spliceCodeDoc SrcSpan
loc) } }
  where
    -- `-ddump-splices`
    spliceDebugDoc :: SrcSpan -> SDoc
    spliceDebugDoc :: SrcSpan -> MsgDoc
spliceDebugDoc SrcSpan
loc
      = let code :: [MsgDoc]
code = case Maybe (LHsExpr GhcRn)
mb_src of
                     Maybe (LHsExpr GhcRn)
Nothing -> [MsgDoc]
ending
                     Just LHsExpr GhcRn
e  -> ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 (LHsExpr GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsExpr GhcRn
e) MsgDoc -> [MsgDoc] -> [MsgDoc]
forall a. a -> [a] -> [a]
: [MsgDoc]
ending
            ending :: [MsgDoc]
ending = [ String -> MsgDoc
text String
"======>", ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 MsgDoc
gen ]
        in  MsgDoc -> ThLevel -> MsgDoc -> MsgDoc
hang (SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpan
loc MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"Splicing" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
sd)
               ThLevel
2 ([MsgDoc] -> MsgDoc
sep [MsgDoc]
code)

    -- `-dth-dec-file`
    spliceCodeDoc :: SrcSpan -> SDoc
    spliceCodeDoc :: SrcSpan -> MsgDoc
spliceCodeDoc SrcSpan
loc
      = [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"--" MsgDoc -> MsgDoc -> MsgDoc
<+> SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpan
loc MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"Splicing" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
sd
             , MsgDoc
gen ]

illegalTypedSplice :: SDoc
illegalTypedSplice :: MsgDoc
illegalTypedSplice = String -> MsgDoc
text String
"Typed splices may not appear in untyped brackets"

illegalUntypedSplice :: SDoc
illegalUntypedSplice :: MsgDoc
illegalUntypedSplice = String -> MsgDoc
text String
"Untyped splices may not appear in typed brackets"

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

  | Bool
otherwise
  = do  { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"checkThLocalName" (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name)
        ; Maybe (TopLevelFlag, ThLevel, ThStage)
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel Name
name
        ; case Maybe (TopLevelFlag, ThLevel, ThStage)
mb_local_use of {
             Maybe (TopLevelFlag, ThLevel, ThStage)
Nothing -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () ;  -- Not a locally-bound thing
             Just (TopLevelFlag
top_lvl, ThLevel
bind_lvl, ThStage
use_stage) ->
    do  { let use_lvl :: ThLevel
use_lvl = ThStage -> ThLevel
thLevel ThStage
use_stage
        ; MsgDoc -> ThLevel -> ThLevel -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkWellStaged (MsgDoc -> MsgDoc
quotes (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name)) ThLevel
bind_lvl ThLevel
use_lvl
        ; String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"checkThLocalName" (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name MsgDoc -> MsgDoc -> MsgDoc
<+> ThLevel -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ThLevel
bind_lvl
                                               MsgDoc -> MsgDoc -> MsgDoc
<+> ThStage -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ThStage
use_stage
                                               MsgDoc -> MsgDoc -> MsgDoc
<+> ThLevel -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ThLevel
use_lvl)
        ; TopLevelFlag
-> ThLevel
-> ThStage
-> ThLevel
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkCrossStageLifting TopLevelFlag
top_lvl ThLevel
bind_lvl ThStage
use_stage ThLevel
use_lvl Name
name } } }

--------------------------------------
checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel
                       -> Name -> TcM ()
-- We are inside brackets, and (use_lvl > bind_lvl)
-- Now we must check whether there's a cross-stage lift to do
-- Examples   \x -> [| x |]
--            [| map |]
--
-- This code is similar to checkCrossStageLifting in TcExpr, but
-- this is only run on *untyped* brackets.

checkCrossStageLifting :: TopLevelFlag
-> ThLevel
-> ThStage
-> ThLevel
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkCrossStageLifting TopLevelFlag
top_lvl ThLevel
bind_lvl ThStage
use_stage ThLevel
use_lvl Name
name
  | Brack ThStage
_ (RnPendingUntyped IORef [PendingRnSplice]
ps_var) <- ThStage
use_stage   -- Only for untyped brackets
  , ThLevel
use_lvl ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
bind_lvl                               -- Cross-stage condition
  = TopLevelFlag
-> Name
-> IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
check_cross_stage_lifting TopLevelFlag
top_lvl Name
name IORef [PendingRnSplice]
ps_var
  | Bool
otherwise
  = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
check_cross_stage_lifting :: TopLevelFlag
-> Name
-> IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
check_cross_stage_lifting TopLevelFlag
top_lvl Name
name IORef [PendingRnSplice]
ps_var
  | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
        -- 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
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
name) (Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
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 -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"checkCrossStageLifting" (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name)

          -- Construct the (lift x) expression
        ; let lift_expr :: LHsExpr GhcRn
lift_expr   = LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP GhcRn
liftName) (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP GhcRn
name)
              pend_splice :: PendingRnSplice
pend_splice = UntypedSpliceFlavour -> Name -> LHsExpr GhcRn -> PendingRnSplice
PendingRnSplice UntypedSpliceFlavour
UntypedExpSplice Name
name LHsExpr GhcRn
lift_expr

          -- Update the pending splices
        ; [PendingRnSplice]
ps <- IORef [PendingRnSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingRnSplice]
forall a env. IORef a -> IOEnv env a
readMutVar IORef [PendingRnSplice]
ps_var
        ; IORef [PendingRnSplice]
-> [PendingRnSplice] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef [PendingRnSplice]
ps_var (PendingRnSplice
pend_splice PendingRnSplice -> [PendingRnSplice] -> [PendingRnSplice]
forall a. a -> [a] -> [a]
: [PendingRnSplice]
ps) }

{-
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 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-stage lifting (c.f. TcExpr.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-stage lifting

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

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