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