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