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