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