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