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