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 = hsGroupBinders 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 (concat (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
139 {- Note [Binders and occurrences]
140 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
141 When we desugar [d| data T = MkT |]
143 Data "T" [] [Con "MkT" []] []
145 Data "Foo:T" [] [Con "Foo:MkT" []] []
146 That is, the new data decl should fit into whatever new module it is
147 asked to fit in. We do *not* clone, though; no need for this:
154 then we must desugar to
155 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
157 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
158 And we use lookupOcc, rather than lookupBinder
159 in repTyClD and repC.
163 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
165 repTyClD tydecl@(L _ (TyFamily {}))
166 = repTyFamily tydecl addTyVarBinds
168 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
169 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
170 tcdCons = cons, tcdDerivs = mb_derivs }))
171 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
172 ; dec <- addTyVarBinds tvs $ \bndrs ->
173 do { cxt1 <- repLContext cxt
174 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
175 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
176 ; cons1 <- mapM repC cons
177 ; cons2 <- coreList conQTyConName cons1
178 ; derivs1 <- repDerivs mb_derivs
179 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
180 ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1
182 ; return $ Just (loc, dec)
185 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
186 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
187 tcdCons = [con], tcdDerivs = mb_derivs }))
188 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
189 ; dec <- addTyVarBinds tvs $ \bndrs ->
190 do { cxt1 <- repLContext cxt
191 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
192 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
194 ; derivs1 <- repDerivs mb_derivs
195 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
196 ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
198 ; return $ Just (loc, dec)
201 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
203 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
204 ; dec <- addTyVarBinds tvs $ \bndrs ->
205 do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
206 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
208 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
209 ; repTySyn tc1 bndrs1 opt_tys2 ty1
211 ; return (Just (loc, dec))
214 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
215 tcdTyVars = tvs, tcdFDs = fds,
216 tcdSigs = sigs, tcdMeths = meth_binds,
218 = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
219 ; dec <- addTyVarBinds tvs $ \bndrs ->
220 do { cxt1 <- repLContext cxt
221 ; sigs1 <- rep_sigs sigs
222 ; binds1 <- rep_binds meth_binds
223 ; fds1 <- repLFunDeps fds
224 ; ats1 <- repLAssocFamilys ats
225 ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
226 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
227 ; repClass cxt1 cls1 bndrs1 fds1 decls1
229 ; return $ Just (loc, dec)
233 repTyClD (L loc d) = putSrcSpanDs loc $
234 do { warnDs (hang ds_msg 4 (ppr d))
237 -- The type variables in the head of families are treated differently when the
238 -- family declaration is associated. In that case, they are usage, not binding
241 repTyFamily :: LTyClDecl Name
242 -> ProcessTyVarBinds TH.Dec
243 -> DsM (Maybe (SrcSpan, Core TH.DecQ))
244 repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
245 tcdLName = tc, tcdTyVars = tvs,
246 tcdKind = opt_kind }))
248 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
249 ; dec <- tyVarBinds tvs $ \bndrs ->
250 do { flav <- repFamilyFlavour flavour
251 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
253 Nothing -> repFamilyNoKind flav tc1 bndrs1
254 Just ki -> do { ki1 <- repKind ki
255 ; repFamilyKind flav tc1 bndrs1 ki1
258 ; return $ Just (loc, dec)
260 repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
264 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
265 repLFunDeps fds = do fds' <- mapM repLFunDep fds
266 fdList <- coreList funDepTyConName fds'
269 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
270 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
271 ys' <- mapM lookupBinder ys
272 xs_list <- coreList nameTyConName xs'
273 ys_list <- coreList nameTyConName ys'
274 repFunDep xs_list ys_list
276 -- represent family declaration flavours
278 repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
279 repFamilyFlavour TypeFamily = rep2 typeFamName []
280 repFamilyFlavour DataFamily = rep2 dataFamName []
282 -- represent associated family declarations
284 repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
285 repLAssocFamilys = mapM repLAssocFamily
287 repLAssocFamily tydecl@(L _ (TyFamily {}))
288 = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
289 repLAssocFamily tydecl
292 msg = ptext (sLit "Illegal associated declaration in class:") <+>
295 -- represent associated family instances
297 repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
298 repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
300 -- represent instance declarations
302 repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
303 repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
304 = do { i <- addTyVarBinds tvs $ \_ ->
305 -- We must bring the type variables into scope, so their
306 -- occurrences don't fail, even though the binders don't
307 -- appear in the resulting data structure
308 do { cxt1 <- repContext cxt
309 ; inst_ty1 <- repPredTy (HsClassP cls tys)
310 ; ss <- mkGenSyms (collectHsBindsBinders binds)
311 ; binds1 <- addBinds ss (rep_binds binds)
312 ; ats1 <- repLAssocFamInst ats
313 ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
314 ; decls2 <- wrapNongenSyms ss decls1
315 -- wrapNongenSyms: do not clone the class op names!
316 -- They must be called 'op' etc, not 'op34'
317 ; repInst cxt1 inst_ty1 (decls2)
321 (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
323 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
324 repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
325 = do MkC name' <- lookupLOcc name
326 MkC typ' <- repLTy typ
327 MkC cc' <- repCCallConv cc
328 MkC s' <- repSafety s
329 cis' <- conv_cimportspec cis
330 MkC str <- coreStringLit $ static
331 ++ unpackFS ch ++ " "
333 dec <- rep2 forImpDName [cc', s', str, name', typ']
336 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
337 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
338 conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
339 conv_cimportspec CWrapper = return "wrapper"
341 CFunction (StaticTarget _ _) -> "static "
343 repForD decl = notHandled "Foreign declaration" (ppr decl)
345 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
346 repCCallConv CCallConv = rep2 cCallName []
347 repCCallConv StdCallConv = rep2 stdCallName []
348 repCCallConv callConv = notHandled "repCCallConv" (ppr callConv)
350 repSafety :: Safety -> DsM (Core TH.Safety)
351 repSafety PlayRisky = rep2 unsafeName []
352 repSafety PlayInterruptible = rep2 interruptibleName []
353 repSafety (PlaySafe False) = rep2 safeName []
354 repSafety (PlaySafe True) = rep2 threadsafeName []
357 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
359 -------------------------------------------------------
361 -------------------------------------------------------
363 repC :: LConDecl Name -> DsM (Core TH.ConQ)
364 repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
365 , con_details = details, con_res = ResTyH98 }))
366 = do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
367 ; repConstr con1 details
369 repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 }))
370 = addTyVarBinds tvs $ \bndrs ->
371 do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] }))
372 ; ctxt' <- repContext ctxt
373 ; bndrs' <- coreList tyVarBndrTyConName bndrs
374 ; rep2 forallCName [unC bndrs', unC ctxt', unC c']
376 repC (L loc con_decl) -- GADTs
378 notHandled "GADT declaration" (ppr con_decl)
380 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
384 rep2 strictTypeName [s, t]
386 (str, ty') = case ty of
387 L _ (HsBangTy _ ty) -> (isStrictName, ty)
388 _ -> (notStrictName, ty)
390 -------------------------------------------------------
392 -------------------------------------------------------
394 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
395 repDerivs Nothing = coreList nameTyConName []
396 repDerivs (Just ctxt)
397 = do { strs <- mapM rep_deriv ctxt ;
398 coreList nameTyConName strs }
400 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
401 -- Deriving clauses must have the simple H98 form
402 rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
403 rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
406 -------------------------------------------------------
407 -- Signatures in a class decl, or a group of bindings
408 -------------------------------------------------------
410 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
411 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
412 return $ de_loc $ sort_by_loc locs_cores
414 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
415 -- We silently ignore ones we don't recognise
416 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
417 return (concat sigs1) }
419 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
421 -- Empty => Too hard, signature ignored
422 rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
423 rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
424 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
425 rep_sig _ = return []
427 rep_proto :: Located Name -> LHsType Name -> SrcSpan
428 -> DsM [(SrcSpan, Core TH.DecQ)]
430 = do { nm1 <- lookupLOcc nm
432 ; sig <- repProto nm1 ty1
433 ; return [(loc, sig)]
436 rep_inline :: Located Name
437 -> InlinePragma -- Never defaultInlinePragma
439 -> DsM [(SrcSpan, Core TH.DecQ)]
440 rep_inline nm ispec loc
441 = do { nm1 <- lookupLOcc nm
442 ; ispec1 <- rep_InlinePrag ispec
443 ; pragma <- repPragInl nm1 ispec1
444 ; return [(loc, pragma)]
447 rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
448 -> DsM [(SrcSpan, Core TH.DecQ)]
449 rep_specialise nm ty ispec loc
450 = do { nm1 <- lookupLOcc nm
452 ; pragma <- if isDefaultInlinePragma ispec
453 then repPragSpec nm1 ty1 -- SPECIALISE
454 else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE
455 ; repPragSpecInl nm1 ty1 ispec1 }
456 ; return [(loc, pragma)]
459 -- Extract all the information needed to build a TH.InlinePrag
461 rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
462 -> DsM (Core TH.InlineSpecQ)
463 rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
464 | Just (flag, phase) <- activation1
465 = repInlineSpecPhase inline1 match1 flag phase
467 = repInlineSpecNoPhase inline1 match1
469 match1 = coreBool (rep_RuleMatchInfo match)
470 activation1 = rep_Activation activation
471 inline1 = case inline of
472 Inline -> coreBool True
473 _other -> coreBool False
474 -- We have no representation for Inlinable
476 rep_RuleMatchInfo FunLike = False
477 rep_RuleMatchInfo ConLike = True
479 rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive
480 rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive
481 rep_Activation (ActiveBefore phase) = Just (coreBool False,
482 MkC $ mkIntExprInt phase)
483 rep_Activation (ActiveAfter phase) = Just (coreBool True,
484 MkC $ mkIntExprInt phase)
487 -------------------------------------------------------
489 -------------------------------------------------------
491 -- We process type variable bindings in two ways, either by generating fresh
492 -- names or looking up existing names. The difference is crucial for type
493 -- families, depending on whether they are associated or not.
495 type ProcessTyVarBinds a =
496 [LHsTyVarBndr Name] -- the binders to be added
497 -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
498 -> DsM (Core (TH.Q a))
500 -- gensym a list of type variables and enter them into the meta environment;
501 -- the computations passed as the second argument is executed in that extended
502 -- meta environment and gets the *new* names on Core-level as an argument
504 addTyVarBinds :: ProcessTyVarBinds a
505 addTyVarBinds tvs m =
507 let names = hsLTyVarNames tvs
508 mkWithKinds = map repTyVarBndrWithKind tvs
509 freshNames <- mkGenSyms names
510 term <- addBinds freshNames $ do
511 bndrs <- mapM lookupBinder names
512 kindedBndrs <- zipWithM ($) mkWithKinds bndrs
514 wrapGenSyms freshNames term
516 -- Look up a list of type variables; the computations passed as the second
517 -- argument gets the *new* names on Core-level as an argument
519 lookupTyVarBinds :: ProcessTyVarBinds a
520 lookupTyVarBinds tvs m =
522 let names = hsLTyVarNames tvs
523 mkWithKinds = map repTyVarBndrWithKind tvs
524 bndrs <- mapM lookupBinder names
525 kindedBndrs <- zipWithM ($) mkWithKinds bndrs
528 -- Produce kinded binder constructors from the Haskell tyvar binders
530 repTyVarBndrWithKind :: LHsTyVarBndr Name
531 -> Core TH.Name -> DsM (Core TH.TyVarBndr)
532 repTyVarBndrWithKind (L _ (UserTyVar {})) nm
534 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
535 = repKind ki >>= repKindedTV nm
537 -- represent a type context
539 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
540 repLContext (L _ ctxt) = repContext ctxt
542 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
544 preds <- mapM repLPred ctxt
545 predList <- coreList predQTyConName preds
548 -- represent a type predicate
550 repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
551 repLPred (L _ p) = repPred p
553 repPred :: HsPred Name -> DsM (Core TH.PredQ)
554 repPred (HsClassP cls tys)
556 cls1 <- lookupOcc cls
558 tys2 <- coreList typeQTyConName tys1
560 repPred (HsEqualP tyleft tyright)
562 tyleft1 <- repLTy tyleft
563 tyright1 <- repLTy tyright
564 repEqualP tyleft1 tyright1
565 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
567 repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
568 repPredTy (HsClassP cls tys)
570 tcon <- repTy (HsTyVar cls)
573 repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
575 -- yield the representation of a list of types
577 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
578 repLTys tys = mapM repLTy tys
582 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
583 repLTy (L _ ty) = repTy ty
585 repTy :: HsType Name -> DsM (Core TH.TypeQ)
586 repTy (HsForAllTy _ tvs ctxt ty) =
587 addTyVarBinds tvs $ \bndrs -> do
588 ctxt1 <- repLContext ctxt
590 bndrs1 <- coreList tyVarBndrTyConName bndrs
591 repTForall bndrs1 ctxt1 ty1
594 | isTvOcc (nameOccName n) = do
600 repTy (HsAppTy f a) = do
604 repTy (HsFunTy f a) = do
607 tcon <- repArrowTyCon
608 repTapps tcon [f1, a1]
609 repTy (HsListTy t) = do
613 repTy (HsPArrTy t) = do
615 tcon <- repTy (HsTyVar (tyConName parrTyCon))
617 repTy (HsTupleTy Boxed tys) = do
619 tcon <- repTupleTyCon (length tys)
621 repTy (HsTupleTy Unboxed tys) = do
623 tcon <- repUnboxedTupleTyCon (length tys)
625 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
627 repTy (HsParTy t) = repLTy t
628 repTy (HsPredTy pred) = repPredTy pred
629 repTy (HsKindSig t k) = do
633 repTy (HsSpliceTy splice _ _) = repSplice splice
634 repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
635 repTy ty = notHandled "Exotic form of type" (ppr ty)
639 repKind :: Kind -> DsM (Core TH.Kind)
641 = do { let (kis, ki') = splitKindFunTys ki
642 ; kis_rep <- mapM repKind kis
643 ; ki'_rep <- repNonArrowKind ki'
644 ; foldrM repArrowK ki'_rep kis_rep
647 repNonArrowKind k | isLiftedTypeKind k = repStarK
648 | otherwise = notHandled "Exotic form of kind"
651 -----------------------------------------------------------------------------
653 -----------------------------------------------------------------------------
655 repSplice :: HsSplice Name -> DsM (Core a)
656 -- See Note [How brackets and nested splices are handled] in TcSplice
657 -- We return a CoreExpr of any old type; the context should know
658 repSplice (HsSplice n _)
659 = do { mb_val <- dsLookupMetaEnv n
661 Just (Splice e) -> do { e' <- dsExpr e
663 _ -> pprPanic "HsSplice" (ppr n) }
664 -- Should not happen; statically checked
666 -----------------------------------------------------------------------------
668 -----------------------------------------------------------------------------
670 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
671 repLEs es = do { es' <- mapM repLE es ;
672 coreList expQTyConName es' }
674 -- FIXME: some of these panics should be converted into proper error messages
675 -- unless we can make sure that constructs, which are plainly not
676 -- supported in TH already lead to error messages at an earlier stage
677 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
678 repLE (L loc e) = putSrcSpanDs loc (repE e)
680 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
682 do { mb_val <- dsLookupMetaEnv x
684 Nothing -> do { str <- globalVar x
685 ; repVarOrCon x str }
686 Just (Bound y) -> repVarOrCon x (coreVar y)
687 Just (Splice e) -> do { e' <- dsExpr e
688 ; return (MkC e') } }
689 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
691 -- Remember, we're desugaring renamer output here, so
692 -- HsOverlit can definitely occur
693 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
694 repE (HsLit l) = do { a <- repLiteral l; repLit a }
695 repE (HsLam (MatchGroup [m] _)) = repLambda m
696 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
698 repE (OpApp e1 op _ e2) =
699 do { arg1 <- repLE e1;
702 repInfixApp arg1 the_op arg2 }
703 repE (NegApp x _) = do
705 negateVar <- lookupOcc negateName >>= repVar
707 repE (HsPar x) = repLE x
708 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
709 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
710 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
711 ; ms2 <- mapM repMatchTup ms
712 ; repCaseE arg (nonEmptyCoreList ms2) }
713 repE (HsIf _ x y z) = do
718 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
719 ; e2 <- addBinds ss (repLE e)
723 -- FIXME: I haven't got the types here right yet
724 repE e@(HsDo ctxt sts body _ _)
725 | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
726 = do { (ss,zs) <- repLSts sts;
727 body' <- addBinds ss $ repLE body;
728 ret <- repNoBindSt body';
729 e' <- repDoE (nonEmptyCoreList (zs ++ [ret]));
733 = do { (ss,zs) <- repLSts sts;
734 body' <- addBinds ss $ repLE body;
735 ret <- repNoBindSt body';
736 e' <- repComp (nonEmptyCoreList (zs ++ [ret]));
740 = notHandled "mdo, monad comprehension and [: :]" (ppr e)
742 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
743 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
744 repE e@(ExplicitTuple es boxed)
745 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
746 | isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs }
747 | otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs }
749 repE (RecordCon c _ flds)
750 = do { x <- lookupLOcc c;
751 fs <- repFields flds;
753 repE (RecordUpd e flds _ _ _)
755 fs <- repFields flds;
758 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
759 repE (ArithSeq _ aseq) =
761 From e -> do { ds1 <- repLE e; repFrom ds1 }
770 FromThenTo e1 e2 e3 -> do
774 repFromThenTo ds1 ds2 ds3
776 repE (HsSpliceE splice) = repSplice splice
777 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
778 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
779 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
780 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
781 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
782 repE e = notHandled "Expression form" (ppr e)
784 -----------------------------------------------------------------------------
785 -- Building representations of auxillary structures like Match, Clause, Stmt,
787 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
788 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
789 do { ss1 <- mkGenSyms (collectPatBinders p)
790 ; addBinds ss1 $ do {
792 ; (ss2,ds) <- repBinds wheres
793 ; addBinds ss2 $ do {
794 ; gs <- repGuards guards
795 ; match <- repMatch p1 gs ds
796 ; wrapGenSyms (ss1++ss2) match }}}
797 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
799 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
800 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
801 do { ss1 <- mkGenSyms (collectPatsBinders ps)
802 ; addBinds ss1 $ do {
804 ; (ss2,ds) <- repBinds wheres
805 ; addBinds ss2 $ do {
806 gs <- repGuards guards
807 ; clause <- repClause ps1 gs ds
808 ; wrapGenSyms (ss1++ss2) clause }}}
810 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
811 repGuards [L _ (GRHS [] e)]
812 = do {a <- repLE e; repNormal a }
814 = do { zs <- mapM process other;
815 let {(xs, ys) = unzip zs};
816 gd <- repGuarded (nonEmptyCoreList ys);
817 wrapGenSyms (concat xs) gd }
819 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
820 process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
821 = do { x <- repLNormalGE e1 e2;
823 process (L _ (GRHS ss rhs))
824 = do (gs, ss') <- repLSts ss
825 rhs' <- addBinds gs $ repLE rhs
826 g <- repPatGE (nonEmptyCoreList ss') rhs'
829 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
830 repFields (HsRecFields { rec_flds = flds })
831 = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
832 ; es <- mapM repLE (map hsRecFieldArg flds)
833 ; fs <- zipWithM repFieldExp fnames es
834 ; coreList fieldExpQTyConName fs }
837 -----------------------------------------------------------------------------
838 -- Representing Stmt's is tricky, especially if bound variables
839 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
840 -- First gensym new names for every variable in any of the patterns.
841 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
842 -- if variables didn't shaddow, the static gensym wouldn't be necessary
843 -- and we could reuse the original names (x and x).
845 -- do { x'1 <- gensym "x"
846 -- ; x'2 <- gensym "x"
847 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
848 -- , BindSt (pvar x'2) [| f x |]
849 -- , NoBindSt [| g x |]
853 -- The strategy is to translate a whole list of do-bindings by building a
854 -- bigger environment, and a bigger set of meta bindings
855 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
856 -- of the expressions within the Do
858 -----------------------------------------------------------------------------
859 -- The helper function repSts computes the translation of each sub expression
860 -- and a bunch of prefix bindings denoting the dynamic renaming.
862 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
863 repLSts stmts = repSts (map unLoc stmts)
865 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
866 repSts (BindStmt p e _ _ : ss) =
868 ; ss1 <- mkGenSyms (collectPatBinders p)
869 ; addBinds ss1 $ do {
871 ; (ss2,zs) <- repSts ss
872 ; z <- repBindSt p1 e2
873 ; return (ss1++ss2, z : zs) }}
874 repSts (LetStmt bs : ss) =
875 do { (ss1,ds) <- repBinds bs
877 ; (ss2,zs) <- addBinds ss1 (repSts ss)
878 ; return (ss1++ss2, z : zs) }
879 repSts (ExprStmt e _ _ _ : ss) =
881 ; z <- repNoBindSt e2
882 ; (ss2,zs) <- repSts ss
883 ; return (ss2, z : zs) }
884 repSts [] = return ([],[])
885 repSts other = notHandled "Exotic statement" (ppr other)
888 -----------------------------------------------------------
890 -----------------------------------------------------------
892 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
893 repBinds EmptyLocalBinds
894 = do { core_list <- coreList decQTyConName []
895 ; return ([], core_list) }
897 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
899 repBinds (HsValBinds decs)
900 = do { let { bndrs = collectHsValBinders decs }
901 -- No need to worrry about detailed scopes within
902 -- the binding group, because we are talking Names
903 -- here, so we can safely treat it as a mutually
905 ; ss <- mkGenSyms bndrs
906 ; prs <- addBinds ss (rep_val_binds decs)
907 ; core_list <- coreList decQTyConName
908 (de_loc (sort_by_loc prs))
909 ; return (ss, core_list) }
911 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
912 -- Assumes: all the binders of the binding are alrady in the meta-env
913 rep_val_binds (ValBindsOut binds sigs)
914 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
915 ; core2 <- rep_sigs' sigs
916 ; return (core1 ++ core2) }
917 rep_val_binds (ValBindsIn _ _)
918 = panic "rep_val_binds: ValBindsIn"
920 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
921 rep_binds binds = do { binds_w_locs <- rep_binds' binds
922 ; return (de_loc (sort_by_loc binds_w_locs)) }
924 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
925 rep_binds' binds = mapM rep_bind (bagToList binds)
927 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
928 -- Assumes: all the binders of the binding are alrady in the meta-env
930 -- Note GHC treats declarations of a variable (not a pattern)
931 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
932 -- with an empty list of patterns
933 rep_bind (L loc (FunBind { fun_id = fn,
934 fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
935 = do { (ss,wherecore) <- repBinds wheres
936 ; guardcore <- addBinds ss (repGuards guards)
937 ; fn' <- lookupLBinder fn
939 ; ans <- repVal p guardcore wherecore
940 ; ans' <- wrapGenSyms ss ans
941 ; return (loc, ans') }
943 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
944 = do { ms1 <- mapM repClauseTup ms
945 ; fn' <- lookupLBinder fn
946 ; ans <- repFun fn' (nonEmptyCoreList ms1)
947 ; return (loc, ans) }
949 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
950 = do { patcore <- repLP pat
951 ; (ss,wherecore) <- repBinds wheres
952 ; guardcore <- addBinds ss (repGuards guards)
953 ; ans <- repVal patcore guardcore wherecore
954 ; ans' <- wrapGenSyms ss ans
955 ; return (loc, ans') }
957 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
958 = do { v' <- lookupBinder v
961 ; patcore <- repPvar v'
962 ; empty_decls <- coreList decQTyConName []
963 ; ans <- repVal patcore x empty_decls
964 ; return (srcLocSpan (getSrcLoc v), ans) }
966 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
968 -----------------------------------------------------------------------------
969 -- Since everything in a Bind is mutually recursive we need rename all
970 -- all the variables simultaneously. For example:
971 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
972 -- do { f'1 <- gensym "f"
973 -- ; g'2 <- gensym "g"
974 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
975 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
977 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
978 -- environment ( f |-> f'1 ) from each binding, and then unioning them
979 -- together. As we do this we collect GenSymBinds's which represent the renamed
980 -- variables bound by the Bindings. In order not to lose track of these
981 -- representations we build a shadow datatype MB with the same structure as
982 -- MonoBinds, but which has slots for the representations
985 -----------------------------------------------------------------------------
986 -- GHC allows a more general form of lambda abstraction than specified
987 -- by Haskell 98. In particular it allows guarded lambda's like :
988 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
989 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
990 -- (\ p1 .. pn -> exp) by causing an error.
992 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
993 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
994 = do { let bndrs = collectPatsBinders ps ;
995 ; ss <- mkGenSyms bndrs
996 ; lam <- addBinds ss (
997 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
998 ; wrapGenSyms ss lam }
1000 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
1003 -----------------------------------------------------------------------------
1005 -- repP deals with patterns. It assumes that we have already
1006 -- walked over the pattern(s) once to collect the binders, and
1007 -- have extended the environment. So every pattern-bound
1008 -- variable should already appear in the environment.
1010 -- Process a list of patterns
1011 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1012 repLPs ps = do { ps' <- mapM repLP ps ;
1013 coreList patQTyConName ps' }
1015 repLP :: LPat Name -> DsM (Core TH.PatQ)
1016 repLP (L _ p) = repP p
1018 repP :: Pat Name -> DsM (Core TH.PatQ)
1019 repP (WildPat _) = repPwild
1020 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1021 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1022 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1023 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1024 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1025 repP (ParPat p) = repLP p
1026 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
1027 repP (TuplePat ps boxed _)
1028 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1029 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1030 repP (ConPatIn dc details)
1031 = do { con_str <- lookupLOcc dc
1033 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1034 RecCon rec -> do { let flds = rec_flds rec
1035 ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
1036 ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
1037 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
1038 ; fps' <- coreList fieldPatQTyConName fps
1039 ; repPrec con_str fps' }
1040 InfixCon p1 p2 -> do { p1' <- repLP p1;
1042 repPinfix p1' con_str p2' }
1044 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1045 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1046 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1047 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1048 -- The problem is to do with scoped type variables.
1049 -- To implement them, we have to implement the scoping rules
1050 -- here in DsMeta, and I don't want to do that today!
1051 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1052 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1053 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1055 repP other = notHandled "Exotic pattern" (ppr other)
1057 ----------------------------------------------------------
1058 -- Declaration ordering helpers
1060 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1061 sort_by_loc xs = sortBy comp xs
1062 where comp x y = compare (fst x) (fst y)
1064 de_loc :: [(a, b)] -> [b]
1067 ----------------------------------------------------------
1068 -- The meta-environment
1070 -- A name/identifier association for fresh names of locally bound entities
1071 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1072 -- I.e. (x, x_id) means
1073 -- let x_id = gensym "x" in ...
1075 -- Generate a fresh name for a locally bound entity
1077 mkGenSyms :: [Name] -> DsM [GenSymBind]
1078 -- We can use the existing name. For example:
1079 -- [| \x_77 -> x_77 + x_77 |]
1081 -- do { x_77 <- genSym "x"; .... }
1082 -- We use the same x_77 in the desugared program, but with the type Bndr
1085 -- We do make it an Internal name, though (hence localiseName)
1087 -- Nevertheless, it's monadic because we have to generate nameTy
1088 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1089 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1092 addBinds :: [GenSymBind] -> DsM a -> DsM a
1093 -- Add a list of fresh names for locally bound entities to the
1094 -- meta environment (which is part of the state carried around
1095 -- by the desugarer monad)
1096 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1098 -- Look up a locally bound name
1100 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1101 lookupLBinder (L _ n) = lookupBinder n
1103 lookupBinder :: Name -> DsM (Core TH.Name)
1105 = do { mb_val <- dsLookupMetaEnv n;
1107 Just (Bound x) -> return (coreVar x)
1108 _ -> failWithDs msg }
1110 msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
1112 -- Look up a name that is either locally bound or a global name
1114 -- * If it is a global name, generate the "original name" representation (ie,
1115 -- the <module>:<name> form) for the associated entity
1117 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1118 -- Lookup an occurrence; it can't be a splice.
1119 -- Use the in-scope bindings if they exist
1120 lookupLOcc (L _ n) = lookupOcc n
1122 lookupOcc :: Name -> DsM (Core TH.Name)
1124 = do { mb_val <- dsLookupMetaEnv n ;
1126 Nothing -> globalVar n
1127 Just (Bound x) -> return (coreVar x)
1128 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1131 lookupTvOcc :: Name -> DsM (Core TH.Name)
1132 -- Type variables can't be staged and are not lexically scoped in TH
1134 = do { mb_val <- dsLookupMetaEnv n ;
1136 Just (Bound x) -> return (coreVar x)
1140 msg = vcat [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n)
1141 , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ]
1143 globalVar :: Name -> DsM (Core TH.Name)
1144 -- Not bound by the meta-env
1145 -- Could be top-level; or could be local
1146 -- f x = $(g [| x |])
1147 -- Here the x will be local
1149 | isExternalName name
1150 = do { MkC mod <- coreStringLit name_mod
1151 ; MkC pkg <- coreStringLit name_pkg
1152 ; MkC occ <- occNameLit name
1153 ; rep2 mk_varg [pkg,mod,occ] }
1155 = do { MkC occ <- occNameLit name
1156 ; MkC uni <- coreIntLit (getKey (getUnique name))
1157 ; rep2 mkNameLName [occ,uni] }
1159 mod = ASSERT( isExternalName name) nameModule name
1160 name_mod = moduleNameString (moduleName mod)
1161 name_pkg = packageIdString (modulePackageId mod)
1162 name_occ = nameOccName name
1163 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1164 | OccName.isVarOcc name_occ = mkNameG_vName
1165 | OccName.isTcOcc name_occ = mkNameG_tcName
1166 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1168 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1169 -> DsM Type -- The type
1170 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1171 return (mkTyConApp tc []) }
1173 wrapGenSyms :: [GenSymBind]
1174 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1175 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1176 -- --> bindQ (gensym nm1) (\ id1 ->
1177 -- bindQ (gensym nm2 (\ id2 ->
1180 wrapGenSyms binds body@(MkC b)
1181 = do { var_ty <- lookupType nameTyConName
1184 [elt_ty] = tcTyConAppArgs (exprType b)
1185 -- b :: Q a, so we can get the type 'a' by looking at the
1186 -- argument type. NB: this relies on Q being a data/newtype,
1187 -- not a type synonym
1189 go _ [] = return body
1190 go var_ty ((name,id) : binds)
1191 = do { MkC body' <- go var_ty binds
1192 ; lit_str <- occNameLit name
1193 ; gensym_app <- repGensym lit_str
1194 ; repBindQ var_ty elt_ty
1195 gensym_app (MkC (Lam id body')) }
1197 -- Just like wrapGenSym, but don't actually do the gensym
1198 -- Instead use the existing name:
1199 -- let x = "x" in ...
1200 -- Only used for [Decl], and for the class ops in class
1201 -- and instance decls
1202 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
1203 wrapNongenSyms binds (MkC body)
1204 = do { binds' <- mapM do_one binds ;
1205 return (MkC (mkLets binds' body)) }
1208 = do { MkC lit_str <- occNameLit name
1209 ; MkC var <- rep2 mkNameName [lit_str]
1210 ; return (NonRec id var) }
1212 occNameLit :: Name -> DsM (Core String)
1213 occNameLit n = coreStringLit (occNameString (nameOccName n))
1216 -- %*********************************************************************
1218 -- Constructing code
1220 -- %*********************************************************************
1222 -----------------------------------------------------------------------------
1223 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1224 -- we invent a new datatype which uses phantom types.
1226 newtype Core a = MkC CoreExpr
1227 unC :: Core a -> CoreExpr
1230 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1231 rep2 n xs = do { id <- dsLookupGlobalId n
1232 ; return (MkC (foldl App (Var id) xs)) }
1234 -- Then we make "repConstructors" which use the phantom types for each of the
1235 -- smart constructors of the Meta.Meta datatypes.
1238 -- %*********************************************************************
1240 -- The 'smart constructors'
1242 -- %*********************************************************************
1244 --------------- Patterns -----------------
1245 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1246 repPlit (MkC l) = rep2 litPName [l]
1248 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1249 repPvar (MkC s) = rep2 varPName [s]
1251 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1252 repPtup (MkC ps) = rep2 tupPName [ps]
1254 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1255 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1257 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1258 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1260 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1261 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1263 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1264 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1266 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1267 repPtilde (MkC p) = rep2 tildePName [p]
1269 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1270 repPbang (MkC p) = rep2 bangPName [p]
1272 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1273 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1275 repPwild :: DsM (Core TH.PatQ)
1276 repPwild = rep2 wildPName []
1278 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1279 repPlist (MkC ps) = rep2 listPName [ps]
1281 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1282 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1284 --------------- Expressions -----------------
1285 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1286 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1287 | otherwise = repVar str
1289 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1290 repVar (MkC s) = rep2 varEName [s]
1292 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1293 repCon (MkC s) = rep2 conEName [s]
1295 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1296 repLit (MkC c) = rep2 litEName [c]
1298 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1299 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1301 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1302 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1304 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1305 repTup (MkC es) = rep2 tupEName [es]
1307 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1308 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
1310 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1311 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1313 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1314 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1316 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1317 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1319 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1320 repDoE (MkC ss) = rep2 doEName [ss]
1322 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1323 repComp (MkC ss) = rep2 compEName [ss]
1325 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1326 repListExp (MkC es) = rep2 listEName [es]
1328 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1329 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1331 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1332 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1334 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1335 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1337 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1338 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1340 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1341 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1343 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1344 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1346 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1347 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1349 ------------ Right hand sides (guarded expressions) ----
1350 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1351 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1353 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1354 repNormal (MkC e) = rep2 normalBName [e]
1356 ------------ Guards ----
1357 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1358 repLNormalGE g e = do g' <- repLE g
1362 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1363 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1365 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1366 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1368 ------------- Stmts -------------------
1369 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1370 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1372 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1373 repLetSt (MkC ds) = rep2 letSName [ds]
1375 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1376 repNoBindSt (MkC e) = rep2 noBindSName [e]
1378 -------------- Range (Arithmetic sequences) -----------
1379 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1380 repFrom (MkC x) = rep2 fromEName [x]
1382 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1383 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1385 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1386 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1388 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1389 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1391 ------------ Match and Clause Tuples -----------
1392 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1393 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1395 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1396 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1398 -------------- Dec -----------------------------
1399 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1400 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1402 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1403 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1405 repData :: 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 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1409 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1410 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1411 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1413 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1414 -> Maybe (Core [TH.TypeQ])
1415 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1416 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1417 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1418 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1419 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1421 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1422 -> Maybe (Core [TH.TypeQ])
1423 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1424 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1425 = rep2 tySynDName [nm, tvs, rhs]
1426 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1427 = rep2 tySynInstDName [nm, tys, rhs]
1429 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1430 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1432 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1433 -> Core [TH.FunDep] -> Core [TH.DecQ]
1434 -> DsM (Core TH.DecQ)
1435 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1436 = rep2 classDName [cxt, cls, tvs, fds, ds]
1438 repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1439 repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1441 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1442 repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1444 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1445 -> DsM (Core TH.DecQ)
1446 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1447 = rep2 pragSpecInlDName [nm, ty, ispec]
1449 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1450 -> DsM (Core TH.DecQ)
1451 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1452 = rep2 familyNoKindDName [flav, nm, tvs]
1454 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1456 -> DsM (Core TH.DecQ)
1457 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1458 = rep2 familyKindDName [flav, nm, tvs, ki]
1460 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
1461 repInlineSpecNoPhase (MkC inline) (MkC conlike)
1462 = rep2 inlineSpecNoPhaseName [inline, conlike]
1464 repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int
1465 -> DsM (Core TH.InlineSpecQ)
1466 repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1467 = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1469 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1470 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1472 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1473 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1475 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1476 repCtxt (MkC tys) = rep2 cxtName [tys]
1478 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1479 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1481 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1482 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1484 repConstr :: Core TH.Name -> HsConDeclDetails Name
1485 -> DsM (Core TH.ConQ)
1486 repConstr con (PrefixCon ps)
1487 = do arg_tys <- mapM repBangTy ps
1488 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1489 rep2 normalCName [unC con, unC arg_tys1]
1490 repConstr con (RecCon ips)
1491 = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
1492 arg_tys <- mapM repBangTy (map cd_fld_type ips)
1493 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1495 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1496 rep2 recCName [unC con, unC arg_vtys']
1497 repConstr con (InfixCon st1 st2)
1498 = do arg1 <- repBangTy st1
1499 arg2 <- repBangTy st2
1500 rep2 infixCName [unC arg1, unC con, unC arg2]
1502 ------------ Types -------------------
1504 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1505 -> DsM (Core TH.TypeQ)
1506 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1507 = rep2 forallTName [tvars, ctxt, ty]
1509 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1510 repTvar (MkC s) = rep2 varTName [s]
1512 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1513 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1515 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1516 repTapps f [] = return f
1517 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1519 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1520 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1522 --------- Type constructors --------------
1524 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1525 repNamedTyCon (MkC s) = rep2 conTName [s]
1527 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1528 -- Note: not Core Int; it's easier to be direct here
1529 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1531 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1532 -- Note: not Core Int; it's easier to be direct here
1533 repUnboxedTupleTyCon i = rep2 unboxedTupleTName [mkIntExprInt i]
1535 repArrowTyCon :: DsM (Core TH.TypeQ)
1536 repArrowTyCon = rep2 arrowTName []
1538 repListTyCon :: DsM (Core TH.TypeQ)
1539 repListTyCon = rep2 listTName []
1541 ------------ Kinds -------------------
1543 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1544 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1546 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1547 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1549 repStarK :: DsM (Core TH.Kind)
1550 repStarK = rep2 starKName []
1552 repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1553 repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2]
1555 ----------------------------------------------------------
1558 repLiteral :: HsLit -> DsM (Core TH.Lit)
1560 = do lit' <- case lit of
1561 HsIntPrim i -> mk_integer i
1562 HsWordPrim w -> mk_integer w
1563 HsInt i -> mk_integer i
1564 HsFloatPrim r -> mk_rational r
1565 HsDoublePrim r -> mk_rational r
1567 lit_expr <- dsLit lit'
1569 Just lit_name -> rep2 lit_name [lit_expr]
1570 Nothing -> notHandled "Exotic literal" (ppr lit)
1572 mb_lit_name = case lit of
1573 HsInteger _ _ -> Just integerLName
1574 HsInt _ -> Just integerLName
1575 HsIntPrim _ -> Just intPrimLName
1576 HsWordPrim _ -> Just wordPrimLName
1577 HsFloatPrim _ -> Just floatPrimLName
1578 HsDoublePrim _ -> Just doublePrimLName
1579 HsChar _ -> Just charLName
1580 HsString _ -> Just stringLName
1581 HsRat _ _ -> Just rationalLName
1584 mk_integer :: Integer -> DsM HsLit
1585 mk_integer i = do integer_ty <- lookupType integerTyConName
1586 return $ HsInteger i integer_ty
1587 mk_rational :: Rational -> DsM HsLit
1588 mk_rational r = do rat_ty <- lookupType rationalTyConName
1589 return $ HsRat r rat_ty
1590 mk_string :: FastString -> DsM HsLit
1591 mk_string s = return $ HsString s
1593 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1594 repOverloadedLiteral (OverLit { ol_val = val})
1595 = do { lit <- mk_lit val; repLiteral lit }
1596 -- The type Rational will be in the environment, becuase
1597 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1598 -- and rationalL is sucked in when any TH stuff is used
1600 mk_lit :: OverLitVal -> DsM HsLit
1601 mk_lit (HsIntegral i) = mk_integer i
1602 mk_lit (HsFractional f) = mk_rational f
1603 mk_lit (HsIsString s) = mk_string s
1605 --------------- Miscellaneous -------------------
1607 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1608 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1610 repBindQ :: Type -> Type -- a and b
1611 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1612 repBindQ ty_a ty_b (MkC x) (MkC y)
1613 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1615 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1616 repSequenceQ ty_a (MkC list)
1617 = rep2 sequenceQName [Type ty_a, list]
1619 ------------ Lists and Tuples -------------------
1620 -- turn a list of patterns into a single pattern matching a list
1622 coreList :: Name -- Of the TyCon of the element type
1623 -> [Core a] -> DsM (Core [a])
1625 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1627 coreList' :: Type -- The element type
1628 -> [Core a] -> Core [a]
1629 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1631 nonEmptyCoreList :: [Core a] -> Core [a]
1632 -- The list must be non-empty so we can get the element type
1633 -- Otherwise use coreList
1634 nonEmptyCoreList [] = panic "coreList: empty argument"
1635 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1637 coreStringLit :: String -> DsM (Core String)
1638 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1640 ------------ Bool, Literals & Variables -------------------
1642 coreBool :: Bool -> Core Bool
1643 coreBool False = MkC $ mkConApp falseDataCon []
1644 coreBool True = MkC $ mkConApp trueDataCon []
1646 coreIntLit :: Int -> DsM (Core Int)
1647 coreIntLit i = return (MkC (mkIntExprInt i))
1649 coreVar :: Id -> Core TH.Name -- The Id has type Name
1650 coreVar id = MkC (Var id)
1652 ----------------- Failure -----------------------
1653 notHandled :: String -> SDoc -> DsM a
1654 notHandled what doc = failWithDs msg
1656 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1660 -- %************************************************************************
1662 -- The known-key names for Template Haskell
1664 -- %************************************************************************
1666 -- To add a name, do three things
1668 -- 1) Allocate a key
1670 -- 3) Add the name to knownKeyNames
1672 templateHaskellNames :: [Name]
1673 -- The names that are implicitly mentioned by ``bracket''
1674 -- Should stay in sync with the import list of DsMeta
1676 templateHaskellNames = [
1677 returnQName, bindQName, sequenceQName, newNameName, liftName,
1678 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1682 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1683 floatPrimLName, doublePrimLName, rationalLName,
1685 litPName, varPName, tupPName, unboxedTupPName,
1686 conPName, tildePName, bangPName, infixPName,
1687 asPName, wildPName, recPName, listPName, sigPName, viewPName,
1695 varEName, conEName, litEName, appEName, infixEName,
1696 infixAppName, sectionLName, sectionRName, lamEName,
1697 tupEName, unboxedTupEName,
1698 condEName, letEName, caseEName, doEName, compEName,
1699 fromEName, fromThenEName, fromToEName, fromThenToEName,
1700 listEName, sigEName, recConEName, recUpdEName,
1704 guardedBName, normalBName,
1706 normalGEName, patGEName,
1708 bindSName, letSName, noBindSName, parSName,
1710 funDName, valDName, dataDName, newtypeDName, tySynDName,
1711 classDName, instanceDName, sigDName, forImpDName,
1712 pragInlDName, pragSpecDName, pragSpecInlDName,
1713 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1718 classPName, equalPName,
1720 isStrictName, notStrictName,
1722 normalCName, recCName, infixCName, forallCName,
1728 forallTName, varTName, conTName, appTName,
1729 tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName,
1731 plainTVName, kindedTVName,
1733 starKName, arrowKName,
1735 cCallName, stdCallName,
1742 inlineSpecNoPhaseName, inlineSpecPhaseName,
1746 typeFamName, dataFamName,
1749 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1750 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1751 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1752 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1753 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1754 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1755 predQTyConName, decsQTyConName,
1758 quoteDecName, quoteTypeName, quoteExpName, quotePatName]
1760 thSyn, thLib, qqLib :: Module
1761 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1762 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1763 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1765 mkTHModule :: FastString -> Module
1766 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1768 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1769 libFun = mk_known_key_name OccName.varName thLib
1770 libTc = mk_known_key_name OccName.tcName thLib
1771 thFun = mk_known_key_name OccName.varName thSyn
1772 thTc = mk_known_key_name OccName.tcName thSyn
1773 qqFun = mk_known_key_name OccName.varName qqLib
1775 -------------------- TH.Syntax -----------------------
1776 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1777 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1778 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1779 predTyConName :: Name
1780 qTyConName = thTc (fsLit "Q") qTyConKey
1781 nameTyConName = thTc (fsLit "Name") nameTyConKey
1782 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
1783 patTyConName = thTc (fsLit "Pat") patTyConKey
1784 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
1785 expTyConName = thTc (fsLit "Exp") expTyConKey
1786 decTyConName = thTc (fsLit "Dec") decTyConKey
1787 typeTyConName = thTc (fsLit "Type") typeTyConKey
1788 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
1789 matchTyConName = thTc (fsLit "Match") matchTyConKey
1790 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
1791 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
1792 predTyConName = thTc (fsLit "Pred") predTyConKey
1794 returnQName, bindQName, sequenceQName, newNameName, liftName,
1795 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1796 mkNameLName, liftStringName :: Name
1797 returnQName = thFun (fsLit "returnQ") returnQIdKey
1798 bindQName = thFun (fsLit "bindQ") bindQIdKey
1799 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1800 newNameName = thFun (fsLit "newName") newNameIdKey
1801 liftName = thFun (fsLit "lift") liftIdKey
1802 liftStringName = thFun (fsLit "liftString") liftStringIdKey
1803 mkNameName = thFun (fsLit "mkName") mkNameIdKey
1804 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
1805 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
1806 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1807 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
1810 -------------------- TH.Lib -----------------------
1812 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1813 floatPrimLName, doublePrimLName, rationalLName :: Name
1814 charLName = libFun (fsLit "charL") charLIdKey
1815 stringLName = libFun (fsLit "stringL") stringLIdKey
1816 integerLName = libFun (fsLit "integerL") integerLIdKey
1817 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
1818 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
1819 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
1820 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1821 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
1824 litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,
1825 asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name
1826 litPName = libFun (fsLit "litP") litPIdKey
1827 varPName = libFun (fsLit "varP") varPIdKey
1828 tupPName = libFun (fsLit "tupP") tupPIdKey
1829 unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
1830 conPName = libFun (fsLit "conP") conPIdKey
1831 infixPName = libFun (fsLit "infixP") infixPIdKey
1832 tildePName = libFun (fsLit "tildeP") tildePIdKey
1833 bangPName = libFun (fsLit "bangP") bangPIdKey
1834 asPName = libFun (fsLit "asP") asPIdKey
1835 wildPName = libFun (fsLit "wildP") wildPIdKey
1836 recPName = libFun (fsLit "recP") recPIdKey
1837 listPName = libFun (fsLit "listP") listPIdKey
1838 sigPName = libFun (fsLit "sigP") sigPIdKey
1839 viewPName = libFun (fsLit "viewP") viewPIdKey
1841 -- type FieldPat = ...
1842 fieldPatName :: Name
1843 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1847 matchName = libFun (fsLit "match") matchIdKey
1849 -- data Clause = ...
1851 clauseName = libFun (fsLit "clause") clauseIdKey
1854 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1855 sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName,
1856 letEName, caseEName, doEName, compEName :: Name
1857 varEName = libFun (fsLit "varE") varEIdKey
1858 conEName = libFun (fsLit "conE") conEIdKey
1859 litEName = libFun (fsLit "litE") litEIdKey
1860 appEName = libFun (fsLit "appE") appEIdKey
1861 infixEName = libFun (fsLit "infixE") infixEIdKey
1862 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
1863 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
1864 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
1865 lamEName = libFun (fsLit "lamE") lamEIdKey
1866 tupEName = libFun (fsLit "tupE") tupEIdKey
1867 unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
1868 condEName = libFun (fsLit "condE") condEIdKey
1869 letEName = libFun (fsLit "letE") letEIdKey
1870 caseEName = libFun (fsLit "caseE") caseEIdKey
1871 doEName = libFun (fsLit "doE") doEIdKey
1872 compEName = libFun (fsLit "compE") compEIdKey
1873 -- ArithSeq skips a level
1874 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1875 fromEName = libFun (fsLit "fromE") fromEIdKey
1876 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
1877 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
1878 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1880 listEName, sigEName, recConEName, recUpdEName :: Name
1881 listEName = libFun (fsLit "listE") listEIdKey
1882 sigEName = libFun (fsLit "sigE") sigEIdKey
1883 recConEName = libFun (fsLit "recConE") recConEIdKey
1884 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
1886 -- type FieldExp = ...
1887 fieldExpName :: Name
1888 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1891 guardedBName, normalBName :: Name
1892 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1893 normalBName = libFun (fsLit "normalB") normalBIdKey
1896 normalGEName, patGEName :: Name
1897 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1898 patGEName = libFun (fsLit "patGE") patGEIdKey
1901 bindSName, letSName, noBindSName, parSName :: Name
1902 bindSName = libFun (fsLit "bindS") bindSIdKey
1903 letSName = libFun (fsLit "letS") letSIdKey
1904 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1905 parSName = libFun (fsLit "parS") parSIdKey
1908 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1909 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
1910 pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
1911 newtypeInstDName, tySynInstDName :: Name
1912 funDName = libFun (fsLit "funD") funDIdKey
1913 valDName = libFun (fsLit "valD") valDIdKey
1914 dataDName = libFun (fsLit "dataD") dataDIdKey
1915 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
1916 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
1917 classDName = libFun (fsLit "classD") classDIdKey
1918 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
1919 sigDName = libFun (fsLit "sigD") sigDIdKey
1920 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
1921 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
1922 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
1923 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
1924 familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
1925 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
1926 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
1927 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1928 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
1932 cxtName = libFun (fsLit "cxt") cxtIdKey
1935 classPName, equalPName :: Name
1936 classPName = libFun (fsLit "classP") classPIdKey
1937 equalPName = libFun (fsLit "equalP") equalPIdKey
1939 -- data Strict = ...
1940 isStrictName, notStrictName :: Name
1941 isStrictName = libFun (fsLit "isStrict") isStrictKey
1942 notStrictName = libFun (fsLit "notStrict") notStrictKey
1945 normalCName, recCName, infixCName, forallCName :: Name
1946 normalCName = libFun (fsLit "normalC") normalCIdKey
1947 recCName = libFun (fsLit "recC") recCIdKey
1948 infixCName = libFun (fsLit "infixC") infixCIdKey
1949 forallCName = libFun (fsLit "forallC") forallCIdKey
1951 -- type StrictType = ...
1952 strictTypeName :: Name
1953 strictTypeName = libFun (fsLit "strictType") strictTKey
1955 -- type VarStrictType = ...
1956 varStrictTypeName :: Name
1957 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
1960 forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
1961 listTName, appTName, sigTName :: Name
1962 forallTName = libFun (fsLit "forallT") forallTIdKey
1963 varTName = libFun (fsLit "varT") varTIdKey
1964 conTName = libFun (fsLit "conT") conTIdKey
1965 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
1966 unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey
1967 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
1968 listTName = libFun (fsLit "listT") listTIdKey
1969 appTName = libFun (fsLit "appT") appTIdKey
1970 sigTName = libFun (fsLit "sigT") sigTIdKey
1972 -- data TyVarBndr = ...
1973 plainTVName, kindedTVName :: Name
1974 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
1975 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
1978 starKName, arrowKName :: Name
1979 starKName = libFun (fsLit "starK") starKIdKey
1980 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
1982 -- data Callconv = ...
1983 cCallName, stdCallName :: Name
1984 cCallName = libFun (fsLit "cCall") cCallIdKey
1985 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
1987 -- data Safety = ...
1988 unsafeName, safeName, threadsafeName, interruptibleName :: Name
1989 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
1990 safeName = libFun (fsLit "safe") safeIdKey
1991 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
1992 interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
1994 -- data InlineSpec = ...
1995 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
1996 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
1997 inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
1999 -- data FunDep = ...
2001 funDepName = libFun (fsLit "funDep") funDepIdKey
2003 -- data FamFlavour = ...
2004 typeFamName, dataFamName :: Name
2005 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
2006 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
2008 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
2009 decQTyConName, conQTyConName, strictTypeQTyConName,
2010 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
2011 patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
2012 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
2013 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
2014 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
2015 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
2016 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
2017 decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
2018 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
2019 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
2020 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
2021 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
2022 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
2023 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
2024 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
2025 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
2028 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
2029 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
2030 quotePatName = qqFun (fsLit "quotePat") quotePatKey
2031 quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
2032 quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
2034 -- TyConUniques available: 200-299
2035 -- Check in PrelNames if you want to change this
2037 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2038 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2039 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2040 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2041 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2042 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2043 predQTyConKey, decsQTyConKey :: Unique
2044 expTyConKey = mkPreludeTyConUnique 200
2045 matchTyConKey = mkPreludeTyConUnique 201
2046 clauseTyConKey = mkPreludeTyConUnique 202
2047 qTyConKey = mkPreludeTyConUnique 203
2048 expQTyConKey = mkPreludeTyConUnique 204
2049 decQTyConKey = mkPreludeTyConUnique 205
2050 patTyConKey = mkPreludeTyConUnique 206
2051 matchQTyConKey = mkPreludeTyConUnique 207
2052 clauseQTyConKey = mkPreludeTyConUnique 208
2053 stmtQTyConKey = mkPreludeTyConUnique 209
2054 conQTyConKey = mkPreludeTyConUnique 210
2055 typeQTyConKey = mkPreludeTyConUnique 211
2056 typeTyConKey = mkPreludeTyConUnique 212
2057 decTyConKey = mkPreludeTyConUnique 213
2058 varStrictTypeQTyConKey = mkPreludeTyConUnique 214
2059 strictTypeQTyConKey = mkPreludeTyConUnique 215
2060 fieldExpTyConKey = mkPreludeTyConUnique 216
2061 fieldPatTyConKey = mkPreludeTyConUnique 217
2062 nameTyConKey = mkPreludeTyConUnique 218
2063 patQTyConKey = mkPreludeTyConUnique 219
2064 fieldPatQTyConKey = mkPreludeTyConUnique 220
2065 fieldExpQTyConKey = mkPreludeTyConUnique 221
2066 funDepTyConKey = mkPreludeTyConUnique 222
2067 predTyConKey = mkPreludeTyConUnique 223
2068 predQTyConKey = mkPreludeTyConUnique 224
2069 tyVarBndrTyConKey = mkPreludeTyConUnique 225
2070 decsQTyConKey = mkPreludeTyConUnique 226
2072 -- IdUniques available: 200-399
2073 -- If you want to change this, make sure you check in PrelNames
2075 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2076 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2077 mkNameLIdKey :: Unique
2078 returnQIdKey = mkPreludeMiscIdUnique 200
2079 bindQIdKey = mkPreludeMiscIdUnique 201
2080 sequenceQIdKey = mkPreludeMiscIdUnique 202
2081 liftIdKey = mkPreludeMiscIdUnique 203
2082 newNameIdKey = mkPreludeMiscIdUnique 204
2083 mkNameIdKey = mkPreludeMiscIdUnique 205
2084 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2085 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2086 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2087 mkNameLIdKey = mkPreludeMiscIdUnique 209
2091 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2092 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2093 charLIdKey = mkPreludeMiscIdUnique 220
2094 stringLIdKey = mkPreludeMiscIdUnique 221
2095 integerLIdKey = mkPreludeMiscIdUnique 222
2096 intPrimLIdKey = mkPreludeMiscIdUnique 223
2097 wordPrimLIdKey = mkPreludeMiscIdUnique 224
2098 floatPrimLIdKey = mkPreludeMiscIdUnique 225
2099 doublePrimLIdKey = mkPreludeMiscIdUnique 226
2100 rationalLIdKey = mkPreludeMiscIdUnique 227
2102 liftStringIdKey :: Unique
2103 liftStringIdKey = mkPreludeMiscIdUnique 228
2106 litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2107 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
2108 litPIdKey = mkPreludeMiscIdUnique 240
2109 varPIdKey = mkPreludeMiscIdUnique 241
2110 tupPIdKey = mkPreludeMiscIdUnique 242
2111 unboxedTupPIdKey = mkPreludeMiscIdUnique 243
2112 conPIdKey = mkPreludeMiscIdUnique 244
2113 infixPIdKey = mkPreludeMiscIdUnique 245
2114 tildePIdKey = mkPreludeMiscIdUnique 246
2115 bangPIdKey = mkPreludeMiscIdUnique 247
2116 asPIdKey = mkPreludeMiscIdUnique 248
2117 wildPIdKey = mkPreludeMiscIdUnique 249
2118 recPIdKey = mkPreludeMiscIdUnique 250
2119 listPIdKey = mkPreludeMiscIdUnique 251
2120 sigPIdKey = mkPreludeMiscIdUnique 252
2121 viewPIdKey = mkPreludeMiscIdUnique 253
2123 -- type FieldPat = ...
2124 fieldPatIdKey :: Unique
2125 fieldPatIdKey = mkPreludeMiscIdUnique 260
2128 matchIdKey :: Unique
2129 matchIdKey = mkPreludeMiscIdUnique 261
2131 -- data Clause = ...
2132 clauseIdKey :: Unique
2133 clauseIdKey = mkPreludeMiscIdUnique 262
2137 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2138 sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey,
2140 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2141 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2142 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2143 varEIdKey = mkPreludeMiscIdUnique 270
2144 conEIdKey = mkPreludeMiscIdUnique 271
2145 litEIdKey = mkPreludeMiscIdUnique 272
2146 appEIdKey = mkPreludeMiscIdUnique 273
2147 infixEIdKey = mkPreludeMiscIdUnique 274
2148 infixAppIdKey = mkPreludeMiscIdUnique 275
2149 sectionLIdKey = mkPreludeMiscIdUnique 276
2150 sectionRIdKey = mkPreludeMiscIdUnique 277
2151 lamEIdKey = mkPreludeMiscIdUnique 278
2152 tupEIdKey = mkPreludeMiscIdUnique 279
2153 unboxedTupEIdKey = mkPreludeMiscIdUnique 280
2154 condEIdKey = mkPreludeMiscIdUnique 281
2155 letEIdKey = mkPreludeMiscIdUnique 282
2156 caseEIdKey = mkPreludeMiscIdUnique 283
2157 doEIdKey = mkPreludeMiscIdUnique 284
2158 compEIdKey = mkPreludeMiscIdUnique 285
2159 fromEIdKey = mkPreludeMiscIdUnique 286
2160 fromThenEIdKey = mkPreludeMiscIdUnique 287
2161 fromToEIdKey = mkPreludeMiscIdUnique 288
2162 fromThenToEIdKey = mkPreludeMiscIdUnique 289
2163 listEIdKey = mkPreludeMiscIdUnique 290
2164 sigEIdKey = mkPreludeMiscIdUnique 291
2165 recConEIdKey = mkPreludeMiscIdUnique 292
2166 recUpdEIdKey = mkPreludeMiscIdUnique 293
2168 -- type FieldExp = ...
2169 fieldExpIdKey :: Unique
2170 fieldExpIdKey = mkPreludeMiscIdUnique 310
2173 guardedBIdKey, normalBIdKey :: Unique
2174 guardedBIdKey = mkPreludeMiscIdUnique 311
2175 normalBIdKey = mkPreludeMiscIdUnique 312
2178 normalGEIdKey, patGEIdKey :: Unique
2179 normalGEIdKey = mkPreludeMiscIdUnique 313
2180 patGEIdKey = mkPreludeMiscIdUnique 314
2183 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2184 bindSIdKey = mkPreludeMiscIdUnique 320
2185 letSIdKey = mkPreludeMiscIdUnique 321
2186 noBindSIdKey = mkPreludeMiscIdUnique 322
2187 parSIdKey = mkPreludeMiscIdUnique 323
2190 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2191 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2192 pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2193 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
2194 funDIdKey = mkPreludeMiscIdUnique 330
2195 valDIdKey = mkPreludeMiscIdUnique 331
2196 dataDIdKey = mkPreludeMiscIdUnique 332
2197 newtypeDIdKey = mkPreludeMiscIdUnique 333
2198 tySynDIdKey = mkPreludeMiscIdUnique 334
2199 classDIdKey = mkPreludeMiscIdUnique 335
2200 instanceDIdKey = mkPreludeMiscIdUnique 336
2201 sigDIdKey = mkPreludeMiscIdUnique 337
2202 forImpDIdKey = mkPreludeMiscIdUnique 338
2203 pragInlDIdKey = mkPreludeMiscIdUnique 339
2204 pragSpecDIdKey = mkPreludeMiscIdUnique 340
2205 pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
2206 familyNoKindDIdKey = mkPreludeMiscIdUnique 342
2207 familyKindDIdKey = mkPreludeMiscIdUnique 343
2208 dataInstDIdKey = mkPreludeMiscIdUnique 344
2209 newtypeInstDIdKey = mkPreludeMiscIdUnique 345
2210 tySynInstDIdKey = mkPreludeMiscIdUnique 346
2214 cxtIdKey = mkPreludeMiscIdUnique 360
2217 classPIdKey, equalPIdKey :: Unique
2218 classPIdKey = mkPreludeMiscIdUnique 361
2219 equalPIdKey = mkPreludeMiscIdUnique 362
2221 -- data Strict = ...
2222 isStrictKey, notStrictKey :: Unique
2223 isStrictKey = mkPreludeMiscIdUnique 363
2224 notStrictKey = mkPreludeMiscIdUnique 364
2227 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2228 normalCIdKey = mkPreludeMiscIdUnique 370
2229 recCIdKey = mkPreludeMiscIdUnique 371
2230 infixCIdKey = mkPreludeMiscIdUnique 372
2231 forallCIdKey = mkPreludeMiscIdUnique 373
2233 -- type StrictType = ...
2234 strictTKey :: Unique
2235 strictTKey = mkPreludeMiscIdUnique 374
2237 -- type VarStrictType = ...
2238 varStrictTKey :: Unique
2239 varStrictTKey = mkPreludeMiscIdUnique 375
2242 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
2243 listTIdKey, appTIdKey, sigTIdKey :: Unique
2244 forallTIdKey = mkPreludeMiscIdUnique 380
2245 varTIdKey = mkPreludeMiscIdUnique 381
2246 conTIdKey = mkPreludeMiscIdUnique 382
2247 tupleTIdKey = mkPreludeMiscIdUnique 383
2248 unboxedTupleTIdKey = mkPreludeMiscIdUnique 384
2249 arrowTIdKey = mkPreludeMiscIdUnique 385
2250 listTIdKey = mkPreludeMiscIdUnique 386
2251 appTIdKey = mkPreludeMiscIdUnique 387
2252 sigTIdKey = mkPreludeMiscIdUnique 388
2254 -- data TyVarBndr = ...
2255 plainTVIdKey, kindedTVIdKey :: Unique
2256 plainTVIdKey = mkPreludeMiscIdUnique 390
2257 kindedTVIdKey = mkPreludeMiscIdUnique 391
2260 starKIdKey, arrowKIdKey :: Unique
2261 starKIdKey = mkPreludeMiscIdUnique 392
2262 arrowKIdKey = mkPreludeMiscIdUnique 393
2264 -- data Callconv = ...
2265 cCallIdKey, stdCallIdKey :: Unique
2266 cCallIdKey = mkPreludeMiscIdUnique 394
2267 stdCallIdKey = mkPreludeMiscIdUnique 395
2269 -- data Safety = ...
2270 unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique
2271 unsafeIdKey = mkPreludeMiscIdUnique 400
2272 safeIdKey = mkPreludeMiscIdUnique 401
2273 threadsafeIdKey = mkPreludeMiscIdUnique 402
2274 interruptibleIdKey = mkPreludeMiscIdUnique 403
2276 -- data InlineSpec =
2277 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2278 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 404
2279 inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 405
2281 -- data FunDep = ...
2282 funDepIdKey :: Unique
2283 funDepIdKey = mkPreludeMiscIdUnique 406
2285 -- data FamFlavour = ...
2286 typeFamIdKey, dataFamIdKey :: Unique
2287 typeFamIdKey = mkPreludeMiscIdUnique 407
2288 dataFamIdKey = mkPreludeMiscIdUnique 408
2291 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2292 quoteExpKey = mkPreludeMiscIdUnique 410
2293 quotePatKey = mkPreludeMiscIdUnique 411
2294 quoteDecKey = mkPreludeMiscIdUnique 412
2295 quoteTypeKey = mkPreludeMiscIdUnique 413