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