never executed always true always false
    1 {-# LANGUAGE AllowAmbiguousTypes    #-}
    2 
    3 {-# LANGUAGE DataKinds              #-}
    4 {-# LANGUAGE FlexibleContexts       #-}
    5 {-# LANGUAGE FunctionalDependencies #-}
    6 {-# LANGUAGE PatternSynonyms        #-}
    7 {-# LANGUAGE RankNTypes             #-}
    8 {-# LANGUAGE ScopedTypeVariables    #-}
    9 {-# LANGUAGE TypeApplications       #-}
   10 {-# LANGUAGE TypeFamilies           #-}
   11 {-# LANGUAGE UndecidableInstances   #-}
   12 
   13 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
   14 
   15 -----------------------------------------------------------------------------
   16 --
   17 -- (c) The University of Glasgow 2006
   18 --
   19 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
   20 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
   21 -- input HsExpr. We do this in the DsM monad, which supplies access to
   22 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
   23 --
   24 -- It also defines a bunch of knownKeyNames, in the same way as is done
   25 -- in prelude/GHC.Builtin.Names.  It's much more convenient to do it here, because
   26 -- otherwise we have to recompile GHC.Builtin.Names whenever we add a Name, which is
   27 -- a Royal Pain (triggers other recompilation).
   28 -----------------------------------------------------------------------------
   29 
   30 module GHC.HsToCore.Quote( dsBracket ) where
   31 
   32 import GHC.Prelude
   33 import GHC.Platform
   34 
   35 import GHC.Driver.Session
   36 
   37 import GHC.HsToCore.Errors.Types
   38 import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr )
   39 import GHC.HsToCore.Match.Literal
   40 import GHC.HsToCore.Monad
   41 import GHC.HsToCore.Binds
   42 
   43 import qualified Language.Haskell.TH as TH
   44 import qualified Language.Haskell.TH.Syntax as TH
   45 
   46 import GHC.Hs
   47 
   48 import GHC.Tc.Utils.TcType
   49 import GHC.Tc.Types.Evidence
   50 
   51 import GHC.Core.Class
   52 import GHC.Core.DataCon
   53 import GHC.Core.TyCon
   54 import GHC.Core.Multiplicity ( pattern Many )
   55 import GHC.Core
   56 import GHC.Core.Make
   57 import GHC.Core.Utils
   58 
   59 import GHC.Builtin.Names
   60 import GHC.Builtin.Names.TH
   61 import GHC.Builtin.Types
   62 
   63 import GHC.Unit.Module
   64 
   65 import GHC.Utils.Outputable
   66 import GHC.Utils.Panic
   67 import GHC.Utils.Panic.Plain
   68 import GHC.Utils.Misc
   69 import GHC.Utils.Monad
   70 
   71 import GHC.Data.Bag
   72 import GHC.Data.FastString
   73 import GHC.Data.Maybe
   74 
   75 import GHC.Types.SrcLoc as SrcLoc
   76 import GHC.Types.Unique
   77 import GHC.Types.Basic
   78 import GHC.Types.ForeignCall
   79 import GHC.Types.Var
   80 import GHC.Types.Id
   81 import GHC.Types.SourceText
   82 import GHC.Types.Fixity
   83 import GHC.Types.TyThing
   84 import GHC.Types.Name hiding( varName, tcName )
   85 import GHC.Types.Name.Env
   86 
   87 import GHC.TypeLits
   88 import Data.Kind (Constraint)
   89 
   90 import qualified GHC.LanguageExtensions as LangExt
   91 
   92 import Data.ByteString ( unpack )
   93 import Control.Monad
   94 import Data.List (sort, sortBy)
   95 import Data.Function
   96 import Control.Monad.Trans.Reader
   97 import Control.Monad.Trans.Class
   98 
   99 data MetaWrappers = MetaWrappers {
  100       -- Applies its argument to a type argument `m` and dictionary `Quote m`
  101       quoteWrapper :: CoreExpr -> CoreExpr
  102       -- Apply its argument to a type argument `m` and a dictionary `Monad m`
  103     , monadWrapper :: CoreExpr -> CoreExpr
  104       -- Apply the container typed variable `m` to the argument type `T` to get `m T`.
  105     , metaTy :: Type -> Type
  106       -- Information about the wrappers which be printed to be inspected
  107     , _debugWrappers :: (HsWrapper, HsWrapper, Type)
  108     }
  109 
  110 -- | Construct the functions which will apply the relevant part of the
  111 -- QuoteWrapper to identifiers during desugaring.
  112 mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers
  113 mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do
  114       let quote_var = Var quote_var_raw
  115       -- Get the superclass selector to select the Monad dictionary, going
  116       -- to be used to construct the monadWrapper.
  117       quote_tc <- dsLookupTyCon quoteClassName
  118       monad_tc <- dsLookupTyCon monadClassName
  119       let Just cls = tyConClass_maybe quote_tc
  120           Just monad_cls = tyConClass_maybe monad_tc
  121           -- Quote m -> Monad m
  122           monad_sel = classSCSelId cls 0
  123 
  124           -- Only used for the defensive assertion that the selector has
  125           -- the expected type
  126           tyvars = dataConUserTyVarBinders (classDataCon cls)
  127           expected_ty = mkInvisForAllTys tyvars $
  128                           mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars)))
  129                                            (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))
  130 
  131       massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty)
  132 
  133       let m_ty = Type m_var
  134           -- Construct the contents of MetaWrappers
  135           quoteWrapper = applyQuoteWrapper q
  136           monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.>
  137                             mkWpTyApps [m_var]
  138           tyWrapper t = mkAppTy m_var t
  139           debug = (quoteWrapper, monadWrapper, m_var)
  140       q_f <- dsHsWrapper quoteWrapper
  141       m_f <- dsHsWrapper monadWrapper
  142       return (MetaWrappers q_f m_f tyWrapper debug)
  143 
  144 -- Turn A into m A
  145 wrapName :: Name -> MetaM Type
  146 wrapName n = do
  147   t <- lookupType n
  148   wrap_fn <- asks metaTy
  149   return (wrap_fn t)
  150 
  151 -- The local state is always the same, calculated from the passed in
  152 -- wrapper
  153 type MetaM a = ReaderT MetaWrappers DsM a
  154 
  155 getPlatform :: MetaM Platform
  156 getPlatform = targetPlatform <$> getDynFlags
  157 
  158 -----------------------------------------------------------------------------
  159 dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
  160           -> HsBracket GhcRn
  161           -> [PendingTcSplice]
  162           -> DsM CoreExpr
  163 -- See Note [Desugaring Brackets]
  164 -- Returns a CoreExpr of type (M TH.Exp)
  165 -- The quoted thing is parameterised over Name, even though it has
  166 -- been type checked.  We don't want all those type decorations!
  167 
  168 dsBracket wrap brack splices
  169   = do_brack brack
  170 
  171   where
  172     runOverloaded act = do
  173       -- In the overloaded case we have to get given a wrapper, it is just
  174       -- for variable quotations that there is no wrapper, because they
  175       -- have a simple type.
  176       mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)
  177       runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw
  178 
  179 
  180     new_bit = mkNameEnv [(n, DsSplice (unLoc e))
  181                         | PendingTcSplice n e <- splices]
  182 
  183     do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOccDsM (unLoc n) ; return e1 }
  184     do_brack (ExpBr _ e)   = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }
  185     do_brack (PatBr _ p)   = runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }
  186     do_brack (TypBr _ t)   = runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }
  187     do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
  188     do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"
  189     do_brack (TExpBr _ e)  = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }
  190 
  191 {-
  192 Note [Desugaring Brackets]
  193 ~~~~~~~~~~~~~~~~~~~~~~~~~~
  194 
  195 In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie
  196 an expression bracket was of type Q Exp. This made the desugaring process simple
  197 as there were no complicated type variables to keep consistent throughout the
  198 whole AST. Due to the overloaded quotations proposal a quotation bracket is now
  199 of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been
  200 generalised to work with any monad implementing a minimal interface.
  201 
  202 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst
  203 
  204 Users can rejoice at the flexibility but now there is some additional complexity in
  205 how brackets are desugared as all these polymorphic combinators need their arguments
  206 instantiated.
  207 
  208 > IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD
  209 > USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR.
  210 
  211 What the arguments should be instantiated to is supplied by the `QuoteWrapper`
  212 datatype which is produced by `GHC.Tc.Gen.Splice`. It is a pair of an evidence variable
  213 for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring
  214 need to be applied to these two type variables.
  215 
  216 There are three important functions which do the application.
  217 
  218 1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument.
  219 2. `rep2M` takes a function name of type `Monad m => T` as an argument
  220 3. `rep2_nw` takes a function name without any constraints as an argument.
  221 
  222 These functions then use the information in QuoteWrapper to apply the correct
  223 arguments to the functions as the representation is constructed.
  224 
  225 The `MetaM` monad carries around an environment of three functions which are
  226 used in order to wrap the polymorphic combinators and instantiate the arguments
  227 to the correct things.
  228 
  229 1. quoteWrapper wraps functions of type `forall m . Quote m => T`
  230 2. monadWrapper wraps functions of type `forall m . Monad m => T`
  231 3. metaTy wraps a type in the polymorphic `m` variable of the whole representation.
  232 
  233 Historical note about the implementation: At the first attempt, I attempted to
  234 lie that the type of any quotation was `Quote m => m Exp` and then specialise it
  235 by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was
  236 simpler to implement but didn't work because of nested splices. For example,
  237 you might have a nested splice of a more specific type which fixes the type of
  238 the overall quote and so all the combinators used must also be instantiated to
  239 that specific type. Therefore you really have to use the contents of the quote
  240 wrapper to directly apply the right type to the combinators rather than
  241 first generate a polymorphic definition and then just apply the wrapper at the end.
  242 
  243 -}
  244 
  245 {- -------------- Examples --------------------
  246 
  247   [| \x -> x |]
  248 ====>
  249   gensym (unpackString "x"#) `bindQ` \ x1::String ->
  250   lam (pvar x1) (var x1)
  251 
  252 
  253   [| \x -> $(f [| x |]) |]
  254 ====>
  255   gensym (unpackString "x"#) `bindQ` \ x1::String ->
  256   lam (pvar x1) (f (var x1))
  257 -}
  258 
  259 
  260 -------------------------------------------------------
  261 --                      Declarations
  262 -------------------------------------------------------
  263 
  264 -- Proxy for the phantom type of `Core`. All the generated fragments have
  265 -- type something like `Quote m => m Exp` so to keep things simple we represent fragments
  266 -- of that type as `M Exp`.
  267 data M a
  268 
  269 repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
  270 repTopP pat = do { ss <- mkGenSyms (collectPatBinders CollNoDictBinders pat)
  271                  ; pat' <- addBinds ss (repLP pat)
  272                  ; wrapGenSyms ss pat' }
  273 
  274 repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec]))
  275 repTopDs group@(HsGroup { hs_valds   = valds
  276                         , hs_splcds  = splcds
  277                         , hs_tyclds  = tyclds
  278                         , hs_derivds = derivds
  279                         , hs_fixds   = fixds
  280                         , hs_defds   = defds
  281                         , hs_fords   = fords
  282                         , hs_warnds  = warnds
  283                         , hs_annds   = annds
  284                         , hs_ruleds  = ruleds
  285                         , hs_docs    = docs })
  286  = do { let { bndrs  = hsScopedTvBinders valds
  287                        ++ hsGroupBinders group
  288                        ++ map foExt (hsPatSynSelectors valds)
  289             ; instds = tyclds >>= group_instds } ;
  290         ss <- mkGenSyms bndrs ;
  291 
  292         -- Bind all the names mainly to avoid repeated use of explicit strings.
  293         -- Thus we get
  294         --      do { t :: String <- genSym "T" ;
  295         --           return (Data t [] ...more t's... }
  296         -- The other important reason is that the output must mention
  297         -- only "T", not "Foo:T" where Foo is the current module
  298 
  299         decls <- addBinds ss (
  300                   do { val_ds   <- rep_val_binds valds
  301                      ; _        <- mapM no_splice splcds
  302                      ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
  303                      ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
  304                      ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)
  305                      ; inst_ds  <- mapM repInstD instds
  306                      ; deriv_ds <- mapM repStandaloneDerivD derivds
  307                      ; fix_ds   <- mapM repLFixD fixds
  308                      ; def_ds   <- mapM repDefD defds
  309                      ; for_ds   <- mapM repForD fords
  310                      ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
  311                                                            warnds)
  312                      ; ann_ds   <- mapM repAnnD annds
  313                      ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
  314                                                             ruleds)
  315                      ; _        <- mapM no_doc docs
  316 
  317                         -- more needed
  318                      ;  return (de_loc $ sort_by_loc $
  319                                 val_ds ++ catMaybes tycl_ds ++ role_ds
  320                                        ++ kisig_ds
  321                                        ++ (concat fix_ds)
  322                                        ++ def_ds
  323                                        ++ inst_ds ++ rule_ds ++ for_ds
  324                                        ++ ann_ds ++ deriv_ds) }) ;
  325 
  326         core_list <- repListM decTyConName return decls ;
  327 
  328         dec_ty <- lookupType decTyConName ;
  329         q_decs  <- repSequenceM dec_ty core_list ;
  330 
  331         wrapGenSyms ss q_decs
  332       }
  333   where
  334     no_splice (L loc _)
  335       = notHandledL (locA loc) ThSplicesWithinDeclBrackets
  336     no_warn :: LWarnDecl GhcRn -> MetaM a
  337     no_warn (L loc (Warning _ thing _))
  338       = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing)
  339     no_doc (L loc _)
  340       = notHandledL (locA loc) ThHaddockDocumentation
  341 
  342 hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
  343 -- See Note [Scoped type variables in quotes]
  344 hsScopedTvBinders binds
  345   = concatMap get_scoped_tvs sigs
  346   where
  347     sigs = case binds of
  348              ValBinds           _ _ sigs  -> sigs
  349              XValBindsLR (NValBinds _ sigs) -> sigs
  350 
  351 get_scoped_tvs :: LSig GhcRn -> [Name]
  352 get_scoped_tvs (L _ signature)
  353   | TypeSig _ _ sig <- signature
  354   = get_scoped_tvs_from_sig (hswc_body sig)
  355   | ClassOpSig _ _ _ sig <- signature
  356   = get_scoped_tvs_from_sig sig
  357   | PatSynSig _ _ sig <- signature
  358   = get_scoped_tvs_from_sig sig
  359   | otherwise
  360   = []
  361 
  362 get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]
  363   -- Collect both implicit and explicit quantified variables, since
  364   -- the types in instance heads, as well as `via` types in DerivingVia, can
  365   -- bring implicitly quantified type variables into scope, e.g.,
  366   --
  367   --   instance Foo [a] where
  368   --     m = n @a
  369   --
  370   -- See also Note [Scoped type variables in quotes]
  371 get_scoped_tvs_from_sig (L _ (HsSig{sig_bndrs = outer_bndrs})) =
  372   hsOuterTyVarNames outer_bndrs
  373 
  374 {- Notes
  375 
  376 Note [Scoped type variables in quotes]
  377 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  378 Quoting declarations with scoped type variables requires some care. Consider:
  379 
  380   $([d| f :: forall a. a -> a
  381         f x = x::a
  382       |])
  383 
  384 Here, the `forall a` brings `a` into scope over the binding group. This has
  385 ramifications when desugaring the quote, as we must ensure that that the
  386 desugared code binds `a` with `Language.Haskell.TH.newName` and refers to the
  387 bound `a` type variable in the type signature and in the body of `f`. As a
  388 result, the call to `newName` must occur before any part of the declaration for
  389 `f` is processed. To achieve this, we:
  390 
  391  (a) Gensym a binding for `a` at the same time as we do one for `f`,
  392      collecting the relevant binders with the hsScopedTvBinders family of
  393      functions.
  394 
  395  (b) Use `addBinds` to bring these gensymmed bindings into scope over any
  396      part of the code where the type variables scope. In the `f` example,
  397      above, that means the type signature and the body of `f`.
  398 
  399  (c) When processing the `forall`, /don't/ gensym the type variables. We have
  400      already brought the type variables into scope in part (b), after all, so
  401      gensymming them again would lead to shadowing. We use the rep_ty_sig
  402      family of functions for processing types without gensymming the type
  403      variables again.
  404 
  405  (d) Finally, we use wrapGenSyms to generate the Core for these scoped type
  406      variables:
  407 
  408        newName "a" >>= \a ->
  409          ... -- process the type signature and body of `f`
  410 
  411 The relevant places are signposted with references to this Note.
  412 
  413 Note [Binders and occurrences]
  414 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  415 When we desugar [d| data T = MkT |]
  416 we want to get
  417         Data "T" [] [Con "MkT" []] []
  418 and *not*
  419         Data "Foo:T" [] [Con "Foo:MkT" []] []
  420 That is, the new data decl should fit into whatever new module it is
  421 asked to fit in.   We do *not* clone, though; no need for this:
  422         Data "T79" ....
  423 
  424 But if we see this:
  425         data T = MkT
  426         foo = reifyDecl T
  427 
  428 then we must desugar to
  429         foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
  430 
  431 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
  432 And we use lookupOcc, rather than lookupBinder
  433 in repTyClD and repC.
  434 
  435 Note [Don't quantify implicit type variables in quotes]
  436 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  437 If you're not careful, it's surprisingly easy to take this quoted declaration:
  438 
  439   [d| id :: a -> a
  440       id x = x
  441     |]
  442 
  443 and have Template Haskell turn it into this:
  444 
  445   id :: forall a. a -> a
  446   id x = x
  447 
  448 Notice that we explicitly quantified the variable `a`! The latter declaration
  449 isn't what the user wrote in the first place.
  450 
  451 Usually, the culprit behind these bugs is taking implicitly quantified type
  452 variables (often from the hsib_vars field of HsImplicitBinders) and putting
  453 them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
  454 -}
  455 
  456 -- represent associated family instances
  457 --
  458 repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec)))
  459 
  460 repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
  461                                               repFamilyDecl (L loc fam)
  462 
  463 repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
  464   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
  465        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
  466                 repSynDecl tc1 bndrs rhs
  467        ; return (Just (locA loc, dec)) }
  468 
  469 repTyClD (L loc (DataDecl { tcdLName = tc
  470                           , tcdTyVars = tvs
  471                           , tcdDataDefn = defn }))
  472   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
  473        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
  474                 repDataDefn tc1 (Left bndrs) defn
  475        ; return (Just (locA loc, dec)) }
  476 
  477 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
  478                              tcdTyVars = tvs, tcdFDs = fds,
  479                              tcdSigs = sigs, tcdMeths = meth_binds,
  480                              tcdATs = ats, tcdATDefs = atds }))
  481   = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
  482        ; dec  <- addQTyVarBinds tvs $ \bndrs ->
  483            do { cxt1   <- repLContext cxt
  484           -- See Note [Scoped type variables in quotes]
  485               ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds
  486               ; fds1   <- repLFunDeps fds
  487               ; ats1   <- repFamilyDecls ats
  488               ; atds1  <- mapM (repAssocTyFamDefaultD . unLoc) atds
  489               ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)
  490               ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
  491               ; wrapGenSyms ss decls2 }
  492        ; return $ Just (locA loc, dec)
  493        }
  494 
  495 -------------------------
  496 repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
  497 repRoleD (L loc (RoleAnnotDecl _ tycon roles))
  498   = do { tycon1 <- lookupLOcc tycon
  499        ; roles1 <- mapM repRole roles
  500        ; roles2 <- coreList roleTyConName roles1
  501        ; dec <- repRoleAnnotD tycon1 roles2
  502        ; return (locA loc, dec) }
  503 
  504 -------------------------
  505 repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
  506 repKiSigD (L loc kisig) =
  507   case kisig of
  508     StandaloneKindSig _ v ki -> do
  509       MkC th_v  <- lookupLOcc v
  510       MkC th_ki <- repHsSigType ki
  511       dec       <- rep2 kiSigDName [th_v, th_ki]
  512       pure (locA loc, dec)
  513 
  514 -------------------------
  515 repDataDefn :: Core TH.Name
  516             -> Either (Core [(M (TH.TyVarBndr ()))])
  517                         -- the repTyClD case
  518                       (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
  519                         -- the repDataFamInstD case
  520             -> HsDataDefn GhcRn
  521             -> MetaM (Core (M TH.Dec))
  522 repDataDefn tc opts
  523           (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
  524                       , dd_cons = cons, dd_derivs = mb_derivs })
  525   = do { cxt1     <- repLContext cxt
  526        ; derivs1  <- repDerivs mb_derivs
  527        ; case (new_or_data, cons) of
  528            (NewType, [con])  -> do { con'  <- repC con
  529                                    ; ksig' <- repMaybeLTy ksig
  530                                    ; repNewtype cxt1 tc opts ksig' con'
  531                                                 derivs1 }
  532            (NewType, _) -> lift $ failWithDs (DsMultipleConForNewtype (getConNames $ unLoc $ head cons))
  533            (DataType, _) -> do { ksig' <- repMaybeLTy ksig
  534                                ; consL <- mapM repC cons
  535                                ; cons1 <- coreListM conTyConName consL
  536                                ; repData cxt1 tc opts ksig' cons1
  537                                          derivs1 }
  538        }
  539 
  540 repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
  541            -> LHsType GhcRn
  542            -> MetaM (Core (M TH.Dec))
  543 repSynDecl tc bndrs ty
  544   = do { ty1 <- repLTy ty
  545        ; repTySyn tc bndrs ty1 }
  546 
  547 repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
  548 repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info
  549                                       , fdLName     = tc
  550                                       , fdTyVars    = tvs
  551                                       , fdResultSig = L _ resultSig
  552                                       , fdInjectivityAnn = injectivity }))
  553   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
  554        ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
  555              mkHsQTvs tvs = HsQTvs { hsq_ext = []
  556                                    , hsq_explicit = tvs }
  557              resTyVar = case resultSig of
  558                      TyVarSig _ bndr -> mkHsQTvs [bndr]
  559                      _               -> mkHsQTvs []
  560        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
  561                 addTyClTyVarBinds resTyVar $ \_ ->
  562            case info of
  563              ClosedTypeFamily Nothing ->
  564                  notHandled (ThAbstractClosedTypeFamily decl)
  565              ClosedTypeFamily (Just eqns) ->
  566                do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
  567                   ; eqns2  <- coreListM tySynEqnTyConName eqns1
  568                   ; result <- repFamilyResultSig resultSig
  569                   ; inj    <- repInjectivityAnn injectivity
  570                   ; repClosedFamilyD tc1 bndrs result inj eqns2 }
  571              OpenTypeFamily ->
  572                do { result <- repFamilyResultSig resultSig
  573                   ; inj    <- repInjectivityAnn injectivity
  574                   ; repOpenFamilyD tc1 bndrs result inj }
  575              DataFamily ->
  576                do { kind <- repFamilyResultSigToMaybeKind resultSig
  577                   ; repDataFamilyD tc1 bndrs kind }
  578        ; return (locA loc, dec)
  579        }
  580 
  581 -- | Represent result signature of a type family
  582 repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig))
  583 repFamilyResultSig (NoSig _)         = repNoSig
  584 repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki
  585                                           ; repKindSig ki' }
  586 repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
  587                                           ; repTyVarSig bndr' }
  588 
  589 -- | Represent result signature using a Maybe Kind. Used with data families,
  590 -- where the result signature can be either missing or a kind but never a named
  591 -- result variable.
  592 repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
  593                               -> MetaM (Core (Maybe (M TH.Kind)))
  594 repFamilyResultSigToMaybeKind (NoSig _) =
  595     coreNothingM kindTyConName
  596 repFamilyResultSigToMaybeKind (KindSig _ ki) =
  597     coreJustM kindTyConName =<< repLTy ki
  598 repFamilyResultSigToMaybeKind TyVarSig{} =
  599     panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"
  600 
  601 -- | Represent injectivity annotation of a type family
  602 repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
  603                   -> MetaM (Core (Maybe TH.InjectivityAnn))
  604 repInjectivityAnn Nothing =
  605     coreNothing injAnnTyConName
  606 repInjectivityAnn (Just (L _ (InjectivityAnn _ lhs rhs))) =
  607     do { lhs'   <- lookupBinder (unLoc lhs)
  608        ; rhs1   <- mapM (lookupBinder . unLoc) rhs
  609        ; rhs2   <- coreList nameTyConName rhs1
  610        ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2]
  611        ; coreJust injAnnTyConName injAnn }
  612 
  613 repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)]
  614 repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
  615 
  616 repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec))
  617 repAssocTyFamDefaultD = repTyFamInstD
  618 
  619 -------------------------
  620 -- represent fundeps
  621 --
  622 repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep])
  623 repLFunDeps fds = repList funDepTyConName repLFunDep fds
  624 
  625 repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep)
  626 repLFunDep (L _ (FunDep _ xs ys))
  627    = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
  628         ys' <- repList nameTyConName (lookupBinder . unLoc) ys
  629         repFunDep xs' ys'
  630 
  631 -- Represent instance declarations
  632 --
  633 repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
  634 repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
  635   = do { dec <- repTyFamInstD fi_decl
  636        ; return (locA loc, dec) }
  637 repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
  638   = do { dec <- repDataFamInstD fi_decl
  639        ; return (locA loc, dec) }
  640 repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
  641   = do { dec <- repClsInstD cls_decl
  642        ; return (locA loc, dec) }
  643 
  644 repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))
  645 repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
  646                          , cid_sigs = sigs, cid_tyfam_insts = ats
  647                          , cid_datafam_insts = adts
  648                          , cid_overlap_mode = overlap
  649                          })
  650   = addSimpleTyVarBinds tvs $
  651             -- We must bring the type variables into scope, so their
  652             -- occurrences don't fail, even though the binders don't
  653             -- appear in the resulting data structure
  654             --
  655             -- But we do NOT bring the binders of 'binds' into scope
  656             -- because they are properly regarded as occurrences
  657             -- For example, the method names should be bound to
  658             -- the selector Ids, not to fresh names (#5410)
  659             --
  660             do { cxt1     <- repLContext cxt
  661                ; inst_ty1 <- repLTy inst_ty
  662           -- See Note [Scoped type variables in quotes]
  663                ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs binds
  664                ; ats1   <- mapM (repTyFamInstD . unLoc) ats
  665                ; adts1  <- mapM (repDataFamInstD . unLoc) adts
  666                ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)
  667                ; rOver  <- repOverlap (fmap unLoc overlap)
  668                ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
  669                ; wrapGenSyms ss decls2 }
  670  where
  671    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
  672 
  673 repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
  674 repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
  675                                        , deriv_type     = ty }))
  676   = do { dec <- repDerivStrategy strat  $ \strat' ->
  677                 addSimpleTyVarBinds tvs $
  678                 do { cxt'     <- repLContext cxt
  679                    ; inst_ty' <- repLTy inst_ty
  680                    ; repDeriv strat' cxt' inst_ty' }
  681        ; return (locA loc, dec) }
  682   where
  683     (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
  684 
  685 repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
  686 repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
  687   = do { eqn1 <- repTyFamEqn eqn
  688        ; repTySynInst eqn1 }
  689 
  690 repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))
  691 repTyFamEqn (FamEqn { feqn_tycon = tc_name
  692                     , feqn_bndrs = outer_bndrs
  693                     , feqn_pats = tys
  694                     , feqn_fixity = fixity
  695                     , feqn_rhs  = rhs })
  696   = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]
  697        ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
  698          do { tys1 <- case fixity of
  699                         Prefix -> repTyArgs (repNamedTyCon tc) tys
  700                         Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
  701                                      ; t1' <- repLTy t1
  702                                      ; t2'  <- repLTy t2
  703                                      ; repTyArgs (repTInfix t1' tc t2') args }
  704             ; rhs1 <- repLTy rhs
  705             ; repTySynEqn mb_exp_bndrs tys1 rhs1 } }
  706      where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
  707            checkTys tys@(HsValArg _:HsValArg _:_) = return tys
  708            checkTys _ = panic "repTyFamEqn:checkTys"
  709 
  710 repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))
  711 repTyArgs f [] = f
  712 repTyArgs f (HsValArg ty : as) = do { f' <- f
  713                                     ; ty' <- repLTy ty
  714                                     ; repTyArgs (repTapp f' ty') as }
  715 repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
  716                                        ; ki' <- repLTy ki
  717                                        ; repTyArgs (repTappKind f' ki') as }
  718 repTyArgs f (HsArgPar _ : as) = repTyArgs f as
  719 
  720 repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
  721 repDataFamInstD (DataFamInstDecl { dfid_eqn =
  722                                       FamEqn { feqn_tycon = tc_name
  723                                              , feqn_bndrs = outer_bndrs
  724                                              , feqn_pats  = tys
  725                                              , feqn_fixity = fixity
  726                                              , feqn_rhs   = defn }})
  727   = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]
  728        ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
  729          do { tys1 <- case fixity of
  730                         Prefix -> repTyArgs (repNamedTyCon tc) tys
  731                         Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
  732                                      ; t1' <- repLTy t1
  733                                      ; t2'  <- repLTy t2
  734                                      ; repTyArgs (repTInfix t1' tc t2') args }
  735             ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } }
  736 
  737       where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
  738             checkTys tys@(HsValArg _: HsValArg _: _) = return tys
  739             checkTys _ = panic "repDataFamInstD:checkTys"
  740 
  741 repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
  742 repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
  743                                   , fd_fi = CImport (L _ cc)
  744                                                     (L _ s) mch cis _ }))
  745  = do MkC name' <- lookupLOcc name
  746       MkC typ' <- repHsSigType typ
  747       MkC cc' <- repCCallConv cc
  748       MkC s' <- repSafety s
  749       cis' <- conv_cimportspec cis
  750       MkC str <- coreStringLit (static ++ chStr ++ cis')
  751       dec <- rep2 forImpDName [cc', s', str, name', typ']
  752       return (locA loc, dec)
  753  where
  754     conv_cimportspec (CLabel cls)
  755       = notHandled (ThForeignLabel cls)
  756     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
  757     conv_cimportspec (CFunction (StaticTarget _ fs _ True))
  758                             = return (unpackFS fs)
  759     conv_cimportspec (CFunction (StaticTarget _ _  _ False))
  760                             = panic "conv_cimportspec: values not supported yet"
  761     conv_cimportspec CWrapper = return "wrapper"
  762     -- these calling conventions do not support headers and the static keyword
  763     raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
  764     static = case cis of
  765                  CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
  766                  _ -> ""
  767     chStr = case mch of
  768             Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
  769             _ -> ""
  770 repForD decl@(L _ ForeignExport{}) = notHandled (ThForeignExport decl)
  771 
  772 repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)
  773 repCCallConv CCallConv          = rep2_nw cCallName []
  774 repCCallConv StdCallConv        = rep2_nw stdCallName []
  775 repCCallConv CApiConv           = rep2_nw cApiCallName []
  776 repCCallConv PrimCallConv       = rep2_nw primCallName []
  777 repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName []
  778 
  779 repSafety :: Safety -> MetaM (Core TH.Safety)
  780 repSafety PlayRisky = rep2_nw unsafeName []
  781 repSafety PlayInterruptible = rep2_nw interruptibleName []
  782 repSafety PlaySafe = rep2_nw safeName []
  783 
  784 repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
  785 repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig
  786 
  787 rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
  788 rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
  789   = do { MkC prec' <- coreIntLit prec
  790        ; let rep_fn = case dir of
  791                         InfixL -> infixLDName
  792                         InfixR -> infixRDName
  793                         InfixN -> infixNDName
  794        ; let do_one name
  795               = do { MkC name' <- lookupLOcc name
  796                    ; dec <- rep2 rep_fn [prec', name']
  797                    ; return (loc,dec) }
  798        ; mapM do_one names }
  799 
  800 repDefD :: LDefaultDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
  801 repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys
  802                                          ; MkC tys2 <- coreListM typeTyConName tys1
  803                                          ; dec <- rep2 defaultDName [tys2]
  804                                          ; return (locA loc, dec)}
  805 
  806 repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
  807 repRuleD (L loc (HsRule { rd_name = n
  808                         , rd_act = act
  809                         , rd_tyvs = ty_bndrs
  810                         , rd_tmvs = tm_bndrs
  811                         , rd_lhs = lhs
  812                         , rd_rhs = rhs }))
  813   = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
  814          do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
  815             ; ss <- mkGenSyms tm_bndr_names
  816             ; rule <- addBinds ss $
  817                       do { elt_ty <- wrapName tyVarBndrUnitTyConName
  818                          ; ty_bndrs' <- return $ case ty_bndrs of
  819                              Nothing -> coreNothing' (mkListTy elt_ty)
  820                              Just _  -> coreJust' (mkListTy elt_ty) ex_bndrs
  821                          ; tm_bndrs' <- repListM ruleBndrTyConName
  822                                                 repRuleBndr
  823                                                 tm_bndrs
  824                          ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
  825                          ; act' <- repPhases act
  826                          ; lhs' <- repLE lhs
  827                          ; rhs' <- repLE rhs
  828                          ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
  829            ; wrapGenSyms ss rule  }
  830        ; return (locA loc, rule) }
  831 
  832 ruleBndrNames :: LRuleBndr GhcRn -> [Name]
  833 ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]
  834 ruleBndrNames (L _ (RuleBndrSig _ n sig))
  835   | HsPS { hsps_ext = HsPSRn { hsps_imp_tvs = vars }} <- sig
  836   = unLoc n : vars
  837 
  838 repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))
  839 repRuleBndr (L _ (RuleBndr _ n))
  840   = do { MkC n' <- lookupNBinder n
  841        ; rep2 ruleVarName [n'] }
  842 repRuleBndr (L _ (RuleBndrSig _ n sig))
  843   = do { MkC n'  <- lookupNBinder n
  844        ; MkC ty' <- repLTy (hsPatSigType sig)
  845        ; rep2 typedRuleVarName [n', ty'] }
  846 
  847 repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
  848 repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
  849   = do { target <- repAnnProv ann_prov
  850        ; exp'   <- repE exp
  851        ; dec    <- repPragAnn target exp'
  852        ; return (locA loc, dec) }
  853 
  854 repAnnProv :: AnnProvenance GhcRn -> MetaM (Core TH.AnnTarget)
  855 repAnnProv (ValueAnnProvenance n)
  856   = do { -- An ANN references an identifier bound elsewhere in the module, so
  857          -- we must look it up using lookupLOcc (#19377).
  858          -- Similarly for TypeAnnProvenance (`ANN type`) below.
  859          MkC n' <- lookupLOcc n
  860        ; rep2_nw valueAnnotationName [ n' ] }
  861 repAnnProv (TypeAnnProvenance n)
  862   = do { MkC n' <- lookupLOcc n
  863        ; rep2_nw typeAnnotationName [ n' ] }
  864 repAnnProv ModuleAnnProvenance
  865   = rep2_nw moduleAnnotationName []
  866 
  867 -------------------------------------------------------
  868 --                      Constructors
  869 -------------------------------------------------------
  870 
  871 repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con))
  872 repC (L _ (ConDeclH98 { con_name   = con
  873                       , con_forall = False
  874                       , con_mb_cxt = Nothing
  875                       , con_args   = args }))
  876   = repH98DataCon con args
  877 
  878 repC (L _ (ConDeclH98 { con_name = con
  879                       , con_forall = is_existential
  880                       , con_ex_tvs = con_tvs
  881                       , con_mb_cxt = mcxt
  882                       , con_args = args }))
  883   = addHsTyVarBinds con_tvs $ \ ex_bndrs ->
  884          do { c'    <- repH98DataCon con args
  885             ; ctxt' <- repMbContext mcxt
  886             ; if not is_existential && isNothing mcxt
  887               then return c'
  888               else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
  889             }
  890 
  891 repC (L _ (ConDeclGADT { con_names  = cons
  892                        , con_bndrs  = L _ outer_bndrs
  893                        , con_mb_cxt = mcxt
  894                        , con_g_args = args
  895                        , con_res_ty = res_ty }))
  896   | null_outer_imp_tvs && null_outer_exp_tvs
  897                                  -- No implicit or explicit variables
  898   , Nothing <- mcxt              -- No context
  899                                  -- ==> no need for a forall
  900   = repGadtDataCons cons args res_ty
  901 
  902   | otherwise
  903   = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' ->
  904              -- See Note [Don't quantify implicit type variables in quotes]
  905     do { c'    <- repGadtDataCons cons args res_ty
  906        ; ctxt' <- repMbContext mcxt
  907        ; if null_outer_exp_tvs && isNothing mcxt
  908          then return c'
  909          else rep2 forallCName ([unC outer_bndrs', unC ctxt', unC c']) }
  910   where
  911     null_outer_imp_tvs = nullOuterImplicit outer_bndrs
  912     null_outer_exp_tvs = nullOuterExplicit outer_bndrs
  913 
  914 repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
  915 repMbContext Nothing          = repContext []
  916 repMbContext (Just (L _ cxt)) = repContext cxt
  917 
  918 repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness))
  919 repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
  920 repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []
  921 repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
  922 
  923 repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness))
  924 repSrcStrictness SrcLazy     = rep2 sourceLazyName         []
  925 repSrcStrictness SrcStrict   = rep2 sourceStrictName       []
  926 repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
  927 
  928 repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType))
  929 repBangTy ty = do
  930   MkC u <- repSrcUnpackedness su'
  931   MkC s <- repSrcStrictness ss'
  932   MkC b <- rep2 bangName [u, s]
  933   MkC t <- repLTy ty'
  934   rep2 bangTypeName [b, t]
  935   where
  936     (su', ss', ty') = case unLoc ty of
  937             HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)
  938             _ -> (NoSrcUnpack, NoSrcStrict, ty)
  939 
  940 -------------------------------------------------------
  941 --                      Deriving clauses
  942 -------------------------------------------------------
  943 
  944 repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause])
  945 repDerivs clauses
  946   = repListM derivClauseTyConName repDerivClause clauses
  947 
  948 repDerivClause :: LHsDerivingClause GhcRn
  949                -> MetaM (Core (M TH.DerivClause))
  950 repDerivClause (L _ (HsDerivingClause
  951                           { deriv_clause_strategy = dcs
  952                           , deriv_clause_tys      = dct }))
  953   = repDerivStrategy dcs $ \(MkC dcs') ->
  954     do MkC dct' <- rep_deriv_clause_tys dct
  955        rep2 derivClauseName [dcs',dct']
  956   where
  957     rep_deriv_clause_tys :: LDerivClauseTys GhcRn -> MetaM (Core [M TH.Type])
  958     rep_deriv_clause_tys (L _ dct) = case dct of
  959       DctSingle _ ty -> rep_deriv_tys [ty]
  960       DctMulti _ tys -> rep_deriv_tys tys
  961 
  962     rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type])
  963     rep_deriv_tys = repListM typeTyConName repHsSigType
  964 
  965 rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
  966                     -> MetaM ([GenSymBind], [Core (M TH.Dec)])
  967 -- Represent signatures and methods in class/instance declarations.
  968 -- See Note [Scoped type variables in quotes]
  969 --
  970 -- Why not use 'repBinds': we have already created symbols for methods in
  971 -- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
  972 -- these fun_id via 'collectHsValBinders decs', which would lead to the
  973 -- instance declarations failing in TH.
  974 rep_meth_sigs_binds sigs binds
  975   = do { let tvs = concatMap get_scoped_tvs sigs
  976        ; ss <- mkGenSyms tvs
  977        ; sigs1 <- addBinds ss $ rep_sigs sigs
  978        ; binds1 <- addBinds ss $ rep_binds binds
  979        ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }
  980 
  981 -------------------------------------------------------
  982 --   Signatures in a class decl, or a group of bindings
  983 -------------------------------------------------------
  984 
  985 rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))]
  986         -- We silently ignore ones we don't recognise
  987 rep_sigs = concatMapM rep_sig
  988 
  989 rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
  990 rep_sig (L loc (TypeSig _ nms ty))
  991   = mapM (rep_wc_ty_sig sigDName (locA loc) ty) nms
  992 rep_sig (L loc (PatSynSig _ nms ty))
  993   = mapM (rep_patsyn_ty_sig (locA loc) ty) nms
  994 rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
  995   | is_deflt     = mapM (rep_ty_sig defaultSigDName (locA loc) ty) nms
  996   | otherwise    = mapM (rep_ty_sig sigDName (locA loc) ty) nms
  997 rep_sig d@(L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)
  998 rep_sig (L loc (FixSig _ fix_sig))   = rep_fix_d (locA loc) fix_sig
  999 rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc)
 1000 rep_sig (L loc (SpecSig _ nm tys ispec))
 1001   = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
 1002 rep_sig (L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty (locA loc)
 1003 rep_sig (L _   (MinimalSig {}))       = notHandled ThMinimalPragmas
 1004 rep_sig (L _   (SCCFunSig {}))        = notHandled ThSCCPragmas
 1005 rep_sig (L loc (CompleteMatchSig _ _st cls mty))
 1006   = rep_complete_sig cls mty (locA loc)
 1007 
 1008 -- Desugar the explicit type variable binders in an 'LHsSigType', making
 1009 -- sure not to gensym them.
 1010 -- See Note [Scoped type variables in quotes]
 1011 -- and Note [Don't quantify implicit type variables in quotes]
 1012 rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn]
 1013                -> MetaM (Core [M TH.TyVarBndrSpec])
 1014 rep_ty_sig_tvs explicit_tvs
 1015   = repListM tyVarBndrSpecTyConName repTyVarBndr
 1016              explicit_tvs
 1017 
 1018 -- Desugar the outer type variable binders in an 'LHsSigType', making
 1019 -- sure not to gensym them.
 1020 -- See Note [Scoped type variables in quotes]
 1021 -- and Note [Don't quantify implicit type variables in quotes]
 1022 rep_ty_sig_outer_tvs :: HsOuterSigTyVarBndrs GhcRn
 1023                      -> MetaM (Core [M TH.TyVarBndrSpec])
 1024 rep_ty_sig_outer_tvs (HsOuterImplicit{}) =
 1025   coreListM tyVarBndrSpecTyConName []
 1026 rep_ty_sig_outer_tvs (HsOuterExplicit{hso_bndrs = explicit_tvs}) =
 1027   rep_ty_sig_tvs explicit_tvs
 1028 
 1029 -- Desugar a top-level type signature. Unlike 'repHsSigType', this
 1030 -- deliberately avoids gensymming the type variables.
 1031 -- See Note [Scoped type variables in quotes]
 1032 -- and Note [Don't quantify implicit type variables in quotes]
 1033 rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> LocatedN Name
 1034            -> MetaM (SrcSpan, Core (M TH.Dec))
 1035 rep_ty_sig mk_sig loc sig_ty nm
 1036   = do { nm1 <- lookupLOcc nm
 1037        ; ty1 <- rep_ty_sig' sig_ty
 1038        ; sig <- repProto mk_sig nm1 ty1
 1039        ; return (loc, sig) }
 1040 
 1041 -- Desugar an 'LHsSigType', making sure not to gensym the type variables at
 1042 -- the front of the type signature.
 1043 -- See Note [Scoped type variables in quotes]
 1044 -- and Note [Don't quantify implicit type variables in quotes]
 1045 rep_ty_sig' :: LHsSigType GhcRn
 1046             -> MetaM (Core (M TH.Type))
 1047 rep_ty_sig' (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body}))
 1048   | (ctxt, tau) <- splitLHsQualTy body
 1049   = do { th_explicit_tvs <- rep_ty_sig_outer_tvs outer_bndrs
 1050        ; th_ctxt <- repLContext ctxt
 1051        ; th_tau  <- repLTy tau
 1052        ; if nullOuterExplicit outer_bndrs && null (fromMaybeContext ctxt)
 1053             then return th_tau
 1054             else repTForall th_explicit_tvs th_ctxt th_tau }
 1055 
 1056 rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> LocatedN Name
 1057                   -> MetaM (SrcSpan, Core (M TH.Dec))
 1058 -- represents a pattern synonym type signature;
 1059 -- see Note [Pattern synonym type signatures and Template Haskell] in "GHC.ThToHs"
 1060 --
 1061 -- Don't create the implicit and explicit variables when desugaring signatures,
 1062 -- see Note [Scoped type variables in quotes]
 1063 -- and Note [Don't quantify implicit type variables in quotes]
 1064 rep_patsyn_ty_sig loc sig_ty nm
 1065   | (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy sig_ty
 1066   = do { nm1 <- lookupLOcc nm
 1067        ; th_univs <- rep_ty_sig_tvs univs
 1068        ; th_exis  <- rep_ty_sig_tvs exis
 1069 
 1070        ; th_reqs  <- repLContext reqs
 1071        ; th_provs <- repLContext provs
 1072        ; th_ty    <- repLTy ty
 1073        ; ty1      <- repTForall th_univs th_reqs =<<
 1074                        repTForall th_exis th_provs th_ty
 1075        ; sig      <- repProto patSynSigDName nm1 ty1
 1076        ; return (loc, sig) }
 1077 
 1078 rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> LocatedN Name
 1079               -> MetaM (SrcSpan, Core (M TH.Dec))
 1080 rep_wc_ty_sig mk_sig loc sig_ty nm
 1081   = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
 1082 
 1083 rep_inline :: LocatedN Name
 1084            -> InlinePragma      -- Never defaultInlinePragma
 1085            -> SrcSpan
 1086            -> MetaM [(SrcSpan, Core (M TH.Dec))]
 1087 rep_inline nm ispec loc
 1088   = do { nm1    <- lookupLOcc nm
 1089        ; inline <- repInline $ inl_inline ispec
 1090        ; rm     <- repRuleMatch $ inl_rule ispec
 1091        ; phases <- repPhases $ inl_act ispec
 1092        ; pragma <- repPragInl nm1 inline rm phases
 1093        ; return [(loc, pragma)]
 1094        }
 1095 
 1096 rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma
 1097                -> SrcSpan
 1098                -> MetaM [(SrcSpan, Core (M TH.Dec))]
 1099 rep_specialise nm ty ispec loc
 1100   = do { nm1 <- lookupLOcc nm
 1101        ; ty1 <- repHsSigType ty
 1102        ; phases <- repPhases $ inl_act ispec
 1103        ; let inline = inl_inline ispec
 1104        ; pragma <- if noUserInlineSpec inline
 1105                    then -- SPECIALISE
 1106                      repPragSpec nm1 ty1 phases
 1107                    else -- SPECIALISE INLINE
 1108                      do { inline1 <- repInline inline
 1109                         ; repPragSpecInl nm1 ty1 inline1 phases }
 1110        ; return [(loc, pragma)]
 1111        }
 1112 
 1113 rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
 1114                    -> MetaM [(SrcSpan, Core (M TH.Dec))]
 1115 rep_specialiseInst ty loc
 1116   = do { ty1    <- repHsSigType ty
 1117        ; pragma <- repPragSpecInst ty1
 1118        ; return [(loc, pragma)] }
 1119 
 1120 repInline :: InlineSpec -> MetaM (Core TH.Inline)
 1121 repInline (NoInline          _ )   = dataCon noInlineDataConName
 1122 repInline (Inline            _ )   = dataCon inlineDataConName
 1123 repInline (Inlinable         _ )   = dataCon inlinableDataConName
 1124 repInline NoUserInlinePrag        = notHandled ThNoUserInline
 1125 
 1126 repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch)
 1127 repRuleMatch ConLike = dataCon conLikeDataConName
 1128 repRuleMatch FunLike = dataCon funLikeDataConName
 1129 
 1130 repPhases :: Activation -> MetaM (Core TH.Phases)
 1131 repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
 1132                                   ; dataCon' beforePhaseDataConName [arg] }
 1133 repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i
 1134                                   ; dataCon' fromPhaseDataConName [arg] }
 1135 repPhases _                  = dataCon allPhasesDataConName
 1136 
 1137 rep_complete_sig :: Located [LocatedN Name]
 1138                  -> Maybe (LocatedN Name)
 1139                  -> SrcSpan
 1140                  -> MetaM [(SrcSpan, Core (M TH.Dec))]
 1141 rep_complete_sig (L _ cls) mty loc
 1142   = do { mty' <- repMaybe nameTyConName lookupLOcc mty
 1143        ; cls' <- repList nameTyConName lookupLOcc cls
 1144        ; sig <- repPragComplete cls' mty'
 1145        ; return [(loc, sig)] }
 1146 
 1147 -------------------------------------------------------
 1148 --                      Types
 1149 -------------------------------------------------------
 1150 
 1151 class RepTV flag flag' | flag -> flag' where
 1152     tyVarBndrName :: Name
 1153     repPlainTV  :: Core TH.Name -> flag -> MetaM (Core (M (TH.TyVarBndr flag')))
 1154     repKindedTV :: Core TH.Name -> flag -> Core (M TH.Kind)
 1155                 -> MetaM (Core (M (TH.TyVarBndr flag')))
 1156 
 1157 instance RepTV () () where
 1158     tyVarBndrName = tyVarBndrUnitTyConName
 1159     repPlainTV  (MkC nm) ()          = rep2 plainTVName  [nm]
 1160     repKindedTV (MkC nm) () (MkC ki) = rep2 kindedTVName [nm, ki]
 1161 
 1162 instance RepTV Specificity TH.Specificity where
 1163     tyVarBndrName = tyVarBndrSpecTyConName
 1164     repPlainTV  (MkC nm) spec          = do { (MkC spec') <- rep_flag spec
 1165                                             ; rep2 plainInvisTVName  [nm, spec'] }
 1166     repKindedTV (MkC nm) spec (MkC ki) = do { (MkC spec') <- rep_flag spec
 1167                                             ; rep2 kindedInvisTVName [nm, spec', ki] }
 1168 
 1169 rep_flag :: Specificity -> MetaM (Core TH.Specificity)
 1170 rep_flag SpecifiedSpec = rep2_nw specifiedSpecName []
 1171 rep_flag InferredSpec  = rep2_nw inferredSpecName []
 1172 
 1173 addHsOuterFamEqnTyVarBinds ::
 1174      HsOuterFamEqnTyVarBndrs GhcRn
 1175   -> (Core (Maybe [M TH.TyVarBndrUnit]) -> MetaM (Core (M a)))
 1176   -> MetaM (Core (M a))
 1177 addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do
 1178   elt_ty <- wrapName tyVarBndrUnitTyConName
 1179   case outer_bndrs of
 1180     HsOuterImplicit{hso_ximplicit = imp_tvs} ->
 1181       addTyClTyVarBinds (mk_qtvs imp_tvs []) $ \_th_exp_bndrs ->
 1182       thing_inside $ coreNothingList elt_ty
 1183     HsOuterExplicit{hso_bndrs = exp_bndrs} ->
 1184       addTyClTyVarBinds (mk_qtvs [] exp_bndrs) $ \th_exp_bndrs ->
 1185       thing_inside $ coreJustList elt_ty th_exp_bndrs
 1186   where
 1187     mk_qtvs imp_tvs exp_tvs = HsQTvs { hsq_ext = imp_tvs
 1188                                      , hsq_explicit = exp_tvs }
 1189 
 1190 addHsOuterSigTyVarBinds ::
 1191      HsOuterSigTyVarBndrs GhcRn
 1192   -> (Core [M TH.TyVarBndrSpec] -> MetaM (Core (M a)))
 1193   -> MetaM (Core (M a))
 1194 addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of
 1195   HsOuterImplicit{hso_ximplicit = imp_tvs} ->
 1196     do th_nil <- coreListM tyVarBndrSpecTyConName []
 1197        addSimpleTyVarBinds imp_tvs $ thing_inside th_nil
 1198   HsOuterExplicit{hso_bndrs = exp_bndrs} ->
 1199     addHsTyVarBinds exp_bndrs thing_inside
 1200 
 1201 -- | If a type implicitly quantifies its outermost type variables, return
 1202 -- 'True' if the list of implicitly bound type variables is empty. If a type
 1203 -- explicitly quantifies its outermost type variables, always return 'True'.
 1204 --
 1205 -- This is used in various places to determine if a Template Haskell 'Type'
 1206 -- should be headed by a 'ForallT' or not.
 1207 nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
 1208 nullOuterImplicit (HsOuterImplicit{hso_ximplicit = imp_tvs}) = null imp_tvs
 1209 nullOuterImplicit (HsOuterExplicit{})                        = True
 1210   -- Vacuously true, as there is no implicit quantification
 1211 
 1212 -- | If a type explicitly quantifies its outermost type variables, return
 1213 -- 'True' if the list of explicitly bound type variables is empty. If a type
 1214 -- implicitly quantifies its outermost type variables, always return 'True'.
 1215 --
 1216 -- This is used in various places to determine if a Template Haskell 'Type'
 1217 -- should be headed by a 'ForallT' or not.
 1218 nullOuterExplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
 1219 nullOuterExplicit (HsOuterExplicit{hso_bndrs = exp_bndrs}) = null exp_bndrs
 1220 nullOuterExplicit (HsOuterImplicit{})                      = True
 1221   -- Vacuously true, as there is no outermost explicit quantification
 1222 
 1223 addSimpleTyVarBinds :: [Name]             -- the binders to be added
 1224                     -> MetaM (Core (M a)) -- action in the ext env
 1225                     -> MetaM (Core (M a))
 1226 addSimpleTyVarBinds names thing_inside
 1227   = do { fresh_names <- mkGenSyms names
 1228        ; term <- addBinds fresh_names thing_inside
 1229        ; wrapGenSyms fresh_names term }
 1230 
 1231 addHsTyVarBinds :: forall flag flag' a. RepTV flag flag'
 1232                 => [LHsTyVarBndr flag GhcRn] -- the binders to be added
 1233                 -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
 1234                 -> MetaM (Core (M a))
 1235 addHsTyVarBinds exp_tvs thing_inside
 1236   = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
 1237        ; term <- addBinds fresh_exp_names $
 1238                  do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr
 1239                                       exp_tvs
 1240                     ; thing_inside kbs }
 1241        ; wrapGenSyms fresh_exp_names term }
 1242 
 1243 addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
 1244                -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env
 1245                -> MetaM (Core (M a))
 1246 addQTyVarBinds (HsQTvs { hsq_ext = imp_tvs
 1247                       , hsq_explicit = exp_tvs })
 1248               thing_inside
 1249   = addTyVarBinds exp_tvs imp_tvs thing_inside
 1250 
 1251 addTyVarBinds :: RepTV flag flag'
 1252               => [LHsTyVarBndr flag GhcRn] -- the binders to be added
 1253               -> [Name]
 1254               -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
 1255               -> MetaM (Core (M a))
 1256 -- gensym a list of type variables and enter them into the meta environment;
 1257 -- the computations passed as the second argument is executed in that extended
 1258 -- meta environment and gets the *new* names on Core-level as an argument
 1259 addTyVarBinds exp_tvs imp_tvs thing_inside
 1260   = addSimpleTyVarBinds imp_tvs $
 1261     addHsTyVarBinds exp_tvs $
 1262     thing_inside
 1263 
 1264 addTyClTyVarBinds :: LHsQTyVars GhcRn
 1265                   -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a)))
 1266                   -> MetaM (Core (M a))
 1267 -- Used for data/newtype declarations, and family instances,
 1268 -- so that the nested type variables work right
 1269 --    instance C (T a) where
 1270 --      type W (T a) = blah
 1271 -- The 'a' in the type instance is the one bound by the instance decl
 1272 addTyClTyVarBinds tvs m
 1273   = do { let tv_names = hsAllLTyVarNames tvs
 1274        ; env <- lift $ dsGetMetaEnv
 1275        ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
 1276             -- Make fresh names for the ones that are not already in scope
 1277             -- This makes things work for family declarations
 1278 
 1279        ; term <- addBinds freshNames $
 1280                  do { kbs <- repListM tyVarBndrUnitTyConName repTyVarBndr
 1281                                      (hsQTvExplicit tvs)
 1282                     ; m kbs }
 1283 
 1284        ; wrapGenSyms freshNames term }
 1285 
 1286 -- | Represent a type variable binder
 1287 repTyVarBndr :: RepTV flag flag'
 1288              => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag')))
 1289 repTyVarBndr (L _ (UserTyVar _ fl (L _ nm)) )
 1290   = do { nm' <- lookupBinder nm
 1291        ; repPlainTV nm' fl }
 1292 repTyVarBndr (L _ (KindedTyVar _ fl (L _ nm) ki))
 1293   = do { nm' <- lookupBinder nm
 1294        ; ki' <- repLTy ki
 1295        ; repKindedTV nm' fl ki' }
 1296 
 1297 -- represent a type context
 1298 --
 1299 repLContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
 1300 repLContext Nothing = repContext []
 1301 repLContext (Just ctxt) = repContext (unLoc ctxt)
 1302 
 1303 repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt))
 1304 repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt
 1305                      repCtxt preds
 1306 
 1307 repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))
 1308 repHsSigType (L _ (HsSig { sig_bndrs = outer_bndrs, sig_body = body }))
 1309   | (ctxt, tau) <- splitLHsQualTy body
 1310   = addHsOuterSigTyVarBinds outer_bndrs $ \ th_outer_bndrs ->
 1311     do { th_ctxt <- repLContext ctxt
 1312        ; th_tau  <- repLTy tau
 1313        ; if nullOuterExplicit outer_bndrs && null (fromMaybeContext ctxt)
 1314          then pure th_tau
 1315          else repTForall th_outer_bndrs th_ctxt th_tau }
 1316 
 1317 -- yield the representation of a list of types
 1318 repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]
 1319 repLTys tys = mapM repLTy tys
 1320 
 1321 -- represent a type
 1322 repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type))
 1323 repLTy ty = repTy (unLoc ty)
 1324 
 1325 -- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or
 1326 -- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax.
 1327 -- In other words, the argument to this function is always an
 1328 -- @HsForAllTy HsForAllInvis{}@ or @HsQualTy@.
 1329 -- Types headed by visible foralls (which are desugared to ForallVisT) are
 1330 -- handled separately in repTy.
 1331 repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
 1332 repForallT ty
 1333  | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLocA ty)
 1334  = addHsTyVarBinds tvs $ \bndrs ->
 1335    do { ctxt1  <- repLContext ctxt
 1336       ; tau1   <- repLTy tau
 1337       ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}
 1338       }
 1339 
 1340 repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))
 1341 repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) =
 1342   case tele of
 1343     HsForAllInvis{} -> repForallT ty
 1344     HsForAllVis { hsf_vis_bndrs = tvs } ->
 1345       addHsTyVarBinds tvs $ \bndrs ->
 1346       do body1 <- repLTy body
 1347          repTForallVis bndrs body1
 1348 repTy ty@(HsQualTy {}) = repForallT ty
 1349 
 1350 repTy (HsTyVar _ _ (L _ n))
 1351   | isLiftedTypeKindTyConName n        = repTStar
 1352   | n `hasKey` constraintKindTyConKey  = repTConstraint
 1353   | n `hasKey` unrestrictedFunTyConKey = repArrowTyCon
 1354   | n `hasKey` funTyConKey             = repMulArrowTyCon
 1355   | isTvOcc occ   = do tv1 <- lookupOcc n
 1356                        repTvar tv1
 1357   | isDataOcc occ = do tc1 <- lookupOcc n
 1358                        repPromotedDataCon tc1
 1359   | n == eqTyConName = repTequality
 1360   | otherwise     = do tc1 <- lookupOcc n
 1361                        repNamedTyCon tc1
 1362   where
 1363     occ = nameOccName n
 1364 
 1365 repTy (HsAppTy _ f a)       = do
 1366                                 f1 <- repLTy f
 1367                                 a1 <- repLTy a
 1368                                 repTapp f1 a1
 1369 repTy (HsAppKindTy _ ty ki) = do
 1370                                 ty1 <- repLTy ty
 1371                                 ki1 <- repLTy ki
 1372                                 repTappKind ty1 ki1
 1373 repTy (HsFunTy _ w f a) | isUnrestricted w = do
 1374                                 f1   <- repLTy f
 1375                                 a1   <- repLTy a
 1376                                 tcon <- repArrowTyCon
 1377                                 repTapps tcon [f1, a1]
 1378 repTy (HsFunTy _ w f a) = do w1   <- repLTy (arrowToHsType w)
 1379                              f1   <- repLTy f
 1380                              a1   <- repLTy a
 1381                              tcon <- repMulArrowTyCon
 1382                              repTapps tcon [w1, f1, a1]
 1383 repTy (HsListTy _ t)        = do
 1384                                 t1   <- repLTy t
 1385                                 tcon <- repListTyCon
 1386                                 repTapp tcon t1
 1387 repTy (HsTupleTy _ HsUnboxedTuple tys) = do
 1388                                 tys1 <- repLTys tys
 1389                                 tcon <- repUnboxedTupleTyCon (length tys)
 1390                                 repTapps tcon tys1
 1391 repTy (HsTupleTy _ _ tys)   = do tys1 <- repLTys tys
 1392                                  tcon <- repTupleTyCon (length tys)
 1393                                  repTapps tcon tys1
 1394 repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys
 1395                                  tcon <- repUnboxedSumTyCon (length tys)
 1396                                  repTapps tcon tys1
 1397 repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
 1398                                    `nlHsAppTy` ty2)
 1399 repTy (HsParTy _ t)         = repLTy t
 1400 repTy (HsStarTy _ _) =  repTStar
 1401 repTy (HsKindSig _ t k)     = do
 1402                                 t1 <- repLTy t
 1403                                 k1 <- repLTy k
 1404                                 repTSig t1 k1
 1405 repTy (HsSpliceTy _ splice)      = repSplice splice
 1406 repTy (HsExplicitListTy _ _ tys) = do
 1407                                     tys1 <- repLTys tys
 1408                                     repTPromotedList tys1
 1409 repTy (HsExplicitTupleTy _ tys) = do
 1410                                     tys1 <- repLTys tys
 1411                                     tcon <- repPromotedTupleTyCon (length tys)
 1412                                     repTapps tcon tys1
 1413 repTy (HsTyLit _ lit) = do
 1414                           lit' <- repTyLit lit
 1415                           repTLit lit'
 1416 repTy (HsWildCardTy _) = repTWildCard
 1417 repTy (HsIParamTy _ n t) = do
 1418                              n' <- rep_implicit_param_name (unLoc n)
 1419                              t' <- repLTy t
 1420                              repTImplicitParam n' t'
 1421 
 1422 repTy ty                      = notHandled (ThExoticFormOfType ty)
 1423 
 1424 repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))
 1425 repTyLit (HsNumTy _ i) = do
 1426                          platform <- getPlatform
 1427                          rep2 numTyLitName [mkIntegerExpr platform i]
 1428 repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
 1429                             ; rep2 strTyLitName [s']
 1430                             }
 1431 repTyLit (HsCharTy _ c) = do { c' <- return (mkCharExpr c)
 1432                              ; rep2 charTyLitName [c']
 1433                              }
 1434 
 1435 -- | Represent a type wrapped in a Maybe
 1436 repMaybeLTy :: Maybe (LHsKind GhcRn)
 1437             -> MetaM (Core (Maybe (M TH.Type)))
 1438 repMaybeLTy m = do
 1439   k_ty <- wrapName kindTyConName
 1440   repMaybeT k_ty repLTy m
 1441 
 1442 repRole :: LocatedAn NoEpAnns (Maybe Role) -> MetaM (Core TH.Role)
 1443 repRole (L _ (Just Nominal))          = rep2_nw nominalRName []
 1444 repRole (L _ (Just Representational)) = rep2_nw representationalRName []
 1445 repRole (L _ (Just Phantom))          = rep2_nw phantomRName []
 1446 repRole (L _ Nothing)                 = rep2_nw inferRName []
 1447 
 1448 -----------------------------------------------------------------------------
 1449 --              Splices
 1450 -----------------------------------------------------------------------------
 1451 
 1452 repSplice :: HsSplice GhcRn -> MetaM (Core a)
 1453 -- See Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice
 1454 -- We return a CoreExpr of any old type; the context should know
 1455 repSplice (HsTypedSplice   _ _ n _) = rep_splice n
 1456 repSplice (HsUntypedSplice _ _ n _) = rep_splice n
 1457 repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n
 1458 repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e)
 1459 
 1460 rep_splice :: Name -> MetaM (Core a)
 1461 rep_splice splice_name
 1462  = do { mb_val <- lift $ dsLookupMetaEnv splice_name
 1463        ; case mb_val of
 1464            Just (DsSplice e) -> do { e' <- lift $ dsExpr e
 1465                                    ; return (MkC e') }
 1466            _ -> pprPanic "HsSplice" (ppr splice_name) }
 1467                         -- Should not happen; statically checked
 1468 
 1469 -----------------------------------------------------------------------------
 1470 --              Expressions
 1471 -----------------------------------------------------------------------------
 1472 
 1473 repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)])
 1474 repLEs es = repListM expTyConName repLE es
 1475 
 1476 -- FIXME: some of these panics should be converted into proper error messages
 1477 --        unless we can make sure that constructs, which are plainly not
 1478 --        supported in TH already lead to error messages at an earlier stage
 1479 repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp))
 1480 repLE (L loc e) = mapReaderT (putSrcSpanDs (locA loc)) (repE e)
 1481 
 1482 repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp))
 1483 repE (HsVar _ (L _ x)) =
 1484   do { mb_val <- lift $ dsLookupMetaEnv x
 1485      ; case mb_val of
 1486         Nothing            -> do { str <- lift $ globalVar x
 1487                                  ; repVarOrCon x str }
 1488         Just (DsBound y)   -> repVarOrCon x (coreVar y)
 1489         Just (DsSplice e)  -> do { e' <- lift $ dsExpr e
 1490                                  ; return (MkC e') } }
 1491 repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
 1492 repE (HsOverLabel _ s) = repOverLabel s
 1493 
 1494 repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))
 1495 
 1496         -- Remember, we're desugaring renamer output here, so
 1497         -- HsOverlit can definitely occur
 1498 repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
 1499 repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a }
 1500 repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m
 1501 repE e@(HsLam _ (MG { mg_alts = (L _ _) })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e)
 1502 repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))
 1503                    = do { ms' <- mapM repMatchTup ms
 1504                         ; core_ms <- coreListM matchTyConName ms'
 1505                         ; repLamCase core_ms }
 1506 repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
 1507 repE (HsAppType _ e t) = do { a <- repLE e
 1508                             ; s <- repLTy (hswc_body t)
 1509                             ; repAppType a s }
 1510 
 1511 repE (OpApp _ e1 op e2) =
 1512   do { arg1 <- repLE e1;
 1513        arg2 <- repLE e2;
 1514        the_op <- repLE op ;
 1515        repInfixApp arg1 the_op arg2 }
 1516 repE (NegApp _ x _)      = do
 1517                               a         <- repLE x
 1518                               negateVar <- lookupOcc negateName >>= repVar
 1519                               negateVar `repApp` a
 1520 repE (HsPar _ _ x _)        = repLE x
 1521 repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
 1522 repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
 1523 repE (HsCase _ e (MG { mg_alts = (L _ ms) }))
 1524                           = do { arg <- repLE e
 1525                                ; ms2 <- mapM repMatchTup ms
 1526                                ; core_ms2 <- coreListM matchTyConName ms2
 1527                                ; repCaseE arg core_ms2 }
 1528 repE (HsIf _ x y z)       = do
 1529                             a <- repLE x
 1530                             b <- repLE y
 1531                             c <- repLE z
 1532                             repCond a b c
 1533 repE (HsMultiIf _ alts)
 1534   = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
 1535        ; expr' <- repMultiIf (nonEmptyCoreList alts')
 1536        ; wrapGenSyms (concat binds) expr' }
 1537 repE (HsLet _ _ bs _ e)         = do { (ss,ds) <- repBinds bs
 1538                                      ; e2 <- addBinds ss (repLE e)
 1539                                      ; z <- repLetE ds e2
 1540                                      ; wrapGenSyms ss z }
 1541 
 1542 -- FIXME: I haven't got the types here right yet
 1543 repE e@(HsDo _ ctxt (L _ sts))
 1544  | Just maybeModuleName <- case ctxt of
 1545      { DoExpr m -> Just m; GhciStmtCtxt -> Just Nothing; _ -> Nothing }
 1546  = do { (ss,zs) <- repLSts sts;
 1547         e'      <- repDoE maybeModuleName (nonEmptyCoreList zs);
 1548         wrapGenSyms ss e' }
 1549 
 1550  | ListComp <- ctxt
 1551  = do { (ss,zs) <- repLSts sts;
 1552         e'      <- repComp (nonEmptyCoreList zs);
 1553         wrapGenSyms ss e' }
 1554 
 1555  | MDoExpr maybeModuleName <- ctxt
 1556  = do { (ss,zs) <- repLSts sts;
 1557         e'      <- repMDoE maybeModuleName (nonEmptyCoreList zs);
 1558         wrapGenSyms ss e' }
 1559 
 1560   | otherwise
 1561   = notHandled (ThMonadComprehensionSyntax e)
 1562 
 1563 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
 1564 repE (ExplicitTuple _ es boxity) =
 1565   let tupArgToCoreExp :: HsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp)))
 1566       tupArgToCoreExp a
 1567         | (Present _ e) <- a = do { e' <- repLE e
 1568                                   ; coreJustM expTyConName e' }
 1569         | otherwise = coreNothingM expTyConName
 1570 
 1571   in do { args <- mapM tupArgToCoreExp es
 1572         ; expTy <- wrapName  expTyConName
 1573         ; let maybeExpQTy = mkTyConApp maybeTyCon [expTy]
 1574               listArg = coreList' maybeExpQTy args
 1575         ; if isBoxed boxity
 1576           then repTup listArg
 1577           else repUnboxedTup listArg }
 1578 
 1579 repE (ExplicitSum _ alt arity e)
 1580  = do { e1 <- repLE e
 1581       ; repUnboxedSum e1 alt arity }
 1582 
 1583 repE (RecordCon { rcon_con = c, rcon_flds = flds })
 1584  = do { x <- lookupLOcc c;
 1585         fs <- repFields flds;
 1586         repRecCon x fs }
 1587 repE (RecordUpd { rupd_expr = e, rupd_flds = Left flds })
 1588  = do { x <- repLE e;
 1589         fs <- repUpdFields flds;
 1590         repRecUpd x fs }
 1591 repE (RecordUpd { rupd_flds = Right _ })
 1592   = do
 1593       -- Not possible due to elimination in the renamer. See Note
 1594       -- [Handling overloaded and rebindable constructs]
 1595       panic "The impossible has happened!"
 1596 
 1597 repE (ExprWithTySig _ e wc_ty)
 1598   = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $
 1599     do { e1 <- repLE e
 1600        ; t1 <- rep_ty_sig' sig_ty
 1601        ; repSigExp e1 t1 }
 1602   where
 1603     sig_ty = dropWildCards wc_ty
 1604 
 1605 repE (ArithSeq _ _ aseq) =
 1606   case aseq of
 1607     From e              -> do { ds1 <- repLE e; repFrom ds1 }
 1608     FromThen e1 e2      -> do
 1609                              ds1 <- repLE e1
 1610                              ds2 <- repLE e2
 1611                              repFromThen ds1 ds2
 1612     FromTo   e1 e2      -> do
 1613                              ds1 <- repLE e1
 1614                              ds2 <- repLE e2
 1615                              repFromTo ds1 ds2
 1616     FromThenTo e1 e2 e3 -> do
 1617                              ds1 <- repLE e1
 1618                              ds2 <- repLE e2
 1619                              ds3 <- repLE e3
 1620                              repFromThenTo ds1 ds2 ds3
 1621 
 1622 repE (HsSpliceE _ splice)  = repSplice splice
 1623 repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC
 1624 repE (HsUnboundVar _ uv)   = do
 1625                                occ   <- occNameLit uv
 1626                                sname <- repNameS occ
 1627                                repUnboundVar sname
 1628 repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ f)))) = do
 1629   e1 <- repLE e
 1630   repGetField e1 f
 1631 repE (HsProjection _ xs) = repProjection (map (unLoc . dfoLabel . unLoc) xs)
 1632 repE (XExpr (HsExpanded orig_expr ds_expr))
 1633   = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
 1634        ; if rebindable_on  -- See Note [Quotation and rebindable syntax]
 1635          then repE ds_expr
 1636          else repE orig_expr }
 1637 repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
 1638 repE e@(HsBracket{}) = notHandled (ThExpressionForm e)
 1639 repE e@(HsRnBracketOut{}) = notHandled (ThExpressionForm e)
 1640 repE e@(HsTcBracketOut{}) = notHandled (ThExpressionForm e)
 1641 repE e@(HsProc{}) = notHandled (ThExpressionForm e)
 1642 
 1643 {- Note [Quotation and rebindable syntax]
 1644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1645 Consider
 1646   f = [| (* 3) |]
 1647 
 1648 Because of Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr,
 1649 the renamer will expand (* 3) to (rightSection (*) 3), regardless of RebindableSyntax.
 1650 Then, concerning the TH quotation,
 1651 
 1652 * If RebindableSyntax is off, we want the TH quote to generate the section (* 3),
 1653   as the user originally wrote.
 1654 
 1655 * If RebindableSyntax is on, we perhaps want the TH quote to generate
 1656   (rightSection (*) 3), using whatever 'rightSection' is in scope, because
 1657   (a) RebindableSyntax might not be on in the splicing context
 1658   (b) Even if it is, 'rightSection' might not be in scope
 1659   (c) At least in the case of Typed Template Haskell we should never get
 1660       a type error from the splice.
 1661 
 1662 We consult the module-wide RebindableSyntax flag here. We could instead record
 1663 the choice in HsExpanded, but it seems simpler to consult the flag (again).
 1664 -}
 1665 
 1666 -----------------------------------------------------------------------------
 1667 -- Building representations of auxiliary structures like Match, Clause, Stmt,
 1668 
 1669 repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match))
 1670 repMatchTup (L _ (Match { m_pats = [p]
 1671                         , m_grhss = GRHSs _ guards wheres })) =
 1672   do { ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p)
 1673      ; addBinds ss1 $ do {
 1674      ; p1 <- repLP p
 1675      ; (ss2,ds) <- repBinds wheres
 1676      ; addBinds ss2 $ do {
 1677      ; gs    <- repGuards guards
 1678      ; match <- repMatch p1 gs ds
 1679      ; wrapGenSyms (ss1++ss2) match }}}
 1680 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
 1681 
 1682 repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause))
 1683 repClauseTup (L _ (Match { m_pats = ps
 1684                          , m_grhss = GRHSs _ guards  wheres })) =
 1685   do { ss1 <- mkGenSyms (collectPatsBinders CollNoDictBinders ps)
 1686      ; addBinds ss1 $ do {
 1687        ps1 <- repLPs ps
 1688      ; (ss2,ds) <- repBinds wheres
 1689      ; addBinds ss2 $ do {
 1690        gs <- repGuards guards
 1691      ; clause <- repClause ps1 gs ds
 1692      ; wrapGenSyms (ss1++ss2) clause }}}
 1693 
 1694 repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  MetaM (Core (M TH.Body))
 1695 repGuards [L _ (GRHS _ [] e)]
 1696   = do {a <- repLE e; repNormal a }
 1697 repGuards other
 1698   = do { zs <- mapM repLGRHS other
 1699        ; let (xs, ys) = unzip zs
 1700        ; gd <- repGuarded (nonEmptyCoreList ys)
 1701        ; wrapGenSyms (concat xs) gd }
 1702 
 1703 repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
 1704          -> MetaM ([GenSymBind], (Core (M (TH.Guard, TH.Exp))))
 1705 repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
 1706   = do { guarded <- repLNormalGE e1 e2
 1707        ; return ([], guarded) }
 1708 repLGRHS (L _ (GRHS _ ss rhs))
 1709   = do { (gs, ss') <- repLSts ss
 1710        ; rhs' <- addBinds gs $ repLE rhs
 1711        ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
 1712        ; return (gs, guarded) }
 1713 
 1714 repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp])
 1715 repFields (HsRecFields { rec_flds = flds })
 1716   = repListM fieldExpTyConName rep_fld flds
 1717   where
 1718     rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
 1719             -> MetaM (Core (M TH.FieldExp))
 1720     rep_fld (L _ fld) = do { fn <- lookupOcc (hsRecFieldSel fld)
 1721                            ; e  <- repLE (hfbRHS fld)
 1722                            ; repFieldExp fn e }
 1723 
 1724 repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp])
 1725 repUpdFields = repListM fieldExpTyConName rep_fld
 1726   where
 1727     rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp))
 1728     rep_fld (L l fld) = case unLoc (hfbLHS fld) of
 1729       Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
 1730                                    ; e  <- repLE (hfbRHS fld)
 1731                                    ; repFieldExp fn e }
 1732       Ambiguous{}            -> notHandled (ThAmbiguousRecordUpdates fld)
 1733 
 1734 
 1735 
 1736 -----------------------------------------------------------------------------
 1737 -- Representing Stmt's is tricky, especially if bound variables
 1738 -- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
 1739 -- First gensym new names for every variable in any of the patterns.
 1740 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
 1741 -- if variables didn't shadow, the static gensym wouldn't be necessary
 1742 -- and we could reuse the original names (x and x).
 1743 --
 1744 -- do { x'1 <- gensym "x"
 1745 --    ; x'2 <- gensym "x"
 1746 --    ; doE Nothing
 1747 --          [ BindSt (pvar x'1) [| f 1 |]
 1748 --          , BindSt (pvar x'2) [| f x |]
 1749 --          , NoBindSt [| g x |]
 1750 --          ]
 1751 --    }
 1752 
 1753 -- The strategy is to translate a whole list of do-bindings by building a
 1754 -- bigger environment, and a bigger set of meta bindings
 1755 -- (like:  x'1 <- gensym "x" ) and then combining these with the translations
 1756 -- of the expressions within the Do
 1757 
 1758 -----------------------------------------------------------------------------
 1759 -- The helper function repSts computes the translation of each sub expression
 1760 -- and a bunch of prefix bindings denoting the dynamic renaming.
 1761 
 1762 repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
 1763 repLSts stmts = repSts (map unLoc stmts)
 1764 
 1765 repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
 1766 repSts (BindStmt _ p e : ss) =
 1767    do { e2 <- repLE e
 1768       ; ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p)
 1769       ; addBinds ss1 $ do {
 1770       ; p1 <- repLP p;
 1771       ; (ss2,zs) <- repSts ss
 1772       ; z <- repBindSt p1 e2
 1773       ; return (ss1++ss2, z : zs) }}
 1774 repSts (LetStmt _ bs : ss) =
 1775    do { (ss1,ds) <- repBinds bs
 1776       ; z <- repLetSt ds
 1777       ; (ss2,zs) <- addBinds ss1 (repSts ss)
 1778       ; return (ss1++ss2, z : zs) }
 1779 repSts (BodyStmt _ e _ _ : ss) =
 1780    do { e2 <- repLE e
 1781       ; z <- repNoBindSt e2
 1782       ; (ss2,zs) <- repSts ss
 1783       ; return (ss2, z : zs) }
 1784 repSts (ParStmt _ stmt_blocks _ _ : ss) =
 1785    do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
 1786       ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
 1787             ss1 = concat ss_s
 1788       ; z <- repParSt stmt_blocks2
 1789       ; (ss2, zs) <- addBinds ss1 (repSts ss)
 1790       ; return (ss1++ss2, z : zs) }
 1791    where
 1792      rep_stmt_block :: ParStmtBlock GhcRn GhcRn
 1793                     -> MetaM ([GenSymBind], Core [(M TH.Stmt)])
 1794      rep_stmt_block (ParStmtBlock _ stmts _ _) =
 1795        do { (ss1, zs) <- repSts (map unLoc stmts)
 1796           ; zs1 <- coreListM stmtTyConName zs
 1797           ; return (ss1, zs1) }
 1798 repSts [LastStmt _ e _ _]
 1799   = do { e2 <- repLE e
 1800        ; z <- repNoBindSt e2
 1801        ; return ([], [z]) }
 1802 repSts (stmt@RecStmt{} : ss)
 1803   = do { let binders = collectLStmtsBinders CollNoDictBinders (unLoc $ recS_stmts stmt)
 1804        ; ss1 <- mkGenSyms binders
 1805        -- Bring all of binders in the recursive group into scope for the
 1806        -- whole group.
 1807        ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (unLoc $ recS_stmts stmt))
 1808        ; massert (sort ss1 == sort ss1_other)
 1809        ; z <- repRecSt (nonEmptyCoreList rss)
 1810        ; (ss2,zs) <- addBinds ss1 (repSts ss)
 1811        ; return (ss1++ss2, z : zs) }
 1812 repSts []    = return ([],[])
 1813 repSts other = notHandled (ThExoticStatement other)
 1814 
 1815 
 1816 -----------------------------------------------------------
 1817 --                      Bindings
 1818 -----------------------------------------------------------
 1819 
 1820 repBinds :: HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [(M TH.Dec)])
 1821 repBinds (EmptyLocalBinds _)
 1822   = do  { core_list <- coreListM decTyConName []
 1823         ; return ([], core_list) }
 1824 
 1825 repBinds (HsIPBinds _ (IPBinds _ decs))
 1826  = do   { ips <- mapM rep_implicit_param_bind decs
 1827         ; core_list <- coreListM decTyConName
 1828                                 (de_loc (sort_by_loc ips))
 1829         ; return ([], core_list)
 1830         }
 1831 
 1832 repBinds (HsValBinds _ decs)
 1833  = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders CollNoDictBinders decs }
 1834                 -- No need to worry about detailed scopes within
 1835                 -- the binding group, because we are talking Names
 1836                 -- here, so we can safely treat it as a mutually
 1837                 -- recursive group
 1838                 -- For hsScopedTvBinders see Note [Scoped type variables in quotes]
 1839         ; ss        <- mkGenSyms bndrs
 1840         ; prs       <- addBinds ss (rep_val_binds decs)
 1841         ; core_list <- coreListM decTyConName
 1842                                 (de_loc (sort_by_loc prs))
 1843         ; return (ss, core_list) }
 1844 
 1845 rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
 1846 rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
 1847  = do { name <- case ename of
 1848                     Left (L _ n) -> rep_implicit_param_name n
 1849                     Right _ ->
 1850                         panic "rep_implicit_param_bind: post typechecking"
 1851       ; rhs' <- repE rhs
 1852       ; ipb <- repImplicitParamBind name rhs'
 1853       ; return (locA loc, ipb) }
 1854 
 1855 rep_implicit_param_name :: HsIPName -> MetaM (Core String)
 1856 rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
 1857 
 1858 rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
 1859 -- Assumes: all the binders of the binding are already in the meta-env
 1860 rep_val_binds (XValBindsLR (NValBinds binds sigs))
 1861  = do { core1 <- rep_binds (unionManyBags (map snd binds))
 1862       ; core2 <- rep_sigs sigs
 1863       ; return (core1 ++ core2) }
 1864 rep_val_binds (ValBinds _ _ _)
 1865  = panic "rep_val_binds: ValBinds"
 1866 
 1867 rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
 1868 rep_binds = mapM rep_bind . bagToList
 1869 
 1870 rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
 1871 -- Assumes: all the binders of the binding are already in the meta-env
 1872 
 1873 -- Note GHC treats declarations of a variable (not a pattern)
 1874 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 1875 -- with an empty list of patterns
 1876 rep_bind (L loc (FunBind
 1877                  { fun_id = fn,
 1878                    fun_matches = MG { mg_alts
 1879                            = (L _ [L _ (Match
 1880                                    { m_pats = []
 1881                                    , m_grhss = GRHSs _ guards wheres }
 1882                                       )]) } }))
 1883  = do { (ss,wherecore) <- repBinds wheres
 1884         ; guardcore <- addBinds ss (repGuards guards)
 1885         ; fn'  <- lookupNBinder fn
 1886         ; p    <- repPvar fn'
 1887         ; ans  <- repVal p guardcore wherecore
 1888         ; ans' <- wrapGenSyms ss ans
 1889         ; return (locA loc, ans') }
 1890 
 1891 rep_bind (L loc (FunBind { fun_id = fn
 1892                          , fun_matches = MG { mg_alts = L _ ms } }))
 1893  =   do { ms1 <- mapM repClauseTup ms
 1894         ; fn' <- lookupNBinder fn
 1895         ; ans <- repFun fn' (nonEmptyCoreList ms1)
 1896         ; return (locA loc, ans) }
 1897 
 1898 rep_bind (L loc (PatBind { pat_lhs = pat
 1899                          , pat_rhs = GRHSs _ guards wheres }))
 1900  =   do { patcore <- repLP pat
 1901         ; (ss,wherecore) <- repBinds wheres
 1902         ; guardcore <- addBinds ss (repGuards guards)
 1903         ; ans  <- repVal patcore guardcore wherecore
 1904         ; ans' <- wrapGenSyms ss ans
 1905         ; return (locA loc, ans') }
 1906 
 1907 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
 1908  =   do { v' <- lookupBinder v
 1909         ; e2 <- repLE e
 1910         ; x <- repNormal e2
 1911         ; patcore <- repPvar v'
 1912         ; empty_decls <- coreListM decTyConName []
 1913         ; ans <- repVal patcore x empty_decls
 1914         ; return (srcLocSpan (getSrcLoc v), ans) }
 1915 
 1916 rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
 1917 rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn
 1918                                    , psb_args = args
 1919                                    , psb_def  = pat
 1920                                    , psb_dir  = dir })))
 1921   = do { syn'      <- lookupNBinder syn
 1922        ; dir'      <- repPatSynDir dir
 1923        ; ss        <- mkGenArgSyms args
 1924        ; patSynD'  <- addBinds ss (
 1925          do { args'  <- repPatSynArgs args
 1926             ; pat'   <- repLP pat
 1927             ; repPatSynD syn' args' dir' pat' })
 1928        ; patSynD'' <- wrapGenArgSyms args ss patSynD'
 1929        ; return (locA loc, patSynD'') }
 1930   where
 1931     mkGenArgSyms :: HsPatSynDetails GhcRn -> MetaM [GenSymBind]
 1932     -- for Record Pattern Synonyms we want to conflate the selector
 1933     -- and the pattern-only names in order to provide a nicer TH
 1934     -- API. Whereas inside GHC, record pattern synonym selectors and
 1935     -- their pattern-only bound right hand sides have different names,
 1936     -- we want to treat them the same in TH. This is the reason why we
 1937     -- need an adjusted mkGenArgSyms in the `RecCon` case below.
 1938     mkGenArgSyms (PrefixCon _ args)   = mkGenSyms (map unLoc args)
 1939     mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
 1940     mkGenArgSyms (RecCon fields)
 1941       = do { let pats = map (unLoc . recordPatSynPatVar) fields
 1942                  sels = map (foExt . recordPatSynField) fields
 1943            ; ss <- mkGenSyms sels
 1944            ; return $ replaceNames (zip sels pats) ss }
 1945 
 1946     replaceNames selsPats genSyms
 1947       = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
 1948                     , sel == sel' ]
 1949 
 1950     wrapGenArgSyms :: HsPatSynDetails GhcRn
 1951                    -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec))
 1952     wrapGenArgSyms (RecCon _) _  dec = return dec
 1953     wrapGenArgSyms _          ss dec = wrapGenSyms ss dec
 1954 
 1955 repPatSynD :: Core TH.Name
 1956            -> Core (M TH.PatSynArgs)
 1957            -> Core (M TH.PatSynDir)
 1958            -> Core (M TH.Pat)
 1959            -> MetaM (Core (M TH.Dec))
 1960 repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
 1961   = rep2 patSynDName [syn, args, dir, pat]
 1962 
 1963 repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs))
 1964 repPatSynArgs (PrefixCon _ args)
 1965   = do { args' <- repList nameTyConName lookupLOcc args
 1966        ; repPrefixPatSynArgs args' }
 1967 repPatSynArgs (InfixCon arg1 arg2)
 1968   = do { arg1' <- lookupLOcc arg1
 1969        ; arg2' <- lookupLOcc arg2
 1970        ; repInfixPatSynArgs arg1' arg2' }
 1971 repPatSynArgs (RecCon fields)
 1972   = do { sels' <- repList nameTyConName (lookupOcc . foExt) sels
 1973        ; repRecordPatSynArgs sels' }
 1974   where sels = map recordPatSynField fields
 1975 
 1976 repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs))
 1977 repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
 1978 
 1979 repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> MetaM (Core (M TH.PatSynArgs))
 1980 repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
 1981 
 1982 repRecordPatSynArgs :: Core [TH.Name]
 1983                     -> MetaM (Core (M TH.PatSynArgs))
 1984 repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
 1985 
 1986 repPatSynDir :: HsPatSynDir GhcRn -> MetaM (Core (M TH.PatSynDir))
 1987 repPatSynDir Unidirectional        = rep2 unidirPatSynName []
 1988 repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
 1989 repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))
 1990   = do { clauses' <- mapM repClauseTup clauses
 1991        ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
 1992 
 1993 repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir))
 1994 repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
 1995 
 1996 
 1997 -----------------------------------------------------------------------------
 1998 -- Since everything in a Bind is mutually recursive we need rename all
 1999 -- all the variables simultaneously. For example:
 2000 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
 2001 -- do { f'1 <- gensym "f"
 2002 --    ; g'2 <- gensym "g"
 2003 --    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
 2004 --        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
 2005 --      ]}
 2006 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
 2007 -- environment ( f |-> f'1 ) from each binding, and then unioning them
 2008 -- together. As we do this we collect GenSymBinds's which represent the renamed
 2009 -- variables bound by the Bindings. In order not to lose track of these
 2010 -- representations we build a shadow datatype MB with the same structure as
 2011 -- MonoBinds, but which has slots for the representations
 2012 
 2013 
 2014 -----------------------------------------------------------------------------
 2015 -- GHC allows a more general form of lambda abstraction than specified
 2016 -- by Haskell 98. In particular it allows guarded lambda's like :
 2017 -- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
 2018 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 2019 -- (\ p1 .. pn -> exp) by causing an error.
 2020 
 2021 repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp))
 2022 repLambda (L _ (Match { m_pats = ps
 2023                       , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
 2024                                               (EmptyLocalBinds _) } ))
 2025  = do { let bndrs = collectPatsBinders CollNoDictBinders ps ;
 2026       ; ss  <- mkGenSyms bndrs
 2027       ; lam <- addBinds ss (
 2028                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
 2029       ; wrapGenSyms ss lam }
 2030 
 2031 repLambda (L _ m) = notHandled (ThGuardedLambdas m)
 2032 
 2033 
 2034 -----------------------------------------------------------------------------
 2035 --                      Patterns
 2036 -- repP deals with patterns.  It assumes that we have already
 2037 -- walked over the pattern(s) once to collect the binders, and
 2038 -- have extended the environment.  So every pattern-bound
 2039 -- variable should already appear in the environment.
 2040 
 2041 -- Process a list of patterns
 2042 repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)])
 2043 repLPs ps = repListM patTyConName repLP ps
 2044 
 2045 repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
 2046 repLP p = repP (unLoc p)
 2047 
 2048 repP :: Pat GhcRn -> MetaM (Core (M TH.Pat))
 2049 repP (WildPat _)        = repPwild
 2050 repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }
 2051 repP (VarPat _ x)       = do { x' <- lookupBinder (unLoc x); repPvar x' }
 2052 repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }
 2053 repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }
 2054 repP (AsPat _ x p)      = do { x' <- lookupNBinder x; p1 <- repLP p
 2055                              ; repPaspat x' p1 }
 2056 repP (ParPat _ _ p _)   = repLP p
 2057 repP (ListPat _ ps)     = do { qs <- repLPs ps; repPlist qs }
 2058 repP (TuplePat _ ps boxed)
 2059   | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }
 2060   | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
 2061 repP (SumPat _ p alt arity) = do { p1 <- repLP p
 2062                                  ; repPunboxedSum p1 alt arity }
 2063 repP (ConPat NoExtField dc details)
 2064  = do { con_str <- lookupLOcc dc
 2065       ; case details of
 2066          PrefixCon tyargs ps -> do { qs <- repLPs ps
 2067                                    ; ts <- repListM typeTyConName (repTy . unLoc . hsps_body) tyargs
 2068                                    ; repPcon con_str ts qs }
 2069          RecCon rec   -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)
 2070                             ; repPrec con_str fps }
 2071          InfixCon p1 p2 -> do { p1' <- repLP p1;
 2072                                 p2' <- repLP p2;
 2073                                 repPinfix p1' con_str p2' }
 2074    }
 2075  where
 2076    rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat)))
 2077    rep_fld (L _ fld) = do { MkC v <- lookupOcc (hsRecFieldSel fld)
 2078                           ; MkC p <- repLP (hfbRHS fld)
 2079                           ; rep2 fieldPatName [v,p] }
 2080 repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l
 2081                                      ; repPlit a }
 2082 repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
 2083 repP p@(NPat _ _ (Just _) _) = notHandled (ThNegativeOverloadedPatterns p)
 2084 repP (SigPat _ p t) = do { p' <- repLP p
 2085                          ; t' <- repLTy (hsPatSigType t)
 2086                          ; repPsig p' t' }
 2087 repP (SplicePat _ splice) = repSplice splice
 2088 repP other = notHandled (ThExoticPattern other)
 2089 
 2090 ----------------------------------------------------------
 2091 -- Declaration ordering helpers
 2092 
 2093 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
 2094 sort_by_loc = sortBy (SrcLoc.leftmost_smallest `on` fst)
 2095 
 2096 de_loc :: [(a, b)] -> [b]
 2097 de_loc = map snd
 2098 
 2099 ----------------------------------------------------------
 2100 --      The meta-environment
 2101 
 2102 -- A name/identifier association for fresh names of locally bound entities
 2103 type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
 2104                                 -- I.e.         (x, x_id) means
 2105                                 --      let x_id = gensym "x" in ...
 2106 
 2107 -- Generate a fresh name for a locally bound entity
 2108 
 2109 mkGenSyms :: [Name] -> MetaM [GenSymBind]
 2110 -- We can use the existing name.  For example:
 2111 --      [| \x_77 -> x_77 + x_77 |]
 2112 -- desugars to
 2113 --      do { x_77 <- genSym "x"; .... }
 2114 -- We use the same x_77 in the desugared program, but with the type Bndr
 2115 -- instead of Int
 2116 --
 2117 -- We do make it an Internal name, though (hence localiseName)
 2118 --
 2119 -- Nevertheless, it's monadic because we have to generate nameTy
 2120 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
 2121                   ; return [(nm, mkLocalId (localiseName nm) Many var_ty) | nm <- ns] }
 2122 
 2123 
 2124 addBinds :: [GenSymBind] -> MetaM a -> MetaM a
 2125 -- Add a list of fresh names for locally bound entities to the
 2126 -- meta environment (which is part of the state carried around
 2127 -- by the desugarer monad)
 2128 addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs])) m
 2129 
 2130 -- Look up a locally bound name
 2131 --
 2132 lookupNBinder :: LocatedN Name -> MetaM (Core TH.Name)
 2133 lookupNBinder n = lookupBinder (unLoc n)
 2134 
 2135 lookupBinder :: Name -> MetaM (Core TH.Name)
 2136 lookupBinder = lookupOcc
 2137   -- Binders are brought into scope before the pattern or what-not is
 2138   -- desugared.  Moreover, in instance declaration the binder of a method
 2139   -- will be the selector Id and hence a global; so we need the
 2140   -- globalVar case of lookupOcc
 2141 
 2142 -- Look up a name that is either locally bound or a global name
 2143 --
 2144 --  * If it is a global name, generate the "original name" representation (ie,
 2145 --   the <module>:<name> form) for the associated entity
 2146 --
 2147 lookupLOcc :: GenLocated l Name -> MetaM (Core TH.Name)
 2148 -- Lookup an occurrence; it can't be a splice.
 2149 -- Use the in-scope bindings if they exist
 2150 lookupLOcc n = lookupOcc (unLoc n)
 2151 
 2152 lookupOcc :: Name -> MetaM (Core TH.Name)
 2153 lookupOcc = lift . lookupOccDsM
 2154 
 2155 lookupOccDsM :: Name -> DsM (Core TH.Name)
 2156 lookupOccDsM n
 2157   = do {  mb_val <- dsLookupMetaEnv n ;
 2158           case mb_val of
 2159                 Nothing           -> globalVar n
 2160                 Just (DsBound x)  -> return (coreVar x)
 2161                 Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
 2162     }
 2163 
 2164 globalVar :: Name -> DsM (Core TH.Name)
 2165 -- Not bound by the meta-env
 2166 -- Could be top-level; or could be local
 2167 --      f x = $(g [| x |])
 2168 -- Here the x will be local
 2169 globalVar name
 2170   | isExternalName name
 2171   = do  { MkC mod <- coreStringLit name_mod
 2172         ; MkC pkg <- coreStringLit name_pkg
 2173         ; MkC occ <- nameLit name
 2174         ; rep2_nwDsM mk_varg [pkg,mod,occ] }
 2175   | otherwise
 2176   = do  { MkC occ <- nameLit name
 2177         ; platform <- targetPlatform <$> getDynFlags
 2178         ; let uni = mkIntegerExpr platform (toInteger $ getKey (getUnique name))
 2179         ; rep2_nwDsM mkNameLName [occ,uni] }
 2180   where
 2181       mod = assert (isExternalName name) nameModule name
 2182       name_mod = moduleNameString (moduleName mod)
 2183       name_pkg = unitString (moduleUnit mod)
 2184       name_occ = nameOccName name
 2185       mk_varg | isDataOcc name_occ = mkNameG_dName
 2186               | isVarOcc  name_occ = mkNameG_vName
 2187               | isTcOcc   name_occ = mkNameG_tcName
 2188               | otherwise          = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name)
 2189 
 2190 lookupType :: Name      -- Name of type constructor (e.g. (M TH.Exp))
 2191            -> MetaM Type  -- The type
 2192 lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ;
 2193                           return (mkTyConApp tc []) }
 2194 
 2195 wrapGenSyms :: [GenSymBind]
 2196             -> Core (M a) -> MetaM (Core (M a))
 2197 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
 2198 --      --> bindQ (gensym nm1) (\ id1 ->
 2199 --          bindQ (gensym nm2 (\ id2 ->
 2200 --          y))
 2201 
 2202 wrapGenSyms binds body@(MkC b)
 2203   = do  { var_ty <- lookupType nameTyConName
 2204         ; go var_ty binds }
 2205   where
 2206     (_, elt_ty) = tcSplitAppTy (exprType b)
 2207         -- b :: m a, so we can get the type 'a' by looking at the
 2208         -- argument type. Need to use `tcSplitAppTy` here as since
 2209         -- the overloaded quotations patch the type of the expression can
 2210         -- be something more complicated than just `Q a`.
 2211         -- See #17839 for when this went wrong with the type `WriterT () m a`
 2212 
 2213     go _ [] = return body
 2214     go var_ty ((name,id) : binds)
 2215       = do { MkC body'  <- go var_ty binds
 2216            ; lit_str    <- lift $ nameLit name
 2217            ; gensym_app <- repGensym lit_str
 2218            ; repBindM var_ty elt_ty
 2219                       gensym_app (MkC (Lam id body')) }
 2220 
 2221 nameLit :: Name -> DsM (Core String)
 2222 nameLit n = coreStringLit (occNameString (nameOccName n))
 2223 
 2224 occNameLit :: OccName -> MetaM (Core String)
 2225 occNameLit name = coreStringLit (occNameString name)
 2226 
 2227 
 2228 -- %*********************************************************************
 2229 -- %*                                                                   *
 2230 --              Constructing code
 2231 -- %*                                                                   *
 2232 -- %*********************************************************************
 2233 
 2234 -----------------------------------------------------------------------------
 2235 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
 2236 -- we invent a new datatype which uses phantom types.
 2237 
 2238 newtype Core a = MkC CoreExpr
 2239 unC :: Core a -> CoreExpr
 2240 unC (MkC x) = x
 2241 
 2242 type family NotM a where
 2243   NotM (M _) = TypeError ('Text ("rep2_nw must not produce something of overloaded type"))
 2244   NotM _other = (() :: Constraint)
 2245 
 2246 rep2M :: Name -> [CoreExpr] -> MetaM (Core (M a))
 2247 rep2 :: Name -> [CoreExpr] -> MetaM (Core (M a))
 2248 rep2_nw :: NotM a => Name -> [CoreExpr] -> MetaM (Core a)
 2249 rep2_nwDsM :: NotM a => Name -> [CoreExpr] -> DsM (Core a)
 2250 rep2 = rep2X lift (asks quoteWrapper)
 2251 rep2M = rep2X lift (asks monadWrapper)
 2252 rep2_nw n xs = lift (rep2_nwDsM n xs)
 2253 rep2_nwDsM = rep2X id (return id)
 2254 
 2255 rep2X :: Monad m => (forall z . DsM z -> m z)
 2256       -> m (CoreExpr -> CoreExpr)
 2257       -> Name
 2258       -> [ CoreExpr ]
 2259       -> m (Core a)
 2260 rep2X lift_dsm get_wrap n xs = do
 2261   { rep_id <- lift_dsm $ dsLookupGlobalId n
 2262   ; wrap <- get_wrap
 2263   ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) }
 2264 
 2265 
 2266 dataCon' :: Name -> [CoreExpr] -> MetaM (Core a)
 2267 dataCon' n args = do { id <- lift $ dsLookupDataCon n
 2268                      ; return $ MkC $ mkCoreConApps id args }
 2269 
 2270 dataCon :: Name -> MetaM (Core a)
 2271 dataCon n = dataCon' n []
 2272 
 2273 
 2274 -- %*********************************************************************
 2275 -- %*                                                                   *
 2276 --              The 'smart constructors'
 2277 -- %*                                                                   *
 2278 -- %*********************************************************************
 2279 
 2280 --------------- Patterns -----------------
 2281 repPlit   :: Core TH.Lit -> MetaM (Core (M TH.Pat))
 2282 repPlit (MkC l) = rep2 litPName [l]
 2283 
 2284 repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat))
 2285 repPvar (MkC s) = rep2 varPName [s]
 2286 
 2287 repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
 2288 repPtup (MkC ps) = rep2 tupPName [ps]
 2289 
 2290 repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
 2291 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
 2292 
 2293 repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat))
 2294 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
 2295 repPunboxedSum (MkC p) alt arity
 2296  = do { platform <- getPlatform
 2297       ; rep2 unboxedSumPName [ p
 2298                              , mkIntExprInt platform alt
 2299                              , mkIntExprInt platform arity ] }
 2300 
 2301 repPcon   :: Core TH.Name -> Core [(M TH.Type)] -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
 2302 repPcon (MkC s) (MkC ts) (MkC ps) = rep2 conPName [s, ts, ps]
 2303 
 2304 repPrec   :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat))
 2305 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
 2306 
 2307 repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
 2308 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
 2309 
 2310 repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
 2311 repPtilde (MkC p) = rep2 tildePName [p]
 2312 
 2313 repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
 2314 repPbang (MkC p) = rep2 bangPName [p]
 2315 
 2316 repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
 2317 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
 2318 
 2319 repPwild  :: MetaM (Core (M TH.Pat))
 2320 repPwild = rep2 wildPName []
 2321 
 2322 repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
 2323 repPlist (MkC ps) = rep2 listPName [ps]
 2324 
 2325 repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
 2326 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
 2327 
 2328 repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat))
 2329 repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
 2330 
 2331 --------------- Expressions -----------------
 2332 repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp))
 2333 repVarOrCon vc str
 2334     | isVarNameSpace ns = repVar str  -- Both type and term variables (#18740)
 2335     | otherwise         = repCon str
 2336   where
 2337     ns = nameNameSpace vc
 2338 
 2339 repVar :: Core TH.Name -> MetaM (Core (M TH.Exp))
 2340 repVar (MkC s) = rep2 varEName [s]
 2341 
 2342 repCon :: Core TH.Name -> MetaM (Core (M TH.Exp))
 2343 repCon (MkC s) = rep2 conEName [s]
 2344 
 2345 repLit :: Core TH.Lit -> MetaM (Core (M TH.Exp))
 2346 repLit (MkC c) = rep2 litEName [c]
 2347 
 2348 repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2349 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
 2350 
 2351 repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
 2352 repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
 2353 
 2354 repLam :: Core [(M TH.Pat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2355 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
 2356 
 2357 repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
 2358 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
 2359 
 2360 repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
 2361 repTup (MkC es) = rep2 tupEName [es]
 2362 
 2363 repUnboxedTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
 2364 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
 2365 
 2366 repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp))
 2367 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
 2368 repUnboxedSum (MkC e) alt arity
 2369  = do { platform <- getPlatform
 2370       ; rep2 unboxedSumEName [ e
 2371                              , mkIntExprInt platform alt
 2372                              , mkIntExprInt platform arity ] }
 2373 
 2374 repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2375 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
 2376 
 2377 repMultiIf :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Exp))
 2378 repMultiIf (MkC alts) = rep2 multiIfEName [alts]
 2379 
 2380 repLetE :: Core [(M TH.Dec)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2381 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
 2382 
 2383 repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
 2384 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
 2385 
 2386 repDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
 2387 repDoE = repDoBlock doEName
 2388 
 2389 repMDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
 2390 repMDoE = repDoBlock mdoEName
 2391 
 2392 repDoBlock :: Name -> Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
 2393 repDoBlock doName maybeModName (MkC ss) = do
 2394     MkC coreModName <- coreModNameM
 2395     rep2 doName [coreModName, ss]
 2396   where
 2397     coreModNameM :: MetaM (Core (Maybe TH.ModName))
 2398     coreModNameM = case maybeModName of
 2399       Just m -> do
 2400         MkC s <- coreStringLit (moduleNameString m)
 2401         mName <- rep2_nw mkModNameName [s]
 2402         coreJust modNameTyConName mName
 2403       _ -> coreNothing modNameTyConName
 2404 
 2405 repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
 2406 repComp (MkC ss) = rep2 compEName [ss]
 2407 
 2408 repListExp :: Core [(M TH.Exp)] -> MetaM (Core (M TH.Exp))
 2409 repListExp (MkC es) = rep2 listEName [es]
 2410 
 2411 repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
 2412 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
 2413 
 2414 repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp))
 2415 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
 2416 
 2417 repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp))
 2418 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
 2419 
 2420 repFieldExp :: Core TH.Name -> Core (M TH.Exp) -> MetaM (Core (M TH.FieldExp))
 2421 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
 2422 
 2423 repInfixApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2424 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
 2425 
 2426 repSectionL :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2427 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
 2428 
 2429 repSectionR :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2430 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
 2431 
 2432 repImplicitParamVar :: Core String -> MetaM (Core (M TH.Exp))
 2433 repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
 2434 
 2435 ------------ Right hand sides (guarded expressions) ----
 2436 repGuarded :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Body))
 2437 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
 2438 
 2439 repNormal :: Core (M TH.Exp) -> MetaM (Core (M TH.Body))
 2440 repNormal (MkC e) = rep2 normalBName [e]
 2441 
 2442 ------------ Guards ----
 2443 repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
 2444              -> MetaM (Core (M (TH.Guard, TH.Exp)))
 2445 repLNormalGE g e = do g' <- repLE g
 2446                       e' <- repLE e
 2447                       repNormalGE g' e'
 2448 
 2449 repNormalGE :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))
 2450 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
 2451 
 2452 repPatGE :: Core [(M TH.Stmt)] -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))
 2453 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
 2454 
 2455 ------------- Stmts -------------------
 2456 repBindSt :: Core (M TH.Pat) -> Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))
 2457 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
 2458 
 2459 repLetSt :: Core [(M TH.Dec)] -> MetaM (Core (M TH.Stmt))
 2460 repLetSt (MkC ds) = rep2 letSName [ds]
 2461 
 2462 repNoBindSt :: Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))
 2463 repNoBindSt (MkC e) = rep2 noBindSName [e]
 2464 
 2465 repParSt :: Core [[(M TH.Stmt)]] -> MetaM (Core (M TH.Stmt))
 2466 repParSt (MkC sss) = rep2 parSName [sss]
 2467 
 2468 repRecSt :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Stmt))
 2469 repRecSt (MkC ss) = rep2 recSName [ss]
 2470 
 2471 -------------- Range (Arithmetic sequences) -----------
 2472 repFrom :: Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2473 repFrom (MkC x) = rep2 fromEName [x]
 2474 
 2475 repFromThen :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2476 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
 2477 
 2478 repFromTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2479 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
 2480 
 2481 repFromThenTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
 2482 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
 2483 
 2484 ------------ Match and Clause Tuples -----------
 2485 repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match))
 2486 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
 2487 
 2488 repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause))
 2489 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
 2490 
 2491 -------------- Dec -----------------------------
 2492 repVal :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
 2493 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
 2494 
 2495 repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec))
 2496 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
 2497 
 2498 repData :: Core (M TH.Cxt) -> Core TH.Name
 2499         -> Either (Core [(M (TH.TyVarBndr ()))])
 2500                   (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
 2501         -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause]
 2502         -> MetaM (Core (M TH.Dec))
 2503 repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
 2504   = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
 2505 repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
 2506         (MkC derivs)
 2507   = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
 2508 
 2509 repNewtype :: Core (M TH.Cxt) -> Core TH.Name
 2510            -> Either (Core [(M (TH.TyVarBndr ()))])
 2511                      (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
 2512            -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause]
 2513            -> MetaM (Core (M TH.Dec))
 2514 repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
 2515            (MkC derivs)
 2516   = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
 2517 repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
 2518            (MkC derivs)
 2519   = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
 2520 
 2521 repTySyn :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
 2522          -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
 2523 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
 2524   = rep2 tySynDName [nm, tvs, rhs]
 2525 
 2526 repInst :: Core (Maybe TH.Overlap) ->
 2527            Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
 2528 repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
 2529                                                               [o, cxt, ty, ds]
 2530 
 2531 repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
 2532                  -> (Core (Maybe (M TH.DerivStrategy)) -> MetaM (Core (M a)))
 2533                  -> MetaM (Core (M a))
 2534 repDerivStrategy mds thing_inside =
 2535   case mds of
 2536     Nothing -> thing_inside =<< nothing
 2537     Just ds ->
 2538       case unLoc ds of
 2539         StockStrategy    _ -> thing_inside =<< just =<< repStockStrategy
 2540         AnyclassStrategy _ -> thing_inside =<< just =<< repAnyclassStrategy
 2541         NewtypeStrategy  _ -> thing_inside =<< just =<< repNewtypeStrategy
 2542         ViaStrategy ty     -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $
 2543                               do ty' <- rep_ty_sig' ty
 2544                                  via_strat <- repViaStrategy ty'
 2545                                  m_via_strat <- just via_strat
 2546                                  thing_inside m_via_strat
 2547   where
 2548   nothing = coreNothingM derivStrategyTyConName
 2549   just    = coreJustM    derivStrategyTyConName
 2550 
 2551 repStockStrategy :: MetaM (Core (M TH.DerivStrategy))
 2552 repStockStrategy = rep2 stockStrategyName []
 2553 
 2554 repAnyclassStrategy :: MetaM (Core (M TH.DerivStrategy))
 2555 repAnyclassStrategy = rep2 anyclassStrategyName []
 2556 
 2557 repNewtypeStrategy :: MetaM (Core (M TH.DerivStrategy))
 2558 repNewtypeStrategy = rep2 newtypeStrategyName []
 2559 
 2560 repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy))
 2561 repViaStrategy (MkC t) = rep2 viaStrategyName [t]
 2562 
 2563 repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap))
 2564 repOverlap mb =
 2565   case mb of
 2566     Nothing -> nothing
 2567     Just o ->
 2568       case o of
 2569         NoOverlap _    -> nothing
 2570         Overlappable _ -> just =<< dataCon overlappableDataConName
 2571         Overlapping _  -> just =<< dataCon overlappingDataConName
 2572         Overlaps _     -> just =<< dataCon overlapsDataConName
 2573         Incoherent _   -> just =<< dataCon incoherentDataConName
 2574   where
 2575   nothing = coreNothing overlapTyConName
 2576   just    = coreJust overlapTyConName
 2577 
 2578 
 2579 repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
 2580          -> Core [TH.FunDep] -> Core [(M TH.Dec)]
 2581          -> MetaM (Core (M TH.Dec))
 2582 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
 2583   = rep2 classDName [cxt, cls, tvs, fds, ds]
 2584 
 2585 repDeriv :: Core (Maybe (M TH.DerivStrategy))
 2586          -> Core (M TH.Cxt) -> Core (M TH.Type)
 2587          -> MetaM (Core (M TH.Dec))
 2588 repDeriv (MkC ds) (MkC cxt) (MkC ty)
 2589   = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
 2590 
 2591 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
 2592            -> Core TH.Phases -> MetaM (Core (M TH.Dec))
 2593 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
 2594   = rep2 pragInlDName [nm, inline, rm, phases]
 2595 
 2596 repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases
 2597             -> MetaM (Core (M TH.Dec))
 2598 repPragSpec (MkC nm) (MkC ty) (MkC phases)
 2599   = rep2 pragSpecDName [nm, ty, phases]
 2600 
 2601 repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline
 2602                -> Core TH.Phases -> MetaM (Core (M TH.Dec))
 2603 repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
 2604   = rep2 pragSpecInlDName [nm, ty, inline, phases]
 2605 
 2606 repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec))
 2607 repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
 2608 
 2609 repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec))
 2610 repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
 2611 
 2612 repPragRule :: Core String -> Core (Maybe [(M (TH.TyVarBndr ()))])
 2613             -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp)
 2614             -> Core TH.Phases -> MetaM (Core (M TH.Dec))
 2615 repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
 2616   = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
 2617 
 2618 repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
 2619 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
 2620 
 2621 repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec))
 2622 repTySynInst (MkC eqn)
 2623     = rep2 tySynInstDName [eqn]
 2624 
 2625 repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
 2626                -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec))
 2627 repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
 2628     = rep2 dataFamilyDName [nm, tvs, kind]
 2629 
 2630 repOpenFamilyD :: Core TH.Name
 2631                -> Core [(M (TH.TyVarBndr ()))]
 2632                -> Core (M TH.FamilyResultSig)
 2633                -> Core (Maybe TH.InjectivityAnn)
 2634                -> MetaM (Core (M TH.Dec))
 2635 repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
 2636     = rep2 openTypeFamilyDName [nm, tvs, result, inj]
 2637 
 2638 repClosedFamilyD :: Core TH.Name
 2639                  -> Core [(M (TH.TyVarBndr ()))]
 2640                  -> Core (M TH.FamilyResultSig)
 2641                  -> Core (Maybe TH.InjectivityAnn)
 2642                  -> Core [(M TH.TySynEqn)]
 2643                  -> MetaM (Core (M TH.Dec))
 2644 repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
 2645     = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
 2646 
 2647 repTySynEqn :: Core (Maybe [(M (TH.TyVarBndr ()))]) ->
 2648                Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn))
 2649 repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
 2650   = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
 2651 
 2652 repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> MetaM (Core (M TH.Dec))
 2653 repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
 2654 
 2655 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> MetaM (Core TH.FunDep)
 2656 repFunDep (MkC xs) (MkC ys) = rep2_nw funDepName [xs, ys]
 2657 
 2658 repProto :: Name -> Core TH.Name -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
 2659 repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
 2660 
 2661 repImplicitParamBind :: Core String -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
 2662 repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
 2663 
 2664 repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt))
 2665 repCtxt (MkC tys) = rep2 cxtName [tys]
 2666 
 2667 repH98DataCon :: LocatedN Name
 2668               -> HsConDeclH98Details GhcRn
 2669               -> MetaM (Core (M TH.Con))
 2670 repH98DataCon con details
 2671     = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
 2672          case details of
 2673            PrefixCon _ ps -> do
 2674              arg_tys <- repPrefixConArgs ps
 2675              rep2 normalCName [unC con', unC arg_tys]
 2676            InfixCon st1 st2 -> do
 2677              verifyLinearConstructors [st1, st2]
 2678              arg1 <- repBangTy (hsScaledThing st1)
 2679              arg2 <- repBangTy (hsScaledThing st2)
 2680              rep2 infixCName [unC arg1, unC con', unC arg2]
 2681            RecCon ips -> do
 2682              arg_vtys <- repRecConArgs ips
 2683              rep2 recCName [unC con', unC arg_vtys]
 2684 
 2685 repGadtDataCons :: [LocatedN Name]
 2686                 -> HsConDeclGADTDetails GhcRn
 2687                 -> LHsType GhcRn
 2688                 -> MetaM (Core (M TH.Con))
 2689 repGadtDataCons cons details res_ty
 2690     = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
 2691          case details of
 2692            PrefixConGADT ps -> do
 2693              arg_tys <- repPrefixConArgs ps
 2694              res_ty' <- repLTy res_ty
 2695              rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty']
 2696            RecConGADT ips _ -> do
 2697              arg_vtys <- repRecConArgs ips
 2698              res_ty'  <- repLTy res_ty
 2699              rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys,
 2700                                 unC res_ty']
 2701 
 2702 -- TH currently only supports linear constructors.
 2703 -- We also accept the (->) arrow when -XLinearTypes is off, because this
 2704 -- denotes a linear field.
 2705 -- This check is not performed in repRecConArgs, since the GADT record
 2706 -- syntax currently does not have a way to mark fields as nonlinear.
 2707 verifyLinearConstructors :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM ()
 2708 verifyLinearConstructors ps = do
 2709   linear <- lift $ xoptM LangExt.LinearTypes
 2710   let allGood = all (\st -> case hsMult st of
 2711                               HsUnrestrictedArrow _ -> not linear
 2712                               HsLinearArrow _       -> True
 2713                               _                     -> False) ps
 2714   unless allGood $ notHandled ThNonLinearDataCon
 2715 
 2716 -- Desugar the arguments in a data constructor declared with prefix syntax.
 2717 repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]
 2718                  -> MetaM (Core [M TH.BangType])
 2719 repPrefixConArgs ps = do
 2720   verifyLinearConstructors ps
 2721   repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
 2722 
 2723 -- Desugar the arguments in a data constructor declared with record syntax.
 2724 repRecConArgs :: LocatedL [LConDeclField GhcRn]
 2725               -> MetaM (Core [M TH.VarBangType])
 2726 repRecConArgs ips = do
 2727   args     <- concatMapM rep_ip (unLoc ips)
 2728   coreListM varBangTypeTyConName args
 2729     where
 2730       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
 2731 
 2732       rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
 2733       rep_one_ip t n = do { MkC v  <- lookupOcc (foExt $ unLoc n)
 2734                           ; MkC ty <- repBangTy  t
 2735                           ; rep2 varBangTypeName [v,ty] }
 2736 
 2737 ------------ Types -------------------
 2738 
 2739 repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type)
 2740            -> MetaM (Core (M TH.Type))
 2741 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
 2742     = rep2 forallTName [tvars, ctxt, ty]
 2743 
 2744 repTForallVis :: Core [(M (TH.TyVarBndr ()))] -> Core (M TH.Type)
 2745               -> MetaM (Core (M TH.Type))
 2746 repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]
 2747 
 2748 repTvar :: Core TH.Name -> MetaM (Core (M TH.Type))
 2749 repTvar (MkC s) = rep2 varTName [s]
 2750 
 2751 repTapp :: Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.Type))
 2752 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
 2753 
 2754 repTappKind :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))
 2755 repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]
 2756 
 2757 repTapps :: Core (M TH.Type) -> [Core (M TH.Type)] -> MetaM (Core (M TH.Type))
 2758 repTapps f []     = return f
 2759 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
 2760 
 2761 repTSig :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))
 2762 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
 2763 
 2764 repTequality :: MetaM (Core (M TH.Type))
 2765 repTequality = rep2 equalityTName []
 2766 
 2767 repTPromotedList :: [Core (M TH.Type)] -> MetaM (Core (M TH.Type))
 2768 repTPromotedList []     = repPromotedNilTyCon
 2769 repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon
 2770                               ; f <- repTapp tcon t
 2771                               ; t' <- repTPromotedList ts
 2772                               ; repTapp f t'
 2773                               }
 2774 
 2775 repTLit :: Core (M TH.TyLit) -> MetaM (Core (M TH.Type))
 2776 repTLit (MkC lit) = rep2 litTName [lit]
 2777 
 2778 repTWildCard :: MetaM (Core (M TH.Type))
 2779 repTWildCard = rep2 wildCardTName []
 2780 
 2781 repTImplicitParam :: Core String -> Core (M TH.Type) -> MetaM (Core (M TH.Type))
 2782 repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
 2783 
 2784 repTStar :: MetaM (Core (M TH.Type))
 2785 repTStar = rep2 starKName []
 2786 
 2787 repTConstraint :: MetaM (Core (M TH.Type))
 2788 repTConstraint = rep2 constraintKName []
 2789 
 2790 --------- Type constructors --------------
 2791 
 2792 repNamedTyCon :: Core TH.Name -> MetaM (Core (M TH.Type))
 2793 repNamedTyCon (MkC s) = rep2 conTName [s]
 2794 
 2795 repTInfix :: Core (M TH.Type) -> Core TH.Name -> Core (M TH.Type)
 2796              -> MetaM (Core (M TH.Type))
 2797 repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]
 2798 
 2799 repTupleTyCon :: Int -> MetaM (Core (M TH.Type))
 2800 -- Note: not Core Int; it's easier to be direct here
 2801 repTupleTyCon i = do platform <- getPlatform
 2802                      rep2 tupleTName [mkIntExprInt platform i]
 2803 
 2804 repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type))
 2805 -- Note: not Core Int; it's easier to be direct here
 2806 repUnboxedTupleTyCon i = do platform <- getPlatform
 2807                             rep2 unboxedTupleTName [mkIntExprInt platform i]
 2808 
 2809 repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type))
 2810 -- Note: not Core TH.SumArity; it's easier to be direct here
 2811 repUnboxedSumTyCon arity = do platform <- getPlatform
 2812                               rep2 unboxedSumTName [mkIntExprInt platform arity]
 2813 
 2814 repArrowTyCon :: MetaM (Core (M TH.Type))
 2815 repArrowTyCon = rep2 arrowTName []
 2816 
 2817 repMulArrowTyCon :: MetaM (Core (M TH.Type))
 2818 repMulArrowTyCon = rep2 mulArrowTName []
 2819 
 2820 repListTyCon :: MetaM (Core (M TH.Type))
 2821 repListTyCon = rep2 listTName []
 2822 
 2823 repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type))
 2824 repPromotedDataCon (MkC s) = rep2 promotedTName [s]
 2825 
 2826 repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type))
 2827 repPromotedTupleTyCon i = do platform <- getPlatform
 2828                              rep2 promotedTupleTName [mkIntExprInt platform i]
 2829 
 2830 repPromotedNilTyCon :: MetaM (Core (M TH.Type))
 2831 repPromotedNilTyCon = rep2 promotedNilTName []
 2832 
 2833 repPromotedConsTyCon :: MetaM (Core (M TH.Type))
 2834 repPromotedConsTyCon = rep2 promotedConsTName []
 2835 
 2836 ----------------------------------------------------------
 2837 --       Type family result signature
 2838 
 2839 repNoSig :: MetaM (Core (M TH.FamilyResultSig))
 2840 repNoSig = rep2 noSigName []
 2841 
 2842 repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig))
 2843 repKindSig (MkC ki) = rep2 kindSigName [ki]
 2844 
 2845 repTyVarSig :: Core (M (TH.TyVarBndr ())) -> MetaM (Core (M TH.FamilyResultSig))
 2846 repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
 2847 
 2848 ----------------------------------------------------------
 2849 --              Literals
 2850 
 2851 repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)
 2852 repLiteral (HsStringPrim _ bs)
 2853   = do word8_ty <- lookupType word8TyConName
 2854        let w8s = unpack bs
 2855            w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
 2856                                   [mkWord8Lit (toInteger w8)]) w8s
 2857        rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr]
 2858 repLiteral lit
 2859   = do lit' <- case lit of
 2860                    HsIntPrim _ i    -> mk_integer i
 2861                    HsWordPrim _ w   -> mk_integer w
 2862                    HsInt _ i        -> mk_integer (il_value i)
 2863                    HsFloatPrim _ r  -> mk_rational r
 2864                    HsDoublePrim _ r -> mk_rational r
 2865                    HsCharPrim _ c   -> mk_char c
 2866                    _ -> return lit
 2867        lit_expr <- lift $ dsLit lit'
 2868        case mb_lit_name of
 2869           Just lit_name -> rep2_nw lit_name [lit_expr]
 2870           Nothing -> notHandled (ThExoticLiteral lit)
 2871   where
 2872     mb_lit_name = case lit of
 2873                  HsInteger _ _ _  -> Just integerLName
 2874                  HsInt _ _        -> Just integerLName
 2875                  HsIntPrim _ _    -> Just intPrimLName
 2876                  HsWordPrim _ _   -> Just wordPrimLName
 2877                  HsFloatPrim _ _  -> Just floatPrimLName
 2878                  HsDoublePrim _ _ -> Just doublePrimLName
 2879                  HsChar _ _       -> Just charLName
 2880                  HsCharPrim _ _   -> Just charPrimLName
 2881                  HsString _ _     -> Just stringLName
 2882                  HsRat _ _ _      -> Just rationalLName
 2883                  _                -> Nothing
 2884 
 2885 mk_integer :: Integer -> MetaM (HsLit GhcRn)
 2886 mk_integer  i = return $ HsInteger NoSourceText i integerTy
 2887 
 2888 mk_rational :: FractionalLit -> MetaM (HsLit GhcRn)
 2889 mk_rational r = do rat_ty <- lookupType rationalTyConName
 2890                    return $ HsRat noExtField r rat_ty
 2891 mk_string :: FastString -> MetaM (HsLit GhcRn)
 2892 mk_string s = return $ HsString NoSourceText s
 2893 
 2894 mk_char :: Char -> MetaM (HsLit GhcRn)
 2895 mk_char c = return $ HsChar NoSourceText c
 2896 
 2897 repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit)
 2898 repOverloadedLiteral (OverLit { ol_val = val})
 2899   = do { lit <- mk_lit val; repLiteral lit }
 2900         -- The type Rational will be in the environment, because
 2901         -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
 2902         -- and rationalL is sucked in when any TH stuff is used
 2903 
 2904 mk_lit :: OverLitVal -> MetaM (HsLit GhcRn)
 2905 mk_lit (HsIntegral i)     = mk_integer  (il_value i)
 2906 mk_lit (HsFractional f)   = mk_rational f
 2907 mk_lit (HsIsString _ s)   = mk_string   s
 2908 
 2909 repNameS :: Core String -> MetaM (Core TH.Name)
 2910 repNameS (MkC name) = rep2_nw mkNameSName [name]
 2911 
 2912 --------------- Miscellaneous -------------------
 2913 
 2914 repGensym :: Core String -> MetaM (Core (M TH.Name))
 2915 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
 2916 
 2917 repBindM :: Type -> Type        -- a and b
 2918          -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b))
 2919 repBindM ty_a ty_b (MkC x) (MkC y)
 2920   = rep2M bindMName [Type ty_a, Type ty_b, x, y]
 2921 
 2922 repSequenceM :: Type -> Core [M a] -> MetaM (Core (M [a]))
 2923 repSequenceM ty_a (MkC list)
 2924   = rep2M sequenceQName [Type ty_a, list]
 2925 
 2926 repUnboundVar :: Core TH.Name -> MetaM (Core (M TH.Exp))
 2927 repUnboundVar (MkC name) = rep2 unboundVarEName [name]
 2928 
 2929 repOverLabel :: FastString -> MetaM (Core (M TH.Exp))
 2930 repOverLabel fs = do
 2931                     (MkC s) <- coreStringLit $ unpackFS fs
 2932                     rep2 labelEName [s]
 2933 
 2934 repGetField :: Core (M TH.Exp) -> FastString -> MetaM (Core (M TH.Exp))
 2935 repGetField (MkC exp) fs = do
 2936   MkC s <- coreStringLit $ unpackFS fs
 2937   rep2 getFieldEName [exp,s]
 2938 
 2939 repProjection :: [FastString] -> MetaM (Core (M TH.Exp))
 2940 repProjection fs = do
 2941   MkC xs <- coreList' stringTy <$> mapM (coreStringLit . unpackFS) fs
 2942   rep2 projectionEName [xs]
 2943 
 2944 ------------ Lists -------------------
 2945 -- turn a list of patterns into a single pattern matching a list
 2946 
 2947 repList :: Name -> (a  -> MetaM (Core b))
 2948                     -> [a] -> MetaM (Core [b])
 2949 repList tc_name f args
 2950   = do { args1 <- mapM f args
 2951        ; coreList tc_name args1 }
 2952 
 2953 -- Create a list of m a values
 2954 repListM :: Name -> (a  -> MetaM (Core b))
 2955                     -> [a] -> MetaM (Core [b])
 2956 repListM tc_name f args
 2957   = do { ty <- wrapName tc_name
 2958        ; args1 <- mapM f args
 2959        ; return $ coreList' ty args1 }
 2960 
 2961 coreListM :: Name -> [Core a] -> MetaM (Core [a])
 2962 coreListM tc as = repListM tc return as
 2963 
 2964 coreList :: Name    -- Of the TyCon of the element type
 2965          -> [Core a] -> MetaM (Core [a])
 2966 coreList tc_name es
 2967   = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
 2968 
 2969 coreList' :: Type       -- The element type
 2970           -> [Core a] -> Core [a]
 2971 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
 2972 
 2973 nonEmptyCoreList :: [Core a] -> Core [a]
 2974   -- The list must be non-empty so we can get the element type
 2975   -- Otherwise use coreList
 2976 nonEmptyCoreList []           = panic "coreList: empty argument"
 2977 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
 2978 
 2979 
 2980 coreStringLit :: MonadThings m => String -> m (Core String)
 2981 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
 2982 
 2983 ------------------- Maybe ------------------
 2984 
 2985 repMaybe :: Name -> (a -> MetaM (Core b))
 2986                     -> Maybe a -> MetaM (Core (Maybe b))
 2987 repMaybe tc_name f m = do
 2988   t <- lookupType tc_name
 2989   repMaybeT t f m
 2990 
 2991 repMaybeT :: Type -> (a -> MetaM (Core b))
 2992                     -> Maybe a -> MetaM (Core (Maybe b))
 2993 repMaybeT ty _ Nothing   = return $ coreNothing' ty
 2994 repMaybeT ty f (Just es) = coreJust' ty <$> f es
 2995 
 2996 -- | Construct Core expression for Nothing of a given type name
 2997 coreNothing :: Name        -- ^ Name of the TyCon of the element type
 2998             -> MetaM (Core (Maybe a))
 2999 coreNothing tc_name =
 3000     do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
 3001 
 3002 coreNothingM :: Name -> MetaM (Core (Maybe a))
 3003 coreNothingM tc_name =
 3004     do { elt_ty <- wrapName tc_name; return (coreNothing' elt_ty) }
 3005 
 3006 -- | Construct Core expression for Nothing of a given type
 3007 coreNothing' :: Type       -- ^ The element type
 3008              -> Core (Maybe a)
 3009 coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
 3010 
 3011 -- | Store given Core expression in a Just of a given type name
 3012 coreJust :: Name        -- ^ Name of the TyCon of the element type
 3013          -> Core a -> MetaM (Core (Maybe a))
 3014 coreJust tc_name es
 3015   = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
 3016 
 3017 coreJustM :: Name -> Core a -> MetaM (Core (Maybe a))
 3018 coreJustM tc_name es = do { elt_ty <- wrapName tc_name; return (coreJust' elt_ty es) }
 3019 
 3020 -- | Store given Core expression in a Just of a given type
 3021 coreJust' :: Type       -- ^ The element type
 3022           -> Core a -> Core (Maybe a)
 3023 coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
 3024 
 3025 ------------------- Maybe Lists ------------------
 3026 
 3027 coreJustList :: Type -> Core [a] -> Core (Maybe [a])
 3028 coreJustList elt_ty = coreJust' (mkListTy elt_ty)
 3029 
 3030 coreNothingList :: Type -> Core (Maybe [a])
 3031 coreNothingList elt_ty = coreNothing' (mkListTy elt_ty)
 3032 
 3033 ------------ Literals & Variables -------------------
 3034 
 3035 coreIntLit :: Int -> MetaM (Core Int)
 3036 coreIntLit i = do platform <- getPlatform
 3037                   return (MkC (mkIntExprInt platform i))
 3038 
 3039 coreVar :: Id -> Core TH.Name   -- The Id has type Name
 3040 coreVar id = MkC (Var id)
 3041 
 3042 ----------------- Failure -----------------------
 3043 notHandledL :: SrcSpan -> ThRejectionReason -> MetaM a
 3044 notHandledL loc reason
 3045   | isGoodSrcSpan loc
 3046   = mapReaderT (putSrcSpanDs loc) $ notHandled reason
 3047   | otherwise
 3048   = notHandled reason
 3049 
 3050 notHandled :: ThRejectionReason -> MetaM a
 3051 notHandled reason = lift $ failWithDs (DsNotYetHandledByTH reason)