1 -----------------------------------------------------------------------------
2 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
3 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
4 -- input HsExpr. We do this in the DsM monad, which supplies access to
5 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
7 -- It also defines a bunch of knownKeyNames, in the same way as is done
8 -- in prelude/PrelNames. It's much more convenient to do it here, becuase
9 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
10 -- a Royal Pain (triggers other recompilation).
11 -----------------------------------------------------------------------------
14 module DsMeta( dsBracket, dsReify,
15 templateHaskellNames, qTyConName,
16 liftName, exprTyConName, declTyConName, typeTyConName,
17 decTyConName, typTyConName ) where
19 #include "HsVersions.h"
21 import {-# SOURCE #-} DsExpr ( dsExpr )
23 import MatchLit ( dsLit )
24 import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
27 import qualified Language.Haskell.THSyntax as M
29 import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
30 Match(..), GRHSs(..), GRHS(..), HsBracket(..),
31 HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
32 HsBinds(..), MonoBinds(..), HsConDetails(..),
33 TyClDecl(..), HsGroup(..),
34 HsReify(..), ReifyFlavour(..),
35 HsType(..), HsContext(..), HsPred(..), HsTyOp(..),
36 HsTyVarBndr(..), Sig(..), ForeignDecl(..),
37 InstDecl(..), ConDecl(..), BangType(..),
38 PendingSplice, splitHsInstDeclTy,
39 placeHolderType, tyClDeclNames,
40 collectHsBinders, collectPatBinders, collectPatsBinders,
41 hsTyVarName, hsConArgs, getBangType,
45 import PrelNames ( mETA_META_Name, rationalTyConName, negateName,
47 import MkIface ( ifaceTyThing )
48 import Name ( Name, nameOccName, nameModule, getSrcLoc )
49 import OccName ( isDataOcc, isTvOcc, occNameUserString )
50 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
51 -- we do this by removing varName from the import of OccName above, making
52 -- a qualified instance of OccName and using OccNameAlias.varName where varName
53 -- ws previously used in this file.
54 import qualified OccName( varName, tcName )
56 import Module ( Module, mkThPkgModule, moduleUserString )
57 import Id ( Id, idType )
58 import Name ( mkKnownKeyExternalName )
59 import OccName ( mkOccFS )
62 import Type ( Type, mkGenTyConApp )
63 import TcType ( TyThing(..), tcTyConAppArgs )
64 import TyCon ( DataConDetails(..) )
65 import TysWiredIn ( stringTy )
67 import CoreUtils ( exprType )
68 import SrcLoc ( noSrcLoc )
69 import Maybes ( orElse )
70 import Maybe ( catMaybes, fromMaybe )
71 import Panic ( panic )
72 import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
73 import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
74 import SrcLoc ( SrcLoc )
77 import FastString ( mkFastString )
79 import Monad ( zipWithM )
80 import List ( sortBy )
82 -----------------------------------------------------------------------------
83 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
84 -- Returns a CoreExpr of type M.ExpQ
85 -- The quoted thing is parameterised over Name, even though it has
86 -- been type checked. We don't want all those type decorations!
88 dsBracket brack splices
89 = dsExtendMetaEnv new_bit (do_brack brack)
91 new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
93 do_brack (ExpBr e) = do { MkC e1 <- repE e ; return e1 }
94 do_brack (PatBr p) = do { MkC p1 <- repP p ; return p1 }
95 do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 }
96 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
98 -----------------------------------------------------------------------------
99 dsReify :: HsReify Id -> DsM CoreExpr
100 -- Returns a CoreExpr of type reifyType --> M.TypQ
101 -- reifyDecl --> M.DecQ
102 -- reifyFixty --> Q M.Fix
103 dsReify (ReifyOut ReifyType name)
104 = do { thing <- dsLookupGlobal name ;
105 -- By deferring the lookup until now (rather than doing it
106 -- in the type checker) we ensure that all zonking has
109 AnId id -> do { MkC e <- repTy (toHsType (idType id)) ;
111 other -> pprPanic "dsReify: reifyType" (ppr name)
114 dsReify r@(ReifyOut ReifyDecl name)
115 = do { thing <- dsLookupGlobal name ;
116 mb_d <- repTyClD (ifaceTyThing thing) ;
118 Just (MkC d) -> return d
119 Nothing -> pprPanic "dsReify" (ppr r)
122 {- -------------- Examples --------------------
126 gensym (unpackString "x"#) `bindQ` \ x1::String ->
127 lam (pvar x1) (var x1)
130 [| \x -> $(f [| x |]) |]
132 gensym (unpackString "x"#) `bindQ` \ x1::String ->
133 lam (pvar x1) (f (var x1))
137 -------------------------------------------------------
139 -------------------------------------------------------
141 repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
143 = do { let { bndrs = groupBinders group } ;
144 ss <- mkGenSyms bndrs ;
146 -- Bind all the names mainly to avoid repeated use of explicit strings.
148 -- do { t :: String <- genSym "T" ;
149 -- return (Data t [] ...more t's... }
150 -- The other important reason is that the output must mention
151 -- only "T", not "Foo:T" where Foo is the current module
154 decls <- addBinds ss (do {
155 val_ds <- rep_binds' (hs_valds group) ;
156 tycl_ds <- mapM repTyClD' (hs_tyclds group) ;
157 inst_ds <- mapM repInstD' (hs_instds group) ;
159 return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
161 decl_ty <- lookupType declTyConName ;
162 let { core_list = coreList' decl_ty decls } ;
164 dec_ty <- lookupType decTyConName ;
165 q_decs <- repSequenceQ dec_ty core_list ;
167 wrapNongenSyms ss q_decs
168 -- Do *not* gensym top-level binders
171 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
172 hs_fords = foreign_decls })
173 -- Collect the binders of a Group
174 = collectHsBinders val_decls ++
175 [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
176 [n | ForeignImport n _ _ _ _ <- foreign_decls]
179 {- Note [Binders and occurrences]
180 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
181 When we desugar [d| data T = MkT |]
183 Data "T" [] [Con "MkT" []] []
185 Data "Foo:T" [] [Con "Foo:MkT" []] []
186 That is, the new data decl should fit into whatever new module it is
187 asked to fit in. We do *not* clone, though; no need for this:
194 then we must desugar to
195 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
197 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds,
198 but in dsReify we do not. And we use lookupOcc, rather than lookupBinder
199 in repTyClD and repC.
203 repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.DecQ))
204 repTyClD decl = do x <- repTyClD' decl
207 repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ))
209 repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt,
210 tcdName = tc, tcdTyVars = tvs,
211 tcdCons = DataCons cons, tcdDerivs = mb_derivs,
213 = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
214 dec <- addTyVarBinds tvs $ \bndrs -> do {
215 cxt1 <- repContext cxt ;
216 cons1 <- mapM repC cons ;
217 cons2 <- coreList consTyConName cons1 ;
218 derivs1 <- repDerivs mb_derivs ;
219 repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
220 return $ Just (loc, dec) }
222 repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty,
224 = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
225 dec <- addTyVarBinds tvs $ \bndrs -> do {
227 repTySyn tc1 (coreList' stringTy bndrs) ty1 } ;
228 return (Just (loc, dec)) }
230 repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls,
232 tcdFDs = [], -- We don't understand functional dependencies
233 tcdSigs = sigs, tcdMeths = mb_meth_binds,
235 = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences]
236 dec <- addTyVarBinds tvs $ \bndrs -> do {
237 cxt1 <- repContext cxt ;
238 sigs1 <- rep_sigs sigs ;
239 binds1 <- rep_monobind meth_binds ;
240 decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
241 repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
242 return $ Just (loc, dec) }
244 -- If the user quotes a class decl, it'll have default-method
245 -- bindings; but if we (reifyDecl C) where C is a class, we
246 -- won't be given the default methods (a definite infelicity).
247 meth_binds = mb_meth_binds `orElse` EmptyMonoBinds
250 repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
254 msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
256 repInstD' (InstDecl ty binds _ _ loc)
257 -- Ignore user pragmas for now
258 = do { cxt1 <- repContext cxt ;
259 inst_ty1 <- repPred (HsClassP cls tys) ;
260 binds1 <- rep_monobind binds ;
261 decls1 <- coreList declTyConName binds1 ;
262 i <- repInst cxt1 inst_ty1 decls1;
265 (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
268 -------------------------------------------------------
270 -------------------------------------------------------
272 repC :: ConDecl Name -> DsM (Core M.ConQ)
273 repC (ConDecl con [] [] details loc)
274 = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
275 repConstr con1 details }
277 repBangTy :: BangType Name -> DsM (Core (M.Q (M.Strictness, M.Typ)))
278 repBangTy (BangType str ty) = do MkC s <- rep2 strName []
280 rep2 strictTypeName [s, t]
281 where strName = case str of
282 NotMarkedStrict -> nonstrictName
285 -------------------------------------------------------
287 -------------------------------------------------------
289 repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
290 repDerivs Nothing = return (coreList' stringTy [])
291 repDerivs (Just ctxt)
292 = do { strs <- mapM rep_deriv ctxt ;
293 return (coreList' stringTy strs) }
295 rep_deriv :: HsPred Name -> DsM (Core String)
296 -- Deriving clauses must have the simple H98 form
297 rep_deriv (HsClassP cls []) = lookupOcc cls
298 rep_deriv other = panic "rep_deriv"
301 -------------------------------------------------------
302 -- Signatures in a class decl, or a group of bindings
303 -------------------------------------------------------
305 rep_sigs :: [Sig Name] -> DsM [Core M.DecQ]
306 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
307 return $ de_loc $ sort_by_loc locs_cores
309 rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core M.DecQ)]
310 -- We silently ignore ones we don't recognise
311 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
312 return (concat sigs1) }
314 rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)]
316 -- Empty => Too hard, signature ignored
317 rep_sig (ClassOpSig nm _ ty loc) = rep_proto nm ty loc
318 rep_sig (Sig nm ty loc) = rep_proto nm ty loc
319 rep_sig other = return []
321 rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)]
322 rep_proto nm ty loc = do { nm1 <- lookupOcc nm ;
324 sig <- repProto nm1 ty1 ;
325 return [(loc, sig)] }
328 -------------------------------------------------------
330 -------------------------------------------------------
332 -- gensym a list of type variables and enter them into the meta environment;
333 -- the computations passed as the second argument is executed in that extended
334 -- meta environment and gets the *new* names on Core-level as an argument
336 addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
337 -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
338 -> DsM (Core (M.Q a))
339 addTyVarBinds tvs m =
341 let names = map hsTyVarName tvs
342 freshNames <- mkGenSyms names
343 term <- addBinds freshNames $ do
344 bndrs <- mapM lookupBinder names
346 wrapGenSyns freshNames term
348 -- represent a type context
350 repContext :: HsContext Name -> DsM (Core M.CxtQ)
352 preds <- mapM repPred ctxt
353 predList <- coreList typeTyConName preds
356 -- represent a type predicate
358 repPred :: HsPred Name -> DsM (Core M.TypQ)
359 repPred (HsClassP cls tys) = do
360 tcon <- repTy (HsTyVar cls)
363 repPred (HsIParam _ _) =
364 panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
366 -- yield the representation of a list of types
368 repTys :: [HsType Name] -> DsM [Core M.TypQ]
369 repTys tys = mapM repTy tys
373 repTy :: HsType Name -> DsM (Core M.TypQ)
374 repTy (HsForAllTy bndrs ctxt ty) =
375 addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do
376 ctxt' <- repContext ctxt
378 repTForall (coreList' stringTy bndrs') ctxt' ty'
381 | isTvOcc (nameOccName n) = do
382 tv1 <- lookupBinder n
387 repTy (HsAppTy f a) = do
391 repTy (HsFunTy f a) = do
394 tcon <- repArrowTyCon
395 repTapps tcon [f1, a1]
396 repTy (HsListTy t) = do
400 repTy (HsPArrTy t) = do
402 tcon <- repTy (HsTyVar parrTyConName)
404 repTy (HsTupleTy tc tys) = do
406 tcon <- repTupleTyCon (length tys)
408 repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2)
409 repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1)
411 repTy (HsParTy t) = repTy t
413 panic "DsMeta.repTy: Can't represent number types (for generics)"
414 repTy (HsPredTy pred) = repPred pred
415 repTy (HsKindSig ty kind) =
416 panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
419 -----------------------------------------------------------------------------
421 -----------------------------------------------------------------------------
423 repEs :: [HsExpr Name] -> DsM (Core [M.ExpQ])
424 repEs es = do { es' <- mapM repE es ;
425 coreList exprTyConName es' }
427 -- FIXME: some of these panics should be converted into proper error messages
428 -- unless we can make sure that constructs, which are plainly not
429 -- supported in TH already lead to error messages at an earlier stage
430 repE :: HsExpr Name -> DsM (Core M.ExpQ)
432 do { mb_val <- dsLookupMetaEnv x
434 Nothing -> do { str <- globalVar x
435 ; repVarOrCon x str }
436 Just (Bound y) -> repVarOrCon x (coreVar y)
437 Just (Splice e) -> do { e' <- dsExpr e
438 ; return (MkC e') } }
439 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
441 -- Remember, we're desugaring renamer output here, so
442 -- HsOverlit can definitely occur
443 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
444 repE (HsLit l) = do { a <- repLiteral l; repLit a }
445 repE (HsLam m) = repLambda m
446 repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
448 repE (OpApp e1 op fix e2) =
449 do { arg1 <- repE e1;
452 repInfixApp arg1 the_op arg2 }
453 repE (NegApp x nm) = do
455 negateVar <- lookupOcc negateName >>= repVar
457 repE (HsPar x) = repE x
458 repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
459 repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
460 repE (HsCase e ms loc) = do { arg <- repE e
461 ; ms2 <- mapM repMatchTup ms
462 ; repCaseE arg (nonEmptyCoreList ms2) }
463 repE (HsIf x y z loc) = do
468 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
469 ; e2 <- addBinds ss (repE e)
472 -- FIXME: I haven't got the types here right yet
473 repE (HsDo DoExpr sts _ ty loc)
474 = do { (ss,zs) <- repSts sts;
475 e <- repDoE (nonEmptyCoreList zs);
477 repE (HsDo ListComp sts _ ty loc)
478 = do { (ss,zs) <- repSts sts;
479 e <- repComp (nonEmptyCoreList zs);
481 repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
482 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
483 repE (ExplicitPArr ty es) =
484 panic "DsMeta.repE: No explicit parallel arrays yet"
485 repE (ExplicitTuple es boxed)
486 | isBoxed boxed = do { xs <- repEs es; repTup xs }
487 | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
488 repE (RecordCon c flds)
489 = do { x <- lookupOcc c;
490 fs <- repFields flds;
492 repE (RecordUpd e flds)
494 fs <- repFields flds;
497 repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
498 repE (ArithSeqIn aseq) =
500 From e -> do { ds1 <- repE e; repFrom ds1 }
509 FromThenTo e1 e2 e3 -> do
513 repFromThenTo ds1 ds2 ds3
514 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
515 repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
516 repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__"
517 repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
518 repE (HsBracketOut _ _) =
519 panic "DsMeta.repE: Can't represent Oxford brackets"
520 repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n
522 Just (Splice e) -> do { e' <- dsExpr e
524 other -> pprPanic "HsSplice" (ppr n) }
525 repE (HsReify _) = panic "DsMeta.repE: Can't represent reification"
527 pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
529 -----------------------------------------------------------------------------
530 -- Building representations of auxillary structures like Match, Clause, Stmt,
532 repMatchTup :: Match Name -> DsM (Core M.MatchQ)
533 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
534 do { ss1 <- mkGenSyms (collectPatBinders p)
535 ; addBinds ss1 $ do {
537 ; (ss2,ds) <- repBinds wheres
538 ; addBinds ss2 $ do {
539 ; gs <- repGuards guards
540 ; match <- repMatch p1 gs ds
541 ; wrapGenSyns (ss1++ss2) match }}}
543 repClauseTup :: Match Name -> DsM (Core M.ClauseQ)
544 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
545 do { ss1 <- mkGenSyms (collectPatsBinders ps)
546 ; addBinds ss1 $ do {
548 ; (ss2,ds) <- repBinds wheres
549 ; addBinds ss2 $ do {
550 gs <- repGuards guards
551 ; clause <- repClause ps1 gs ds
552 ; wrapGenSyns (ss1++ss2) clause }}}
554 repGuards :: [GRHS Name] -> DsM (Core M.RightHandSideQ)
555 repGuards [GRHS [ResultStmt e loc] loc2]
556 = do {a <- repE e; repNormal a }
558 = do { zs <- mapM process other;
559 repGuarded (nonEmptyCoreList (map corePair zs)) }
561 process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
562 = do { x <- repE e1; y <- repE e2; return (x, y) }
563 process other = panic "Non Haskell 98 guarded body"
565 repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FieldExp])
567 fnames <- mapM lookupOcc (map fst flds)
568 es <- mapM repE (map snd flds)
569 fs <- zipWithM (\n x -> rep2 fieldName [unC n, unC x]) fnames es
570 coreList fieldTyConName fs
573 -----------------------------------------------------------------------------
574 -- Representing Stmt's is tricky, especially if bound variables
575 -- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
576 -- First gensym new names for every variable in any of the patterns.
577 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
578 -- if variables didn't shaddow, the static gensym wouldn't be necessary
579 -- and we could reuse the original names (x and x).
581 -- do { x'1 <- gensym "x"
582 -- ; x'2 <- gensym "x"
583 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
584 -- , BindSt (pvar x'2) [| f x |]
585 -- , NoBindSt [| g x |]
589 -- The strategy is to translate a whole list of do-bindings by building a
590 -- bigger environment, and a bigger set of meta bindings
591 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
592 -- of the expressions within the Do
594 -----------------------------------------------------------------------------
595 -- The helper function repSts computes the translation of each sub expression
596 -- and a bunch of prefix bindings denoting the dynamic renaming.
598 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.StatementQ])
599 repSts [ResultStmt e loc] =
601 ; e1 <- repNoBindSt a
602 ; return ([], [e1]) }
603 repSts (BindStmt p e loc : ss) =
605 ; ss1 <- mkGenSyms (collectPatBinders p)
606 ; addBinds ss1 $ do {
608 ; (ss2,zs) <- repSts ss
609 ; z <- repBindSt p1 e2
610 ; return (ss1++ss2, z : zs) }}
611 repSts (LetStmt bs : ss) =
612 do { (ss1,ds) <- repBinds bs
614 ; (ss2,zs) <- addBinds ss1 (repSts ss)
615 ; return (ss1++ss2, z : zs) }
616 repSts (ExprStmt e ty loc : ss) =
618 ; z <- repNoBindSt e2
619 ; (ss2,zs) <- repSts ss
620 ; return (ss2, z : zs) }
621 repSts other = panic "Exotic Stmt in meta brackets"
624 -----------------------------------------------------------
626 -----------------------------------------------------------
628 repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ])
630 = do { let { bndrs = collectHsBinders decs } ;
631 ss <- mkGenSyms bndrs ;
632 core <- addBinds ss (rep_binds decs) ;
633 core_list <- coreList declTyConName core ;
634 return (ss, core_list) }
636 rep_binds :: HsBinds Name -> DsM [Core M.DecQ]
637 rep_binds binds = do locs_cores <- rep_binds' binds
638 return $ de_loc $ sort_by_loc locs_cores
640 rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
641 rep_binds' EmptyBinds = return []
642 rep_binds' (ThenBinds x y)
643 = do { core1 <- rep_binds' x
644 ; core2 <- rep_binds' y
645 ; return (core1 ++ core2) }
646 rep_binds' (MonoBind bs sigs _)
647 = do { core1 <- rep_monobind' bs
648 ; core2 <- rep_sigs' sigs
649 ; return (core1 ++ core2) }
650 rep_binds' (IPBinds _ _)
651 = panic "DsMeta:repBinds: can't do implicit parameters"
653 rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ]
654 rep_monobind binds = do locs_cores <- rep_monobind' binds
655 return $ de_loc $ sort_by_loc locs_cores
657 rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
658 rep_monobind' EmptyMonoBinds = return []
659 rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x;
660 y1 <- rep_monobind' y;
663 -- Note GHC treats declarations of a variable (not a pattern)
664 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
665 -- with an empty list of patterns
666 rep_monobind' (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
667 = do { (ss,wherecore) <- repBinds wheres
668 ; guardcore <- addBinds ss (repGuards guards)
669 ; fn' <- lookupBinder fn
671 ; ans <- repVal p guardcore wherecore
672 ; return [(loc, ans)] }
674 rep_monobind' (FunMonoBind fn infx ms loc)
675 = do { ms1 <- mapM repClauseTup ms
676 ; fn' <- lookupBinder fn
677 ; ans <- repFun fn' (nonEmptyCoreList ms1)
678 ; return [(loc, ans)] }
680 rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc)
681 = do { patcore <- repP pat
682 ; (ss,wherecore) <- repBinds wheres
683 ; guardcore <- addBinds ss (repGuards guards)
684 ; ans <- repVal patcore guardcore wherecore
685 ; return [(loc, ans)] }
687 rep_monobind' (VarMonoBind v e)
688 = do { v' <- lookupBinder v
691 ; patcore <- repPvar v'
692 ; empty_decls <- coreList declTyConName []
693 ; ans <- repVal patcore x empty_decls
694 ; return [(getSrcLoc v, ans)] }
696 -----------------------------------------------------------------------------
697 -- Since everything in a MonoBind is mutually recursive we need rename all
698 -- all the variables simultaneously. For example:
699 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
700 -- do { f'1 <- gensym "f"
701 -- ; g'2 <- gensym "g"
702 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
703 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
705 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
706 -- environment ( f |-> f'1 ) from each binding, and then unioning them
707 -- together. As we do this we collect GenSymBinds's which represent the renamed
708 -- variables bound by the Bindings. In order not to lose track of these
709 -- representations we build a shadow datatype MB with the same structure as
710 -- MonoBinds, but which has slots for the representations
713 -----------------------------------------------------------------------------
714 -- GHC allows a more general form of lambda abstraction than specified
715 -- by Haskell 98. In particular it allows guarded lambda's like :
716 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
717 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
718 -- (\ p1 .. pn -> exp) by causing an error.
720 repLambda :: Match Name -> DsM (Core M.ExpQ)
721 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
723 = do { let bndrs = collectPatsBinders ps ;
724 ; ss <- mkGenSyms bndrs
725 ; lam <- addBinds ss (
726 do { xs <- repPs ps; body <- repE e; repLam xs body })
727 ; wrapGenSyns ss lam }
729 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
732 -----------------------------------------------------------------------------
734 -- repP deals with patterns. It assumes that we have already
735 -- walked over the pattern(s) once to collect the binders, and
736 -- have extended the environment. So every pattern-bound
737 -- variable should already appear in the environment.
739 -- Process a list of patterns
740 repPs :: [Pat Name] -> DsM (Core [M.Pat])
741 repPs ps = do { ps' <- mapM repP ps ;
742 coreList pattTyConName ps' }
744 repP :: Pat Name -> DsM (Core M.Pat)
745 repP (WildPat _) = repPwild
746 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
747 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
748 repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 }
749 repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
750 repP (ParPat p) = repP p
751 repP (ListPat ps _) = repListPat ps
752 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
753 repP (ConPatIn dc details)
754 = do { con_str <- lookupOcc dc
756 PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
757 RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
758 ; ps <- sequence $ map repP (map snd pairs)
759 ; fps <- zipWithM (\x y -> rep2 fieldPName [unC x,unC y]) vs ps
760 ; fps' <- coreList fieldPTyConName fps
761 ; repPrec con_str fps' }
762 InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
764 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
765 repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
766 repP other = panic "Exotic pattern inside meta brackets"
768 repListPat :: [Pat Name] -> DsM (Core M.Pat)
769 repListPat [] = do { nil_con <- coreStringLit "[]"
770 ; nil_args <- coreList pattTyConName []
771 ; repPcon nil_con nil_args }
772 repListPat (p:ps) = do { p2 <- repP p
773 ; ps2 <- repListPat ps
774 ; cons_con <- coreStringLit ":"
775 ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
778 ----------------------------------------------------------
779 -- Declaration ordering helpers
781 sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)]
782 sort_by_loc xs = sortBy comp xs
783 where comp x y = compare (fst x) (fst y)
785 de_loc :: [(SrcLoc, a)] -> [a]
788 ----------------------------------------------------------
789 -- The meta-environment
791 -- A name/identifier association for fresh names of locally bound entities
793 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
794 -- I.e. (x, x_id) means
795 -- let x_id = gensym "x" in ...
797 -- Generate a fresh name for a locally bound entity
799 mkGenSym :: Name -> DsM GenSymBind
800 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
802 -- Ditto for a list of names
804 mkGenSyms :: [Name] -> DsM [GenSymBind]
805 mkGenSyms ns = mapM mkGenSym ns
807 -- Add a list of fresh names for locally bound entities to the meta
808 -- environment (which is part of the state carried around by the desugarer
811 addBinds :: [GenSymBind] -> DsM a -> DsM a
812 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
814 -- Look up a locally bound name
816 lookupBinder :: Name -> DsM (Core String)
818 = do { mb_val <- dsLookupMetaEnv n;
820 Just (Bound x) -> return (coreVar x)
821 other -> pprPanic "Failed binder lookup:" (ppr n) }
823 -- Look up a name that is either locally bound or a global name
825 -- * If it is a global name, generate the "original name" representation (ie,
826 -- the <module>:<name> form) for the associated entity
828 lookupOcc :: Name -> DsM (Core String)
829 -- Lookup an occurrence; it can't be a splice.
830 -- Use the in-scope bindings if they exist
832 = do { mb_val <- dsLookupMetaEnv n ;
834 Nothing -> globalVar n
835 Just (Bound x) -> return (coreVar x)
836 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
839 globalVar :: Name -> DsM (Core String)
840 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
842 name_mod = moduleUserString (nameModule n)
843 name_occ = occNameUserString (nameOccName n)
845 localVar :: Name -> DsM (Core String)
846 localVar n = coreStringLit (occNameUserString (nameOccName n))
848 lookupType :: Name -- Name of type constructor (e.g. M.ExpQ)
849 -> DsM Type -- The type
850 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
851 return (mkGenTyConApp tc []) }
853 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
854 -- --> bindQ (gensym nm1) (\ id1 ->
855 -- bindQ (gensym nm2 (\ id2 ->
858 wrapGenSyns :: [GenSymBind]
859 -> Core (M.Q a) -> DsM (Core (M.Q a))
860 wrapGenSyns binds body@(MkC b)
863 [elt_ty] = tcTyConAppArgs (exprType b)
864 -- b :: Q a, so we can get the type 'a' by looking at the
865 -- argument type. NB: this relies on Q being a data/newtype,
866 -- not a type synonym
869 go ((name,id) : binds)
870 = do { MkC body' <- go binds
871 ; lit_str <- localVar name
872 ; gensym_app <- repGensym lit_str
873 ; repBindQ stringTy elt_ty
874 gensym_app (MkC (Lam id body')) }
876 -- Just like wrapGenSym, but don't actually do the gensym
877 -- Instead use the existing name
878 -- Only used for [Decl]
879 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
880 wrapNongenSyms binds (MkC body)
881 = do { binds' <- mapM do_one binds ;
882 return (MkC (mkLets binds' body)) }
885 = do { MkC lit_str <- localVar name -- No gensym
886 ; return (NonRec id lit_str) }
888 void = placeHolderType
890 string :: String -> HsExpr Id
891 string s = HsLit (HsString (mkFastString s))
894 -- %*********************************************************************
898 -- %*********************************************************************
900 -----------------------------------------------------------------------------
901 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
902 -- we invent a new datatype which uses phantom types.
904 newtype Core a = MkC CoreExpr
907 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
908 rep2 n xs = do { id <- dsLookupGlobalId n
909 ; return (MkC (foldl App (Var id) xs)) }
911 -- Then we make "repConstructors" which use the phantom types for each of the
912 -- smart constructors of the Meta.Meta datatypes.
915 -- %*********************************************************************
917 -- The 'smart constructors'
919 -- %*********************************************************************
921 --------------- Patterns -----------------
922 repPlit :: Core M.Lit -> DsM (Core M.Pat)
923 repPlit (MkC l) = rep2 plitName [l]
925 repPvar :: Core String -> DsM (Core M.Pat)
926 repPvar (MkC s) = rep2 pvarName [s]
928 repPtup :: Core [M.Pat] -> DsM (Core M.Pat)
929 repPtup (MkC ps) = rep2 ptupName [ps]
931 repPcon :: Core String -> Core [M.Pat] -> DsM (Core M.Pat)
932 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
934 repPrec :: Core String -> Core [(String,M.Pat)] -> DsM (Core M.Pat)
935 repPrec (MkC c) (MkC rps) = rep2 precName [c,rps]
937 repPtilde :: Core M.Pat -> DsM (Core M.Pat)
938 repPtilde (MkC p) = rep2 ptildeName [p]
940 repPaspat :: Core String -> Core M.Pat -> DsM (Core M.Pat)
941 repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
943 repPwild :: DsM (Core M.Pat)
944 repPwild = rep2 pwildName []
946 --------------- Expressions -----------------
947 repVarOrCon :: Name -> Core String -> DsM (Core M.ExpQ)
948 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
949 | otherwise = repVar str
951 repVar :: Core String -> DsM (Core M.ExpQ)
952 repVar (MkC s) = rep2 varName [s]
954 repCon :: Core String -> DsM (Core M.ExpQ)
955 repCon (MkC s) = rep2 conName [s]
957 repLit :: Core M.Lit -> DsM (Core M.ExpQ)
958 repLit (MkC c) = rep2 litName [c]
960 repApp :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
961 repApp (MkC x) (MkC y) = rep2 appName [x,y]
963 repLam :: Core [M.Pat] -> Core M.ExpQ -> DsM (Core M.ExpQ)
964 repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
966 repTup :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
967 repTup (MkC es) = rep2 tupName [es]
969 repCond :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
970 repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z]
972 repLetE :: Core [M.DecQ] -> Core M.ExpQ -> DsM (Core M.ExpQ)
973 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
975 repCaseE :: Core M.ExpQ -> Core [M.MatchQ] -> DsM( Core M.ExpQ)
976 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
978 repDoE :: Core [M.StatementQ] -> DsM (Core M.ExpQ)
979 repDoE (MkC ss) = rep2 doEName [ss]
981 repComp :: Core [M.StatementQ] -> DsM (Core M.ExpQ)
982 repComp (MkC ss) = rep2 compName [ss]
984 repListExp :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
985 repListExp (MkC es) = rep2 listExpName [es]
987 repSigExp :: Core M.ExpQ -> Core M.TypQ -> DsM (Core M.ExpQ)
988 repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
990 repRecCon :: Core String -> Core [M.FieldExp]-> DsM (Core M.ExpQ)
991 repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs]
993 repRecUpd :: Core M.ExpQ -> Core [M.FieldExp] -> DsM (Core M.ExpQ)
994 repRecUpd (MkC e) (MkC fs) = rep2 recUpdName [e,fs]
996 repInfixApp :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
997 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
999 repSectionL :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1000 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1002 repSectionR :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1003 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1005 ------------ Right hand sides (guarded expressions) ----
1006 repGuarded :: Core [(M.ExpQ, M.ExpQ)] -> DsM (Core M.RightHandSideQ)
1007 repGuarded (MkC pairs) = rep2 guardedName [pairs]
1009 repNormal :: Core M.ExpQ -> DsM (Core M.RightHandSideQ)
1010 repNormal (MkC e) = rep2 normalName [e]
1012 ------------- Statements -------------------
1013 repBindSt :: Core M.Pat -> Core M.ExpQ -> DsM (Core M.StatementQ)
1014 repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
1016 repLetSt :: Core [M.DecQ] -> DsM (Core M.StatementQ)
1017 repLetSt (MkC ds) = rep2 letStName [ds]
1019 repNoBindSt :: Core M.ExpQ -> DsM (Core M.StatementQ)
1020 repNoBindSt (MkC e) = rep2 noBindStName [e]
1022 -------------- DotDot (Arithmetic sequences) -----------
1023 repFrom :: Core M.ExpQ -> DsM (Core M.ExpQ)
1024 repFrom (MkC x) = rep2 fromName [x]
1026 repFromThen :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1027 repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
1029 repFromTo :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1030 repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
1032 repFromThenTo :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1033 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
1035 ------------ Match and Clause Tuples -----------
1036 repMatch :: Core M.Pat -> Core M.RightHandSideQ -> Core [M.DecQ] -> DsM (Core M.MatchQ)
1037 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1039 repClause :: Core [M.Pat] -> Core M.RightHandSideQ -> Core [M.DecQ] -> DsM (Core M.ClauseQ)
1040 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1042 -------------- Dec -----------------------------
1043 repVal :: Core M.Pat -> Core M.RightHandSideQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
1044 repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
1046 repFun :: Core String -> Core [M.ClauseQ] -> DsM (Core M.DecQ)
1047 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
1049 repData :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.ConQ] -> Core [String] -> DsM (Core M.DecQ)
1050 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1052 repTySyn :: Core String -> Core [String] -> Core M.TypQ -> DsM (Core M.DecQ)
1053 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1055 repInst :: Core M.CxtQ -> Core M.TypQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
1056 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
1058 repClass :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.DecQ] -> DsM (Core M.DecQ)
1059 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
1061 repProto :: Core String -> Core M.TypQ -> DsM (Core M.DecQ)
1062 repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
1064 repCtxt :: Core [M.TypQ] -> DsM (Core M.CxtQ)
1065 repCtxt (MkC tys) = rep2 ctxtName [tys]
1067 repConstr :: Core String -> HsConDetails Name (BangType Name)
1068 -> DsM (Core M.ConQ)
1069 repConstr con (PrefixCon ps)
1070 = do arg_tys <- mapM repBangTy ps
1071 arg_tys1 <- coreList strTypeTyConName arg_tys
1072 rep2 constrName [unC con, unC arg_tys1]
1073 repConstr con (RecCon ips)
1074 = do arg_vs <- mapM lookupOcc (map fst ips)
1075 arg_tys <- mapM repBangTy (map snd ips)
1076 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1078 arg_vtys' <- coreList varStrTypeTyConName arg_vtys
1079 rep2 recConstrName [unC con, unC arg_vtys']
1080 repConstr con (InfixCon st1 st2)
1081 = do arg1 <- repBangTy st1
1082 arg2 <- repBangTy st2
1083 rep2 infixConstrName [unC arg1, unC con, unC arg2]
1085 ------------ Types -------------------
1087 repTForall :: Core [String] -> Core M.CxtQ -> Core M.TypQ -> DsM (Core M.TypQ)
1088 repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 tforallName [tvars, ctxt, ty]
1090 repTvar :: Core String -> DsM (Core M.TypQ)
1091 repTvar (MkC s) = rep2 tvarName [s]
1093 repTapp :: Core M.TypQ -> Core M.TypQ -> DsM (Core M.TypQ)
1094 repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
1096 repTapps :: Core M.TypQ -> [Core M.TypQ] -> DsM (Core M.TypQ)
1097 repTapps f [] = return f
1098 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1100 --------- Type constructors --------------
1102 repNamedTyCon :: Core String -> DsM (Core M.TypQ)
1103 repNamedTyCon (MkC s) = rep2 namedTyConName [s]
1105 repTupleTyCon :: Int -> DsM (Core M.TypQ)
1106 -- Note: not Core Int; it's easier to be direct here
1107 repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
1109 repArrowTyCon :: DsM (Core M.TypQ)
1110 repArrowTyCon = rep2 arrowTyConName []
1112 repListTyCon :: DsM (Core M.TypQ)
1113 repListTyCon = rep2 listTyConName []
1116 ----------------------------------------------------------
1119 repLiteral :: HsLit -> DsM (Core M.Lit)
1121 = do lit' <- case lit of
1122 HsIntPrim i -> return $ HsInteger i
1123 HsInt i -> return $ HsInteger i
1124 HsFloatPrim r -> do rat_ty <- lookupType rationalTyConName
1125 return $ HsRat r rat_ty
1126 HsDoublePrim r -> do rat_ty <- lookupType rationalTyConName
1127 return $ HsRat r rat_ty
1129 lit_expr <- dsLit lit'
1130 rep2 lit_name [lit_expr]
1132 lit_name = case lit of
1133 HsInteger _ -> integerLName
1134 HsInt _ -> integerLName
1135 HsIntPrim _ -> intPrimLName
1136 HsFloatPrim _ -> floatPrimLName
1137 HsDoublePrim _ -> doublePrimLName
1138 HsChar _ -> charLName
1139 HsString _ -> stringLName
1140 HsRat _ _ -> rationalLName
1142 uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1145 repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
1146 repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInteger i)
1147 repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
1148 repLiteral (HsRat f rat_ty) }
1149 -- The type Rational will be in the environment, becuase
1150 -- the smart constructor 'THSyntax.rationalL' uses it in its type,
1151 -- and rationalL is sucked in when any TH stuff is used
1153 --------------- Miscellaneous -------------------
1155 repLift :: Core e -> DsM (Core M.ExpQ)
1156 repLift (MkC x) = rep2 liftName [x]
1158 repGensym :: Core String -> DsM (Core (M.Q String))
1159 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
1161 repBindQ :: Type -> Type -- a and b
1162 -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
1163 repBindQ ty_a ty_b (MkC x) (MkC y)
1164 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1166 repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
1167 repSequenceQ ty_a (MkC list)
1168 = rep2 sequenceQName [Type ty_a, list]
1170 ------------ Lists and Tuples -------------------
1171 -- turn a list of patterns into a single pattern matching a list
1173 coreList :: Name -- Of the TyCon of the element type
1174 -> [Core a] -> DsM (Core [a])
1176 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1178 coreList' :: Type -- The element type
1179 -> [Core a] -> Core [a]
1180 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1182 nonEmptyCoreList :: [Core a] -> Core [a]
1183 -- The list must be non-empty so we can get the element type
1184 -- Otherwise use coreList
1185 nonEmptyCoreList [] = panic "coreList: empty argument"
1186 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1188 corePair :: (Core a, Core b) -> Core (a,b)
1189 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1191 coreStringLit :: String -> DsM (Core String)
1192 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
1194 coreVar :: Id -> Core String -- The Id has type String
1195 coreVar id = MkC (Var id)
1199 -- %************************************************************************
1201 -- The known-key names for Template Haskell
1203 -- %************************************************************************
1205 -- To add a name, do three things
1207 -- 1) Allocate a key
1209 -- 3) Add the name to knownKeyNames
1211 templateHaskellNames :: NameSet
1212 -- The names that are implicitly mentioned by ``bracket''
1213 -- Should stay in sync with the import list of DsMeta
1214 templateHaskellNames
1215 = mkNameSet [ intPrimLName, floatPrimLName, doublePrimLName,
1216 integerLName, charLName, stringLName, rationalLName,
1217 plitName, pvarName, ptupName,
1218 pconName, ptildeName, paspatName, pwildName,
1219 varName, conName, litName, appName, infixEName, lamName,
1220 tupName, doEName, compName,
1221 listExpName, sigExpName, condName, letEName, caseEName,
1222 infixAppName, sectionLName, sectionRName,
1223 guardedName, normalName,
1224 bindStName, letStName, noBindStName, parStName,
1225 fromName, fromThenName, fromToName, fromThenToName,
1226 funName, valName, liftName,
1227 gensymName, returnQName, bindQName, sequenceQName,
1228 matchName, clauseName, funName, valName, tySynDName, dataDName, classDName,
1229 instName, protoName, tforallName, tvarName, tconName, tappName,
1230 arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
1231 ctxtName, constrName, recConstrName, infixConstrName,
1232 exprTyConName, declTyConName, pattTyConName, mtchTyConName,
1233 clseTyConName, stmtTyConName, consTyConName, typeTyConName,
1234 strTypeTyConName, varStrTypeTyConName,
1235 qTyConName, expTyConName, matTyConName, clsTyConName,
1236 decTyConName, typTyConName, strictTypeName, varStrictTypeName,
1237 recConName, recUpdName, precName,
1238 fieldName, fieldTyConName, fieldPName, fieldPTyConName,
1239 strictName, nonstrictName ]
1242 varQual = mk_known_key_name OccName.varName
1243 tcQual = mk_known_key_name OccName.tcName
1246 -- NB: the THSyntax module comes from the "haskell-src" package
1247 thModule = mkThPkgModule mETA_META_Name
1249 mk_known_key_name space str uniq
1250 = mkKnownKeyExternalName thModule (mkOccFS space str) uniq
1252 intPrimLName = varQual FSLIT("intPrimL") intPrimLIdKey
1253 floatPrimLName = varQual FSLIT("floatPrimL") floatPrimLIdKey
1254 doublePrimLName = varQual FSLIT("doublePrimL") doublePrimLIdKey
1255 integerLName = varQual FSLIT("integerL") integerLIdKey
1256 charLName = varQual FSLIT("charL") charLIdKey
1257 stringLName = varQual FSLIT("stringL") stringLIdKey
1258 rationalLName = varQual FSLIT("rationalL") rationalLIdKey
1259 plitName = varQual FSLIT("plit") plitIdKey
1260 pvarName = varQual FSLIT("pvar") pvarIdKey
1261 ptupName = varQual FSLIT("ptup") ptupIdKey
1262 pconName = varQual FSLIT("pcon") pconIdKey
1263 ptildeName = varQual FSLIT("ptilde") ptildeIdKey
1264 paspatName = varQual FSLIT("paspat") paspatIdKey
1265 pwildName = varQual FSLIT("pwild") pwildIdKey
1266 precName = varQual FSLIT("prec") precIdKey
1267 varName = varQual FSLIT("var") varIdKey
1268 conName = varQual FSLIT("con") conIdKey
1269 litName = varQual FSLIT("lit") litIdKey
1270 appName = varQual FSLIT("app") appIdKey
1271 infixEName = varQual FSLIT("infixE") infixEIdKey
1272 lamName = varQual FSLIT("lam") lamIdKey
1273 tupName = varQual FSLIT("tup") tupIdKey
1274 doEName = varQual FSLIT("doE") doEIdKey
1275 compName = varQual FSLIT("comp") compIdKey
1276 listExpName = varQual FSLIT("listExp") listExpIdKey
1277 sigExpName = varQual FSLIT("sigExp") sigExpIdKey
1278 condName = varQual FSLIT("cond") condIdKey
1279 letEName = varQual FSLIT("letE") letEIdKey
1280 caseEName = varQual FSLIT("caseE") caseEIdKey
1281 infixAppName = varQual FSLIT("infixApp") infixAppIdKey
1282 sectionLName = varQual FSLIT("sectionL") sectionLIdKey
1283 sectionRName = varQual FSLIT("sectionR") sectionRIdKey
1284 recConName = varQual FSLIT("recCon") recConIdKey
1285 recUpdName = varQual FSLIT("recUpd") recUpdIdKey
1286 guardedName = varQual FSLIT("guarded") guardedIdKey
1287 normalName = varQual FSLIT("normal") normalIdKey
1288 bindStName = varQual FSLIT("bindSt") bindStIdKey
1289 letStName = varQual FSLIT("letSt") letStIdKey
1290 noBindStName = varQual FSLIT("noBindSt") noBindStIdKey
1291 parStName = varQual FSLIT("parSt") parStIdKey
1292 fromName = varQual FSLIT("from") fromIdKey
1293 fromThenName = varQual FSLIT("fromThen") fromThenIdKey
1294 fromToName = varQual FSLIT("fromTo") fromToIdKey
1295 fromThenToName = varQual FSLIT("fromThenTo") fromThenToIdKey
1296 liftName = varQual FSLIT("lift") liftIdKey
1297 gensymName = varQual FSLIT("gensym") gensymIdKey
1298 returnQName = varQual FSLIT("returnQ") returnQIdKey
1299 bindQName = varQual FSLIT("bindQ") bindQIdKey
1300 sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey
1303 matchName = varQual FSLIT("match") matchIdKey
1305 -- data Clause = ...
1306 clauseName = varQual FSLIT("clause") clauseIdKey
1309 funName = varQual FSLIT("fun") funIdKey
1310 valName = varQual FSLIT("val") valIdKey
1311 dataDName = varQual FSLIT("dataD") dataDIdKey
1312 tySynDName = varQual FSLIT("tySynD") tySynDIdKey
1313 classDName = varQual FSLIT("classD") classDIdKey
1314 instName = varQual FSLIT("inst") instIdKey
1315 protoName = varQual FSLIT("proto") protoIdKey
1318 tforallName = varQual FSLIT("tforall") tforallIdKey
1319 tvarName = varQual FSLIT("tvar") tvarIdKey
1320 tconName = varQual FSLIT("tcon") tconIdKey
1321 tappName = varQual FSLIT("tapp") tappIdKey
1324 arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey
1325 tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey
1326 listTyConName = varQual FSLIT("listTyCon") listIdKey
1327 namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey
1330 ctxtName = varQual FSLIT("cxt") ctxtIdKey
1333 constrName = varQual FSLIT("constr") constrIdKey
1334 recConstrName = varQual FSLIT("recConstr") recConstrIdKey
1335 infixConstrName = varQual FSLIT("infixConstr") infixConstrIdKey
1337 exprTyConName = tcQual FSLIT("ExpQ") exprTyConKey
1338 declTyConName = tcQual FSLIT("DecQ") declTyConKey
1339 pattTyConName = tcQual FSLIT("Pat") pattTyConKey
1340 mtchTyConName = tcQual FSLIT("MatchQ") mtchTyConKey
1341 clseTyConName = tcQual FSLIT("ClauseQ") clseTyConKey
1342 stmtTyConName = tcQual FSLIT("StatementQ") stmtTyConKey
1343 consTyConName = tcQual FSLIT("ConQ") consTyConKey
1344 typeTyConName = tcQual FSLIT("TypQ") typeTyConKey
1345 strTypeTyConName = tcQual FSLIT("StrType") strTypeTyConKey
1346 varStrTypeTyConName = tcQual FSLIT("VarStrType") varStrTypeTyConKey
1348 fieldTyConName = tcQual FSLIT("FieldExp") fieldTyConKey
1349 fieldPTyConName = tcQual FSLIT("FieldPat") fieldPTyConKey
1351 qTyConName = tcQual FSLIT("Q") qTyConKey
1352 expTyConName = tcQual FSLIT("Exp") expTyConKey
1353 decTyConName = tcQual FSLIT("Dec") decTyConKey
1354 typTyConName = tcQual FSLIT("Typ") typTyConKey
1355 matTyConName = tcQual FSLIT("Match") matTyConKey
1356 clsTyConName = tcQual FSLIT("Clause") clsTyConKey
1358 strictTypeName = varQual FSLIT("strictType") strictTypeKey
1359 varStrictTypeName = varQual FSLIT("varStrictType") varStrictTypeKey
1360 strictName = varQual FSLIT("strict") strictKey
1361 nonstrictName = varQual FSLIT("nonstrict") nonstrictKey
1363 fieldName = varQual FSLIT("fieldExp") fieldKey
1364 fieldPName = varQual FSLIT("fieldPat") fieldPKey
1366 -- TyConUniques available: 100-119
1367 -- Check in PrelNames if you want to change this
1369 expTyConKey = mkPreludeTyConUnique 100
1370 matTyConKey = mkPreludeTyConUnique 101
1371 clsTyConKey = mkPreludeTyConUnique 102
1372 qTyConKey = mkPreludeTyConUnique 103
1373 exprTyConKey = mkPreludeTyConUnique 104
1374 declTyConKey = mkPreludeTyConUnique 105
1375 pattTyConKey = mkPreludeTyConUnique 106
1376 mtchTyConKey = mkPreludeTyConUnique 107
1377 clseTyConKey = mkPreludeTyConUnique 108
1378 stmtTyConKey = mkPreludeTyConUnique 109
1379 consTyConKey = mkPreludeTyConUnique 110
1380 typeTyConKey = mkPreludeTyConUnique 111
1381 typTyConKey = mkPreludeTyConUnique 112
1382 decTyConKey = mkPreludeTyConUnique 113
1383 varStrTypeTyConKey = mkPreludeTyConUnique 114
1384 strTypeTyConKey = mkPreludeTyConUnique 115
1385 fieldTyConKey = mkPreludeTyConUnique 116
1386 fieldPTyConKey = mkPreludeTyConUnique 117
1390 -- IdUniques available: 200-299
1391 -- If you want to change this, make sure you check in PrelNames
1392 fromIdKey = mkPreludeMiscIdUnique 200
1393 fromThenIdKey = mkPreludeMiscIdUnique 201
1394 fromToIdKey = mkPreludeMiscIdUnique 202
1395 fromThenToIdKey = mkPreludeMiscIdUnique 203
1396 liftIdKey = mkPreludeMiscIdUnique 204
1397 gensymIdKey = mkPreludeMiscIdUnique 205
1398 returnQIdKey = mkPreludeMiscIdUnique 206
1399 bindQIdKey = mkPreludeMiscIdUnique 207
1400 funIdKey = mkPreludeMiscIdUnique 208
1401 valIdKey = mkPreludeMiscIdUnique 209
1402 protoIdKey = mkPreludeMiscIdUnique 210
1403 matchIdKey = mkPreludeMiscIdUnique 211
1404 clauseIdKey = mkPreludeMiscIdUnique 212
1405 integerLIdKey = mkPreludeMiscIdUnique 213
1406 charLIdKey = mkPreludeMiscIdUnique 214
1408 classDIdKey = mkPreludeMiscIdUnique 215
1409 instIdKey = mkPreludeMiscIdUnique 216
1410 dataDIdKey = mkPreludeMiscIdUnique 217
1412 sequenceQIdKey = mkPreludeMiscIdUnique 218
1413 tySynDIdKey = mkPreludeMiscIdUnique 219
1415 plitIdKey = mkPreludeMiscIdUnique 220
1416 pvarIdKey = mkPreludeMiscIdUnique 221
1417 ptupIdKey = mkPreludeMiscIdUnique 222
1418 pconIdKey = mkPreludeMiscIdUnique 223
1419 ptildeIdKey = mkPreludeMiscIdUnique 224
1420 paspatIdKey = mkPreludeMiscIdUnique 225
1421 pwildIdKey = mkPreludeMiscIdUnique 226
1422 varIdKey = mkPreludeMiscIdUnique 227
1423 conIdKey = mkPreludeMiscIdUnique 228
1424 litIdKey = mkPreludeMiscIdUnique 229
1425 appIdKey = mkPreludeMiscIdUnique 230
1426 infixEIdKey = mkPreludeMiscIdUnique 231
1427 lamIdKey = mkPreludeMiscIdUnique 232
1428 tupIdKey = mkPreludeMiscIdUnique 233
1429 doEIdKey = mkPreludeMiscIdUnique 234
1430 compIdKey = mkPreludeMiscIdUnique 235
1431 listExpIdKey = mkPreludeMiscIdUnique 237
1432 condIdKey = mkPreludeMiscIdUnique 238
1433 letEIdKey = mkPreludeMiscIdUnique 239
1434 caseEIdKey = mkPreludeMiscIdUnique 240
1435 infixAppIdKey = mkPreludeMiscIdUnique 241
1437 sectionLIdKey = mkPreludeMiscIdUnique 243
1438 sectionRIdKey = mkPreludeMiscIdUnique 244
1439 guardedIdKey = mkPreludeMiscIdUnique 245
1440 normalIdKey = mkPreludeMiscIdUnique 246
1441 bindStIdKey = mkPreludeMiscIdUnique 247
1442 letStIdKey = mkPreludeMiscIdUnique 248
1443 noBindStIdKey = mkPreludeMiscIdUnique 249
1444 parStIdKey = mkPreludeMiscIdUnique 250
1446 tforallIdKey = mkPreludeMiscIdUnique 251
1447 tvarIdKey = mkPreludeMiscIdUnique 252
1448 tconIdKey = mkPreludeMiscIdUnique 253
1449 tappIdKey = mkPreludeMiscIdUnique 254
1451 arrowIdKey = mkPreludeMiscIdUnique 255
1452 tupleIdKey = mkPreludeMiscIdUnique 256
1453 listIdKey = mkPreludeMiscIdUnique 257
1454 namedTyConIdKey = mkPreludeMiscIdUnique 258
1456 ctxtIdKey = mkPreludeMiscIdUnique 259
1458 constrIdKey = mkPreludeMiscIdUnique 260
1460 stringLIdKey = mkPreludeMiscIdUnique 261
1461 rationalLIdKey = mkPreludeMiscIdUnique 262
1463 sigExpIdKey = mkPreludeMiscIdUnique 263
1465 strictTypeKey = mkPreludeMiscIdUnique 264
1466 strictKey = mkPreludeMiscIdUnique 265
1467 nonstrictKey = mkPreludeMiscIdUnique 266
1468 varStrictTypeKey = mkPreludeMiscIdUnique 267
1470 recConstrIdKey = mkPreludeMiscIdUnique 268
1471 infixConstrIdKey = mkPreludeMiscIdUnique 269
1473 recConIdKey = mkPreludeMiscIdUnique 270
1474 recUpdIdKey = mkPreludeMiscIdUnique 271
1475 precIdKey = mkPreludeMiscIdUnique 272
1476 fieldKey = mkPreludeMiscIdUnique 273
1477 fieldPKey = mkPreludeMiscIdUnique 274
1479 intPrimLIdKey = mkPreludeMiscIdUnique 275
1480 floatPrimLIdKey = mkPreludeMiscIdUnique 276
1481 doublePrimLIdKey = mkPreludeMiscIdUnique 277
1483 -- %************************************************************************
1487 -- %************************************************************************
1489 -- It is rather usatisfactory that we don't have a SrcLoc
1490 addDsWarn :: SDoc -> DsM ()
1491 addDsWarn msg = dsWarn (noSrcLoc, msg)