{-# LANGUAGE AllowAmbiguousTypes    #-}
{-# LANGUAGE CPP                    #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PatternSynonyms        #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2006
--
-- The purpose of this module is to transform an HsExpr into a CoreExpr which
-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
-- input HsExpr. We do this in the DsM monad, which supplies access to
-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
-- in prelude/GHC.Builtin.Names.  It's much more convenient to do it here, because
-- otherwise we have to recompile GHC.Builtin.Names whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
-----------------------------------------------------------------------------

module GHC.HsToCore.Quote( dsBracket ) where

#include "HsVersions.h"

import GHC.Prelude
import GHC.Platform

import GHC.Driver.Session

import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr )
import GHC.HsToCore.Match.Literal
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds

import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH

import GHC.Hs

import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence

import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Multiplicity ( pattern Many )
import GHC.Core
import GHC.Core.Make
import GHC.Core.Utils

import GHC.Builtin.Names
import GHC.Builtin.Names.TH
import GHC.Builtin.Types

import GHC.Unit.Module

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Monad

import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.Maybe

import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique
import GHC.Types.Basic
import GHC.Types.ForeignCall
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.SourceText
import GHC.Types.Fixity
import GHC.Types.TyThing
import GHC.Types.Name hiding( varName, tcName )
import GHC.Types.Name.Env

import GHC.TypeLits
import Data.Kind (Constraint)

import qualified GHC.LanguageExtensions as LangExt

import Data.ByteString ( unpack )
import Control.Monad
import Data.List (sort, sortBy)
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Function
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class

data MetaWrappers = MetaWrappers {
      -- Applies its argument to a type argument `m` and dictionary `Quote m`
      MetaWrappers -> CoreExpr -> CoreExpr
quoteWrapper :: CoreExpr -> CoreExpr
      -- Apply its argument to a type argument `m` and a dictionary `Monad m`
    , MetaWrappers -> CoreExpr -> CoreExpr
monadWrapper :: CoreExpr -> CoreExpr
      -- Apply the container typed variable `m` to the argument type `T` to get `m T`.
    , MetaWrappers -> Type -> Type
metaTy :: Type -> Type
      -- Information about the wrappers which be printed to be inspected
    , MetaWrappers -> (HsWrapper, HsWrapper, Type)
_debugWrappers :: (HsWrapper, HsWrapper, Type)
    }

-- | Construct the functions which will apply the relevant part of the
-- QuoteWrapper to identifiers during desugaring.
mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers
mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers
mkMetaWrappers q :: QuoteWrapper
q@(QuoteWrapper Id
quote_var_raw Type
m_var) = do
      let quote_var :: CoreExpr
quote_var = forall b. Id -> Expr b
Var Id
quote_var_raw
      -- Get the superclass selector to select the Monad dictionary, going
      -- to be used to construct the monadWrapper.
      TyCon
quote_tc <- Name -> DsM TyCon
dsLookupTyCon Name
quoteClassName
      TyCon
monad_tc <- Name -> DsM TyCon
dsLookupTyCon Name
monadClassName
      let Just Class
cls = TyCon -> Maybe Class
tyConClass_maybe TyCon
quote_tc
          Just Class
monad_cls = TyCon -> Maybe Class
tyConClass_maybe TyCon
monad_tc
          -- Quote m -> Monad m
          monad_sel :: Id
monad_sel = Class -> Int -> Id
classSCSelId Class
cls Int
0

          -- Only used for the defensive assertion that the selector has
          -- the expected type
          tyvars :: [InvisTVBinder]
tyvars = DataCon -> [InvisTVBinder]
dataConUserTyVarBinders (Class -> DataCon
classDataCon Class
cls)
          expected_ty :: Type
expected_ty = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
tyvars forall a b. (a -> b) -> a -> b
$
                          Type -> Type -> Type
mkInvisFunTyMany (Class -> [Type] -> Type
mkClassPred Class
cls ([Id] -> [Type]
mkTyVarTys (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tyvars)))
                                           (Class -> [Type] -> Type
mkClassPred Class
monad_cls ([Id] -> [Type]
mkTyVarTys (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tyvars)))

      MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty)

      let m_ty :: CoreExpr
m_ty = forall b. Type -> Expr b
Type Type
m_var
          -- Construct the contents of MetaWrappers
          quoteWrapper :: HsWrapper
quoteWrapper = QuoteWrapper -> HsWrapper
applyQuoteWrapper QuoteWrapper
q
          monadWrapper :: HsWrapper
monadWrapper = [EvTerm] -> HsWrapper
mkWpEvApps [CoreExpr -> EvTerm
EvExpr forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (forall b. Id -> Expr b
Var Id
monad_sel) [CoreExpr
m_ty, CoreExpr
quote_var]] HsWrapper -> HsWrapper -> HsWrapper
<.>
                            [Type] -> HsWrapper
mkWpTyApps [Type
m_var]
          tyWrapper :: Type -> Type
tyWrapper Type
t = Type -> Type -> Type
mkAppTy Type
m_var Type
t
          debug :: (HsWrapper, HsWrapper, Type)
debug = (HsWrapper
quoteWrapper, HsWrapper
monadWrapper, Type
m_var)
      CoreExpr -> CoreExpr
q_f <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
quoteWrapper
      CoreExpr -> CoreExpr
m_f <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
monadWrapper
      forall (m :: * -> *) a. Monad m => a -> m a
return ((CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr)
-> (Type -> Type)
-> (HsWrapper, HsWrapper, Type)
-> MetaWrappers
MetaWrappers CoreExpr -> CoreExpr
q_f CoreExpr -> CoreExpr
m_f Type -> Type
tyWrapper (HsWrapper, HsWrapper, Type)
debug)

-- Turn A into m A
wrapName :: Name -> MetaM Type
wrapName :: Name -> MetaM Type
wrapName Name
n = do
  Type
t <- Name -> MetaM Type
lookupType Name
n
  Type -> Type
wrap_fn <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MetaWrappers -> Type -> Type
metaTy
  forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type
wrap_fn Type
t)

-- The local state is always the same, calculated from the passed in
-- wrapper
type MetaM a = ReaderT MetaWrappers DsM a

getPlatform :: MetaM Platform
getPlatform :: MetaM Platform
getPlatform = DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

-----------------------------------------------------------------------------
dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
          -> HsBracket GhcRn
          -> [PendingTcSplice]
          -> DsM CoreExpr
-- See Note [Desugaring Brackets]
-- Returns a CoreExpr of type (M TH.Exp)
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

dsBracket :: Maybe QuoteWrapper
-> HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
dsBracket Maybe QuoteWrapper
wrap HsBracket GhcRn
brack [PendingTcSplice]
splices
  = HsBracket GhcRn -> DsM CoreExpr
do_brack HsBracket GhcRn
brack

  where
    runOverloaded :: ReaderT MetaWrappers DsM CoreExpr -> DsM CoreExpr
runOverloaded ReaderT MetaWrappers DsM CoreExpr
act = do
      -- In the overloaded case we have to get given a wrapper, it is just
      -- for variable quotations that there is no wrapper, because they
      -- have a simple type.
      MetaWrappers
mw <- QuoteWrapper -> DsM MetaWrappers
mkMetaWrappers (forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"runOverloaded" Maybe QuoteWrapper
wrap)
      forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT (forall a. DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv DsMetaEnv
new_bit) ReaderT MetaWrappers DsM CoreExpr
act) MetaWrappers
mw


    new_bit :: DsMetaEnv
new_bit = forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name
n, HsExpr GhcTc -> DsMetaVal
DsSplice (forall l e. GenLocated l e -> e
unLoc LHsExpr GhcTc
e))
                        | PendingTcSplice Name
n LHsExpr GhcTc
e <- [PendingTcSplice]
splices]

    do_brack :: HsBracket GhcRn -> DsM CoreExpr
do_brack (VarBr XVarBr GhcRn
_ Bool
_ LIdP GhcRn
n) = do { MkC CoreExpr
e1  <- Name -> DsM (Core Name)
lookupOccDsM (forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
n) ; forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e1 }
    do_brack (ExpBr XExpBr GhcRn
_ LHsExpr GhcRn
e)   = ReaderT MetaWrappers DsM CoreExpr -> DsM CoreExpr
runOverloaded forall a b. (a -> b) -> a -> b
$ do { MkC CoreExpr
e1  <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
e     ; forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e1 }
    do_brack (PatBr XPatBr GhcRn
_ LPat GhcRn
p)   = ReaderT MetaWrappers DsM CoreExpr -> DsM CoreExpr
runOverloaded forall a b. (a -> b) -> a -> b
$ do { MkC CoreExpr
p1  <- LPat GhcRn -> MetaM (Core (M Pat))
repTopP LPat GhcRn
p   ; forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
p1 }
    do_brack (TypBr XTypBr GhcRn
_ LHsType GhcRn
t)   = ReaderT MetaWrappers DsM CoreExpr -> DsM CoreExpr
runOverloaded forall a b. (a -> b) -> a -> b
$ do { MkC CoreExpr
t1  <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
t    ; forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
t1 }
    do_brack (DecBrG XDecBrG GhcRn
_ HsGroup GhcRn
gp) = ReaderT MetaWrappers DsM CoreExpr -> DsM CoreExpr
runOverloaded forall a b. (a -> b) -> a -> b
$ do { MkC CoreExpr
ds1 <- HsGroup GhcRn -> MetaM (Core (M [Dec]))
repTopDs HsGroup GhcRn
gp ; forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
ds1 }
    do_brack (DecBrL {})   = forall a. String -> a
panic String
"dsBracket: unexpected DecBrL"
    do_brack (TExpBr XTExpBr GhcRn
_ LHsExpr GhcRn
e)  = ReaderT MetaWrappers DsM CoreExpr -> DsM CoreExpr
runOverloaded forall a b. (a -> b) -> a -> b
$ do { MkC CoreExpr
e1  <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
e     ; forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e1 }

{-
Note [Desugaring Brackets]
~~~~~~~~~~~~~~~~~~~~~~~~~~

In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie
an expression bracket was of type Q Exp. This made the desugaring process simple
as there were no complicated type variables to keep consistent throughout the
whole AST. Due to the overloaded quotations proposal a quotation bracket is now
of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been
generalised to work with any monad implementing a minimal interface.

https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst

Users can rejoice at the flexibility but now there is some additional complexity in
how brackets are desugared as all these polymorphic combinators need their arguments
instantiated.

> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD
> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR.

What the arguments should be instantiated to is supplied by the `QuoteWrapper`
datatype which is produced by `GHC.Tc.Gen.Splice`. It is a pair of an evidence variable
for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring
need to be applied to these two type variables.

There are three important functions which do the application.

1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument.
2. `rep2M` takes a function name of type `Monad m => T` as an argument
3. `rep2_nw` takes a function name without any constraints as an argument.

These functions then use the information in QuoteWrapper to apply the correct
arguments to the functions as the representation is constructed.

The `MetaM` monad carries around an environment of three functions which are
used in order to wrap the polymorphic combinators and instantiate the arguments
to the correct things.

1. quoteWrapper wraps functions of type `forall m . Quote m => T`
2. monadWrapper wraps functions of type `forall m . Monad m => T`
3. metaTy wraps a type in the polymorphic `m` variable of the whole representation.

Historical note about the implementation: At the first attempt, I attempted to
lie that the type of any quotation was `Quote m => m Exp` and then specialise it
by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was
simpler to implement but didn't work because of nested splices. For example,
you might have a nested splice of a more specific type which fixes the type of
the overall quote and so all the combinators used must also be instantiated to
that specific type. Therefore you really have to use the contents of the quote
wrapper to directly apply the right type to the combinators rather than
first generate a polymorphic definition and then just apply the wrapper at the end.

-}

{- -------------- Examples --------------------

  [| \x -> x |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (var x1)


  [| \x -> $(f [| x |]) |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (f (var x1))
-}


-------------------------------------------------------
--                      Declarations
-------------------------------------------------------

-- Proxy for the phantom type of `Core`. All the generated fragments have
-- type something like `Quote m => m Exp` so to keep things simple we represent fragments
-- of that type as `M Exp`.
data M a

repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
repTopP :: LPat GhcRn -> MetaM (Core (M Pat))
repTopP LPat GhcRn
pat = do { [GenSymBind]
ss <- [Name] -> MetaM [GenSymBind]
mkGenSyms (forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders forall p. CollectFlag p
CollNoDictBinders LPat GhcRn
pat)
                 ; Core (M Pat)
pat' <- forall a. [GenSymBind] -> MetaM a -> MetaM a
addBinds [GenSymBind]
ss (LPat GhcRn -> MetaM (Core (M Pat))
repLP LPat GhcRn
pat)
                 ; forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms [GenSymBind]
ss Core (M Pat)
pat' }

repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec]))
repTopDs :: HsGroup GhcRn -> MetaM (Core (M [Dec]))
repTopDs group :: HsGroup GhcRn
group@(HsGroup { hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds   = HsValBinds GhcRn
valds
                        , hs_splcds :: forall p. HsGroup p -> [LSpliceDecl p]
hs_splcds  = [LSpliceDecl GhcRn]
splcds
                        , hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds  = [TyClGroup GhcRn]
tyclds
                        , hs_derivds :: forall p. HsGroup p -> [LDerivDecl p]
hs_derivds = [LDerivDecl GhcRn]
derivds
                        , hs_fixds :: forall p. HsGroup p -> [LFixitySig p]
hs_fixds   = [LFixitySig GhcRn]
fixds
                        , hs_defds :: forall p. HsGroup p -> [LDefaultDecl p]
hs_defds   = [LDefaultDecl GhcRn]
defds
                        , hs_fords :: forall p. HsGroup p -> [LForeignDecl p]
hs_fords   = [LForeignDecl GhcRn]
fords
                        , hs_warnds :: forall p. HsGroup p -> [LWarnDecls p]
hs_warnds  = [LWarnDecls GhcRn]
warnds
                        , hs_annds :: forall p. HsGroup p -> [LAnnDecl p]
hs_annds   = [LAnnDecl GhcRn]
annds
                        , hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds  = [LRuleDecls GhcRn]
ruleds
                        , hs_docs :: forall p. HsGroup p -> [LDocDecl p]
hs_docs    = [LDocDecl GhcRn]
docs })
 = do { let { bndrs :: [Name]
bndrs  = HsValBinds GhcRn -> [Name]
hsScopedTvBinders HsValBinds GhcRn
valds
                       forall a. [a] -> [a] -> [a]
++ HsGroup GhcRn -> [Name]
hsGroupBinders HsGroup GhcRn
group
                       forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall pass. FieldOcc pass -> XCFieldOcc pass
extFieldOcc (forall (p :: Pass).
IsPass p =>
HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)]
hsPatSynSelectors HsValBinds GhcRn
valds)
            ; instds :: [GenLocated SrcSpanAnnA (InstDecl GhcRn)]
instds = [TyClGroup GhcRn]
tyclds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds } ;
        [GenSymBind]
ss <- [Name] -> MetaM [GenSymBind]
mkGenSyms [Name]
bndrs ;

        -- Bind all the names mainly to avoid repeated use of explicit strings.
        -- Thus we get
        --      do { t :: String <- genSym "T" ;
        --           return (Data t [] ...more t's... }
        -- The other important reason is that the output must mention
        -- only "T", not "Foo:T" where Foo is the current module

        [Core (M Dec)]
decls <- forall a. [GenSymBind] -> MetaM a -> MetaM a
addBinds [GenSymBind]
ss (
                  do { [(SrcSpan, Core (M Dec))]
val_ds   <- HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M Dec))]
rep_val_binds HsValBinds GhcRn
valds
                     ; [Any]
_        <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a} {e} {a}. GenLocated (SrcSpanAnn' a) e -> MetaM a
no_splice [LSpliceDecl GhcRn]
splcds
                     ; [Maybe (SrcSpan, Core (M Dec))]
tycl_ds  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M Dec)))
repTyClD (forall pass. [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls [TyClGroup GhcRn]
tyclds)
                     ; [(SrcSpan, Core (M Dec))]
role_ds  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repRoleD (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall pass. TyClGroup pass -> [LRoleAnnotDecl pass]
group_roles [TyClGroup GhcRn]
tyclds)
                     ; [(SrcSpan, Core (M Dec))]
kisig_ds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M Dec))
repKiSigD (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall pass. TyClGroup pass -> [LStandaloneKindSig pass]
group_kisigs [TyClGroup GhcRn]
tyclds)
                     ; [(SrcSpan, Core (M Dec))]
inst_ds  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LInstDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repInstD [GenLocated SrcSpanAnnA (InstDecl GhcRn)]
instds
                     ; [(SrcSpan, Core (M Dec))]
deriv_ds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repStandaloneDerivD [LDerivDecl GhcRn]
derivds
                     ; [[(SrcSpan, Core (M Dec))]]
fix_ds   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M Dec))]
repLFixD [LFixitySig GhcRn]
fixds
                     ; [Any]
_        <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a} {a} {a}.
Outputable a =>
GenLocated (SrcSpanAnn' a) a -> MetaM a
no_default_decl [LDefaultDecl GhcRn]
defds
                     ; [(SrcSpan, Core (M Dec))]
for_ds   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repForD [LForeignDecl GhcRn]
fords
                     ; [Any]
_        <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. LWarnDecl GhcRn -> MetaM a
no_warn (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall pass. WarnDecls pass -> [LWarnDecl pass]
wd_warnings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
                                                           [LWarnDecls GhcRn]
warnds)
                     ; [(SrcSpan, Core (M Dec))]
ann_ds   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repAnnD [LAnnDecl GhcRn]
annds
                     ; [(SrcSpan, Core (M Dec))]
rule_ds  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repRuleD (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall pass. RuleDecls pass -> [LRuleDecl pass]
rds_rules forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
                                                            [LRuleDecls GhcRn]
ruleds)
                     ; [Any]
_        <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a} {e} {a}. GenLocated (SrcSpanAnn' a) e -> MetaM a
no_doc [LDocDecl GhcRn]
docs

                        -- more needed
                     ;  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. [(a, b)] -> [b]
de_loc forall a b. (a -> b) -> a -> b
$ forall a. [(SrcSpan, a)] -> [(SrcSpan, a)]
sort_by_loc forall a b. (a -> b) -> a -> b
$
                                [(SrcSpan, Core (M Dec))]
val_ds forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
catMaybes [Maybe (SrcSpan, Core (M Dec))]
tycl_ds forall a. [a] -> [a] -> [a]
++ [(SrcSpan, Core (M Dec))]
role_ds
                                       forall a. [a] -> [a] -> [a]
++ [(SrcSpan, Core (M Dec))]
kisig_ds
                                       forall a. [a] -> [a] -> [a]
++ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(SrcSpan, Core (M Dec))]]
fix_ds)
                                       forall a. [a] -> [a] -> [a]
++ [(SrcSpan, Core (M Dec))]
inst_ds forall a. [a] -> [a] -> [a]
++ [(SrcSpan, Core (M Dec))]
rule_ds forall a. [a] -> [a] -> [a]
++ [(SrcSpan, Core (M Dec))]
for_ds
                                       forall a. [a] -> [a] -> [a]
++ [(SrcSpan, Core (M Dec))]
ann_ds forall a. [a] -> [a] -> [a]
++ [(SrcSpan, Core (M Dec))]
deriv_ds) }) ;

        Core [M Dec]
core_list <- forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repListM Name
decTyConName forall (m :: * -> *) a. Monad m => a -> m a
return [Core (M Dec)]
decls ;

        Type
dec_ty <- Name -> MetaM Type
lookupType Name
decTyConName ;
        Core (M [Dec])
q_decs  <- forall a. Type -> Core [M a] -> MetaM (Core (M [a]))
repSequenceM Type
dec_ty Core [M Dec]
core_list ;

        forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms [GenSymBind]
ss Core (M [Dec])
q_decs
      }
  where
    no_splice :: GenLocated (SrcSpanAnn' a) e -> MetaM a
no_splice (L SrcSpanAnn' a
loc e
_)
      = forall a. SrcSpan -> String -> SDoc -> MetaM a
notHandledL (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc) String
"Splices within declaration brackets" SDoc
empty
    no_default_decl :: GenLocated (SrcSpanAnn' a) a -> MetaM a
no_default_decl (L SrcSpanAnn' a
loc a
decl)
      = forall a. SrcSpan -> String -> SDoc -> MetaM a
notHandledL (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc) String
"Default declarations" (forall a. Outputable a => a -> SDoc
ppr a
decl)
    no_warn :: LWarnDecl GhcRn -> MetaM a
    no_warn :: forall a. LWarnDecl GhcRn -> MetaM a
no_warn (L SrcSpanAnnA
loc (Warning XWarning GhcRn
_ [LIdP GhcRn]
thing WarningTxt
_))
      = forall a. SrcSpan -> String -> SDoc -> MetaM a
notHandledL (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) String
"WARNING and DEPRECATION pragmas" forall a b. (a -> b) -> a -> b
$
                    String -> SDoc
text String
"Pragma for declaration of" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
thing
    no_doc :: GenLocated (SrcSpanAnn' a) e -> MetaM a
no_doc (L SrcSpanAnn' a
loc e
_)
      = forall a. SrcSpan -> String -> SDoc -> MetaM a
notHandledL (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc) String
"Haddock documentation" SDoc
empty

hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
-- See Note [Scoped type variables in quotes]
hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
hsScopedTvBinders HsValBinds GhcRn
binds
  = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LSig GhcRn -> [Name]
get_scoped_tvs [LSig GhcRn]
sigs
  where
    sigs :: [LSig GhcRn]
sigs = case HsValBinds GhcRn
binds of
             ValBinds           XValBinds GhcRn GhcRn
_ LHsBindsLR GhcRn GhcRn
_ [LSig GhcRn]
sigs  -> [LSig GhcRn]
sigs
             XValBindsLR (NValBinds [(RecFlag, LHsBindsLR GhcRn GhcRn)]
_ [LSig GhcRn]
sigs) -> [LSig GhcRn]
sigs

get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs (L SrcSpanAnnA
_ Sig GhcRn
signature)
  | TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
_ LHsSigWcType GhcRn
sig <- Sig GhcRn
signature
  = LHsSigType GhcRn -> [Name]
get_scoped_tvs_from_sig (forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsSigWcType GhcRn
sig)
  | ClassOpSig XClassOpSig GhcRn
_ Bool
_ [LIdP GhcRn]
_ LHsSigType GhcRn
sig <- Sig GhcRn
signature
  = LHsSigType GhcRn -> [Name]
get_scoped_tvs_from_sig LHsSigType GhcRn
sig
  | PatSynSig XPatSynSig GhcRn
_ [LIdP GhcRn]
_ LHsSigType GhcRn
sig <- Sig GhcRn
signature
  = LHsSigType GhcRn -> [Name]
get_scoped_tvs_from_sig LHsSigType GhcRn
sig
  | Bool
otherwise
  = []

get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]
  -- Collect both implicit and explicit quantified variables, since
  -- the types in instance heads, as well as `via` types in DerivingVia, can
  -- bring implicitly quantified type variables into scope, e.g.,
  --
  --   instance Foo [a] where
  --     m = n @a
  --
  -- See also Note [Scoped type variables in quotes]
get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]
get_scoped_tvs_from_sig (L SrcSpanAnnA
_ (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs})) =
  forall flag. HsOuterTyVarBndrs flag GhcRn -> [Name]
hsOuterTyVarNames HsOuterSigTyVarBndrs GhcRn
outer_bndrs

{- Notes

Note [Scoped type variables in quotes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Quoting declarations with scoped type variables requires some care. Consider:

  $([d| f :: forall a. a -> a
        f x = x::a
      |])

Here, the `forall a` brings `a` into scope over the binding group. This has
ramifications when desugaring the quote, as we must ensure that that the
desugared code binds `a` with `Language.Haskell.TH.newName` and refers to the
bound `a` type variable in the type signature and in the body of `f`. As a
result, the call to `newName` must occur before any part of the declaration for
`f` is processed. To achieve this, we:

 (a) Gensym a binding for `a` at the same time as we do one for `f`,
     collecting the relevant binders with the hsScopedTvBinders family of
     functions.

 (b) Use `addBinds` to bring these gensymmed bindings into scope over any
     part of the code where the type variables scope. In the `f` example,
     above, that means the type signature and the body of `f`.

 (c) When processing the `forall`, /don't/ gensym the type variables. We have
     already brought the type variables into scope in part (b), after all, so
     gensymming them again would lead to shadowing. We use the rep_ty_sig
     family of functions for processing types without gensymming the type
     variables again.

 (d) Finally, we use wrapGenSyms to generate the Core for these scoped type
     variables:

       newName "a" >>= \a ->
         ... -- process the type signature and body of `f`

The relevant places are signposted with references to this Note.

Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we desugar [d| data T = MkT |]
we want to get
        Data "T" [] [Con "MkT" []] []
and *not*
        Data "Foo:T" [] [Con "Foo:MkT" []] []
That is, the new data decl should fit into whatever new module it is
asked to fit in.   We do *not* clone, though; no need for this:
        Data "T79" ....

But if we see this:
        data T = MkT
        foo = reifyDecl T

then we must desugar to
        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []

So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
in repTyClD and repC.

Note [Don't quantify implicit type variables in quotes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you're not careful, it's surprisingly easy to take this quoted declaration:

  [d| id :: a -> a
      id x = x
    |]

and have Template Haskell turn it into this:

  id :: forall a. a -> a
  id x = x

Notice that we explicitly quantified the variable `a`! The latter declaration
isn't what the user wrote in the first place.

Usually, the culprit behind these bugs is taking implicitly quantified type
variables (often from the hsib_vars field of HsImplicitBinders) and putting
them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
-}

-- represent associated family instances
--
repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec)))

repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M Dec)))
repTyClD (L SrcSpanAnnA
loc (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcRn
fam })) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                                              LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repFamilyDecl (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc FamilyDecl GhcRn
fam)

repTyClD (L SrcSpanAnnA
loc (SynDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP GhcRn
tc, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcRn
tvs, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsType GhcRn
rhs }))
  = do { Core Name
tc1 <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
tc           -- See note [Binders and occurrences]
       ; Core (M Dec)
dec <- forall a.
LHsQTyVars GhcRn
-> (Core [M (TyVarBndr ())] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addTyClTyVarBinds LHsQTyVars GhcRn
tvs forall a b. (a -> b) -> a -> b
$ \Core [M (TyVarBndr ())]
bndrs ->
                Core Name
-> Core [M (TyVarBndr ())] -> LHsType GhcRn -> MetaM (Core (M Dec))
repSynDecl Core Name
tc1 Core [M (TyVarBndr ())]
bndrs LHsType GhcRn
rhs
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec)) }

repTyClD (L SrcSpanAnnA
loc (DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP GhcRn
tc
                          , tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcRn
tvs
                          , tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
defn }))
  = do { Core Name
tc1 <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
tc           -- See note [Binders and occurrences]
       ; Core (M Dec)
dec <- forall a.
LHsQTyVars GhcRn
-> (Core [M (TyVarBndr ())] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addTyClTyVarBinds LHsQTyVars GhcRn
tvs forall a b. (a -> b) -> a -> b
$ \Core [M (TyVarBndr ())]
bndrs ->
                Core Name
-> Either
     (Core [M (TyVarBndr ())])
     (Core (Maybe [M (TyVarBndr ())]), Core (M Type))
-> HsDataDefn GhcRn
-> MetaM (Core (M Dec))
repDataDefn Core Name
tc1 (forall a b. a -> Either a b
Left Core [M (TyVarBndr ())]
bndrs) HsDataDefn GhcRn
defn
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec)) }

repTyClD (L SrcSpanAnnA
loc (ClassDecl { tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdCtxt = Maybe (LHsContext GhcRn)
cxt, tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP GhcRn
cls,
                             tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcRn
tvs, tcdFDs :: forall pass. TyClDecl pass -> [LHsFunDep pass]
tcdFDs = [LHsFunDep GhcRn]
fds,
                             tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
sigs, tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths = LHsBindsLR GhcRn GhcRn
meth_binds,
                             tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats, tcdATDefs :: forall pass. TyClDecl pass -> [LTyFamDefltDecl pass]
tcdATDefs = [LTyFamDefltDecl GhcRn]
atds }))
  = do { Core Name
cls1 <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
cls         -- See note [Binders and occurrences]
       ; Core (M Dec)
dec  <- forall a.
LHsQTyVars GhcRn
-> (Core [M (TyVarBndr ())] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addQTyVarBinds LHsQTyVars GhcRn
tvs forall a b. (a -> b) -> a -> b
$ \Core [M (TyVarBndr ())]
bndrs ->
           do { Core (M Cxt)
cxt1   <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repLContext Maybe (LHsContext GhcRn)
cxt
          -- See Note [Scoped type variables in quotes]
              ; ([GenSymBind]
ss, [Core (M Dec)]
sigs_binds) <- [LSig GhcRn]
-> LHsBindsLR GhcRn GhcRn -> MetaM ([GenSymBind], [Core (M Dec)])
rep_meth_sigs_binds [LSig GhcRn]
sigs LHsBindsLR GhcRn GhcRn
meth_binds
              ; Core [FunDep]
fds1   <- [LHsFunDep GhcRn] -> MetaM (Core [FunDep])
repLFunDeps [LHsFunDep GhcRn]
fds
              ; [Core (M Dec)]
ats1   <- [LFamilyDecl GhcRn] -> MetaM [Core (M Dec)]
repFamilyDecls [LFamilyDecl GhcRn]
ats
              ; [Core (M Dec)]
atds1  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TyFamDefltDecl GhcRn -> MetaM (Core (M Dec))
repAssocTyFamDefaultD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LTyFamDefltDecl GhcRn]
atds
              ; Core [M Dec]
decls1 <- forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repListM Name
decTyConName forall (m :: * -> *) a. Monad m => a -> m a
return ([Core (M Dec)]
ats1 forall a. [a] -> [a] -> [a]
++ [Core (M Dec)]
atds1 forall a. [a] -> [a] -> [a]
++ [Core (M Dec)]
sigs_binds)
              ; Core (M Dec)
decls2 <- Core (M Cxt)
-> Core Name
-> Core [M (TyVarBndr ())]
-> Core [FunDep]
-> Core [M Dec]
-> MetaM (Core (M Dec))
repClass Core (M Cxt)
cxt1 Core Name
cls1 Core [M (TyVarBndr ())]
bndrs Core [FunDep]
fds1 Core [M Dec]
decls1
              ; forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms [GenSymBind]
ss Core (M Dec)
decls2 }
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec)
       }

-------------------------
repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repRoleD (L SrcSpanAnnA
loc (RoleAnnotDecl XCRoleAnnotDecl GhcRn
_ LIdP GhcRn
tycon [XRec GhcRn (Maybe Role)]
roles))
  = do { Core Name
tycon1 <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
tycon
       ; [Core Role]
roles1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (Maybe Role) -> MetaM (Core Role)
repRole [XRec GhcRn (Maybe Role)]
roles
       ; Core [Role]
roles2 <- forall a. Name -> [Core a] -> MetaM (Core [a])
coreList Name
roleTyConName [Core Role]
roles1
       ; Core (M Dec)
dec <- Core Name -> Core [Role] -> MetaM (Core (M Dec))
repRoleAnnotD Core Name
tycon1 Core [Role]
roles2
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec) }

-------------------------
repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M Dec))
repKiSigD (L SrcSpanAnnA
loc StandaloneKindSig GhcRn
kisig) =
  case StandaloneKindSig GhcRn
kisig of
    StandaloneKindSig XStandaloneKindSig GhcRn
_ LIdP GhcRn
v LHsSigType GhcRn
ki -> do
      MkC CoreExpr
th_v  <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
v
      MkC CoreExpr
th_ki <- LHsSigType GhcRn -> MetaM (Core (M Type))
repHsSigType LHsSigType GhcRn
ki
      Core (M Dec)
dec       <- forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
kiSigDName [CoreExpr
th_v, CoreExpr
th_ki]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec)

-------------------------
repDataDefn :: Core TH.Name
            -> Either (Core [(M (TH.TyVarBndr ()))])
                        -- the repTyClD case
                      (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
                        -- the repDataFamInstD case
            -> HsDataDefn GhcRn
            -> MetaM (Core (M TH.Dec))
repDataDefn :: Core Name
-> Either
     (Core [M (TyVarBndr ())])
     (Core (Maybe [M (TyVarBndr ())]), Core (M Type))
-> HsDataDefn GhcRn
-> MetaM (Core (M Dec))
repDataDefn Core Name
tc Either
  (Core [M (TyVarBndr ())])
  (Core (Maybe [M (TyVarBndr ())]), Core (M Type))
opts
          (HsDataDefn { dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data, dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt = Maybe (LHsContext GhcRn)
cxt, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcRn)
ksig
                      , dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons, dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcRn
mb_derivs })
  = do { Core (M Cxt)
cxt1     <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repLContext Maybe (LHsContext GhcRn)
cxt
       ; Core [M DerivClause]
derivs1  <- HsDeriving GhcRn -> MetaM (Core [M DerivClause])
repDerivs HsDeriving GhcRn
mb_derivs
       ; case (NewOrData
new_or_data, [LConDecl GhcRn]
cons) of
           (NewOrData
NewType, [GenLocated SrcSpanAnnA (ConDecl GhcRn)
con])  -> do { Core (M Con)
con'  <- LConDecl GhcRn -> MetaM (Core (M Con))
repC GenLocated SrcSpanAnnA (ConDecl GhcRn)
con
                                   ; Core (Maybe (M Type))
ksig' <- Maybe (LHsType GhcRn) -> MetaM (Core (Maybe (M Type)))
repMaybeLTy Maybe (LHsType GhcRn)
ksig
                                   ; Core (M Cxt)
-> Core Name
-> Either
     (Core [M (TyVarBndr ())])
     (Core (Maybe [M (TyVarBndr ())]), Core (M Type))
-> Core (Maybe (M Type))
-> Core (M Con)
-> Core [M DerivClause]
-> MetaM (Core (M Dec))
repNewtype Core (M Cxt)
cxt1 Core Name
tc Either
  (Core [M (TyVarBndr ())])
  (Core (Maybe [M (TyVarBndr ())]), Core (M Type))
opts Core (Maybe (M Type))
ksig' Core (M Con)
con'
                                                Core [M DerivClause]
derivs1 }
           (NewOrData
NewType, [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
_) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. SDoc -> DsM a
failWithDs (String -> SDoc
text String
"Multiple constructors for newtype:"
                                       SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => [a] -> SDoc
pprQuotedList
                                       (ConDecl GhcRn -> [LocatedN Name]
getConNames forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [LConDecl GhcRn]
cons))
           (NewOrData
DataType, [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
_) -> do { Core (Maybe (M Type))
ksig' <- Maybe (LHsType GhcRn) -> MetaM (Core (Maybe (M Type)))
repMaybeLTy Maybe (LHsType GhcRn)
ksig
                               ; [Core (M Con)]
consL <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LConDecl GhcRn -> MetaM (Core (M Con))
repC [LConDecl GhcRn]
cons
                               ; Core [M Con]
cons1 <- forall a. Name -> [Core a] -> MetaM (Core [a])
coreListM Name
conTyConName [Core (M Con)]
consL
                               ; Core (M Cxt)
-> Core Name
-> Either
     (Core [M (TyVarBndr ())])
     (Core (Maybe [M (TyVarBndr ())]), Core (M Type))
-> Core (Maybe (M Type))
-> Core [M Con]
-> Core [M DerivClause]
-> MetaM (Core (M Dec))
repData Core (M Cxt)
cxt1 Core Name
tc Either
  (Core [M (TyVarBndr ())])
  (Core (Maybe [M (TyVarBndr ())]), Core (M Type))
opts Core (Maybe (M Type))
ksig' Core [M Con]
cons1
                                         Core [M DerivClause]
derivs1 }
       }

repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
           -> LHsType GhcRn
           -> MetaM (Core (M TH.Dec))
repSynDecl :: Core Name
-> Core [M (TyVarBndr ())] -> LHsType GhcRn -> MetaM (Core (M Dec))
repSynDecl Core Name
tc Core [M (TyVarBndr ())]
bndrs LHsType GhcRn
ty
  = do { Core (M Type)
ty1 <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
ty
       ; Core Name
-> Core [M (TyVarBndr ())] -> Core (M Type) -> MetaM (Core (M Dec))
repTySyn Core Name
tc Core [M (TyVarBndr ())]
bndrs Core (M Type)
ty1 }

repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repFamilyDecl decl :: LFamilyDecl GhcRn
decl@(L SrcSpanAnnA
loc (FamilyDecl { fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo      = FamilyInfo GhcRn
info
                                      , fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName     = LIdP GhcRn
tc
                                      , fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars    = LHsQTyVars GhcRn
tvs
                                      , fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = L SrcSpan
_ FamilyResultSig GhcRn
resultSig
                                      , fdInjectivityAnn :: forall pass. FamilyDecl pass -> Maybe (LInjectivityAnn pass)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcRn)
injectivity }))
  = do { Core Name
tc1 <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
tc           -- See note [Binders and occurrences]
       ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
             mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
mkHsQTvs [LHsTyVarBndr () GhcRn]
tvs = HsQTvs { hsq_ext :: XHsQTvs GhcRn
hsq_ext = []
                                   , hsq_explicit :: [LHsTyVarBndr () GhcRn]
hsq_explicit = [LHsTyVarBndr () GhcRn]
tvs }
             resTyVar :: LHsQTyVars GhcRn
resTyVar = case FamilyResultSig GhcRn
resultSig of
                     TyVarSig XTyVarSig GhcRn
_ LHsTyVarBndr () GhcRn
bndr -> [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
mkHsQTvs [LHsTyVarBndr () GhcRn
bndr]
                     FamilyResultSig GhcRn
_               -> [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
mkHsQTvs []
       ; Core (M Dec)
dec <- forall a.
LHsQTyVars GhcRn
-> (Core [M (TyVarBndr ())] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addTyClTyVarBinds LHsQTyVars GhcRn
tvs forall a b. (a -> b) -> a -> b
$ \Core [M (TyVarBndr ())]
bndrs ->
                forall a.
LHsQTyVars GhcRn
-> (Core [M (TyVarBndr ())] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addTyClTyVarBinds LHsQTyVars GhcRn
resTyVar forall a b. (a -> b) -> a -> b
$ \Core [M (TyVarBndr ())]
_ ->
           case FamilyInfo GhcRn
info of
             ClosedTypeFamily Maybe [LTyFamInstEqn GhcRn]
Nothing ->
                 forall a. String -> SDoc -> MetaM a
notHandled String
"abstract closed type family" (forall a. Outputable a => a -> SDoc
ppr LFamilyDecl GhcRn
decl)
             ClosedTypeFamily (Just [LTyFamInstEqn GhcRn]
eqns) ->
               do { [Core (M TySynEqn)]
eqns1  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TyFamInstEqn GhcRn -> ReaderT MetaWrappers DsM (Core (M TySynEqn))
repTyFamEqn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LTyFamInstEqn GhcRn]
eqns
                  ; Core [M TySynEqn]
eqns2  <- forall a. Name -> [Core a] -> MetaM (Core [a])
coreListM Name
tySynEqnTyConName [Core (M TySynEqn)]
eqns1
                  ; Core (M FamilyResultSig)
result <- FamilyResultSig GhcRn -> MetaM (Core (M FamilyResultSig))
repFamilyResultSig FamilyResultSig GhcRn
resultSig
                  ; Core (Maybe InjectivityAnn)
inj    <- Maybe (LInjectivityAnn GhcRn)
-> MetaM (Core (Maybe InjectivityAnn))
repInjectivityAnn Maybe (LInjectivityAnn GhcRn)
injectivity
                  ; Core Name
-> Core [M (TyVarBndr ())]
-> Core (M FamilyResultSig)
-> Core (Maybe InjectivityAnn)
-> Core [M TySynEqn]
-> MetaM (Core (M Dec))
repClosedFamilyD Core Name
tc1 Core [M (TyVarBndr ())]
bndrs Core (M FamilyResultSig)
result Core (Maybe InjectivityAnn)
inj Core [M TySynEqn]
eqns2 }
             FamilyInfo GhcRn
OpenTypeFamily ->
               do { Core (M FamilyResultSig)
result <- FamilyResultSig GhcRn -> MetaM (Core (M FamilyResultSig))
repFamilyResultSig FamilyResultSig GhcRn
resultSig
                  ; Core (Maybe InjectivityAnn)
inj    <- Maybe (LInjectivityAnn GhcRn)
-> MetaM (Core (Maybe InjectivityAnn))
repInjectivityAnn Maybe (LInjectivityAnn GhcRn)
injectivity
                  ; Core Name
-> Core [M (TyVarBndr ())]
-> Core (M FamilyResultSig)
-> Core (Maybe InjectivityAnn)
-> MetaM (Core (M Dec))
repOpenFamilyD Core Name
tc1 Core [M (TyVarBndr ())]
bndrs Core (M FamilyResultSig)
result Core (Maybe InjectivityAnn)
inj }
             FamilyInfo GhcRn
DataFamily ->
               do { Core (Maybe (M Type))
kind <- FamilyResultSig GhcRn -> MetaM (Core (Maybe (M Type)))
repFamilyResultSigToMaybeKind FamilyResultSig GhcRn
resultSig
                  ; Core Name
-> Core [M (TyVarBndr ())]
-> Core (Maybe (M Type))
-> MetaM (Core (M Dec))
repDataFamilyD Core Name
tc1 Core [M (TyVarBndr ())]
bndrs Core (Maybe (M Type))
kind }
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec)
       }

-- | Represent result signature of a type family
repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig))
repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M FamilyResultSig))
repFamilyResultSig (NoSig XNoSig GhcRn
_)         = MetaM (Core (M FamilyResultSig))
repNoSig
repFamilyResultSig (KindSig XCKindSig GhcRn
_ LHsType GhcRn
ki)    = do { Core (M Type)
ki' <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
ki
                                          ; Core (M Type) -> MetaM (Core (M FamilyResultSig))
repKindSig Core (M Type)
ki' }
repFamilyResultSig (TyVarSig XTyVarSig GhcRn
_ LHsTyVarBndr () GhcRn
bndr) = do { Core (M (TyVarBndr ()))
bndr' <- forall flag flag'.
RepTV flag flag' =>
LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TyVarBndr flag')))
repTyVarBndr LHsTyVarBndr () GhcRn
bndr
                                          ; Core (M (TyVarBndr ())) -> MetaM (Core (M FamilyResultSig))
repTyVarSig Core (M (TyVarBndr ()))
bndr' }

-- | Represent result signature using a Maybe Kind. Used with data families,
-- where the result signature can be either missing or a kind but never a named
-- result variable.
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
                              -> MetaM (Core (Maybe (M TH.Kind)))
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn -> MetaM (Core (Maybe (M Type)))
repFamilyResultSigToMaybeKind (NoSig XNoSig GhcRn
_) =
    forall a. Name -> MetaM (Core (Maybe a))
coreNothingM Name
kindTyConName
repFamilyResultSigToMaybeKind (KindSig XCKindSig GhcRn
_ LHsType GhcRn
ki) =
    forall a. Name -> Core a -> MetaM (Core (Maybe a))
coreJustM Name
kindTyConName forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
ki
repFamilyResultSigToMaybeKind TyVarSig{} =
    forall a. String -> a
panic String
"repFamilyResultSigToMaybeKind: unexpected TyVarSig"

-- | Represent injectivity annotation of a type family
repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
                  -> MetaM (Core (Maybe TH.InjectivityAnn))
repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
-> MetaM (Core (Maybe InjectivityAnn))
repInjectivityAnn Maybe (LInjectivityAnn GhcRn)
Nothing =
    forall a. Name -> MetaM (Core (Maybe a))
coreNothing Name
injAnnTyConName
repInjectivityAnn (Just (L SrcSpan
_ (InjectivityAnn XCInjectivityAnn GhcRn
_ LIdP GhcRn
lhs [LIdP GhcRn]
rhs))) =
    do { Core Name
lhs'   <- Name -> MetaM (Core Name)
lookupBinder (forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
lhs)
       ; [Core Name]
rhs1   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> MetaM (Core Name)
lookupBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LIdP GhcRn]
rhs
       ; Core [Name]
rhs2   <- forall a. Name -> [Core a] -> MetaM (Core [a])
coreList Name
nameTyConName [Core Name]
rhs1
       ; Core InjectivityAnn
injAnn <- forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
injectivityAnnName [forall a. Core a -> CoreExpr
unC Core Name
lhs', forall a. Core a -> CoreExpr
unC Core [Name]
rhs2]
       ; forall a. Name -> Core a -> MetaM (Core (Maybe a))
coreJust Name
injAnnTyConName Core InjectivityAnn
injAnn }

repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)]
repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M Dec)]
repFamilyDecls [LFamilyDecl GhcRn]
fds = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. [(a, b)] -> [b]
de_loc (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repFamilyDecl [LFamilyDecl GhcRn]
fds)

repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec))
repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M Dec))
repAssocTyFamDefaultD = TyFamDefltDecl GhcRn -> MetaM (Core (M Dec))
repTyFamInstD

-------------------------
-- represent fundeps
--
repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep])
repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [FunDep])
repLFunDeps [LHsFunDep GhcRn]
fds = forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repList Name
funDepTyConName LHsFunDep GhcRn -> MetaM (Core FunDep)
repLFunDep [LHsFunDep GhcRn]
fds

repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep)
repLFunDep :: LHsFunDep GhcRn -> MetaM (Core FunDep)
repLFunDep (L SrcSpanAnnA
_ (FunDep XCFunDep GhcRn
_ [LIdP GhcRn]
xs [LIdP GhcRn]
ys))
   = do Core [Name]
xs' <- forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repList Name
nameTyConName (Name -> MetaM (Core Name)
lookupBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LIdP GhcRn]
xs
        Core [Name]
ys' <- forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repList Name
nameTyConName (Name -> MetaM (Core Name)
lookupBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LIdP GhcRn]
ys
        Core [Name] -> Core [Name] -> MetaM (Core FunDep)
repFunDep Core [Name]
xs' Core [Name]
ys'

-- Represent instance declarations
--
repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repInstD (L SrcSpanAnnA
loc (TyFamInstD { tfid_inst :: forall pass. InstDecl pass -> TyFamInstDecl pass
tfid_inst = TyFamDefltDecl GhcRn
fi_decl }))
  = do { Core (M Dec)
dec <- TyFamDefltDecl GhcRn -> MetaM (Core (M Dec))
repTyFamInstD TyFamDefltDecl GhcRn
fi_decl
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec) }
repInstD (L SrcSpanAnnA
loc (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl GhcRn
fi_decl }))
  = do { Core (M Dec)
dec <- DataFamInstDecl GhcRn -> MetaM (Core (M Dec))
repDataFamInstD DataFamInstDecl GhcRn
fi_decl
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec) }
repInstD (L SrcSpanAnnA
loc (ClsInstD { cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst = ClsInstDecl GhcRn
cls_decl }))
  = do { Core (M Dec)
dec <- ClsInstDecl GhcRn -> MetaM (Core (M Dec))
repClsInstD ClsInstDecl GhcRn
cls_decl
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec) }

repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M Dec))
repClsInstD (ClsInstDecl { cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_poly_ty = LHsSigType GhcRn
ty, cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds = LHsBindsLR GhcRn GhcRn
binds
                         , cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_sigs = [LSig GhcRn]
sigs, cid_tyfam_insts :: forall pass. ClsInstDecl pass -> [LTyFamInstDecl pass]
cid_tyfam_insts = [LTyFamDefltDecl GhcRn]
ats
                         , cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts = [LDataFamInstDecl GhcRn]
adts
                         , cid_overlap_mode :: forall pass. ClsInstDecl pass -> Maybe (XRec pass OverlapMode)
cid_overlap_mode = Maybe (XRec GhcRn OverlapMode)
overlap
                         })
  = forall a. [Name] -> MetaM (Core (M a)) -> MetaM (Core (M a))
addSimpleTyVarBinds [Name]
tvs forall a b. (a -> b) -> a -> b
$
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
            -- appear in the resulting data structure
            --
            -- But we do NOT bring the binders of 'binds' into scope
            -- because they are properly regarded as occurrences
            -- For example, the method names should be bound to
            -- the selector Ids, not to fresh names (#5410)
            --
            do { Core (M Cxt)
cxt1     <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repLContext Maybe (LHsContext GhcRn)
cxt
               ; Core (M Type)
inst_ty1 <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
inst_ty
          -- See Note [Scoped type variables in quotes]
               ; ([GenSymBind]
ss, [Core (M Dec)]
sigs_binds) <- [LSig GhcRn]
-> LHsBindsLR GhcRn GhcRn -> MetaM ([GenSymBind], [Core (M Dec)])
rep_meth_sigs_binds [LSig GhcRn]
sigs LHsBindsLR GhcRn GhcRn
binds
               ; [Core (M Dec)]
ats1   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TyFamDefltDecl GhcRn -> MetaM (Core (M Dec))
repTyFamInstD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LTyFamDefltDecl GhcRn]
ats
               ; [Core (M Dec)]
adts1  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DataFamInstDecl GhcRn -> MetaM (Core (M Dec))
repDataFamInstD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LDataFamInstDecl GhcRn]
adts
               ; Core [M Dec]
decls1 <- forall a. Name -> [Core a] -> MetaM (Core [a])
coreListM Name
decTyConName ([Core (M Dec)]
ats1 forall a. [a] -> [a] -> [a]
++ [Core (M Dec)]
adts1 forall a. [a] -> [a] -> [a]
++ [Core (M Dec)]
sigs_binds)
               ; Core (Maybe Overlap)
rOver  <- Maybe OverlapMode -> MetaM (Core (Maybe Overlap))
repOverlap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc Maybe (XRec GhcRn OverlapMode)
overlap)
               ; Core (M Dec)
decls2 <- Core (Maybe Overlap)
-> Core (M Cxt)
-> Core (M Type)
-> Core [M Dec]
-> MetaM (Core (M Dec))
repInst Core (Maybe Overlap)
rOver Core (M Cxt)
cxt1 Core (M Type)
inst_ty1 Core [M Dec]
decls1
               ; forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms [GenSymBind]
ss Core (M Dec)
decls2 }
 where
   ([Name]
tvs, Maybe (LHsContext GhcRn)
cxt, LHsType GhcRn
inst_ty) = LHsSigType GhcRn
-> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)
splitLHsInstDeclTy LHsSigType GhcRn
ty

repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repStandaloneDerivD (L SrcSpanAnnA
loc (DerivDecl { deriv_strategy :: forall pass. DerivDecl pass -> Maybe (LDerivStrategy pass)
deriv_strategy = Maybe (LDerivStrategy GhcRn)
strat
                                       , deriv_type :: forall pass. DerivDecl pass -> LHsSigWcType pass
deriv_type     = LHsSigWcType GhcRn
ty }))
  = do { Core (M Dec)
dec <- forall a.
Maybe (LDerivStrategy GhcRn)
-> (Core (Maybe (M DerivStrategy)) -> MetaM (Core (M a)))
-> MetaM (Core (M a))
repDerivStrategy Maybe (LDerivStrategy GhcRn)
strat  forall a b. (a -> b) -> a -> b
$ \Core (Maybe (M DerivStrategy))
strat' ->
                forall a. [Name] -> MetaM (Core (M a)) -> MetaM (Core (M a))
addSimpleTyVarBinds [Name]
tvs forall a b. (a -> b) -> a -> b
$
                do { Core (M Cxt)
cxt'     <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repLContext Maybe (LHsContext GhcRn)
cxt
                   ; Core (M Type)
inst_ty' <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
inst_ty
                   ; Core (Maybe (M DerivStrategy))
-> Core (M Cxt) -> Core (M Type) -> MetaM (Core (M Dec))
repDeriv Core (Maybe (M DerivStrategy))
strat' Core (M Cxt)
cxt' Core (M Type)
inst_ty' }
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec) }
  where
    ([Name]
tvs, Maybe (LHsContext GhcRn)
cxt, LHsType GhcRn
inst_ty) = LHsSigType GhcRn
-> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)
splitLHsInstDeclTy (forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType GhcRn
ty)

repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repTyFamInstD :: TyFamDefltDecl GhcRn -> MetaM (Core (M Dec))
repTyFamInstD (TyFamInstDecl { tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn = TyFamInstEqn GhcRn
eqn })
  = do { Core (M TySynEqn)
eqn1 <- TyFamInstEqn GhcRn -> ReaderT MetaWrappers DsM (Core (M TySynEqn))
repTyFamEqn TyFamInstEqn GhcRn
eqn
       ; Core (M TySynEqn) -> MetaM (Core (M Dec))
repTySynInst Core (M TySynEqn)
eqn1 }

repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))
repTyFamEqn :: TyFamInstEqn GhcRn -> ReaderT MetaWrappers DsM (Core (M TySynEqn))
repTyFamEqn (FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = LIdP GhcRn
tc_name
                    , feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
                    , feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats = HsTyPats GhcRn
tys
                    , feqn_fixity :: forall pass rhs. FamEqn pass rhs -> LexicalFixity
feqn_fixity = LexicalFixity
fixity
                    , feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs  = LHsType GhcRn
rhs })
  = do { Core Name
tc <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
tc_name     -- See note [Binders and occurrences]
       ; forall a.
HsOuterFamEqnTyVarBndrs GhcRn
-> (Core (Maybe [M (TyVarBndr ())]) -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsOuterFamEqnTyVarBinds HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs forall a b. (a -> b) -> a -> b
$ \Core (Maybe [M (TyVarBndr ())])
mb_exp_bndrs ->
         do { Core (M Type)
tys1 <- case LexicalFixity
fixity of
                        LexicalFixity
Prefix -> MetaM (Core (M Type)) -> HsTyPats GhcRn -> MetaM (Core (M Type))
repTyArgs (Core Name -> MetaM (Core (M Type))
repNamedTyCon Core Name
tc) HsTyPats GhcRn
tys
                        LexicalFixity
Infix  -> do { (HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
t1: HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
t2: [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcRn))
   (GenLocated SrcSpanAnnA (HsType GhcRn))]
args) <- HsTyPats GhcRn -> MetaM (HsTyPats GhcRn)
checkTys HsTyPats GhcRn
tys
                                     ; Core (M Type)
t1' <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy GenLocated SrcSpanAnnA (HsType GhcRn)
t1
                                     ; Core (M Type)
t2'  <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy GenLocated SrcSpanAnnA (HsType GhcRn)
t2
                                     ; MetaM (Core (M Type)) -> HsTyPats GhcRn -> MetaM (Core (M Type))
repTyArgs (Core (M Type)
-> Core Name -> Core (M Type) -> MetaM (Core (M Type))
repTInfix Core (M Type)
t1' Core Name
tc Core (M Type)
t2') [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcRn))
   (GenLocated SrcSpanAnnA (HsType GhcRn))]
args }
            ; Core (M Type)
rhs1 <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
rhs
            ; Core (Maybe [M (TyVarBndr ())])
-> Core (M Type)
-> Core (M Type)
-> ReaderT MetaWrappers DsM (Core (M TySynEqn))
repTySynEqn Core (Maybe [M (TyVarBndr ())])
mb_exp_bndrs Core (M Type)
tys1 Core (M Type)
rhs1 } }
     where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
           checkTys :: HsTyPats GhcRn -> MetaM (HsTyPats GhcRn)
checkTys tys :: HsTyPats GhcRn
tys@(HsValArg LHsType GhcRn
_:HsValArg LHsType GhcRn
_:HsTyPats GhcRn
_) = forall (m :: * -> *) a. Monad m => a -> m a
return HsTyPats GhcRn
tys
           checkTys HsTyPats GhcRn
_ = forall a. String -> a
panic String
"repTyFamEqn:checkTys"

repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))
repTyArgs :: MetaM (Core (M Type)) -> HsTyPats GhcRn -> MetaM (Core (M Type))
repTyArgs MetaM (Core (M Type))
f [] = MetaM (Core (M Type))
f
repTyArgs MetaM (Core (M Type))
f (HsValArg LHsType GhcRn
ty : HsTyPats GhcRn
as) = do { Core (M Type)
f' <- MetaM (Core (M Type))
f
                                    ; Core (M Type)
ty' <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
ty
                                    ; MetaM (Core (M Type)) -> HsTyPats GhcRn -> MetaM (Core (M Type))
repTyArgs (Core (M Type) -> Core (M Type) -> MetaM (Core (M Type))
repTapp Core (M Type)
f' Core (M Type)
ty') HsTyPats GhcRn
as }
repTyArgs MetaM (Core (M Type))
f (HsTypeArg SrcSpan
_ LHsType GhcRn
ki : HsTyPats GhcRn
as) = do { Core (M Type)
f' <- MetaM (Core (M Type))
f
                                       ; Core (M Type)
ki' <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
ki
                                       ; MetaM (Core (M Type)) -> HsTyPats GhcRn -> MetaM (Core (M Type))
repTyArgs (Core (M Type) -> Core (M Type) -> MetaM (Core (M Type))
repTappKind Core (M Type)
f' Core (M Type)
ki') HsTyPats GhcRn
as }
repTyArgs MetaM (Core (M Type))
f (HsArgPar SrcSpan
_ : HsTyPats GhcRn
as) = MetaM (Core (M Type)) -> HsTyPats GhcRn -> MetaM (Core (M Type))
repTyArgs MetaM (Core (M Type))
f HsTyPats GhcRn
as

repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M Dec))
repDataFamInstD (DataFamInstDecl { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn =
                                      FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = LIdP GhcRn
tc_name
                                             , feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
                                             , feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats  = HsTyPats GhcRn
tys
                                             , feqn_fixity :: forall pass rhs. FamEqn pass rhs -> LexicalFixity
feqn_fixity = LexicalFixity
fixity
                                             , feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs   = HsDataDefn GhcRn
defn }})
  = do { Core Name
tc <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
tc_name         -- See note [Binders and occurrences]
       ; forall a.
HsOuterFamEqnTyVarBndrs GhcRn
-> (Core (Maybe [M (TyVarBndr ())]) -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsOuterFamEqnTyVarBinds HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs forall a b. (a -> b) -> a -> b
$ \Core (Maybe [M (TyVarBndr ())])
mb_exp_bndrs ->
         do { Core (M Type)
tys1 <- case LexicalFixity
fixity of
                        LexicalFixity
Prefix -> MetaM (Core (M Type)) -> HsTyPats GhcRn -> MetaM (Core (M Type))
repTyArgs (Core Name -> MetaM (Core (M Type))
repNamedTyCon Core Name
tc) HsTyPats GhcRn
tys
                        LexicalFixity
Infix  -> do { (HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
t1: HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
t2: [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcRn))
   (GenLocated SrcSpanAnnA (HsType GhcRn))]
args) <- HsTyPats GhcRn -> MetaM (HsTyPats GhcRn)
checkTys HsTyPats GhcRn
tys
                                     ; Core (M Type)
t1' <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy GenLocated SrcSpanAnnA (HsType GhcRn)
t1
                                     ; Core (M Type)
t2'  <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy GenLocated SrcSpanAnnA (HsType GhcRn)
t2
                                     ; MetaM (Core (M Type)) -> HsTyPats GhcRn -> MetaM (Core (M Type))
repTyArgs (Core (M Type)
-> Core Name -> Core (M Type) -> MetaM (Core (M Type))
repTInfix Core (M Type)
t1' Core Name
tc Core (M Type)
t2') [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcRn))
   (GenLocated SrcSpanAnnA (HsType GhcRn))]
args }
            ; Core Name
-> Either
     (Core [M (TyVarBndr ())])
     (Core (Maybe [M (TyVarBndr ())]), Core (M Type))
-> HsDataDefn GhcRn
-> MetaM (Core (M Dec))
repDataDefn Core Name
tc (forall a b. b -> Either a b
Right (Core (Maybe [M (TyVarBndr ())])
mb_exp_bndrs, Core (M Type)
tys1)) HsDataDefn GhcRn
defn } }

      where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
            checkTys :: HsTyPats GhcRn -> MetaM (HsTyPats GhcRn)
checkTys tys :: HsTyPats GhcRn
tys@(HsValArg LHsType GhcRn
_: HsValArg LHsType GhcRn
_: HsTyPats GhcRn
_) = forall (m :: * -> *) a. Monad m => a -> m a
return HsTyPats GhcRn
tys
            checkTys HsTyPats GhcRn
_ = forall a. String -> a
panic String
"repDataFamInstD:checkTys"

repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repForD (L SrcSpanAnnA
loc (ForeignImport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = LIdP GhcRn
name, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcRn
typ
                                  , fd_fi :: forall pass. ForeignDecl pass -> ForeignImport
fd_fi = CImport (L SrcSpan
_ CCallConv
cc)
                                                    (L SrcSpan
_ Safety
s) Maybe Header
mch CImportSpec
cis Located SourceText
_ }))
 = do MkC CoreExpr
name' <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
name
      MkC CoreExpr
typ' <- LHsSigType GhcRn -> MetaM (Core (M Type))
repHsSigType LHsSigType GhcRn
typ
      MkC CoreExpr
cc' <- CCallConv -> MetaM (Core Callconv)
repCCallConv CCallConv
cc
      MkC CoreExpr
s' <- Safety -> MetaM (Core Safety)
repSafety Safety
s
      String
cis' <- CImportSpec -> MetaM String
conv_cimportspec CImportSpec
cis
      MkC CoreExpr
str <- forall (m :: * -> *). MonadThings m => String -> m (Core String)
coreStringLit (String
static forall a. [a] -> [a] -> [a]
++ String
chStr forall a. [a] -> [a] -> [a]
++ String
cis')
      Core (M Dec)
dec <- forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
forImpDName [CoreExpr
cc', CoreExpr
s', CoreExpr
str, CoreExpr
name', CoreExpr
typ']
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec)
 where
    conv_cimportspec :: CImportSpec -> MetaM String
conv_cimportspec (CLabel CLabelString
cls)
      = forall a. String -> SDoc -> MetaM a
notHandled String
"Foreign label" (SDoc -> SDoc
doubleQuotes (forall a. Outputable a => a -> SDoc
ppr CLabelString
cls))
    conv_cimportspec (CFunction CCallTarget
DynamicTarget) = forall (m :: * -> *) a. Monad m => a -> m a
return String
"dynamic"
    conv_cimportspec (CFunction (StaticTarget SourceText
_ CLabelString
fs Maybe Unit
_ Bool
True))
                            = forall (m :: * -> *) a. Monad m => a -> m a
return (CLabelString -> String
unpackFS CLabelString
fs)
    conv_cimportspec (CFunction (StaticTarget SourceText
_ CLabelString
_  Maybe Unit
_ Bool
False))
                            = forall a. String -> a
panic String
"conv_cimportspec: values not supported yet"
    conv_cimportspec CImportSpec
CWrapper = forall (m :: * -> *) a. Monad m => a -> m a
return String
"wrapper"
    -- these calling conventions do not support headers and the static keyword
    raw_cconv :: Bool
raw_cconv = CCallConv
cc forall a. Eq a => a -> a -> Bool
== CCallConv
PrimCallConv Bool -> Bool -> Bool
|| CCallConv
cc forall a. Eq a => a -> a -> Bool
== CCallConv
JavaScriptCallConv
    static :: String
static = case CImportSpec
cis of
                 CFunction (StaticTarget SourceText
_ CLabelString
_ Maybe Unit
_ Bool
_) | Bool -> Bool
not Bool
raw_cconv -> String
"static "
                 CImportSpec
_ -> String
""
    chStr :: String
chStr = case Maybe Header
mch of
            Just (Header SourceText
_ CLabelString
h) | Bool -> Bool
not Bool
raw_cconv -> CLabelString -> String
unpackFS CLabelString
h forall a. [a] -> [a] -> [a]
++ String
" "
            Maybe Header
_ -> String
""
repForD decl :: LForeignDecl GhcRn
decl@(L SrcSpanAnnA
_ ForeignExport{}) = forall a. String -> SDoc -> MetaM a
notHandled String
"Foreign export" (forall a. Outputable a => a -> SDoc
ppr LForeignDecl GhcRn
decl)

repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)
repCCallConv :: CCallConv -> MetaM (Core Callconv)
repCCallConv CCallConv
CCallConv          = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
cCallName []
repCCallConv CCallConv
StdCallConv        = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
stdCallName []
repCCallConv CCallConv
CApiConv           = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
cApiCallName []
repCCallConv CCallConv
PrimCallConv       = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
primCallName []
repCCallConv CCallConv
JavaScriptCallConv = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
javaScriptCallName []

repSafety :: Safety -> MetaM (Core TH.Safety)
repSafety :: Safety -> MetaM (Core Safety)
repSafety Safety
PlayRisky = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
unsafeName []
repSafety Safety
PlayInterruptible = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
interruptibleName []
repSafety Safety
PlaySafe = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
safeName []

repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M Dec))]
repLFixD (L SrcSpanAnnA
loc FixitySig GhcRn
fix_sig) = SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M Dec))]
rep_fix_d (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) FixitySig GhcRn
fix_sig

rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M Dec))]
rep_fix_d SrcSpan
loc (FixitySig XFixitySig GhcRn
_ [LIdP GhcRn]
names (Fixity SourceText
_ Int
prec FixityDirection
dir))
  = do { MkC CoreExpr
prec' <- Int -> MetaM (Core Int)
coreIntLit Int
prec
       ; let rep_fn :: Name
rep_fn = case FixityDirection
dir of
                        FixityDirection
InfixL -> Name
infixLDName
                        FixityDirection
InfixR -> Name
infixRDName
                        FixityDirection
InfixN -> Name
infixNDName
       ; let do_one :: LocatedN Name -> MetaM (SrcSpan, Core (M Dec))
do_one LocatedN Name
name
              = do { MkC CoreExpr
name' <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LocatedN Name
name
                   ; Core (M Dec)
dec <- forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
rep_fn [CoreExpr
prec', CoreExpr
name']
                   ; forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
loc,Core (M Dec)
dec) }
       ; forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LocatedN Name -> MetaM (SrcSpan, Core (M Dec))
do_one [LIdP GhcRn]
names }

repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repRuleD (L SrcSpanAnnA
loc (HsRule { rd_name :: forall pass. RuleDecl pass -> XRec pass (SourceText, CLabelString)
rd_name = XRec GhcRn (SourceText, CLabelString)
n
                        , rd_act :: forall pass. RuleDecl pass -> Activation
rd_act = Activation
act
                        , rd_tyvs :: forall pass.
RuleDecl pass -> Maybe [LHsTyVarBndr () (NoGhcTc pass)]
rd_tyvs = Maybe [LHsTyVarBndr () (NoGhcTc GhcRn)]
ty_bndrs
                        , rd_tmvs :: forall pass. RuleDecl pass -> [LRuleBndr pass]
rd_tmvs = [LRuleBndr GhcRn]
tm_bndrs
                        , rd_lhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_lhs = LHsExpr GhcRn
lhs
                        , rd_rhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_rhs = LHsExpr GhcRn
rhs }))
  = do { Core (M Dec)
rule <- forall flag flag' a.
RepTV flag flag' =>
[LHsTyVarBndr flag GhcRn]
-> (Core [M (TyVarBndr flag')] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsTyVarBinds (forall a. a -> Maybe a -> a
fromMaybe [] Maybe [LHsTyVarBndr () (NoGhcTc GhcRn)]
ty_bndrs) forall a b. (a -> b) -> a -> b
$ \ Core [M (TyVarBndr ())]
ex_bndrs ->
         do { let tm_bndr_names :: [Name]
tm_bndr_names = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LRuleBndr GhcRn -> [Name]
ruleBndrNames [LRuleBndr GhcRn]
tm_bndrs
            ; [GenSymBind]
ss <- [Name] -> MetaM [GenSymBind]
mkGenSyms [Name]
tm_bndr_names
            ; Core (M Dec)
rule <- forall a. [GenSymBind] -> MetaM a -> MetaM a
addBinds [GenSymBind]
ss forall a b. (a -> b) -> a -> b
$
                      do { Type
elt_ty <- Name -> MetaM Type
wrapName Name
tyVarBndrUnitTyConName
                         ; Core (Maybe [M (TyVarBndr ())])
ty_bndrs' <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe [LHsTyVarBndr () (NoGhcTc GhcRn)]
ty_bndrs of
                             Maybe [LHsTyVarBndr () (NoGhcTc GhcRn)]
Nothing -> forall a. Type -> Core (Maybe a)
coreNothing' (Type -> Type
mkListTy Type
elt_ty)
                             Just [LHsTyVarBndr () (NoGhcTc GhcRn)]
_  -> forall a. Type -> Core a -> Core (Maybe a)
coreJust' (Type -> Type
mkListTy Type
elt_ty) Core [M (TyVarBndr ())]
ex_bndrs
                         ; Core [M RuleBndr]
tm_bndrs' <- forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repListM Name
ruleBndrTyConName
                                                LRuleBndr GhcRn -> MetaM (Core (M RuleBndr))
repRuleBndr
                                                [LRuleBndr GhcRn]
tm_bndrs
                         ; Core String
n'   <- forall (m :: * -> *). MonadThings m => String -> m (Core String)
coreStringLit forall a b. (a -> b) -> a -> b
$ CLabelString -> String
unpackFS forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcRn (SourceText, CLabelString)
n
                         ; Core Phases
act' <- Activation -> MetaM (Core Phases)
repPhases Activation
act
                         ; Core (M Exp)
lhs' <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
lhs
                         ; Core (M Exp)
rhs' <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
rhs
                         ; Core String
-> Core (Maybe [M (TyVarBndr ())])
-> Core [M RuleBndr]
-> Core (M Exp)
-> Core (M Exp)
-> Core Phases
-> MetaM (Core (M Dec))
repPragRule Core String
n' Core (Maybe [M (TyVarBndr ())])
ty_bndrs' Core [M RuleBndr]
tm_bndrs' Core (M Exp)
lhs' Core (M Exp)
rhs' Core Phases
act' }
           ; forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms [GenSymBind]
ss Core (M Dec)
rule  }
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
rule) }

ruleBndrNames :: LRuleBndr GhcRn -> [Name]
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
ruleBndrNames (L SrcSpan
_ (RuleBndr XCRuleBndr GhcRn
_ LIdP GhcRn
n))      = [forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
n]
ruleBndrNames (L SrcSpan
_ (RuleBndrSig XRuleBndrSig GhcRn
_ LIdP GhcRn
n HsPatSigType GhcRn
sig))
  | HsPS { hsps_ext :: forall pass. HsPatSigType pass -> XHsPS pass
hsps_ext = HsPSRn { hsps_imp_tvs :: HsPSRn -> [Name]
hsps_imp_tvs = [Name]
vars }} <- HsPatSigType GhcRn
sig
  = forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
n forall a. a -> [a] -> [a]
: [Name]
vars

repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))
repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M RuleBndr))
repRuleBndr (L SrcSpan
_ (RuleBndr XCRuleBndr GhcRn
_ LIdP GhcRn
n))
  = do { MkC CoreExpr
n' <- LocatedN Name -> MetaM (Core Name)
lookupNBinder LIdP GhcRn
n
       ; forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
ruleVarName [CoreExpr
n'] }
repRuleBndr (L SrcSpan
_ (RuleBndrSig XRuleBndrSig GhcRn
_ LIdP GhcRn
n HsPatSigType GhcRn
sig))
  = do { MkC CoreExpr
n'  <- LocatedN Name -> MetaM (Core Name)
lookupNBinder LIdP GhcRn
n
       ; MkC CoreExpr
ty' <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy (forall pass. HsPatSigType pass -> LHsType pass
hsPatSigType HsPatSigType GhcRn
sig)
       ; forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
typedRuleVarName [CoreExpr
n', CoreExpr
ty'] }

repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M Dec))
repAnnD (L SrcSpanAnnA
loc (HsAnnotation XHsAnnotation GhcRn
_ SourceText
_ AnnProvenance GhcRn
ann_prov (L SrcSpanAnnA
_ HsExpr GhcRn
exp)))
  = do { Core AnnTarget
target <- AnnProvenance GhcRn -> MetaM (Core AnnTarget)
repAnnProv AnnProvenance GhcRn
ann_prov
       ; Core (M Exp)
exp'   <- HsExpr GhcRn -> MetaM (Core (M Exp))
repE HsExpr GhcRn
exp
       ; Core (M Dec)
dec    <- Core AnnTarget -> Core (M Exp) -> MetaM (Core (M Dec))
repPragAnn Core AnnTarget
target Core (M Exp)
exp'
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc, Core (M Dec)
dec) }

repAnnProv :: AnnProvenance GhcRn -> MetaM (Core TH.AnnTarget)
repAnnProv :: AnnProvenance GhcRn -> MetaM (Core AnnTarget)
repAnnProv (ValueAnnProvenance LIdP GhcRn
n)
  = do { -- An ANN references an identifier bound elsewhere in the module, so
         -- we must look it up using lookupLOcc (#19377).
         -- Similarly for TypeAnnProvenance (`ANN type`) below.
         MkC CoreExpr
n' <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
n
       ; forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
valueAnnotationName [ CoreExpr
n' ] }
repAnnProv (TypeAnnProvenance LIdP GhcRn
n)
  = do { MkC CoreExpr
n' <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LIdP GhcRn
n
       ; forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
typeAnnotationName [ CoreExpr
n' ] }
repAnnProv AnnProvenance GhcRn
ModuleAnnProvenance
  = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
moduleAnnotationName []

-------------------------------------------------------
--                      Constructors
-------------------------------------------------------

repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con))
repC :: LConDecl GhcRn -> MetaM (Core (M Con))
repC (L SrcSpanAnnA
_ (ConDeclH98 { con_name :: forall pass. ConDecl pass -> LIdP pass
con_name   = LIdP GhcRn
con
                      , con_forall :: forall pass. ConDecl pass -> Bool
con_forall = Bool
False
                      , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
Nothing
                      , con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args   = HsConDeclH98Details GhcRn
args }))
  = LocatedN Name -> HsConDeclH98Details GhcRn -> MetaM (Core (M Con))
repH98DataCon LIdP GhcRn
con HsConDeclH98Details GhcRn
args

repC (L SrcSpanAnnA
_ (ConDeclH98 { con_name :: forall pass. ConDecl pass -> LIdP pass
con_name = LIdP GhcRn
con
                      , con_forall :: forall pass. ConDecl pass -> Bool
con_forall = Bool
is_existential
                      , con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs = [LHsTyVarBndr Specificity GhcRn]
con_tvs
                      , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
mcxt
                      , con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = HsConDeclH98Details GhcRn
args }))
  = forall flag flag' a.
RepTV flag flag' =>
[LHsTyVarBndr flag GhcRn]
-> (Core [M (TyVarBndr flag')] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsTyVarBinds [LHsTyVarBndr Specificity GhcRn]
con_tvs forall a b. (a -> b) -> a -> b
$ \ Core [M (TyVarBndr Specificity)]
ex_bndrs ->
         do { Core (M Con)
c'    <- LocatedN Name -> HsConDeclH98Details GhcRn -> MetaM (Core (M Con))
repH98DataCon LIdP GhcRn
con HsConDeclH98Details GhcRn
args
            ; Core (M Cxt)
ctxt' <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repMbContext Maybe (LHsContext GhcRn)
mcxt
            ; if Bool -> Bool
not Bool
is_existential Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe (LHsContext GhcRn)
mcxt
              then forall (m :: * -> *) a. Monad m => a -> m a
return Core (M Con)
c'
              else forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
forallCName ([forall a. Core a -> CoreExpr
unC Core [M (TyVarBndr Specificity)]
ex_bndrs, forall a. Core a -> CoreExpr
unC Core (M Cxt)
ctxt', forall a. Core a -> CoreExpr
unC Core (M Con)
c'])
            }

repC (L SrcSpanAnnA
_ (ConDeclGADT { con_names :: forall pass. ConDecl pass -> [LIdP pass]
con_names  = [LIdP GhcRn]
cons
                       , con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs  = L SrcSpanAnnA
_ HsOuterSigTyVarBndrs GhcRn
outer_bndrs
                       , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
mcxt
                       , con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = HsConDeclGADTDetails GhcRn
args
                       , con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty = LHsType GhcRn
res_ty }))
  | Bool
null_outer_imp_tvs Bool -> Bool -> Bool
&& Bool
null_outer_exp_tvs
                                 -- No implicit or explicit variables
  , Maybe (LHsContext GhcRn)
Nothing <- Maybe (LHsContext GhcRn)
mcxt              -- No context
                                 -- ==> no need for a forall
  = [LocatedN Name]
-> HsConDeclGADTDetails GhcRn
-> LHsType GhcRn
-> MetaM (Core (M Con))
repGadtDataCons [LIdP GhcRn]
cons HsConDeclGADTDetails GhcRn
args LHsType GhcRn
res_ty

  | Bool
otherwise
  = forall a.
HsOuterSigTyVarBndrs GhcRn
-> (Core [M (TyVarBndr Specificity)] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsOuterSigTyVarBinds HsOuterSigTyVarBndrs GhcRn
outer_bndrs forall a b. (a -> b) -> a -> b
$ \ Core [M (TyVarBndr Specificity)]
outer_bndrs' ->
             -- See Note [Don't quantify implicit type variables in quotes]
    do { Core (M Con)
c'    <- [LocatedN Name]
-> HsConDeclGADTDetails GhcRn
-> LHsType GhcRn
-> MetaM (Core (M Con))
repGadtDataCons [LIdP GhcRn]
cons HsConDeclGADTDetails GhcRn
args LHsType GhcRn
res_ty
       ; Core (M Cxt)
ctxt' <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repMbContext Maybe (LHsContext GhcRn)
mcxt
       ; if Bool
null_outer_exp_tvs Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe (LHsContext GhcRn)
mcxt
         then forall (m :: * -> *) a. Monad m => a -> m a
return Core (M Con)
c'
         else forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
forallCName ([forall a. Core a -> CoreExpr
unC Core [M (TyVarBndr Specificity)]
outer_bndrs', forall a. Core a -> CoreExpr
unC Core (M Cxt)
ctxt', forall a. Core a -> CoreExpr
unC Core (M Con)
c']) }
  where
    null_outer_imp_tvs :: Bool
null_outer_imp_tvs = HsOuterSigTyVarBndrs GhcRn -> Bool
nullOuterImplicit HsOuterSigTyVarBndrs GhcRn
outer_bndrs
    null_outer_exp_tvs :: Bool
null_outer_exp_tvs = HsOuterSigTyVarBndrs GhcRn -> Bool
nullOuterExplicit HsOuterSigTyVarBndrs GhcRn
outer_bndrs

repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repMbContext Maybe (LHsContext GhcRn)
Nothing          = HsContext GhcRn -> MetaM (Core (M Cxt))
repContext []
repMbContext (Just (L SrcSpanAnnC
_ [GenLocated SrcSpanAnnA (HsType GhcRn)]
cxt)) = HsContext GhcRn -> MetaM (Core (M Cxt))
repContext [GenLocated SrcSpanAnnA (HsType GhcRn)]
cxt

repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness))
repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M SourceUnpackedness))
repSrcUnpackedness SrcUnpackedness
SrcUnpack   = forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
sourceUnpackName         []
repSrcUnpackedness SrcUnpackedness
SrcNoUnpack = forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
sourceNoUnpackName       []
repSrcUnpackedness SrcUnpackedness
NoSrcUnpack = forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
noSourceUnpackednessName []

repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness))
repSrcStrictness :: SrcStrictness -> MetaM (Core (M SourceStrictness))
repSrcStrictness SrcStrictness
SrcLazy     = forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
sourceLazyName         []
repSrcStrictness SrcStrictness
SrcStrict   = forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
sourceStrictName       []
repSrcStrictness SrcStrictness
NoSrcStrict = forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
noSourceStrictnessName []

repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType))
repBangTy :: LHsType GhcRn -> MetaM (Core (M BangType))
repBangTy LHsType GhcRn
ty = do
  MkC CoreExpr
u <- SrcUnpackedness -> MetaM (Core (M SourceUnpackedness))
repSrcUnpackedness SrcUnpackedness
su'
  MkC CoreExpr
s <- SrcStrictness -> MetaM (Core (M SourceStrictness))
repSrcStrictness SrcStrictness
ss'
  MkC CoreExpr
b <- forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
bangName [CoreExpr
u, CoreExpr
s]
  MkC CoreExpr
t <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy GenLocated SrcSpanAnnA (HsType GhcRn)
ty'
  forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
bangTypeName [CoreExpr
b, CoreExpr
t]
  where
    (SrcUnpackedness
su', SrcStrictness
ss', GenLocated SrcSpanAnnA (HsType GhcRn)
ty') = case forall l e. GenLocated l e -> e
unLoc LHsType GhcRn
ty of
            HsBangTy XBangTy GhcRn
_ (HsSrcBang SourceText
_ SrcUnpackedness
su SrcStrictness
ss) LHsType GhcRn
ty -> (SrcUnpackedness
su, SrcStrictness
ss, LHsType GhcRn
ty)
            HsType GhcRn
_ -> (SrcUnpackedness
NoSrcUnpack, SrcStrictness
NoSrcStrict, LHsType GhcRn
ty)

-------------------------------------------------------
--                      Deriving clauses
-------------------------------------------------------

repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause])
repDerivs :: HsDeriving GhcRn -> MetaM (Core [M DerivClause])
repDerivs HsDeriving GhcRn
clauses
  = forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repListM Name
derivClauseTyConName LHsDerivingClause GhcRn -> MetaM (Core (M DerivClause))
repDerivClause HsDeriving GhcRn
clauses

repDerivClause :: LHsDerivingClause GhcRn
               -> MetaM (Core (M TH.DerivClause))
repDerivClause :: LHsDerivingClause GhcRn -> MetaM (Core (M DerivClause))
repDerivClause (L SrcSpan
_ (HsDerivingClause
                          { deriv_clause_strategy :: forall pass. HsDerivingClause pass -> Maybe (LDerivStrategy pass)
deriv_clause_strategy = Maybe (LDerivStrategy GhcRn)
dcs
                          , deriv_clause_tys :: forall pass. HsDerivingClause pass -> LDerivClauseTys pass
deriv_clause_tys      = LDerivClauseTys GhcRn
dct }))
  = forall a.
Maybe (LDerivStrategy GhcRn)
-> (Core (Maybe (M DerivStrategy)) -> MetaM (Core (M a)))
-> MetaM (Core (M a))
repDerivStrategy Maybe (LDerivStrategy GhcRn)
dcs forall a b. (a -> b) -> a -> b
$ \(MkC CoreExpr
dcs') ->
    do MkC CoreExpr
dct' <- LDerivClauseTys GhcRn -> MetaM (Core [M Type])
rep_deriv_clause_tys LDerivClauseTys GhcRn
dct
       forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
derivClauseName [CoreExpr
dcs',CoreExpr
dct']
  where
    rep_deriv_clause_tys :: LDerivClauseTys GhcRn -> MetaM (Core [M TH.Type])
    rep_deriv_clause_tys :: LDerivClauseTys GhcRn -> MetaM (Core [M Type])
rep_deriv_clause_tys (L SrcSpanAnnC
_ DerivClauseTys GhcRn
dct) = case DerivClauseTys GhcRn
dct of
      DctSingle XDctSingle GhcRn
_ LHsSigType GhcRn
ty -> [LHsSigType GhcRn] -> MetaM (Core [M Type])
rep_deriv_tys [LHsSigType GhcRn
ty]
      DctMulti XDctMulti GhcRn
_ [LHsSigType GhcRn]
tys -> [LHsSigType GhcRn] -> MetaM (Core [M Type])
rep_deriv_tys [LHsSigType GhcRn]
tys

    rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type])
    rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M Type])
rep_deriv_tys = forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repListM Name
typeTyConName LHsSigType GhcRn -> MetaM (Core (M Type))
repHsSigType

rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
                    -> MetaM ([GenSymBind], [Core (M TH.Dec)])
-- Represent signatures and methods in class/instance declarations.
-- See Note [Scoped type variables in quotes]
--
-- Why not use 'repBinds': we have already created symbols for methods in
-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
-- these fun_id via 'collectHsValBinders decs', which would lead to the
-- instance declarations failing in TH.
rep_meth_sigs_binds :: [LSig GhcRn]
-> LHsBindsLR GhcRn GhcRn -> MetaM ([GenSymBind], [Core (M Dec)])
rep_meth_sigs_binds [LSig GhcRn]
sigs LHsBindsLR GhcRn GhcRn
binds
  = do { let tvs :: [Name]
tvs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LSig GhcRn -> [Name]
get_scoped_tvs [LSig GhcRn]
sigs
       ; [GenSymBind]
ss <- [Name] -> MetaM [GenSymBind]
mkGenSyms [Name]
tvs
       ; [(SrcSpan, Core (M Dec))]
sigs1 <- forall a. [GenSymBind] -> MetaM a -> MetaM a
addBinds [GenSymBind]
ss forall a b. (a -> b) -> a -> b
$ [LSig GhcRn] -> MetaM [(SrcSpan, Core (M Dec))]
rep_sigs [LSig GhcRn]
sigs
       ; [(SrcSpan, Core (M Dec))]
binds1 <- forall a. [GenSymBind] -> MetaM a -> MetaM a
addBinds [GenSymBind]
ss forall a b. (a -> b) -> a -> b
$ LHsBindsLR GhcRn GhcRn -> MetaM [(SrcSpan, Core (M Dec))]
rep_binds LHsBindsLR GhcRn GhcRn
binds
       ; forall (m :: * -> *) a. Monad m => a -> m a
return ([GenSymBind]
ss, forall a b. [(a, b)] -> [b]
de_loc (forall a. [(SrcSpan, a)] -> [(SrcSpan, a)]
sort_by_loc ([(SrcSpan, Core (M Dec))]
sigs1 forall a. [a] -> [a] -> [a]
++ [(SrcSpan, Core (M Dec))]
binds1))) }

-------------------------------------------------------
--   Signatures in a class decl, or a group of bindings
-------------------------------------------------------

rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))]
        -- We silently ignore ones we don't recognise
rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M Dec))]
rep_sigs = forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM LSig GhcRn -> MetaM [(SrcSpan, Core (M Dec))]
rep_sig

rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M Dec))]
rep_sig (L SrcSpanAnnA
loc (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
nms LHsSigWcType GhcRn
ty))
  = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name
-> SrcSpan
-> LHsSigWcType GhcRn
-> LocatedN Name
-> MetaM (SrcSpan, Core (M Dec))
rep_wc_ty_sig Name
sigDName (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) LHsSigWcType GhcRn
ty) [LIdP GhcRn]
nms
rep_sig (L SrcSpanAnnA
loc (PatSynSig XPatSynSig GhcRn
_ [LIdP GhcRn]
nms LHsSigType GhcRn
ty))
  = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan
-> LHsSigType GhcRn
-> LocatedN Name
-> MetaM (SrcSpan, Core (M Dec))
rep_patsyn_ty_sig (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) LHsSigType GhcRn
ty) [LIdP GhcRn]
nms
rep_sig (L SrcSpanAnnA
loc (ClassOpSig XClassOpSig GhcRn
_ Bool
is_deflt [LIdP GhcRn]
nms LHsSigType GhcRn
ty))
  | Bool
is_deflt     = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name
-> SrcSpan
-> LHsSigType GhcRn
-> LocatedN Name
-> MetaM (SrcSpan, Core (M Dec))
rep_ty_sig Name
defaultSigDName (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) LHsSigType GhcRn
ty) [LIdP GhcRn]
nms
  | Bool
otherwise    = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name
-> SrcSpan
-> LHsSigType GhcRn
-> LocatedN Name
-> MetaM (SrcSpan, Core (M Dec))
rep_ty_sig Name
sigDName (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) LHsSigType GhcRn
ty) [LIdP GhcRn]
nms
rep_sig d :: LSig GhcRn
d@(L SrcSpanAnnA
_ (IdSig {}))           = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rep_sig IdSig" (forall a. Outputable a => a -> SDoc
ppr LSig GhcRn
d)
rep_sig (L SrcSpanAnnA
loc (FixSig XFixSig GhcRn
_ FixitySig GhcRn
fix_sig))   = SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M Dec))]
rep_fix_d (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) FixitySig GhcRn
fix_sig
rep_sig (L SrcSpanAnnA
loc (InlineSig XInlineSig GhcRn
_ LIdP GhcRn
nm InlinePragma
ispec))= LocatedN Name
-> InlinePragma -> SrcSpan -> MetaM [(SrcSpan, Core (M Dec))]
rep_inline LIdP GhcRn
nm InlinePragma
ispec (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
rep_sig (L SrcSpanAnnA
loc (SpecSig XSpecSig GhcRn
_ LIdP GhcRn
nm [LHsSigType GhcRn]
tys InlinePragma
ispec))
  = forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (\GenLocated SrcSpanAnnA (HsSigType GhcRn)
t -> LocatedN Name
-> LHsSigType GhcRn
-> InlinePragma
-> SrcSpan
-> MetaM [(SrcSpan, Core (M Dec))]
rep_specialise LIdP GhcRn
nm GenLocated SrcSpanAnnA (HsSigType GhcRn)
t InlinePragma
ispec (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)) [LHsSigType GhcRn]
tys
rep_sig (L SrcSpanAnnA
loc (SpecInstSig XSpecInstSig GhcRn
_ SourceText
_ LHsSigType GhcRn
ty))  = LHsSigType GhcRn -> SrcSpan -> MetaM [(SrcSpan, Core (M Dec))]
rep_specialiseInst LHsSigType GhcRn
ty (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
rep_sig (L SrcSpanAnnA
_   (MinimalSig {}))       = forall a. String -> SDoc -> MetaM a
notHandled String
"MINIMAL pragmas" SDoc
empty
rep_sig (L SrcSpanAnnA
_   (SCCFunSig {}))        = forall a. String -> SDoc -> MetaM a
notHandled String
"SCC pragmas" SDoc
empty
rep_sig (L SrcSpanAnnA
loc (CompleteMatchSig XCompleteMatchSig GhcRn
_ SourceText
_st XRec GhcRn [LIdP GhcRn]
cls Maybe (LIdP GhcRn)
mty))
  = Located [LocatedN Name]
-> Maybe (LocatedN Name)
-> SrcSpan
-> MetaM [(SrcSpan, Core (M Dec))]
rep_complete_sig XRec GhcRn [LIdP GhcRn]
cls Maybe (LIdP GhcRn)
mty (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)

-- Desugar the explicit type variable binders in an 'LHsSigType', making
-- sure not to gensym them.
-- See Note [Scoped type variables in quotes]
-- and Note [Don't quantify implicit type variables in quotes]
rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn]
               -> MetaM (Core [M TH.TyVarBndrSpec])
rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn]
-> MetaM (Core [M (TyVarBndr Specificity)])
rep_ty_sig_tvs [LHsTyVarBndr Specificity GhcRn]
explicit_tvs
  = forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repListM Name
tyVarBndrSpecTyConName forall flag flag'.
RepTV flag flag' =>
LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TyVarBndr flag')))
repTyVarBndr
             [LHsTyVarBndr Specificity GhcRn]
explicit_tvs

-- Desugar the outer type variable binders in an 'LHsSigType', making
-- sure not to gensym them.
-- See Note [Scoped type variables in quotes]
-- and Note [Don't quantify implicit type variables in quotes]
rep_ty_sig_outer_tvs :: HsOuterSigTyVarBndrs GhcRn
                     -> MetaM (Core [M TH.TyVarBndrSpec])
rep_ty_sig_outer_tvs :: HsOuterSigTyVarBndrs GhcRn
-> MetaM (Core [M (TyVarBndr Specificity)])
rep_ty_sig_outer_tvs (HsOuterImplicit{}) =
  forall a. Name -> [Core a] -> MetaM (Core [a])
coreListM Name
tyVarBndrSpecTyConName []
rep_ty_sig_outer_tvs (HsOuterExplicit{hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
explicit_tvs}) =
  [LHsTyVarBndr Specificity GhcRn]
-> MetaM (Core [M (TyVarBndr Specificity)])
rep_ty_sig_tvs [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
explicit_tvs

-- Desugar a top-level type signature. Unlike 'repHsSigType', this
-- deliberately avoids gensymming the type variables.
-- See Note [Scoped type variables in quotes]
-- and Note [Don't quantify implicit type variables in quotes]
rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> LocatedN Name
           -> MetaM (SrcSpan, Core (M TH.Dec))
rep_ty_sig :: Name
-> SrcSpan
-> LHsSigType GhcRn
-> LocatedN Name
-> MetaM (SrcSpan, Core (M Dec))
rep_ty_sig Name
mk_sig SrcSpan
loc LHsSigType GhcRn
sig_ty LocatedN Name
nm
  = do { Core Name
nm1 <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LocatedN Name
nm
       ; Core (M Type)
ty1 <- LHsSigType GhcRn -> MetaM (Core (M Type))
rep_ty_sig' LHsSigType GhcRn
sig_ty
       ; Core (M Dec)
sig <- Name -> Core Name -> Core (M Type) -> MetaM (Core (M Dec))
repProto Name
mk_sig Core Name
nm1 Core (M Type)
ty1
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
loc, Core (M Dec)
sig) }

-- Desugar an 'LHsSigType', making sure not to gensym the type variables at
-- the front of the type signature.
-- See Note [Scoped type variables in quotes]
-- and Note [Don't quantify implicit type variables in quotes]
rep_ty_sig' :: LHsSigType GhcRn
            -> MetaM (Core (M TH.Type))
rep_ty_sig' :: LHsSigType GhcRn -> MetaM (Core (M Type))
rep_ty_sig' (L SrcSpanAnnA
_ (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
body}))
  | (Maybe (LHsContext GhcRn)
ctxt, LHsType GhcRn
tau) <- forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy LHsType GhcRn
body
  = do { Core [M (TyVarBndr Specificity)]
th_explicit_tvs <- HsOuterSigTyVarBndrs GhcRn
-> MetaM (Core [M (TyVarBndr Specificity)])
rep_ty_sig_outer_tvs HsOuterSigTyVarBndrs GhcRn
outer_bndrs
       ; Core (M Cxt)
th_ctxt <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repLContext Maybe (LHsContext GhcRn)
ctxt
       ; Core (M Type)
th_tau  <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
tau
       ; if HsOuterSigTyVarBndrs GhcRn -> Bool
nullOuterExplicit HsOuterSigTyVarBndrs GhcRn
outer_bndrs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
ctxt)
            then forall (m :: * -> *) a. Monad m => a -> m a
return Core (M Type)
th_tau
            else Core [M (TyVarBndr Specificity)]
-> Core (M Cxt) -> Core (M Type) -> MetaM (Core (M Type))
repTForall Core [M (TyVarBndr Specificity)]
th_explicit_tvs Core (M Cxt)
th_ctxt Core (M Type)
th_tau }

rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> LocatedN Name
                  -> MetaM (SrcSpan, Core (M TH.Dec))
-- represents a pattern synonym type signature;
-- see Note [Pattern synonym type signatures and Template Haskell] in "GHC.ThToHs"
--
-- Don't create the implicit and explicit variables when desugaring signatures,
-- see Note [Scoped type variables in quotes]
-- and Note [Don't quantify implicit type variables in quotes]
rep_patsyn_ty_sig :: SrcSpan
-> LHsSigType GhcRn
-> LocatedN Name
-> MetaM (SrcSpan, Core (M Dec))
rep_patsyn_ty_sig SrcSpan
loc LHsSigType GhcRn
sig_ty LocatedN Name
nm
  | ([LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass 'Renamed))]
univs, Maybe (LHsContext GhcRn)
reqs, [LHsTyVarBndr Specificity GhcRn]
exis, Maybe (LHsContext GhcRn)
provs, LHsType GhcRn
ty) <- forall (p :: Pass).
LHsSigType (GhcPass p)
-> ([LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))],
    Maybe (LHsContext (GhcPass p)),
    [LHsTyVarBndr Specificity (GhcPass p)],
    Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))
splitLHsPatSynTy LHsSigType GhcRn
sig_ty
  = do { Core Name
nm1 <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LocatedN Name
nm
       ; Core [M (TyVarBndr Specificity)]
th_univs <- [LHsTyVarBndr Specificity GhcRn]
-> MetaM (Core [M (TyVarBndr Specificity)])
rep_ty_sig_tvs [LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass 'Renamed))]
univs
       ; Core [M (TyVarBndr Specificity)]
th_exis  <- [LHsTyVarBndr Specificity GhcRn]
-> MetaM (Core [M (TyVarBndr Specificity)])
rep_ty_sig_tvs [LHsTyVarBndr Specificity GhcRn]
exis

       ; Core (M Cxt)
th_reqs  <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repLContext Maybe (LHsContext GhcRn)
reqs
       ; Core (M Cxt)
th_provs <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repLContext Maybe (LHsContext GhcRn)
provs
       ; Core (M Type)
th_ty    <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
ty
       ; Core (M Type)
ty1      <- Core [M (TyVarBndr Specificity)]
-> Core (M Cxt) -> Core (M Type) -> MetaM (Core (M Type))
repTForall Core [M (TyVarBndr Specificity)]
th_univs Core (M Cxt)
th_reqs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                       Core [M (TyVarBndr Specificity)]
-> Core (M Cxt) -> Core (M Type) -> MetaM (Core (M Type))
repTForall Core [M (TyVarBndr Specificity)]
th_exis Core (M Cxt)
th_provs Core (M Type)
th_ty
       ; Core (M Dec)
sig      <- Name -> Core Name -> Core (M Type) -> MetaM (Core (M Dec))
repProto Name
patSynSigDName Core Name
nm1 Core (M Type)
ty1
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
loc, Core (M Dec)
sig) }

rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> LocatedN Name
              -> MetaM (SrcSpan, Core (M TH.Dec))
rep_wc_ty_sig :: Name
-> SrcSpan
-> LHsSigWcType GhcRn
-> LocatedN Name
-> MetaM (SrcSpan, Core (M Dec))
rep_wc_ty_sig Name
mk_sig SrcSpan
loc LHsSigWcType GhcRn
sig_ty LocatedN Name
nm
  = Name
-> SrcSpan
-> LHsSigType GhcRn
-> LocatedN Name
-> MetaM (SrcSpan, Core (M Dec))
rep_ty_sig Name
mk_sig SrcSpan
loc (forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsSigWcType GhcRn
sig_ty) LocatedN Name
nm

rep_inline :: LocatedN Name
           -> InlinePragma      -- Never defaultInlinePragma
           -> SrcSpan
           -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_inline :: LocatedN Name
-> InlinePragma -> SrcSpan -> MetaM [(SrcSpan, Core (M Dec))]
rep_inline LocatedN Name
nm InlinePragma
ispec SrcSpan
loc
  = do { Core Name
nm1    <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LocatedN Name
nm
       ; Core Inline
inline <- InlineSpec -> MetaM (Core Inline)
repInline forall a b. (a -> b) -> a -> b
$ InlinePragma -> InlineSpec
inl_inline InlinePragma
ispec
       ; Core RuleMatch
rm     <- RuleMatchInfo -> MetaM (Core RuleMatch)
repRuleMatch forall a b. (a -> b) -> a -> b
$ InlinePragma -> RuleMatchInfo
inl_rule InlinePragma
ispec
       ; Core Phases
phases <- Activation -> MetaM (Core Phases)
repPhases forall a b. (a -> b) -> a -> b
$ InlinePragma -> Activation
inl_act InlinePragma
ispec
       ; Core (M Dec)
pragma <- Core Name
-> Core Inline
-> Core RuleMatch
-> Core Phases
-> MetaM (Core (M Dec))
repPragInl Core Name
nm1 Core Inline
inline Core RuleMatch
rm Core Phases
phases
       ; forall (m :: * -> *) a. Monad m => a -> m a
return [(SrcSpan
loc, Core (M Dec)
pragma)]
       }

rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma
               -> SrcSpan
               -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_specialise :: LocatedN Name
-> LHsSigType GhcRn
-> InlinePragma
-> SrcSpan
-> MetaM [(SrcSpan, Core (M Dec))]
rep_specialise LocatedN Name
nm LHsSigType GhcRn
ty InlinePragma
ispec SrcSpan
loc
  = do { Core Name
nm1 <- forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc LocatedN Name
nm
       ; Core (M Type)
ty1 <- LHsSigType GhcRn -> MetaM (Core (M Type))
repHsSigType LHsSigType GhcRn
ty
       ; Core Phases
phases <- Activation -> MetaM (Core Phases)
repPhases forall a b. (a -> b) -> a -> b
$ InlinePragma -> Activation
inl_act InlinePragma
ispec
       ; let inline :: InlineSpec
inline = InlinePragma -> InlineSpec
inl_inline InlinePragma
ispec
       ; Core (M Dec)
pragma <- if InlineSpec -> Bool
noUserInlineSpec InlineSpec
inline
                   then -- SPECIALISE
                     Core Name -> Core (M Type) -> Core Phases -> MetaM (Core (M Dec))
repPragSpec Core Name
nm1 Core (M Type)
ty1 Core Phases
phases
                   else -- SPECIALISE INLINE
                     do { Core Inline
inline1 <- InlineSpec -> MetaM (Core Inline)
repInline InlineSpec
inline
                        ; Core Name
-> Core (M Type)
-> Core Inline
-> Core Phases
-> MetaM (Core (M Dec))
repPragSpecInl Core Name
nm1 Core (M Type)
ty1 Core Inline
inline1 Core Phases
phases }
       ; forall (m :: * -> *) a. Monad m => a -> m a
return [(SrcSpan
loc, Core (M Dec)
pragma)]
       }

rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
                   -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan -> MetaM [(SrcSpan, Core (M Dec))]
rep_specialiseInst LHsSigType GhcRn
ty SrcSpan
loc
  = do { Core (M Type)
ty1    <- LHsSigType GhcRn -> MetaM (Core (M Type))
repHsSigType LHsSigType GhcRn
ty
       ; Core (M Dec)
pragma <- Core (M Type) -> MetaM (Core (M Dec))
repPragSpecInst Core (M Type)
ty1
       ; forall (m :: * -> *) a. Monad m => a -> m a
return [(SrcSpan
loc, Core (M Dec)
pragma)] }

repInline :: InlineSpec -> MetaM (Core TH.Inline)
repInline :: InlineSpec -> MetaM (Core Inline)
repInline InlineSpec
NoInline         = forall a. Name -> MetaM (Core a)
dataCon Name
noInlineDataConName
repInline InlineSpec
Inline           = forall a. Name -> MetaM (Core a)
dataCon Name
inlineDataConName
repInline InlineSpec
Inlinable        = forall a. Name -> MetaM (Core a)
dataCon Name
inlinableDataConName
repInline InlineSpec
NoUserInlinePrag = forall a. String -> SDoc -> MetaM a
notHandled String
"NOUSERINLINE" SDoc
empty

repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch)
repRuleMatch :: RuleMatchInfo -> MetaM (Core RuleMatch)
repRuleMatch RuleMatchInfo
ConLike = forall a. Name -> MetaM (Core a)
dataCon Name
conLikeDataConName
repRuleMatch RuleMatchInfo
FunLike = forall a. Name -> MetaM (Core a)
dataCon Name
funLikeDataConName

repPhases :: Activation -> MetaM (Core TH.Phases)
repPhases :: Activation -> MetaM (Core Phases)
repPhases (ActiveBefore SourceText
_ Int
i) = do { MkC CoreExpr
arg <- Int -> MetaM (Core Int)
coreIntLit Int
i
                                  ; forall a. Name -> [CoreExpr] -> MetaM (Core a)
dataCon' Name
beforePhaseDataConName [CoreExpr
arg] }
repPhases (ActiveAfter SourceText
_ Int
i)  = do { MkC CoreExpr
arg <- Int -> MetaM (Core Int)
coreIntLit Int
i
                                  ; forall a. Name -> [CoreExpr] -> MetaM (Core a)
dataCon' Name
fromPhaseDataConName [CoreExpr
arg] }
repPhases Activation
_                  = forall a. Name -> MetaM (Core a)
dataCon Name
allPhasesDataConName

rep_complete_sig :: Located [LocatedN Name]
                 -> Maybe (LocatedN Name)
                 -> SrcSpan
                 -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_complete_sig :: Located [LocatedN Name]
-> Maybe (LocatedN Name)
-> SrcSpan
-> MetaM [(SrcSpan, Core (M Dec))]
rep_complete_sig (L SrcSpan
_ [LocatedN Name]
cls) Maybe (LocatedN Name)
mty SrcSpan
loc
  = do { Core (Maybe Name)
mty' <- forall a b.
Name -> (a -> MetaM (Core b)) -> Maybe a -> MetaM (Core (Maybe b))
repMaybe Name
nameTyConName forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc Maybe (LocatedN Name)
mty
       ; Core [Name]
cls' <- forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repList Name
nameTyConName forall l. GenLocated l Name -> MetaM (Core Name)
lookupLOcc [LocatedN Name]
cls
       ; Core (M Dec)
sig <- Core [Name] -> Core (Maybe Name) -> MetaM (Core (M Dec))
repPragComplete Core [Name]
cls' Core (Maybe Name)
mty'
       ; forall (m :: * -> *) a. Monad m => a -> m a
return [(SrcSpan
loc, Core (M Dec)
sig)] }

-------------------------------------------------------
--                      Types
-------------------------------------------------------

class RepTV flag flag' | flag -> flag' where
    tyVarBndrName :: Name
    repPlainTV  :: Core TH.Name -> flag -> MetaM (Core (M (TH.TyVarBndr flag')))
    repKindedTV :: Core TH.Name -> flag -> Core (M TH.Kind)
                -> MetaM (Core (M (TH.TyVarBndr flag')))

instance RepTV () () where
    tyVarBndrName :: Name
tyVarBndrName = Name
tyVarBndrUnitTyConName
    repPlainTV :: Core Name -> () -> MetaM (Core (M (TyVarBndr ())))
repPlainTV  (MkC CoreExpr
nm) ()          = forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
plainTVName  [CoreExpr
nm]
    repKindedTV :: Core Name -> () -> Core (M Type) -> MetaM (Core (M (TyVarBndr ())))
repKindedTV (MkC CoreExpr
nm) () (MkC CoreExpr
ki) = forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
kindedTVName [CoreExpr
nm, CoreExpr
ki]

instance RepTV Specificity TH.Specificity where
    tyVarBndrName :: Name
tyVarBndrName = Name
tyVarBndrSpecTyConName
    repPlainTV :: Core Name
-> Specificity -> MetaM (Core (M (TyVarBndr Specificity)))
repPlainTV  (MkC CoreExpr
nm) Specificity
spec          = do { (MkC CoreExpr
spec') <- Specificity -> MetaM (Core Specificity)
rep_flag Specificity
spec
                                            ; forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
plainInvisTVName  [CoreExpr
nm, CoreExpr
spec'] }
    repKindedTV :: Core Name
-> Specificity
-> Core (M Type)
-> MetaM (Core (M (TyVarBndr Specificity)))
repKindedTV (MkC CoreExpr
nm) Specificity
spec (MkC CoreExpr
ki) = do { (MkC CoreExpr
spec') <- Specificity -> MetaM (Core Specificity)
rep_flag Specificity
spec
                                            ; forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
kindedInvisTVName [CoreExpr
nm, CoreExpr
spec', CoreExpr
ki] }

rep_flag :: Specificity -> MetaM (Core TH.Specificity)
rep_flag :: Specificity -> MetaM (Core Specificity)
rep_flag Specificity
SpecifiedSpec = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
specifiedSpecName []
rep_flag Specificity
InferredSpec  = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
inferredSpecName []

addHsOuterFamEqnTyVarBinds ::
     HsOuterFamEqnTyVarBndrs GhcRn
  -> (Core (Maybe [M TH.TyVarBndrUnit]) -> MetaM (Core (M a)))
  -> MetaM (Core (M a))
addHsOuterFamEqnTyVarBinds :: forall a.
HsOuterFamEqnTyVarBndrs GhcRn
-> (Core (Maybe [M (TyVarBndr ())]) -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsOuterFamEqnTyVarBinds HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs Core (Maybe [M (TyVarBndr ())]) -> MetaM (Core (M a))
thing_inside = do
  Type
elt_ty <- Name -> MetaM Type
wrapName Name
tyVarBndrUnitTyConName
  case HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs of
    HsOuterImplicit{hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcRn
imp_tvs} ->
      forall a.
LHsQTyVars GhcRn
-> (Core [M (TyVarBndr ())] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addTyClTyVarBinds (forall {pass}.
XHsQTvs pass
-> [XRec pass (HsTyVarBndr () pass)] -> LHsQTyVars pass
mk_qtvs XHsOuterImplicit GhcRn
imp_tvs []) forall a b. (a -> b) -> a -> b
$ \Core [M (TyVarBndr ())]
_th_exp_bndrs ->
      Core (Maybe [M (TyVarBndr ())]) -> MetaM (Core (M a))
thing_inside forall a b. (a -> b) -> a -> b
$ forall a. Type -> Core (Maybe [a])
coreNothingList Type
elt_ty
    HsOuterExplicit{hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr () (NoGhcTc GhcRn)]
exp_bndrs} ->
      forall a.
LHsQTyVars GhcRn
-> (Core [M (TyVarBndr ())] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addTyClTyVarBinds (forall {pass}.
XHsQTvs pass
-> [XRec pass (HsTyVarBndr () pass)] -> LHsQTyVars pass
mk_qtvs [] [LHsTyVarBndr () (NoGhcTc GhcRn)]
exp_bndrs) forall a b. (a -> b) -> a -> b
$ \Core [M (TyVarBndr ())]
th_exp_bndrs ->
      Core (Maybe [M (TyVarBndr ())]) -> MetaM (Core (M a))
thing_inside forall a b. (a -> b) -> a -> b
$ forall a. Type -> Core [a] -> Core (Maybe [a])
coreJustList Type
elt_ty Core [M (TyVarBndr ())]
th_exp_bndrs
  where
    mk_qtvs :: XHsQTvs pass
-> [XRec pass (HsTyVarBndr () pass)] -> LHsQTyVars pass
mk_qtvs XHsQTvs pass
imp_tvs [XRec pass (HsTyVarBndr () pass)]
exp_tvs = HsQTvs { hsq_ext :: XHsQTvs pass
hsq_ext = XHsQTvs pass
imp_tvs
                                     , hsq_explicit :: [XRec pass (HsTyVarBndr () pass)]
hsq_explicit = [XRec pass (HsTyVarBndr () pass)]
exp_tvs }

addHsOuterSigTyVarBinds ::
     HsOuterSigTyVarBndrs GhcRn
  -> (Core [M TH.TyVarBndrSpec] -> MetaM (Core (M a)))
  -> MetaM (Core (M a))
addHsOuterSigTyVarBinds :: forall a.
HsOuterSigTyVarBndrs GhcRn
-> (Core [M (TyVarBndr Specificity)] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsOuterSigTyVarBinds HsOuterSigTyVarBndrs GhcRn
outer_bndrs Core [M (TyVarBndr Specificity)] -> MetaM (Core (M a))
thing_inside = case HsOuterSigTyVarBndrs GhcRn
outer_bndrs of
  HsOuterImplicit{hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcRn
imp_tvs} ->
    do Core [M (TyVarBndr Specificity)]
th_nil <- forall a. Name -> [Core a] -> MetaM (Core [a])
coreListM Name
tyVarBndrSpecTyConName []
       forall a. [Name] -> MetaM (Core (M a)) -> MetaM (Core (M a))
addSimpleTyVarBinds XHsOuterImplicit GhcRn
imp_tvs forall a b. (a -> b) -> a -> b
$ Core [M (TyVarBndr Specificity)] -> MetaM (Core (M a))
thing_inside Core [M (TyVarBndr Specificity)]
th_nil
  HsOuterExplicit{hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
exp_bndrs} ->
    forall flag flag' a.
RepTV flag flag' =>
[LHsTyVarBndr flag GhcRn]
-> (Core [M (TyVarBndr flag')] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsTyVarBinds [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
exp_bndrs Core [M (TyVarBndr Specificity)] -> MetaM (Core (M a))
thing_inside

-- | If a type implicitly quantifies its outermost type variables, return
-- 'True' if the list of implicitly bound type variables is empty. If a type
-- explicitly quantifies its outermost type variables, always return 'True'.
--
-- This is used in various places to determine if a Template Haskell 'Type'
-- should be headed by a 'ForallT' or not.
nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
nullOuterImplicit (HsOuterImplicit{hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcRn
imp_tvs}) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null XHsOuterImplicit GhcRn
imp_tvs
nullOuterImplicit (HsOuterExplicit{})                        = Bool
True
  -- Vacuously true, as there is no implicit quantification

-- | If a type explicitly quantifies its outermost type variables, return
-- 'True' if the list of explicitly bound type variables is empty. If a type
-- implicitly quantifies its outermost type variables, always return 'True'.
--
-- This is used in various places to determine if a Template Haskell 'Type'
-- should be headed by a 'ForallT' or not.
nullOuterExplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
nullOuterExplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
nullOuterExplicit (HsOuterExplicit{hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
exp_bndrs}) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
exp_bndrs
nullOuterExplicit (HsOuterImplicit{})                      = Bool
True
  -- Vacuously true, as there is no outermost explicit quantification

addSimpleTyVarBinds :: [Name]             -- the binders to be added
                    -> MetaM (Core (M a)) -- action in the ext env
                    -> MetaM (Core (M a))
addSimpleTyVarBinds :: forall a. [Name] -> MetaM (Core (M a)) -> MetaM (Core (M a))
addSimpleTyVarBinds [Name]
names MetaM (Core (M a))
thing_inside
  = do { [GenSymBind]
fresh_names <- [Name] -> MetaM [GenSymBind]
mkGenSyms [Name]
names
       ; Core (M a)
term <- forall a. [GenSymBind] -> MetaM a -> MetaM a
addBinds [GenSymBind]
fresh_names MetaM (Core (M a))
thing_inside
       ; forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms [GenSymBind]
fresh_names Core (M a)
term }

addHsTyVarBinds :: forall flag flag' a. RepTV flag flag'
                => [LHsTyVarBndr flag GhcRn] -- the binders to be added
                -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
                -> MetaM (Core (M a))
addHsTyVarBinds :: forall flag flag' a.
RepTV flag flag' =>
[LHsTyVarBndr flag GhcRn]
-> (Core [M (TyVarBndr flag')] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsTyVarBinds [LHsTyVarBndr flag GhcRn]
exp_tvs Core [M (TyVarBndr flag')] -> MetaM (Core (M a))
thing_inside
  = do { [GenSymBind]
fresh_exp_names <- [Name] -> MetaM [GenSymBind]
mkGenSyms (forall flag (p :: Pass).
[LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]
hsLTyVarNames [LHsTyVarBndr flag GhcRn]
exp_tvs)
       ; Core (M a)
term <- forall a. [GenSymBind] -> MetaM a -> MetaM a
addBinds [GenSymBind]
fresh_exp_names forall a b. (a -> b) -> a -> b
$
                 do { Core [M (TyVarBndr flag')]
kbs <- forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repListM (forall flag flag'. RepTV flag flag' => Name
tyVarBndrName @flag @flag') forall flag flag'.
RepTV flag flag' =>
LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TyVarBndr flag')))
repTyVarBndr
                                      [LHsTyVarBndr flag GhcRn]
exp_tvs
                    ; Core [M (TyVarBndr flag')] -> MetaM (Core (M a))
thing_inside Core [M (TyVarBndr flag')]
kbs }
       ; forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms [GenSymBind]
fresh_exp_names Core (M a)
term }

addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
               -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env
               -> MetaM (Core (M a))
addQTyVarBinds :: forall a.
LHsQTyVars GhcRn
-> (Core [M (TyVarBndr ())] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addQTyVarBinds (HsQTvs { hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_ext = XHsQTvs GhcRn
imp_tvs
                      , hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit = [LHsTyVarBndr () GhcRn]
exp_tvs })
              Core [M (TyVarBndr ())] -> MetaM (Core (M a))
thing_inside
  = forall flag flag' a.
RepTV flag flag' =>
[LHsTyVarBndr flag GhcRn]
-> [Name]
-> (Core [M (TyVarBndr flag')] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addTyVarBinds [LHsTyVarBndr () GhcRn]
exp_tvs XHsQTvs GhcRn
imp_tvs Core [M (TyVarBndr ())] -> MetaM (Core (M a))
thing_inside

addTyVarBinds :: RepTV flag flag'
              => [LHsTyVarBndr flag GhcRn] -- the binders to be added
              -> [Name]
              -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
              -> MetaM (Core (M a))
-- gensym a list of type variables and enter them into the meta environment;
-- the computations passed as the second argument is executed in that extended
-- meta environment and gets the *new* names on Core-level as an argument
addTyVarBinds :: forall flag flag' a.
RepTV flag flag' =>
[LHsTyVarBndr flag GhcRn]
-> [Name]
-> (Core [M (TyVarBndr flag')] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addTyVarBinds [LHsTyVarBndr flag GhcRn]
exp_tvs [Name]
imp_tvs Core [M (TyVarBndr flag')] -> MetaM (Core (M a))
thing_inside
  = forall a. [Name] -> MetaM (Core (M a)) -> MetaM (Core (M a))
addSimpleTyVarBinds [Name]
imp_tvs forall a b. (a -> b) -> a -> b
$
    forall flag flag' a.
RepTV flag flag' =>
[LHsTyVarBndr flag GhcRn]
-> (Core [M (TyVarBndr flag')] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsTyVarBinds [LHsTyVarBndr flag GhcRn]
exp_tvs forall a b. (a -> b) -> a -> b
$
    Core [M (TyVarBndr flag')] -> MetaM (Core (M a))
thing_inside

addTyClTyVarBinds :: LHsQTyVars GhcRn
                  -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a)))
                  -> MetaM (Core (M a))
-- Used for data/newtype declarations, and family instances,
-- so that the nested type variables work right
--    instance C (T a) where
--      type W (T a) = blah
-- The 'a' in the type instance is the one bound by the instance decl
addTyClTyVarBinds :: forall a.
LHsQTyVars GhcRn
-> (Core [M (TyVarBndr ())] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addTyClTyVarBinds LHsQTyVars GhcRn
tvs Core [M (TyVarBndr ())] -> MetaM (Core (M a))
m
  = do { let tv_names :: [Name]
tv_names = LHsQTyVars GhcRn -> [Name]
hsAllLTyVarNames LHsQTyVars GhcRn
tvs
       ; DsMetaEnv
env <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ DsM DsMetaEnv
dsGetMetaEnv
       ; [GenSymBind]
freshNames <- [Name] -> MetaM [GenSymBind]
mkGenSyms (forall a. (a -> Bool) -> [a] -> [a]
filterOut (forall a. Name -> NameEnv a -> Bool
`elemNameEnv` DsMetaEnv
env) [Name]
tv_names)
            -- Make fresh names for the ones that are not already in scope
            -- This makes things work for family declarations

       ; Core (M a)
term <- forall a. [GenSymBind] -> MetaM a -> MetaM a
addBinds [GenSymBind]
freshNames forall a b. (a -> b) -> a -> b
$
                 do { Core [M (TyVarBndr ())]
kbs <- forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repListM Name
tyVarBndrUnitTyConName forall flag flag'.
RepTV flag flag' =>
LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TyVarBndr flag')))
repTyVarBndr
                                     (forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsQTvExplicit LHsQTyVars GhcRn
tvs)
                    ; Core [M (TyVarBndr ())] -> MetaM (Core (M a))
m Core [M (TyVarBndr ())]
kbs }

       ; forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms [GenSymBind]
freshNames Core (M a)
term }

-- | Represent a type variable binder
repTyVarBndr :: RepTV flag flag'
             => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag')))
repTyVarBndr :: forall flag flag'.
RepTV flag flag' =>
LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TyVarBndr flag')))
repTyVarBndr (L SrcSpanAnnA
_ (UserTyVar XUserTyVar GhcRn
_ flag
fl (L SrcSpanAnnN
_ Name
nm)) )
  = do { Core Name
nm' <- Name -> MetaM (Core Name)
lookupBinder Name
nm
       ; forall flag flag'.
RepTV flag flag' =>
Core Name -> flag -> MetaM (Core (M (TyVarBndr flag')))
repPlainTV Core Name
nm' flag
fl }
repTyVarBndr (L SrcSpanAnnA
_ (KindedTyVar XKindedTyVar GhcRn
_ flag
fl (L SrcSpanAnnN
_ Name
nm) LHsType GhcRn
ki))
  = do { Core Name
nm' <- Name -> MetaM (Core Name)
lookupBinder Name
nm
       ; Core (M Type)
ki' <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
ki
       ; forall flag flag'.
RepTV flag flag' =>
Core Name
-> flag -> Core (M Type) -> MetaM (Core (M (TyVarBndr flag')))
repKindedTV Core Name
nm' flag
fl Core (M Type)
ki' }

-- represent a type context
--
repLContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
repLContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repLContext Maybe (LHsContext GhcRn)
Nothing = HsContext GhcRn -> MetaM (Core (M Cxt))
repContext []
repLContext (Just LHsContext GhcRn
ctxt) = HsContext GhcRn -> MetaM (Core (M Cxt))
repContext (forall l e. GenLocated l e -> e
unLoc LHsContext GhcRn
ctxt)

repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt))
repContext :: HsContext GhcRn -> MetaM (Core (M Cxt))
repContext HsContext GhcRn
ctxt = do Core [M Type]
preds <- forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repListM Name
typeTyConName LHsType GhcRn -> MetaM (Core (M Type))
repLTy HsContext GhcRn
ctxt
                     Core [M Type] -> MetaM (Core (M Cxt))
repCtxt Core [M Type]
preds

repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))
repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M Type))
repHsSigType (L SrcSpanAnnA
_ (HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
body }))
  | (Maybe (LHsContext GhcRn)
ctxt, LHsType GhcRn
tau) <- forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy LHsType GhcRn
body
  = forall a.
HsOuterSigTyVarBndrs GhcRn
-> (Core [M (TyVarBndr Specificity)] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsOuterSigTyVarBinds HsOuterSigTyVarBndrs GhcRn
outer_bndrs forall a b. (a -> b) -> a -> b
$ \ Core [M (TyVarBndr Specificity)]
th_outer_bndrs ->
    do { Core (M Cxt)
th_ctxt <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repLContext Maybe (LHsContext GhcRn)
ctxt
       ; Core (M Type)
th_tau  <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
tau
       ; if HsOuterSigTyVarBndrs GhcRn -> Bool
nullOuterExplicit HsOuterSigTyVarBndrs GhcRn
outer_bndrs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
ctxt)
         then forall (f :: * -> *) a. Applicative f => a -> f a
pure Core (M Type)
th_tau
         else Core [M (TyVarBndr Specificity)]
-> Core (M Cxt) -> Core (M Type) -> MetaM (Core (M Type))
repTForall Core [M (TyVarBndr Specificity)]
th_outer_bndrs Core (M Cxt)
th_ctxt Core (M Type)
th_tau }

-- yield the representation of a list of types
repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]
repLTys :: HsContext GhcRn -> MetaM [Core (M Type)]
repLTys HsContext GhcRn
tys = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsType GhcRn -> MetaM (Core (M Type))
repLTy HsContext GhcRn
tys

-- represent a type
repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type))
repLTy :: LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
ty = HsType GhcRn -> MetaM (Core (M Type))
repTy (forall l e. GenLocated l e -> e
unLoc LHsType GhcRn
ty)

-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or
-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax.
-- In other words, the argument to this function is always an
-- @HsForAllTy HsForAllInvis{}@ or @HsQualTy@.
-- Types headed by visible foralls (which are desugared to ForallVisT) are
-- handled separately in repTy.
repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
repForallT :: HsType GhcRn -> MetaM (Core (M Type))
repForallT HsType GhcRn
ty
 | ([LHsTyVarBndr Specificity GhcRn]
tvs, Maybe (LHsContext GhcRn)
ctxt, LHsType GhcRn
tau) <- forall (p :: Pass).
LHsType (GhcPass p)
-> ([LHsTyVarBndr Specificity (GhcPass p)],
    Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))
splitLHsSigmaTyInvis (forall a an. a -> LocatedAn an a
noLocA HsType GhcRn
ty)
 = forall flag flag' a.
RepTV flag flag' =>
[LHsTyVarBndr flag GhcRn]
-> (Core [M (TyVarBndr flag')] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsTyVarBinds [LHsTyVarBndr Specificity GhcRn]
tvs forall a b. (a -> b) -> a -> b
$ \Core [M (TyVarBndr Specificity)]
bndrs ->
   do { Core (M Cxt)
ctxt1  <- Maybe (LHsContext GhcRn) -> MetaM (Core (M Cxt))
repLContext Maybe (LHsContext GhcRn)
ctxt
      ; Core (M Type)
tau1   <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
tau
      ; Core [M (TyVarBndr Specificity)]
-> Core (M Cxt) -> Core (M Type) -> MetaM (Core (M Type))
repTForall Core [M (TyVarBndr Specificity)]
bndrs Core (M Cxt)
ctxt1 Core (M Type)
tau1 -- forall a. C a => {...}
      }

repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))
repTy :: HsType GhcRn -> MetaM (Core (M Type))
repTy ty :: HsType GhcRn
ty@(HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcRn
tele, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
body }) =
  case HsForAllTelescope GhcRn
tele of
    HsForAllInvis{} -> HsType GhcRn -> MetaM (Core (M Type))
repForallT HsType GhcRn
ty
    HsForAllVis { hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs = [LHsTyVarBndr () GhcRn]
tvs } ->
      forall flag flag' a.
RepTV flag flag' =>
[LHsTyVarBndr flag GhcRn]
-> (Core [M (TyVarBndr flag')] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
addHsTyVarBinds [LHsTyVarBndr () GhcRn]
tvs forall a b. (a -> b) -> a -> b
$ \Core [M (TyVarBndr ())]
bndrs ->
      do Core (M Type)
body1 <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
body
         Core [M (TyVarBndr ())] -> Core (M Type) -> MetaM (Core (M Type))
repTForallVis Core [M (TyVarBndr ())]
bndrs Core (M Type)
body1
repTy ty :: HsType GhcRn
ty@(HsQualTy {}) = HsType GhcRn -> MetaM (Core (M Type))
repForallT HsType GhcRn
ty

repTy (HsTyVar XTyVar GhcRn
_ PromotionFlag
_ (L SrcSpanAnnN
_ Name
n))
  | Name -> Bool
isLiftedTypeKindTyConName Name
n        = MetaM (Core (M Type))
repTStar
  | Name
n forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
constraintKindTyConKey  = MetaM (Core (M Type))
repTConstraint
  | Name
n forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unrestrictedFunTyConKey = MetaM (Core (M Type))
repArrowTyCon
  | Name
n forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funTyConKey             = MetaM (Core (M Type))
repMulArrowTyCon
  | OccName -> Bool
isTvOcc OccName
occ   = do Core Name
tv1 <- Name -> MetaM (Core Name)
lookupOcc Name
n
                       Core Name -> MetaM (Core (M Type))
repTvar Core Name
tv1
  | OccName -> Bool
isDataOcc OccName
occ = do Core Name
tc1 <- Name -> MetaM (Core Name)
lookupOcc Name
n
                       Core Name -> MetaM (Core (M Type))
repPromotedDataCon Core Name
tc1
  | Name
n forall a. Eq a => a -> a -> Bool
== Name
eqTyConName = MetaM (Core (M Type))
repTequality
  | Bool
otherwise     = do Core Name
tc1 <- Name -> MetaM (Core Name)
lookupOcc Name
n
                       Core Name -> MetaM (Core (M Type))
repNamedTyCon Core Name
tc1
  where
    occ :: OccName
occ = Name -> OccName
nameOccName Name
n

repTy (HsAppTy XAppTy GhcRn
_ LHsType GhcRn
f LHsType GhcRn
a)       = do
                                Core (M Type)
f1 <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
f
                                Core (M Type)
a1 <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
a
                                Core (M Type) -> Core (M Type) -> MetaM (Core (M Type))
repTapp Core (M Type)
f1 Core (M Type)
a1
repTy (HsAppKindTy XAppKindTy GhcRn
_ LHsType GhcRn
ty LHsType GhcRn
ki) = do
                                Core (M Type)
ty1 <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
ty
                                Core (M Type)
ki1 <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
ki
                                Core (M Type) -> Core (M Type) -> MetaM (Core (M Type))
repTappKind Core (M Type)
ty1 Core (M Type)
ki1
repTy (HsFunTy XFunTy GhcRn
_ HsArrow GhcRn
w LHsType GhcRn
f LHsType GhcRn
a) | HsArrow GhcRn -> Bool
isUnrestricted HsArrow GhcRn
w = do
                                Core (M Type)
f1   <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
f
                                Core (M Type)
a1   <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
a
                                Core (M Type)
tcon <- MetaM (Core (M Type))
repArrowTyCon
                                Core (M Type) -> [Core (M Type)] -> MetaM (Core (M Type))
repTapps Core (M Type)
tcon [Core (M Type)
f1, Core (M Type)
a1]
repTy (HsFunTy XFunTy GhcRn
_ HsArrow GhcRn
w LHsType GhcRn
f LHsType GhcRn
a) = do Core (M Type)
w1   <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy (HsArrow GhcRn -> LHsType GhcRn
arrowToHsType HsArrow GhcRn
w)
                             Core (M Type)
f1   <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
f
                             Core (M Type)
a1   <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
a
                             Core (M Type)
tcon <- MetaM (Core (M Type))
repMulArrowTyCon
                             Core (M Type) -> [Core (M Type)] -> MetaM (Core (M Type))
repTapps Core (M Type)
tcon [Core (M Type)
w1, Core (M Type)
f1, Core (M Type)
a1]
repTy (HsListTy XListTy GhcRn
_ LHsType GhcRn
t)        = do
                                Core (M Type)
t1   <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
t
                                Core (M Type)
tcon <- MetaM (Core (M Type))
repListTyCon
                                Core (M Type) -> Core (M Type) -> MetaM (Core (M Type))
repTapp Core (M Type)
tcon Core (M Type)
t1
repTy (HsTupleTy XTupleTy GhcRn
_ HsTupleSort
HsUnboxedTuple HsContext GhcRn
tys) = do
                                [Core (M Type)]
tys1 <- HsContext GhcRn -> MetaM [Core (M Type)]
repLTys HsContext GhcRn
tys
                                Core (M Type)
tcon <- Int -> MetaM (Core (M Type))
repUnboxedTupleTyCon (forall (t :: * -> *) a. Foldable t => t a -> Int
length HsContext GhcRn
tys)
                                Core (M Type) -> [Core (M Type)] -> MetaM (Core (M Type))
repTapps Core (M Type)
tcon [Core (M Type)]
tys1
repTy (HsTupleTy XTupleTy GhcRn
_ HsTupleSort
_ HsContext GhcRn
tys)   = do [Core (M Type)]
tys1 <- HsContext GhcRn -> MetaM [Core (M Type)]
repLTys HsContext GhcRn
tys
                                 Core (M Type)
tcon <- Int -> MetaM (Core (M Type))
repTupleTyCon (forall (t :: * -> *) a. Foldable t => t a -> Int
length HsContext GhcRn
tys)
                                 Core (M Type) -> [Core (M Type)] -> MetaM (Core (M Type))
repTapps Core (M Type)
tcon [Core (M Type)]
tys1
repTy (HsSumTy XSumTy GhcRn
_ HsContext GhcRn
tys)       = do [Core (M Type)]
tys1 <- HsContext GhcRn -> MetaM [Core (M Type)]
repLTys HsContext GhcRn
tys
                                 Core (M Type)
tcon <- Int -> MetaM (Core (M Type))
repUnboxedSumTyCon (forall (t :: * -> *) a. Foldable t => t a -> Int
length HsContext GhcRn
tys)
                                 Core (M Type) -> [Core (M Type)] -> MetaM (Core (M Type))
repTapps Core (M Type)
tcon [Core (M Type)]
tys1
repTy (HsOpTy XOpTy GhcRn
_ LHsType GhcRn
ty1 LIdP GhcRn
n LHsType GhcRn
ty2)  = LHsType GhcRn -> MetaM (Core (M Type))
repLTy ((forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar (forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
n) forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
`nlHsAppTy` LHsType GhcRn
ty1)
                                   forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
`nlHsAppTy` LHsType GhcRn
ty2)
repTy (HsParTy XParTy GhcRn
_ LHsType GhcRn
t)         = LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
t
repTy (HsStarTy XStarTy GhcRn
_ Bool
_) =  MetaM (Core (M Type))
repTStar
repTy (HsKindSig XKindSig GhcRn
_ LHsType GhcRn
t LHsType GhcRn
k)     = do
                                Core (M Type)
t1 <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
t
                                Core (M Type)
k1 <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
k
                                Core (M Type) -> Core (M Type) -> MetaM (Core (M Type))
repTSig Core (M Type)
t1 Core (M Type)
k1
repTy (HsSpliceTy XSpliceTy GhcRn
_ HsSplice GhcRn
splice)      = forall a. HsSplice GhcRn -> MetaM (Core a)
repSplice HsSplice GhcRn
splice
repTy (HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
_ HsContext GhcRn
tys) = do
                                    [Core (M Type)]
tys1 <- HsContext GhcRn -> MetaM [Core (M Type)]
repLTys HsContext GhcRn
tys
                                    [Core (M Type)] -> MetaM (Core (M Type))
repTPromotedList [Core (M Type)]
tys1
repTy (HsExplicitTupleTy XExplicitTupleTy GhcRn
_ HsContext GhcRn
tys) = do
                                    [Core (M Type)]
tys1 <- HsContext GhcRn -> MetaM [Core (M Type)]
repLTys HsContext GhcRn
tys
                                    Core (M Type)
tcon <- Int -> MetaM (Core (M Type))
repPromotedTupleTyCon (forall (t :: * -> *) a. Foldable t => t a -> Int
length HsContext GhcRn
tys)
                                    Core (M Type) -> [Core (M Type)] -> MetaM (Core (M Type))
repTapps Core (M Type)
tcon [Core (M Type)]
tys1
repTy (HsTyLit XTyLit GhcRn
_ HsTyLit
lit) = do
                          Core (M TyLit)
lit' <- HsTyLit -> MetaM (Core (M TyLit))
repTyLit HsTyLit
lit
                          Core (M TyLit) -> MetaM (Core (M Type))
repTLit Core (M TyLit)
lit'
repTy (HsWildCardTy XWildCardTy GhcRn
_) = MetaM (Core (M Type))
repTWildCard
repTy (HsIParamTy XIParamTy GhcRn
_ XRec GhcRn HsIPName
n LHsType GhcRn
t) = do
                             Core String
n' <- HsIPName -> ReaderT MetaWrappers DsM (Core String)
rep_implicit_param_name (forall l e. GenLocated l e -> e
unLoc XRec GhcRn HsIPName
n)
                             Core (M Type)
t' <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy LHsType GhcRn
t
                             Core String -> Core (M Type) -> MetaM (Core (M Type))
repTImplicitParam Core String
n' Core (M Type)
t'

repTy HsType GhcRn
ty                      = forall a. String -> SDoc -> MetaM a
notHandled String
"Exotic form of type" (forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty)

repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))
repTyLit :: HsTyLit -> MetaM (Core (M TyLit))
repTyLit (HsNumTy SourceText
_ Integer
i) = forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
numTyLitName [Integer -> CoreExpr
mkIntegerExpr Integer
i]
repTyLit (HsStrTy SourceText
_ CLabelString
s) = do { CoreExpr
s' <- forall (m :: * -> *). MonadThings m => CLabelString -> m CoreExpr
mkStringExprFS CLabelString
s
                            ; forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
strTyLitName [CoreExpr
s']
                            }
repTyLit (HsCharTy SourceText
_ Char
c) = do { CoreExpr
c' <- forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> CoreExpr
mkCharExpr Char
c)
                             ; forall a. Name -> [CoreExpr] -> MetaM (Core (M a))
rep2 Name
charTyLitName [CoreExpr
c']
                             }

-- | Represent a type wrapped in a Maybe
repMaybeLTy :: Maybe (LHsKind GhcRn)
            -> MetaM (Core (Maybe (M TH.Type)))
repMaybeLTy :: Maybe (LHsType GhcRn) -> MetaM (Core (Maybe (M Type)))
repMaybeLTy Maybe (LHsType GhcRn)
m = do
  Type
k_ty <- Name -> MetaM Type
wrapName Name
kindTyConName
  forall a b.
Type -> (a -> MetaM (Core b)) -> Maybe a -> MetaM (Core (Maybe b))
repMaybeT Type
k_ty LHsType GhcRn -> MetaM (Core (M Type))
repLTy Maybe (LHsType GhcRn)
m

repRole :: Located (Maybe Role) -> MetaM (Core TH.Role)
repRole :: Located (Maybe Role) -> MetaM (Core Role)
repRole (L SrcSpan
_ (Just Role
Nominal))          = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
nominalRName []
repRole (L SrcSpan
_ (Just Role
Representational)) = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
representationalRName []
repRole (L SrcSpan
_ (Just Role
Phantom))          = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
phantomRName []
repRole (L SrcSpan
_ Maybe Role
Nothing)                 = forall a. NotM a => Name -> [CoreExpr] -> MetaM (Core a)
rep2_nw Name
inferRName []

-----------------------------------------------------------------------------
--              Splices
-----------------------------------------------------------------------------

repSplice :: HsSplice GhcRn -> MetaM (Core a)
-- See Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice
-- We return a CoreExpr of any old type; the context should know
repSplice :: forall a. HsSplice GhcRn -> MetaM (Core a)
repSplice (HsTypedSplice   XTypedSplice GhcRn
_ SpliceDecoration
_ IdP GhcRn
n LHsExpr GhcRn
_) = forall a. Name -> MetaM (Core a)
rep_splice IdP GhcRn
n
repSplice (HsUntypedSplice XUntypedSplice GhcRn
_ SpliceDecoration
_ IdP GhcRn
n LHsExpr GhcRn
_) = forall a. Name -> MetaM (Core a)
rep_splice IdP GhcRn
n
repSplice (HsQuasiQuote XQuasiQuote GhcRn
_ IdP GhcRn
n IdP GhcRn
_ SrcSpan
_ CLabelString
_)  = forall a. Name -> MetaM (Core a)
rep_splice IdP GhcRn
n
repSplice e :: HsSplice GhcRn
e@(HsSpliced {})          = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"repSplice" (forall a. Outputable a => a -> SDoc
ppr HsSplice GhcRn
e)

rep_splice :: Name -> MetaM (Core a)
rep_splice :: forall a. Name -> MetaM (Core a)
rep_splice Name
splice_name
 = do { Maybe DsMetaVal
mb_val <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv Name
splice_name
       ; case Maybe DsMetaVal
mb_val of
           Just (DsSplice HsExpr GhcTc
e) -> do { CoreExpr
e' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
                                   ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. CoreExpr -> Core a
MkC CoreExpr
e') }
           Maybe DsMetaVal
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"HsSplice" (forall a. Outputable a => a -> SDoc
ppr Name
splice_name) }
                        -- Should not happen; statically checked

-----------------------------------------------------------------------------
--              Expressions
-----------------------------------------------------------------------------

repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)])
repLEs :: [LHsExpr GhcRn] -> MetaM (Core [M Exp])
repLEs [LHsExpr GhcRn]
es = forall a b.
Name -> (a -> MetaM (Core b)) -> [a] -> MetaM (Core [b])
repListM Name
expTyConName LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE [LHsExpr GhcRn]
es

-- FIXME: some of these panics should be converted into proper error messages
--        unless we can make sure that constructs, which are plainly not
--        supported in TH already lead to error messages at an earlier stage
repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp))
repLE :: LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE (L SrcSpanAnnA
loc HsExpr GhcRn
e) = forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT (forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)) (HsExpr GhcRn -> MetaM (Core (M Exp))
repE HsExpr GhcRn
e)

repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp))
repE :: HsExpr GhcRn -> MetaM (Core (M Exp))
repE (HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
x)) =
  do { Maybe DsMetaVal
mb_val <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv Name
x
     ; case Maybe DsMetaVal
mb_val of
        Maybe DsMetaVal
Nothing            -> do { Core Name
str <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Name -> DsM (Core Name)
globalVar Name
x
                                 ; Name -> Core Name -> MetaM (Core (M Exp))
repVarOrCon Name
x Core Name
str }
        Just (DsBound Id
y)   -> Name -> Core Name -> MetaM (Core (M Exp))
repVarOrCon Name
x (Id -> Core Name
coreVar Id
y)
        Just (DsSplice HsExpr GhcTc
e)  -> do { CoreExpr
e' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
                                 ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. CoreExpr -> Core a
MkC CoreExpr
e') } }
repE (HsIPVar XIPVar GhcRn
_ HsIPName
n) = HsIPName -> ReaderT MetaWrappers DsM (Core String)
rep_implicit_param_name HsIPName
n forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Core String -> MetaM (Core (M Exp))
repImplicitParamVar
repE (HsOverLabel XOverLabel GhcRn
_ CLabelString
s) = CLabelString -> MetaM (Core (M Exp))
repOverLabel CLabelString
s

repE e :: HsExpr GhcRn
e@(HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
f) = case AmbiguousFieldOcc GhcRn
f of
  Unambiguous XUnambiguous GhcRn
x LocatedN RdrName
_ -> HsExpr GhcRn -> MetaM (Core (M Exp))
repE (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA XUnambiguous GhcRn
x))
  Ambiguous{}     -> forall a. String -> SDoc -> MetaM a
notHandled String
"Ambiguous record selectors" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)

        -- Remember, we're desugaring renamer output here, so
        -- HsOverlit can definitely occur
repE (HsOverLit XOverLitE GhcRn
_ HsOverLit GhcRn
l) = do { Core Lit
a <- HsOverLit GhcRn -> MetaM (Core Lit)
repOverloadedLiteral HsOverLit GhcRn
l; Core Lit -> MetaM (Core (M Exp))
repLit Core Lit
a }
repE (HsLit XLitE GhcRn
_ HsLit GhcRn
l)     = do { Core Lit
a <- HsLit GhcRn -> MetaM (Core Lit)
repLiteral HsLit GhcRn
l;           Core Lit -> MetaM (Core (M Exp))
repLit Core Lit
a }
repE (HsLam XLam GhcRn
_ (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnL
_ [GenLocated
  SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
m]) })) = LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M Exp))
repLambda GenLocated
  SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
m
repE e :: HsExpr GhcRn
e@(HsLam XLam GhcRn
_ (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
_) })) = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"repE: HsLam with multiple alternatives" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
repE (HsLamCase XLamCase GhcRn
_ (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
ms) }))
                   = do { [Core (M Match)]
ms' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M Match))
repMatchTup [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
ms
                        ; Core [M Match]
core_ms <- forall a. Name -> [Core a] -> MetaM (Core [a])
coreListM Name
matchTyConName [Core (M Match)]
ms'
                        ; Core [M Match] -> MetaM (Core (M Exp))
repLamCase Core [M Match]
core_ms }
repE (HsApp XApp GhcRn
_ LHsExpr GhcRn
x LHsExpr GhcRn
y)   = do {Core (M Exp)
a <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
x; Core (M Exp)
b <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
y; Core (M Exp) -> Core (M Exp) -> MetaM (Core (M Exp))
repApp Core (M Exp)
a Core (M Exp)
b}
repE (HsAppType XAppTypeE GhcRn
_ LHsExpr GhcRn
e LHsWcType (NoGhcTc GhcRn)
t) = do { Core (M Exp)
a <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
e
                            ; Core (M Type)
s <- LHsType GhcRn -> MetaM (Core (M Type))
repLTy (forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsWcType (NoGhcTc GhcRn)
t)
                            ; Core (M Exp) -> Core (M Type) -> MetaM (Core (M Exp))
repAppType Core (M Exp)
a Core (M Type)
s }

repE (OpApp XOpApp GhcRn
_ LHsExpr GhcRn
e1 LHsExpr GhcRn
op LHsExpr GhcRn
e2) =
  do { Core (M Exp)
arg1 <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
e1;
       Core (M Exp)
arg2 <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
e2;
       Core (M Exp)
the_op <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
op ;
       Core (M Exp)
-> Core (M Exp) -> Core (M Exp) -> MetaM (Core (M Exp))
repInfixApp Core (M Exp)
arg1 Core (M Exp)
the_op Core (M Exp)
arg2 }
repE (NegApp XNegApp GhcRn
_ LHsExpr GhcRn
x SyntaxExpr GhcRn
_)      = do
                              Core (M Exp)
a         <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
x
                              Core (M Exp)
negateVar <- Name -> MetaM (Core Name)
lookupOcc Name
negateName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Core Name -> MetaM (Core (M Exp))
repVar
                              Core (M Exp)
negateVar Core (M Exp) -> Core (M Exp) -> MetaM (Core (M Exp))
`repApp` Core (M Exp)
a
repE (HsPar XPar GhcRn
_ LHsExpr GhcRn
x)            = LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
x
repE (SectionL XSectionL GhcRn
_ LHsExpr GhcRn
x LHsExpr GhcRn
y)       = do { Core (M Exp)
a <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
x; Core (M Exp)
b <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
y; Core (M Exp) -> Core (M Exp) -> MetaM (Core (M Exp))
repSectionL Core (M Exp)
a Core (M Exp)
b }
repE (SectionR XSectionR GhcRn
_ LHsExpr GhcRn
x LHsExpr GhcRn
y)       = do { Core (M Exp)
a <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
x; Core (M Exp)
b <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
y; Core (M Exp) -> Core (M Exp) -> MetaM (Core (M Exp))
repSectionR Core (M Exp)
a Core (M Exp)
b }
repE (HsCase XCase GhcRn
_ LHsExpr GhcRn
e (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
ms) }))
                          = do { Core (M Exp)
arg <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
e
                               ; [Core (M Match)]
ms2 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M Match))
repMatchTup [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
ms
                               ; Core [M Match]
core_ms2 <- forall a. Name -> [Core a] -> MetaM (Core [a])
coreListM Name
matchTyConName [Core (M Match)]
ms2
                               ; Core (M Exp) -> Core [M Match] -> MetaM (Core (M Exp))
repCaseE Core (M Exp)
arg Core [M Match]
core_ms2 }
repE (HsIf XIf GhcRn
_ LHsExpr GhcRn
x LHsExpr GhcRn
y LHsExpr GhcRn
z)       = do
                            Core (M Exp)
a <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
x
                            Core (M Exp)
b <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
y
                            Core (M Exp)
c <- LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
z
                            Core (M Exp)
-> Core (M Exp) -> Core (M Exp) -> MetaM (Core (M Exp))
repCond Core (M Exp)
a Core (M Exp)
b Core (M Exp)
c
repE (HsMultiIf XMultiIf GhcRn
_ [LGRHS GhcRn (LHsExpr GhcRn)]
alts)
  = do { ([[GenSymBind]]
binds, [Core (M (Guard, Exp))]
alts') <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LGRHS GhcRn (LHsExpr GhcRn)
-> MetaM ([GenSymBind], Core (M (Guard, Exp)))
repLGRHS [LGRHS GhcRn (LHsExpr GhcRn)]
alts
       ; Core (M Exp)
expr' <- Core [M (Guard, Exp)] -> MetaM (Core (M Exp))
repMultiIf (forall a. [Core a] -> Core [a]
nonEmptyCoreList [Core (M (Guard, Exp))]
alts')
       ; forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[GenSymBind]]
binds) Core (M Exp)
expr' }
repE (HsLet XLet GhcRn
_ HsLocalBinds GhcRn
bs LHsExpr GhcRn
e)             = do { ([GenSymBind]
ss,Core [M Dec]
ds) <- HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [M Dec])
repBinds HsLocalBinds GhcRn
bs
                                     ; Core (M Exp)
e2 <- forall a. [GenSymBind] -> MetaM a -> MetaM a
addBinds [GenSymBind]
ss (LHsExpr GhcRn -> MetaM (Core (M Exp))
repLE LHsExpr GhcRn
e)
                                     ; Core (M Exp)
z <- Core [M Dec] -> Core (M Exp) -> MetaM (Core (M Exp))
repLetE Core [M Dec]
ds Core (M Exp)
e2
                                     ; forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms [GenSymBind]
ss Core (M Exp)
z }

-- FIXME: I haven't got the types here right yet
repE e :: HsExpr GhcRn
e@(HsDo XDo GhcRn
_ HsStmtContext (HsDoRn GhcRn)
ctxt (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
sts))
 | Just Maybe ModuleName
maybeModuleName <- case HsStmtContext (HsDoRn GhcRn)
ctxt of
     { DoExpr Maybe ModuleName
m -> forall a. a -> Maybe a
Just Maybe ModuleName
m; HsStmtContext (HsDoRn GhcRn)
GhciStmtCtxt -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing; HsStmtContext (HsDoRn GhcRn)
_ -> forall a. Maybe a
Nothing }
 = do { ([GenSymBind]
ss,[Core (M Stmt)]
zs) <- [ExprLStmt GhcRn] -> MetaM ([GenSymBind], [Core (M Stmt)])
repLSts [GenLocated
   SrcSpanAnnA (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
sts;
        Core (M Exp)
e'      <- Maybe ModuleName -> Core [M Stmt] -> MetaM (Core (M Exp))
repDoE Maybe ModuleName
maybeModuleName (forall a. [Core a] -> Core [a]
nonEmptyCoreList [Core (M Stmt)]
zs);
        forall a. [GenSymBind] -> Core (M a) -> MetaM (Core (M a))
wrapGenSyms [GenSymBind]
ss Core (M Exp)
e' }

 | HsStmtContext (HsDoRn GhcRn)
ListComp <-