More typos in comments [skip ci]
[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 quantified 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 rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc
741
742
743 rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
744 -> DsM (SrcSpan, Core TH.DecQ)
745 rep_ty_sig mk_sig loc sig_ty nm
746 = do { nm1 <- lookupLOcc nm
747 ; ty1 <- repHsSigType sig_ty
748 ; sig <- repProto mk_sig nm1 ty1
749 ; return (loc, sig) }
750
751 rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name
752 -> DsM (SrcSpan, Core TH.DecQ)
753 -- represents a pattern synonym type signature;
754 -- see Note [Pattern synonym type signatures and Template Haskell] in Convert
755 rep_patsyn_ty_sig loc sig_ty nm
756 = do { nm1 <- lookupLOcc nm
757 ; ty1 <- repHsPatSynSigType sig_ty
758 ; sig <- repProto patSynSigDName nm1 ty1
759 ; return (loc, sig) }
760
761 rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
762 -> DsM (SrcSpan, Core TH.DecQ)
763 -- We must special-case the top-level explicit for-all of a TypeSig
764 -- See Note [Scoped type variables in bindings]
765 rep_wc_ty_sig mk_sig loc sig_ty nm
766 | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty
767 , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
768 = do { nm1 <- lookupLOcc nm
769 ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
770 ; repTyVarBndrWithKind tv name }
771 ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv
772 explicit_tvs
773 -- NB: Don't pass any implicit type variables to repList above
774 -- See Note [Don't quantify implicit type variables in quotes]
775
776 ; th_ctxt <- repLContext ctxt
777 ; th_ty <- repLTy ty
778 ; ty1 <- if null explicit_tvs && null (unLoc ctxt)
779 then return th_ty
780 else repTForall th_explicit_tvs th_ctxt th_ty
781 ; sig <- repProto mk_sig nm1 ty1
782 ; return (loc, sig) }
783
784 rep_inline :: Located Name
785 -> InlinePragma -- Never defaultInlinePragma
786 -> SrcSpan
787 -> DsM [(SrcSpan, Core TH.DecQ)]
788 rep_inline nm ispec loc
789 = do { nm1 <- lookupLOcc nm
790 ; inline <- repInline $ inl_inline ispec
791 ; rm <- repRuleMatch $ inl_rule ispec
792 ; phases <- repPhases $ inl_act ispec
793 ; pragma <- repPragInl nm1 inline rm phases
794 ; return [(loc, pragma)]
795 }
796
797 rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan
798 -> DsM [(SrcSpan, Core TH.DecQ)]
799 rep_specialise nm ty ispec loc
800 = do { nm1 <- lookupLOcc nm
801 ; ty1 <- repHsSigType ty
802 ; phases <- repPhases $ inl_act ispec
803 ; let inline = inl_inline ispec
804 ; pragma <- if isEmptyInlineSpec inline
805 then -- SPECIALISE
806 repPragSpec nm1 ty1 phases
807 else -- SPECIALISE INLINE
808 do { inline1 <- repInline inline
809 ; repPragSpecInl nm1 ty1 inline1 phases }
810 ; return [(loc, pragma)]
811 }
812
813 rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
814 rep_specialiseInst ty loc
815 = do { ty1 <- repHsSigType ty
816 ; pragma <- repPragSpecInst ty1
817 ; return [(loc, pragma)] }
818
819 repInline :: InlineSpec -> DsM (Core TH.Inline)
820 repInline NoInline = dataCon noInlineDataConName
821 repInline Inline = dataCon inlineDataConName
822 repInline Inlinable = dataCon inlinableDataConName
823 repInline spec = notHandled "repInline" (ppr spec)
824
825 repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
826 repRuleMatch ConLike = dataCon conLikeDataConName
827 repRuleMatch FunLike = dataCon funLikeDataConName
828
829 repPhases :: Activation -> DsM (Core TH.Phases)
830 repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
831 ; dataCon' beforePhaseDataConName [arg] }
832 repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i
833 ; dataCon' fromPhaseDataConName [arg] }
834 repPhases _ = dataCon allPhasesDataConName
835
836 rep_complete_sig :: Located [Located Name]
837 -> Maybe (Located Name)
838 -> SrcSpan
839 -> DsM [(SrcSpan, Core TH.DecQ)]
840 rep_complete_sig (L _ cls) mty loc
841 = do { mty' <- rep_maybe_name mty
842 ; cls' <- repList nameTyConName lookupLOcc cls
843 ; sig <- repPragComplete cls' mty'
844 ; return [(loc, sig)] }
845 where
846 rep_maybe_name Nothing = coreNothing nameTyConName
847 rep_maybe_name (Just n) = do
848 cn <- lookupLOcc n
849 coreJust nameTyConName cn
850
851 -------------------------------------------------------
852 -- Types
853 -------------------------------------------------------
854
855 addSimpleTyVarBinds :: [Name] -- the binders to be added
856 -> DsM (Core (TH.Q a)) -- action in the ext env
857 -> DsM (Core (TH.Q a))
858 addSimpleTyVarBinds names thing_inside
859 = do { fresh_names <- mkGenSyms names
860 ; term <- addBinds fresh_names thing_inside
861 ; wrapGenSyms fresh_names term }
862
863 addTyVarBinds :: LHsQTyVars Name -- the binders to be added
864 -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
865 -> DsM (Core (TH.Q a))
866 -- gensym a list of type variables and enter them into the meta environment;
867 -- the computations passed as the second argument is executed in that extended
868 -- meta environment and gets the *new* names on Core-level as an argument
869
870 addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m
871 = do { fresh_imp_names <- mkGenSyms imp_tvs
872 ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
873 ; let fresh_names = fresh_imp_names ++ fresh_exp_names
874 ; term <- addBinds fresh_names $
875 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr
876 (exp_tvs `zip` fresh_exp_names)
877 ; m kbs }
878 ; wrapGenSyms fresh_names term }
879 where
880 mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
881
882 addTyClTyVarBinds :: LHsQTyVars Name
883 -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
884 -> DsM (Core (TH.Q a))
885
886 -- Used for data/newtype declarations, and family instances,
887 -- so that the nested type variables work right
888 -- instance C (T a) where
889 -- type W (T a) = blah
890 -- The 'a' in the type instance is the one bound by the instance decl
891 addTyClTyVarBinds tvs m
892 = do { let tv_names = hsAllLTyVarNames tvs
893 ; env <- dsGetMetaEnv
894 ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
895 -- Make fresh names for the ones that are not already in scope
896 -- This makes things work for family declarations
897
898 ; term <- addBinds freshNames $
899 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs)
900 ; m kbs }
901
902 ; wrapGenSyms freshNames term }
903 where
904 mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
905 ; repTyVarBndrWithKind tv v }
906
907 -- Produce kinded binder constructors from the Haskell tyvar binders
908 --
909 repTyVarBndrWithKind :: LHsTyVarBndr Name
910 -> Core TH.Name -> DsM (Core TH.TyVarBndr)
911 repTyVarBndrWithKind (L _ (UserTyVar _)) nm
912 = repPlainTV nm
913 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
914 = repLKind ki >>= repKindedTV nm
915
916 -- | Represent a type variable binder
917 repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)
918 repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
919 ; repPlainTV nm' }
920 repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
921 ; ki' <- repLKind ki
922 ; repKindedTV nm' ki' }
923
924 -- represent a type context
925 --
926 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
927 repLContext (L _ ctxt) = repContext ctxt
928
929 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
930 repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
931 repCtxt preds
932
933 repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
934 repHsSigType (HsIB { hsib_vars = implicit_tvs
935 , hsib_body = body })
936 | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
937 = addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs
938 , hsq_explicit = explicit_tvs
939 , hsq_dependent = emptyNameSet })
940 -- NB: Don't pass implicit_tvs to the hsq_explicit field above
941 -- See Note [Don't quantify implicit type variables in quotes]
942 $ \ th_explicit_tvs ->
943 do { th_ctxt <- repLContext ctxt
944 ; th_ty <- repLTy ty
945 ; if null explicit_tvs && null (unLoc ctxt)
946 then return th_ty
947 else repTForall th_explicit_tvs th_ctxt th_ty }
948
949 repHsPatSynSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
950 repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
951 , hsib_body = body })
952 = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs ->
953 addTyVarBinds (newTvs [] exis) $ \th_exis ->
954 do { th_reqs <- repLContext reqs
955 ; th_provs <- repLContext provs
956 ; th_ty <- repLTy ty
957 ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }
958 where
959 newTvs impl_tvs expl_tvs = HsQTvs
960 { hsq_implicit = impl_tvs
961 , hsq_explicit = expl_tvs
962 , hsq_dependent = emptyNameSet }
963 -- NB: Don't pass impl_tvs to the hsq_explicit field above
964 -- See Note [Don't quantify implicit type variables in quotes]
965
966 (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body
967
968 repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
969 repHsSigWcType (HsWC { hswc_body = sig1 })
970 = repHsSigType sig1
971
972 -- yield the representation of a list of types
973 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
974 repLTys tys = mapM repLTy tys
975
976 -- represent a type
977 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
978 repLTy (L _ ty) = repTy ty
979
980 repForall :: HsType Name -> DsM (Core TH.TypeQ)
981 -- Arg of repForall is always HsForAllTy or HsQualTy
982 repForall ty
983 | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
984 = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs
985 , hsq_dependent = emptyNameSet }) $ \bndrs ->
986 do { ctxt1 <- repLContext ctxt
987 ; ty1 <- repLTy tau
988 ; repTForall bndrs ctxt1 ty1 }
989
990 repTy :: HsType Name -> DsM (Core TH.TypeQ)
991 repTy ty@(HsForAllTy {}) = repForall ty
992 repTy ty@(HsQualTy {}) = repForall ty
993
994 repTy (HsTyVar _ (L _ n))
995 | isTvOcc occ = do tv1 <- lookupOcc n
996 repTvar tv1
997 | isDataOcc occ = do tc1 <- lookupOcc n
998 repPromotedDataCon tc1
999 | n == eqTyConName = repTequality
1000 | otherwise = do tc1 <- lookupOcc n
1001 repNamedTyCon tc1
1002 where
1003 occ = nameOccName n
1004
1005 repTy (HsAppTy f a) = do
1006 f1 <- repLTy f
1007 a1 <- repLTy a
1008 repTapp f1 a1
1009 repTy (HsFunTy f a) = do
1010 f1 <- repLTy f
1011 a1 <- repLTy a
1012 tcon <- repArrowTyCon
1013 repTapps tcon [f1, a1]
1014 repTy (HsListTy t) = do
1015 t1 <- repLTy t
1016 tcon <- repListTyCon
1017 repTapp tcon t1
1018 repTy (HsPArrTy t) = do
1019 t1 <- repLTy t
1020 tcon <- repTy (HsTyVar NotPromoted
1021 (noLoc (tyConName parrTyCon)))
1022 repTapp tcon t1
1023 repTy (HsTupleTy HsUnboxedTuple tys) = do
1024 tys1 <- repLTys tys
1025 tcon <- repUnboxedTupleTyCon (length tys)
1026 repTapps tcon tys1
1027 repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
1028 tcon <- repTupleTyCon (length tys)
1029 repTapps tcon tys1
1030 repTy (HsSumTy tys) = do tys1 <- repLTys tys
1031 tcon <- repUnboxedSumTyCon (length tys)
1032 repTapps tcon tys1
1033 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
1034 `nlHsAppTy` ty2)
1035 repTy (HsParTy t) = repLTy t
1036 repTy (HsEqTy t1 t2) = do
1037 t1' <- repLTy t1
1038 t2' <- repLTy t2
1039 eq <- repTequality
1040 repTapps eq [t1', t2']
1041 repTy (HsKindSig t k) = do
1042 t1 <- repLTy t
1043 k1 <- repLKind k
1044 repTSig t1 k1
1045 repTy (HsSpliceTy splice _) = repSplice splice
1046 repTy (HsExplicitListTy _ _ tys) = do
1047 tys1 <- repLTys tys
1048 repTPromotedList tys1
1049 repTy (HsExplicitTupleTy _ tys) = do
1050 tys1 <- repLTys tys
1051 tcon <- repPromotedTupleTyCon (length tys)
1052 repTapps tcon tys1
1053 repTy (HsTyLit lit) = do
1054 lit' <- repTyLit lit
1055 repTLit lit'
1056 repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
1057
1058 repTy ty = notHandled "Exotic form of type" (ppr ty)
1059
1060 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
1061 repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
1062 rep2 numTyLitName [iExpr]
1063 repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
1064 ; rep2 strTyLitName [s']
1065 }
1066
1067 -- represent a kind
1068 --
1069 repLKind :: LHsKind Name -> DsM (Core TH.Kind)
1070 repLKind ki
1071 = do { let (kis, ki') = splitHsFunType ki
1072 ; kis_rep <- mapM repLKind kis
1073 ; ki'_rep <- repNonArrowLKind ki'
1074 ; kcon <- repKArrow
1075 ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
1076 ; foldrM f ki'_rep kis_rep
1077 }
1078
1079 -- | Represent a kind wrapped in a Maybe
1080 repMaybeLKind :: Maybe (LHsKind Name)
1081 -> DsM (Core (Maybe TH.Kind))
1082 repMaybeLKind Nothing =
1083 do { coreNothing kindTyConName }
1084 repMaybeLKind (Just ki) =
1085 do { ki' <- repLKind ki
1086 ; coreJust kindTyConName ki' }
1087
1088 repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
1089 repNonArrowLKind (L _ ki) = repNonArrowKind ki
1090
1091 repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
1092 repNonArrowKind (HsTyVar _ (L _ name))
1093 | isLiftedTypeKindTyConName name = repKStar
1094 | name `hasKey` constraintKindTyConKey = repKConstraint
1095 | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar
1096 | otherwise = lookupOcc name >>= repKCon
1097 repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f
1098 ; a' <- repLKind a
1099 ; repKApp f' a'
1100 }
1101 repNonArrowKind (HsListTy k) = do { k' <- repLKind k
1102 ; kcon <- repKList
1103 ; repKApp kcon k'
1104 }
1105 repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks
1106 ; kcon <- repKTuple (length ks)
1107 ; repKApps kcon ks'
1108 }
1109 repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
1110
1111 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
1112 repRole (L _ (Just Nominal)) = rep2 nominalRName []
1113 repRole (L _ (Just Representational)) = rep2 representationalRName []
1114 repRole (L _ (Just Phantom)) = rep2 phantomRName []
1115 repRole (L _ Nothing) = rep2 inferRName []
1116
1117 -----------------------------------------------------------------------------
1118 -- Splices
1119 -----------------------------------------------------------------------------
1120
1121 repSplice :: HsSplice Name -> DsM (Core a)
1122 -- See Note [How brackets and nested splices are handled] in TcSplice
1123 -- We return a CoreExpr of any old type; the context should know
1124 repSplice (HsTypedSplice _ n _) = rep_splice n
1125 repSplice (HsUntypedSplice _ n _) = rep_splice n
1126 repSplice (HsQuasiQuote n _ _ _) = rep_splice n
1127 repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e)
1128
1129 rep_splice :: Name -> DsM (Core a)
1130 rep_splice splice_name
1131 = do { mb_val <- dsLookupMetaEnv splice_name
1132 ; case mb_val of
1133 Just (DsSplice e) -> do { e' <- dsExpr e
1134 ; return (MkC e') }
1135 _ -> pprPanic "HsSplice" (ppr splice_name) }
1136 -- Should not happen; statically checked
1137
1138 -----------------------------------------------------------------------------
1139 -- Expressions
1140 -----------------------------------------------------------------------------
1141
1142 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
1143 repLEs es = repList expQTyConName repLE es
1144
1145 -- FIXME: some of these panics should be converted into proper error messages
1146 -- unless we can make sure that constructs, which are plainly not
1147 -- supported in TH already lead to error messages at an earlier stage
1148 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
1149 repLE (L loc e) = putSrcSpanDs loc (repE e)
1150
1151 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
1152 repE (HsVar (L _ x)) =
1153 do { mb_val <- dsLookupMetaEnv x
1154 ; case mb_val of
1155 Nothing -> do { str <- globalVar x
1156 ; repVarOrCon x str }
1157 Just (DsBound y) -> repVarOrCon x (coreVar y)
1158 Just (DsSplice e) -> do { e' <- dsExpr e
1159 ; return (MkC e') } }
1160 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
1161 repE e@(HsOverLabel _) = notHandled "Overloaded labels" (ppr e)
1162
1163 repE e@(HsRecFld f) = case f of
1164 Unambiguous _ x -> repE (HsVar (noLoc x))
1165 Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
1166
1167 -- Remember, we're desugaring renamer output here, so
1168 -- HsOverlit can definitely occur
1169 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
1170 repE (HsLit l) = do { a <- repLiteral l; repLit a }
1171 repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m
1172 repE (HsLamCase (MG { mg_alts = L _ ms }))
1173 = do { ms' <- mapM repMatchTup ms
1174 ; core_ms <- coreList matchQTyConName ms'
1175 ; repLamCase core_ms }
1176 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
1177 repE (HsAppType e t) = do { a <- repLE e
1178 ; s <- repLTy (hswc_body t)
1179 ; repAppType a s }
1180
1181 repE (OpApp e1 op _ e2) =
1182 do { arg1 <- repLE e1;
1183 arg2 <- repLE e2;
1184 the_op <- repLE op ;
1185 repInfixApp arg1 the_op arg2 }
1186 repE (NegApp x _) = do
1187 a <- repLE x
1188 negateVar <- lookupOcc negateName >>= repVar
1189 negateVar `repApp` a
1190 repE (HsPar x) = repLE x
1191 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
1192 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
1193 repE (HsCase e (MG { mg_alts = L _ ms }))
1194 = do { arg <- repLE e
1195 ; ms2 <- mapM repMatchTup ms
1196 ; core_ms2 <- coreList matchQTyConName ms2
1197 ; repCaseE arg core_ms2 }
1198 repE (HsIf _ x y z) = do
1199 a <- repLE x
1200 b <- repLE y
1201 c <- repLE z
1202 repCond a b c
1203 repE (HsMultiIf _ alts)
1204 = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
1205 ; expr' <- repMultiIf (nonEmptyCoreList alts')
1206 ; wrapGenSyms (concat binds) expr' }
1207 repE (HsLet (L _ bs) e) = do { (ss,ds) <- repBinds bs
1208 ; e2 <- addBinds ss (repLE e)
1209 ; z <- repLetE ds e2
1210 ; wrapGenSyms ss z }
1211
1212 -- FIXME: I haven't got the types here right yet
1213 repE e@(HsDo ctxt (L _ sts) _)
1214 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
1215 = do { (ss,zs) <- repLSts sts;
1216 e' <- repDoE (nonEmptyCoreList zs);
1217 wrapGenSyms ss e' }
1218
1219 | ListComp <- ctxt
1220 = do { (ss,zs) <- repLSts sts;
1221 e' <- repComp (nonEmptyCoreList zs);
1222 wrapGenSyms ss e' }
1223
1224 | otherwise
1225 = notHandled "mdo, monad comprehension and [: :]" (ppr e)
1226
1227 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
1228 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
1229 repE e@(ExplicitTuple es boxed)
1230 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
1231 | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
1232 | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
1233 ; repUnboxedTup xs }
1234
1235 repE (ExplicitSum alt arity e _)
1236 = do { e1 <- repLE e
1237 ; repUnboxedSum e1 alt arity }
1238
1239 repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
1240 = do { x <- lookupLOcc c;
1241 fs <- repFields flds;
1242 repRecCon x fs }
1243 repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
1244 = do { x <- repLE e;
1245 fs <- repUpdFields flds;
1246 repRecUpd x fs }
1247
1248 repE (ExprWithTySig e ty)
1249 = do { e1 <- repLE e
1250 ; t1 <- repHsSigWcType ty
1251 ; repSigExp e1 t1 }
1252
1253 repE (ArithSeq _ _ aseq) =
1254 case aseq of
1255 From e -> do { ds1 <- repLE e; repFrom ds1 }
1256 FromThen e1 e2 -> do
1257 ds1 <- repLE e1
1258 ds2 <- repLE e2
1259 repFromThen ds1 ds2
1260 FromTo e1 e2 -> do
1261 ds1 <- repLE e1
1262 ds2 <- repLE e2
1263 repFromTo ds1 ds2
1264 FromThenTo e1 e2 e3 -> do
1265 ds1 <- repLE e1
1266 ds2 <- repLE e2
1267 ds3 <- repLE e3
1268 repFromThenTo ds1 ds2 ds3
1269
1270 repE (HsSpliceE splice) = repSplice splice
1271 repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC
1272 repE (HsUnboundVar uv) = do
1273 occ <- occNameLit (unboundVarOcc uv)
1274 sname <- repNameS occ
1275 repUnboundVar sname
1276
1277 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
1278 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
1279 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
1280 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
1281 repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
1282 repE e = notHandled "Expression form" (ppr e)
1283
1284 -----------------------------------------------------------------------------
1285 -- Building representations of auxillary structures like Match, Clause, Stmt,
1286
1287 repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
1288 repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) =
1289 do { ss1 <- mkGenSyms (collectPatBinders p)
1290 ; addBinds ss1 $ do {
1291 ; p1 <- repLP p
1292 ; (ss2,ds) <- repBinds wheres
1293 ; addBinds ss2 $ do {
1294 ; gs <- repGuards guards
1295 ; match <- repMatch p1 gs ds
1296 ; wrapGenSyms (ss1++ss2) match }}}
1297 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
1298
1299 repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
1300 repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) =
1301 do { ss1 <- mkGenSyms (collectPatsBinders ps)
1302 ; addBinds ss1 $ do {
1303 ps1 <- repLPs ps
1304 ; (ss2,ds) <- repBinds wheres
1305 ; addBinds ss2 $ do {
1306 gs <- repGuards guards
1307 ; clause <- repClause ps1 gs ds
1308 ; wrapGenSyms (ss1++ss2) clause }}}
1309
1310 repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ)
1311 repGuards [L _ (GRHS [] e)]
1312 = do {a <- repLE e; repNormal a }
1313 repGuards other
1314 = do { zs <- mapM repLGRHS other
1315 ; let (xs, ys) = unzip zs
1316 ; gd <- repGuarded (nonEmptyCoreList ys)
1317 ; wrapGenSyms (concat xs) gd }
1318
1319 repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
1320 repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))
1321 = do { guarded <- repLNormalGE e1 e2
1322 ; return ([], guarded) }
1323 repLGRHS (L _ (GRHS ss rhs))
1324 = do { (gs, ss') <- repLSts ss
1325 ; rhs' <- addBinds gs $ repLE rhs
1326 ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
1327 ; return (gs, guarded) }
1328
1329 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
1330 repFields (HsRecFields { rec_flds = flds })
1331 = repList fieldExpQTyConName rep_fld flds
1332 where
1333 rep_fld :: LHsRecField Name (LHsExpr Name) -> DsM (Core (TH.Q TH.FieldExp))
1334 rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
1335 ; e <- repLE (hsRecFieldArg fld)
1336 ; repFieldExp fn e }
1337
1338 repUpdFields :: [LHsRecUpdField Name] -> DsM (Core [TH.Q TH.FieldExp])
1339 repUpdFields = repList fieldExpQTyConName rep_fld
1340 where
1341 rep_fld :: LHsRecUpdField Name -> DsM (Core (TH.Q TH.FieldExp))
1342 rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
1343 Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)
1344 ; e <- repLE (hsRecFieldArg fld)
1345 ; repFieldExp fn e }
1346 _ -> notHandled "Ambiguous record updates" (ppr fld)
1347
1348
1349
1350 -----------------------------------------------------------------------------
1351 -- Representing Stmt's is tricky, especially if bound variables
1352 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
1353 -- First gensym new names for every variable in any of the patterns.
1354 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
1355 -- if variables didn't shaddow, the static gensym wouldn't be necessary
1356 -- and we could reuse the original names (x and x).
1357 --
1358 -- do { x'1 <- gensym "x"
1359 -- ; x'2 <- gensym "x"
1360 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
1361 -- , BindSt (pvar x'2) [| f x |]
1362 -- , NoBindSt [| g x |]
1363 -- ]
1364 -- }
1365
1366 -- The strategy is to translate a whole list of do-bindings by building a
1367 -- bigger environment, and a bigger set of meta bindings
1368 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
1369 -- of the expressions within the Do
1370
1371 -----------------------------------------------------------------------------
1372 -- The helper function repSts computes the translation of each sub expression
1373 -- and a bunch of prefix bindings denoting the dynamic renaming.
1374
1375 repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1376 repLSts stmts = repSts (map unLoc stmts)
1377
1378 repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1379 repSts (BindStmt p e _ _ _ : ss) =
1380 do { e2 <- repLE e
1381 ; ss1 <- mkGenSyms (collectPatBinders p)
1382 ; addBinds ss1 $ do {
1383 ; p1 <- repLP p;
1384 ; (ss2,zs) <- repSts ss
1385 ; z <- repBindSt p1 e2
1386 ; return (ss1++ss2, z : zs) }}
1387 repSts (LetStmt (L _ bs) : ss) =
1388 do { (ss1,ds) <- repBinds bs
1389 ; z <- repLetSt ds
1390 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1391 ; return (ss1++ss2, z : zs) }
1392 repSts (BodyStmt e _ _ _ : ss) =
1393 do { e2 <- repLE e
1394 ; z <- repNoBindSt e2
1395 ; (ss2,zs) <- repSts ss
1396 ; return (ss2, z : zs) }
1397 repSts (ParStmt stmt_blocks _ _ _ : ss) =
1398 do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
1399 ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
1400 ss1 = concat ss_s
1401 ; z <- repParSt stmt_blocks2
1402 ; (ss2, zs) <- addBinds ss1 (repSts ss)
1403 ; return (ss1++ss2, z : zs) }
1404 where
1405 rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ])
1406 rep_stmt_block (ParStmtBlock stmts _ _) =
1407 do { (ss1, zs) <- repSts (map unLoc stmts)
1408 ; zs1 <- coreList stmtQTyConName zs
1409 ; return (ss1, zs1) }
1410 repSts [LastStmt e _ _]
1411 = do { e2 <- repLE e
1412 ; z <- repNoBindSt e2
1413 ; return ([], [z]) }
1414 repSts [] = return ([],[])
1415 repSts other = notHandled "Exotic statement" (ppr other)
1416
1417
1418 -----------------------------------------------------------
1419 -- Bindings
1420 -----------------------------------------------------------
1421
1422 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
1423 repBinds EmptyLocalBinds
1424 = do { core_list <- coreList decQTyConName []
1425 ; return ([], core_list) }
1426
1427 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
1428
1429 repBinds (HsValBinds decs)
1430 = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
1431 -- No need to worry about detailed scopes within
1432 -- the binding group, because we are talking Names
1433 -- here, so we can safely treat it as a mutually
1434 -- recursive group
1435 -- For hsSigTvBinders see Note [Scoped type variables in bindings]
1436 ; ss <- mkGenSyms bndrs
1437 ; prs <- addBinds ss (rep_val_binds decs)
1438 ; core_list <- coreList decQTyConName
1439 (de_loc (sort_by_loc prs))
1440 ; return (ss, core_list) }
1441
1442 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1443 -- Assumes: all the binders of the binding are already in the meta-env
1444 rep_val_binds (ValBindsOut binds sigs)
1445 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
1446 ; core2 <- rep_sigs' sigs
1447 ; return (core1 ++ core2) }
1448 rep_val_binds (ValBindsIn _ _)
1449 = panic "rep_val_binds: ValBindsIn"
1450
1451 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
1452 rep_binds binds = do { binds_w_locs <- rep_binds' binds
1453 ; return (de_loc (sort_by_loc binds_w_locs)) }
1454
1455 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1456 rep_binds' = mapM rep_bind . bagToList
1457
1458 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
1459 -- Assumes: all the binders of the binding are already in the meta-env
1460
1461 -- Note GHC treats declarations of a variable (not a pattern)
1462 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1463 -- with an empty list of patterns
1464 rep_bind (L loc (FunBind
1465 { fun_id = fn,
1466 fun_matches = MG { mg_alts
1467 = L _ [L _ (Match _ [] _
1468 (GRHSs guards (L _ wheres)))] } }))
1469 = do { (ss,wherecore) <- repBinds wheres
1470 ; guardcore <- addBinds ss (repGuards guards)
1471 ; fn' <- lookupLBinder fn
1472 ; p <- repPvar fn'
1473 ; ans <- repVal p guardcore wherecore
1474 ; ans' <- wrapGenSyms ss ans
1475 ; return (loc, ans') }
1476
1477 rep_bind (L loc (FunBind { fun_id = fn
1478 , fun_matches = MG { mg_alts = L _ ms } }))
1479 = do { ms1 <- mapM repClauseTup ms
1480 ; fn' <- lookupLBinder fn
1481 ; ans <- repFun fn' (nonEmptyCoreList ms1)
1482 ; return (loc, ans) }
1483
1484 rep_bind (L loc (PatBind { pat_lhs = pat
1485 , pat_rhs = GRHSs guards (L _ wheres) }))
1486 = do { patcore <- repLP pat
1487 ; (ss,wherecore) <- repBinds wheres
1488 ; guardcore <- addBinds ss (repGuards guards)
1489 ; ans <- repVal patcore guardcore wherecore
1490 ; ans' <- wrapGenSyms ss ans
1491 ; return (loc, ans') }
1492
1493 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1494 = do { v' <- lookupBinder v
1495 ; e2 <- repLE e
1496 ; x <- repNormal e2
1497 ; patcore <- repPvar v'
1498 ; empty_decls <- coreList decQTyConName []
1499 ; ans <- repVal patcore x empty_decls
1500 ; return (srcLocSpan (getSrcLoc v), ans) }
1501
1502 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1503 rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig"
1504 rep_bind (L loc (PatSynBind (PSB { psb_id = syn
1505 , psb_fvs = _fvs
1506 , psb_args = args
1507 , psb_def = pat
1508 , psb_dir = dir })))
1509 = do { syn' <- lookupLBinder syn
1510 ; dir' <- repPatSynDir dir
1511 ; ss <- mkGenArgSyms args
1512 ; patSynD' <- addBinds ss (
1513 do { args' <- repPatSynArgs args
1514 ; pat' <- repLP pat
1515 ; repPatSynD syn' args' dir' pat' })
1516 ; patSynD'' <- wrapGenArgSyms args ss patSynD'
1517 ; return (loc, patSynD'') }
1518 where
1519 mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]
1520 -- for Record Pattern Synonyms we want to conflate the selector
1521 -- and the pattern-only names in order to provide a nicer TH
1522 -- API. Whereas inside GHC, record pattern synonym selectors and
1523 -- their pattern-only bound right hand sides have different names,
1524 -- we want to treat them the same in TH. This is the reason why we
1525 -- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below.
1526 mkGenArgSyms (PrefixPatSyn args) = mkGenSyms (map unLoc args)
1527 mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
1528 mkGenArgSyms (RecordPatSyn fields)
1529 = do { let pats = map (unLoc . recordPatSynPatVar) fields
1530 sels = map (unLoc . recordPatSynSelectorId) fields
1531 ; ss <- mkGenSyms sels
1532 ; return $ replaceNames (zip sels pats) ss }
1533
1534 replaceNames selsPats genSyms
1535 = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
1536 , sel == sel' ]
1537
1538 wrapGenArgSyms :: HsPatSynDetails (Located Name)
1539 -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
1540 wrapGenArgSyms (RecordPatSyn _) _ dec = return dec
1541 wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
1542
1543 repPatSynD :: Core TH.Name
1544 -> Core TH.PatSynArgsQ
1545 -> Core TH.PatSynDirQ
1546 -> Core TH.PatQ
1547 -> DsM (Core TH.DecQ)
1548 repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
1549 = rep2 patSynDName [syn, args, dir, pat]
1550
1551 repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
1552 repPatSynArgs (PrefixPatSyn args)
1553 = do { args' <- repList nameTyConName lookupLOcc args
1554 ; repPrefixPatSynArgs args' }
1555 repPatSynArgs (InfixPatSyn arg1 arg2)
1556 = do { arg1' <- lookupLOcc arg1
1557 ; arg2' <- lookupLOcc arg2
1558 ; repInfixPatSynArgs arg1' arg2' }
1559 repPatSynArgs (RecordPatSyn fields)
1560 = do { sels' <- repList nameTyConName lookupLOcc sels
1561 ; repRecordPatSynArgs sels' }
1562 where sels = map recordPatSynSelectorId fields
1563
1564 repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)
1565 repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
1566
1567 repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)
1568 repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
1569
1570 repRecordPatSynArgs :: Core [TH.Name]
1571 -> DsM (Core TH.PatSynArgsQ)
1572 repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
1573
1574 repPatSynDir :: HsPatSynDir Name -> DsM (Core TH.PatSynDirQ)
1575 repPatSynDir Unidirectional = rep2 unidirPatSynName []
1576 repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
1577 repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))
1578 = do { clauses' <- mapM repClauseTup clauses
1579 ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
1580
1581 repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
1582 repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
1583
1584
1585 -----------------------------------------------------------------------------
1586 -- Since everything in a Bind is mutually recursive we need rename all
1587 -- all the variables simultaneously. For example:
1588 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1589 -- do { f'1 <- gensym "f"
1590 -- ; g'2 <- gensym "g"
1591 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1592 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1593 -- ]}
1594 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1595 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1596 -- together. As we do this we collect GenSymBinds's which represent the renamed
1597 -- variables bound by the Bindings. In order not to lose track of these
1598 -- representations we build a shadow datatype MB with the same structure as
1599 -- MonoBinds, but which has slots for the representations
1600
1601
1602 -----------------------------------------------------------------------------
1603 -- GHC allows a more general form of lambda abstraction than specified
1604 -- by Haskell 98. In particular it allows guarded lambda's like :
1605 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1606 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1607 -- (\ p1 .. pn -> exp) by causing an error.
1608
1609 repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)
1610 repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds))))
1611 = do { let bndrs = collectPatsBinders ps ;
1612 ; ss <- mkGenSyms bndrs
1613 ; lam <- addBinds ss (
1614 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1615 ; wrapGenSyms ss lam }
1616
1617 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m)
1618
1619
1620 -----------------------------------------------------------------------------
1621 -- Patterns
1622 -- repP deals with patterns. It assumes that we have already
1623 -- walked over the pattern(s) once to collect the binders, and
1624 -- have extended the environment. So every pattern-bound
1625 -- variable should already appear in the environment.
1626
1627 -- Process a list of patterns
1628 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1629 repLPs ps = repList patQTyConName repLP ps
1630
1631 repLP :: LPat Name -> DsM (Core TH.PatQ)
1632 repLP (L _ p) = repP p
1633
1634 repP :: Pat Name -> DsM (Core TH.PatQ)
1635 repP (WildPat _) = repPwild
1636 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1637 repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
1638 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1639 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1640 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1641 repP (ParPat p) = repLP p
1642 repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
1643 repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p}
1644 repP (TuplePat ps boxed _)
1645 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1646 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1647 repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity }
1648 repP (ConPatIn dc details)
1649 = do { con_str <- lookupLOcc dc
1650 ; case details of
1651 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1652 RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
1653 ; repPrec con_str fps }
1654 InfixCon p1 p2 -> do { p1' <- repLP p1;
1655 p2' <- repLP p2;
1656 repPinfix p1' con_str p2' }
1657 }
1658 where
1659 rep_fld :: LHsRecField Name (LPat Name) -> DsM (Core (TH.Name,TH.PatQ))
1660 rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
1661 ; MkC p <- repLP (hsRecFieldArg fld)
1662 ; rep2 fieldPatName [v,p] }
1663
1664 repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
1665 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1666 repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
1667 repP (SigPatIn p t) = do { p' <- repLP p
1668 ; t' <- repLTy (hsSigWcType t)
1669 ; repPsig p' t' }
1670 repP (SplicePat splice) = repSplice splice
1671
1672 repP other = notHandled "Exotic pattern" (ppr other)
1673
1674 ----------------------------------------------------------
1675 -- Declaration ordering helpers
1676
1677 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1678 sort_by_loc xs = sortBy comp xs
1679 where comp x y = compare (fst x) (fst y)
1680
1681 de_loc :: [(a, b)] -> [b]
1682 de_loc = map snd
1683
1684 ----------------------------------------------------------
1685 -- The meta-environment
1686
1687 -- A name/identifier association for fresh names of locally bound entities
1688 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1689 -- I.e. (x, x_id) means
1690 -- let x_id = gensym "x" in ...
1691
1692 -- Generate a fresh name for a locally bound entity
1693
1694 mkGenSyms :: [Name] -> DsM [GenSymBind]
1695 -- We can use the existing name. For example:
1696 -- [| \x_77 -> x_77 + x_77 |]
1697 -- desugars to
1698 -- do { x_77 <- genSym "x"; .... }
1699 -- We use the same x_77 in the desugared program, but with the type Bndr
1700 -- instead of Int
1701 --
1702 -- We do make it an Internal name, though (hence localiseName)
1703 --
1704 -- Nevertheless, it's monadic because we have to generate nameTy
1705 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1706 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1707
1708
1709 addBinds :: [GenSymBind] -> DsM a -> DsM a
1710 -- Add a list of fresh names for locally bound entities to the
1711 -- meta environment (which is part of the state carried around
1712 -- by the desugarer monad)
1713 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
1714
1715 -- Look up a locally bound name
1716 --
1717 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1718 lookupLBinder (L _ n) = lookupBinder n
1719
1720 lookupBinder :: Name -> DsM (Core TH.Name)
1721 lookupBinder = lookupOcc
1722 -- Binders are brought into scope before the pattern or what-not is
1723 -- desugared. Moreover, in instance declaration the binder of a method
1724 -- will be the selector Id and hence a global; so we need the
1725 -- globalVar case of lookupOcc
1726
1727 -- Look up a name that is either locally bound or a global name
1728 --
1729 -- * If it is a global name, generate the "original name" representation (ie,
1730 -- the <module>:<name> form) for the associated entity
1731 --
1732 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1733 -- Lookup an occurrence; it can't be a splice.
1734 -- Use the in-scope bindings if they exist
1735 lookupLOcc (L _ n) = lookupOcc n
1736
1737 lookupOcc :: Name -> DsM (Core TH.Name)
1738 lookupOcc n
1739 = do { mb_val <- dsLookupMetaEnv n ;
1740 case mb_val of
1741 Nothing -> globalVar n
1742 Just (DsBound x) -> return (coreVar x)
1743 Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
1744 }
1745
1746 globalVar :: Name -> DsM (Core TH.Name)
1747 -- Not bound by the meta-env
1748 -- Could be top-level; or could be local
1749 -- f x = $(g [| x |])
1750 -- Here the x will be local
1751 globalVar name
1752 | isExternalName name
1753 = do { MkC mod <- coreStringLit name_mod
1754 ; MkC pkg <- coreStringLit name_pkg
1755 ; MkC occ <- nameLit name
1756 ; rep2 mk_varg [pkg,mod,occ] }
1757 | otherwise
1758 = do { MkC occ <- nameLit name
1759 ; MkC uni <- coreIntLit (getKey (getUnique name))
1760 ; rep2 mkNameLName [occ,uni] }
1761 where
1762 mod = ASSERT( isExternalName name) nameModule name
1763 name_mod = moduleNameString (moduleName mod)
1764 name_pkg = unitIdString (moduleUnitId mod)
1765 name_occ = nameOccName name
1766 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1767 | OccName.isVarOcc name_occ = mkNameG_vName
1768 | OccName.isTcOcc name_occ = mkNameG_tcName
1769 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1770
1771 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1772 -> DsM Type -- The type
1773 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1774 return (mkTyConApp tc []) }
1775
1776 wrapGenSyms :: [GenSymBind]
1777 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1778 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1779 -- --> bindQ (gensym nm1) (\ id1 ->
1780 -- bindQ (gensym nm2 (\ id2 ->
1781 -- y))
1782
1783 wrapGenSyms binds body@(MkC b)
1784 = do { var_ty <- lookupType nameTyConName
1785 ; go var_ty binds }
1786 where
1787 [elt_ty] = tcTyConAppArgs (exprType b)
1788 -- b :: Q a, so we can get the type 'a' by looking at the
1789 -- argument type. NB: this relies on Q being a data/newtype,
1790 -- not a type synonym
1791
1792 go _ [] = return body
1793 go var_ty ((name,id) : binds)
1794 = do { MkC body' <- go var_ty binds
1795 ; lit_str <- nameLit name
1796 ; gensym_app <- repGensym lit_str
1797 ; repBindQ var_ty elt_ty
1798 gensym_app (MkC (Lam id body')) }
1799
1800 nameLit :: Name -> DsM (Core String)
1801 nameLit n = coreStringLit (occNameString (nameOccName n))
1802
1803 occNameLit :: OccName -> DsM (Core String)
1804 occNameLit name = coreStringLit (occNameString name)
1805
1806
1807 -- %*********************************************************************
1808 -- %* *
1809 -- Constructing code
1810 -- %* *
1811 -- %*********************************************************************
1812
1813 -----------------------------------------------------------------------------
1814 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1815 -- we invent a new datatype which uses phantom types.
1816
1817 newtype Core a = MkC CoreExpr
1818 unC :: Core a -> CoreExpr
1819 unC (MkC x) = x
1820
1821 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1822 rep2 n xs = do { id <- dsLookupGlobalId n
1823 ; return (MkC (foldl App (Var id) xs)) }
1824
1825 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
1826 dataCon' n args = do { id <- dsLookupDataCon n
1827 ; return $ MkC $ mkCoreConApps id args }
1828
1829 dataCon :: Name -> DsM (Core a)
1830 dataCon n = dataCon' n []
1831
1832
1833 -- %*********************************************************************
1834 -- %* *
1835 -- The 'smart constructors'
1836 -- %* *
1837 -- %*********************************************************************
1838
1839 --------------- Patterns -----------------
1840 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1841 repPlit (MkC l) = rep2 litPName [l]
1842
1843 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1844 repPvar (MkC s) = rep2 varPName [s]
1845
1846 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1847 repPtup (MkC ps) = rep2 tupPName [ps]
1848
1849 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1850 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1851
1852 repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
1853 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
1854 repPunboxedSum (MkC p) alt arity
1855 = do { dflags <- getDynFlags
1856 ; rep2 unboxedSumPName [ p
1857 , mkIntExprInt dflags alt
1858 , mkIntExprInt dflags arity ] }
1859
1860 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1861 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1862
1863 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1864 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1865
1866 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1867 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1868
1869 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1870 repPtilde (MkC p) = rep2 tildePName [p]
1871
1872 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1873 repPbang (MkC p) = rep2 bangPName [p]
1874
1875 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1876 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1877
1878 repPwild :: DsM (Core TH.PatQ)
1879 repPwild = rep2 wildPName []
1880
1881 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1882 repPlist (MkC ps) = rep2 listPName [ps]
1883
1884 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1885 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1886
1887 repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1888 repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1889
1890 --------------- Expressions -----------------
1891 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1892 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1893 | otherwise = repVar str
1894
1895 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1896 repVar (MkC s) = rep2 varEName [s]
1897
1898 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1899 repCon (MkC s) = rep2 conEName [s]
1900
1901 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1902 repLit (MkC c) = rep2 litEName [c]
1903
1904 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1905 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1906
1907 repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1908 repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
1909
1910 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1911 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1912
1913 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
1914 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
1915
1916 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1917 repTup (MkC es) = rep2 tupEName [es]
1918
1919 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1920 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
1921
1922 repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
1923 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
1924 repUnboxedSum (MkC e) alt arity
1925 = do { dflags <- getDynFlags
1926 ; rep2 unboxedSumEName [ e
1927 , mkIntExprInt dflags alt
1928 , mkIntExprInt dflags arity ] }
1929
1930 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1931 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1932
1933 repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
1934 repMultiIf (MkC alts) = rep2 multiIfEName [alts]
1935
1936 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1937 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1938
1939 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1940 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1941
1942 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1943 repDoE (MkC ss) = rep2 doEName [ss]
1944
1945 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1946 repComp (MkC ss) = rep2 compEName [ss]
1947
1948 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1949 repListExp (MkC es) = rep2 listEName [es]
1950
1951 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1952 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1953
1954 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1955 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1956
1957 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1958 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1959
1960 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1961 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1962
1963 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1964 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1965
1966 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1967 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1968
1969 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1970 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1971
1972 ------------ Right hand sides (guarded expressions) ----
1973 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1974 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1975
1976 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1977 repNormal (MkC e) = rep2 normalBName [e]
1978
1979 ------------ Guards ----
1980 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1981 repLNormalGE g e = do g' <- repLE g
1982 e' <- repLE e
1983 repNormalGE g' e'
1984
1985 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1986 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1987
1988 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1989 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1990
1991 ------------- Stmts -------------------
1992 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1993 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1994
1995 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1996 repLetSt (MkC ds) = rep2 letSName [ds]
1997
1998 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1999 repNoBindSt (MkC e) = rep2 noBindSName [e]
2000
2001 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
2002 repParSt (MkC sss) = rep2 parSName [sss]
2003
2004 -------------- Range (Arithmetic sequences) -----------
2005 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
2006 repFrom (MkC x) = rep2 fromEName [x]
2007
2008 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2009 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
2010
2011 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2012 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
2013
2014 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2015 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
2016
2017 ------------ Match and Clause Tuples -----------
2018 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
2019 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
2020
2021 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
2022 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
2023
2024 -------------- Dec -----------------------------
2025 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
2026 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
2027
2028 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
2029 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
2030
2031 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
2032 -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
2033 -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
2034 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
2035 = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
2036 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
2037 (MkC derivs)
2038 = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]
2039
2040 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
2041 -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
2042 -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
2043 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
2044 (MkC derivs)
2045 = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
2046 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)
2047 (MkC derivs)
2048 = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]
2049
2050 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
2051 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
2052 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
2053 = rep2 tySynDName [nm, tvs, rhs]
2054
2055 repInst :: Core (Maybe TH.Overlap) ->
2056 Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
2057 repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
2058 [o, cxt, ty, ds]
2059
2060 repDerivStrategy :: Maybe (Located DerivStrategy)
2061 -> DsM (Core (Maybe TH.DerivStrategy))
2062 repDerivStrategy mds =
2063 case mds of
2064 Nothing -> nothing
2065 Just (L _ ds) ->
2066 case ds of
2067 StockStrategy -> just =<< dataCon stockStrategyDataConName
2068 AnyclassStrategy -> just =<< dataCon anyclassStrategyDataConName
2069 NewtypeStrategy -> just =<< dataCon newtypeStrategyDataConName
2070 where
2071 nothing = coreNothing derivStrategyTyConName
2072 just = coreJust derivStrategyTyConName
2073
2074 repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
2075 repOverlap mb =
2076 case mb of
2077 Nothing -> nothing
2078 Just o ->
2079 case o of
2080 NoOverlap _ -> nothing
2081 Overlappable _ -> just =<< dataCon overlappableDataConName
2082 Overlapping _ -> just =<< dataCon overlappingDataConName
2083 Overlaps _ -> just =<< dataCon overlapsDataConName
2084 Incoherent _ -> just =<< dataCon incoherentDataConName
2085 where
2086 nothing = coreNothing overlapTyConName
2087 just = coreJust overlapTyConName
2088
2089
2090 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
2091 -> Core [TH.FunDep] -> Core [TH.DecQ]
2092 -> DsM (Core TH.DecQ)
2093 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
2094 = rep2 classDName [cxt, cls, tvs, fds, ds]
2095
2096 repDeriv :: Core (Maybe TH.DerivStrategy)
2097 -> Core TH.CxtQ -> Core TH.TypeQ
2098 -> DsM (Core TH.DecQ)
2099 repDeriv (MkC ds) (MkC cxt) (MkC ty)
2100 = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
2101
2102 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
2103 -> Core TH.Phases -> DsM (Core TH.DecQ)
2104 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
2105 = rep2 pragInlDName [nm, inline, rm, phases]
2106
2107 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
2108 -> DsM (Core TH.DecQ)
2109 repPragSpec (MkC nm) (MkC ty) (MkC phases)
2110 = rep2 pragSpecDName [nm, ty, phases]
2111
2112 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
2113 -> Core TH.Phases -> DsM (Core TH.DecQ)
2114 repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
2115 = rep2 pragSpecInlDName [nm, ty, inline, phases]
2116
2117 repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
2118 repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
2119
2120 repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
2121 repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
2122
2123 repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
2124 -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
2125 repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
2126 = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
2127
2128 repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
2129 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
2130
2131 repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
2132 repTySynInst (MkC nm) (MkC eqn)
2133 = rep2 tySynInstDName [nm, eqn]
2134
2135 repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr]
2136 -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ)
2137 repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
2138 = rep2 dataFamilyDName [nm, tvs, kind]
2139
2140 repOpenFamilyD :: Core TH.Name
2141 -> Core [TH.TyVarBndr]
2142 -> Core TH.FamilyResultSig
2143 -> Core (Maybe TH.InjectivityAnn)
2144 -> DsM (Core TH.DecQ)
2145 repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
2146 = rep2 openTypeFamilyDName [nm, tvs, result, inj]
2147
2148 repClosedFamilyD :: Core TH.Name
2149 -> Core [TH.TyVarBndr]
2150 -> Core TH.FamilyResultSig
2151 -> Core (Maybe TH.InjectivityAnn)
2152 -> Core [TH.TySynEqnQ]
2153 -> DsM (Core TH.DecQ)
2154 repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
2155 = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
2156
2157 repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
2158 repTySynEqn (MkC lhs) (MkC rhs)
2159 = rep2 tySynEqnName [lhs, rhs]
2160
2161 repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
2162 repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
2163
2164 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
2165 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
2166
2167 repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
2168 repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
2169
2170 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
2171 repCtxt (MkC tys) = rep2 cxtName [tys]
2172
2173 repDataCon :: Located Name
2174 -> HsConDeclDetails Name
2175 -> DsM (Core TH.ConQ)
2176 repDataCon con details
2177 = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
2178 repConstr details Nothing [con']
2179
2180 repGadtDataCons :: [Located Name]
2181 -> HsConDeclDetails Name
2182 -> LHsType Name
2183 -> DsM (Core TH.ConQ)
2184 repGadtDataCons cons details res_ty
2185 = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
2186 repConstr details (Just res_ty) cons'
2187
2188 -- Invariant:
2189 -- * for plain H98 data constructors second argument is Nothing and third
2190 -- argument is a singleton list
2191 -- * for GADTs data constructors second argument is (Just return_type) and
2192 -- third argument is a non-empty list
2193 repConstr :: HsConDeclDetails Name
2194 -> Maybe (LHsType Name)
2195 -> [Core TH.Name]
2196 -> DsM (Core TH.ConQ)
2197 repConstr (PrefixCon ps) Nothing [con]
2198 = do arg_tys <- repList bangTypeQTyConName repBangTy ps
2199 rep2 normalCName [unC con, unC arg_tys]
2200
2201 repConstr (PrefixCon ps) (Just (L _ res_ty)) cons
2202 = do arg_tys <- repList bangTypeQTyConName repBangTy ps
2203 res_ty' <- repTy res_ty
2204 rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
2205
2206 repConstr (RecCon (L _ ips)) resTy cons
2207 = do args <- concatMapM rep_ip ips
2208 arg_vtys <- coreList varBangTypeQTyConName args
2209 case resTy of
2210 Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
2211 Just (L _ res_ty) -> do
2212 res_ty' <- repTy res_ty
2213 rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
2214 unC res_ty']
2215
2216 where
2217 rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
2218
2219 rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a)
2220 rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n)
2221 ; MkC ty <- repBangTy t
2222 ; rep2 varBangTypeName [v,ty] }
2223
2224 repConstr (InfixCon st1 st2) Nothing [con]
2225 = do arg1 <- repBangTy st1
2226 arg2 <- repBangTy st2
2227 rep2 infixCName [unC arg1, unC con, unC arg2]
2228
2229 repConstr (InfixCon {}) (Just _) _ =
2230 panic "repConstr: infix GADT constructor should be in a PrefixCon"
2231 repConstr _ _ _ =
2232 panic "repConstr: invariant violated"
2233
2234 ------------ Types -------------------
2235
2236 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
2237 -> DsM (Core TH.TypeQ)
2238 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
2239 = rep2 forallTName [tvars, ctxt, ty]
2240
2241 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
2242 repTvar (MkC s) = rep2 varTName [s]
2243
2244 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
2245 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
2246
2247 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
2248 repTapps f [] = return f
2249 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
2250
2251 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
2252 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
2253
2254 repTequality :: DsM (Core TH.TypeQ)
2255 repTequality = rep2 equalityTName []
2256
2257 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
2258 repTPromotedList [] = repPromotedNilTyCon
2259 repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
2260 ; f <- repTapp tcon t
2261 ; t' <- repTPromotedList ts
2262 ; repTapp f t'
2263 }
2264
2265 repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
2266 repTLit (MkC lit) = rep2 litTName [lit]
2267
2268 repTWildCard :: DsM (Core TH.TypeQ)
2269 repTWildCard = rep2 wildCardTName []
2270
2271 --------- Type constructors --------------
2272
2273 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
2274 repNamedTyCon (MkC s) = rep2 conTName [s]
2275
2276 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2277 -- Note: not Core Int; it's easier to be direct here
2278 repTupleTyCon i = do dflags <- getDynFlags
2279 rep2 tupleTName [mkIntExprInt dflags i]
2280
2281 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2282 -- Note: not Core Int; it's easier to be direct here
2283 repUnboxedTupleTyCon i = do dflags <- getDynFlags
2284 rep2 unboxedTupleTName [mkIntExprInt dflags i]
2285
2286 repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
2287 -- Note: not Core TH.SumArity; it's easier to be direct here
2288 repUnboxedSumTyCon arity = do dflags <- getDynFlags
2289 rep2 unboxedSumTName [mkIntExprInt dflags arity]
2290
2291 repArrowTyCon :: DsM (Core TH.TypeQ)
2292 repArrowTyCon = rep2 arrowTName []
2293
2294 repListTyCon :: DsM (Core TH.TypeQ)
2295 repListTyCon = rep2 listTName []
2296
2297 repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)
2298 repPromotedDataCon (MkC s) = rep2 promotedTName [s]
2299
2300 repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2301 repPromotedTupleTyCon i = do dflags <- getDynFlags
2302 rep2 promotedTupleTName [mkIntExprInt dflags i]
2303
2304 repPromotedNilTyCon :: DsM (Core TH.TypeQ)
2305 repPromotedNilTyCon = rep2 promotedNilTName []
2306
2307 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
2308 repPromotedConsTyCon = rep2 promotedConsTName []
2309
2310 ------------ Kinds -------------------
2311
2312 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
2313 repPlainTV (MkC nm) = rep2 plainTVName [nm]
2314
2315 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
2316 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
2317
2318 repKVar :: Core TH.Name -> DsM (Core TH.Kind)
2319 repKVar (MkC s) = rep2 varKName [s]
2320
2321 repKCon :: Core TH.Name -> DsM (Core TH.Kind)
2322 repKCon (MkC s) = rep2 conKName [s]
2323
2324 repKTuple :: Int -> DsM (Core TH.Kind)
2325 repKTuple i = do dflags <- getDynFlags
2326 rep2 tupleKName [mkIntExprInt dflags i]
2327
2328 repKArrow :: DsM (Core TH.Kind)
2329 repKArrow = rep2 arrowKName []
2330
2331 repKList :: DsM (Core TH.Kind)
2332 repKList = rep2 listKName []
2333
2334 repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
2335 repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]
2336
2337 repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)
2338 repKApps f [] = return f
2339 repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }
2340
2341 repKStar :: DsM (Core TH.Kind)
2342 repKStar = rep2 starKName []
2343
2344 repKConstraint :: DsM (Core TH.Kind)
2345 repKConstraint = rep2 constraintKName []
2346
2347 ----------------------------------------------------------
2348 -- Type family result signature
2349
2350 repNoSig :: DsM (Core TH.FamilyResultSig)
2351 repNoSig = rep2 noSigName []
2352
2353 repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig)
2354 repKindSig (MkC ki) = rep2 kindSigName [ki]
2355
2356 repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig)
2357 repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
2358
2359 ----------------------------------------------------------
2360 -- Literals
2361
2362 repLiteral :: HsLit -> DsM (Core TH.Lit)
2363 repLiteral (HsStringPrim _ bs)
2364 = do dflags <- getDynFlags
2365 word8_ty <- lookupType word8TyConName
2366 let w8s = unpack bs
2367 w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
2368 [mkWordLit dflags (toInteger w8)]) w8s
2369 rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
2370 repLiteral lit
2371 = do lit' <- case lit of
2372 HsIntPrim _ i -> mk_integer i
2373 HsWordPrim _ w -> mk_integer w
2374 HsInt _ i -> mk_integer i
2375 HsFloatPrim r -> mk_rational r
2376 HsDoublePrim r -> mk_rational r
2377 HsCharPrim _ c -> mk_char c
2378 _ -> return lit
2379 lit_expr <- dsLit lit'
2380 case mb_lit_name of
2381 Just lit_name -> rep2 lit_name [lit_expr]
2382 Nothing -> notHandled "Exotic literal" (ppr lit)
2383 where
2384 mb_lit_name = case lit of
2385 HsInteger _ _ _ -> Just integerLName
2386 HsInt _ _ -> Just integerLName
2387 HsIntPrim _ _ -> Just intPrimLName
2388 HsWordPrim _ _ -> Just wordPrimLName
2389 HsFloatPrim _ -> Just floatPrimLName
2390 HsDoublePrim _ -> Just doublePrimLName
2391 HsChar _ _ -> Just charLName
2392 HsCharPrim _ _ -> Just charPrimLName
2393 HsString _ _ -> Just stringLName
2394 HsRat _ _ -> Just rationalLName
2395 _ -> Nothing
2396
2397 mk_integer :: Integer -> DsM HsLit
2398 mk_integer i = do integer_ty <- lookupType integerTyConName
2399 return $ HsInteger NoSourceText i integer_ty
2400 mk_rational :: FractionalLit -> DsM HsLit
2401 mk_rational r = do rat_ty <- lookupType rationalTyConName
2402 return $ HsRat r rat_ty
2403 mk_string :: FastString -> DsM HsLit
2404 mk_string s = return $ HsString NoSourceText s
2405
2406 mk_char :: Char -> DsM HsLit
2407 mk_char c = return $ HsChar NoSourceText c
2408
2409 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
2410 repOverloadedLiteral (OverLit { ol_val = val})
2411 = do { lit <- mk_lit val; repLiteral lit }
2412 -- The type Rational will be in the environment, because
2413 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
2414 -- and rationalL is sucked in when any TH stuff is used
2415
2416 mk_lit :: OverLitVal -> DsM HsLit
2417 mk_lit (HsIntegral _ i) = mk_integer i
2418 mk_lit (HsFractional f) = mk_rational f
2419 mk_lit (HsIsString _ s) = mk_string s
2420
2421 repNameS :: Core String -> DsM (Core TH.Name)
2422 repNameS (MkC name) = rep2 mkNameSName [name]
2423
2424 --------------- Miscellaneous -------------------
2425
2426 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
2427 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
2428
2429 repBindQ :: Type -> Type -- a and b
2430 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
2431 repBindQ ty_a ty_b (MkC x) (MkC y)
2432 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
2433
2434 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
2435 repSequenceQ ty_a (MkC list)
2436 = rep2 sequenceQName [Type ty_a, list]
2437
2438 repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
2439 repUnboundVar (MkC name) = rep2 unboundVarEName [name]
2440
2441 ------------ Lists -------------------
2442 -- turn a list of patterns into a single pattern matching a list
2443
2444 repList :: Name -> (a -> DsM (Core b))
2445 -> [a] -> DsM (Core [b])
2446 repList tc_name f args
2447 = do { args1 <- mapM f args
2448 ; coreList tc_name args1 }
2449
2450 coreList :: Name -- Of the TyCon of the element type
2451 -> [Core a] -> DsM (Core [a])
2452 coreList tc_name es
2453 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
2454
2455 coreList' :: Type -- The element type
2456 -> [Core a] -> Core [a]
2457 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
2458
2459 nonEmptyCoreList :: [Core a] -> Core [a]
2460 -- The list must be non-empty so we can get the element type
2461 -- Otherwise use coreList
2462 nonEmptyCoreList [] = panic "coreList: empty argument"
2463 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
2464
2465 coreStringLit :: String -> DsM (Core String)
2466 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
2467
2468 ------------------- Maybe ------------------
2469
2470 -- | Construct Core expression for Nothing of a given type name
2471 coreNothing :: Name -- ^ Name of the TyCon of the element type
2472 -> DsM (Core (Maybe a))
2473 coreNothing tc_name =
2474 do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
2475
2476 -- | Construct Core expression for Nothing of a given type
2477 coreNothing' :: Type -- ^ The element type
2478 -> Core (Maybe a)
2479 coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
2480
2481 -- | Store given Core expression in a Just of a given type name
2482 coreJust :: Name -- ^ Name of the TyCon of the element type
2483 -> Core a -> DsM (Core (Maybe a))
2484 coreJust tc_name es
2485 = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
2486
2487 -- | Store given Core expression in a Just of a given type
2488 coreJust' :: Type -- ^ The element type
2489 -> Core a -> Core (Maybe a)
2490 coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
2491
2492 ------------ Literals & Variables -------------------
2493
2494 coreIntLit :: Int -> DsM (Core Int)
2495 coreIntLit i = do dflags <- getDynFlags
2496 return (MkC (mkIntExprInt dflags i))
2497
2498 coreVar :: Id -> Core TH.Name -- The Id has type Name
2499 coreVar id = MkC (Var id)
2500
2501 ----------------- Failure -----------------------
2502 notHandledL :: SrcSpan -> String -> SDoc -> DsM a
2503 notHandledL loc what doc
2504 | isGoodSrcSpan loc
2505 = putSrcSpanDs loc $ notHandled what doc
2506 | otherwise
2507 = notHandled what doc
2508
2509 notHandled :: String -> SDoc -> DsM a
2510 notHandled what doc = failWithDs msg
2511 where
2512 msg = hang (text what <+> text "not (yet) handled by Template Haskell")
2513 2 doc