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