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