1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2006
5 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
6 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
7 -- input HsExpr. We do this in the DsM monad, which supplies access to
8 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
10 -- It also defines a bunch of knownKeyNames, in the same way as is done
11 -- in prelude/PrelNames. It's much more convenient to do it here, becuase
12 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
13 -- a Royal Pain (triggers other recompilation).
14 -----------------------------------------------------------------------------
16 module DsMeta( dsBracket,
17 templateHaskellNames, qTyConName, nameTyConName,
18 liftName, liftStringName, expQTyConName, patQTyConName,
19 decQTyConName, decsQTyConName, typeQTyConName,
20 decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
21 quoteExpName, quotePatName, quoteDecName, quoteTypeName
24 #include "HsVersions.h"
26 import {-# SOURCE #-} DsExpr ( dsExpr )
31 import qualified Language.Haskell.TH as TH
36 -- To avoid clashes with DsMeta.varName we must make a local alias for
37 -- OccName.varName we do this by removing varName from the import of
38 -- OccName above, making a qualified instance of OccName and using
39 -- OccNameAlias.varName where varName ws previously used in this file.
40 import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName )
44 import Name hiding( isVarOcc, isTcOcc, varName, tcName )
65 -----------------------------------------------------------------------------
66 dsBracket :: HsBracket Name -> [PendingSplice] -> 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!
71 dsBracket brack splices
72 = dsExtendMetaEnv new_bit (do_brack brack)
74 new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
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"
83 {- -------------- Examples --------------------
87 gensym (unpackString "x"#) `bindQ` \ x1::String ->
88 lam (pvar x1) (var x1)
91 [| \x -> $(f [| x |]) |]
93 gensym (unpackString "x"#) `bindQ` \ x1::String ->
94 lam (pvar x1) (f (var x1))
98 -------------------------------------------------------
100 -------------------------------------------------------
102 repTopP :: LPat Name -> DsM (Core TH.PatQ)
103 repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
104 ; pat' <- addBinds ss (repLP pat)
105 ; wrapNongenSyms ss pat' }
107 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
109 = do { let { bndrs = groupBinders group } ;
110 ss <- mkGenSyms bndrs ;
112 -- Bind all the names mainly to avoid repeated use of explicit strings.
114 -- do { t :: String <- genSym "T" ;
115 -- return (Data t [] ...more t's... }
116 -- The other important reason is that the output must mention
117 -- only "T", not "Foo:T" where Foo is the current module
120 decls <- addBinds ss (do {
121 val_ds <- rep_val_binds (hs_valds group) ;
122 tycl_ds <- mapM repTyClD (hs_tyclds group) ;
123 inst_ds <- mapM repInstD' (hs_instds group) ;
124 for_ds <- mapM repForD (hs_fords group) ;
126 return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
128 decl_ty <- lookupType decQTyConName ;
129 let { core_list = coreList' decl_ty decls } ;
131 dec_ty <- lookupType decTyConName ;
132 q_decs <- repSequenceQ dec_ty core_list ;
134 wrapNongenSyms ss q_decs
135 -- Do *not* gensym top-level binders
138 groupBinders :: HsGroup Name -> [Name]
139 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
140 hs_instds = inst_decls, hs_fords = foreign_decls })
141 -- Collect the binders of a Group
142 = collectHsValBinders val_decls ++
143 [n | d <- tycl_decls ++ assoc_tycl_decls, L _ n <- tyClDeclNames (unLoc d)] ++
144 [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
146 assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
149 {- Note [Binders and occurrences]
150 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
151 When we desugar [d| data T = MkT |]
153 Data "T" [] [Con "MkT" []] []
155 Data "Foo:T" [] [Con "Foo:MkT" []] []
156 That is, the new data decl should fit into whatever new module it is
157 asked to fit in. We do *not* clone, though; no need for this:
164 then we must desugar to
165 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
167 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
168 And we use lookupOcc, rather than lookupBinder
169 in repTyClD and repC.
173 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
175 repTyClD tydecl@(L _ (TyFamily {}))
176 = repTyFamily tydecl addTyVarBinds
178 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
179 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
180 tcdCons = cons, tcdDerivs = mb_derivs }))
181 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
182 ; dec <- addTyVarBinds tvs $ \bndrs ->
183 do { cxt1 <- repLContext cxt
184 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
185 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
186 ; cons1 <- mapM repC cons
187 ; cons2 <- coreList conQTyConName cons1
188 ; derivs1 <- repDerivs mb_derivs
189 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
190 ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1
192 ; return $ Just (loc, dec)
195 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
196 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
197 tcdCons = [con], tcdDerivs = mb_derivs }))
198 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
199 ; dec <- addTyVarBinds tvs $ \bndrs ->
200 do { cxt1 <- repLContext cxt
201 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
202 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
204 ; derivs1 <- repDerivs mb_derivs
205 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
206 ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
208 ; return $ Just (loc, dec)
211 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
213 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
214 ; dec <- addTyVarBinds tvs $ \bndrs ->
215 do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
216 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
218 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
219 ; repTySyn tc1 bndrs1 opt_tys2 ty1
221 ; return (Just (loc, dec))
224 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
225 tcdTyVars = tvs, tcdFDs = fds,
226 tcdSigs = sigs, tcdMeths = meth_binds,
228 = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
229 ; dec <- addTyVarBinds tvs $ \bndrs ->
230 do { cxt1 <- repLContext cxt
231 ; sigs1 <- rep_sigs sigs
232 ; binds1 <- rep_binds meth_binds
233 ; fds1 <- repLFunDeps fds
234 ; ats1 <- repLAssocFamilys ats
235 ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
236 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
237 ; repClass cxt1 cls1 bndrs1 fds1 decls1
239 ; return $ Just (loc, dec)
243 repTyClD (L loc d) = putSrcSpanDs loc $
244 do { warnDs (hang ds_msg 4 (ppr d))
247 -- The type variables in the head of families are treated differently when the
248 -- family declaration is associated. In that case, they are usage, not binding
251 repTyFamily :: LTyClDecl Name
252 -> ProcessTyVarBinds TH.Dec
253 -> DsM (Maybe (SrcSpan, Core TH.DecQ))
254 repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
255 tcdLName = tc, tcdTyVars = tvs,
256 tcdKind = opt_kind }))
258 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
259 ; dec <- tyVarBinds tvs $ \bndrs ->
260 do { flav <- repFamilyFlavour flavour
261 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
263 Nothing -> repFamilyNoKind flav tc1 bndrs1
264 Just ki -> do { ki1 <- repKind ki
265 ; repFamilyKind flav tc1 bndrs1 ki1
268 ; return $ Just (loc, dec)
270 repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
274 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
275 repLFunDeps fds = do fds' <- mapM repLFunDep fds
276 fdList <- coreList funDepTyConName fds'
279 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
280 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
281 ys' <- mapM lookupBinder ys
282 xs_list <- coreList nameTyConName xs'
283 ys_list <- coreList nameTyConName ys'
284 repFunDep xs_list ys_list
286 -- represent family declaration flavours
288 repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
289 repFamilyFlavour TypeFamily = rep2 typeFamName []
290 repFamilyFlavour DataFamily = rep2 dataFamName []
292 -- represent associated family declarations
294 repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
295 repLAssocFamilys = mapM repLAssocFamily
297 repLAssocFamily tydecl@(L _ (TyFamily {}))
298 = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
299 repLAssocFamily tydecl
302 msg = ptext (sLit "Illegal associated declaration in class:") <+>
305 -- represent associated family instances
307 repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
308 repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
310 -- represent instance declarations
312 repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
313 repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
314 = do { i <- addTyVarBinds tvs $ \_ ->
315 -- We must bring the type variables into scope, so their
316 -- occurrences don't fail, even though the binders don't
317 -- appear in the resulting data structure
318 do { cxt1 <- repContext cxt
319 ; inst_ty1 <- repPredTy (HsClassP cls tys)
320 ; ss <- mkGenSyms (collectHsBindsBinders binds)
321 ; binds1 <- addBinds ss (rep_binds binds)
322 ; ats1 <- repLAssocFamInst ats
323 ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
324 ; decls2 <- wrapNongenSyms ss decls1
325 -- wrapNongenSyms: do not clone the class op names!
326 -- They must be called 'op' etc, not 'op34'
327 ; repInst cxt1 inst_ty1 (decls2)
331 (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
333 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
334 repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
335 = do MkC name' <- lookupLOcc name
336 MkC typ' <- repLTy typ
337 MkC cc' <- repCCallConv cc
338 MkC s' <- repSafety s
339 cis' <- conv_cimportspec cis
340 MkC str <- coreStringLit $ static
341 ++ unpackFS ch ++ " "
343 dec <- rep2 forImpDName [cc', s', str, name', typ']
346 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
347 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
348 conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
349 conv_cimportspec CWrapper = return "wrapper"
351 CFunction (StaticTarget _ _) -> "static "
353 repForD decl = notHandled "Foreign declaration" (ppr decl)
355 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
356 repCCallConv CCallConv = rep2 cCallName []
357 repCCallConv StdCallConv = rep2 stdCallName []
358 repCCallConv callConv = notHandled "repCCallConv" (ppr callConv)
360 repSafety :: Safety -> DsM (Core TH.Safety)
361 repSafety PlayRisky = rep2 unsafeName []
362 repSafety (PlaySafe False) = rep2 safeName []
363 repSafety (PlaySafe True) = rep2 threadsafeName []
366 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
368 -------------------------------------------------------
370 -------------------------------------------------------
372 repC :: LConDecl Name -> DsM (Core TH.ConQ)
373 repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
374 , con_details = details, con_res = ResTyH98 }))
375 = do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
376 ; repConstr con1 details
378 repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 }))
379 = addTyVarBinds tvs $ \bndrs ->
380 do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] }))
381 ; ctxt' <- repContext ctxt
382 ; bndrs' <- coreList tyVarBndrTyConName bndrs
383 ; rep2 forallCName [unC bndrs', unC ctxt', unC c']
385 repC (L loc con_decl) -- GADTs
387 notHandled "GADT declaration" (ppr con_decl)
389 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
393 rep2 strictTypeName [s, t]
395 (str, ty') = case ty of
396 L _ (HsBangTy _ ty) -> (isStrictName, ty)
397 _ -> (notStrictName, ty)
399 -------------------------------------------------------
401 -------------------------------------------------------
403 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
404 repDerivs Nothing = coreList nameTyConName []
405 repDerivs (Just ctxt)
406 = do { strs <- mapM rep_deriv ctxt ;
407 coreList nameTyConName strs }
409 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
410 -- Deriving clauses must have the simple H98 form
411 rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
412 rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
415 -------------------------------------------------------
416 -- Signatures in a class decl, or a group of bindings
417 -------------------------------------------------------
419 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
420 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
421 return $ de_loc $ sort_by_loc locs_cores
423 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
424 -- We silently ignore ones we don't recognise
425 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
426 return (concat sigs1) }
428 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
430 -- Empty => Too hard, signature ignored
431 rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
432 rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
433 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
434 rep_sig _ = return []
436 rep_proto :: Located Name -> LHsType Name -> SrcSpan
437 -> DsM [(SrcSpan, Core TH.DecQ)]
439 = do { nm1 <- lookupLOcc nm
441 ; sig <- repProto nm1 ty1
442 ; return [(loc, sig)]
445 rep_inline :: Located Name
446 -> InlinePragma -- Never defaultInlinePragma
448 -> DsM [(SrcSpan, Core TH.DecQ)]
449 rep_inline nm ispec loc
450 = do { nm1 <- lookupLOcc nm
451 ; ispec1 <- rep_InlinePrag ispec
452 ; pragma <- repPragInl nm1 ispec1
453 ; return [(loc, pragma)]
456 rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
457 -> DsM [(SrcSpan, Core TH.DecQ)]
458 rep_specialise nm ty ispec loc
459 = do { nm1 <- lookupLOcc nm
461 ; pragma <- if isDefaultInlinePragma ispec
462 then repPragSpec nm1 ty1 -- SPECIALISE
463 else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE
464 ; repPragSpecInl nm1 ty1 ispec1 }
465 ; return [(loc, pragma)]
468 -- Extract all the information needed to build a TH.InlinePrag
470 rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
471 -> DsM (Core TH.InlineSpecQ)
472 rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
473 | Nothing <- activation1
474 = repInlineSpecNoPhase inline1 match1
475 | Just (flag, phase) <- activation1
476 = repInlineSpecPhase inline1 match1 flag phase
477 | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
479 match1 = coreBool (rep_RuleMatchInfo match)
480 activation1 = rep_Activation activation
481 inline1 = coreBool inline
483 rep_RuleMatchInfo FunLike = False
484 rep_RuleMatchInfo ConLike = True
486 rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive
487 rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive
488 rep_Activation (ActiveBefore phase) = Just (coreBool False,
489 MkC $ mkIntExprInt phase)
490 rep_Activation (ActiveAfter phase) = Just (coreBool True,
491 MkC $ mkIntExprInt phase)
494 -------------------------------------------------------
496 -------------------------------------------------------
498 -- We process type variable bindings in two ways, either by generating fresh
499 -- names or looking up existing names. The difference is crucial for type
500 -- families, depending on whether they are associated or not.
502 type ProcessTyVarBinds a =
503 [LHsTyVarBndr Name] -- the binders to be added
504 -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
505 -> DsM (Core (TH.Q a))
507 -- gensym a list of type variables and enter them into the meta environment;
508 -- the computations passed as the second argument is executed in that extended
509 -- meta environment and gets the *new* names on Core-level as an argument
511 addTyVarBinds :: ProcessTyVarBinds a
512 addTyVarBinds tvs m =
514 let names = hsLTyVarNames tvs
515 mkWithKinds = map repTyVarBndrWithKind tvs
516 freshNames <- mkGenSyms names
517 term <- addBinds freshNames $ do
518 bndrs <- mapM lookupBinder names
519 kindedBndrs <- zipWithM ($) mkWithKinds bndrs
521 wrapGenSyms freshNames term
523 -- Look up a list of type variables; the computations passed as the second
524 -- argument gets the *new* names on Core-level as an argument
526 lookupTyVarBinds :: ProcessTyVarBinds a
527 lookupTyVarBinds tvs m =
529 let names = hsLTyVarNames tvs
530 mkWithKinds = map repTyVarBndrWithKind tvs
531 bndrs <- mapM lookupBinder names
532 kindedBndrs <- zipWithM ($) mkWithKinds bndrs
535 -- Produce kinded binder constructors from the Haskell tyvar binders
537 repTyVarBndrWithKind :: LHsTyVarBndr Name
538 -> Core TH.Name -> DsM (Core TH.TyVarBndr)
539 repTyVarBndrWithKind (L _ (UserTyVar {})) nm
541 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
542 = repKind ki >>= repKindedTV nm
544 -- represent a type context
546 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
547 repLContext (L _ ctxt) = repContext ctxt
549 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
551 preds <- mapM repLPred ctxt
552 predList <- coreList predQTyConName preds
555 -- represent a type predicate
557 repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
558 repLPred (L _ p) = repPred p
560 repPred :: HsPred Name -> DsM (Core TH.PredQ)
561 repPred (HsClassP cls tys)
563 cls1 <- lookupOcc cls
565 tys2 <- coreList typeQTyConName tys1
567 repPred (HsEqualP tyleft tyright)
569 tyleft1 <- repLTy tyleft
570 tyright1 <- repLTy tyright
571 repEqualP tyleft1 tyright1
572 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
574 repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
575 repPredTy (HsClassP cls tys)
577 tcon <- repTy (HsTyVar cls)
580 repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
582 -- yield the representation of a list of types
584 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
585 repLTys tys = mapM repLTy tys
589 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
590 repLTy (L _ ty) = repTy ty
592 repTy :: HsType Name -> DsM (Core TH.TypeQ)
593 repTy (HsForAllTy _ tvs ctxt ty) =
594 addTyVarBinds tvs $ \bndrs -> do
595 ctxt1 <- repLContext ctxt
597 bndrs1 <- coreList tyVarBndrTyConName bndrs
598 repTForall bndrs1 ctxt1 ty1
601 | isTvOcc (nameOccName n) = do
607 repTy (HsAppTy f a) = do
611 repTy (HsFunTy f a) = do
614 tcon <- repArrowTyCon
615 repTapps tcon [f1, a1]
616 repTy (HsListTy t) = do
620 repTy (HsPArrTy t) = do
622 tcon <- repTy (HsTyVar (tyConName parrTyCon))
624 repTy (HsTupleTy _ tys) = do
626 tcon <- repTupleTyCon (length tys)
628 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
630 repTy (HsParTy t) = repLTy t
631 repTy (HsPredTy pred) = repPredTy pred
632 repTy (HsKindSig t k) = do
636 repTy (HsSpliceTy splice _ _) = repSplice splice
637 repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
638 repTy ty = notHandled "Exotic form of type" (ppr ty)
642 repKind :: Kind -> DsM (Core TH.Kind)
644 = do { let (kis, ki') = splitKindFunTys ki
645 ; kis_rep <- mapM repKind kis
646 ; ki'_rep <- repNonArrowKind ki'
647 ; foldrM repArrowK ki'_rep kis_rep
650 repNonArrowKind k | isLiftedTypeKind k = repStarK
651 | otherwise = notHandled "Exotic form of kind"
654 -----------------------------------------------------------------------------
656 -----------------------------------------------------------------------------
658 repSplice :: HsSplice Name -> DsM (Core a)
659 -- See Note [How brackets and nested splices are handled] in TcSplice
660 -- We return a CoreExpr of any old type; the context should know
661 repSplice (HsSplice n _)
662 = do { mb_val <- dsLookupMetaEnv n
664 Just (Splice e) -> do { e' <- dsExpr e
666 _ -> pprPanic "HsSplice" (ppr n) }
667 -- Should not happen; statically checked
669 -----------------------------------------------------------------------------
671 -----------------------------------------------------------------------------
673 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
674 repLEs es = do { es' <- mapM repLE es ;
675 coreList expQTyConName es' }
677 -- FIXME: some of these panics should be converted into proper error messages
678 -- unless we can make sure that constructs, which are plainly not
679 -- supported in TH already lead to error messages at an earlier stage
680 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
681 repLE (L loc e) = putSrcSpanDs loc (repE e)
683 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
685 do { mb_val <- dsLookupMetaEnv x
687 Nothing -> do { str <- globalVar x
688 ; repVarOrCon x str }
689 Just (Bound y) -> repVarOrCon x (coreVar y)
690 Just (Splice e) -> do { e' <- dsExpr e
691 ; return (MkC e') } }
692 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
694 -- Remember, we're desugaring renamer output here, so
695 -- HsOverlit can definitely occur
696 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
697 repE (HsLit l) = do { a <- repLiteral l; repLit a }
698 repE (HsLam (MatchGroup [m] _)) = repLambda m
699 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
701 repE (OpApp e1 op _ e2) =
702 do { arg1 <- repLE e1;
705 repInfixApp arg1 the_op arg2 }
706 repE (NegApp x _) = do
708 negateVar <- lookupOcc negateName >>= repVar
710 repE (HsPar x) = repLE x
711 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
712 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
713 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
714 ; ms2 <- mapM repMatchTup ms
715 ; repCaseE arg (nonEmptyCoreList ms2) }
716 repE (HsIf x y z) = do
721 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
722 ; e2 <- addBinds ss (repLE e)
726 -- FIXME: I haven't got the types here right yet
727 repE e@(HsDo ctxt sts body _)
728 | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
729 = do { (ss,zs) <- repLSts sts;
730 body' <- addBinds ss $ repLE body;
731 ret <- repNoBindSt body';
732 e' <- repDoE (nonEmptyCoreList (zs ++ [ret]));
736 = do { (ss,zs) <- repLSts sts;
737 body' <- addBinds ss $ repLE body;
738 ret <- repNoBindSt body';
739 e' <- repComp (nonEmptyCoreList (zs ++ [ret]));
743 = notHandled "mdo and [: :]" (ppr e)
745 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
746 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
747 repE e@(ExplicitTuple es boxed)
748 | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e)
749 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
750 | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs }
752 repE (RecordCon c _ flds)
753 = do { x <- lookupLOcc c;
754 fs <- repFields flds;
756 repE (RecordUpd e flds _ _ _)
758 fs <- repFields flds;
761 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
762 repE (ArithSeq _ aseq) =
764 From e -> do { ds1 <- repLE e; repFrom ds1 }
773 FromThenTo e1 e2 e3 -> do
777 repFromThenTo ds1 ds2 ds3
779 repE (HsSpliceE splice) = repSplice splice
780 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
781 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
782 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
783 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
784 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
785 repE e = notHandled "Expression form" (ppr e)
787 -----------------------------------------------------------------------------
788 -- Building representations of auxillary structures like Match, Clause, Stmt,
790 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
791 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
792 do { ss1 <- mkGenSyms (collectPatBinders p)
793 ; addBinds ss1 $ do {
795 ; (ss2,ds) <- repBinds wheres
796 ; addBinds ss2 $ do {
797 ; gs <- repGuards guards
798 ; match <- repMatch p1 gs ds
799 ; wrapGenSyms (ss1++ss2) match }}}
800 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
802 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
803 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
804 do { ss1 <- mkGenSyms (collectPatsBinders ps)
805 ; addBinds ss1 $ do {
807 ; (ss2,ds) <- repBinds wheres
808 ; addBinds ss2 $ do {
809 gs <- repGuards guards
810 ; clause <- repClause ps1 gs ds
811 ; wrapGenSyms (ss1++ss2) clause }}}
813 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
814 repGuards [L _ (GRHS [] e)]
815 = do {a <- repLE e; repNormal a }
817 = do { zs <- mapM process other;
818 let {(xs, ys) = unzip zs};
819 gd <- repGuarded (nonEmptyCoreList ys);
820 wrapGenSyms (concat xs) gd }
822 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
823 process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
824 = do { x <- repLNormalGE e1 e2;
826 process (L _ (GRHS ss rhs))
827 = do (gs, ss') <- repLSts ss
828 rhs' <- addBinds gs $ repLE rhs
829 g <- repPatGE (nonEmptyCoreList ss') rhs'
832 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
833 repFields (HsRecFields { rec_flds = flds })
834 = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
835 ; es <- mapM repLE (map hsRecFieldArg flds)
836 ; fs <- zipWithM repFieldExp fnames es
837 ; coreList fieldExpQTyConName fs }
840 -----------------------------------------------------------------------------
841 -- Representing Stmt's is tricky, especially if bound variables
842 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
843 -- First gensym new names for every variable in any of the patterns.
844 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
845 -- if variables didn't shaddow, the static gensym wouldn't be necessary
846 -- and we could reuse the original names (x and x).
848 -- do { x'1 <- gensym "x"
849 -- ; x'2 <- gensym "x"
850 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
851 -- , BindSt (pvar x'2) [| f x |]
852 -- , NoBindSt [| g x |]
856 -- The strategy is to translate a whole list of do-bindings by building a
857 -- bigger environment, and a bigger set of meta bindings
858 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
859 -- of the expressions within the Do
861 -----------------------------------------------------------------------------
862 -- The helper function repSts computes the translation of each sub expression
863 -- and a bunch of prefix bindings denoting the dynamic renaming.
865 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
866 repLSts stmts = repSts (map unLoc stmts)
868 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
869 repSts (BindStmt p e _ _ : ss) =
871 ; ss1 <- mkGenSyms (collectPatBinders p)
872 ; addBinds ss1 $ do {
874 ; (ss2,zs) <- repSts ss
875 ; z <- repBindSt p1 e2
876 ; return (ss1++ss2, z : zs) }}
877 repSts (LetStmt bs : ss) =
878 do { (ss1,ds) <- repBinds bs
880 ; (ss2,zs) <- addBinds ss1 (repSts ss)
881 ; return (ss1++ss2, z : zs) }
882 repSts (ExprStmt e _ _ : ss) =
884 ; z <- repNoBindSt e2
885 ; (ss2,zs) <- repSts ss
886 ; return (ss2, z : zs) }
887 repSts [] = return ([],[])
888 repSts other = notHandled "Exotic statement" (ppr other)
891 -----------------------------------------------------------
893 -----------------------------------------------------------
895 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
896 repBinds EmptyLocalBinds
897 = do { core_list <- coreList decQTyConName []
898 ; return ([], core_list) }
900 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
902 repBinds (HsValBinds decs)
903 = do { let { bndrs = collectHsValBinders decs }
904 -- No need to worrry about detailed scopes within
905 -- the binding group, because we are talking Names
906 -- here, so we can safely treat it as a mutually
908 ; ss <- mkGenSyms bndrs
909 ; prs <- addBinds ss (rep_val_binds decs)
910 ; core_list <- coreList decQTyConName
911 (de_loc (sort_by_loc prs))
912 ; return (ss, core_list) }
914 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
915 -- Assumes: all the binders of the binding are alrady in the meta-env
916 rep_val_binds (ValBindsOut binds sigs)
917 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
918 ; core2 <- rep_sigs' sigs
919 ; return (core1 ++ core2) }
920 rep_val_binds (ValBindsIn _ _)
921 = panic "rep_val_binds: ValBindsIn"
923 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
924 rep_binds binds = do { binds_w_locs <- rep_binds' binds
925 ; return (de_loc (sort_by_loc binds_w_locs)) }
927 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
928 rep_binds' binds = mapM rep_bind (bagToList binds)
930 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
931 -- Assumes: all the binders of the binding are alrady in the meta-env
933 -- Note GHC treats declarations of a variable (not a pattern)
934 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
935 -- with an empty list of patterns
936 rep_bind (L loc (FunBind { fun_id = fn,
937 fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
938 = do { (ss,wherecore) <- repBinds wheres
939 ; guardcore <- addBinds ss (repGuards guards)
940 ; fn' <- lookupLBinder fn
942 ; ans <- repVal p guardcore wherecore
943 ; ans' <- wrapGenSyms ss ans
944 ; return (loc, ans') }
946 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
947 = do { ms1 <- mapM repClauseTup ms
948 ; fn' <- lookupLBinder fn
949 ; ans <- repFun fn' (nonEmptyCoreList ms1)
950 ; return (loc, ans) }
952 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
953 = do { patcore <- repLP pat
954 ; (ss,wherecore) <- repBinds wheres
955 ; guardcore <- addBinds ss (repGuards guards)
956 ; ans <- repVal patcore guardcore wherecore
957 ; ans' <- wrapGenSyms ss ans
958 ; return (loc, ans') }
960 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
961 = do { v' <- lookupBinder v
964 ; patcore <- repPvar v'
965 ; empty_decls <- coreList decQTyConName []
966 ; ans <- repVal patcore x empty_decls
967 ; return (srcLocSpan (getSrcLoc v), ans) }
969 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
971 -----------------------------------------------------------------------------
972 -- Since everything in a Bind is mutually recursive we need rename all
973 -- all the variables simultaneously. For example:
974 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
975 -- do { f'1 <- gensym "f"
976 -- ; g'2 <- gensym "g"
977 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
978 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
980 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
981 -- environment ( f |-> f'1 ) from each binding, and then unioning them
982 -- together. As we do this we collect GenSymBinds's which represent the renamed
983 -- variables bound by the Bindings. In order not to lose track of these
984 -- representations we build a shadow datatype MB with the same structure as
985 -- MonoBinds, but which has slots for the representations
988 -----------------------------------------------------------------------------
989 -- GHC allows a more general form of lambda abstraction than specified
990 -- by Haskell 98. In particular it allows guarded lambda's like :
991 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
992 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
993 -- (\ p1 .. pn -> exp) by causing an error.
995 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
996 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
997 = do { let bndrs = collectPatsBinders ps ;
998 ; ss <- mkGenSyms bndrs
999 ; lam <- addBinds ss (
1000 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1001 ; wrapGenSyms ss lam }
1003 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
1006 -----------------------------------------------------------------------------
1008 -- repP deals with patterns. It assumes that we have already
1009 -- walked over the pattern(s) once to collect the binders, and
1010 -- have extended the environment. So every pattern-bound
1011 -- variable should already appear in the environment.
1013 -- Process a list of patterns
1014 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1015 repLPs ps = do { ps' <- mapM repLP ps ;
1016 coreList patQTyConName ps' }
1018 repLP :: LPat Name -> DsM (Core TH.PatQ)
1019 repLP (L _ p) = repP p
1021 repP :: Pat Name -> DsM (Core TH.PatQ)
1022 repP (WildPat _) = repPwild
1023 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1024 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1025 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1026 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1027 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1028 repP (ParPat p) = repLP p
1029 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
1030 repP p@(TuplePat ps boxed _)
1031 | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p)
1032 | otherwise = do { qs <- repLPs ps; repPtup qs }
1033 repP (ConPatIn dc details)
1034 = do { con_str <- lookupLOcc dc
1036 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1037 RecCon rec -> do { let flds = rec_flds rec
1038 ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
1039 ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
1040 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
1041 ; fps' <- coreList fieldPatQTyConName fps
1042 ; repPrec con_str fps' }
1043 InfixCon p1 p2 -> do { p1' <- repLP p1;
1045 repPinfix p1' con_str p2' }
1047 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1048 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1049 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1050 -- The problem is to do with scoped type variables.
1051 -- To implement them, we have to implement the scoping rules
1052 -- here in DsMeta, and I don't want to do that today!
1053 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1054 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1055 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1057 repP other = notHandled "Exotic pattern" (ppr other)
1059 ----------------------------------------------------------
1060 -- Declaration ordering helpers
1062 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1063 sort_by_loc xs = sortBy comp xs
1064 where comp x y = compare (fst x) (fst y)
1066 de_loc :: [(a, b)] -> [b]
1069 ----------------------------------------------------------
1070 -- The meta-environment
1072 -- A name/identifier association for fresh names of locally bound entities
1073 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1074 -- I.e. (x, x_id) means
1075 -- let x_id = gensym "x" in ...
1077 -- Generate a fresh name for a locally bound entity
1079 mkGenSyms :: [Name] -> DsM [GenSymBind]
1080 -- We can use the existing name. For example:
1081 -- [| \x_77 -> x_77 + x_77 |]
1083 -- do { x_77 <- genSym "x"; .... }
1084 -- We use the same x_77 in the desugared program, but with the type Bndr
1087 -- We do make it an Internal name, though (hence localiseName)
1089 -- Nevertheless, it's monadic because we have to generate nameTy
1090 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1091 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1094 addBinds :: [GenSymBind] -> DsM a -> DsM a
1095 -- Add a list of fresh names for locally bound entities to the
1096 -- meta environment (which is part of the state carried around
1097 -- by the desugarer monad)
1098 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1100 -- Look up a locally bound name
1102 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1103 lookupLBinder (L _ n) = lookupBinder n
1105 lookupBinder :: Name -> DsM (Core TH.Name)
1107 = do { mb_val <- dsLookupMetaEnv n;
1109 Just (Bound x) -> return (coreVar x)
1110 _ -> failWithDs msg }
1112 msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
1114 -- Look up a name that is either locally bound or a global name
1116 -- * If it is a global name, generate the "original name" representation (ie,
1117 -- the <module>:<name> form) for the associated entity
1119 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1120 -- Lookup an occurrence; it can't be a splice.
1121 -- Use the in-scope bindings if they exist
1122 lookupLOcc (L _ n) = lookupOcc n
1124 lookupOcc :: Name -> DsM (Core TH.Name)
1126 = do { mb_val <- dsLookupMetaEnv n ;
1128 Nothing -> globalVar n
1129 Just (Bound x) -> return (coreVar x)
1130 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1133 lookupTvOcc :: Name -> DsM (Core TH.Name)
1134 -- Type variables can't be staged and are not lexically scoped in TH
1136 = do { mb_val <- dsLookupMetaEnv n ;
1138 Just (Bound x) -> return (coreVar x)
1142 msg = vcat [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n)
1143 , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ]
1145 globalVar :: Name -> DsM (Core TH.Name)
1146 -- Not bound by the meta-env
1147 -- Could be top-level; or could be local
1148 -- f x = $(g [| x |])
1149 -- Here the x will be local
1151 | isExternalName name
1152 = do { MkC mod <- coreStringLit name_mod
1153 ; MkC pkg <- coreStringLit name_pkg
1154 ; MkC occ <- occNameLit name
1155 ; rep2 mk_varg [pkg,mod,occ] }
1157 = do { MkC occ <- occNameLit name
1158 ; MkC uni <- coreIntLit (getKey (getUnique name))
1159 ; rep2 mkNameLName [occ,uni] }
1161 mod = ASSERT( isExternalName name) nameModule name
1162 name_mod = moduleNameString (moduleName mod)
1163 name_pkg = packageIdString (modulePackageId mod)
1164 name_occ = nameOccName name
1165 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1166 | OccName.isVarOcc name_occ = mkNameG_vName
1167 | OccName.isTcOcc name_occ = mkNameG_tcName
1168 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1170 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1171 -> DsM Type -- The type
1172 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1173 return (mkTyConApp tc []) }
1175 wrapGenSyms :: [GenSymBind]
1176 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1177 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1178 -- --> bindQ (gensym nm1) (\ id1 ->
1179 -- bindQ (gensym nm2 (\ id2 ->
1182 wrapGenSyms binds body@(MkC b)
1183 = do { var_ty <- lookupType nameTyConName
1186 [elt_ty] = tcTyConAppArgs (exprType b)
1187 -- b :: Q a, so we can get the type 'a' by looking at the
1188 -- argument type. NB: this relies on Q being a data/newtype,
1189 -- not a type synonym
1191 go _ [] = return body
1192 go var_ty ((name,id) : binds)
1193 = do { MkC body' <- go var_ty binds
1194 ; lit_str <- occNameLit name
1195 ; gensym_app <- repGensym lit_str
1196 ; repBindQ var_ty elt_ty
1197 gensym_app (MkC (Lam id body')) }
1199 -- Just like wrapGenSym, but don't actually do the gensym
1200 -- Instead use the existing name:
1201 -- let x = "x" in ...
1202 -- Only used for [Decl], and for the class ops in class
1203 -- and instance decls
1204 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
1205 wrapNongenSyms binds (MkC body)
1206 = do { binds' <- mapM do_one binds ;
1207 return (MkC (mkLets binds' body)) }
1210 = do { MkC lit_str <- occNameLit name
1211 ; MkC var <- rep2 mkNameName [lit_str]
1212 ; return (NonRec id var) }
1214 occNameLit :: Name -> DsM (Core String)
1215 occNameLit n = coreStringLit (occNameString (nameOccName n))
1218 -- %*********************************************************************
1220 -- Constructing code
1222 -- %*********************************************************************
1224 -----------------------------------------------------------------------------
1225 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1226 -- we invent a new datatype which uses phantom types.
1228 newtype Core a = MkC CoreExpr
1229 unC :: Core a -> CoreExpr
1232 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1233 rep2 n xs = do { id <- dsLookupGlobalId n
1234 ; return (MkC (foldl App (Var id) xs)) }
1236 -- Then we make "repConstructors" which use the phantom types for each of the
1237 -- smart constructors of the Meta.Meta datatypes.
1240 -- %*********************************************************************
1242 -- The 'smart constructors'
1244 -- %*********************************************************************
1246 --------------- Patterns -----------------
1247 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1248 repPlit (MkC l) = rep2 litPName [l]
1250 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1251 repPvar (MkC s) = rep2 varPName [s]
1253 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1254 repPtup (MkC ps) = rep2 tupPName [ps]
1256 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1257 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1259 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1260 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1262 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1263 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1265 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1266 repPtilde (MkC p) = rep2 tildePName [p]
1268 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1269 repPbang (MkC p) = rep2 bangPName [p]
1271 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1272 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1274 repPwild :: DsM (Core TH.PatQ)
1275 repPwild = rep2 wildPName []
1277 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1278 repPlist (MkC ps) = rep2 listPName [ps]
1280 --------------- Expressions -----------------
1281 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1282 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1283 | otherwise = repVar str
1285 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1286 repVar (MkC s) = rep2 varEName [s]
1288 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1289 repCon (MkC s) = rep2 conEName [s]
1291 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1292 repLit (MkC c) = rep2 litEName [c]
1294 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1295 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1297 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1298 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1300 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1301 repTup (MkC es) = rep2 tupEName [es]
1303 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1304 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1306 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1307 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1309 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1310 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1312 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1313 repDoE (MkC ss) = rep2 doEName [ss]
1315 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1316 repComp (MkC ss) = rep2 compEName [ss]
1318 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1319 repListExp (MkC es) = rep2 listEName [es]
1321 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1322 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1324 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1325 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1327 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1328 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1330 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1331 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1333 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1334 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1336 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1337 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1339 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1340 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1342 ------------ Right hand sides (guarded expressions) ----
1343 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1344 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1346 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1347 repNormal (MkC e) = rep2 normalBName [e]
1349 ------------ Guards ----
1350 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1351 repLNormalGE g e = do g' <- repLE g
1355 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1356 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1358 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1359 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1361 ------------- Stmts -------------------
1362 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1363 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1365 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1366 repLetSt (MkC ds) = rep2 letSName [ds]
1368 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1369 repNoBindSt (MkC e) = rep2 noBindSName [e]
1371 -------------- Range (Arithmetic sequences) -----------
1372 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1373 repFrom (MkC x) = rep2 fromEName [x]
1375 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1376 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1378 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1379 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1381 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1382 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1384 ------------ Match and Clause Tuples -----------
1385 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1386 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1388 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1389 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1391 -------------- Dec -----------------------------
1392 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1393 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1395 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1396 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1398 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1399 -> Maybe (Core [TH.TypeQ])
1400 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1401 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1402 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1403 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1404 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1406 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1407 -> Maybe (Core [TH.TypeQ])
1408 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1409 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1410 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1411 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1412 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1414 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1415 -> Maybe (Core [TH.TypeQ])
1416 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1417 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1418 = rep2 tySynDName [nm, tvs, rhs]
1419 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1420 = rep2 tySynInstDName [nm, tys, rhs]
1422 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1423 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1425 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1426 -> Core [TH.FunDep] -> Core [TH.DecQ]
1427 -> DsM (Core TH.DecQ)
1428 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1429 = rep2 classDName [cxt, cls, tvs, fds, ds]
1431 repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1432 repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1434 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1435 repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1437 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1438 -> DsM (Core TH.DecQ)
1439 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1440 = rep2 pragSpecInlDName [nm, ty, ispec]
1442 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1443 -> DsM (Core TH.DecQ)
1444 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1445 = rep2 familyNoKindDName [flav, nm, tvs]
1447 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1449 -> DsM (Core TH.DecQ)
1450 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1451 = rep2 familyKindDName [flav, nm, tvs, ki]
1453 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
1454 repInlineSpecNoPhase (MkC inline) (MkC conlike)
1455 = rep2 inlineSpecNoPhaseName [inline, conlike]
1457 repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int
1458 -> DsM (Core TH.InlineSpecQ)
1459 repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1460 = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1462 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1463 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1465 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1466 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1468 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1469 repCtxt (MkC tys) = rep2 cxtName [tys]
1471 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1472 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1474 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1475 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1477 repConstr :: Core TH.Name -> HsConDeclDetails Name
1478 -> DsM (Core TH.ConQ)
1479 repConstr con (PrefixCon ps)
1480 = do arg_tys <- mapM repBangTy ps
1481 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1482 rep2 normalCName [unC con, unC arg_tys1]
1483 repConstr con (RecCon ips)
1484 = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
1485 arg_tys <- mapM repBangTy (map cd_fld_type ips)
1486 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1488 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1489 rep2 recCName [unC con, unC arg_vtys']
1490 repConstr con (InfixCon st1 st2)
1491 = do arg1 <- repBangTy st1
1492 arg2 <- repBangTy st2
1493 rep2 infixCName [unC arg1, unC con, unC arg2]
1495 ------------ Types -------------------
1497 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1498 -> DsM (Core TH.TypeQ)
1499 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1500 = rep2 forallTName [tvars, ctxt, ty]
1502 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1503 repTvar (MkC s) = rep2 varTName [s]
1505 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1506 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1508 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1509 repTapps f [] = return f
1510 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1512 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1513 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1515 --------- Type constructors --------------
1517 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1518 repNamedTyCon (MkC s) = rep2 conTName [s]
1520 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1521 -- Note: not Core Int; it's easier to be direct here
1522 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1524 repArrowTyCon :: DsM (Core TH.TypeQ)
1525 repArrowTyCon = rep2 arrowTName []
1527 repListTyCon :: DsM (Core TH.TypeQ)
1528 repListTyCon = rep2 listTName []
1530 ------------ Kinds -------------------
1532 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1533 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1535 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1536 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1538 repStarK :: DsM (Core TH.Kind)
1539 repStarK = rep2 starKName []
1541 repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1542 repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2]
1544 ----------------------------------------------------------
1547 repLiteral :: HsLit -> DsM (Core TH.Lit)
1549 = do lit' <- case lit of
1550 HsIntPrim i -> mk_integer i
1551 HsWordPrim w -> mk_integer w
1552 HsInt i -> mk_integer i
1553 HsFloatPrim r -> mk_rational r
1554 HsDoublePrim r -> mk_rational r
1556 lit_expr <- dsLit lit'
1558 Just lit_name -> rep2 lit_name [lit_expr]
1559 Nothing -> notHandled "Exotic literal" (ppr lit)
1561 mb_lit_name = case lit of
1562 HsInteger _ _ -> Just integerLName
1563 HsInt _ -> Just integerLName
1564 HsIntPrim _ -> Just intPrimLName
1565 HsWordPrim _ -> Just wordPrimLName
1566 HsFloatPrim _ -> Just floatPrimLName
1567 HsDoublePrim _ -> Just doublePrimLName
1568 HsChar _ -> Just charLName
1569 HsString _ -> Just stringLName
1570 HsRat _ _ -> Just rationalLName
1573 mk_integer :: Integer -> DsM HsLit
1574 mk_integer i = do integer_ty <- lookupType integerTyConName
1575 return $ HsInteger i integer_ty
1576 mk_rational :: Rational -> DsM HsLit
1577 mk_rational r = do rat_ty <- lookupType rationalTyConName
1578 return $ HsRat r rat_ty
1579 mk_string :: FastString -> DsM HsLit
1580 mk_string s = return $ HsString s
1582 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1583 repOverloadedLiteral (OverLit { ol_val = val})
1584 = do { lit <- mk_lit val; repLiteral lit }
1585 -- The type Rational will be in the environment, becuase
1586 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1587 -- and rationalL is sucked in when any TH stuff is used
1589 mk_lit :: OverLitVal -> DsM HsLit
1590 mk_lit (HsIntegral i) = mk_integer i
1591 mk_lit (HsFractional f) = mk_rational f
1592 mk_lit (HsIsString s) = mk_string s
1594 --------------- Miscellaneous -------------------
1596 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1597 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1599 repBindQ :: Type -> Type -- a and b
1600 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1601 repBindQ ty_a ty_b (MkC x) (MkC y)
1602 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1604 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1605 repSequenceQ ty_a (MkC list)
1606 = rep2 sequenceQName [Type ty_a, list]
1608 ------------ Lists and Tuples -------------------
1609 -- turn a list of patterns into a single pattern matching a list
1611 coreList :: Name -- Of the TyCon of the element type
1612 -> [Core a] -> DsM (Core [a])
1614 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1616 coreList' :: Type -- The element type
1617 -> [Core a] -> Core [a]
1618 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1620 nonEmptyCoreList :: [Core a] -> Core [a]
1621 -- The list must be non-empty so we can get the element type
1622 -- Otherwise use coreList
1623 nonEmptyCoreList [] = panic "coreList: empty argument"
1624 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1626 coreStringLit :: String -> DsM (Core String)
1627 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1629 ------------ Bool, Literals & Variables -------------------
1631 coreBool :: Bool -> Core Bool
1632 coreBool False = MkC $ mkConApp falseDataCon []
1633 coreBool True = MkC $ mkConApp trueDataCon []
1635 coreIntLit :: Int -> DsM (Core Int)
1636 coreIntLit i = return (MkC (mkIntExprInt i))
1638 coreVar :: Id -> Core TH.Name -- The Id has type Name
1639 coreVar id = MkC (Var id)
1641 ----------------- Failure -----------------------
1642 notHandled :: String -> SDoc -> DsM a
1643 notHandled what doc = failWithDs msg
1645 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1649 -- %************************************************************************
1651 -- The known-key names for Template Haskell
1653 -- %************************************************************************
1655 -- To add a name, do three things
1657 -- 1) Allocate a key
1659 -- 3) Add the name to knownKeyNames
1661 templateHaskellNames :: [Name]
1662 -- The names that are implicitly mentioned by ``bracket''
1663 -- Should stay in sync with the import list of DsMeta
1665 templateHaskellNames = [
1666 returnQName, bindQName, sequenceQName, newNameName, liftName,
1667 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1670 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1671 floatPrimLName, doublePrimLName, rationalLName,
1673 litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
1674 asPName, wildPName, recPName, listPName, sigPName,
1682 varEName, conEName, litEName, appEName, infixEName,
1683 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1684 condEName, letEName, caseEName, doEName, compEName,
1685 fromEName, fromThenEName, fromToEName, fromThenToEName,
1686 listEName, sigEName, recConEName, recUpdEName,
1690 guardedBName, normalBName,
1692 normalGEName, patGEName,
1694 bindSName, letSName, noBindSName, parSName,
1696 funDName, valDName, dataDName, newtypeDName, tySynDName,
1697 classDName, instanceDName, sigDName, forImpDName,
1698 pragInlDName, pragSpecDName, pragSpecInlDName,
1699 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1704 classPName, equalPName,
1706 isStrictName, notStrictName,
1708 normalCName, recCName, infixCName, forallCName,
1714 forallTName, varTName, conTName, appTName,
1715 tupleTName, arrowTName, listTName, sigTName,
1717 plainTVName, kindedTVName,
1719 starKName, arrowKName,
1721 cCallName, stdCallName,
1727 inlineSpecNoPhaseName, inlineSpecPhaseName,
1731 typeFamName, dataFamName,
1734 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1735 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1736 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1737 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1738 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1739 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1740 predQTyConName, decsQTyConName,
1743 quoteDecName, quoteTypeName, quoteExpName, quotePatName]
1745 thSyn, thLib, qqLib :: Module
1746 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1747 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1748 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1750 mkTHModule :: FastString -> Module
1751 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1753 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1754 libFun = mk_known_key_name OccName.varName thLib
1755 libTc = mk_known_key_name OccName.tcName thLib
1756 thFun = mk_known_key_name OccName.varName thSyn
1757 thTc = mk_known_key_name OccName.tcName thSyn
1758 qqFun = mk_known_key_name OccName.varName qqLib
1760 -------------------- TH.Syntax -----------------------
1761 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1762 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1763 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1764 predTyConName :: Name
1765 qTyConName = thTc (fsLit "Q") qTyConKey
1766 nameTyConName = thTc (fsLit "Name") nameTyConKey
1767 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
1768 patTyConName = thTc (fsLit "Pat") patTyConKey
1769 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
1770 expTyConName = thTc (fsLit "Exp") expTyConKey
1771 decTyConName = thTc (fsLit "Dec") decTyConKey
1772 typeTyConName = thTc (fsLit "Type") typeTyConKey
1773 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
1774 matchTyConName = thTc (fsLit "Match") matchTyConKey
1775 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
1776 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
1777 predTyConName = thTc (fsLit "Pred") predTyConKey
1779 returnQName, bindQName, sequenceQName, newNameName, liftName,
1780 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1781 mkNameLName, liftStringName :: Name
1782 returnQName = thFun (fsLit "returnQ") returnQIdKey
1783 bindQName = thFun (fsLit "bindQ") bindQIdKey
1784 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1785 newNameName = thFun (fsLit "newName") newNameIdKey
1786 liftName = thFun (fsLit "lift") liftIdKey
1787 liftStringName = thFun (fsLit "liftString") liftStringIdKey
1788 mkNameName = thFun (fsLit "mkName") mkNameIdKey
1789 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
1790 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
1791 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1792 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
1795 -------------------- TH.Lib -----------------------
1797 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1798 floatPrimLName, doublePrimLName, rationalLName :: Name
1799 charLName = libFun (fsLit "charL") charLIdKey
1800 stringLName = libFun (fsLit "stringL") stringLIdKey
1801 integerLName = libFun (fsLit "integerL") integerLIdKey
1802 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
1803 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
1804 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
1805 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1806 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
1809 litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName,
1810 asPName, wildPName, recPName, listPName, sigPName :: Name
1811 litPName = libFun (fsLit "litP") litPIdKey
1812 varPName = libFun (fsLit "varP") varPIdKey
1813 tupPName = libFun (fsLit "tupP") tupPIdKey
1814 conPName = libFun (fsLit "conP") conPIdKey
1815 infixPName = libFun (fsLit "infixP") infixPIdKey
1816 tildePName = libFun (fsLit "tildeP") tildePIdKey
1817 bangPName = libFun (fsLit "bangP") bangPIdKey
1818 asPName = libFun (fsLit "asP") asPIdKey
1819 wildPName = libFun (fsLit "wildP") wildPIdKey
1820 recPName = libFun (fsLit "recP") recPIdKey
1821 listPName = libFun (fsLit "listP") listPIdKey
1822 sigPName = libFun (fsLit "sigP") sigPIdKey
1824 -- type FieldPat = ...
1825 fieldPatName :: Name
1826 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1830 matchName = libFun (fsLit "match") matchIdKey
1832 -- data Clause = ...
1834 clauseName = libFun (fsLit "clause") clauseIdKey
1837 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1838 sectionLName, sectionRName, lamEName, tupEName, condEName,
1839 letEName, caseEName, doEName, compEName :: Name
1840 varEName = libFun (fsLit "varE") varEIdKey
1841 conEName = libFun (fsLit "conE") conEIdKey
1842 litEName = libFun (fsLit "litE") litEIdKey
1843 appEName = libFun (fsLit "appE") appEIdKey
1844 infixEName = libFun (fsLit "infixE") infixEIdKey
1845 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
1846 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
1847 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
1848 lamEName = libFun (fsLit "lamE") lamEIdKey
1849 tupEName = libFun (fsLit "tupE") tupEIdKey
1850 condEName = libFun (fsLit "condE") condEIdKey
1851 letEName = libFun (fsLit "letE") letEIdKey
1852 caseEName = libFun (fsLit "caseE") caseEIdKey
1853 doEName = libFun (fsLit "doE") doEIdKey
1854 compEName = libFun (fsLit "compE") compEIdKey
1855 -- ArithSeq skips a level
1856 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1857 fromEName = libFun (fsLit "fromE") fromEIdKey
1858 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
1859 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
1860 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1862 listEName, sigEName, recConEName, recUpdEName :: Name
1863 listEName = libFun (fsLit "listE") listEIdKey
1864 sigEName = libFun (fsLit "sigE") sigEIdKey
1865 recConEName = libFun (fsLit "recConE") recConEIdKey
1866 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
1868 -- type FieldExp = ...
1869 fieldExpName :: Name
1870 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1873 guardedBName, normalBName :: Name
1874 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1875 normalBName = libFun (fsLit "normalB") normalBIdKey
1878 normalGEName, patGEName :: Name
1879 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1880 patGEName = libFun (fsLit "patGE") patGEIdKey
1883 bindSName, letSName, noBindSName, parSName :: Name
1884 bindSName = libFun (fsLit "bindS") bindSIdKey
1885 letSName = libFun (fsLit "letS") letSIdKey
1886 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1887 parSName = libFun (fsLit "parS") parSIdKey
1890 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1891 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
1892 pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
1893 newtypeInstDName, tySynInstDName :: Name
1894 funDName = libFun (fsLit "funD") funDIdKey
1895 valDName = libFun (fsLit "valD") valDIdKey
1896 dataDName = libFun (fsLit "dataD") dataDIdKey
1897 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
1898 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
1899 classDName = libFun (fsLit "classD") classDIdKey
1900 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
1901 sigDName = libFun (fsLit "sigD") sigDIdKey
1902 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
1903 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
1904 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
1905 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
1906 familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
1907 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
1908 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
1909 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1910 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
1914 cxtName = libFun (fsLit "cxt") cxtIdKey
1917 classPName, equalPName :: Name
1918 classPName = libFun (fsLit "classP") classPIdKey
1919 equalPName = libFun (fsLit "equalP") equalPIdKey
1921 -- data Strict = ...
1922 isStrictName, notStrictName :: Name
1923 isStrictName = libFun (fsLit "isStrict") isStrictKey
1924 notStrictName = libFun (fsLit "notStrict") notStrictKey
1927 normalCName, recCName, infixCName, forallCName :: Name
1928 normalCName = libFun (fsLit "normalC") normalCIdKey
1929 recCName = libFun (fsLit "recC") recCIdKey
1930 infixCName = libFun (fsLit "infixC") infixCIdKey
1931 forallCName = libFun (fsLit "forallC") forallCIdKey
1933 -- type StrictType = ...
1934 strictTypeName :: Name
1935 strictTypeName = libFun (fsLit "strictType") strictTKey
1937 -- type VarStrictType = ...
1938 varStrictTypeName :: Name
1939 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
1942 forallTName, varTName, conTName, tupleTName, arrowTName,
1943 listTName, appTName, sigTName :: Name
1944 forallTName = libFun (fsLit "forallT") forallTIdKey
1945 varTName = libFun (fsLit "varT") varTIdKey
1946 conTName = libFun (fsLit "conT") conTIdKey
1947 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
1948 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
1949 listTName = libFun (fsLit "listT") listTIdKey
1950 appTName = libFun (fsLit "appT") appTIdKey
1951 sigTName = libFun (fsLit "sigT") sigTIdKey
1953 -- data TyVarBndr = ...
1954 plainTVName, kindedTVName :: Name
1955 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
1956 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
1959 starKName, arrowKName :: Name
1960 starKName = libFun (fsLit "starK") starKIdKey
1961 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
1963 -- data Callconv = ...
1964 cCallName, stdCallName :: Name
1965 cCallName = libFun (fsLit "cCall") cCallIdKey
1966 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
1968 -- data Safety = ...
1969 unsafeName, safeName, threadsafeName :: Name
1970 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
1971 safeName = libFun (fsLit "safe") safeIdKey
1972 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
1974 -- data InlineSpec = ...
1975 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
1976 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
1977 inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
1979 -- data FunDep = ...
1981 funDepName = libFun (fsLit "funDep") funDepIdKey
1983 -- data FamFlavour = ...
1984 typeFamName, dataFamName :: Name
1985 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
1986 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
1988 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
1989 decQTyConName, conQTyConName, strictTypeQTyConName,
1990 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
1991 patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
1992 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
1993 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
1994 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
1995 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
1996 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
1997 decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
1998 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
1999 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
2000 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
2001 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
2002 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
2003 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
2004 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
2005 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
2008 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
2009 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
2010 quotePatName = qqFun (fsLit "quotePat") quotePatKey
2011 quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
2012 quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
2014 -- TyConUniques available: 100-129
2015 -- Check in PrelNames if you want to change this
2017 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2018 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2019 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2020 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2021 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2022 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2023 predQTyConKey, decsQTyConKey :: Unique
2024 expTyConKey = mkPreludeTyConUnique 100
2025 matchTyConKey = mkPreludeTyConUnique 101
2026 clauseTyConKey = mkPreludeTyConUnique 102
2027 qTyConKey = mkPreludeTyConUnique 103
2028 expQTyConKey = mkPreludeTyConUnique 104
2029 decQTyConKey = mkPreludeTyConUnique 105
2030 patTyConKey = mkPreludeTyConUnique 106
2031 matchQTyConKey = mkPreludeTyConUnique 107
2032 clauseQTyConKey = mkPreludeTyConUnique 108
2033 stmtQTyConKey = mkPreludeTyConUnique 109
2034 conQTyConKey = mkPreludeTyConUnique 110
2035 typeQTyConKey = mkPreludeTyConUnique 111
2036 typeTyConKey = mkPreludeTyConUnique 112
2037 decTyConKey = mkPreludeTyConUnique 113
2038 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
2039 strictTypeQTyConKey = mkPreludeTyConUnique 115
2040 fieldExpTyConKey = mkPreludeTyConUnique 116
2041 fieldPatTyConKey = mkPreludeTyConUnique 117
2042 nameTyConKey = mkPreludeTyConUnique 118
2043 patQTyConKey = mkPreludeTyConUnique 119
2044 fieldPatQTyConKey = mkPreludeTyConUnique 120
2045 fieldExpQTyConKey = mkPreludeTyConUnique 121
2046 funDepTyConKey = mkPreludeTyConUnique 122
2047 predTyConKey = mkPreludeTyConUnique 123
2048 predQTyConKey = mkPreludeTyConUnique 124
2049 tyVarBndrTyConKey = mkPreludeTyConUnique 125
2050 decsQTyConKey = mkPreludeTyConUnique 126
2052 -- IdUniques available: 200-399
2053 -- If you want to change this, make sure you check in PrelNames
2055 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2056 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2057 mkNameLIdKey :: Unique
2058 returnQIdKey = mkPreludeMiscIdUnique 200
2059 bindQIdKey = mkPreludeMiscIdUnique 201
2060 sequenceQIdKey = mkPreludeMiscIdUnique 202
2061 liftIdKey = mkPreludeMiscIdUnique 203
2062 newNameIdKey = mkPreludeMiscIdUnique 204
2063 mkNameIdKey = mkPreludeMiscIdUnique 205
2064 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2065 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2066 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2067 mkNameLIdKey = mkPreludeMiscIdUnique 209
2071 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2072 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2073 charLIdKey = mkPreludeMiscIdUnique 210
2074 stringLIdKey = mkPreludeMiscIdUnique 211
2075 integerLIdKey = mkPreludeMiscIdUnique 212
2076 intPrimLIdKey = mkPreludeMiscIdUnique 213
2077 wordPrimLIdKey = mkPreludeMiscIdUnique 214
2078 floatPrimLIdKey = mkPreludeMiscIdUnique 215
2079 doublePrimLIdKey = mkPreludeMiscIdUnique 216
2080 rationalLIdKey = mkPreludeMiscIdUnique 217
2082 liftStringIdKey :: Unique
2083 liftStringIdKey = mkPreludeMiscIdUnique 218
2086 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2087 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
2088 litPIdKey = mkPreludeMiscIdUnique 220
2089 varPIdKey = mkPreludeMiscIdUnique 221
2090 tupPIdKey = mkPreludeMiscIdUnique 222
2091 conPIdKey = mkPreludeMiscIdUnique 223
2092 infixPIdKey = mkPreludeMiscIdUnique 312
2093 tildePIdKey = mkPreludeMiscIdUnique 224
2094 bangPIdKey = mkPreludeMiscIdUnique 359
2095 asPIdKey = mkPreludeMiscIdUnique 225
2096 wildPIdKey = mkPreludeMiscIdUnique 226
2097 recPIdKey = mkPreludeMiscIdUnique 227
2098 listPIdKey = mkPreludeMiscIdUnique 228
2099 sigPIdKey = mkPreludeMiscIdUnique 229
2101 -- type FieldPat = ...
2102 fieldPatIdKey :: Unique
2103 fieldPatIdKey = mkPreludeMiscIdUnique 230
2106 matchIdKey :: Unique
2107 matchIdKey = mkPreludeMiscIdUnique 231
2109 -- data Clause = ...
2110 clauseIdKey :: Unique
2111 clauseIdKey = mkPreludeMiscIdUnique 232
2115 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2116 sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
2117 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2118 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2119 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2120 varEIdKey = mkPreludeMiscIdUnique 240
2121 conEIdKey = mkPreludeMiscIdUnique 241
2122 litEIdKey = mkPreludeMiscIdUnique 242
2123 appEIdKey = mkPreludeMiscIdUnique 243
2124 infixEIdKey = mkPreludeMiscIdUnique 244
2125 infixAppIdKey = mkPreludeMiscIdUnique 245
2126 sectionLIdKey = mkPreludeMiscIdUnique 246
2127 sectionRIdKey = mkPreludeMiscIdUnique 247
2128 lamEIdKey = mkPreludeMiscIdUnique 248
2129 tupEIdKey = mkPreludeMiscIdUnique 249
2130 condEIdKey = mkPreludeMiscIdUnique 250
2131 letEIdKey = mkPreludeMiscIdUnique 251
2132 caseEIdKey = mkPreludeMiscIdUnique 252
2133 doEIdKey = mkPreludeMiscIdUnique 253
2134 compEIdKey = mkPreludeMiscIdUnique 254
2135 fromEIdKey = mkPreludeMiscIdUnique 255
2136 fromThenEIdKey = mkPreludeMiscIdUnique 256
2137 fromToEIdKey = mkPreludeMiscIdUnique 257
2138 fromThenToEIdKey = mkPreludeMiscIdUnique 258
2139 listEIdKey = mkPreludeMiscIdUnique 259
2140 sigEIdKey = mkPreludeMiscIdUnique 260
2141 recConEIdKey = mkPreludeMiscIdUnique 261
2142 recUpdEIdKey = mkPreludeMiscIdUnique 262
2144 -- type FieldExp = ...
2145 fieldExpIdKey :: Unique
2146 fieldExpIdKey = mkPreludeMiscIdUnique 265
2149 guardedBIdKey, normalBIdKey :: Unique
2150 guardedBIdKey = mkPreludeMiscIdUnique 266
2151 normalBIdKey = mkPreludeMiscIdUnique 267
2154 normalGEIdKey, patGEIdKey :: Unique
2155 normalGEIdKey = mkPreludeMiscIdUnique 310
2156 patGEIdKey = mkPreludeMiscIdUnique 311
2159 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2160 bindSIdKey = mkPreludeMiscIdUnique 268
2161 letSIdKey = mkPreludeMiscIdUnique 269
2162 noBindSIdKey = mkPreludeMiscIdUnique 270
2163 parSIdKey = mkPreludeMiscIdUnique 271
2166 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2167 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2168 pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2169 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
2170 funDIdKey = mkPreludeMiscIdUnique 272
2171 valDIdKey = mkPreludeMiscIdUnique 273
2172 dataDIdKey = mkPreludeMiscIdUnique 274
2173 newtypeDIdKey = mkPreludeMiscIdUnique 275
2174 tySynDIdKey = mkPreludeMiscIdUnique 276
2175 classDIdKey = mkPreludeMiscIdUnique 277
2176 instanceDIdKey = mkPreludeMiscIdUnique 278
2177 sigDIdKey = mkPreludeMiscIdUnique 279
2178 forImpDIdKey = mkPreludeMiscIdUnique 297
2179 pragInlDIdKey = mkPreludeMiscIdUnique 348
2180 pragSpecDIdKey = mkPreludeMiscIdUnique 349
2181 pragSpecInlDIdKey = mkPreludeMiscIdUnique 352
2182 familyNoKindDIdKey= mkPreludeMiscIdUnique 340
2183 familyKindDIdKey = mkPreludeMiscIdUnique 353
2184 dataInstDIdKey = mkPreludeMiscIdUnique 341
2185 newtypeInstDIdKey = mkPreludeMiscIdUnique 342
2186 tySynInstDIdKey = mkPreludeMiscIdUnique 343
2190 cxtIdKey = mkPreludeMiscIdUnique 280
2193 classPIdKey, equalPIdKey :: Unique
2194 classPIdKey = mkPreludeMiscIdUnique 346
2195 equalPIdKey = mkPreludeMiscIdUnique 347
2197 -- data Strict = ...
2198 isStrictKey, notStrictKey :: Unique
2199 isStrictKey = mkPreludeMiscIdUnique 281
2200 notStrictKey = mkPreludeMiscIdUnique 282
2203 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2204 normalCIdKey = mkPreludeMiscIdUnique 283
2205 recCIdKey = mkPreludeMiscIdUnique 284
2206 infixCIdKey = mkPreludeMiscIdUnique 285
2207 forallCIdKey = mkPreludeMiscIdUnique 288
2209 -- type StrictType = ...
2210 strictTKey :: Unique
2211 strictTKey = mkPreludeMiscIdUnique 286
2213 -- type VarStrictType = ...
2214 varStrictTKey :: Unique
2215 varStrictTKey = mkPreludeMiscIdUnique 287
2218 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
2219 listTIdKey, appTIdKey, sigTIdKey :: Unique
2220 forallTIdKey = mkPreludeMiscIdUnique 290
2221 varTIdKey = mkPreludeMiscIdUnique 291
2222 conTIdKey = mkPreludeMiscIdUnique 292
2223 tupleTIdKey = mkPreludeMiscIdUnique 294
2224 arrowTIdKey = mkPreludeMiscIdUnique 295
2225 listTIdKey = mkPreludeMiscIdUnique 296
2226 appTIdKey = mkPreludeMiscIdUnique 293
2227 sigTIdKey = mkPreludeMiscIdUnique 358
2229 -- data TyVarBndr = ...
2230 plainTVIdKey, kindedTVIdKey :: Unique
2231 plainTVIdKey = mkPreludeMiscIdUnique 354
2232 kindedTVIdKey = mkPreludeMiscIdUnique 355
2235 starKIdKey, arrowKIdKey :: Unique
2236 starKIdKey = mkPreludeMiscIdUnique 356
2237 arrowKIdKey = mkPreludeMiscIdUnique 357
2239 -- data Callconv = ...
2240 cCallIdKey, stdCallIdKey :: Unique
2241 cCallIdKey = mkPreludeMiscIdUnique 300
2242 stdCallIdKey = mkPreludeMiscIdUnique 301
2244 -- data Safety = ...
2245 unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
2246 unsafeIdKey = mkPreludeMiscIdUnique 305
2247 safeIdKey = mkPreludeMiscIdUnique 306
2248 threadsafeIdKey = mkPreludeMiscIdUnique 307
2250 -- data InlineSpec =
2251 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2252 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350
2253 inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 351
2255 -- data FunDep = ...
2256 funDepIdKey :: Unique
2257 funDepIdKey = mkPreludeMiscIdUnique 320
2259 -- data FamFlavour = ...
2260 typeFamIdKey, dataFamIdKey :: Unique
2261 typeFamIdKey = mkPreludeMiscIdUnique 344
2262 dataFamIdKey = mkPreludeMiscIdUnique 345
2265 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2266 quoteExpKey = mkPreludeMiscIdUnique 321
2267 quotePatKey = mkPreludeMiscIdUnique 322
2268 quoteDecKey = mkPreludeMiscIdUnique 323
2269 quoteTypeKey = mkPreludeMiscIdUnique 324