Quote.hs 127 KB
Newer Older
1
{-# LANGUAGE AllowAmbiguousTypes    #-}
2

3
4
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
Gert-Jan Bottu's avatar
Gert-Jan Bottu committed
5
{-# LANGUAGE FunctionalDependencies #-}
6
7
8
9
10
11
{-# LANGUAGE PatternSynonyms        #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}
12

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

15
-----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
16
17
18
--
-- (c) The University of Glasgow 2006
--
19
20
21
22
-- 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.
23
24
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
Sylvain Henry's avatar
Sylvain Henry committed
25
26
-- 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
27
-- a Royal Pain (triggers other recompilation).
28
29
-----------------------------------------------------------------------------

romes's avatar
romes committed
30
module GHC.HsToCore.Quote( dsBracket ) where
31

32
import GHC.Prelude
Sylvain Henry's avatar
Sylvain Henry committed
33
import GHC.Platform
34

Sylvain Henry's avatar
Sylvain Henry committed
35
import GHC.Driver.Session
36

37
import GHC.HsToCore.Errors.Types
Sylvain Henry's avatar
Sylvain Henry committed
38
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr )
39
40
import GHC.HsToCore.Match.Literal
import GHC.HsToCore.Monad
Sylvain Henry's avatar
Sylvain Henry committed
41
import GHC.HsToCore.Binds
42

43
import qualified Language.Haskell.TH as TH
44
import qualified Language.Haskell.TH.Syntax as TH
45

Sylvain Henry's avatar
Sylvain Henry committed
46
import GHC.Hs
Sylvain Henry's avatar
Sylvain Henry committed
47

Sylvain Henry's avatar
Sylvain Henry committed
48
import GHC.Tc.Utils.TcType
Sylvain Henry's avatar
Sylvain Henry committed
49
50
51
52
import GHC.Tc.Types.Evidence

import GHC.Core.Class
import GHC.Core.DataCon
Sylvain Henry's avatar
Sylvain Henry committed
53
import GHC.Core.TyCon
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
54
import GHC.Core.Multiplicity ( pattern Many )
Sylvain Henry's avatar
Sylvain Henry committed
55
56
57
import GHC.Core
import GHC.Core.Make
import GHC.Core.Utils
Sylvain Henry's avatar
Sylvain Henry committed
58
59
60
61
62
63
64

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

import GHC.Unit.Module

65
import GHC.Utils.Outputable
66
import GHC.Utils.Panic
67
import GHC.Utils.Panic.Plain
Sylvain Henry's avatar
Sylvain Henry committed
68
69
70
import GHC.Utils.Misc
import GHC.Utils.Monad

71
72
73
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.Maybe
Sylvain Henry's avatar
Sylvain Henry committed
74
75
76
77
78

import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique
import GHC.Types.Basic
import GHC.Types.ForeignCall
Sylvain Henry's avatar
Sylvain Henry committed
79
import GHC.Types.Var
Sylvain Henry's avatar
Sylvain Henry committed
80
81
82
83
84
85
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
86
87
88

import GHC.TypeLits
import Data.Kind (Constraint)
89

90
91
import qualified GHC.LanguageExtensions as LangExt

92
import Data.ByteString ( unpack )
Simon Marlow's avatar
Simon Marlow committed
93
import Control.Monad
94
import Data.List (sort, sortBy)
95
import Data.List.NonEmpty ( NonEmpty(..) )
96
import Data.Function
Sylvain Henry's avatar
Sylvain Henry committed
97
98
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class
Ian Lynagh's avatar
Ian Lynagh committed
99

100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
data MetaWrappers = MetaWrappers {
      -- Applies its argument to a type argument `m` and dictionary `Quote m`
      quoteWrapper :: CoreExpr -> CoreExpr
      -- Apply its argument to a type argument `m` and a dictionary `Monad m`
    , monadWrapper :: CoreExpr -> CoreExpr
      -- Apply the container typed variable `m` to the argument type `T` to get `m T`.
    , metaTy :: Type -> Type
      -- Information about the wrappers which be printed to be inspected
    , _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 q@(QuoteWrapper quote_var_raw m_var) = do
      let quote_var = Var quote_var_raw
      -- Get the superclass selector to select the Monad dictionary, going
      -- to be used to construct the monadWrapper.
      quote_tc <- dsLookupTyCon quoteClassName
      monad_tc <- dsLookupTyCon monadClassName
      let Just cls = tyConClass_maybe quote_tc
          Just monad_cls = tyConClass_maybe monad_tc
          -- Quote m -> Monad m
          monad_sel = classSCSelId cls 0

          -- Only used for the defensive assertion that the selector has
          -- the expected type
          tyvars = dataConUserTyVarBinders (classDataCon cls)
Gert-Jan Bottu's avatar
Gert-Jan Bottu committed
128
          expected_ty = mkInvisForAllTys tyvars $
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
129
130
                          mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars)))
                                           (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))
131

132
      massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty)
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155

      let m_ty = Type m_var
          -- Construct the contents of MetaWrappers
          quoteWrapper = applyQuoteWrapper q
          monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.>
                            mkWpTyApps [m_var]
          tyWrapper t = mkAppTy m_var t
          debug = (quoteWrapper, monadWrapper, m_var)
      q_f <- dsHsWrapper quoteWrapper
      m_f <- dsHsWrapper monadWrapper
      return (MetaWrappers q_f m_f tyWrapper debug)

-- Turn A into m A
wrapName :: Name -> MetaM Type
wrapName n = do
  t <- lookupType n
  wrap_fn <- asks metaTy
  return (wrap_fn t)

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

Sylvain Henry's avatar
Sylvain Henry committed
156
157
158
getPlatform :: MetaM Platform
getPlatform = targetPlatform <$> getDynFlags

159
-----------------------------------------------------------------------------
romes's avatar
romes committed
160
161
162
163
dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
          -> HsQuote GhcRn      -- See Note [The life cycle of a TH quotation]
          -> [PendingTcSplice]
          -> DsM CoreExpr
164
165
-- See Note [Desugaring Brackets]
-- Returns a CoreExpr of type (M TH.Exp)
166
167
168
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

romes's avatar
romes committed
169
dsBracket wrap brack splices
170
  = do_brack brack
171
  where
172
173
174
175
176
    runOverloaded 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.
      mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)
romes's avatar
romes committed
177
178
179
180
      runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw

    new_bit = mkNameEnv [(n, DsSplice (unLoc e))
                        | PendingTcSplice n e <- splices]
181

Alan Zimmerman's avatar
Alan Zimmerman committed
182
    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOccDsM (unLoc n) ; return e1 }
183
184
185
186
    do_brack (ExpBr _ e)   = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }
    do_brack (PatBr _ p)   = runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }
    do_brack (TypBr _ t)   = runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }
    do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
187
188
    do_brack (DecBrL {})   = panic "dsUntypedBracket: unexpected DecBrL"

189

190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
{-
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`
Sylvain Henry's avatar
Sylvain Henry committed
211
datatype which is produced by `GHC.Tc.Gen.Splice`. It is a pair of an evidence variable
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
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.

-}

244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
{- -------------- 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))
-}


259
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
260
--                      Declarations
261
262
-------------------------------------------------------

263
264
265
266
267
268
-- 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))
269
repTopP pat = do { ss <- mkGenSyms (collectPatBinders CollNoDictBinders pat)
270
                 ; pat' <- addBinds ss (repLP pat)
271
                 ; wrapGenSyms ss pat' }
272

273
repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec]))
274
275
276
277
278
279
280
281
282
283
284
repTopDs group@(HsGroup { hs_valds   = valds
                        , hs_splcds  = splcds
                        , hs_tyclds  = tyclds
                        , hs_derivds = derivds
                        , hs_fixds   = fixds
                        , hs_defds   = defds
                        , hs_fords   = fords
                        , hs_warnds  = warnds
                        , hs_annds   = annds
                        , hs_ruleds  = ruleds
                        , hs_docs    = docs })
285
 = do { let { bndrs  = hsScopedTvBinders valds
286
                       ++ hsGroupBinders group
287
                       ++ map foExt (hsPatSynSelectors valds)
288
            ; instds = tyclds >>= group_instds } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
289
        ss <- mkGenSyms bndrs ;
290

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
291
292
293
294
295
296
        -- 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
297

298
        decls <- addBinds ss (
299
300
                  do { val_ds   <- rep_val_binds valds
                     ; _        <- mapM no_splice splcds
301
                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
302
                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
303
                     ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)
304
305
                     ; inst_ds  <- mapM repInstD instds
                     ; deriv_ds <- mapM repStandaloneDerivD derivds
306
                     ; fix_ds   <- mapM repLFixD fixds
307
                     ; def_ds   <- mapM repDefD defds
308
                     ; for_ds   <- mapM repForD fords
Alan Zimmerman's avatar
Alan Zimmerman committed
309
310
                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
                                                           warnds)
311
                     ; ann_ds   <- mapM repAnnD annds
Alan Zimmerman's avatar
Alan Zimmerman committed
312
313
                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
                                                            ruleds)
314
                     ; _        <- mapM no_doc docs
315

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
316
                        -- more needed
317
                     ;  return (de_loc $ sort_by_loc $
318
                                val_ds ++ catMaybes tycl_ds ++ role_ds
319
                                       ++ kisig_ds
320
                                       ++ (concat fix_ds)
321
                                       ++ def_ds
322
                                       ++ inst_ds ++ rule_ds ++ for_ds
323
                                       ++ ann_ds ++ deriv_ds) }) ;
324

325
        core_list <- repListM decTyConName return decls ;
326

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
327
        dec_ty <- lookupType decTyConName ;
328
        q_decs  <- repSequenceM dec_ty core_list ;
329

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
330
        wrapGenSyms ss q_decs
331
      }
332
  where
333
    no_splice (L loc _)
334
      = notHandledL (locA loc) ThSplicesWithinDeclBrackets
Ryan Scott's avatar
Ryan Scott committed
335
    no_warn :: LWarnDecl GhcRn -> MetaM a
336
    no_warn (L loc (Warning _ thing _))
337
      = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing)
338
    no_doc (L loc _)
339
      = notHandledL (locA loc) ThHaddockDocumentation
340

341
hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
342
-- See Note [Scoped type variables in quotes]
343
hsScopedTvBinders binds
344
  = concatMap get_scoped_tvs sigs
345
346
  where
    sigs = case binds of
347
348
             ValBinds           _ _ sigs  -> sigs
             XValBindsLR (NValBinds _ sigs) -> sigs
349

350
get_scoped_tvs :: LSig GhcRn -> [Name]
351
get_scoped_tvs (L _ signature)
352
  | TypeSig _ _ sig <- signature
353
  = get_scoped_tvs_from_sig (hswc_body sig)
354
  | ClassOpSig _ _ _ sig <- signature
355
  = get_scoped_tvs_from_sig sig
356
  | PatSynSig _ _ sig <- signature
357
358
359
  = get_scoped_tvs_from_sig sig
  | otherwise
  = []
360
361
362
363
364
365
366
367
368
369

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]
370
371
get_scoped_tvs_from_sig (L _ (HsSig{sig_bndrs = outer_bndrs})) =
  hsOuterTyVarNames outer_bndrs
372

373
374
{- Notes

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

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

383
384
385
386
387
388
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:
389

390
391
392
 (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.
393

394
395
396
 (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`.
397

398
399
400
401
402
 (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.
403

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

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

410
The relevant places are signposted with references to this Note.
411

412
413
Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
414
415
When we desugar [d| data T = MkT |]
we want to get
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
416
        Data "T" [] [Con "MkT" []] []
417
and *not*
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
418
        Data "Foo:T" [] [Con "Foo:MkT" []] []
419
420
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:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
421
        Data "T79" ....
422
423

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
424
425
        data T = MkT
        foo = reifyDecl T
426
427

then we must desugar to
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
428
        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
429

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

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

438
439
  [d| id :: a -> a
      id x = x
440
441
442
443
    |]

and have Template Haskell turn it into this:

444
445
  id :: forall a. a -> a
  id x = x
446

447
Notice that we explicitly quantified the variable `a`! The latter declaration
448
isn't what the user wrote in the first place.
449
450
451
452

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.
453
454
-}

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

459
460
repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
                                              repFamilyDecl (L loc fam)
461

462
repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
Ben Gamari's avatar
Ben Gamari committed
463
  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
464
465
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repSynDecl tc1 bndrs rhs
Alan Zimmerman's avatar
Alan Zimmerman committed
466
       ; return (Just (locA loc, dec)) }
467

468
469
470
repTyClD (L loc (DataDecl { tcdLName = tc
                          , tcdTyVars = tvs
                          , tcdDataDefn = defn }))
Ben Gamari's avatar
Ben Gamari committed
471
  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
472
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
473
                repDataDefn tc1 (Left bndrs) defn
Alan Zimmerman's avatar
Alan Zimmerman committed
474
       ; return (Just (locA loc, dec)) }
475

476
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
477
478
                             tcdTyVars = tvs, tcdFDs = fds,
                             tcdSigs = sigs, tcdMeths = meth_binds,
479
                             tcdATs = ats, tcdATDefs = atds }))
Ben Gamari's avatar
Ben Gamari committed
480
  = do { cls1 <- lookupLOcc cls         -- See Note [Binders and occurrences]
Gert-Jan Bottu's avatar
Gert-Jan Bottu committed
481
       ; dec  <- addQTyVarBinds tvs $ \bndrs ->
482
           do { cxt1   <- repLContext cxt
483
484
          -- See Note [Scoped type variables in quotes]
              ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
485
              ; fds1   <- repLFunDeps fds
486
              ; ats1   <- repFamilyDecls ats
487
              ; atds1  <- mapM (repAssocTyFamDefaultD . unLoc) atds
488
              ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)
489
490
              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
              ; wrapGenSyms ss decls2 }
Alan Zimmerman's avatar
Alan Zimmerman committed
491
       ; return $ Just (locA loc, dec)
492
       }
493

494
-------------------------
495
repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
496
repRoleD (L loc (RoleAnnotDecl _ tycon roles))
497
498
499
500
  = do { tycon1 <- lookupLOcc tycon
       ; roles1 <- mapM repRole roles
       ; roles2 <- coreList roleTyConName roles1
       ; dec <- repRoleAnnotD tycon1 roles2
Alan Zimmerman's avatar
Alan Zimmerman committed
501
       ; return (locA loc, dec) }
502

503
-------------------------
504
repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
505
repKiSigD (L loc kisig) =
506
  case kisig of
507
508
509
510
    StandaloneKindSig _ v ki -> do
      MkC th_v  <- lookupLOcc v
      MkC th_ki <- repHsSigType ki
      dec       <- rep2 kiSigDName [th_v, th_ki]
Alan Zimmerman's avatar
Alan Zimmerman committed
511
      pure (locA loc, dec)
512

513
-------------------------
514
repDataDefn :: Core TH.Name
Gert-Jan Bottu's avatar
Gert-Jan Bottu committed
515
            -> Either (Core [(M (TH.TyVarBndr ()))])
516
                        -- the repTyClD case
Gert-Jan Bottu's avatar
Gert-Jan Bottu committed
517
                      (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
518
                        -- the repDataFamInstD case
519
            -> HsDataDefn GhcRn
520
            -> MetaM (Core (M TH.Dec))
521
repDataDefn tc opts
522
          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
523
                      , dd_cons = cons, dd_derivs = mb_derivs })
524
525
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
526
527
       ; case (new_or_data, cons) of
           (NewType, [con])  -> do { con'  <- repC con
Ryan Scott's avatar
Ryan Scott committed
528
                                   ; ksig' <- repMaybeLTy ksig
529
                                   ; repNewtype cxt1 tc opts ksig' con'
530
                                                derivs1 }
531
           (NewType, _) -> lift $ failWithDs (DsMultipleConForNewtype (getConNames $ unLoc $ head cons))
Ryan Scott's avatar
Ryan Scott committed
532
           (DataType, _) -> do { ksig' <- repMaybeLTy ksig
533
                               ; consL <- mapM repC cons
534
                               ; cons1 <- coreListM conTyConName consL
535
                               ; repData cxt1 tc opts ksig' cons1
536
537
                                         derivs1 }
       }
538

Gert-Jan Bottu's avatar
Gert-Jan Bottu committed
539
repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
540
           -> LHsType GhcRn
541
           -> MetaM (Core (M TH.Dec))
542
repSynDecl tc bndrs ty
543
  = do { ty1 <- repLTy ty
544
545
       ; repTySyn tc bndrs ty1 }

546
repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
547
548
549
550
551
repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info
                                      , fdLName     = tc
                                      , fdTyVars    = tvs
                                      , fdResultSig = L _ resultSig
                                      , fdInjectivityAnn = injectivity }))
Ben Gamari's avatar
Ben Gamari committed
552
  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
Gert-Jan Bottu's avatar
Gert-Jan Bottu committed
553
       ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
554
             mkHsQTvs tvs = HsQTvs { hsq_ext = []
555
                                   , hsq_explicit = tvs }
Jan Stolarek's avatar
Jan Stolarek committed
556
             resTyVar = case resultSig of
557
558
                     TyVarSig _ bndr -> mkHsQTvs [bndr]
                     _               -> mkHsQTvs []
559
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
Jan Stolarek's avatar
Jan Stolarek committed
560
561
562
                addTyClTyVarBinds resTyVar $ \_ ->
           case info of
             ClosedTypeFamily Nothing ->
563
                 notHandled (ThAbstractClosedTypeFamily decl)
Jan Stolarek's avatar
Jan Stolarek committed
564
             ClosedTypeFamily (Just eqns) ->
565
               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
566
                  ; eqns2  <- coreListM tySynEqnTyConName eqns1
Jan Stolarek's avatar
Jan Stolarek committed
567
568
569
570
571
572
573
574
575
576
                  ; result <- repFamilyResultSig resultSig
                  ; inj    <- repInjectivityAnn injectivity
                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }
             OpenTypeFamily ->
               do { result <- repFamilyResultSig resultSig
                  ; inj    <- repInjectivityAnn injectivity
                  ; repOpenFamilyD tc1 bndrs result inj }
             DataFamily ->
               do { kind <- repFamilyResultSigToMaybeKind resultSig
                  ; repDataFamilyD tc1 bndrs kind }
Alan Zimmerman's avatar
Alan Zimmerman committed
577
       ; return (locA loc, dec)
578
579
       }

Jan Stolarek's avatar
Jan Stolarek committed
580
-- | Represent result signature of a type family
581
repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig))
582
583
584
585
586
repFamilyResultSig (NoSig _)         = repNoSig
repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki
                                          ; repKindSig ki' }
repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
                                          ; repTyVarSig bndr' }
Jan Stolarek's avatar
Jan Stolarek committed
587
588
589
590

-- | 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.
591
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
592
                              -> MetaM (Core (Maybe (M TH.Kind)))
593
repFamilyResultSigToMaybeKind (NoSig _) =
594
    coreNothingM kindTyConName
595
repFamilyResultSigToMaybeKind (KindSig _ ki) =
596
    coreJustM kindTyConName =<< repLTy ki
597
598
repFamilyResultSigToMaybeKind TyVarSig{} =
    panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"
Jan Stolarek's avatar
Jan Stolarek committed
599
600

-- | Represent injectivity annotation of a type family
601
repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
602
                  -> MetaM (Core (Maybe TH.InjectivityAnn))
Jan Stolarek's avatar
Jan Stolarek committed
603
repInjectivityAnn Nothing =
604
    coreNothing injAnnTyConName
Alan Zimmerman's avatar
Alan Zimmerman committed
605
repInjectivityAnn (Just (L _ (InjectivityAnn _ lhs rhs))) =
Jan Stolarek's avatar
Jan Stolarek committed
606
607
608
    do { lhs'   <- lookupBinder (unLoc lhs)
       ; rhs1   <- mapM (lookupBinder . unLoc) rhs
       ; rhs2   <- coreList nameTyConName rhs1
609
       ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2]
Jan Stolarek's avatar
Jan Stolarek committed
610
611
       ; coreJust injAnnTyConName injAnn }

612
repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)]
613
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
614

615
repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec))
616
repAssocTyFamDefaultD = repTyFamInstD
My Nguyen's avatar
My Nguyen committed
617

618
-------------------------
619
620
-- represent fundeps
--
621
repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep])
622
repLFunDeps fds = repList funDepTyConName repLFunDep fds
623

624
repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep)
Alan Zimmerman's avatar
Alan Zimmerman committed
625
repLFunDep (L _ (FunDep _ xs ys))
Alan Zimmerman's avatar
Alan Zimmerman committed
626
627
628
   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
        repFunDep xs' ys'
629

630
631
-- Represent instance declarations
--
632
repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
633
repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
634
  = do { dec <- repTyFamInstD fi_decl
Alan Zimmerman's avatar
Alan Zimmerman committed
635
       ; return (locA loc, dec) }
636
repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
637
  = do { dec <- repDataFamInstD fi_decl
Alan Zimmerman's avatar
Alan Zimmerman committed
638
       ; return (locA loc, dec) }
639
repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
640
  = do { dec <- repClsInstD cls_decl
Alan Zimmerman's avatar
Alan Zimmerman committed
641
       ; return (locA loc, dec) }
642

643
repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))
644
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
645
                         , cid_sigs = sigs, cid_tyfam_insts = ats
646
647
648
                         , cid_datafam_insts = adts
                         , cid_overlap_mode = overlap
                         })
649
  = addSimpleTyVarBinds tvs $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
650
651
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
652
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
653
654
655
656
            --
            -- 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
657
            -- the selector Ids, not to fresh names (#5410)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
658
            --
659
            do { cxt1     <- repLContext cxt
660
               ; inst_ty1 <- repLTy inst_ty
661
662
          -- See Note [Scoped type variables in quotes]
               ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs binds
663
664
               ; ats1   <- mapM (repTyFamInstD . unLoc) ats
               ; adts1  <- mapM (repDataFamInstD . unLoc) adts
665
               ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)
666
667
668
               ; rOver  <- repOverlap (fmap unLoc overlap)
               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
               ; wrapGenSyms ss decls2 }
669
 where
670
   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
671

672
repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
673
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
674
                                       , deriv_type     = ty }))
675
676
  = do { dec <- repDerivStrategy strat  $ \strat' ->
                addSimpleTyVarBinds tvs $
677
678
                do { cxt'     <- repLContext cxt
                   ; inst_ty' <- repLTy inst_ty
Ryan Scott's avatar
Ryan Scott committed
679
                   ; repDeriv strat' cxt' inst_ty' }
Alan Zimmerman's avatar
Alan Zimmerman committed
680
       ; return (locA loc, dec) }
681
  where
682
    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
683

684
repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
My Nguyen's avatar
My Nguyen committed
685
686
687
repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
  = do { eqn1 <- repTyFamEqn eqn
       ; repTySynInst eqn1 }
688

689
repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))
690
691
692
693
694
repTyFamEqn (FamEqn { feqn_tycon = tc_name
                    , feqn_bndrs = outer_bndrs
                    , feqn_pats = tys
                    , feqn_fixity = fixity
                    , feqn_rhs  = rhs })
Ben Gamari's avatar
Ben Gamari committed
695
  = do { tc <- lookupLOcc tc_name     -- See Note [Binders and occurrences]
696
697
       ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
         do { tys1 <- case fixity of
My Nguyen's avatar
My Nguyen committed
698
699
700
701
702
                        Prefix -> repTyArgs (repNamedTyCon tc) tys
                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
                                     ; t1' <- repLTy t1
                                     ; t2'  <- repLTy t2
                                     ; repTyArgs (repTInfix t1' tc t2') args }
703
            ; rhs1 <- repLTy rhs
704
            ; repTySynEqn mb_exp_bndrs tys1 rhs1 } }
705
     where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
My Nguyen's avatar
My Nguyen committed
706
707
           checkTys tys@(HsValArg _:HsValArg _:_) = return tys
           checkTys _ = panic "repTyFamEqn:checkTys"
708

709
repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))
My Nguyen's avatar
My Nguyen committed
710
711
712
713
repTyArgs f [] = f
repTyArgs f (HsValArg ty : as) = do { f' <- f
                                    ; ty' <- repLTy ty
                                    ; repTyArgs (repTapp f' ty') as }
714
715
716
repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
                                       ; ki' <- repLTy ki
                                       ; repTyArgs (repTappKind f' ki') as }
My Nguyen's avatar
My Nguyen committed
717
718
repTyArgs f (HsArgPar _ : as) = repTyArgs f as

719
repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
720
repDataFamInstD (DataFamInstDecl { dfid_eqn =
721
722
                                      FamEqn { feqn_tycon = tc_name
                                             , feqn_bndrs = outer_bndrs
723
                                             , feqn_pats  = tys
My Nguyen's avatar
My Nguyen committed
724
                                             , feqn_fixity = fixity
725
                                             , feqn_rhs   = defn }})
Ben Gamari's avatar
Ben Gamari committed
726
  = do { tc <- lookupLOcc tc_name         -- See Note [Binders and occurrences]
727
728
       ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
         do { tys1 <- case fixity of
My Nguyen's avatar
My Nguyen committed
729
730
731
732
733
                        Prefix -> repTyArgs (repNamedTyCon tc) tys
                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
                                     ; t1' <- repLTy t1
                                     ; t2'  <- repLTy t2
                                     ; repTyArgs (repTInfix t1' tc t2') args }
734
            ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } }
My Nguyen's avatar
My Nguyen committed
735

736
      where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
My Nguyen's avatar
My Nguyen committed
737
738
739
            checkTys tys@(HsValArg _: HsValArg _: _) = return tys
            checkTys _ = panic "repDataFamInstD:checkTys"

Alan Zimmerman's avatar
Alan Zimmerman committed
740
repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
741
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
742
743
                                  , fd_fi = CImport (L _ cc)
                                                    (L _ s) mch cis _ }))
744
 = do MkC name' <- lookupLOcc name
745
      MkC typ' <- repHsSigType typ
746
747
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
748
      cis' <- conv_cimportspec cis
749
      MkC str <- coreStringLit (static ++ chStr ++ cis')
750
      dec <- rep2 forImpDName [cc', s', str, name', typ']
Alan Zimmerman's avatar
Alan Zimmerman committed
751
      return (locA loc, dec)
752
 where
753
    conv_cimportspec (CLabel cls)
754
      = notHandled (ThForeignLabel cls)
755
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
756
757
758
759
    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                            = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                            = panic "conv_cimportspec: values not supported yet"
760
    conv_cimportspec CWrapper = return "wrapper"
761
762
    -- these calling conventions do not support headers and the static keyword
    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
763
    static = case cis of
764
                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
765
                 _ -> ""
766
    chStr = case mch of
767
768
            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
            _ -> ""
769
repForD decl@(L _ ForeignExport{}) = notHandled (ThForeignExport decl)
770

771
772
773
774
775
776
repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)
repCCallConv CCallConv          = rep2_nw cCallName []
repCCallConv StdCallConv        = rep2_nw stdCallName []
repCCallConv CApiConv           = rep2_nw cApiCallName []
repCCallConv PrimCallConv       = rep2_nw primCallName []
repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName []
777

778
779
780
781
repSafety :: Safety -> MetaM (Core TH.Safety)
repSafety PlayRisky = rep2_nw unsafeName []
repSafety PlayInterruptible = rep2_nw interruptibleName []
repSafety PlaySafe = rep2_nw safeName []
782

783
repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
Alan Zimmerman's avatar
Alan Zimmerman committed
784
repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig
785
786
787

rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
788
  = do { MkC prec' <- coreIntLit prec
789
       ; let rep_fn = case dir of
790
791
792
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
793
794
795
796
797
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
798

799
800
801
802
803
804
repDefD :: LDefaultDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys
                                         ; MkC tys2 <- coreListM typeTyConName tys1
                                         ; dec <- rep2 defaultDName [tys2]
                                         ; return (locA loc, dec)}

805
repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
806
807
808
809
810
811
repRuleD (L loc (HsRule { rd_name = n
                        , rd_act = act
                        , rd_tyvs = ty_bndrs
                        , rd_tmvs = tm_bndrs
                        , rd_lhs = lhs
                        , rd_rhs = rhs }))
812
813
814
815
  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
            ; ss <- mkGenSyms tm_bndr_names
            ; rule <- addBinds ss $
Gert-Jan Bottu's avatar
Gert-Jan Bottu committed
816
                      do { elt_ty <- wrapName tyVarBndrUnitTyConName
817
818
819
820
                         ; ty_bndrs' <- return $ case ty_bndrs of
                             Nothing -> coreNothing' (mkListTy elt_ty)
                             Just _  -> coreJust' (mkListTy elt_ty) ex_bndrs
                         ; tm_bndrs' <- repListM ruleBndrTyConName
821
822
823
824
825
826
827
828
                                                repRuleBndr
                                                tm_bndrs
                         ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
                         ; act' <- repPhases act
                         ; lhs' <- repLE lhs
                         ; rhs' <- repLE rhs
                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
           ; wrapGenSyms ss rule  }
Alan Zimmerman's avatar
Alan Zimmerman committed
829
       ; return (locA loc, rule) }
830

831
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
832
833
ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig _ n sig))
834
  | HsPS { hsps_ext = HsPSRn { hsps_imp_tvs = vars }} <- sig
835
  = unLoc n : vars
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
836

837
repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))
838
repRuleBndr (L _ (RuleBndr _ n))
Alan Zimmerman's avatar
Alan Zimmerman committed
839
  = do { MkC n' <- lookupNBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
840
       ; rep2 ruleVarName [n'] }
841
repRuleBndr (L _ (RuleBndrSig _ n sig))
Alan Zimmerman's avatar
Alan Zimmerman committed
842
  = do { MkC n'  <- lookupNBinder n
843
       ; MkC ty' <- repLTy (hsPatSigType sig)
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
844
845
       ; rep2 typedRuleVarName [n', ty'] }

846
repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
847
repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
848
849
850
  = do { target <- repAnnProv ann_prov
       ; exp'   <- repE exp
       ; dec    <- repPragAnn target exp'
Alan Zimmerman's avatar
Alan Zimmerman committed
851
       ; return (locA loc, dec) }
852

Alan Zimmerman's avatar
Alan Zimmerman committed
853
repAnnProv :: AnnProvenance GhcRn -> MetaM (Core TH.AnnTarget)
854
855
856
857
858
repAnnProv (ValueAnnProvenance 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 n' <- lookupLOcc n
859
       ; rep2_nw valueAnnotationName [ n' ] }
860
861
repAnnProv (TypeAnnProvenance n)
  = do { MkC n' <- lookupLOcc n
862
       ; rep2_nw typeAnnotationName [ n' ] }
863
repAnnProv ModuleAnnProvenance
864
  = rep2_nw moduleAnnotationName []
865

866
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
867
--                      Constructors
868
869
-------------------------------------------------------

870
repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con))
871
repC (L _ (ConDeclH98 { con_name   = con
Alan Zimmerman's avatar
Alan Zimmerman committed
872
                      , con_forall = False
873
874
                      , con_mb_cxt = Nothing
                      , con_args   = args }))
Ryan Scott's avatar
Ryan Scott committed
875
  = repH98DataCon con args