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 = map unLoc (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 -> [Located 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, n <- tyClDeclNames (unLoc d)] ++
144 [n | L _ (ForeignImport 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 (collectHsBindBinders 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 _)) = repPlainTV
540 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) =
541 \nm -> repKind ki >>= repKindedTV nm
543 -- represent a type context
545 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
546 repLContext (L _ ctxt) = repContext ctxt
548 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
550 preds <- mapM repLPred ctxt
551 predList <- coreList predQTyConName preds
554 -- represent a type predicate
556 repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
557 repLPred (L _ p) = repPred p
559 repPred :: HsPred Name -> DsM (Core TH.PredQ)
560 repPred (HsClassP cls tys)
562 cls1 <- lookupOcc cls
564 tys2 <- coreList typeQTyConName tys1
566 repPred (HsEqualP tyleft tyright)
568 tyleft1 <- repLTy tyleft
569 tyright1 <- repLTy tyright
570 repEqualP tyleft1 tyright1
571 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
573 repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
574 repPredTy (HsClassP cls tys)
576 tcon <- repTy (HsTyVar cls)
579 repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
581 -- yield the representation of a list of types
583 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
584 repLTys tys = mapM repLTy tys
588 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
589 repLTy (L _ ty) = repTy ty
591 repTy :: HsType Name -> DsM (Core TH.TypeQ)
592 repTy (HsForAllTy _ tvs ctxt ty) =
593 addTyVarBinds tvs $ \bndrs -> do
594 ctxt1 <- repLContext ctxt
596 bndrs1 <- coreList tyVarBndrTyConName bndrs
597 repTForall bndrs1 ctxt1 ty1
600 | isTvOcc (nameOccName n) = do
606 repTy (HsAppTy f a) = do
610 repTy (HsFunTy f a) = do
613 tcon <- repArrowTyCon
614 repTapps tcon [f1, a1]
615 repTy (HsListTy t) = do
619 repTy (HsPArrTy t) = do
621 tcon <- repTy (HsTyVar (tyConName parrTyCon))
623 repTy (HsTupleTy _ tys) = do
625 tcon <- repTupleTyCon (length tys)
627 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
629 repTy (HsParTy t) = repLTy t
630 repTy (HsPredTy pred) = repPredTy pred
631 repTy (HsKindSig t k) = do
635 repTy (HsSpliceTy splice) = repSplice splice
636 repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
637 repTy ty = notHandled "Exotic form of type" (ppr ty)
641 repKind :: Kind -> DsM (Core TH.Kind)
643 = do { let (kis, ki') = splitKindFunTys ki
644 ; kis_rep <- mapM repKind kis
645 ; ki'_rep <- repNonArrowKind ki'
646 ; foldlM repArrowK ki'_rep kis_rep
649 repNonArrowKind k | isLiftedTypeKind k = repStarK
650 | otherwise = notHandled "Exotic form of kind"
653 -----------------------------------------------------------------------------
655 -----------------------------------------------------------------------------
657 repSplice :: HsSplice Name -> DsM (Core a)
658 -- See Note [How brackets and nested splices are handled] in TcSplice
659 -- We return a CoreExpr of any old type; the context should know
660 repSplice (HsSplice n _)
661 = do { mb_val <- dsLookupMetaEnv n
663 Just (Splice e) -> do { e' <- dsExpr e
665 _ -> pprPanic "HsSplice" (ppr n) }
666 -- Should not happen; statically checked
668 -----------------------------------------------------------------------------
670 -----------------------------------------------------------------------------
672 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
673 repLEs es = do { es' <- mapM repLE es ;
674 coreList expQTyConName es' }
676 -- FIXME: some of these panics should be converted into proper error messages
677 -- unless we can make sure that constructs, which are plainly not
678 -- supported in TH already lead to error messages at an earlier stage
679 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
680 repLE (L loc e) = putSrcSpanDs loc (repE e)
682 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
684 do { mb_val <- dsLookupMetaEnv x
686 Nothing -> do { str <- globalVar x
687 ; repVarOrCon x str }
688 Just (Bound y) -> repVarOrCon x (coreVar y)
689 Just (Splice e) -> do { e' <- dsExpr e
690 ; return (MkC e') } }
691 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
693 -- Remember, we're desugaring renamer output here, so
694 -- HsOverlit can definitely occur
695 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
696 repE (HsLit l) = do { a <- repLiteral l; repLit a }
697 repE (HsLam (MatchGroup [m] _)) = repLambda m
698 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
700 repE (OpApp e1 op _ e2) =
701 do { arg1 <- repLE e1;
704 repInfixApp arg1 the_op arg2 }
705 repE (NegApp x _) = do
707 negateVar <- lookupOcc negateName >>= repVar
709 repE (HsPar x) = repLE x
710 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
711 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
712 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
713 ; ms2 <- mapM repMatchTup ms
714 ; repCaseE arg (nonEmptyCoreList ms2) }
715 repE (HsIf x y z) = do
720 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
721 ; e2 <- addBinds ss (repLE e)
725 -- FIXME: I haven't got the types here right yet
726 repE e@(HsDo ctxt sts body _)
727 | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
728 = do { (ss,zs) <- repLSts sts;
729 body' <- addBinds ss $ repLE body;
730 ret <- repNoBindSt body';
731 e' <- repDoE (nonEmptyCoreList (zs ++ [ret]));
735 = do { (ss,zs) <- repLSts sts;
736 body' <- addBinds ss $ repLE body;
737 ret <- repNoBindSt body';
738 e' <- repComp (nonEmptyCoreList (zs ++ [ret]));
742 = notHandled "mdo and [: :]" (ppr e)
744 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
745 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
746 repE e@(ExplicitTuple es boxed)
747 | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e)
748 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
749 | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs }
751 repE (RecordCon c _ flds)
752 = do { x <- lookupLOcc c;
753 fs <- repFields flds;
755 repE (RecordUpd e flds _ _ _)
757 fs <- repFields flds;
760 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
761 repE (ArithSeq _ aseq) =
763 From e -> do { ds1 <- repLE e; repFrom ds1 }
772 FromThenTo e1 e2 e3 -> do
776 repFromThenTo ds1 ds2 ds3
778 repE (HsSpliceE splice) = repSplice splice
779 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
780 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
781 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
782 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
783 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
784 repE e = notHandled "Expression form" (ppr e)
786 -----------------------------------------------------------------------------
787 -- Building representations of auxillary structures like Match, Clause, Stmt,
789 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
790 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
791 do { ss1 <- mkGenSyms (collectPatBinders p)
792 ; addBinds ss1 $ do {
794 ; (ss2,ds) <- repBinds wheres
795 ; addBinds ss2 $ do {
796 ; gs <- repGuards guards
797 ; match <- repMatch p1 gs ds
798 ; wrapGenSyms (ss1++ss2) match }}}
799 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
801 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
802 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
803 do { ss1 <- mkGenSyms (collectPatsBinders ps)
804 ; addBinds ss1 $ do {
806 ; (ss2,ds) <- repBinds wheres
807 ; addBinds ss2 $ do {
808 gs <- repGuards guards
809 ; clause <- repClause ps1 gs ds
810 ; wrapGenSyms (ss1++ss2) clause }}}
812 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
813 repGuards [L _ (GRHS [] e)]
814 = do {a <- repLE e; repNormal a }
816 = do { zs <- mapM process other;
817 let {(xs, ys) = unzip zs};
818 gd <- repGuarded (nonEmptyCoreList ys);
819 wrapGenSyms (concat xs) gd }
821 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
822 process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
823 = do { x <- repLNormalGE e1 e2;
825 process (L _ (GRHS ss rhs))
826 = do (gs, ss') <- repLSts ss
827 rhs' <- addBinds gs $ repLE rhs
828 g <- repPatGE (nonEmptyCoreList ss') rhs'
831 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
832 repFields (HsRecFields { rec_flds = flds })
833 = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
834 ; es <- mapM repLE (map hsRecFieldArg flds)
835 ; fs <- zipWithM repFieldExp fnames es
836 ; coreList fieldExpQTyConName fs }
839 -----------------------------------------------------------------------------
840 -- Representing Stmt's is tricky, especially if bound variables
841 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
842 -- First gensym new names for every variable in any of the patterns.
843 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
844 -- if variables didn't shaddow, the static gensym wouldn't be necessary
845 -- and we could reuse the original names (x and x).
847 -- do { x'1 <- gensym "x"
848 -- ; x'2 <- gensym "x"
849 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
850 -- , BindSt (pvar x'2) [| f x |]
851 -- , NoBindSt [| g x |]
855 -- The strategy is to translate a whole list of do-bindings by building a
856 -- bigger environment, and a bigger set of meta bindings
857 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
858 -- of the expressions within the Do
860 -----------------------------------------------------------------------------
861 -- The helper function repSts computes the translation of each sub expression
862 -- and a bunch of prefix bindings denoting the dynamic renaming.
864 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
865 repLSts stmts = repSts (map unLoc stmts)
867 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
868 repSts (BindStmt p e _ _ : ss) =
870 ; ss1 <- mkGenSyms (collectPatBinders p)
871 ; addBinds ss1 $ do {
873 ; (ss2,zs) <- repSts ss
874 ; z <- repBindSt p1 e2
875 ; return (ss1++ss2, z : zs) }}
876 repSts (LetStmt bs : ss) =
877 do { (ss1,ds) <- repBinds bs
879 ; (ss2,zs) <- addBinds ss1 (repSts ss)
880 ; return (ss1++ss2, z : zs) }
881 repSts (ExprStmt e _ _ : ss) =
883 ; z <- repNoBindSt e2
884 ; (ss2,zs) <- repSts ss
885 ; return (ss2, z : zs) }
886 repSts [] = return ([],[])
887 repSts other = notHandled "Exotic statement" (ppr other)
890 -----------------------------------------------------------
892 -----------------------------------------------------------
894 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
895 repBinds EmptyLocalBinds
896 = do { core_list <- coreList decQTyConName []
897 ; return ([], core_list) }
899 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
901 repBinds (HsValBinds decs)
902 = do { let { bndrs = map unLoc (collectHsValBinders decs) }
903 -- No need to worrry about detailed scopes within
904 -- the binding group, because we are talking Names
905 -- here, so we can safely treat it as a mutually
907 ; ss <- mkGenSyms bndrs
908 ; prs <- addBinds ss (rep_val_binds decs)
909 ; core_list <- coreList decQTyConName
910 (de_loc (sort_by_loc prs))
911 ; return (ss, core_list) }
913 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
914 -- Assumes: all the binders of the binding are alrady in the meta-env
915 rep_val_binds (ValBindsOut binds sigs)
916 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
917 ; core2 <- rep_sigs' sigs
918 ; return (core1 ++ core2) }
919 rep_val_binds (ValBindsIn _ _)
920 = panic "rep_val_binds: ValBindsIn"
922 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
923 rep_binds binds = do { binds_w_locs <- rep_binds' binds
924 ; return (de_loc (sort_by_loc binds_w_locs)) }
926 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
927 rep_binds' binds = mapM rep_bind (bagToList binds)
929 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
930 -- Assumes: all the binders of the binding are alrady in the meta-env
932 -- Note GHC treats declarations of a variable (not a pattern)
933 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
934 -- with an empty list of patterns
935 rep_bind (L loc (FunBind { fun_id = fn,
936 fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
937 = do { (ss,wherecore) <- repBinds wheres
938 ; guardcore <- addBinds ss (repGuards guards)
939 ; fn' <- lookupLBinder fn
941 ; ans <- repVal p guardcore wherecore
942 ; ans' <- wrapGenSyms ss ans
943 ; return (loc, ans') }
945 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
946 = do { ms1 <- mapM repClauseTup ms
947 ; fn' <- lookupLBinder fn
948 ; ans <- repFun fn' (nonEmptyCoreList ms1)
949 ; return (loc, ans) }
951 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
952 = do { patcore <- repLP pat
953 ; (ss,wherecore) <- repBinds wheres
954 ; guardcore <- addBinds ss (repGuards guards)
955 ; ans <- repVal patcore guardcore wherecore
956 ; ans' <- wrapGenSyms ss ans
957 ; return (loc, ans') }
959 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
960 = do { v' <- lookupBinder v
963 ; patcore <- repPvar v'
964 ; empty_decls <- coreList decQTyConName []
965 ; ans <- repVal patcore x empty_decls
966 ; return (srcLocSpan (getSrcLoc v), ans) }
968 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
970 -----------------------------------------------------------------------------
971 -- Since everything in a Bind is mutually recursive we need rename all
972 -- all the variables simultaneously. For example:
973 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
974 -- do { f'1 <- gensym "f"
975 -- ; g'2 <- gensym "g"
976 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
977 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
979 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
980 -- environment ( f |-> f'1 ) from each binding, and then unioning them
981 -- together. As we do this we collect GenSymBinds's which represent the renamed
982 -- variables bound by the Bindings. In order not to lose track of these
983 -- representations we build a shadow datatype MB with the same structure as
984 -- MonoBinds, but which has slots for the representations
987 -----------------------------------------------------------------------------
988 -- GHC allows a more general form of lambda abstraction than specified
989 -- by Haskell 98. In particular it allows guarded lambda's like :
990 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
991 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
992 -- (\ p1 .. pn -> exp) by causing an error.
994 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
995 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
996 = do { let bndrs = collectPatsBinders ps ;
997 ; ss <- mkGenSyms bndrs
998 ; lam <- addBinds ss (
999 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1000 ; wrapGenSyms ss lam }
1002 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
1005 -----------------------------------------------------------------------------
1007 -- repP deals with patterns. It assumes that we have already
1008 -- walked over the pattern(s) once to collect the binders, and
1009 -- have extended the environment. So every pattern-bound
1010 -- variable should already appear in the environment.
1012 -- Process a list of patterns
1013 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1014 repLPs ps = do { ps' <- mapM repLP ps ;
1015 coreList patQTyConName ps' }
1017 repLP :: LPat Name -> DsM (Core TH.PatQ)
1018 repLP (L _ p) = repP p
1020 repP :: Pat Name -> DsM (Core TH.PatQ)
1021 repP (WildPat _) = repPwild
1022 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1023 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1024 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1025 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1026 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1027 repP (ParPat p) = repLP p
1028 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
1029 repP p@(TuplePat ps boxed _)
1030 | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p)
1031 | otherwise = do { qs <- repLPs ps; repPtup qs }
1032 repP (ConPatIn dc details)
1033 = do { con_str <- lookupLOcc dc
1035 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1036 RecCon rec -> do { let flds = rec_flds rec
1037 ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
1038 ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
1039 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
1040 ; fps' <- coreList fieldPatQTyConName fps
1041 ; repPrec con_str fps' }
1042 InfixCon p1 p2 -> do { p1' <- repLP p1;
1044 repPinfix p1' con_str p2' }
1046 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1047 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1048 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1049 -- The problem is to do with scoped type variables.
1050 -- To implement them, we have to implement the scoping rules
1051 -- here in DsMeta, and I don't want to do that today!
1052 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1053 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1054 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1056 repP other = notHandled "Exotic pattern" (ppr other)
1058 ----------------------------------------------------------
1059 -- Declaration ordering helpers
1061 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1062 sort_by_loc xs = sortBy comp xs
1063 where comp x y = compare (fst x) (fst y)
1065 de_loc :: [(a, b)] -> [b]
1068 ----------------------------------------------------------
1069 -- The meta-environment
1071 -- A name/identifier association for fresh names of locally bound entities
1072 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1073 -- I.e. (x, x_id) means
1074 -- let x_id = gensym "x" in ...
1076 -- Generate a fresh name for a locally bound entity
1078 mkGenSyms :: [Name] -> DsM [GenSymBind]
1079 -- We can use the existing name. For example:
1080 -- [| \x_77 -> x_77 + x_77 |]
1082 -- do { x_77 <- genSym "x"; .... }
1083 -- We use the same x_77 in the desugared program, but with the type Bndr
1086 -- We do make it an Internal name, though (hence localiseName)
1088 -- Nevertheless, it's monadic because we have to generate nameTy
1089 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1090 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1093 addBinds :: [GenSymBind] -> DsM a -> DsM a
1094 -- Add a list of fresh names for locally bound entities to the
1095 -- meta environment (which is part of the state carried around
1096 -- by the desugarer monad)
1097 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1099 -- Look up a locally bound name
1101 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1102 lookupLBinder (L _ n) = lookupBinder n
1104 lookupBinder :: Name -> DsM (Core TH.Name)
1106 = do { mb_val <- dsLookupMetaEnv n;
1108 Just (Bound x) -> return (coreVar x)
1109 _ -> failWithDs msg }
1111 msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
1113 -- Look up a name that is either locally bound or a global name
1115 -- * If it is a global name, generate the "original name" representation (ie,
1116 -- the <module>:<name> form) for the associated entity
1118 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1119 -- Lookup an occurrence; it can't be a splice.
1120 -- Use the in-scope bindings if they exist
1121 lookupLOcc (L _ n) = lookupOcc n
1123 lookupOcc :: Name -> DsM (Core TH.Name)
1125 = do { mb_val <- dsLookupMetaEnv n ;
1127 Nothing -> globalVar n
1128 Just (Bound x) -> return (coreVar x)
1129 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1132 lookupTvOcc :: Name -> DsM (Core TH.Name)
1133 -- Type variables can't be staged and are not lexically scoped in TH
1135 = do { mb_val <- dsLookupMetaEnv n ;
1137 Just (Bound x) -> return (coreVar x)
1141 msg = vcat [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n)
1142 , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ]
1144 globalVar :: Name -> DsM (Core TH.Name)
1145 -- Not bound by the meta-env
1146 -- Could be top-level; or could be local
1147 -- f x = $(g [| x |])
1148 -- Here the x will be local
1150 | isExternalName name
1151 = do { MkC mod <- coreStringLit name_mod
1152 ; MkC pkg <- coreStringLit name_pkg
1153 ; MkC occ <- occNameLit name
1154 ; rep2 mk_varg [pkg,mod,occ] }
1156 = do { MkC occ <- occNameLit name
1157 ; MkC uni <- coreIntLit (getKey (getUnique name))
1158 ; rep2 mkNameLName [occ,uni] }
1160 mod = ASSERT( isExternalName name) nameModule name
1161 name_mod = moduleNameString (moduleName mod)
1162 name_pkg = packageIdString (modulePackageId mod)
1163 name_occ = nameOccName name
1164 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1165 | OccName.isVarOcc name_occ = mkNameG_vName
1166 | OccName.isTcOcc name_occ = mkNameG_tcName
1167 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1169 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1170 -> DsM Type -- The type
1171 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1172 return (mkTyConApp tc []) }
1174 wrapGenSyms :: [GenSymBind]
1175 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1176 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1177 -- --> bindQ (gensym nm1) (\ id1 ->
1178 -- bindQ (gensym nm2 (\ id2 ->
1181 wrapGenSyms binds body@(MkC b)
1182 = do { var_ty <- lookupType nameTyConName
1185 [elt_ty] = tcTyConAppArgs (exprType b)
1186 -- b :: Q a, so we can get the type 'a' by looking at the
1187 -- argument type. NB: this relies on Q being a data/newtype,
1188 -- not a type synonym
1190 go _ [] = return body
1191 go var_ty ((name,id) : binds)
1192 = do { MkC body' <- go var_ty binds
1193 ; lit_str <- occNameLit name
1194 ; gensym_app <- repGensym lit_str
1195 ; repBindQ var_ty elt_ty
1196 gensym_app (MkC (Lam id body')) }
1198 -- Just like wrapGenSym, but don't actually do the gensym
1199 -- Instead use the existing name:
1200 -- let x = "x" in ...
1201 -- Only used for [Decl], and for the class ops in class
1202 -- and instance decls
1203 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
1204 wrapNongenSyms binds (MkC body)
1205 = do { binds' <- mapM do_one binds ;
1206 return (MkC (mkLets binds' body)) }
1209 = do { MkC lit_str <- occNameLit name
1210 ; MkC var <- rep2 mkNameName [lit_str]
1211 ; return (NonRec id var) }
1213 occNameLit :: Name -> DsM (Core String)
1214 occNameLit n = coreStringLit (occNameString (nameOccName n))
1217 -- %*********************************************************************
1219 -- Constructing code
1221 -- %*********************************************************************
1223 -----------------------------------------------------------------------------
1224 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1225 -- we invent a new datatype which uses phantom types.
1227 newtype Core a = MkC CoreExpr
1228 unC :: Core a -> CoreExpr
1231 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1232 rep2 n xs = do { id <- dsLookupGlobalId n
1233 ; return (MkC (foldl App (Var id) xs)) }
1235 -- Then we make "repConstructors" which use the phantom types for each of the
1236 -- smart constructors of the Meta.Meta datatypes.
1239 -- %*********************************************************************
1241 -- The 'smart constructors'
1243 -- %*********************************************************************
1245 --------------- Patterns -----------------
1246 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1247 repPlit (MkC l) = rep2 litPName [l]
1249 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1250 repPvar (MkC s) = rep2 varPName [s]
1252 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1253 repPtup (MkC ps) = rep2 tupPName [ps]
1255 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1256 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1258 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1259 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1261 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1262 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1264 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1265 repPtilde (MkC p) = rep2 tildePName [p]
1267 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1268 repPbang (MkC p) = rep2 bangPName [p]
1270 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1271 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1273 repPwild :: DsM (Core TH.PatQ)
1274 repPwild = rep2 wildPName []
1276 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1277 repPlist (MkC ps) = rep2 listPName [ps]
1279 --------------- Expressions -----------------
1280 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1281 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1282 | otherwise = repVar str
1284 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1285 repVar (MkC s) = rep2 varEName [s]
1287 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1288 repCon (MkC s) = rep2 conEName [s]
1290 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1291 repLit (MkC c) = rep2 litEName [c]
1293 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1294 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1296 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1297 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1299 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1300 repTup (MkC es) = rep2 tupEName [es]
1302 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1303 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1305 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1306 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1308 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1309 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1311 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1312 repDoE (MkC ss) = rep2 doEName [ss]
1314 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1315 repComp (MkC ss) = rep2 compEName [ss]
1317 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1318 repListExp (MkC es) = rep2 listEName [es]
1320 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1321 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1323 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1324 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1326 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1327 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1329 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1330 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1332 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1333 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1335 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1336 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1338 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1339 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1341 ------------ Right hand sides (guarded expressions) ----
1342 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1343 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1345 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1346 repNormal (MkC e) = rep2 normalBName [e]
1348 ------------ Guards ----
1349 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1350 repLNormalGE g e = do g' <- repLE g
1354 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1355 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1357 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1358 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1360 ------------- Stmts -------------------
1361 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1362 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1364 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1365 repLetSt (MkC ds) = rep2 letSName [ds]
1367 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1368 repNoBindSt (MkC e) = rep2 noBindSName [e]
1370 -------------- Range (Arithmetic sequences) -----------
1371 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1372 repFrom (MkC x) = rep2 fromEName [x]
1374 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1375 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1377 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1378 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1380 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1381 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1383 ------------ Match and Clause Tuples -----------
1384 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1385 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1387 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1388 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1390 -------------- Dec -----------------------------
1391 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1392 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1394 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1395 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1397 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1398 -> Maybe (Core [TH.TypeQ])
1399 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1400 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1401 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1402 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1403 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1405 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1406 -> Maybe (Core [TH.TypeQ])
1407 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1408 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1409 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1410 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1411 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1413 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1414 -> Maybe (Core [TH.TypeQ])
1415 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1416 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1417 = rep2 tySynDName [nm, tvs, rhs]
1418 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1419 = rep2 tySynInstDName [nm, tys, rhs]
1421 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1422 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1424 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1425 -> Core [TH.FunDep] -> Core [TH.DecQ]
1426 -> DsM (Core TH.DecQ)
1427 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1428 = rep2 classDName [cxt, cls, tvs, fds, ds]
1430 repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1431 repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1433 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1434 repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1436 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1437 -> DsM (Core TH.DecQ)
1438 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1439 = rep2 pragSpecInlDName [nm, ty, ispec]
1441 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1442 -> DsM (Core TH.DecQ)
1443 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1444 = rep2 familyNoKindDName [flav, nm, tvs]
1446 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1448 -> DsM (Core TH.DecQ)
1449 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1450 = rep2 familyKindDName [flav, nm, tvs, ki]
1452 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
1453 repInlineSpecNoPhase (MkC inline) (MkC conlike)
1454 = rep2 inlineSpecNoPhaseName [inline, conlike]
1456 repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int
1457 -> DsM (Core TH.InlineSpecQ)
1458 repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1459 = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1461 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1462 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1464 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1465 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1467 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1468 repCtxt (MkC tys) = rep2 cxtName [tys]
1470 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1471 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1473 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1474 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1476 repConstr :: Core TH.Name -> HsConDeclDetails Name
1477 -> DsM (Core TH.ConQ)
1478 repConstr con (PrefixCon ps)
1479 = do arg_tys <- mapM repBangTy ps
1480 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1481 rep2 normalCName [unC con, unC arg_tys1]
1482 repConstr con (RecCon ips)
1483 = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
1484 arg_tys <- mapM repBangTy (map cd_fld_type ips)
1485 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1487 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1488 rep2 recCName [unC con, unC arg_vtys']
1489 repConstr con (InfixCon st1 st2)
1490 = do arg1 <- repBangTy st1
1491 arg2 <- repBangTy st2
1492 rep2 infixCName [unC arg1, unC con, unC arg2]
1494 ------------ Types -------------------
1496 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1497 -> DsM (Core TH.TypeQ)
1498 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1499 = rep2 forallTName [tvars, ctxt, ty]
1501 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1502 repTvar (MkC s) = rep2 varTName [s]
1504 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1505 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1507 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1508 repTapps f [] = return f
1509 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1511 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1512 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1514 --------- Type constructors --------------
1516 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1517 repNamedTyCon (MkC s) = rep2 conTName [s]
1519 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1520 -- Note: not Core Int; it's easier to be direct here
1521 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1523 repArrowTyCon :: DsM (Core TH.TypeQ)
1524 repArrowTyCon = rep2 arrowTName []
1526 repListTyCon :: DsM (Core TH.TypeQ)
1527 repListTyCon = rep2 listTName []
1529 ------------ Kinds -------------------
1531 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1532 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1534 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1535 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1537 repStarK :: DsM (Core TH.Kind)
1538 repStarK = rep2 starKName []
1540 repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1541 repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2]
1543 ----------------------------------------------------------
1546 repLiteral :: HsLit -> DsM (Core TH.Lit)
1548 = do lit' <- case lit of
1549 HsIntPrim i -> mk_integer i
1550 HsWordPrim w -> mk_integer w
1551 HsInt i -> mk_integer i
1552 HsFloatPrim r -> mk_rational r
1553 HsDoublePrim r -> mk_rational r
1555 lit_expr <- dsLit lit'
1557 Just lit_name -> rep2 lit_name [lit_expr]
1558 Nothing -> notHandled "Exotic literal" (ppr lit)
1560 mb_lit_name = case lit of
1561 HsInteger _ _ -> Just integerLName
1562 HsInt _ -> Just integerLName
1563 HsIntPrim _ -> Just intPrimLName
1564 HsWordPrim _ -> Just wordPrimLName
1565 HsFloatPrim _ -> Just floatPrimLName
1566 HsDoublePrim _ -> Just doublePrimLName
1567 HsChar _ -> Just charLName
1568 HsString _ -> Just stringLName
1569 HsRat _ _ -> Just rationalLName
1572 mk_integer :: Integer -> DsM HsLit
1573 mk_integer i = do integer_ty <- lookupType integerTyConName
1574 return $ HsInteger i integer_ty
1575 mk_rational :: Rational -> DsM HsLit
1576 mk_rational r = do rat_ty <- lookupType rationalTyConName
1577 return $ HsRat r rat_ty
1578 mk_string :: FastString -> DsM HsLit
1579 mk_string s = return $ HsString s
1581 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1582 repOverloadedLiteral (OverLit { ol_val = val})
1583 = do { lit <- mk_lit val; repLiteral lit }
1584 -- The type Rational will be in the environment, becuase
1585 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1586 -- and rationalL is sucked in when any TH stuff is used
1588 mk_lit :: OverLitVal -> DsM HsLit
1589 mk_lit (HsIntegral i) = mk_integer i
1590 mk_lit (HsFractional f) = mk_rational f
1591 mk_lit (HsIsString s) = mk_string s
1593 --------------- Miscellaneous -------------------
1595 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1596 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1598 repBindQ :: Type -> Type -- a and b
1599 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1600 repBindQ ty_a ty_b (MkC x) (MkC y)
1601 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1603 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1604 repSequenceQ ty_a (MkC list)
1605 = rep2 sequenceQName [Type ty_a, list]
1607 ------------ Lists and Tuples -------------------
1608 -- turn a list of patterns into a single pattern matching a list
1610 coreList :: Name -- Of the TyCon of the element type
1611 -> [Core a] -> DsM (Core [a])
1613 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1615 coreList' :: Type -- The element type
1616 -> [Core a] -> Core [a]
1617 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1619 nonEmptyCoreList :: [Core a] -> Core [a]
1620 -- The list must be non-empty so we can get the element type
1621 -- Otherwise use coreList
1622 nonEmptyCoreList [] = panic "coreList: empty argument"
1623 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1625 coreStringLit :: String -> DsM (Core String)
1626 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1628 ------------ Bool, Literals & Variables -------------------
1630 coreBool :: Bool -> Core Bool
1631 coreBool False = MkC $ mkConApp falseDataCon []
1632 coreBool True = MkC $ mkConApp trueDataCon []
1634 coreIntLit :: Int -> DsM (Core Int)
1635 coreIntLit i = return (MkC (mkIntExprInt i))
1637 coreVar :: Id -> Core TH.Name -- The Id has type Name
1638 coreVar id = MkC (Var id)
1640 ----------------- Failure -----------------------
1641 notHandled :: String -> SDoc -> DsM a
1642 notHandled what doc = failWithDs msg
1644 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1648 -- %************************************************************************
1650 -- The known-key names for Template Haskell
1652 -- %************************************************************************
1654 -- To add a name, do three things
1656 -- 1) Allocate a key
1658 -- 3) Add the name to knownKeyNames
1660 templateHaskellNames :: [Name]
1661 -- The names that are implicitly mentioned by ``bracket''
1662 -- Should stay in sync with the import list of DsMeta
1664 templateHaskellNames = [
1665 returnQName, bindQName, sequenceQName, newNameName, liftName,
1666 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1669 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1670 floatPrimLName, doublePrimLName, rationalLName,
1672 litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
1673 asPName, wildPName, recPName, listPName, sigPName,
1681 varEName, conEName, litEName, appEName, infixEName,
1682 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1683 condEName, letEName, caseEName, doEName, compEName,
1684 fromEName, fromThenEName, fromToEName, fromThenToEName,
1685 listEName, sigEName, recConEName, recUpdEName,
1689 guardedBName, normalBName,
1691 normalGEName, patGEName,
1693 bindSName, letSName, noBindSName, parSName,
1695 funDName, valDName, dataDName, newtypeDName, tySynDName,
1696 classDName, instanceDName, sigDName, forImpDName,
1697 pragInlDName, pragSpecDName, pragSpecInlDName,
1698 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1703 classPName, equalPName,
1705 isStrictName, notStrictName,
1707 normalCName, recCName, infixCName, forallCName,
1713 forallTName, varTName, conTName, appTName,
1714 tupleTName, arrowTName, listTName, sigTName,
1716 plainTVName, kindedTVName,
1718 starKName, arrowKName,
1720 cCallName, stdCallName,
1726 inlineSpecNoPhaseName, inlineSpecPhaseName,
1730 typeFamName, dataFamName,
1733 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1734 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1735 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1736 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1737 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1738 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1739 predQTyConName, decsQTyConName,
1742 quoteDecName, quoteTypeName, quoteExpName, quotePatName]
1744 thSyn, thLib, qqLib :: Module
1745 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1746 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1747 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1749 mkTHModule :: FastString -> Module
1750 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1752 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1753 libFun = mk_known_key_name OccName.varName thLib
1754 libTc = mk_known_key_name OccName.tcName thLib
1755 thFun = mk_known_key_name OccName.varName thSyn
1756 thTc = mk_known_key_name OccName.tcName thSyn
1757 qqFun = mk_known_key_name OccName.varName qqLib
1759 -------------------- TH.Syntax -----------------------
1760 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1761 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1762 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1763 predTyConName :: Name
1764 qTyConName = thTc (fsLit "Q") qTyConKey
1765 nameTyConName = thTc (fsLit "Name") nameTyConKey
1766 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
1767 patTyConName = thTc (fsLit "Pat") patTyConKey
1768 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
1769 expTyConName = thTc (fsLit "Exp") expTyConKey
1770 decTyConName = thTc (fsLit "Dec") decTyConKey
1771 typeTyConName = thTc (fsLit "Type") typeTyConKey
1772 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
1773 matchTyConName = thTc (fsLit "Match") matchTyConKey
1774 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
1775 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
1776 predTyConName = thTc (fsLit "Pred") predTyConKey
1778 returnQName, bindQName, sequenceQName, newNameName, liftName,
1779 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1780 mkNameLName, liftStringName :: Name
1781 returnQName = thFun (fsLit "returnQ") returnQIdKey
1782 bindQName = thFun (fsLit "bindQ") bindQIdKey
1783 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1784 newNameName = thFun (fsLit "newName") newNameIdKey
1785 liftName = thFun (fsLit "lift") liftIdKey
1786 liftStringName = thFun (fsLit "liftString") liftStringIdKey
1787 mkNameName = thFun (fsLit "mkName") mkNameIdKey
1788 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
1789 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
1790 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1791 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
1794 -------------------- TH.Lib -----------------------
1796 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1797 floatPrimLName, doublePrimLName, rationalLName :: Name
1798 charLName = libFun (fsLit "charL") charLIdKey
1799 stringLName = libFun (fsLit "stringL") stringLIdKey
1800 integerLName = libFun (fsLit "integerL") integerLIdKey
1801 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
1802 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
1803 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
1804 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1805 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
1808 litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName,
1809 asPName, wildPName, recPName, listPName, sigPName :: Name
1810 litPName = libFun (fsLit "litP") litPIdKey
1811 varPName = libFun (fsLit "varP") varPIdKey
1812 tupPName = libFun (fsLit "tupP") tupPIdKey
1813 conPName = libFun (fsLit "conP") conPIdKey
1814 infixPName = libFun (fsLit "infixP") infixPIdKey
1815 tildePName = libFun (fsLit "tildeP") tildePIdKey
1816 bangPName = libFun (fsLit "bangP") bangPIdKey
1817 asPName = libFun (fsLit "asP") asPIdKey
1818 wildPName = libFun (fsLit "wildP") wildPIdKey
1819 recPName = libFun (fsLit "recP") recPIdKey
1820 listPName = libFun (fsLit "listP") listPIdKey
1821 sigPName = libFun (fsLit "sigP") sigPIdKey
1823 -- type FieldPat = ...
1824 fieldPatName :: Name
1825 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1829 matchName = libFun (fsLit "match") matchIdKey
1831 -- data Clause = ...
1833 clauseName = libFun (fsLit "clause") clauseIdKey
1836 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1837 sectionLName, sectionRName, lamEName, tupEName, condEName,
1838 letEName, caseEName, doEName, compEName :: Name
1839 varEName = libFun (fsLit "varE") varEIdKey
1840 conEName = libFun (fsLit "conE") conEIdKey
1841 litEName = libFun (fsLit "litE") litEIdKey
1842 appEName = libFun (fsLit "appE") appEIdKey
1843 infixEName = libFun (fsLit "infixE") infixEIdKey
1844 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
1845 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
1846 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
1847 lamEName = libFun (fsLit "lamE") lamEIdKey
1848 tupEName = libFun (fsLit "tupE") tupEIdKey
1849 condEName = libFun (fsLit "condE") condEIdKey
1850 letEName = libFun (fsLit "letE") letEIdKey
1851 caseEName = libFun (fsLit "caseE") caseEIdKey
1852 doEName = libFun (fsLit "doE") doEIdKey
1853 compEName = libFun (fsLit "compE") compEIdKey
1854 -- ArithSeq skips a level
1855 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1856 fromEName = libFun (fsLit "fromE") fromEIdKey
1857 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
1858 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
1859 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1861 listEName, sigEName, recConEName, recUpdEName :: Name
1862 listEName = libFun (fsLit "listE") listEIdKey
1863 sigEName = libFun (fsLit "sigE") sigEIdKey
1864 recConEName = libFun (fsLit "recConE") recConEIdKey
1865 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
1867 -- type FieldExp = ...
1868 fieldExpName :: Name
1869 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1872 guardedBName, normalBName :: Name
1873 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1874 normalBName = libFun (fsLit "normalB") normalBIdKey
1877 normalGEName, patGEName :: Name
1878 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1879 patGEName = libFun (fsLit "patGE") patGEIdKey
1882 bindSName, letSName, noBindSName, parSName :: Name
1883 bindSName = libFun (fsLit "bindS") bindSIdKey
1884 letSName = libFun (fsLit "letS") letSIdKey
1885 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1886 parSName = libFun (fsLit "parS") parSIdKey
1889 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1890 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
1891 pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
1892 newtypeInstDName, tySynInstDName :: Name
1893 funDName = libFun (fsLit "funD") funDIdKey
1894 valDName = libFun (fsLit "valD") valDIdKey
1895 dataDName = libFun (fsLit "dataD") dataDIdKey
1896 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
1897 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
1898 classDName = libFun (fsLit "classD") classDIdKey
1899 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
1900 sigDName = libFun (fsLit "sigD") sigDIdKey
1901 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
1902 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
1903 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
1904 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
1905 familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
1906 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
1907 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
1908 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1909 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
1913 cxtName = libFun (fsLit "cxt") cxtIdKey
1916 classPName, equalPName :: Name
1917 classPName = libFun (fsLit "classP") classPIdKey
1918 equalPName = libFun (fsLit "equalP") equalPIdKey
1920 -- data Strict = ...
1921 isStrictName, notStrictName :: Name
1922 isStrictName = libFun (fsLit "isStrict") isStrictKey
1923 notStrictName = libFun (fsLit "notStrict") notStrictKey
1926 normalCName, recCName, infixCName, forallCName :: Name
1927 normalCName = libFun (fsLit "normalC") normalCIdKey
1928 recCName = libFun (fsLit "recC") recCIdKey
1929 infixCName = libFun (fsLit "infixC") infixCIdKey
1930 forallCName = libFun (fsLit "forallC") forallCIdKey
1932 -- type StrictType = ...
1933 strictTypeName :: Name
1934 strictTypeName = libFun (fsLit "strictType") strictTKey
1936 -- type VarStrictType = ...
1937 varStrictTypeName :: Name
1938 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
1941 forallTName, varTName, conTName, tupleTName, arrowTName,
1942 listTName, appTName, sigTName :: Name
1943 forallTName = libFun (fsLit "forallT") forallTIdKey
1944 varTName = libFun (fsLit "varT") varTIdKey
1945 conTName = libFun (fsLit "conT") conTIdKey
1946 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
1947 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
1948 listTName = libFun (fsLit "listT") listTIdKey
1949 appTName = libFun (fsLit "appT") appTIdKey
1950 sigTName = libFun (fsLit "sigT") sigTIdKey
1952 -- data TyVarBndr = ...
1953 plainTVName, kindedTVName :: Name
1954 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
1955 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
1958 starKName, arrowKName :: Name
1959 starKName = libFun (fsLit "starK") starKIdKey
1960 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
1962 -- data Callconv = ...
1963 cCallName, stdCallName :: Name
1964 cCallName = libFun (fsLit "cCall") cCallIdKey
1965 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
1967 -- data Safety = ...
1968 unsafeName, safeName, threadsafeName :: Name
1969 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
1970 safeName = libFun (fsLit "safe") safeIdKey
1971 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
1973 -- data InlineSpec = ...
1974 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
1975 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
1976 inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
1978 -- data FunDep = ...
1980 funDepName = libFun (fsLit "funDep") funDepIdKey
1982 -- data FamFlavour = ...
1983 typeFamName, dataFamName :: Name
1984 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
1985 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
1987 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
1988 decQTyConName, conQTyConName, strictTypeQTyConName,
1989 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
1990 patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
1991 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
1992 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
1993 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
1994 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
1995 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
1996 decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
1997 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
1998 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
1999 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
2000 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
2001 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
2002 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
2003 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
2004 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
2007 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
2008 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
2009 quotePatName = qqFun (fsLit "quotePat") quotePatKey
2010 quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
2011 quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
2013 -- TyConUniques available: 100-129
2014 -- Check in PrelNames if you want to change this
2016 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2017 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2018 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2019 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2020 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2021 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2022 predQTyConKey, decsQTyConKey :: Unique
2023 expTyConKey = mkPreludeTyConUnique 100
2024 matchTyConKey = mkPreludeTyConUnique 101
2025 clauseTyConKey = mkPreludeTyConUnique 102
2026 qTyConKey = mkPreludeTyConUnique 103
2027 expQTyConKey = mkPreludeTyConUnique 104
2028 decQTyConKey = mkPreludeTyConUnique 105
2029 patTyConKey = mkPreludeTyConUnique 106
2030 matchQTyConKey = mkPreludeTyConUnique 107
2031 clauseQTyConKey = mkPreludeTyConUnique 108
2032 stmtQTyConKey = mkPreludeTyConUnique 109
2033 conQTyConKey = mkPreludeTyConUnique 110
2034 typeQTyConKey = mkPreludeTyConUnique 111
2035 typeTyConKey = mkPreludeTyConUnique 112
2036 decTyConKey = mkPreludeTyConUnique 113
2037 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
2038 strictTypeQTyConKey = mkPreludeTyConUnique 115
2039 fieldExpTyConKey = mkPreludeTyConUnique 116
2040 fieldPatTyConKey = mkPreludeTyConUnique 117
2041 nameTyConKey = mkPreludeTyConUnique 118
2042 patQTyConKey = mkPreludeTyConUnique 119
2043 fieldPatQTyConKey = mkPreludeTyConUnique 120
2044 fieldExpQTyConKey = mkPreludeTyConUnique 121
2045 funDepTyConKey = mkPreludeTyConUnique 122
2046 predTyConKey = mkPreludeTyConUnique 123
2047 predQTyConKey = mkPreludeTyConUnique 124
2048 tyVarBndrTyConKey = mkPreludeTyConUnique 125
2049 decsQTyConKey = mkPreludeTyConUnique 126
2051 -- IdUniques available: 200-399
2052 -- If you want to change this, make sure you check in PrelNames
2054 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2055 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2056 mkNameLIdKey :: Unique
2057 returnQIdKey = mkPreludeMiscIdUnique 200
2058 bindQIdKey = mkPreludeMiscIdUnique 201
2059 sequenceQIdKey = mkPreludeMiscIdUnique 202
2060 liftIdKey = mkPreludeMiscIdUnique 203
2061 newNameIdKey = mkPreludeMiscIdUnique 204
2062 mkNameIdKey = mkPreludeMiscIdUnique 205
2063 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2064 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2065 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2066 mkNameLIdKey = mkPreludeMiscIdUnique 209
2070 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2071 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2072 charLIdKey = mkPreludeMiscIdUnique 210
2073 stringLIdKey = mkPreludeMiscIdUnique 211
2074 integerLIdKey = mkPreludeMiscIdUnique 212
2075 intPrimLIdKey = mkPreludeMiscIdUnique 213
2076 wordPrimLIdKey = mkPreludeMiscIdUnique 214
2077 floatPrimLIdKey = mkPreludeMiscIdUnique 215
2078 doublePrimLIdKey = mkPreludeMiscIdUnique 216
2079 rationalLIdKey = mkPreludeMiscIdUnique 217
2081 liftStringIdKey :: Unique
2082 liftStringIdKey = mkPreludeMiscIdUnique 218
2085 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2086 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
2087 litPIdKey = mkPreludeMiscIdUnique 220
2088 varPIdKey = mkPreludeMiscIdUnique 221
2089 tupPIdKey = mkPreludeMiscIdUnique 222
2090 conPIdKey = mkPreludeMiscIdUnique 223
2091 infixPIdKey = mkPreludeMiscIdUnique 312
2092 tildePIdKey = mkPreludeMiscIdUnique 224
2093 bangPIdKey = mkPreludeMiscIdUnique 359
2094 asPIdKey = mkPreludeMiscIdUnique 225
2095 wildPIdKey = mkPreludeMiscIdUnique 226
2096 recPIdKey = mkPreludeMiscIdUnique 227
2097 listPIdKey = mkPreludeMiscIdUnique 228
2098 sigPIdKey = mkPreludeMiscIdUnique 229
2100 -- type FieldPat = ...
2101 fieldPatIdKey :: Unique
2102 fieldPatIdKey = mkPreludeMiscIdUnique 230
2105 matchIdKey :: Unique
2106 matchIdKey = mkPreludeMiscIdUnique 231
2108 -- data Clause = ...
2109 clauseIdKey :: Unique
2110 clauseIdKey = mkPreludeMiscIdUnique 232
2114 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2115 sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
2116 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2117 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2118 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2119 varEIdKey = mkPreludeMiscIdUnique 240
2120 conEIdKey = mkPreludeMiscIdUnique 241
2121 litEIdKey = mkPreludeMiscIdUnique 242
2122 appEIdKey = mkPreludeMiscIdUnique 243
2123 infixEIdKey = mkPreludeMiscIdUnique 244
2124 infixAppIdKey = mkPreludeMiscIdUnique 245
2125 sectionLIdKey = mkPreludeMiscIdUnique 246
2126 sectionRIdKey = mkPreludeMiscIdUnique 247
2127 lamEIdKey = mkPreludeMiscIdUnique 248
2128 tupEIdKey = mkPreludeMiscIdUnique 249
2129 condEIdKey = mkPreludeMiscIdUnique 250
2130 letEIdKey = mkPreludeMiscIdUnique 251
2131 caseEIdKey = mkPreludeMiscIdUnique 252
2132 doEIdKey = mkPreludeMiscIdUnique 253
2133 compEIdKey = mkPreludeMiscIdUnique 254
2134 fromEIdKey = mkPreludeMiscIdUnique 255
2135 fromThenEIdKey = mkPreludeMiscIdUnique 256
2136 fromToEIdKey = mkPreludeMiscIdUnique 257
2137 fromThenToEIdKey = mkPreludeMiscIdUnique 258
2138 listEIdKey = mkPreludeMiscIdUnique 259
2139 sigEIdKey = mkPreludeMiscIdUnique 260
2140 recConEIdKey = mkPreludeMiscIdUnique 261
2141 recUpdEIdKey = mkPreludeMiscIdUnique 262
2143 -- type FieldExp = ...
2144 fieldExpIdKey :: Unique
2145 fieldExpIdKey = mkPreludeMiscIdUnique 265
2148 guardedBIdKey, normalBIdKey :: Unique
2149 guardedBIdKey = mkPreludeMiscIdUnique 266
2150 normalBIdKey = mkPreludeMiscIdUnique 267
2153 normalGEIdKey, patGEIdKey :: Unique
2154 normalGEIdKey = mkPreludeMiscIdUnique 310
2155 patGEIdKey = mkPreludeMiscIdUnique 311
2158 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2159 bindSIdKey = mkPreludeMiscIdUnique 268
2160 letSIdKey = mkPreludeMiscIdUnique 269
2161 noBindSIdKey = mkPreludeMiscIdUnique 270
2162 parSIdKey = mkPreludeMiscIdUnique 271
2165 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2166 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2167 pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2168 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
2169 funDIdKey = mkPreludeMiscIdUnique 272
2170 valDIdKey = mkPreludeMiscIdUnique 273
2171 dataDIdKey = mkPreludeMiscIdUnique 274
2172 newtypeDIdKey = mkPreludeMiscIdUnique 275
2173 tySynDIdKey = mkPreludeMiscIdUnique 276
2174 classDIdKey = mkPreludeMiscIdUnique 277
2175 instanceDIdKey = mkPreludeMiscIdUnique 278
2176 sigDIdKey = mkPreludeMiscIdUnique 279
2177 forImpDIdKey = mkPreludeMiscIdUnique 297
2178 pragInlDIdKey = mkPreludeMiscIdUnique 348
2179 pragSpecDIdKey = mkPreludeMiscIdUnique 349
2180 pragSpecInlDIdKey = mkPreludeMiscIdUnique 352
2181 familyNoKindDIdKey= mkPreludeMiscIdUnique 340
2182 familyKindDIdKey = mkPreludeMiscIdUnique 353
2183 dataInstDIdKey = mkPreludeMiscIdUnique 341
2184 newtypeInstDIdKey = mkPreludeMiscIdUnique 342
2185 tySynInstDIdKey = mkPreludeMiscIdUnique 343
2189 cxtIdKey = mkPreludeMiscIdUnique 280
2192 classPIdKey, equalPIdKey :: Unique
2193 classPIdKey = mkPreludeMiscIdUnique 346
2194 equalPIdKey = mkPreludeMiscIdUnique 347
2196 -- data Strict = ...
2197 isStrictKey, notStrictKey :: Unique
2198 isStrictKey = mkPreludeMiscIdUnique 281
2199 notStrictKey = mkPreludeMiscIdUnique 282
2202 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2203 normalCIdKey = mkPreludeMiscIdUnique 283
2204 recCIdKey = mkPreludeMiscIdUnique 284
2205 infixCIdKey = mkPreludeMiscIdUnique 285
2206 forallCIdKey = mkPreludeMiscIdUnique 288
2208 -- type StrictType = ...
2209 strictTKey :: Unique
2210 strictTKey = mkPreludeMiscIdUnique 286
2212 -- type VarStrictType = ...
2213 varStrictTKey :: Unique
2214 varStrictTKey = mkPreludeMiscIdUnique 287
2217 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
2218 listTIdKey, appTIdKey, sigTIdKey :: Unique
2219 forallTIdKey = mkPreludeMiscIdUnique 290
2220 varTIdKey = mkPreludeMiscIdUnique 291
2221 conTIdKey = mkPreludeMiscIdUnique 292
2222 tupleTIdKey = mkPreludeMiscIdUnique 294
2223 arrowTIdKey = mkPreludeMiscIdUnique 295
2224 listTIdKey = mkPreludeMiscIdUnique 296
2225 appTIdKey = mkPreludeMiscIdUnique 293
2226 sigTIdKey = mkPreludeMiscIdUnique 358
2228 -- data TyVarBndr = ...
2229 plainTVIdKey, kindedTVIdKey :: Unique
2230 plainTVIdKey = mkPreludeMiscIdUnique 354
2231 kindedTVIdKey = mkPreludeMiscIdUnique 355
2234 starKIdKey, arrowKIdKey :: Unique
2235 starKIdKey = mkPreludeMiscIdUnique 356
2236 arrowKIdKey = mkPreludeMiscIdUnique 357
2238 -- data Callconv = ...
2239 cCallIdKey, stdCallIdKey :: Unique
2240 cCallIdKey = mkPreludeMiscIdUnique 300
2241 stdCallIdKey = mkPreludeMiscIdUnique 301
2243 -- data Safety = ...
2244 unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
2245 unsafeIdKey = mkPreludeMiscIdUnique 305
2246 safeIdKey = mkPreludeMiscIdUnique 306
2247 threadsafeIdKey = mkPreludeMiscIdUnique 307
2249 -- data InlineSpec =
2250 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2251 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350
2252 inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 351
2254 -- data FunDep = ...
2255 funDepIdKey :: Unique
2256 funDepIdKey = mkPreludeMiscIdUnique 320
2258 -- data FamFlavour = ...
2259 typeFamIdKey, dataFamIdKey :: Unique
2260 typeFamIdKey = mkPreludeMiscIdUnique 344
2261 dataFamIdKey = mkPreludeMiscIdUnique 345
2264 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2265 quoteExpKey = mkPreludeMiscIdUnique 321
2266 quotePatKey = mkPreludeMiscIdUnique 322
2267 quoteDecKey = mkPreludeMiscIdUnique 323
2268 quoteTypeKey = mkPreludeMiscIdUnique 324