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