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