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