Add support for ImplicitParams and RecursiveDo in TH
[ghc.git] / compiler / deSugar / DsMeta.hs
1 {-# LANGUAGE CPP, TypeFamilies #-}
2 {-# LANGUAGE FlexibleContexts #-}
3
4 -----------------------------------------------------------------------------
5 --
6 -- (c) The University of Glasgow 2006
7 --
8 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
9 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
10 -- input HsExpr. We do this in the DsM monad, which supplies access to
11 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
12 --
13 -- It also defines a bunch of knownKeyNames, in the same way as is done
14 -- in prelude/PrelNames. It's much more convenient to do it here, because
15 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
16 -- a Royal Pain (triggers other recompilation).
17 -----------------------------------------------------------------------------
18
19 module DsMeta( dsBracket ) where
20
21 #include "HsVersions.h"
22
23 import GhcPrelude
24
25 import {-# SOURCE #-} DsExpr ( dsExpr )
26
27 import MatchLit
28 import DsMonad
29
30 import qualified Language.Haskell.TH as TH
31
32 import HsSyn
33 import PrelNames
34 -- To avoid clashes with DsMeta.varName we must make a local alias for
35 -- OccName.varName we do this by removing varName from the import of
36 -- OccName above, making a qualified instance of OccName and using
37 -- OccNameAlias.varName where varName ws previously used in this file.
38 import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
39
40 import Module
41 import Id
42 import Name hiding( isVarOcc, isTcOcc, varName, tcName )
43 import THNames
44 import NameEnv
45 import NameSet
46 import TcType
47 import TyCon
48 import TysWiredIn
49 import CoreSyn
50 import MkCore
51 import CoreUtils
52 import SrcLoc
53 import Unique
54 import BasicTypes
55 import Outputable
56 import Bag
57 import DynFlags
58 import FastString
59 import ForeignCall
60 import Util
61 import Maybes
62 import MonadUtils
63
64 import Data.ByteString ( unpack )
65 import Control.Monad
66 import Data.List
67
68 -----------------------------------------------------------------------------
69 dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
70 -- Returns a CoreExpr of type TH.ExpQ
71 -- The quoted thing is parameterised over Name, even though it has
72 -- been type checked. We don't want all those type decorations!
73
74 dsBracket brack splices
75 = dsExtendMetaEnv new_bit (do_brack brack)
76 where
77 new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
78
79 do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
80 do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }
81 do_brack (PatBr _ p) = do { MkC p1 <- repTopP p ; return p1 }
82 do_brack (TypBr _ t) = do { MkC t1 <- repLTy t ; return t1 }
83 do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
84 do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL"
85 do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }
86 do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
87
88 {- -------------- Examples --------------------
89
90 [| \x -> x |]
91 ====>
92 gensym (unpackString "x"#) `bindQ` \ x1::String ->
93 lam (pvar x1) (var x1)
94
95
96 [| \x -> $(f [| x |]) |]
97 ====>
98 gensym (unpackString "x"#) `bindQ` \ x1::String ->
99 lam (pvar x1) (f (var x1))
100 -}
101
102
103 -------------------------------------------------------
104 -- Declarations
105 -------------------------------------------------------
106
107 repTopP :: LPat GhcRn -> DsM (Core TH.PatQ)
108 repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
109 ; pat' <- addBinds ss (repLP pat)
110 ; wrapGenSyms ss pat' }
111
112 repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))
113 repTopDs group@(HsGroup { hs_valds = valds
114 , hs_splcds = splcds
115 , hs_tyclds = tyclds
116 , hs_derivds = derivds
117 , hs_fixds = fixds
118 , hs_defds = defds
119 , hs_fords = fords
120 , hs_warnds = warnds
121 , hs_annds = annds
122 , hs_ruleds = ruleds
123 , hs_docs = docs })
124 = do { let { bndrs = hsScopedTvBinders valds
125 ++ hsGroupBinders group
126 ++ hsPatSynSelectors valds
127 ; instds = tyclds >>= group_instds } ;
128 ss <- mkGenSyms bndrs ;
129
130 -- Bind all the names mainly to avoid repeated use of explicit strings.
131 -- Thus we get
132 -- do { t :: String <- genSym "T" ;
133 -- return (Data t [] ...more t's... }
134 -- The other important reason is that the output must mention
135 -- only "T", not "Foo:T" where Foo is the current module
136
137 decls <- addBinds ss (
138 do { val_ds <- rep_val_binds valds
139 ; _ <- mapM no_splice splcds
140 ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds)
141 ; role_ds <- mapM repRoleD (concatMap group_roles tyclds)
142 ; inst_ds <- mapM repInstD instds
143 ; deriv_ds <- mapM repStandaloneDerivD derivds
144 ; fix_ds <- mapM repFixD fixds
145 ; _ <- mapM no_default_decl defds
146 ; for_ds <- mapM repForD fords
147 ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc)
148 warnds)
149 ; ann_ds <- mapM repAnnD annds
150 ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc)
151 ruleds)
152 ; _ <- mapM no_doc docs
153
154 -- more needed
155 ; return (de_loc $ sort_by_loc $
156 val_ds ++ catMaybes tycl_ds ++ role_ds
157 ++ (concat fix_ds)
158 ++ inst_ds ++ rule_ds ++ for_ds
159 ++ ann_ds ++ deriv_ds) }) ;
160
161 decl_ty <- lookupType decQTyConName ;
162 let { core_list = coreList' decl_ty decls } ;
163
164 dec_ty <- lookupType decTyConName ;
165 q_decs <- repSequenceQ dec_ty core_list ;
166
167 wrapGenSyms ss q_decs
168 }
169 where
170 no_splice (L loc _)
171 = notHandledL loc "Splices within declaration brackets" empty
172 no_default_decl (L loc decl)
173 = notHandledL loc "Default declarations" (ppr decl)
174 no_warn (L loc (Warning _ thing _))
175 = notHandledL loc "WARNING and DEPRECATION pragmas" $
176 text "Pragma for declaration of" <+> ppr thing
177 no_warn (L _ (XWarnDecl _)) = panic "repTopDs"
178 no_doc (L loc _)
179 = notHandledL loc "Haddock documentation" empty
180 repTopDs (XHsGroup _) = panic "repTopDs"
181
182 hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
183 -- See Note [Scoped type variables in bindings]
184 hsScopedTvBinders binds
185 = concatMap get_scoped_tvs sigs
186 where
187 sigs = case binds of
188 ValBinds _ _ sigs -> sigs
189 XValBindsLR (NValBinds _ sigs) -> sigs
190
191 get_scoped_tvs :: LSig GhcRn -> [Name]
192 get_scoped_tvs (L _ signature)
193 | TypeSig _ _ sig <- signature
194 = get_scoped_tvs_from_sig (hswc_body sig)
195 | ClassOpSig _ _ _ sig <- signature
196 = get_scoped_tvs_from_sig sig
197 | PatSynSig _ _ sig <- signature
198 = get_scoped_tvs_from_sig sig
199 | otherwise
200 = []
201 where
202 get_scoped_tvs_from_sig sig
203 -- Both implicit and explicit quantified variables
204 -- We need the implicit ones for f :: forall (a::k). blah
205 -- here 'k' scopes too
206 | HsIB { hsib_ext = implicit_vars
207 , hsib_body = hs_ty } <- sig
208 , (explicit_vars, _) <- splitLHsForAllTy hs_ty
209 = implicit_vars ++ map hsLTyVarName explicit_vars
210 get_scoped_tvs_from_sig (XHsImplicitBndrs _)
211 = panic "get_scoped_tvs_from_sig"
212
213 {- Notes
214
215 Note [Scoped type variables in bindings]
216 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
217 Consider
218 f :: forall a. a -> a
219 f x = x::a
220 Here the 'forall a' brings 'a' into scope over the binding group.
221 To achieve this we
222
223 a) Gensym a binding for 'a' at the same time as we do one for 'f'
224 collecting the relevant binders with hsScopedTvBinders
225
226 b) When processing the 'forall', don't gensym
227
228 The relevant places are signposted with references to this Note
229
230 Note [Scoped type variables in class and instance declarations]
231 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
232 Scoped type variables may occur in default methods and default
233 signatures. We need to bring the type variables in 'foralls'
234 into the scope of the method bindings.
235
236 Consider
237 class Foo a where
238 foo :: forall (b :: k). a -> Proxy b -> Proxy b
239 foo _ x = (x :: Proxy b)
240
241 We want to ensure that the 'b' in the type signature and the default
242 implementation are the same, so we do the following:
243
244 a) Before desugaring the signature and binding of 'foo', use
245 get_scoped_tvs to collect type variables in 'forall' and
246 create symbols for them.
247 b) Use 'addBinds' to bring these symbols into the scope of the type
248 signatures and bindings.
249 c) Use these symbols to generate Core for the class/instance declaration.
250
251 Note that when desugaring the signatures, we lookup the type variables
252 from the scope rather than recreate symbols for them. See more details
253 in "rep_ty_sig" and in Trac#14885.
254
255 Note [Binders and occurrences]
256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
257 When we desugar [d| data T = MkT |]
258 we want to get
259 Data "T" [] [Con "MkT" []] []
260 and *not*
261 Data "Foo:T" [] [Con "Foo:MkT" []] []
262 That is, the new data decl should fit into whatever new module it is
263 asked to fit in. We do *not* clone, though; no need for this:
264 Data "T79" ....
265
266 But if we see this:
267 data T = MkT
268 foo = reifyDecl T
269
270 then we must desugar to
271 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
272
273 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
274 And we use lookupOcc, rather than lookupBinder
275 in repTyClD and repC.
276
277 Note [Don't quantify implicit type variables in quotes]
278 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
279 If you're not careful, it's suprisingly easy to take this quoted declaration:
280
281 [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b
282 idProxy x = x
283 |]
284
285 and have Template Haskell turn it into this:
286
287 idProxy :: forall k proxy (b :: k). proxy b -> proxy b
288 idProxy x = x
289
290 Notice that we explicitly quantified the variable `k`! The latter declaration
291 isn't what the user wrote in the first place.
292
293 Usually, the culprit behind these bugs is taking implicitly quantified type
294 variables (often from the hsib_vars field of HsImplicitBinders) and putting
295 them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
296 -}
297
298 -- represent associated family instances
299 --
300 repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))
301
302 repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)
303
304 repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
305 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
306 ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
307 repSynDecl tc1 bndrs rhs
308 ; return (Just (loc, dec)) }
309
310 repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
311 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
312 ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
313 repDataDefn tc1 bndrs Nothing defn
314 ; return (Just (loc, dec)) }
315
316 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
317 tcdTyVars = tvs, tcdFDs = fds,
318 tcdSigs = sigs, tcdMeths = meth_binds,
319 tcdATs = ats, tcdATDefs = atds }))
320 = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
321 ; dec <- addTyVarBinds tvs $ \bndrs ->
322 do { cxt1 <- repLContext cxt
323 -- See Note [Scoped type variables in class and instance declarations]
324 ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds
325 ; fds1 <- repLFunDeps fds
326 ; ats1 <- repFamilyDecls ats
327 ; atds1 <- repAssocTyFamDefaults atds
328 ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)
329 ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
330 ; wrapGenSyms ss decls2 }
331 ; return $ Just (loc, dec)
332 }
333
334 repTyClD (L _ (XTyClDecl _)) = panic "repTyClD"
335
336 -------------------------
337 repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
338 repRoleD (L loc (RoleAnnotDecl _ tycon roles))
339 = do { tycon1 <- lookupLOcc tycon
340 ; roles1 <- mapM repRole roles
341 ; roles2 <- coreList roleTyConName roles1
342 ; dec <- repRoleAnnotD tycon1 roles2
343 ; return (loc, dec) }
344 repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD"
345
346 -------------------------
347 repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ]
348 -> Maybe (Core [TH.TypeQ])
349 -> HsDataDefn GhcRn
350 -> DsM (Core TH.DecQ)
351 repDataDefn tc bndrs opt_tys
352 (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
353 , dd_cons = cons, dd_derivs = mb_derivs })
354 = do { cxt1 <- repLContext cxt
355 ; derivs1 <- repDerivs mb_derivs
356 ; case (new_or_data, cons) of
357 (NewType, [con]) -> do { con' <- repC con
358 ; ksig' <- repMaybeLTy ksig
359 ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
360 derivs1 }
361 (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
362 <+> pprQuotedList
363 (getConNames $ unLoc $ head cons))
364 (DataType, _) -> do { ksig' <- repMaybeLTy ksig
365 ; consL <- mapM repC cons
366 ; cons1 <- coreList conQTyConName consL
367 ; repData cxt1 tc bndrs opt_tys ksig' cons1
368 derivs1 }
369 }
370 repDataDefn _ _ _ (XHsDataDefn _) = panic "repDataDefn"
371
372 repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
373 -> LHsType GhcRn
374 -> DsM (Core TH.DecQ)
375 repSynDecl tc bndrs ty
376 = do { ty1 <- repLTy ty
377 ; repTySyn tc bndrs ty1 }
378
379 repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
380 repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
381 fdLName = tc,
382 fdTyVars = tvs,
383 fdResultSig = L _ resultSig,
384 fdInjectivityAnn = injectivity }))
385 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
386 ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
387 mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn
388 { hsq_implicit = []
389 , hsq_dependent = emptyNameSet }
390 , hsq_explicit = tvs }
391 resTyVar = case resultSig of
392 TyVarSig _ bndr -> mkHsQTvs [bndr]
393 _ -> mkHsQTvs []
394 ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
395 addTyClTyVarBinds resTyVar $ \_ ->
396 case info of
397 ClosedTypeFamily Nothing ->
398 notHandled "abstract closed type family" (ppr decl)
399 ClosedTypeFamily (Just eqns) ->
400 do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns
401 ; eqns2 <- coreList tySynEqnQTyConName eqns1
402 ; result <- repFamilyResultSig resultSig
403 ; inj <- repInjectivityAnn injectivity
404 ; repClosedFamilyD tc1 bndrs result inj eqns2 }
405 OpenTypeFamily ->
406 do { result <- repFamilyResultSig resultSig
407 ; inj <- repInjectivityAnn injectivity
408 ; repOpenFamilyD tc1 bndrs result inj }
409 DataFamily ->
410 do { kind <- repFamilyResultSigToMaybeKind resultSig
411 ; repDataFamilyD tc1 bndrs kind }
412 ; return (loc, dec)
413 }
414 repFamilyDecl (L _ (XFamilyDecl _)) = panic "repFamilyDecl"
415
416 -- | Represent result signature of a type family
417 repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
418 repFamilyResultSig (NoSig _) = repNoSig
419 repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki
420 ; repKindSig ki' }
421 repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
422 ; repTyVarSig bndr' }
423 repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig"
424
425 -- | Represent result signature using a Maybe Kind. Used with data families,
426 -- where the result signature can be either missing or a kind but never a named
427 -- result variable.
428 repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
429 -> DsM (Core (Maybe TH.KindQ))
430 repFamilyResultSigToMaybeKind (NoSig _) =
431 do { coreNothing kindQTyConName }
432 repFamilyResultSigToMaybeKind (KindSig _ ki) =
433 do { ki' <- repLTy ki
434 ; coreJust kindQTyConName ki' }
435 repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"
436
437 -- | Represent injectivity annotation of a type family
438 repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
439 -> DsM (Core (Maybe TH.InjectivityAnn))
440 repInjectivityAnn Nothing =
441 do { coreNothing injAnnTyConName }
442 repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
443 do { lhs' <- lookupBinder (unLoc lhs)
444 ; rhs1 <- mapM (lookupBinder . unLoc) rhs
445 ; rhs2 <- coreList nameTyConName rhs1
446 ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]
447 ; coreJust injAnnTyConName injAnn }
448
449 repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]
450 repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
451
452 repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ]
453 repAssocTyFamDefaults = mapM rep_deflt
454 where
455 -- very like repTyFamEqn, but different in the details
456 rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
457 rep_deflt (L _ (FamEqn { feqn_tycon = tc
458 , feqn_pats = bndrs
459 , feqn_rhs = rhs }))
460 = addTyClTyVarBinds bndrs $ \ _ ->
461 do { tc1 <- lookupLOcc tc
462 ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
463 ; tys2 <- coreList typeQTyConName tys1
464 ; rhs1 <- repLTy rhs
465 ; eqn1 <- repTySynEqn tys2 rhs1
466 ; repTySynInst tc1 eqn1 }
467 rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults"
468
469 -------------------------
470 -- represent fundeps
471 --
472 repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
473 repLFunDeps fds = repList funDepTyConName repLFunDep fds
474
475 repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
476 repLFunDep (L _ (xs, ys))
477 = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
478 ys' <- repList nameTyConName (lookupBinder . unLoc) ys
479 repFunDep xs' ys'
480
481 -- Represent instance declarations
482 --
483 repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
484 repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
485 = do { dec <- repTyFamInstD fi_decl
486 ; return (loc, dec) }
487 repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
488 = do { dec <- repDataFamInstD fi_decl
489 ; return (loc, dec) }
490 repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
491 = do { dec <- repClsInstD cls_decl
492 ; return (loc, dec) }
493 repInstD (L _ (XInstDecl _)) = panic "repInstD"
494
495 repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
496 repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
497 , cid_sigs = sigs, cid_tyfam_insts = ats
498 , cid_datafam_insts = adts
499 , cid_overlap_mode = overlap
500 })
501 = addSimpleTyVarBinds tvs $
502 -- We must bring the type variables into scope, so their
503 -- occurrences don't fail, even though the binders don't
504 -- appear in the resulting data structure
505 --
506 -- But we do NOT bring the binders of 'binds' into scope
507 -- because they are properly regarded as occurrences
508 -- For example, the method names should be bound to
509 -- the selector Ids, not to fresh names (Trac #5410)
510 --
511 do { cxt1 <- repLContext cxt
512 ; inst_ty1 <- repLTy inst_ty
513 -- See Note [Scoped type variables in class and instance declarations]
514 ; (ss, sigs_binds) <- rep_sigs_binds sigs binds
515 ; ats1 <- mapM (repTyFamInstD . unLoc) ats
516 ; adts1 <- mapM (repDataFamInstD . unLoc) adts
517 ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds)
518 ; rOver <- repOverlap (fmap unLoc overlap)
519 ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
520 ; wrapGenSyms ss decls2 }
521 where
522 (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
523 repClsInstD (XClsInstDecl _) = panic "repClsInstD"
524
525 repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
526 repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
527 , deriv_type = ty }))
528 = do { dec <- addSimpleTyVarBinds tvs $
529 do { cxt' <- repLContext cxt
530 ; strat' <- repDerivStrategy strat
531 ; inst_ty' <- repLTy inst_ty
532 ; repDeriv strat' cxt' inst_ty' }
533 ; return (loc, dec) }
534 where
535 (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
536 repStandaloneDerivD (L _ (XDerivDecl _)) = panic "repStandaloneDerivD"
537
538 repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
539 repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
540 = do { let tc_name = tyFamInstDeclLName decl
541 ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
542 ; eqn1 <- repTyFamEqn eqn
543 ; repTySynInst tc eqn1 }
544
545 repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
546 repTyFamEqn (HsIB { hsib_ext = var_names
547 , hsib_body = FamEqn { feqn_pats = tys
548 , feqn_rhs = rhs }})
549 = do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
550 { hsq_implicit = var_names
551 , hsq_dependent = emptyNameSet } -- Yuk
552 , hsq_explicit = [] }
553 ; addTyClTyVarBinds hs_tvs $ \ _ ->
554 do { tys1 <- repLTys tys
555 ; tys2 <- coreList typeQTyConName tys1
556 ; rhs1 <- repLTy rhs
557 ; repTySynEqn tys2 rhs1 } }
558 repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
559 repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
560
561 repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
562 repDataFamInstD (DataFamInstDecl { dfid_eqn =
563 (HsIB { hsib_ext = var_names
564 , hsib_body = FamEqn { feqn_tycon = tc_name
565 , feqn_pats = tys
566 , feqn_rhs = defn }})})
567 = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
568 ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
569 { hsq_implicit = var_names
570 , hsq_dependent = emptyNameSet } -- Yuk
571 , hsq_explicit = [] }
572 ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
573 do { tys1 <- repList typeQTyConName repLTy tys
574 ; repDataDefn tc bndrs (Just tys1) defn } }
575 repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
576 = panic "repDataFamInstD"
577 repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
578 = panic "repDataFamInstD"
579
580 repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
581 repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
582 , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
583 = do MkC name' <- lookupLOcc name
584 MkC typ' <- repHsSigType typ
585 MkC cc' <- repCCallConv cc
586 MkC s' <- repSafety s
587 cis' <- conv_cimportspec cis
588 MkC str <- coreStringLit (static ++ chStr ++ cis')
589 dec <- rep2 forImpDName [cc', s', str, name', typ']
590 return (loc, dec)
591 where
592 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
593 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
594 conv_cimportspec (CFunction (StaticTarget _ fs _ True))
595 = return (unpackFS fs)
596 conv_cimportspec (CFunction (StaticTarget _ _ _ False))
597 = panic "conv_cimportspec: values not supported yet"
598 conv_cimportspec CWrapper = return "wrapper"
599 -- these calling conventions do not support headers and the static keyword
600 raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
601 static = case cis of
602 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
603 _ -> ""
604 chStr = case mch of
605 Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
606 _ -> ""
607 repForD decl = notHandled "Foreign declaration" (ppr decl)
608
609 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
610 repCCallConv CCallConv = rep2 cCallName []
611 repCCallConv StdCallConv = rep2 stdCallName []
612 repCCallConv CApiConv = rep2 cApiCallName []
613 repCCallConv PrimCallConv = rep2 primCallName []
614 repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
615
616 repSafety :: Safety -> DsM (Core TH.Safety)
617 repSafety PlayRisky = rep2 unsafeName []
618 repSafety PlayInterruptible = rep2 interruptibleName []
619 repSafety PlaySafe = rep2 safeName []
620
621 repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
622 repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
623 = do { MkC prec' <- coreIntLit prec
624 ; let rep_fn = case dir of
625 InfixL -> infixLDName
626 InfixR -> infixRDName
627 InfixN -> infixNDName
628 ; let do_one name
629 = do { MkC name' <- lookupLOcc name
630 ; dec <- rep2 rep_fn [prec', name']
631 ; return (loc,dec) }
632 ; mapM do_one names }
633 repFixD (L _ (XFixitySig _)) = panic "repFixD"
634
635 repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
636 repRuleD (L loc (HsRule _ n act bndrs lhs rhs))
637 = do { let bndr_names = concatMap ruleBndrNames bndrs
638 ; ss <- mkGenSyms bndr_names
639 ; rule1 <- addBinds ss $
640 do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
641 ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
642 ; act' <- repPhases act
643 ; lhs' <- repLE lhs
644 ; rhs' <- repLE rhs
645 ; repPragRule n' bndrs' lhs' rhs' act' }
646 ; rule2 <- wrapGenSyms ss rule1
647 ; return (loc, rule2) }
648 repRuleD (L _ (XRuleDecl _)) = panic "repRuleD"
649
650 ruleBndrNames :: LRuleBndr GhcRn -> [Name]
651 ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
652 ruleBndrNames (L _ (RuleBndrSig _ n sig))
653 | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
654 = unLoc n : vars
655 ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
656 = panic "ruleBndrNames"
657 ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
658 = panic "ruleBndrNames"
659 ruleBndrNames (L _ (XRuleBndr _)) = panic "ruleBndrNames"
660
661 repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
662 repRuleBndr (L _ (RuleBndr _ n))
663 = do { MkC n' <- lookupLBinder n
664 ; rep2 ruleVarName [n'] }
665 repRuleBndr (L _ (RuleBndrSig _ n sig))
666 = do { MkC n' <- lookupLBinder n
667 ; MkC ty' <- repLTy (hsSigWcType sig)
668 ; rep2 typedRuleVarName [n', ty'] }
669 repRuleBndr (L _ (XRuleBndr _)) = panic "repRuleBndr"
670
671 repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
672 repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
673 = do { target <- repAnnProv ann_prov
674 ; exp' <- repE exp
675 ; dec <- repPragAnn target exp'
676 ; return (loc, dec) }
677 repAnnD (L _ (XAnnDecl _)) = panic "repAnnD"
678
679 repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
680 repAnnProv (ValueAnnProvenance (L _ n))
681 = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level
682 ; rep2 valueAnnotationName [ n' ] }
683 repAnnProv (TypeAnnProvenance (L _ n))
684 = do { MkC n' <- globalVar n
685 ; rep2 typeAnnotationName [ n' ] }
686 repAnnProv ModuleAnnProvenance
687 = rep2 moduleAnnotationName []
688
689 -------------------------------------------------------
690 -- Constructors
691 -------------------------------------------------------
692
693 repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
694 repC (L _ (ConDeclH98 { con_name = con
695 , con_forall = L _ False
696 , con_mb_cxt = Nothing
697 , con_args = args }))
698 = repDataCon con args
699
700 repC (L _ (ConDeclH98 { con_name = con
701 , con_forall = L _ is_existential
702 , con_ex_tvs = con_tvs
703 , con_mb_cxt = mcxt
704 , con_args = args }))
705 = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
706 do { c' <- repDataCon con args
707 ; ctxt' <- repMbContext mcxt
708 ; if not is_existential && isNothing mcxt
709 then return c'
710 else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
711 }
712 }
713
714 repC (L _ (ConDeclGADT { con_names = cons
715 , con_qvars = qtvs, con_mb_cxt = mcxt
716 , con_args = args, con_res_ty = res_ty }))
717 | isEmptyLHsQTvs qtvs -- No implicit or explicit variables
718 , Nothing <- mcxt -- No context
719 -- ==> no need for a forall
720 = repGadtDataCons cons args res_ty
721
722 | otherwise
723 = addTyVarBinds qtvs $ \ ex_bndrs ->
724 -- See Note [Don't quantify implicit type variables in quotes]
725 do { c' <- repGadtDataCons cons args res_ty
726 ; ctxt' <- repMbContext mcxt
727 ; if null (hsQTvExplicit qtvs) && isNothing mcxt
728 then return c'
729 else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
730
731 repC (L _ (XConDecl _)) = panic "repC"
732
733
734 repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
735 repMbContext Nothing = repContext []
736 repMbContext (Just (L _ cxt)) = repContext cxt
737
738 repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
739 repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName []
740 repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName []
741 repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
742
743 repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)
744 repSrcStrictness SrcLazy = rep2 sourceLazyName []
745 repSrcStrictness SrcStrict = rep2 sourceStrictName []
746 repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
747
748 repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ))
749 repBangTy ty = do
750 MkC u <- repSrcUnpackedness su'
751 MkC s <- repSrcStrictness ss'
752 MkC b <- rep2 bangName [u, s]
753 MkC t <- repLTy ty'
754 rep2 bangTypeName [b, t]
755 where
756 (su', ss', ty') = case ty of
757 L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty)
758 _ -> (NoSrcUnpack, NoSrcStrict, ty)
759
760 -------------------------------------------------------
761 -- Deriving clauses
762 -------------------------------------------------------
763
764 repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
765 repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses
766
767 repDerivClause :: LHsDerivingClause GhcRn
768 -> DsM (Core TH.DerivClauseQ)
769 repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs
770 , deriv_clause_tys = L _ dct }))
771 = do MkC dcs' <- repDerivStrategy dcs
772 MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
773 rep2 derivClauseName [dcs',dct']
774 where
775 rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
776 rep_deriv_ty (L _ ty) = repTy ty
777 repDerivClause (L _ (XHsDerivingClause _)) = panic "repDerivClause"
778
779 rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
780 -> DsM ([GenSymBind], [Core TH.DecQ])
781 -- Represent signatures and methods in class/instance declarations.
782 -- See Note [Scoped type variables in class and instance declarations]
783 --
784 -- Why not use 'repBinds': we have already created symbols for methods in
785 -- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
786 -- these fun_id via 'collectHsValBinders decs', which would lead to the
787 -- instance declarations failing in TH.
788 rep_sigs_binds sigs binds
789 = do { let tvs = concatMap get_scoped_tvs sigs
790 ; ss <- mkGenSyms tvs
791 ; sigs1 <- addBinds ss $ rep_sigs sigs
792 ; binds1 <- addBinds ss $ rep_binds binds
793 ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }
794
795 -------------------------------------------------------
796 -- Signatures in a class decl, or a group of bindings
797 -------------------------------------------------------
798
799 rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
800 -- We silently ignore ones we don't recognise
801 rep_sigs = concatMapM rep_sig
802
803 rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
804 rep_sig (L loc (TypeSig _ nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
805 rep_sig (L loc (PatSynSig _ nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms
806 rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
807 | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
808 | otherwise = mapM (rep_ty_sig sigDName loc ty) nms
809 rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
810 rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
811 rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
812 rep_sig (L loc (SpecSig _ nm tys ispec))
813 = concatMapM (\t -> rep_specialise nm t ispec loc) tys
814 rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
815 rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
816 rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
817 rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc
818 rep_sig (L _ (XSig _)) = panic "rep_sig"
819
820 rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
821 -> DsM (SrcSpan, Core TH.DecQ)
822 -- Don't create the implicit and explicit variables when desugaring signatures,
823 -- see Note [Scoped type variables in class and instance declarations].
824 -- and Note [Don't quantify implicit type variables in quotes]
825 rep_ty_sig mk_sig loc sig_ty nm
826 | HsIB { hsib_body = hs_ty } <- sig_ty
827 , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
828 = do { nm1 <- lookupLOcc nm
829 ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
830 ; repTyVarBndrWithKind tv name }
831 ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv
832 explicit_tvs
833
834 -- NB: Don't pass any implicit type variables to repList above
835 -- See Note [Don't quantify implicit type variables in quotes]
836
837 ; th_ctxt <- repLContext ctxt
838 ; th_ty <- repLTy ty
839 ; ty1 <- if null explicit_tvs && null (unLoc ctxt)
840 then return th_ty
841 else repTForall th_explicit_tvs th_ctxt th_ty
842 ; sig <- repProto mk_sig nm1 ty1
843 ; return (loc, sig) }
844 rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig"
845
846 rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
847 -> DsM (SrcSpan, Core TH.DecQ)
848 -- represents a pattern synonym type signature;
849 -- see Note [Pattern synonym type signatures and Template Haskell] in Convert
850 --
851 -- Don't create the implicit and explicit variables when desugaring signatures,
852 -- see Note [Scoped type variables in class and instance declarations]
853 -- and Note [Don't quantify implicit type variables in quotes]
854 rep_patsyn_ty_sig loc sig_ty nm
855 | HsIB { hsib_body = hs_ty } <- sig_ty
856 , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
857 = do { nm1 <- lookupLOcc nm
858 ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
859 ; repTyVarBndrWithKind tv name }
860 ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs
861 ; th_exis <- repList tyVarBndrQTyConName rep_in_scope_tv exis
862
863 -- NB: Don't pass any implicit type variables to repList above
864 -- See Note [Don't quantify implicit type variables in quotes]
865
866 ; th_reqs <- repLContext reqs
867 ; th_provs <- repLContext provs
868 ; th_ty <- repLTy ty
869 ; ty1 <- repTForall th_univs th_reqs =<<
870 repTForall th_exis th_provs th_ty
871 ; sig <- repProto patSynSigDName nm1 ty1
872 ; return (loc, sig) }
873 rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig"
874
875 rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
876 -> DsM (SrcSpan, Core TH.DecQ)
877 rep_wc_ty_sig mk_sig loc sig_ty nm
878 = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
879
880 rep_inline :: Located Name
881 -> InlinePragma -- Never defaultInlinePragma
882 -> SrcSpan
883 -> DsM [(SrcSpan, Core TH.DecQ)]
884 rep_inline nm ispec loc
885 = do { nm1 <- lookupLOcc nm
886 ; inline <- repInline $ inl_inline ispec
887 ; rm <- repRuleMatch $ inl_rule ispec
888 ; phases <- repPhases $ inl_act ispec
889 ; pragma <- repPragInl nm1 inline rm phases
890 ; return [(loc, pragma)]
891 }
892
893 rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
894 -> SrcSpan
895 -> DsM [(SrcSpan, Core TH.DecQ)]
896 rep_specialise nm ty ispec loc
897 = do { nm1 <- lookupLOcc nm
898 ; ty1 <- repHsSigType ty
899 ; phases <- repPhases $ inl_act ispec
900 ; let inline = inl_inline ispec
901 ; pragma <- if noUserInlineSpec inline
902 then -- SPECIALISE
903 repPragSpec nm1 ty1 phases
904 else -- SPECIALISE INLINE
905 do { inline1 <- repInline inline
906 ; repPragSpecInl nm1 ty1 inline1 phases }
907 ; return [(loc, pragma)]
908 }
909
910 rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
911 -> DsM [(SrcSpan, Core TH.DecQ)]
912 rep_specialiseInst ty loc
913 = do { ty1 <- repHsSigType ty
914 ; pragma <- repPragSpecInst ty1
915 ; return [(loc, pragma)] }
916
917 repInline :: InlineSpec -> DsM (Core TH.Inline)
918 repInline NoInline = dataCon noInlineDataConName
919 repInline Inline = dataCon inlineDataConName
920 repInline Inlinable = dataCon inlinableDataConName
921 repInline spec = notHandled "repInline" (ppr spec)
922
923 repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
924 repRuleMatch ConLike = dataCon conLikeDataConName
925 repRuleMatch FunLike = dataCon funLikeDataConName
926
927 repPhases :: Activation -> DsM (Core TH.Phases)
928 repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
929 ; dataCon' beforePhaseDataConName [arg] }
930 repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i
931 ; dataCon' fromPhaseDataConName [arg] }
932 repPhases _ = dataCon allPhasesDataConName
933
934 rep_complete_sig :: Located [Located Name]
935 -> Maybe (Located Name)
936 -> SrcSpan
937 -> DsM [(SrcSpan, Core TH.DecQ)]
938 rep_complete_sig (L _ cls) mty loc
939 = do { mty' <- rep_maybe_name mty
940 ; cls' <- repList nameTyConName lookupLOcc cls
941 ; sig <- repPragComplete cls' mty'
942 ; return [(loc, sig)] }
943 where
944 rep_maybe_name Nothing = coreNothing nameTyConName
945 rep_maybe_name (Just n) = do
946 cn <- lookupLOcc n
947 coreJust nameTyConName cn
948
949 -------------------------------------------------------
950 -- Types
951 -------------------------------------------------------
952
953 addSimpleTyVarBinds :: [Name] -- the binders to be added
954 -> DsM (Core (TH.Q a)) -- action in the ext env
955 -> DsM (Core (TH.Q a))
956 addSimpleTyVarBinds names thing_inside
957 = do { fresh_names <- mkGenSyms names
958 ; term <- addBinds fresh_names thing_inside
959 ; wrapGenSyms fresh_names term }
960
961 addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added
962 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
963 -> DsM (Core (TH.Q a))
964 addHsTyVarBinds exp_tvs thing_inside
965 = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
966 ; term <- addBinds fresh_exp_names $
967 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
968 (exp_tvs `zip` fresh_exp_names)
969 ; thing_inside kbs }
970 ; wrapGenSyms fresh_exp_names term }
971 where
972 mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
973
974 addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
975 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
976 -> DsM (Core (TH.Q a))
977 -- gensym a list of type variables and enter them into the meta environment;
978 -- the computations passed as the second argument is executed in that extended
979 -- meta environment and gets the *new* names on Core-level as an argument
980 addTyVarBinds (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_tvs}
981 , hsq_explicit = exp_tvs })
982 thing_inside
983 = addSimpleTyVarBinds imp_tvs $
984 addHsTyVarBinds exp_tvs $
985 thing_inside
986 addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds"
987
988 addTyClTyVarBinds :: LHsQTyVars GhcRn
989 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
990 -> DsM (Core (TH.Q a))
991
992 -- Used for data/newtype declarations, and family instances,
993 -- so that the nested type variables work right
994 -- instance C (T a) where
995 -- type W (T a) = blah
996 -- The 'a' in the type instance is the one bound by the instance decl
997 addTyClTyVarBinds tvs m
998 = do { let tv_names = hsAllLTyVarNames tvs
999 ; env <- dsGetMetaEnv
1000 ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
1001 -- Make fresh names for the ones that are not already in scope
1002 -- This makes things work for family declarations
1003
1004 ; term <- addBinds freshNames $
1005 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
1006 (hsQTvExplicit tvs)
1007 ; m kbs }
1008
1009 ; wrapGenSyms freshNames term }
1010 where
1011 mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
1012 mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
1013 ; repTyVarBndrWithKind tv v }
1014
1015 -- Produce kinded binder constructors from the Haskell tyvar binders
1016 --
1017 repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
1018 -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
1019 repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
1020 = repPlainTV nm
1021 repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
1022 = repLTy ki >>= repKindedTV nm
1023 repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind"
1024
1025 -- | Represent a type variable binder
1026 repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
1027 repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )= do { nm' <- lookupBinder nm
1028 ; repPlainTV nm' }
1029 repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm
1030 ; ki' <- repLTy ki
1031 ; repKindedTV nm' ki' }
1032 repTyVarBndr (L _ (XTyVarBndr{})) = panic "repTyVarBndr"
1033
1034 -- represent a type context
1035 --
1036 repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)
1037 repLContext (L _ ctxt) = repContext ctxt
1038
1039 repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ)
1040 repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
1041 repCtxt preds
1042
1043 repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
1044 repHsSigType (HsIB { hsib_ext = implicit_tvs
1045 , hsib_body = body })
1046 | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
1047 = addSimpleTyVarBinds implicit_tvs $
1048 -- See Note [Don't quantify implicit type variables in quotes]
1049 addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
1050 do { th_ctxt <- repLContext ctxt
1051 ; th_ty <- repLTy ty
1052 ; if null explicit_tvs && null (unLoc ctxt)
1053 then return th_ty
1054 else repTForall th_explicit_tvs th_ctxt th_ty }
1055 repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType"
1056
1057 repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
1058 repHsSigWcType (HsWC { hswc_body = sig1 })
1059 = repHsSigType sig1
1060 repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType"
1061
1062 -- yield the representation of a list of types
1063 repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]
1064 repLTys tys = mapM repLTy tys
1065
1066 -- represent a type
1067 repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ)
1068 repLTy (L _ ty) = repTy ty
1069
1070 repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)
1071 -- Arg of repForall is always HsForAllTy or HsQualTy
1072 repForall ty
1073 | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
1074 = addHsTyVarBinds tvs $ \bndrs ->
1075 do { ctxt1 <- repLContext ctxt
1076 ; ty1 <- repLTy tau
1077 ; repTForall bndrs ctxt1 ty1 }
1078
1079 repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
1080 repTy ty@(HsForAllTy {}) = repForall ty
1081 repTy ty@(HsQualTy {}) = repForall ty
1082
1083 repTy (HsTyVar _ _ (L _ n))
1084 | isLiftedTypeKindTyConName n = repTStar
1085 | n `hasKey` constraintKindTyConKey = repTConstraint
1086 | n `hasKey` funTyConKey = repArrowTyCon
1087 | isTvOcc occ = do tv1 <- lookupOcc n
1088 repTvar tv1
1089 | isDataOcc occ = do tc1 <- lookupOcc n
1090 repPromotedDataCon tc1
1091 | n == eqTyConName = repTequality
1092 | otherwise = do tc1 <- lookupOcc n
1093 repNamedTyCon tc1
1094 where
1095 occ = nameOccName n
1096
1097 repTy (HsAppTy _ f a) = do
1098 f1 <- repLTy f
1099 a1 <- repLTy a
1100 repTapp f1 a1
1101 repTy (HsFunTy _ f a) = do
1102 f1 <- repLTy f
1103 a1 <- repLTy a
1104 tcon <- repArrowTyCon
1105 repTapps tcon [f1, a1]
1106 repTy (HsListTy _ t) = do
1107 t1 <- repLTy t
1108 tcon <- repListTyCon
1109 repTapp tcon t1
1110 repTy (HsTupleTy _ HsUnboxedTuple tys) = do
1111 tys1 <- repLTys tys
1112 tcon <- repUnboxedTupleTyCon (length tys)
1113 repTapps tcon tys1
1114 repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys
1115 tcon <- repTupleTyCon (length tys)
1116 repTapps tcon tys1
1117 repTy (HsSumTy _ tys) = do tys1 <- repLTys tys
1118 tcon <- repUnboxedSumTyCon (length tys)
1119 repTapps tcon tys1
1120 repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
1121 `nlHsAppTy` ty2)
1122 repTy (HsParTy _ t) = repLTy t
1123 repTy (HsStarTy _ _) = repTStar
1124 repTy (HsKindSig _ t k) = do
1125 t1 <- repLTy t
1126 k1 <- repLTy k
1127 repTSig t1 k1
1128 repTy (HsSpliceTy _ splice) = repSplice splice
1129 repTy (HsExplicitListTy _ _ tys) = do
1130 tys1 <- repLTys tys
1131 repTPromotedList tys1
1132 repTy (HsExplicitTupleTy _ tys) = do
1133 tys1 <- repLTys tys
1134 tcon <- repPromotedTupleTyCon (length tys)
1135 repTapps tcon tys1
1136 repTy (HsTyLit _ lit) = do
1137 lit' <- repTyLit lit
1138 repTLit lit'
1139 repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
1140 repTy (HsIParamTy _ n t) = do
1141 n' <- rep_implicit_param_name (unLoc n)
1142 t' <- repLTy t
1143 repTImplicitParam n' t'
1144
1145 repTy ty = notHandled "Exotic form of type" (ppr ty)
1146
1147 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
1148 repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
1149 rep2 numTyLitName [iExpr]
1150 repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
1151 ; rep2 strTyLitName [s']
1152 }
1153
1154 -- | Represent a type wrapped in a Maybe
1155 repMaybeLTy :: Maybe (LHsKind GhcRn)
1156 -> DsM (Core (Maybe TH.TypeQ))
1157 repMaybeLTy Nothing =
1158 do { coreNothing kindQTyConName }
1159 repMaybeLTy (Just ki) =
1160 do { ki' <- repLTy ki
1161 ; coreJust kindQTyConName ki' }
1162
1163 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
1164 repRole (L _ (Just Nominal)) = rep2 nominalRName []
1165 repRole (L _ (Just Representational)) = rep2 representationalRName []
1166 repRole (L _ (Just Phantom)) = rep2 phantomRName []
1167 repRole (L _ Nothing) = rep2 inferRName []
1168
1169 -----------------------------------------------------------------------------
1170 -- Splices
1171 -----------------------------------------------------------------------------
1172
1173 repSplice :: HsSplice GhcRn -> DsM (Core a)
1174 -- See Note [How brackets and nested splices are handled] in TcSplice
1175 -- We return a CoreExpr of any old type; the context should know
1176 repSplice (HsTypedSplice _ _ n _) = rep_splice n
1177 repSplice (HsUntypedSplice _ _ n _) = rep_splice n
1178 repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n
1179 repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e)
1180 repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e)
1181
1182 rep_splice :: Name -> DsM (Core a)
1183 rep_splice splice_name
1184 = do { mb_val <- dsLookupMetaEnv splice_name
1185 ; case mb_val of
1186 Just (DsSplice e) -> do { e' <- dsExpr e
1187 ; return (MkC e') }
1188 _ -> pprPanic "HsSplice" (ppr splice_name) }
1189 -- Should not happen; statically checked
1190
1191 -----------------------------------------------------------------------------
1192 -- Expressions
1193 -----------------------------------------------------------------------------
1194
1195 repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ])
1196 repLEs es = repList expQTyConName repLE es
1197
1198 -- FIXME: some of these panics should be converted into proper error messages
1199 -- unless we can make sure that constructs, which are plainly not
1200 -- supported in TH already lead to error messages at an earlier stage
1201 repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
1202 repLE (L loc e) = putSrcSpanDs loc (repE e)
1203
1204 repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
1205 repE (HsVar _ (L _ x)) =
1206 do { mb_val <- dsLookupMetaEnv x
1207 ; case mb_val of
1208 Nothing -> do { str <- globalVar x
1209 ; repVarOrCon x str }
1210 Just (DsBound y) -> repVarOrCon x (coreVar y)
1211 Just (DsSplice e) -> do { e' <- dsExpr e
1212 ; return (MkC e') } }
1213 repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
1214 repE (HsOverLabel _ _ s) = repOverLabel s
1215
1216 repE e@(HsRecFld _ f) = case f of
1217 Unambiguous x _ -> repE (HsVar noExt (noLoc x))
1218 Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
1219 XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
1220
1221 -- Remember, we're desugaring renamer output here, so
1222 -- HsOverlit can definitely occur
1223 repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
1224 repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
1225 repE (HsLam _ (MG { mg_alts = L _ [m] })) = repLambda m
1226 repE (HsLamCase _ (MG { mg_alts = L _ ms }))
1227 = do { ms' <- mapM repMatchTup ms
1228 ; core_ms <- coreList matchQTyConName ms'
1229 ; repLamCase core_ms }
1230 repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
1231 repE (HsAppType t e) = do { a <- repLE e
1232 ; s <- repLTy (hswc_body t)
1233 ; repAppType a s }
1234
1235 repE (OpApp _ e1 op e2) =
1236 do { arg1 <- repLE e1;
1237 arg2 <- repLE e2;
1238 the_op <- repLE op ;
1239 repInfixApp arg1 the_op arg2 }
1240 repE (NegApp _ x _) = do
1241 a <- repLE x
1242 negateVar <- lookupOcc negateName >>= repVar
1243 negateVar `repApp` a
1244 repE (HsPar _ x) = repLE x
1245 repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
1246 repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
1247 repE (HsCase _ e (MG { mg_alts = L _ ms }))
1248 = do { arg <- repLE e
1249 ; ms2 <- mapM repMatchTup ms
1250 ; core_ms2 <- coreList matchQTyConName ms2
1251 ; repCaseE arg core_ms2 }
1252 repE (HsIf _ _ x y z) = do
1253 a <- repLE x
1254 b <- repLE y
1255 c <- repLE z
1256 repCond a b c
1257 repE (HsMultiIf _ alts)
1258 = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
1259 ; expr' <- repMultiIf (nonEmptyCoreList alts')
1260 ; wrapGenSyms (concat binds) expr' }
1261 repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs
1262 ; e2 <- addBinds ss (repLE e)
1263 ; z <- repLetE ds e2
1264 ; wrapGenSyms ss z }
1265
1266 -- FIXME: I haven't got the types here right yet
1267 repE e@(HsDo _ ctxt (L _ sts))
1268 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
1269 = do { (ss,zs) <- repLSts sts;
1270 e' <- repDoE (nonEmptyCoreList zs);
1271 wrapGenSyms ss e' }
1272
1273 | ListComp <- ctxt
1274 = do { (ss,zs) <- repLSts sts;
1275 e' <- repComp (nonEmptyCoreList zs);
1276 wrapGenSyms ss e' }
1277
1278 | MDoExpr <- ctxt
1279 = do { (ss,zs) <- repLSts sts;
1280 e' <- repMDoE (nonEmptyCoreList zs);
1281 wrapGenSyms ss e' }
1282
1283 | otherwise
1284 = notHandled "monad comprehension and [: :]" (ppr e)
1285
1286 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
1287 repE e@(ExplicitTuple _ es boxed)
1288 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
1289 | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs }
1290 | otherwise = do { xs <- repLEs [e | L _ (Present _ e) <- es]
1291 ; repUnboxedTup xs }
1292
1293 repE (ExplicitSum _ alt arity e)
1294 = do { e1 <- repLE e
1295 ; repUnboxedSum e1 alt arity }
1296
1297 repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
1298 = do { x <- lookupLOcc c;
1299 fs <- repFields flds;
1300 repRecCon x fs }
1301 repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
1302 = do { x <- repLE e;
1303 fs <- repUpdFields flds;
1304 repRecUpd x fs }
1305
1306 repE (ExprWithTySig ty e)
1307 = do { e1 <- repLE e
1308 ; t1 <- repHsSigWcType ty
1309 ; repSigExp e1 t1 }
1310
1311 repE (ArithSeq _ _ aseq) =
1312 case aseq of
1313 From e -> do { ds1 <- repLE e; repFrom ds1 }
1314 FromThen e1 e2 -> do
1315 ds1 <- repLE e1
1316 ds2 <- repLE e2
1317 repFromThen ds1 ds2
1318 FromTo e1 e2 -> do
1319 ds1 <- repLE e1
1320 ds2 <- repLE e2
1321 repFromTo ds1 ds2
1322 FromThenTo e1 e2 e3 -> do
1323 ds1 <- repLE e1
1324 ds2 <- repLE e2
1325 ds3 <- repLE e3
1326 repFromThenTo ds1 ds2 ds3
1327
1328 repE (HsSpliceE _ splice) = repSplice splice
1329 repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC
1330 repE (HsUnboundVar _ uv) = do
1331 occ <- occNameLit (unboundVarOcc uv)
1332 sname <- repNameS occ
1333 repUnboundVar sname
1334
1335 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
1336 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
1337 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
1338 repE e = notHandled "Expression form" (ppr e)
1339
1340 -----------------------------------------------------------------------------
1341 -- Building representations of auxillary structures like Match, Clause, Stmt,
1342
1343 repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
1344 repMatchTup (L _ (Match { m_pats = [p]
1345 , m_grhss = GRHSs _ guards (L _ wheres) })) =
1346 do { ss1 <- mkGenSyms (collectPatBinders p)
1347 ; addBinds ss1 $ do {
1348 ; p1 <- repLP p
1349 ; (ss2,ds) <- repBinds wheres
1350 ; addBinds ss2 $ do {
1351 ; gs <- repGuards guards
1352 ; match <- repMatch p1 gs ds
1353 ; wrapGenSyms (ss1++ss2) match }}}
1354 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
1355
1356 repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
1357 repClauseTup (L _ (Match { m_pats = ps
1358 , m_grhss = GRHSs _ guards (L _ wheres) })) =
1359 do { ss1 <- mkGenSyms (collectPatsBinders ps)
1360 ; addBinds ss1 $ do {
1361 ps1 <- repLPs ps
1362 ; (ss2,ds) <- repBinds wheres
1363 ; addBinds ss2 $ do {
1364 gs <- repGuards guards
1365 ; clause <- repClause ps1 gs ds
1366 ; wrapGenSyms (ss1++ss2) clause }}}
1367 repClauseTup (L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"
1368 repClauseTup (L _ (XMatch _)) = panic "repClauseTup"
1369
1370 repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ)
1371 repGuards [L _ (GRHS _ [] e)]
1372 = do {a <- repLE e; repNormal a }
1373 repGuards other
1374 = do { zs <- mapM repLGRHS other
1375 ; let (xs, ys) = unzip zs
1376 ; gd <- repGuarded (nonEmptyCoreList ys)
1377 ; wrapGenSyms (concat xs) gd }
1378
1379 repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
1380 -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
1381 repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
1382 = do { guarded <- repLNormalGE e1 e2
1383 ; return ([], guarded) }
1384 repLGRHS (L _ (GRHS _ ss rhs))
1385 = do { (gs, ss') <- repLSts ss
1386 ; rhs' <- addBinds gs $ repLE rhs
1387 ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
1388 ; return (gs, guarded) }
1389 repLGRHS (L _ (XGRHS _)) = panic "repLGRHS"
1390
1391 repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])
1392 repFields (HsRecFields { rec_flds = flds })
1393 = repList fieldExpQTyConName rep_fld flds
1394 where
1395 rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
1396 -> DsM (Core (TH.Q TH.FieldExp))
1397 rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
1398 ; e <- repLE (hsRecFieldArg fld)
1399 ; repFieldExp fn e }
1400
1401 repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])
1402 repUpdFields = repList fieldExpQTyConName rep_fld
1403 where
1404 rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
1405 rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
1406 Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
1407 ; e <- repLE (hsRecFieldArg fld)
1408 ; repFieldExp fn e }
1409 _ -> notHandled "Ambiguous record updates" (ppr fld)
1410
1411
1412
1413 -----------------------------------------------------------------------------
1414 -- Representing Stmt's is tricky, especially if bound variables
1415 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
1416 -- First gensym new names for every variable in any of the patterns.
1417 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
1418 -- if variables didn't shaddow, the static gensym wouldn't be necessary
1419 -- and we could reuse the original names (x and x).
1420 --
1421 -- do { x'1 <- gensym "x"
1422 -- ; x'2 <- gensym "x"
1423 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
1424 -- , BindSt (pvar x'2) [| f x |]
1425 -- , NoBindSt [| g x |]
1426 -- ]
1427 -- }
1428
1429 -- The strategy is to translate a whole list of do-bindings by building a
1430 -- bigger environment, and a bigger set of meta bindings
1431 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
1432 -- of the expressions within the Do
1433
1434 -----------------------------------------------------------------------------
1435 -- The helper function repSts computes the translation of each sub expression
1436 -- and a bunch of prefix bindings denoting the dynamic renaming.
1437
1438 repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1439 repLSts stmts = repSts (map unLoc stmts)
1440
1441 repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1442 repSts (BindStmt _ p e _ _ : ss) =
1443 do { e2 <- repLE e
1444 ; ss1 <- mkGenSyms (collectPatBinders p)
1445 ; addBinds ss1 $ do {
1446 ; p1 <- repLP p;
1447 ; (ss2,zs) <- repSts ss
1448 ; z <- repBindSt p1 e2
1449 ; return (ss1++ss2, z : zs) }}
1450 repSts (LetStmt _ (L _ bs) : ss) =
1451 do { (ss1,ds) <- repBinds bs
1452 ; z <- repLetSt ds
1453 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1454 ; return (ss1++ss2, z : zs) }
1455 repSts (BodyStmt _ e _ _ : ss) =
1456 do { e2 <- repLE e
1457 ; z <- repNoBindSt e2
1458 ; (ss2,zs) <- repSts ss
1459 ; return (ss2, z : zs) }
1460 repSts (ParStmt _ stmt_blocks _ _ : ss) =
1461 do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
1462 ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
1463 ss1 = concat ss_s
1464 ; z <- repParSt stmt_blocks2
1465 ; (ss2, zs) <- addBinds ss1 (repSts ss)
1466 ; return (ss1++ss2, z : zs) }
1467 where
1468 rep_stmt_block :: ParStmtBlock GhcRn GhcRn
1469 -> DsM ([GenSymBind], Core [TH.StmtQ])
1470 rep_stmt_block (ParStmtBlock _ stmts _ _) =
1471 do { (ss1, zs) <- repSts (map unLoc stmts)
1472 ; zs1 <- coreList stmtQTyConName zs
1473 ; return (ss1, zs1) }
1474 rep_stmt_block (XParStmtBlock{}) = panic "repSts"
1475 repSts [LastStmt _ e _ _]
1476 = do { e2 <- repLE e
1477 ; z <- repNoBindSt e2
1478 ; return ([], [z]) }
1479 repSts (stmt@RecStmt{} : ss)
1480 = do { let binders = collectLStmtsBinders (recS_stmts stmt)
1481 ; ss1 <- mkGenSyms binders
1482 -- Bring all of binders in the recursive group into scope for the
1483 -- whole group.
1484 ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))
1485 ; MASSERT(sort ss1 == sort ss1_other)
1486 ; z <- repRecSt (nonEmptyCoreList rss)
1487 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1488 ; return (ss1++ss2, z : zs) }
1489 repSts [] = return ([],[])
1490 repSts other = notHandled "Exotic statement" (ppr other)
1491
1492
1493 -----------------------------------------------------------
1494 -- Bindings
1495 -----------------------------------------------------------
1496
1497 repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
1498 repBinds (EmptyLocalBinds _)
1499 = do { core_list <- coreList decQTyConName []
1500 ; return ([], core_list) }
1501
1502 repBinds (HsIPBinds _ (IPBinds _ decs))
1503 = do { ips <- mapM rep_implicit_param_bind decs
1504 ; core_list <- coreList decQTyConName
1505 (de_loc (sort_by_loc ips))
1506 ; return ([], core_list)
1507 }
1508
1509 repBinds b@(HsIPBinds _ XHsIPBinds {})
1510 = notHandled "Implicit parameter binds extension" (ppr b)
1511
1512 repBinds (HsValBinds _ decs)
1513 = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
1514 -- No need to worry about detailed scopes within
1515 -- the binding group, because we are talking Names
1516 -- here, so we can safely treat it as a mutually
1517 -- recursive group
1518 -- For hsScopedTvBinders see Note [Scoped type variables in bindings]
1519 ; ss <- mkGenSyms bndrs
1520 ; prs <- addBinds ss (rep_val_binds decs)
1521 ; core_list <- coreList decQTyConName
1522 (de_loc (sort_by_loc prs))
1523 ; return (ss, core_list) }
1524 repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
1525
1526 rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
1527 rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
1528 = do { name <- case ename of
1529 Left (L _ n) -> rep_implicit_param_name n
1530 Right _ ->
1531 panic "rep_implicit_param_bind: post typechecking"
1532 ; rhs' <- repE rhs
1533 ; ipb <- repImplicitParamBind name rhs'
1534 ; return (loc, ipb) }
1535 rep_implicit_param_bind (L _ b@(XIPBind _))
1536 = notHandled "Implicit parameter bind extension" (ppr b)
1537
1538 rep_implicit_param_name :: HsIPName -> DsM (Core String)
1539 rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
1540
1541 rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
1542 -- Assumes: all the binders of the binding are already in the meta-env
1543 rep_val_binds (XValBindsLR (NValBinds binds sigs))
1544 = do { core1 <- rep_binds (unionManyBags (map snd binds))
1545 ; core2 <- rep_sigs sigs
1546 ; return (core1 ++ core2) }
1547 rep_val_binds (ValBinds _ _ _)
1548 = panic "rep_val_binds: ValBinds"
1549
1550 rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
1551 rep_binds = mapM rep_bind . bagToList
1552
1553 rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
1554 -- Assumes: all the binders of the binding are already in the meta-env
1555
1556 -- Note GHC treats declarations of a variable (not a pattern)
1557 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1558 -- with an empty list of patterns
1559 rep_bind (L loc (FunBind
1560 { fun_id = fn,
1561 fun_matches = MG { mg_alts
1562 = L _ [L _ (Match
1563 { m_pats = []
1564 , m_grhss = GRHSs _ guards (L _ wheres) }
1565 )] } }))
1566 = do { (ss,wherecore) <- repBinds wheres
1567 ; guardcore <- addBinds ss (repGuards guards)
1568 ; fn' <- lookupLBinder fn
1569 ; p <- repPvar fn'
1570 ; ans <- repVal p guardcore wherecore
1571 ; ans' <- wrapGenSyms ss ans
1572 ; return (loc, ans') }
1573
1574 rep_bind (L loc (FunBind { fun_id = fn
1575 , fun_matches = MG { mg_alts = L _ ms } }))
1576 = do { ms1 <- mapM repClauseTup ms
1577 ; fn' <- lookupLBinder fn
1578 ; ans <- repFun fn' (nonEmptyCoreList ms1)
1579 ; return (loc, ans) }
1580
1581 rep_bind (L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"
1582
1583 rep_bind (L loc (PatBind { pat_lhs = pat
1584 , pat_rhs = GRHSs _ guards (L _ wheres) }))
1585 = do { patcore <- repLP pat
1586 ; (ss,wherecore) <- repBinds wheres
1587 ; guardcore <- addBinds ss (repGuards guards)
1588 ; ans <- repVal patcore guardcore wherecore
1589 ; ans' <- wrapGenSyms ss ans
1590 ; return (loc, ans') }
1591 rep_bind (L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"
1592
1593 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1594 = do { v' <- lookupBinder v
1595 ; e2 <- repLE e
1596 ; x <- repNormal e2
1597 ; patcore <- repPvar v'
1598 ; empty_decls <- coreList decQTyConName []
1599 ; ans <- repVal patcore x empty_decls
1600 ; return (srcLocSpan (getSrcLoc v), ans) }
1601
1602 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1603 rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
1604 , psb_args = args
1605 , psb_def = pat
1606 , psb_dir = dir })))
1607 = do { syn' <- lookupLBinder syn
1608 ; dir' <- repPatSynDir dir
1609 ; ss <- mkGenArgSyms args
1610 ; patSynD' <- addBinds ss (
1611 do { args' <- repPatSynArgs args
1612 ; pat' <- repLP pat
1613 ; repPatSynD syn' args' dir' pat' })
1614 ; patSynD'' <- wrapGenArgSyms args ss patSynD'
1615 ; return (loc, patSynD'') }
1616 where
1617 mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]
1618 -- for Record Pattern Synonyms we want to conflate the selector
1619 -- and the pattern-only names in order to provide a nicer TH
1620 -- API. Whereas inside GHC, record pattern synonym selectors and
1621 -- their pattern-only bound right hand sides have different names,
1622 -- we want to treat them the same in TH. This is the reason why we
1623 -- need an adjusted mkGenArgSyms in the `RecCon` case below.
1624 mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args)
1625 mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
1626 mkGenArgSyms (RecCon fields)
1627 = do { let pats = map (unLoc . recordPatSynPatVar) fields
1628 sels = map (unLoc . recordPatSynSelectorId) fields
1629 ; ss <- mkGenSyms sels
1630 ; return $ replaceNames (zip sels pats) ss }
1631
1632 replaceNames selsPats genSyms
1633 = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
1634 , sel == sel' ]
1635
1636 wrapGenArgSyms :: HsPatSynDetails (Located Name)
1637 -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
1638 wrapGenArgSyms (RecCon _) _ dec = return dec
1639 wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
1640
1641 rep_bind (L _ (PatSynBind _ (XPatSynBind _))) = panic "rep_bind: XPatSynBind"
1642 rep_bind (L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR"
1643
1644 repPatSynD :: Core TH.Name
1645 -> Core TH.PatSynArgsQ
1646 -> Core TH.PatSynDirQ
1647 -> Core TH.PatQ
1648 -> DsM (Core TH.DecQ)
1649 repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
1650 = rep2 patSynDName [syn, args, dir, pat]
1651
1652 repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
1653 repPatSynArgs (PrefixCon args)
1654 = do { args' <- repList nameTyConName lookupLOcc args
1655 ; repPrefixPatSynArgs args' }
1656 repPatSynArgs (InfixCon arg1 arg2)
1657 = do { arg1' <- lookupLOcc arg1
1658 ; arg2' <- lookupLOcc arg2
1659 ; repInfixPatSynArgs arg1' arg2' }
1660 repPatSynArgs (RecCon fields)
1661 = do { sels' <- repList nameTyConName lookupLOcc sels
1662 ; repRecordPatSynArgs sels' }
1663 where sels = map recordPatSynSelectorId fields
1664
1665 repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)
1666 repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
1667
1668 repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)
1669 repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
1670
1671 repRecordPatSynArgs :: Core [TH.Name]
1672 -> DsM (Core TH.PatSynArgsQ)
1673 repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
1674
1675 repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)
1676 repPatSynDir Unidirectional = rep2 unidirPatSynName []
1677 repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
1678 repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))
1679 = do { clauses' <- mapM repClauseTup clauses
1680 ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
1681 repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"
1682
1683 repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
1684 repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
1685
1686
1687 -----------------------------------------------------------------------------
1688 -- Since everything in a Bind is mutually recursive we need rename all
1689 -- all the variables simultaneously. For example:
1690 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1691 -- do { f'1 <- gensym "f"
1692 -- ; g'2 <- gensym "g"
1693 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1694 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1695 -- ]}
1696 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1697 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1698 -- together. As we do this we collect GenSymBinds's which represent the renamed
1699 -- variables bound by the Bindings. In order not to lose track of these
1700 -- representations we build a shadow datatype MB with the same structure as
1701 -- MonoBinds, but which has slots for the representations
1702
1703
1704 -----------------------------------------------------------------------------
1705 -- GHC allows a more general form of lambda abstraction than specified
1706 -- by Haskell 98. In particular it allows guarded lambda's like :
1707 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1708 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1709 -- (\ p1 .. pn -> exp) by causing an error.
1710
1711 repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
1712 repLambda (L _ (Match { m_pats = ps
1713 , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
1714 (L _ (EmptyLocalBinds _)) } ))
1715 = do { let bndrs = collectPatsBinders ps ;
1716 ; ss <- mkGenSyms bndrs
1717 ; lam <- addBinds ss (
1718 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1719 ; wrapGenSyms ss lam }
1720
1721 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m)
1722
1723
1724 -----------------------------------------------------------------------------
1725 -- Patterns
1726 -- repP deals with patterns. It assumes that we have already
1727 -- walked over the pattern(s) once to collect the binders, and
1728 -- have extended the environment. So every pattern-bound
1729 -- variable should already appear in the environment.
1730
1731 -- Process a list of patterns
1732 repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ])
1733 repLPs ps = repList patQTyConName repLP ps
1734
1735 repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
1736 repLP (L _ p) = repP p
1737
1738 repP :: Pat GhcRn -> DsM (Core TH.PatQ)
1739 repP (WildPat _) = repPwild
1740 repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 }
1741 repP (VarPat _ (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
1742 repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 }
1743 repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 }
1744 repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p
1745 ; repPaspat x' p1 }
1746 repP (ParPat _ p) = repLP p
1747 repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs }
1748 repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)
1749 ; e' <- repE (syn_expr e)
1750 ; repPview e' p}
1751 repP (TuplePat _ ps boxed)
1752 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1753 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1754 repP (SumPat _ p alt arity) = do { p1 <- repLP p
1755 ; repPunboxedSum p1 alt arity }
1756 repP (ConPatIn dc details)
1757 = do { con_str <- lookupLOcc dc
1758 ; case details of
1759 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1760 RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
1761 ; repPrec con_str fps }
1762 InfixCon p1 p2 -> do { p1' <- repLP p1;
1763 p2' <- repLP p2;
1764 repPinfix p1' con_str p2' }
1765 }
1766 where
1767 rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))
1768 rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
1769 ; MkC p <- repLP (hsRecFieldArg fld)
1770 ; rep2 fieldPatName [v,p] }
1771
1772 repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1773 repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1774 repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1775 repP (SigPat t p) = do { p' <- repLP p
1776 ; t' <- repLTy (hsSigWcType t)
1777 ; repPsig p' t' }
1778 repP (SplicePat _ splice) = repSplice splice
1779
1780 repP other = notHandled "Exotic pattern" (ppr other)
1781
1782 ----------------------------------------------------------
1783 -- Declaration ordering helpers
1784
1785 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1786 sort_by_loc xs = sortBy comp xs
1787 where comp x y = compare (fst x) (fst y)
1788
1789 de_loc :: [(a, b)] -> [b]
1790 de_loc = map snd
1791
1792 ----------------------------------------------------------
1793 -- The meta-environment
1794
1795 -- A name/identifier association for fresh names of locally bound entities
1796 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1797 -- I.e. (x, x_id) means
1798 -- let x_id = gensym "x" in ...
1799
1800 -- Generate a fresh name for a locally bound entity
1801
1802 mkGenSyms :: [Name] -> DsM [GenSymBind]
1803 -- We can use the existing name. For example:
1804 -- [| \x_77 -> x_77 + x_77 |]
1805 -- desugars to
1806 -- do { x_77 <- genSym "x"; .... }
1807 -- We use the same x_77 in the desugared program, but with the type Bndr
1808 -- instead of Int
1809 --
1810 -- We do make it an Internal name, though (hence localiseName)
1811 --
1812 -- Nevertheless, it's monadic because we have to generate nameTy
1813 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1814 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1815
1816
1817 addBinds :: [GenSymBind] -> DsM a -> DsM a
1818 -- Add a list of fresh names for locally bound entities to the
1819 -- meta environment (which is part of the state carried around
1820 -- by the desugarer monad)
1821 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
1822
1823 -- Look up a locally bound name
1824 --
1825 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1826 lookupLBinder (L _ n) = lookupBinder n
1827
1828 lookupBinder :: Name -> DsM (Core TH.Name)
1829 lookupBinder = lookupOcc
1830 -- Binders are brought into scope before the pattern or what-not is
1831 -- desugared. Moreover, in instance declaration the binder of a method
1832 -- will be the selector Id and hence a global; so we need the
1833 -- globalVar case of lookupOcc
1834
1835 -- Look up a name that is either locally bound or a global name
1836 --
1837 -- * If it is a global name, generate the "original name" representation (ie,
1838 -- the <module>:<name> form) for the associated entity
1839 --
1840 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1841 -- Lookup an occurrence; it can't be a splice.
1842 -- Use the in-scope bindings if they exist
1843 lookupLOcc (L _ n) = lookupOcc n
1844
1845 lookupOcc :: Name -> DsM (Core TH.Name)
1846 lookupOcc n
1847 = do { mb_val <- dsLookupMetaEnv n ;
1848 case mb_val of
1849 Nothing -> globalVar n
1850 Just (DsBound x) -> return (coreVar x)
1851 Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
1852 }
1853
1854 globalVar :: Name -> DsM (Core TH.Name)
1855 -- Not bound by the meta-env
1856 -- Could be top-level; or could be local
1857 -- f x = $(g [| x |])
1858 -- Here the x will be local
1859 globalVar name
1860 | isExternalName name
1861 = do { MkC mod <- coreStringLit name_mod
1862 ; MkC pkg <- coreStringLit name_pkg
1863 ; MkC occ <- nameLit name
1864 ; rep2 mk_varg [pkg,mod,occ] }
1865 | otherwise
1866 = do { MkC occ <- nameLit name
1867 ; MkC uni <- coreIntLit (getKey (getUnique name))
1868 ; rep2 mkNameLName [occ,uni] }
1869 where
1870 mod = ASSERT( isExternalName name) nameModule name
1871 name_mod = moduleNameString (moduleName mod)
1872 name_pkg = unitIdString (moduleUnitId mod)
1873 name_occ = nameOccName name
1874 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1875 | OccName.isVarOcc name_occ = mkNameG_vName
1876 | OccName.isTcOcc name_occ = mkNameG_tcName
1877 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1878
1879 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1880 -> DsM Type -- The type
1881 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1882 return (mkTyConApp tc []) }
1883
1884 wrapGenSyms :: [GenSymBind]
1885 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1886 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1887 -- --> bindQ (gensym nm1) (\ id1 ->
1888 -- bindQ (gensym nm2 (\ id2 ->
1889 -- y))
1890
1891 wrapGenSyms binds body@(MkC b)
1892 = do { var_ty <- lookupType nameTyConName
1893 ; go var_ty binds }
1894 where
1895 [elt_ty] = tcTyConAppArgs (exprType b)
1896 -- b :: Q a, so we can get the type 'a' by looking at the
1897 -- argument type. NB: this relies on Q being a data/newtype,
1898 -- not a type synonym
1899
1900 go _ [] = return body
1901 go var_ty ((name,id) : binds)
1902 = do { MkC body' <- go var_ty binds
1903 ; lit_str <- nameLit name
1904 ; gensym_app <- repGensym lit_str
1905 ; repBindQ var_ty elt_ty
1906 gensym_app (MkC (Lam id body')) }
1907
1908 nameLit :: Name -> DsM (Core String)
1909 nameLit n = coreStringLit (occNameString (nameOccName n))
1910
1911 occNameLit :: OccName -> DsM (Core String)
1912 occNameLit name = coreStringLit (occNameString name)
1913
1914
1915 -- %*********************************************************************
1916 -- %* *
1917 -- Constructing code
1918 -- %* *
1919 -- %*********************************************************************
1920
1921 -----------------------------------------------------------------------------
1922 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1923 -- we invent a new datatype which uses phantom types.
1924
1925 newtype Core a = MkC CoreExpr
1926 unC :: Core a -> CoreExpr
1927 unC (MkC x) = x
1928
1929 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1930 rep2 n xs = do { id <- dsLookupGlobalId n
1931 ; return (MkC (foldl' App (Var id) xs)) }
1932
1933 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
1934 dataCon' n args = do { id <- dsLookupDataCon n
1935 ; return $ MkC $ mkCoreConApps id args }
1936
1937 dataCon :: Name -> DsM (Core a)
1938 dataCon n = dataCon' n []
1939
1940
1941 -- %*********************************************************************
1942 -- %* *
1943 -- The 'smart constructors'
1944 -- %* *
1945 -- %*********************************************************************
1946
1947 --------------- Patterns -----------------
1948 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1949 repPlit (MkC l) = rep2 litPName [l]
1950
1951 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1952 repPvar (MkC s) = rep2 varPName [s]
1953
1954 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1955 repPtup (MkC ps) = rep2 tupPName [ps]
1956
1957 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1958 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1959
1960 repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
1961 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
1962 repPunboxedSum (MkC p) alt arity
1963 = do { dflags <- getDynFlags
1964 ; rep2 unboxedSumPName [ p
1965 , mkIntExprInt dflags alt
1966 , mkIntExprInt dflags arity ] }
1967
1968 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1969 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1970
1971 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1972 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1973
1974 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1975 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1976
1977 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1978 repPtilde (MkC p) = rep2 tildePName [p]
1979
1980 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1981 repPbang (MkC p) = rep2 bangPName [p]
1982
1983 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1984 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1985
1986 repPwild :: DsM (Core TH.PatQ)
1987 repPwild = rep2 wildPName []
1988
1989 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1990 repPlist (MkC ps) = rep2 listPName [ps]
1991
1992 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1993 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1994
1995 repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1996 repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1997
1998 --------------- Expressions -----------------
1999 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
2000 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
2001 | otherwise = repVar str
2002
2003 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
2004 repVar (MkC s) = rep2 varEName [s]
2005
2006 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
2007 repCon (MkC s) = rep2 conEName [s]
2008
2009 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
2010 repLit (MkC c) = rep2 litEName [c]
2011
2012 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2013 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
2014
2015 repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
2016 repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
2017
2018 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2019 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
2020
2021 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
2022 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
2023
2024 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
2025 repTup (MkC es) = rep2 tupEName [es]
2026
2027 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
2028 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
2029
2030 repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
2031 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
2032 repUnboxedSum (MkC e) alt arity
2033 = do { dflags <- getDynFlags
2034 ; rep2 unboxedSumEName [ e
2035 , mkIntExprInt dflags alt
2036 , mkIntExprInt dflags arity ] }
2037
2038 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2039 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
2040
2041 repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
2042 repMultiIf (MkC alts) = rep2 multiIfEName [alts]
2043
2044 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2045 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
2046
2047 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
2048 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
2049
2050 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
2051 repDoE (MkC ss) = rep2 doEName [ss]
2052
2053 repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
2054 repMDoE (MkC ss) = rep2 mdoEName [ss]
2055
2056 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
2057 repComp (MkC ss) = rep2 compEName [ss]
2058
2059 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
2060 repListExp (MkC es) = rep2 listEName [es]
2061
2062 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
2063 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
2064
2065 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
2066 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
2067
2068 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
2069 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
2070
2071 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
2072 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
2073
2074 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2075 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
2076
2077 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2078 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
2079
2080 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2081 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
2082
2083 repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)
2084 repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
2085
2086 ------------ Right hand sides (guarded expressions) ----
2087 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
2088 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
2089
2090 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
2091 repNormal (MkC e) = rep2 normalBName [e]
2092
2093 ------------ Guards ----
2094 repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
2095 -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
2096 repLNormalGE g e = do g' <- repLE g
2097 e' <- repLE e
2098 repNormalGE g' e'
2099
2100 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
2101 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
2102
2103 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
2104 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
2105
2106 ------------- Stmts -------------------
2107 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
2108 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
2109
2110 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
2111 repLetSt (MkC ds) = rep2 letSName [ds]
2112
2113 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
2114 repNoBindSt (MkC e) = rep2 noBindSName [e]
2115
2116 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
2117 repParSt (MkC sss) = rep2 parSName [sss]
2118
2119 repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)
2120 repRecSt (MkC ss) = rep2 recSName [ss]
2121
2122 -------------- Range (Arithmetic sequences) -----------
2123 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
2124 repFrom (MkC x) = rep2 fromEName [x]
2125
2126 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2127 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
2128
2129 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2130 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
2131
2132 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2133 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
2134
2135 ------------ Match and Clause Tuples -----------
2136 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
2137 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
2138
2139 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
2140 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
2141
2142 -------------- Dec -----------------------------
2143 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
2144 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
2145
2146 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
2147 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
2148
2149 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
2150 -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
2151 -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
2152 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
2153 = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
2154 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
2155 (MkC derivs)
2156 = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]
2157
2158 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
2159 -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
2160 -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
2161 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
2162 (MkC derivs)
2163 = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
2164 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)
2165 (MkC derivs)
2166 = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]
2167
2168 repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
2169 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
2170 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
2171 = rep2 tySynDName [nm, tvs, rhs]
2172
2173 repInst :: Core (Maybe TH.Overlap) ->
2174 Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
2175 repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
2176 [o, cxt, ty, ds]
2177
2178 repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
2179 -> DsM (Core (Maybe TH.DerivStrategyQ))
2180 repDerivStrategy mds =
2181 case mds of
2182 Nothing -> nothing
2183 Just (L _ ds) ->
2184 case ds of
2185 StockStrategy -> just =<< repStockStrategy
2186 AnyclassStrategy -> just =<< repAnyclassStrategy
2187 NewtypeStrategy -> just =<< repNewtypeStrategy
2188 ViaStrategy ty -> do ty' <- repLTy (hsSigType ty)
2189 via_strat <- repViaStrategy ty'
2190 just via_strat
2191 where
2192 nothing = coreNothing derivStrategyQTyConName
2193 just = coreJust derivStrategyQTyConName
2194
2195 repStockStrategy :: DsM (Core TH.DerivStrategyQ)
2196 repStockStrategy = rep2 stockStrategyName []
2197
2198 repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ)
2199 repAnyclassStrategy = rep2 anyclassStrategyName []
2200
2201 repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ)
2202 repNewtypeStrategy = rep2 newtypeStrategyName []
2203
2204 repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ)
2205 repViaStrategy (MkC t) = rep2 viaStrategyName [t]
2206
2207 repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
2208 repOverlap mb =
2209 case mb of
2210 Nothing -> nothing
2211 Just o ->
2212 case o of
2213 NoOverlap _ -> nothing
2214 Overlappable _ -> just =<< dataCon overlappableDataConName
2215 Overlapping _ -> just =<< dataCon overlappingDataConName
2216 Overlaps _ -> just =<< dataCon overlapsDataConName
2217 Incoherent _ -> just =<< dataCon incoherentDataConName
2218 where
2219 nothing = coreNothing overlapTyConName
2220 just = coreJust overlapTyConName
2221
2222
2223 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
2224 -> Core [TH.FunDep] -> Core [TH.DecQ]
2225 -> DsM (Core TH.DecQ)
2226 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
2227 = rep2 classDName [cxt, cls, tvs, fds, ds]
2228
2229 repDeriv :: Core (Maybe TH.DerivStrategyQ)
2230 -> Core TH.CxtQ -> Core TH.TypeQ
2231 -> DsM (Core TH.DecQ)
2232 repDeriv (MkC ds) (MkC cxt) (MkC ty)
2233 = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
2234
2235 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
2236 -> Core TH.Phases -> DsM (Core TH.DecQ)
2237 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
2238 = rep2 pragInlDName [nm, inline, rm, phases]
2239
2240 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
2241 -> DsM (Core TH.DecQ)
2242 repPragSpec (MkC nm) (MkC ty) (MkC phases)
2243 = rep2 pragSpecDName [nm, ty, phases]
2244
2245 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
2246 -> Core TH.Phases -> DsM (Core TH.DecQ)
2247 repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
2248 = rep2 pragSpecInlDName [nm, ty, inline, phases]
2249
2250 repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
2251 repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
2252
2253 repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
2254 repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
2255
2256 repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
2257 -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
2258 repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
2259 = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
2260
2261 repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
2262 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
2263
2264 repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
2265 repTySynInst (MkC nm) (MkC eqn)
2266 = rep2 tySynInstDName [nm, eqn]
2267
2268 repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
2269 -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
2270 repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
2271 = rep2 dataFamilyDName [nm, tvs, kind]
2272
2273 repOpenFamilyD :: Core TH.Name
2274 -> Core [TH.TyVarBndrQ]
2275 -> Core TH.FamilyResultSigQ
2276 -> Core (Maybe TH.InjectivityAnn)
2277 -> DsM (Core TH.DecQ)
2278 repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
2279 = rep2 openTypeFamilyDName [nm, tvs, result, inj]
2280
2281 repClosedFamilyD :: Core TH.Name
2282 -> Core [TH.TyVarBndrQ]
2283 -> Core TH.FamilyResultSigQ
2284 -> Core (Maybe TH.InjectivityAnn)
2285 -> Core [TH.TySynEqnQ]
2286 -> DsM (Core TH.DecQ)
2287 repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
2288 = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
2289
2290 repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
2291 repTySynEqn (MkC lhs) (MkC rhs)
2292 = rep2 tySynEqnName [lhs, rhs]
2293
2294 repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
2295 repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
2296
2297 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
2298 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
2299
2300 repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
2301 repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
2302
2303 repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)
2304 repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
2305
2306 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
2307 repCtxt (MkC tys) = rep2 cxtName [tys]
2308
2309 repDataCon :: Located Name
2310 -> HsConDeclDetails GhcRn
2311 -> DsM (Core TH.ConQ)
2312 repDataCon con details
2313 = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
2314 repConstr details Nothing [con']
2315
2316 repGadtDataCons :: [Located Name]
2317 -> HsConDeclDetails GhcRn
2318 -> LHsType GhcRn
2319 -> DsM (Core TH.ConQ)
2320 repGadtDataCons cons details res_ty
2321 = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
2322 repConstr details (Just res_ty) cons'
2323
2324 -- Invariant:
2325 -- * for plain H98 data constructors second argument is Nothing and third
2326 -- argument is a singleton list
2327 -- * for GADTs data constructors second argument is (Just return_type) and
2328 -- third argument is a non-empty list
2329 repConstr :: HsConDeclDetails GhcRn
2330 -> Maybe (LHsType GhcRn)
2331 -> [Core TH.Name]
2332 -> DsM (Core TH.ConQ)
2333 repConstr (PrefixCon ps) Nothing [con]
2334 = do arg_tys <- repList bangTypeQTyConName repBangTy ps
2335 rep2 normalCName [unC con, unC arg_tys]
2336
2337 repConstr (PrefixCon ps) (Just (L _ res_ty)) cons
2338 = do arg_tys <- repList bangTypeQTyConName repBangTy ps
2339 res_ty' <- repTy res_ty
2340 rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
2341
2342 repConstr (RecCon (L _ ips)) resTy cons
2343 = do args <- concatMapM rep_ip ips
2344 arg_vtys <- coreList varBangTypeQTyConName args
2345 case resTy of
2346 Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
2347 Just (L _ res_ty) -> do
2348 res_ty' <- repTy res_ty
2349 rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
2350 unC res_ty']
2351
2352 where
2353 rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
2354
2355 rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
2356 rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n)
2357 ; MkC ty <- repBangTy t
2358 ; rep2 varBangTypeName [v,ty] }
2359
2360 repConstr (InfixCon st1 st2) Nothing [con]
2361 = do arg1 <- repBangTy st1
2362 arg2 <- repBangTy st2
2363 rep2 infixCName [unC arg1, unC con, unC arg2]
2364
2365 repConstr (InfixCon {}) (Just _) _ =
2366 panic "repConstr: infix GADT constructor should be in a PrefixCon"
2367 repConstr _ _ _ =
2368 panic "repConstr: invariant violated"
2369
2370 ------------ Types -------------------
2371
2372 repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ
2373 -> DsM (Core TH.TypeQ)
2374 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
2375 = rep2 forallTName [tvars, ctxt, ty]
2376
2377 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
2378 repTvar (MkC s) = rep2 varTName [s]
2379
2380 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
2381 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
2382
2383 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
2384 repTapps f [] = return f
2385 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
2386
2387 repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
2388 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
2389
2390 repTequality :: DsM (Core TH.TypeQ)
2391 repTequality = rep2 equalityTName []
2392
2393 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
2394 repTPromotedList [] = repPromotedNilTyCon
2395 repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
2396 ; f <- repTapp tcon t
2397 ; t' <- repTPromotedList ts
2398 ; repTapp f t'
2399 }
2400
2401 repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
2402 repTLit (MkC lit) = rep2 litTName [lit]
2403
2404 repTWildCard :: DsM (Core TH.TypeQ)
2405 repTWildCard = rep2 wildCardTName []
2406
2407 repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
2408 repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
2409
2410 repTStar :: DsM (Core TH.TypeQ)
2411 repTStar = rep2 starKName []
2412
2413 repTConstraint :: DsM (Core TH.TypeQ)
2414 repTConstraint = rep2 constraintKName []
2415
2416 --------- Type constructors --------------
2417
2418 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
2419 repNamedTyCon (MkC s) = rep2 conTName [s]
2420
2421 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2422 -- Note: not Core Int; it's easier to be direct here
2423 repTupleTyCon i = do dflags <- getDynFlags
2424 rep2 tupleTName [mkIntExprInt dflags i]
2425
2426 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2427 -- Note: not Core Int; it's easier to be direct here
2428 repUnboxedTupleTyCon i = do dflags <- getDynFlags
2429 rep2 unboxedTupleTName [mkIntExprInt dflags i]
2430
2431 repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
2432 -- Note: not Core TH.SumArity; it's easier to be direct here
2433 repUnboxedSumTyCon arity = do dflags <- getDynFlags
2434 rep2 unboxedSumTName [mkIntExprInt dflags arity]
2435
2436 repArrowTyCon :: DsM (Core TH.TypeQ)
2437 repArrowTyCon = rep2 arrowTName []
2438
2439 repListTyCon :: DsM (Core TH.TypeQ)
2440 repListTyCon = rep2 listTName []
2441
2442 repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)
2443 repPromotedDataCon (MkC s) = rep2 promotedTName [s]
2444
2445 repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2446 repPromotedTupleTyCon i = do dflags <- getDynFlags
2447 rep2 promotedTupleTName [mkIntExprInt dflags i]
2448
2449 repPromotedNilTyCon :: DsM (Core TH.TypeQ)
2450 repPromotedNilTyCon = rep2 promotedNilTName []
2451
2452 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
2453 repPromotedConsTyCon = rep2 promotedConsTName []
2454
2455 ------------ TyVarBndrs -------------------
2456
2457 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)
2458 repPlainTV (MkC nm) = rep2 plainTVName [nm]
2459
2460 repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)
2461 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
2462
2463 ----------------------------------------------------------
2464 -- Type family result signature
2465
2466 repNoSig :: DsM (Core TH.FamilyResultSigQ)
2467 repNoSig = rep2 noSigName []
2468
2469 repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)
2470 repKindSig (MkC ki) = rep2 kindSigName [ki]
2471
2472 repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)
2473 repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
2474
2475 ----------------------------------------------------------
2476 -- Literals
2477
2478 repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit)
2479 repLiteral (HsStringPrim _ bs)
2480 = do dflags <- getDynFlags
2481 word8_ty <- lookupType word8TyConName
2482 let w8s = unpack bs
2483 w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
2484 [mkWordLit dflags (toInteger w8)]) w8s
2485 rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
2486 repLiteral lit
2487 = do lit' <- case lit of
2488 HsIntPrim _ i -> mk_integer i
2489 HsWordPrim _ w -> mk_integer w
2490 HsInt _ i -> mk_integer (il_value i)
2491 HsFloatPrim _ r -> mk_rational r
2492 HsDoublePrim _ r -> mk_rational r
2493 HsCharPrim _ c -> mk_char c
2494 _ -> return lit
2495 lit_expr <- dsLit lit'
2496 case mb_lit_name of
2497 Just lit_name -> rep2 lit_name [lit_expr]
2498 Nothing -> notHandled "Exotic literal" (ppr lit)
2499 where
2500 mb_lit_name = case lit of
2501 HsInteger _ _ _ -> Just integerLName
2502 HsInt _ _ -> Just integerLName
2503 HsIntPrim _ _ -> Just intPrimLName
2504 HsWordPrim _ _ -> Just wordPrimLName
2505 HsFloatPrim _ _ -> Just floatPrimLName
2506 HsDoublePrim _ _ -> Just doublePrimLName
2507 HsChar _ _ -> Just charLName
2508 HsCharPrim _ _ -> Just charPrimLName
2509 HsString _ _ -> Just stringLName
2510 HsRat _ _ _ -> Just rationalLName
2511 _ -> Nothing
2512
2513 mk_integer :: Integer -> DsM (HsLit GhcRn)
2514 mk_integer i = do integer_ty <- lookupType integerTyConName
2515 return $ HsInteger NoSourceText i integer_ty
2516
2517 mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
2518 mk_rational r = do rat_ty <- lookupType rationalTyConName
2519 return $ HsRat noExt r rat_ty
2520 mk_string :: FastString -> DsM (HsLit GhcRn)
2521 mk_string s = return $ HsString NoSourceText s
2522
2523 mk_char :: Char -> DsM (HsLit GhcRn)
2524 mk_char c = return $ HsChar NoSourceText c
2525
2526 repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)
2527 repOverloadedLiteral (OverLit { ol_val = val})
2528 = do { lit <- mk_lit val; repLiteral lit }
2529 -- The type Rational will be in the environment, because
2530 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
2531 -- and rationalL is sucked in when any TH stuff is used
2532 repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"
2533
2534 mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
2535 mk_lit (HsIntegral i) = mk_integer (il_value i)
2536 mk_lit (HsFractional f) = mk_rational f
2537 mk_lit (HsIsString _ s) = mk_string s
2538
2539 repNameS :: Core String -> DsM (Core TH.Name)
2540 repNameS (MkC name) = rep2 mkNameSName [name]
2541
2542 --------------- Miscellaneous -------------------
2543
2544 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
2545 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
2546
2547 repBindQ :: Type -> Type -- a and b
2548 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
2549 repBindQ ty_a ty_b (MkC x) (MkC y)
2550 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
2551
2552 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
2553 repSequenceQ ty_a (MkC list)
2554 = rep2 sequenceQName [Type ty_a, list]
2555
2556 repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
2557 repUnboundVar (MkC name) = rep2 unboundVarEName [name]
2558
2559 repOverLabel :: FastString -> DsM (Core TH.ExpQ)
2560 repOverLabel fs = do
2561 (MkC s) <- coreStringLit $ unpackFS fs
2562 rep2 labelEName [s]
2563
2564
2565 ------------ Lists -------------------
2566 -- turn a list of patterns into a single pattern matching a list
2567
2568 repList :: Name -> (a -> DsM (Core b))
2569 -> [a] -> DsM (Core [b])
2570 repList tc_name f args
2571 = do { args1 <- mapM f args
2572 ; coreList tc_name args1 }
2573
2574 coreList :: Name -- Of the TyCon of the element type
2575 -> [Core a] -> DsM (Core [a])
2576 coreList tc_name es
2577 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
2578
2579 coreList' :: Type -- The element type
2580 -> [Core a] -> Core [a]
2581 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
2582
2583 nonEmptyCoreList :: [Core a] -> Core [a]
2584 -- The list must be non-empty so we can get the element type
2585 -- Otherwise use coreList
2586 nonEmptyCoreList [] = panic "coreList: empty argument"
2587 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
2588
2589 coreStringLit :: String -> DsM (Core String)
2590 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
2591
2592 ------------------- Maybe ------------------
2593
2594 -- | Construct Core expression for Nothing of a given type name
2595 coreNothing :: Name -- ^ Name of the TyCon of the element type
2596 -> DsM (Core (Maybe a))
2597 coreNothing tc_name =
2598 do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
2599
2600 -- | Construct Core expression for Nothing of a given type
2601 coreNothing' :: Type -- ^ The element type
2602 -> Core (Maybe a)
2603 coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
2604
2605 -- | Store given Core expression in a Just of a given type name
2606 coreJust :: Name -- ^ Name of the TyCon of the element type
2607 -> Core a -> DsM (Core (Maybe a))
2608 coreJust tc_name es
2609 = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
2610
2611 -- | Store given Core expression in a Just of a given type
2612 coreJust' :: Type -- ^ The element type
2613 -> Core a -> Core (Maybe a)
2614 coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
2615
2616 ------------ Literals & Variables -------------------
2617
2618 coreIntLit :: Int -> DsM (Core Int)
2619 coreIntLit i = do dflags <- getDynFlags
2620 return (MkC (mkIntExprInt dflags i))
2621
2622 coreVar :: Id -> Core TH.Name -- The Id has type Name
2623 coreVar id = MkC (Var id)
2624
2625 ----------------- Failure -----------------------
2626 notHandledL :: SrcSpan -> String -> SDoc -> DsM a
2627 notHandledL loc what doc
2628 | isGoodSrcSpan loc
2629 = putSrcSpanDs loc $ notHandled what doc
2630 | otherwise
2631 = notHandled what doc
2632
2633 notHandled :: String -> SDoc -> DsM a
2634 notHandled what doc = failWithDs msg
2635 where
2636 msg = hang (text what <+> text "not (yet) handled by Template Haskell")
2637 2 doc