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