Context Navigation

DsMeta.hs

Visit:

Revision aa487406a0ff96a2e02ebe6c40b5191dabcc9b2e, 97.5 KB (checked in by Simon Peyton Jones <simonpj@…>, 4 days ago)

Wibbles from 'Fix scoping of kind variables in instance declarations'

This earlier commit

6a8b4290 * Fix scoping of kind variables in instance declarations

make became a bit more rigourous about ensuring that the kind-variable
field of LHsTyVarBndrs was properly filled after renaming. This patch
fixed DsMeta? to follow suit.

Property mode set to 100644

Line
1	-----------------------------------------------------------------------------
2	--
3	-- (c) The University of Glasgow 2006
4	--
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.
9	--
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	-----------------------------------------------------------------------------
15
16	{-# OPTIONS -fno-warn-tabs #-}
17	-- The above warning supression flag is a temporary kludge.
18	-- While working on this module you are encouraged to remove it and
19	-- detab the module (please do the detabbing in a separate patch). See
20	-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
21	-- for details
22
23	module DsMeta( dsBracket,
24	templateHaskellNames, qTyConName, nameTyConName,
25	liftName, liftStringName, expQTyConName, patQTyConName,
26	decQTyConName, decsQTyConName, typeQTyConName,
27	decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
28	quoteExpName, quotePatName, quoteDecName, quoteTypeName
29	) where
30
31	#include "HsVersions.h"
32
33	import {-# SOURCE #-} DsExpr ( dsExpr )
34
35	import MatchLit
36	import DsMonad
37
38	import qualified Language.Haskell.TH as TH
39
40	import HsSyn
41	import Class
42	import PrelNames
43	-- To avoid clashes with DsMeta.varName we must make a local alias for
44	-- OccName.varName we do this by removing varName from the import of
45	-- OccName above, making a qualified instance of OccName and using
46	-- OccNameAlias.varName where varName ws previously used in this file.
47	import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName )
48
49	import Module
50	import Id
51	import Name hiding( isVarOcc, isTcOcc, varName, tcName )
52	import NameEnv
53	import TcType
54	import TyCon
55	import TysWiredIn
56	import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
57	import CoreSyn
58	import MkCore
59	import CoreUtils
60	import SrcLoc
61	import Unique
62	import BasicTypes
63	import Outputable
64	import Bag
65	import FastString
66	import ForeignCall
67	import MonadUtils
68	import Util( equalLength, filterOut )
69
70	import Data.Maybe
71	import Control.Monad
72	import Data.List
73
74	-----------------------------------------------------------------------------
75	dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
76	-- Returns a CoreExpr of type TH.ExpQ
77	-- The quoted thing is parameterised over Name, even though it has
78	-- been type checked. We don't want all those type decorations!
79
80	dsBracket brack splices
81	= dsExtendMetaEnv new_bit (do_brack brack)
82	where
83	new_bit = mkNameEnv [(n, Splice (unLoc e)) \| (n,e) <- splices]
84
85	do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
86	do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
87	do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 }
88	do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
89	do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
90	do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL"
91
92	{- -------------- Examples --------------------
93
94	[\| \x -> x \|]
95	====>
96	gensym (unpackString "x"#) `bindQ` \ x1::String ->
97	lam (pvar x1) (var x1)
98
99
100	[\| \x -> $(f [\| x \|]) \|]
101	====>
102	gensym (unpackString "x"#) `bindQ` \ x1::String ->
103	lam (pvar x1) (f (var x1))
104	-}
105
106
107	-------------------------------------------------------
108	-- Declarations
109	-------------------------------------------------------
110
111	repTopP :: LPat Name -> DsM (Core TH.PatQ)
112	repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
113	; pat' <- addBinds ss (repLP pat)
114	; wrapGenSyms ss pat' }
115
116	repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
117	repTopDs group
118	= do { let { tv_bndrs = hsSigTvBinders (hs_valds group)
119	; bndrs = tv_bndrs ++ hsGroupBinders group } ;
120	ss <- mkGenSyms bndrs ;
121
122	-- Bind all the names mainly to avoid repeated use of explicit strings.
123	-- Thus we get
124	-- do { t :: String <- genSym "T" ;
125	-- return (Data t [] ...more t's... }
126	-- The other important reason is that the output must mention
127	-- only "T", not "Foo:T" where Foo is the current module
128
129	decls <- addBinds ss (do {
130	fix_ds <- mapM repFixD (hs_fixds group) ;
131	val_ds <- rep_val_binds (hs_valds group) ;
132	tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
133	inst_ds <- mapM repInstD (hs_instds group) ;
134	for_ds <- mapM repForD (hs_fords group) ;
135	-- more needed
136	return (de_loc $ sort_by_loc $
137	val_ds ++ catMaybes tycl_ds ++ fix_ds
138	++ inst_ds ++ for_ds) }) ;
139
140	decl_ty <- lookupType decQTyConName ;
141	let { core_list = coreList' decl_ty decls } ;
142
143	dec_ty <- lookupType decTyConName ;
144	q_decs <- repSequenceQ dec_ty core_list ;
145
146	wrapGenSyms ss q_decs
147	}
148
149
150	hsSigTvBinders :: HsValBinds Name -> [Name]
151	-- See Note [Scoped type variables in bindings]
152	hsSigTvBinders binds
153	= [hsLTyVarName tv \| L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs
154	, tv <- hsQTvBndrs qtvs]
155	where
156	sigs = case binds of
157	ValBindsIn _ sigs -> sigs
158	ValBindsOut _ sigs -> sigs
159
160
161	{- Notes
162
163	Note [Scoped type variables in bindings]
164	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
165	Consider
166	f :: forall a. a -> a
167	f x = x::a
168	Here the 'forall a' brings 'a' into scope over the binding group.
169	To achieve this we
170
171	a) Gensym a binding for 'a' at the same time as we do one for 'f'
172	collecting the relevant binders with hsSigTvBinders
173
174	b) When processing the 'forall', don't gensym
175
176	The relevant places are signposted with references to this Note
177
178	Note [Binders and occurrences]
179	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
180	When we desugar [d\| data T = MkT \|]
181	we want to get
182	Data "T" [] [Con "MkT" []] []
183	and not
184	Data "Foo:T" [] [Con "Foo:MkT" []] []
185	That is, the new data decl should fit into whatever new module it is
186	asked to fit in. We do not clone, though; no need for this:
187	Data "T79" ....
188
189	But if we see this:
190	data T = MkT
191	foo = reifyDecl T
192
193	then we must desugar to
194	foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
195
196	So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
197	And we use lookupOcc, rather than lookupBinder
198	in repTyClD and repC.
199
200	-}
201
202	-- represent associated family instances
203	--
204	repTyClDs :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
205	repTyClDs ds = liftM de_loc (mapMaybeM repTyClD ds)
206
207
208	repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
209
210	repTyClD (L loc (TyFamily { tcdFlavour = flavour,
211	tcdLName = tc, tcdTyVars = tvs,
212	tcdKindSig = opt_kind }))
213	= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
214	; dec <- addTyClTyVarBinds tvs $ \bndrs ->
215	do { flav <- repFamilyFlavour flavour
216	; case opt_kind of
217	Nothing -> repFamilyNoKind flav tc1 bndrs
218	Just ki -> do { ki1 <- repLKind ki
219	; repFamilyKind flav tc1 bndrs ki1 }
220	}
221	; return $ Just (loc, dec)
222	}
223
224	repTyClD (L loc (TyDecl { tcdLName = tc, tcdTyVars = tvs, tcdTyDefn = defn }))
225	= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
226	; tc_tvs <- mk_extra_tvs tc tvs defn
227	; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
228	repTyDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
229	; return (Just (loc, dec)) }
230
231	repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
232	tcdTyVars = tvs, tcdFDs = fds,
233	tcdSigs = sigs, tcdMeths = meth_binds,
234	tcdATs = ats, tcdATDefs = [] }))
235	= do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
236	; dec <- addTyVarBinds tvs $ \bndrs ->
237	do { cxt1 <- repLContext cxt
238	; sigs1 <- rep_sigs sigs
239	; binds1 <- rep_binds meth_binds
240	; fds1 <- repLFunDeps fds
241	; ats1 <- repTyClDs ats
242	; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
243	; repClass cxt1 cls1 bndrs fds1 decls1
244	}
245	; return $ Just (loc, dec)
246	}
247
248	-- Un-handled cases
249	repTyClD (L loc d) = putSrcSpanDs loc $
250	do { warnDs (hang ds_msg 4 (ppr d))
251	; return Nothing }
252
253	-------------------------
254	repTyDefn :: Core TH.Name -> Core [TH.TyVarBndr]
255	-> Maybe (Core [TH.TypeQ])
256	-> [Name] -> HsTyDefn Name
257	-> DsM (Core TH.DecQ)
258	repTyDefn tc bndrs opt_tys tv_names
259	(TyData { td_ND = new_or_data, td_ctxt = cxt
260	, td_cons = cons, td_derivs = mb_derivs })
261	= do { cxt1 <- repLContext cxt
262	; derivs1 <- repDerivs mb_derivs
263	; case new_or_data of
264	NewType -> do { con1 <- repC tv_names (head cons)
265	; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 }
266	DataType -> do { cons1 <- mapM (repC tv_names) cons
267	; cons2 <- coreList conQTyConName cons1
268	; repData cxt1 tc bndrs opt_tys cons2 derivs1 } }
269
270	repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty })
271	= do { ty1 <- repLTy ty
272	; repTySyn tc bndrs opt_tys ty1 }
273
274	-------------------------
275	mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
276	-> HsTyDefn Name -> DsM (LHsTyVarBndrs Name)
277	-- If there is a kind signature it must be of form
278	-- k1 -> .. -> kn -> *
279	-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
280	mk_extra_tvs tc tvs defn
281	\| TyData { td_kindSig = Just hs_kind } <- defn
282	= do { extra_tvs <- go hs_kind
283	; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
284	\| otherwise
285	= return tvs
286	where
287	go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
288	go (L loc (HsFunTy kind rest))
289	= do { uniq <- newUnique
290	; let { occ = mkTyVarOccFS (fsLit "t")
291	; nm = mkInternalName uniq occ loc
292	; hs_tv = L loc (KindedTyVar nm kind) }
293	; hs_tvs <- go rest
294	; return (hs_tv : hs_tvs) }
295
296	go (L _ (HsTyVar n))
297	\| n == liftedTypeKindTyConName
298	= return []
299
300	go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
301
302	-------------------------
303	-- represent fundeps
304	--
305	repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
306	repLFunDeps fds = do fds' <- mapM repLFunDep fds
307	fdList <- coreList funDepTyConName fds'
308	return fdList
309
310	repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
311	repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
312	ys' <- mapM lookupBinder ys
313	xs_list <- coreList nameTyConName xs'
314	ys_list <- coreList nameTyConName ys'
315	repFunDep xs_list ys_list
316
317	-- represent family declaration flavours
318	--
319	repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
320	repFamilyFlavour TypeFamily = rep2 typeFamName []
321	repFamilyFlavour DataFamily = rep2 dataFamName []
322
323	-- Represent instance declarations
324	--
325	repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
326	repInstD (L loc (FamInstD { lid_inst = fi_decl }))
327	= do { dec <- repFamInstD fi_decl
328	; return (loc, dec) }
329
330	repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
331	, cid_sigs = prags, cid_fam_insts = ats }))
332	= do { dec <- addTyVarBinds tvs $ \_ ->
333	-- We must bring the type variables into scope, so their
334	-- occurrences don't fail, even though the binders don't
335	-- appear in the resulting data structure
336	--
337	-- But we do NOT bring the binders of 'binds' into scope
338	-- becuase they are properly regarded as occurrences
339	-- For example, the method names should be bound to
340	-- the selector Ids, not to fresh names (Trac #5410)
341	--
342	do { cxt1 <- repContext cxt
343	; cls_tcon <- repTy (HsTyVar (unLoc cls))
344	; cls_tys <- repLTys tys
345	; inst_ty1 <- repTapps cls_tcon cls_tys
346	; binds1 <- rep_binds binds
347	; prags1 <- rep_sigs prags
348	; ats1 <- mapM (repFamInstD . unLoc) ats
349	; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1)
350	; repInst cxt1 inst_ty1 decls }
351	; return (loc, dec) }
352	where
353	Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
354
355	repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
356	repFamInstD (FamInstDecl { fid_tycon = tc_name
357	, fid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
358	, fid_defn = defn })
359	= WARN( not (null kv_names), ppr kv_names ) -- We have not yet dealt with kind
360	-- polymorphism in Template Haskell (sigh)
361	do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
362	; let loc = getLoc tc_name
363	hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
364	; addTyClTyVarBinds hs_tvs $ \ bndrs ->
365	do { tys1 <- repLTys tys
366	; tys2 <- coreList typeQTyConName tys1
367	; repTyDefn tc bndrs (Just tys2) tv_names defn } }
368
369	repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
370	repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
371	= do MkC name' <- lookupLOcc name
372	MkC typ' <- repLTy typ
373	MkC cc' <- repCCallConv cc
374	MkC s' <- repSafety s
375	cis' <- conv_cimportspec cis
376	MkC str <- coreStringLit (static ++ chStr ++ cis')
377	dec <- rep2 forImpDName [cc', s', str, name', typ']
378	return (loc, dec)
379	where
380	conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
381	conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
382	conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
383	conv_cimportspec (CFunction (StaticTarget _ _ False)) = panic "conv_cimportspec: values not supported yet"
384	conv_cimportspec CWrapper = return "wrapper"
385	static = case cis of
386	CFunction (StaticTarget _ _ _) -> "static "
387	_ -> ""
388	chStr = case mch of
389	Nothing -> ""
390	Just (Header h) -> unpackFS h ++ " "
391	repForD decl = notHandled "Foreign declaration" (ppr decl)
392
393	repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
394	repCCallConv CCallConv = rep2 cCallName []
395	repCCallConv StdCallConv = rep2 stdCallName []
396	repCCallConv callConv = notHandled "repCCallConv" (ppr callConv)
397
398	repSafety :: Safety -> DsM (Core TH.Safety)
399	repSafety PlayRisky = rep2 unsafeName []
400	repSafety PlayInterruptible = rep2 interruptibleName []
401	repSafety PlaySafe = rep2 safeName []
402
403	repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ)
404	repFixD (L loc (FixitySig name (Fixity prec dir)))
405	= do { MkC name' <- lookupLOcc name
406	; MkC prec' <- coreIntLit prec
407	; let rep_fn = case dir of
408	InfixL -> infixLDName
409	InfixR -> infixRDName
410	InfixN -> infixNDName
411	; dec <- rep2 rep_fn [prec', name']
412	; return (loc, dec) }
413
414	ds_msg :: SDoc
415	ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
416
417	-------------------------------------------------------
418	-- Constructors
419	-------------------------------------------------------
420
421	repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
422	repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
423	, con_details = details, con_res = ResTyH98 }))
424	\| null (hsQTvBndrs con_tvs)
425	= do { con1 <- lookupLOcc con -- See Note [Binders and occurrences]
426	; repConstr con1 details }
427
428	repC tvs (L _ (ConDecl { con_name = con
429	, con_qvars = con_tvs, con_cxt = L _ ctxt
430	, con_details = details
431	, con_res = res_ty }))
432	= do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
433	; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)
434	, hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }
435
436	; binds <- mapM dupBinder con_tv_subst
437	; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
438	addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs
439	do { con1 <- lookupLOcc con -- See Note [Binders and occurrences]
440	; c' <- repConstr con1 details
441	; ctxt' <- repContext (eq_ctxt ++ ctxt)
442	; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
443
444	in_subst :: [(Name,Name)] -> Name -> Bool
445	in_subst [] _ = False
446	in_subst ((n',_):ns) n = n==n' \|\| in_subst ns n
447
448	mkGadtCtxt :: [Name] -- Tyvars of the data type
449	-> ResType (LHsType Name)
450	-> DsM (HsContext Name, [(Name,Name)])
451	-- Given a data type in GADT syntax, figure out the equality
452	-- context, so that we can represent it with an explicit
453	-- equality context, because that is the only way to express
454	-- the GADT in TH syntax
455	--
456	-- Example:
457	-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
458	-- mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
459	-- returns
460	-- (b~[e], c~e), [d->a]
461	--
462	-- This function is fiddly, but not really hard
463	mkGadtCtxt _ ResTyH98
464	= return ([], [])
465	mkGadtCtxt data_tvs (ResTyGADT res_ty)
466	\| let (head_ty, tys) = splitHsAppTys res_ty []
467	, Just _ <- is_hs_tyvar head_ty
468	, data_tvs `equalLength` tys
469	= return (go [] [] (data_tvs `zip` tys))
470
471	\| otherwise
472	= failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
473	where
474	go cxt subst [] = (cxt, subst)
475	go cxt subst ((data_tv, ty) : rest)
476	\| Just con_tv <- is_hs_tyvar ty
477	, isTyVarName con_tv
478	, not (in_subst subst con_tv)
479	= go cxt ((con_tv, data_tv) : subst) rest
480	\| otherwise
481	= go (eq_pred : cxt) subst rest
482	where
483	loc = getLoc ty
484	eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
485
486	is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables and tycons
487	is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
488	is_hs_tyvar _ = Nothing
489
490
491	repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
492	repBangTy ty= do
493	MkC s <- rep2 str []
494	MkC t <- repLTy ty'
495	rep2 strictTypeName [s, t]
496	where
497	(str, ty') = case ty of
498	L _ (HsBangTy HsUnpack ty) -> (unpackedName, ty)
499	L _ (HsBangTy _ ty) -> (isStrictName, ty)
500	_ -> (notStrictName, ty)
501
502	-------------------------------------------------------
503	-- Deriving clause
504	-------------------------------------------------------
505
506	repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
507	repDerivs Nothing = coreList nameTyConName []
508	repDerivs (Just ctxt)
509	= do { strs <- mapM rep_deriv ctxt ;
510	coreList nameTyConName strs }
511	where
512	rep_deriv :: LHsType Name -> DsM (Core TH.Name)
513	-- Deriving clauses must have the simple H98 form
514	rep_deriv ty
515	\| Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
516	= lookupOcc cls
517	\| otherwise
518	= notHandled "Non-H98 deriving clause" (ppr ty)
519
520
521	-------------------------------------------------------
522	-- Signatures in a class decl, or a group of bindings
523	-------------------------------------------------------
524
525	rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
526	rep_sigs sigs = do locs_cores <- rep_sigs' sigs
527	return $ de_loc $ sort_by_loc locs_cores
528
529	rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
530	-- We silently ignore ones we don't recognise
531	rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
532	return (concat sigs1) }
533
534	rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
535	-- Singleton => Ok
536	-- Empty => Too hard, signature ignored
537	rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig loc ty) nms
538	rep_sig (L _ (GenericSig nm _)) = failWithDs msg
539	where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
540	, ptext (sLit "Default signatures are not supported by Template Haskell") ]
541
542	rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
543	rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
544	rep_sig _ = return []
545
546	rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
547	-> DsM (SrcSpan, Core TH.DecQ)
548	rep_ty_sig loc (L _ ty) nm
549	= do { nm1 <- lookupLOcc nm
550	; ty1 <- rep_ty ty
551	; sig <- repProto nm1 ty1
552	; return (loc, sig) }
553	where
554	-- We must special-case the top-level explicit for-all of a TypeSig
555	-- See Note [Scoped type variables in bindings]
556	rep_ty (HsForAllTy Explicit tvs ctxt ty)
557	= do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
558	; repTyVarBndrWithKind tv name }
559	; bndrs1 <- mapM rep_in_scope_tv (hsQTvBndrs tvs)
560	; bndrs2 <- coreList tyVarBndrTyConName bndrs1
561	; ctxt1 <- repLContext ctxt
562	; ty1 <- repLTy ty
563	; repTForall bndrs2 ctxt1 ty1 }
564
565	rep_ty ty = repTy ty
566
567
568	rep_inline :: Located Name
569	-> InlinePragma -- Never defaultInlinePragma
570	-> SrcSpan
571	-> DsM [(SrcSpan, Core TH.DecQ)]
572	rep_inline nm ispec loc
573	= do { nm1 <- lookupLOcc nm
574	; ispec1 <- rep_InlinePrag ispec
575	; pragma <- repPragInl nm1 ispec1
576	; return [(loc, pragma)]
577	}
578
579	rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
580	-> DsM [(SrcSpan, Core TH.DecQ)]
581	rep_specialise nm ty ispec loc
582	= do { nm1 <- lookupLOcc nm
583	; ty1 <- repLTy ty
584	; pragma <- if isDefaultInlinePragma ispec
585	then repPragSpec nm1 ty1 -- SPECIALISE
586	else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE
587	; repPragSpecInl nm1 ty1 ispec1 }
588	; return [(loc, pragma)]
589	}
590
591	repInline :: InlineSpec -> DsM (Core TH.Inline)
592	repInline NoInline = dataCon noInlineDataConName
593	repInline Inline = dataCon inlineDataConName
594	repInline Inlinable = dataCon inlinableDataConName
595	repInline spec = notHandled "repInline" (ppr spec)
596
597	-- Extract all the information needed to build a TH.InlinePrag
598	--
599	rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
600	-> DsM (Core TH.InlineSpecQ)
601	rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
602	\| Just (flag, phase) <- activation1
603	= do { inline1 <- repInline inline
604	; repInlineSpecPhase inline1 match1 flag phase }
605	\| otherwise
606	= do { inline1 <- repInline inline
607	; repInlineSpecNoPhase inline1 match1 }
608	where
609	match1 = coreBool (rep_RuleMatchInfo match)
610	activation1 = rep_Activation activation
611	rep_RuleMatchInfo FunLike = False
612	rep_RuleMatchInfo ConLike = True
613
614	rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive
615	rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive
616	rep_Activation (ActiveBefore phase) = Just (coreBool False,
617	MkC $ mkIntExprInt phase)
618	rep_Activation (ActiveAfter phase) = Just (coreBool True,
619	MkC $ mkIntExprInt phase)
620
621
622	-------------------------------------------------------
623	-- Types
624	-------------------------------------------------------
625
626	addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added
627	-> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
628	-> DsM (Core (TH.Q a))
629	-- gensym a list of type variables and enter them into the meta environment;
630	-- the computations passed as the second argument is executed in that extended
631	-- meta environment and gets the new names on Core-level as an argument
632
633	addTyVarBinds tvs m
634	= do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs)
635	; term <- addBinds freshNames $
636	do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
637	; kbs2 <- coreList tyVarBndrTyConName kbs1
638	; m kbs2 }
639	; wrapGenSyms freshNames term }
640	where
641	mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
642
643	addTyClTyVarBinds :: LHsTyVarBndrs Name
644	-> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
645	-> DsM (Core (TH.Q a))
646
647	-- Used for data/newtype declarations, and family instances,
648	-- so that the nested type variables work right
649	-- instance C (T a) where
650	-- type W (T a) = blah
651	-- The 'a' in the type instance is the one bound by the instance decl
652	addTyClTyVarBinds tvs m
653	= do { let tv_names = hsLKiTyVarNames tvs
654	; env <- dsGetMetaEnv
655	; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
656	-- Make fresh names for the ones that are not already in scope
657	-- This makes things work for family declarations
658
659	; term <- addBinds freshNames $
660	do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs)
661	; kbs2 <- coreList tyVarBndrTyConName kbs1
662	; m kbs2 }
663
664	; wrapGenSyms freshNames term }
665	where
666	mk_tv_bndr tv = do { v <- lookupOcc (hsLTyVarName tv)
667	; repTyVarBndrWithKind tv v }
668
669	-- Produce kinded binder constructors from the Haskell tyvar binders
670	--
671	repTyVarBndrWithKind :: LHsTyVarBndr Name
672	-> Core TH.Name -> DsM (Core TH.TyVarBndr)
673	repTyVarBndrWithKind (L _ (UserTyVar {})) nm
674	= repPlainTV nm
675	repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
676	= repLKind ki >>= repKindedTV nm
677
678	-- represent a type context
679	--
680	repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
681	repLContext (L _ ctxt) = repContext ctxt
682
683	repContext :: HsContext Name -> DsM (Core TH.CxtQ)
684	repContext ctxt = do
685	preds <- mapM repLPred ctxt
686	predList <- coreList predQTyConName preds
687	repCtxt predList
688
689	-- represent a type predicate
690	--
691	repLPred :: LHsType Name -> DsM (Core TH.PredQ)
692	repLPred (L _ p) = repPred p
693
694	repPred :: HsType Name -> DsM (Core TH.PredQ)
695	repPred ty
696	\| Just (cls, tys) <- splitHsClassTy_maybe ty
697	= do
698	cls1 <- lookupOcc cls
699	tys1 <- repLTys tys
700	tys2 <- coreList typeQTyConName tys1
701	repClassP cls1 tys2
702	repPred (HsEqTy tyleft tyright)
703	= do
704	tyleft1 <- repLTy tyleft
705	tyright1 <- repLTy tyright
706	repEqualP tyleft1 tyright1
707	repPred ty
708	= notHandled "Exotic predicate type" (ppr ty)
709
710	-- yield the representation of a list of types
711	--
712	repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
713	repLTys tys = mapM repLTy tys
714
715	-- represent a type
716	--
717	repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
718	repLTy (L _ ty) = repTy ty
719
720	repTy :: HsType Name -> DsM (Core TH.TypeQ)
721	repTy (HsForAllTy _ tvs ctxt ty) =
722	addTyVarBinds tvs $ \bndrs -> do
723	ctxt1 <- repLContext ctxt
724	ty1 <- repLTy ty
725	repTForall bndrs ctxt1 ty1
726
727	repTy (HsTyVar n)
728	\| isTvOcc occ = do tv1 <- lookupOcc n
729	repTvar tv1
730	\| isDataOcc occ = do tc1 <- lookupOcc n
731	repPromotedTyCon tc1
732	\| otherwise = do tc1 <- lookupOcc n
733	repNamedTyCon tc1
734	where
735	occ = nameOccName n
736
737	repTy (HsAppTy f a) = do
738	f1 <- repLTy f
739	a1 <- repLTy a
740	repTapp f1 a1
741	repTy (HsFunTy f a) = do
742	f1 <- repLTy f
743	a1 <- repLTy a
744	tcon <- repArrowTyCon
745	repTapps tcon [f1, a1]
746	repTy (HsListTy t) = do
747	t1 <- repLTy t
748	tcon <- repListTyCon
749	repTapp tcon t1
750	repTy (HsPArrTy t) = do
751	t1 <- repLTy t
752	tcon <- repTy (HsTyVar (tyConName parrTyCon))
753	repTapp tcon t1
754	repTy (HsTupleTy HsUnboxedTuple tys) = do
755	tys1 <- repLTys tys
756	tcon <- repUnboxedTupleTyCon (length tys)
757	repTapps tcon tys1
758	repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
759	tcon <- repTupleTyCon (length tys)
760	repTapps tcon tys1
761	repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
762	`nlHsAppTy` ty2)
763	repTy (HsParTy t) = repLTy t
764	repTy (HsKindSig t k) = do
765	t1 <- repLTy t
766	k1 <- repLKind k
767	repTSig t1 k1
768	repTy (HsSpliceTy splice _ _) = repSplice splice
769	repTy (HsExplicitListTy _ tys) = do
770	tys1 <- repLTys tys
771	repTPromotedList tys1
772	repTy (HsExplicitTupleTy _ tys) = do
773	tys1 <- repLTys tys
774	tcon <- repPromotedTupleTyCon (length tys)
775	repTapps tcon tys1
776	repTy (HsTyLit lit) = do
777	lit' <- repTyLit lit
778	repTLit lit'
779	repTy ty = notHandled "Exotic form of type" (ppr ty)
780
781	repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
782	repTyLit (HsNumTy i) = rep2 numTyLitName [mkIntExpr i]
783	repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
784	; rep2 strTyLitName [s']
785	}
786
787	-- represent a kind
788	--
789	repLKind :: LHsKind Name -> DsM (Core TH.Kind)
790	repLKind ki
791	= do { let (kis, ki') = splitHsFunType ki
792	; kis_rep <- mapM repLKind kis
793	; ki'_rep <- repNonArrowLKind ki'
794	; kcon <- repKArrow
795	; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
796	; foldrM f ki'_rep kis_rep
797	}
798
799	repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
800	repNonArrowLKind (L _ ki) = repNonArrowKind ki
801
802	repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
803	repNonArrowKind (HsTyVar name)
804	\| name == liftedTypeKindTyConName = repKStar
805	\| name == constraintKindTyConName = repKConstraint
806	\| isTvOcc (nameOccName name) = lookupOcc name >>= repKVar
807	\| otherwise = lookupOcc name >>= repKCon
808	repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f
809	; a' <- repLKind a
810	; repKApp f' a'
811	}
812	repNonArrowKind (HsListTy k) = do { k' <- repLKind k
813	; kcon <- repKList
814	; repKApp kcon k'
815	}
816	repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks
817	; kcon <- repKTuple (length ks)
818	; repKApps kcon ks'
819	}
820	repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
821
822	-----------------------------------------------------------------------------
823	-- Splices
824	-----------------------------------------------------------------------------
825
826	repSplice :: HsSplice Name -> DsM (Core a)
827	-- See Note [How brackets and nested splices are handled] in TcSplice
828	-- We return a CoreExpr of any old type; the context should know
829	repSplice (HsSplice n _)
830	= do { mb_val <- dsLookupMetaEnv n
831	; case mb_val of
832	Just (Splice e) -> do { e' <- dsExpr e
833	; return (MkC e') }
834	_ -> pprPanic "HsSplice" (ppr n) }
835	-- Should not happen; statically checked
836
837	-----------------------------------------------------------------------------
838	-- Expressions
839	-----------------------------------------------------------------------------
840
841	repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
842	repLEs es = do { es' <- mapM repLE es ;
843	coreList expQTyConName es' }
844
845	-- FIXME: some of these panics should be converted into proper error messages
846	-- unless we can make sure that constructs, which are plainly not
847	-- supported in TH already lead to error messages at an earlier stage
848	repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
849	repLE (L loc e) = putSrcSpanDs loc (repE e)
850
851	repE :: HsExpr Name -> DsM (Core TH.ExpQ)
852	repE (HsVar x) =
853	do { mb_val <- dsLookupMetaEnv x
854	; case mb_val of
855	Nothing -> do { str <- globalVar x
856	; repVarOrCon x str }
857	Just (Bound y) -> repVarOrCon x (coreVar y)
858	Just (Splice e) -> do { e' <- dsExpr e
859	; return (MkC e') } }
860	repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
861
862	-- Remember, we're desugaring renamer output here, so
863	-- HsOverlit can definitely occur
864	repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
865	repE (HsLit l) = do { a <- repLiteral l; repLit a }
866	repE (HsLam (MatchGroup [m] _)) = repLambda m
867	repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
868
869	repE (OpApp e1 op _ e2) =
870	do { arg1 <- repLE e1;
871	arg2 <- repLE e2;
872	the_op <- repLE op ;
873	repInfixApp arg1 the_op arg2 }
874	repE (NegApp x _) = do
875	a <- repLE x
876	negateVar <- lookupOcc negateName >>= repVar
877	negateVar `repApp` a
878	repE (HsPar x) = repLE x
879	repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
880	repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
881	repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
882	; ms2 <- mapM repMatchTup ms
883	; repCaseE arg (nonEmptyCoreList ms2) }
884	repE (HsIf _ x y z) = do
885	a <- repLE x
886	b <- repLE y
887	c <- repLE z
888	repCond a b c
889	repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
890	; e2 <- addBinds ss (repLE e)
891	; z <- repLetE ds e2
892	; wrapGenSyms ss z }
893
894	-- FIXME: I haven't got the types here right yet
895	repE e@(HsDo ctxt sts _)
896	\| case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
897	= do { (ss,zs) <- repLSts sts;
898	e' <- repDoE (nonEmptyCoreList zs);
899	wrapGenSyms ss e' }
900
901	\| ListComp <- ctxt
902	= do { (ss,zs) <- repLSts sts;
903	e' <- repComp (nonEmptyCoreList zs);
904	wrapGenSyms ss e' }
905
906	\| otherwise
907	= notHandled "mdo, monad comprehension and [: :]" (ppr e)
908
909	repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
910	repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
911	repE e@(ExplicitTuple es boxed)
912	\| not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
913	\| isBoxed boxed = do { xs <- repLEs [e \| Present e <- es]; repTup xs }
914	\| otherwise = do { xs <- repLEs [e \| Present e <- es]; repUnboxedTup xs }
915
916	repE (RecordCon c _ flds)
917	= do { x <- lookupLOcc c;
918	fs <- repFields flds;
919	repRecCon x fs }
920	repE (RecordUpd e flds _ _ _)
921	= do { x <- repLE e;
922	fs <- repFields flds;
923	repRecUpd x fs }
924
925	repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
926	repE (ArithSeq _ aseq) =
927	case aseq of
928	From e -> do { ds1 <- repLE e; repFrom ds1 }
929	FromThen e1 e2 -> do
930	ds1 <- repLE e1
931	ds2 <- repLE e2
932	repFromThen ds1 ds2
933	FromTo e1 e2 -> do
934	ds1 <- repLE e1
935	ds2 <- repLE e2
936	repFromTo ds1 ds2
937	FromThenTo e1 e2 e3 -> do
938	ds1 <- repLE e1
939	ds2 <- repLE e2
940	ds3 <- repLE e3
941	repFromThenTo ds1 ds2 ds3
942
943	repE (HsSpliceE splice) = repSplice splice
944	repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
945	repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
946	repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
947	repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
948	repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
949	repE e = notHandled "Expression form" (ppr e)
950
951	-----------------------------------------------------------------------------
952	-- Building representations of auxillary structures like Match, Clause, Stmt,
953
954	repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
955	repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
956	do { ss1 <- mkGenSyms (collectPatBinders p)
957	; addBinds ss1 $ do {
958	; p1 <- repLP p
959	; (ss2,ds) <- repBinds wheres
960	; addBinds ss2 $ do {
961	; gs <- repGuards guards
962	; match <- repMatch p1 gs ds
963	; wrapGenSyms (ss1++ss2) match }}}
964	repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
965
966	repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
967	repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
968	do { ss1 <- mkGenSyms (collectPatsBinders ps)
969	; addBinds ss1 $ do {
970	ps1 <- repLPs ps
971	; (ss2,ds) <- repBinds wheres
972	; addBinds ss2 $ do {
973	gs <- repGuards guards
974	; clause <- repClause ps1 gs ds
975	; wrapGenSyms (ss1++ss2) clause }}}
976
977	repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
978	repGuards [L _ (GRHS [] e)]
979	= do {a <- repLE e; repNormal a }
980	repGuards other
981	= do { zs <- mapM process other;
982	let {(xs, ys) = unzip zs};
983	gd <- repGuarded (nonEmptyCoreList ys);
984	wrapGenSyms (concat xs) gd }
985	where
986	process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
987	process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
988	= do { x <- repLNormalGE e1 e2;
989	return ([], x) }
990	process (L _ (GRHS ss rhs))
991	= do (gs, ss') <- repLSts ss
992	rhs' <- addBinds gs $ repLE rhs
993	g <- repPatGE (nonEmptyCoreList ss') rhs'
994	return (gs, g)
995
996	repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
997	repFields (HsRecFields { rec_flds = flds })
998	= do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
999	; es <- mapM repLE (map hsRecFieldArg flds)
1000	; fs <- zipWithM repFieldExp fnames es
1001	; coreList fieldExpQTyConName fs }
1002
1003
1004	-----------------------------------------------------------------------------
1005	-- Representing Stmt's is tricky, especially if bound variables
1006	-- shadow each other. Consider: [\| do { x <- f 1; x <- f x; g x } \|]
1007	-- First gensym new names for every variable in any of the patterns.
1008	-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
1009	-- if variables didn't shaddow, the static gensym wouldn't be necessary
1010	-- and we could reuse the original names (x and x).
1011	--
1012	-- do { x'1 <- gensym "x"
1013	-- ; x'2 <- gensym "x"
1014	-- ; doE [ BindSt (pvar x'1) [\| f 1 \|]
1015	-- , BindSt (pvar x'2) [\| f x \|]
1016	-- , NoBindSt [\| g x \|]
1017	-- ]
1018	-- }
1019
1020	-- The strategy is to translate a whole list of do-bindings by building a
1021	-- bigger environment, and a bigger set of meta bindings
1022	-- (like: x'1 <- gensym "x" ) and then combining these with the translations
1023	-- of the expressions within the Do
1024
1025	-----------------------------------------------------------------------------
1026	-- The helper function repSts computes the translation of each sub expression
1027	-- and a bunch of prefix bindings denoting the dynamic renaming.
1028
1029	repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
1030	repLSts stmts = repSts (map unLoc stmts)
1031
1032	repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
1033	repSts (BindStmt p e _ _ : ss) =
1034	do { e2 <- repLE e
1035	; ss1 <- mkGenSyms (collectPatBinders p)
1036	; addBinds ss1 $ do {
1037	; p1 <- repLP p;
1038	; (ss2,zs) <- repSts ss
1039	; z <- repBindSt p1 e2
1040	; return (ss1++ss2, z : zs) }}
1041	repSts (LetStmt bs : ss) =
1042	do { (ss1,ds) <- repBinds bs
1043	; z <- repLetSt ds
1044	; (ss2,zs) <- addBinds ss1 (repSts ss)
1045	; return (ss1++ss2, z : zs) }
1046	repSts (ExprStmt e _ _ _ : ss) =
1047	do { e2 <- repLE e
1048	; z <- repNoBindSt e2
1049	; (ss2,zs) <- repSts ss
1050	; return (ss2, z : zs) }
1051	repSts [LastStmt e _]
1052	= do { e2 <- repLE e
1053	; z <- repNoBindSt e2
1054	; return ([], [z]) }
1055	repSts [] = return ([],[])
1056	repSts other = notHandled "Exotic statement" (ppr other)
1057
1058
1059	-----------------------------------------------------------
1060	-- Bindings
1061	-----------------------------------------------------------
1062
1063	repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
1064	repBinds EmptyLocalBinds
1065	= do { core_list <- coreList decQTyConName []
1066	; return ([], core_list) }
1067
1068	repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
1069
1070	repBinds (HsValBinds decs)
1071	= do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
1072	-- No need to worrry about detailed scopes within
1073	-- the binding group, because we are talking Names
1074	-- here, so we can safely treat it as a mutually
1075	-- recursive group
1076	-- For hsSigTvBinders see Note [Scoped type variables in bindings]
1077	; ss <- mkGenSyms bndrs
1078	; prs <- addBinds ss (rep_val_binds decs)
1079	; core_list <- coreList decQTyConName
1080	(de_loc (sort_by_loc prs))
1081	; return (ss, core_list) }
1082
1083	rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1084	-- Assumes: all the binders of the binding are alrady in the meta-env
1085	rep_val_binds (ValBindsOut binds sigs)
1086	= do { core1 <- rep_binds' (unionManyBags (map snd binds))
1087	; core2 <- rep_sigs' sigs
1088	; return (core1 ++ core2) }
1089	rep_val_binds (ValBindsIn _ _)
1090	= panic "rep_val_binds: ValBindsIn"
1091
1092	rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
1093	rep_binds binds = do { binds_w_locs <- rep_binds' binds
1094	; return (de_loc (sort_by_loc binds_w_locs)) }
1095
1096	rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1097	rep_binds' binds = mapM rep_bind (bagToList binds)
1098
1099	rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
1100	-- Assumes: all the binders of the binding are alrady in the meta-env
1101
1102	-- Note GHC treats declarations of a variable (not a pattern)
1103	-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1104	-- with an empty list of patterns
1105	rep_bind (L loc (FunBind { fun_id = fn,
1106	fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
1107	= do { (ss,wherecore) <- repBinds wheres
1108	; guardcore <- addBinds ss (repGuards guards)
1109	; fn' <- lookupLBinder fn
1110	; p <- repPvar fn'
1111	; ans <- repVal p guardcore wherecore
1112	; ans' <- wrapGenSyms ss ans
1113	; return (loc, ans') }
1114
1115	rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
1116	= do { ms1 <- mapM repClauseTup ms
1117	; fn' <- lookupLBinder fn
1118	; ans <- repFun fn' (nonEmptyCoreList ms1)
1119	; return (loc, ans) }
1120
1121	rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
1122	= do { patcore <- repLP pat
1123	; (ss,wherecore) <- repBinds wheres
1124	; guardcore <- addBinds ss (repGuards guards)
1125	; ans <- repVal patcore guardcore wherecore
1126	; ans' <- wrapGenSyms ss ans
1127	; return (loc, ans') }
1128
1129	rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1130	= do { v' <- lookupBinder v
1131	; e2 <- repLE e
1132	; x <- repNormal e2
1133	; patcore <- repPvar v'
1134	; empty_decls <- coreList decQTyConName []
1135	; ans <- repVal patcore x empty_decls
1136	; return (srcLocSpan (getSrcLoc v), ans) }
1137
1138	rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1139
1140	-----------------------------------------------------------------------------
1141	-- Since everything in a Bind is mutually recursive we need rename all
1142	-- all the variables simultaneously. For example:
1143	-- [\| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) \|] would translate to
1144	-- do { f'1 <- gensym "f"
1145	-- ; g'2 <- gensym "g"
1146	-- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [\| x + g2 \|]},
1147	-- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [\| f 1 + 2 \|]}
1148	-- ]}
1149	-- This requires collecting the bindings (f'1 <- gensym "f"), and the
1150	-- environment ( f \|-> f'1 ) from each binding, and then unioning them
1151	-- together. As we do this we collect GenSymBinds's which represent the renamed
1152	-- variables bound by the Bindings. In order not to lose track of these
1153	-- representations we build a shadow datatype MB with the same structure as
1154	-- MonoBinds, but which has slots for the representations
1155
1156
1157	-----------------------------------------------------------------------------
1158	-- GHC allows a more general form of lambda abstraction than specified
1159	-- by Haskell 98. In particular it allows guarded lambda's like :
1160	-- (\ x \| even x -> 0 \| odd x -> 1) at the moment we can't represent this in
1161	-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1162	-- (\ p1 .. pn -> exp) by causing an error.
1163
1164	repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
1165	repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
1166	= do { let bndrs = collectPatsBinders ps ;
1167	; ss <- mkGenSyms bndrs
1168	; lam <- addBinds ss (
1169	do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1170	; wrapGenSyms ss lam }
1171
1172	repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
1173
1174
1175	-----------------------------------------------------------------------------
1176	-- Patterns
1177	-- repP deals with patterns. It assumes that we have already
1178	-- walked over the pattern(s) once to collect the binders, and
1179	-- have extended the environment. So every pattern-bound
1180	-- variable should already appear in the environment.
1181
1182	-- Process a list of patterns
1183	repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1184	repLPs ps = do { ps' <- mapM repLP ps ;
1185	coreList patQTyConName ps' }
1186
1187	repLP :: LPat Name -> DsM (Core TH.PatQ)
1188	repLP (L _ p) = repP p
1189
1190	repP :: Pat Name -> DsM (Core TH.PatQ)
1191	repP (WildPat _) = repPwild
1192	repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1193	repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1194	repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1195	repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1196	repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1197	repP (ParPat p) = repLP p
1198	repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
1199	repP (TuplePat ps boxed _)
1200	\| isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1201	\| otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1202	repP (ConPatIn dc details)
1203	= do { con_str <- lookupLOcc dc
1204	; case details of
1205	PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1206	RecCon rec -> do { let flds = rec_flds rec
1207	; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
1208	; ps <- sequence $ map repLP (map hsRecFieldArg flds)
1209	; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
1210	; fps' <- coreList fieldPatQTyConName fps
1211	; repPrec con_str fps' }
1212	InfixCon p1 p2 -> do { p1' <- repLP p1;
1213	p2' <- repLP p2;
1214	repPinfix p1' con_str p2' }
1215	}
1216	repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1217	repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1218	repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1219	repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1220	-- The problem is to do with scoped type variables.
1221	-- To implement them, we have to implement the scoping rules
1222	-- here in DsMeta, and I don't want to do that today!
1223	-- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1224	-- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1225	-- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1226
1227	repP other = notHandled "Exotic pattern" (ppr other)
1228
1229	----------------------------------------------------------
1230	-- Declaration ordering helpers
1231
1232	sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1233	sort_by_loc xs = sortBy comp xs
1234	where comp x y = compare (fst x) (fst y)
1235
1236	de_loc :: [(a, b)] -> [b]
1237	de_loc = map snd
1238
1239	----------------------------------------------------------
1240	-- The meta-environment
1241
1242	-- A name/identifier association for fresh names of locally bound entities
1243	type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1244	-- I.e. (x, x_id) means
1245	-- let x_id = gensym "x" in ...
1246
1247	-- Generate a fresh name for a locally bound entity
1248
1249	mkGenSyms :: [Name] -> DsM [GenSymBind]
1250	-- We can use the existing name. For example:
1251	-- [\| \x_77 -> x_77 + x_77 \|]
1252	-- desugars to
1253	-- do { x_77 <- genSym "x"; .... }
1254	-- We use the same x_77 in the desugared program, but with the type Bndr
1255	-- instead of Int
1256	--
1257	-- We do make it an Internal name, though (hence localiseName)
1258	--
1259	-- Nevertheless, it's monadic because we have to generate nameTy
1260	mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1261	; return [(nm, mkLocalId (localiseName nm) var_ty) \| nm <- ns] }
1262
1263
1264	addBinds :: [GenSymBind] -> DsM a -> DsM a
1265	-- Add a list of fresh names for locally bound entities to the
1266	-- meta environment (which is part of the state carried around
1267	-- by the desugarer monad)
1268	addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) \| (n,id) <- bs]) m
1269
1270	dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)
1271	dupBinder (new, old)
1272	= do { mb_val <- dsLookupMetaEnv old
1273	; case mb_val of
1274	Just val -> return (new, val)
1275	Nothing -> pprPanic "dupBinder" (ppr old) }
1276
1277	-- Look up a locally bound name
1278	--
1279	lookupLBinder :: Located Name -> DsM (Core TH.Name)
1280	lookupLBinder (L _ n) = lookupBinder n
1281
1282	lookupBinder :: Name -> DsM (Core TH.Name)
1283	lookupBinder = lookupOcc
1284	-- Binders are brought into scope before the pattern or what-not is
1285	-- desugared. Moreover, in instance declaration the binder of a method
1286	-- will be the selector Id and hence a global; so we need the
1287	-- globalVar case of lookupOcc
1288
1289	-- Look up a name that is either locally bound or a global name
1290	--
1291	-- * If it is a global name, generate the "original name" representation (ie,
1292	-- the <module>:<name> form) for the associated entity
1293	--
1294	lookupLOcc :: Located Name -> DsM (Core TH.Name)
1295	-- Lookup an occurrence; it can't be a splice.
1296	-- Use the in-scope bindings if they exist
1297	lookupLOcc (L _ n) = lookupOcc n
1298
1299	lookupOcc :: Name -> DsM (Core TH.Name)
1300	lookupOcc n
1301	= do { mb_val <- dsLookupMetaEnv n ;
1302	case mb_val of
1303	Nothing -> globalVar n
1304	Just (Bound x) -> return (coreVar x)
1305	Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1306	}
1307
1308	globalVar :: Name -> DsM (Core TH.Name)
1309	-- Not bound by the meta-env
1310	-- Could be top-level; or could be local
1311	-- f x = $(g [\| x \|])
1312	-- Here the x will be local
1313	globalVar name
1314	\| isExternalName name
1315	= do { MkC mod <- coreStringLit name_mod
1316	; MkC pkg <- coreStringLit name_pkg
1317	; MkC occ <- occNameLit name
1318	; rep2 mk_varg [pkg,mod,occ] }
1319	\| otherwise
1320	= do { MkC occ <- occNameLit name
1321	; MkC uni <- coreIntLit (getKey (getUnique name))
1322	; rep2 mkNameLName [occ,uni] }
1323	where
1324	mod = ASSERT( isExternalName name) nameModule name
1325	name_mod = moduleNameString (moduleName mod)
1326	name_pkg = packageIdString (modulePackageId mod)
1327	name_occ = nameOccName name
1328	mk_varg \| OccName.isDataOcc name_occ = mkNameG_dName
1329	\| OccName.isVarOcc name_occ = mkNameG_vName
1330	\| OccName.isTcOcc name_occ = mkNameG_tcName
1331	\| otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1332
1333	lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1334	-> DsM Type -- The type
1335	lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1336	return (mkTyConApp tc []) }
1337
1338	wrapGenSyms :: [GenSymBind]
1339	-> Core (TH.Q a) -> DsM (Core (TH.Q a))
1340	-- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1341	-- --> bindQ (gensym nm1) (\ id1 ->
1342	-- bindQ (gensym nm2 (\ id2 ->
1343	-- y))
1344
1345	wrapGenSyms binds body@(MkC b)
1346	= do { var_ty <- lookupType nameTyConName
1347	; go var_ty binds }
1348	where
1349	[elt_ty] = tcTyConAppArgs (exprType b)
1350	-- b :: Q a, so we can get the type 'a' by looking at the
1351	-- argument type. NB: this relies on Q being a data/newtype,
1352	-- not a type synonym
1353
1354	go _ [] = return body
1355	go var_ty ((name,id) : binds)
1356	= do { MkC body' <- go var_ty binds
1357	; lit_str <- occNameLit name
1358	; gensym_app <- repGensym lit_str
1359	; repBindQ var_ty elt_ty
1360	gensym_app (MkC (Lam id body')) }
1361
1362	occNameLit :: Name -> DsM (Core String)
1363	occNameLit n = coreStringLit (occNameString (nameOccName n))
1364
1365
1366	-- %*********************************************************************
1367	-- %* *
1368	-- Constructing code
1369	-- %* *
1370	-- %*********************************************************************
1371
1372	-----------------------------------------------------------------------------
1373	-- PHANTOM TYPES for consistency. In order to make sure we do this correct
1374	-- we invent a new datatype which uses phantom types.
1375
1376	newtype Core a = MkC CoreExpr
1377	unC :: Core a -> CoreExpr
1378	unC (MkC x) = x
1379
1380	rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1381	rep2 n xs = do { id <- dsLookupGlobalId n
1382	; return (MkC (foldl App (Var id) xs)) }
1383
1384	dataCon :: Name -> DsM (Core a)
1385	dataCon n = do { id <- dsLookupDataCon n
1386	; return $ MkC $ mkConApp id [] }
1387
1388	-- Then we make "repConstructors" which use the phantom types for each of the
1389	-- smart constructors of the Meta.Meta datatypes.
1390
1391
1392	-- %*********************************************************************
1393	-- %* *
1394	-- The 'smart constructors'
1395	-- %* *
1396	-- %*********************************************************************
1397
1398	--------------- Patterns -----------------
1399	repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1400	repPlit (MkC l) = rep2 litPName [l]
1401
1402	repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1403	repPvar (MkC s) = rep2 varPName [s]
1404
1405	repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1406	repPtup (MkC ps) = rep2 tupPName [ps]
1407
1408	repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1409	repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1410
1411	repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1412	repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1413
1414	repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1415	repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1416
1417	repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1418	repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1419
1420	repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1421	repPtilde (MkC p) = rep2 tildePName [p]
1422
1423	repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1424	repPbang (MkC p) = rep2 bangPName [p]
1425
1426	repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1427	repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1428
1429	repPwild :: DsM (Core TH.PatQ)
1430	repPwild = rep2 wildPName []
1431
1432	repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1433	repPlist (MkC ps) = rep2 listPName [ps]
1434
1435	repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1436	repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1437
1438	--------------- Expressions -----------------
1439	repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1440	repVarOrCon vc str \| isDataOcc (nameOccName vc) = repCon str
1441	\| otherwise = repVar str
1442
1443	repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1444	repVar (MkC s) = rep2 varEName [s]
1445
1446	repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1447	repCon (MkC s) = rep2 conEName [s]
1448
1449	repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1450	repLit (MkC c) = rep2 litEName [c]
1451
1452	repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1453	repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1454
1455	repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1456	repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1457
1458	repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1459	repTup (MkC es) = rep2 tupEName [es]
1460
1461	repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1462	repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
1463
1464	repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1465	repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1466
1467	repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1468	repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1469
1470	repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1471	repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1472
1473	repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1474	repDoE (MkC ss) = rep2 doEName [ss]
1475
1476	repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1477	repComp (MkC ss) = rep2 compEName [ss]
1478
1479	repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1480	repListExp (MkC es) = rep2 listEName [es]
1481
1482	repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1483	repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1484
1485	repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1486	repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1487
1488	repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1489	repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1490
1491	repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1492	repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1493
1494	repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1495	repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1496
1497	repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1498	repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1499
1500	repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1501	repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1502
1503	------------ Right hand sides (guarded expressions) ----
1504	repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1505	repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1506
1507	repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1508	repNormal (MkC e) = rep2 normalBName [e]
1509
1510	------------ Guards ----
1511	repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1512	repLNormalGE g e = do g' <- repLE g
1513	e' <- repLE e
1514	repNormalGE g' e'
1515
1516	repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1517	repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1518
1519	repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1520	repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1521
1522	------------- Stmts -------------------
1523	repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1524	repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1525
1526	repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1527	repLetSt (MkC ds) = rep2 letSName [ds]
1528
1529	repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1530	repNoBindSt (MkC e) = rep2 noBindSName [e]
1531
1532	-------------- Range (Arithmetic sequences) -----------
1533	repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1534	repFrom (MkC x) = rep2 fromEName [x]
1535
1536	repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1537	repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1538
1539	repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1540	repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1541
1542	repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1543	repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1544
1545	------------ Match and Clause Tuples -----------
1546	repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1547	repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1548
1549	repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1550	repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1551
1552	-------------- Dec -----------------------------
1553	repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1554	repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1555
1556	repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1557	repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1558
1559	repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1560	-> Maybe (Core [TH.TypeQ])
1561	-> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1562	repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1563	= rep2 dataDName [cxt, nm, tvs, cons, derivs]
1564	repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1565	= rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1566
1567	repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1568	-> Maybe (Core [TH.TypeQ])
1569	-> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1570	repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1571	= rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1572	repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1573	= rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1574
1575	repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1576	-> Maybe (Core [TH.TypeQ])
1577	-> Core TH.TypeQ -> DsM (Core TH.DecQ)
1578	repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1579	= rep2 tySynDName [nm, tvs, rhs]
1580	repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1581	= rep2 tySynInstDName [nm, tys, rhs]
1582
1583	repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1584	repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1585
1586	repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1587	-> Core [TH.FunDep] -> Core [TH.DecQ]
1588	-> DsM (Core TH.DecQ)
1589	repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1590	= rep2 classDName [cxt, cls, tvs, fds, ds]
1591
1592	repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1593	repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1594
1595	repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1596	repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1597
1598	repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1599	-> DsM (Core TH.DecQ)
1600	repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1601	= rep2 pragSpecInlDName [nm, ty, ispec]
1602
1603	repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1604	-> DsM (Core TH.DecQ)
1605	repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1606	= rep2 familyNoKindDName [flav, nm, tvs]
1607
1608	repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1609	-> Core TH.Kind
1610	-> DsM (Core TH.DecQ)
1611	repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1612	= rep2 familyKindDName [flav, nm, tvs, ki]
1613
1614	repInlineSpecNoPhase :: Core TH.Inline -> Core Bool
1615	-> DsM (Core TH.InlineSpecQ)
1616	repInlineSpecNoPhase (MkC inline) (MkC conlike)
1617	= rep2 inlineSpecNoPhaseName [inline, conlike]
1618
1619	repInlineSpecPhase :: Core TH.Inline -> Core Bool -> Core Bool -> Core Int
1620	-> DsM (Core TH.InlineSpecQ)
1621	repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1622	= rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1623
1624	repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1625	repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1626
1627	repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1628	repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1629
1630	repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1631	repCtxt (MkC tys) = rep2 cxtName [tys]
1632
1633	repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1634	repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1635
1636	repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1637	repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1638
1639	repConstr :: Core TH.Name -> HsConDeclDetails Name
1640	-> DsM (Core TH.ConQ)
1641	repConstr con (PrefixCon ps)
1642	= do arg_tys <- mapM repBangTy ps
1643	arg_tys1 <- coreList strictTypeQTyConName arg_tys
1644	rep2 normalCName [unC con, unC arg_tys1]
1645	repConstr con (RecCon ips)
1646	= do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
1647	arg_tys <- mapM repBangTy (map cd_fld_type ips)
1648	arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1649	arg_vs arg_tys
1650	arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1651	rep2 recCName [unC con, unC arg_vtys']
1652	repConstr con (InfixCon st1 st2)
1653	= do arg1 <- repBangTy st1
1654	arg2 <- repBangTy st2
1655	rep2 infixCName [unC arg1, unC con, unC arg2]
1656
1657	------------ Types -------------------
1658
1659	repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1660	-> DsM (Core TH.TypeQ)
1661	repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1662	= rep2 forallTName [tvars, ctxt, ty]
1663
1664	repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1665	repTvar (MkC s) = rep2 varTName [s]
1666
1667	repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1668	repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1669
1670	repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1671	repTapps f [] = return f
1672	repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1673
1674	repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1675	repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1676
1677	repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1678	repTPromotedList [] = repPromotedNilTyCon
1679	repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
1680	; f <- repTapp tcon t
1681	; t' <- repTPromotedList ts
1682	; repTapp f t'
1683	}
1684
1685	repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
1686	repTLit (MkC lit) = rep2 litTName [lit]
1687
1688	--------- Type constructors --------------
1689
1690	repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1691	repNamedTyCon (MkC s) = rep2 conTName [s]
1692
1693	repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1694	-- Note: not Core Int; it's easier to be direct here
1695	repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1696
1697	repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1698	-- Note: not Core Int; it's easier to be direct here
1699	repUnboxedTupleTyCon i = rep2 unboxedTupleTName [mkIntExprInt i]
1700
1701	repArrowTyCon :: DsM (Core TH.TypeQ)
1702	repArrowTyCon = rep2 arrowTName []
1703
1704	repListTyCon :: DsM (Core TH.TypeQ)
1705	repListTyCon = rep2 listTName []
1706
1707	repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1708	repPromotedTyCon (MkC s) = rep2 promotedTName [s]
1709
1710	repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1711	repPromotedTupleTyCon i = rep2 promotedTupleTName [mkIntExprInt i]
1712
1713	repPromotedNilTyCon :: DsM (Core TH.TypeQ)
1714	repPromotedNilTyCon = rep2 promotedNilTName []
1715
1716	repPromotedConsTyCon :: DsM (Core TH.TypeQ)
1717	repPromotedConsTyCon = rep2 promotedConsTName []
1718
1719	------------ Kinds -------------------
1720
1721	repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1722	repPlainTV (MkC nm) = rep2 plainTVName [nm]
1723
1724	repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1725	repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1726
1727	repKVar :: Core TH.Name -> DsM (Core TH.Kind)
1728	repKVar (MkC s) = rep2 varKName [s]
1729
1730	repKCon :: Core TH.Name -> DsM (Core TH.Kind)
1731	repKCon (MkC s) = rep2 conKName [s]
1732
1733	repKTuple :: Int -> DsM (Core TH.Kind)
1734	repKTuple i = rep2 tupleKName [mkIntExprInt i]
1735
1736	repKArrow :: DsM (Core TH.Kind)
1737	repKArrow = rep2 arrowKName []
1738
1739	repKList :: DsM (Core TH.Kind)
1740	repKList = rep2 listKName []
1741
1742	repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1743	repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]
1744
1745	repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)
1746	repKApps f [] = return f
1747	repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }
1748
1749	repKStar :: DsM (Core TH.Kind)
1750	repKStar = rep2 starKName []
1751
1752	repKConstraint :: DsM (Core TH.Kind)
1753	repKConstraint = rep2 constraintKName []
1754
1755	----------------------------------------------------------
1756	-- Literals
1757
1758	repLiteral :: HsLit -> DsM (Core TH.Lit)
1759	repLiteral lit
1760	= do lit' <- case lit of
1761	HsIntPrim i -> mk_integer i
1762	HsWordPrim w -> mk_integer w
1763	HsInt i -> mk_integer i
1764	HsFloatPrim r -> mk_rational r
1765	HsDoublePrim r -> mk_rational r
1766	_ -> return lit
1767	lit_expr <- dsLit lit'
1768	case mb_lit_name of
1769	Just lit_name -> rep2 lit_name [lit_expr]
1770	Nothing -> notHandled "Exotic literal" (ppr lit)
1771	where
1772	mb_lit_name = case lit of
1773	HsInteger _ _ -> Just integerLName
1774	HsInt _ -> Just integerLName
1775	HsIntPrim _ -> Just intPrimLName
1776	HsWordPrim _ -> Just wordPrimLName
1777	HsFloatPrim _ -> Just floatPrimLName
1778	HsDoublePrim _ -> Just doublePrimLName
1779	HsChar _ -> Just charLName
1780	HsString _ -> Just stringLName
1781	HsRat _ _ -> Just rationalLName
1782	_ -> Nothing
1783
1784	mk_integer :: Integer -> DsM HsLit
1785	mk_integer i = do integer_ty <- lookupType integerTyConName
1786	return $ HsInteger i integer_ty
1787	mk_rational :: FractionalLit -> DsM HsLit
1788	mk_rational r = do rat_ty <- lookupType rationalTyConName
1789	return $ HsRat r rat_ty
1790	mk_string :: FastString -> DsM HsLit
1791	mk_string s = return $ HsString s
1792
1793	repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1794	repOverloadedLiteral (OverLit { ol_val = val})
1795	= do { lit <- mk_lit val; repLiteral lit }
1796	-- The type Rational will be in the environment, becuase
1797	-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1798	-- and rationalL is sucked in when any TH stuff is used
1799
1800	mk_lit :: OverLitVal -> DsM HsLit
1801	mk_lit (HsIntegral i) = mk_integer i
1802	mk_lit (HsFractional f) = mk_rational f
1803	mk_lit (HsIsString s) = mk_string s
1804
1805	--------------- Miscellaneous -------------------
1806
1807	repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1808	repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1809
1810	repBindQ :: Type -> Type -- a and b
1811	-> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1812	repBindQ ty_a ty_b (MkC x) (MkC y)
1813	= rep2 bindQName [Type ty_a, Type ty_b, x, y]
1814
1815	repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1816	repSequenceQ ty_a (MkC list)
1817	= rep2 sequenceQName [Type ty_a, list]
1818
1819	------------ Lists and Tuples -------------------
1820	-- turn a list of patterns into a single pattern matching a list
1821
1822	coreList :: Name -- Of the TyCon of the element type
1823	-> [Core a] -> DsM (Core [a])
1824	coreList tc_name es
1825	= do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1826
1827	coreList' :: Type -- The element type
1828	-> [Core a] -> Core [a]
1829	coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1830
1831	nonEmptyCoreList :: [Core a] -> Core [a]
1832	-- The list must be non-empty so we can get the element type
1833	-- Otherwise use coreList
1834	nonEmptyCoreList [] = panic "coreList: empty argument"
1835	nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1836
1837	coreStringLit :: String -> DsM (Core String)
1838	coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1839
1840	------------ Bool, Literals & Variables -------------------
1841
1842	coreBool :: Bool -> Core Bool
1843	coreBool False = MkC $ mkConApp falseDataCon []
1844	coreBool True = MkC $ mkConApp trueDataCon []
1845
1846	coreIntLit :: Int -> DsM (Core Int)
1847	coreIntLit i = return (MkC (mkIntExprInt i))
1848
1849	coreVar :: Id -> Core TH.Name -- The Id has type Name
1850	coreVar id = MkC (Var id)
1851
1852	----------------- Failure -----------------------
1853	notHandled :: String -> SDoc -> DsM a
1854	notHandled what doc = failWithDs msg
1855	where
1856	msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1857	2 doc
1858
1859
1860	-- %************************************************************************
1861	-- %* *
1862	-- The known-key names for Template Haskell
1863	-- %* *
1864	-- %************************************************************************
1865
1866	-- To add a name, do three things
1867	--
1868	-- 1) Allocate a key
1869	-- 2) Make a "Name"
1870	-- 3) Add the name to knownKeyNames
1871
1872	templateHaskellNames :: [Name]
1873	-- The names that are implicitly mentioned by ``bracket''
1874	-- Should stay in sync with the import list of DsMeta
1875
1876	templateHaskellNames = [
1877	returnQName, bindQName, sequenceQName, newNameName, liftName,
1878	mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1879	liftStringName,
1880
1881	-- Lit
1882	charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1883	floatPrimLName, doublePrimLName, rationalLName,
1884	-- Pat
1885	litPName, varPName, tupPName, unboxedTupPName,
1886	conPName, tildePName, bangPName, infixPName,
1887	asPName, wildPName, recPName, listPName, sigPName, viewPName,
1888	-- FieldPat
1889	fieldPatName,
1890	-- Match
1891	matchName,
1892	-- Clause
1893	clauseName,
1894	-- Exp
1895	varEName, conEName, litEName, appEName, infixEName,
1896	infixAppName, sectionLName, sectionRName, lamEName,
1897	tupEName, unboxedTupEName,
1898	condEName, letEName, caseEName, doEName, compEName,
1899	fromEName, fromThenEName, fromToEName, fromThenToEName,
1900	listEName, sigEName, recConEName, recUpdEName,
1901	-- FieldExp
1902	fieldExpName,
1903	-- Body
1904	guardedBName, normalBName,
1905	-- Guard
1906	normalGEName, patGEName,
1907	-- Stmt
1908	bindSName, letSName, noBindSName, parSName,
1909	-- Dec
1910	funDName, valDName, dataDName, newtypeDName, tySynDName,
1911	classDName, instanceDName, sigDName, forImpDName,
1912	pragInlDName, pragSpecDName, pragSpecInlDName,
1913	familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1914	tySynInstDName, infixLDName, infixRDName, infixNDName,
1915	-- Cxt
1916	cxtName,
1917	-- Pred
1918	classPName, equalPName,
1919	-- Strict
1920	isStrictName, notStrictName, unpackedName,
1921	-- Con
1922	normalCName, recCName, infixCName, forallCName,
1923	-- StrictType
1924	strictTypeName,
1925	-- VarStrictType
1926	varStrictTypeName,
1927	-- Type
1928	forallTName, varTName, conTName, appTName,
1929	tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
1930	promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
1931	-- TyLit
1932	numTyLitName, strTyLitName,
1933	-- TyVarBndr
1934	plainTVName, kindedTVName,
1935	-- Kind
1936	varKName, conKName, tupleKName, arrowKName, listKName, appKName,
1937	starKName, constraintKName,
1938	-- Callconv
1939	cCallName, stdCallName,
1940	-- Safety
1941	unsafeName,
1942	safeName,
1943	interruptibleName,
1944	-- Inline
1945	noInlineDataConName, inlineDataConName, inlinableDataConName,
1946	-- InlineSpec
1947	inlineSpecNoPhaseName, inlineSpecPhaseName,
1948	-- FunDep
1949	funDepName,
1950	-- FamFlavour
1951	typeFamName, dataFamName,
1952
1953	-- And the tycons
1954	qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1955	clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1956	stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1957	varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1958	typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1959	patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1960	predQTyConName, decsQTyConName,
1961
1962	-- Quasiquoting
1963	quoteDecName, quoteTypeName, quoteExpName, quotePatName]
1964
1965	thSyn, thLib, qqLib :: Module
1966	thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1967	thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1968	qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1969
1970	mkTHModule :: FastString -> Module
1971	mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1972
1973	libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name
1974	libFun = mk_known_key_name OccName.varName thLib
1975	libTc = mk_known_key_name OccName.tcName thLib
1976	thFun = mk_known_key_name OccName.varName thSyn
1977	thTc = mk_known_key_name OccName.tcName thSyn
1978	thCon = mk_known_key_name OccName.dataName thSyn
1979	qqFun = mk_known_key_name OccName.varName qqLib
1980
1981	-------------------- TH.Syntax -----------------------
1982	qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1983	fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1984	tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1985	predTyConName :: Name
1986	qTyConName = thTc (fsLit "Q") qTyConKey
1987	nameTyConName = thTc (fsLit "Name") nameTyConKey
1988	fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
1989	patTyConName = thTc (fsLit "Pat") patTyConKey
1990	fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
1991	expTyConName = thTc (fsLit "Exp") expTyConKey
1992	decTyConName = thTc (fsLit "Dec") decTyConKey
1993	typeTyConName = thTc (fsLit "Type") typeTyConKey
1994	tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
1995	matchTyConName = thTc (fsLit "Match") matchTyConKey
1996	clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
1997	funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
1998	predTyConName = thTc (fsLit "Pred") predTyConKey
1999
2000	returnQName, bindQName, sequenceQName, newNameName, liftName,
2001	mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
2002	mkNameLName, liftStringName :: Name
2003	returnQName = thFun (fsLit "returnQ") returnQIdKey
2004	bindQName = thFun (fsLit "bindQ") bindQIdKey
2005	sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
2006	newNameName = thFun (fsLit "newName") newNameIdKey
2007	liftName = thFun (fsLit "lift") liftIdKey
2008	liftStringName = thFun (fsLit "liftString") liftStringIdKey
2009	mkNameName = thFun (fsLit "mkName") mkNameIdKey
2010	mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
2011	mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
2012	mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
2013	mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
2014
2015
2016	-------------------- TH.Lib -----------------------
2017	-- data Lit = ...
2018	charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
2019	floatPrimLName, doublePrimLName, rationalLName :: Name
2020	charLName = libFun (fsLit "charL") charLIdKey
2021	stringLName = libFun (fsLit "stringL") stringLIdKey
2022	integerLName = libFun (fsLit "integerL") integerLIdKey
2023	intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
2024	wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
2025	floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
2026	doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
2027	rationalLName = libFun (fsLit "rationalL") rationalLIdKey
2028
2029	-- data Pat = ...
2030	litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,
2031	asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name
2032	litPName = libFun (fsLit "litP") litPIdKey
2033	varPName = libFun (fsLit "varP") varPIdKey
2034	tupPName = libFun (fsLit "tupP") tupPIdKey
2035	unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
2036	conPName = libFun (fsLit "conP") conPIdKey
2037	infixPName = libFun (fsLit "infixP") infixPIdKey
2038	tildePName = libFun (fsLit "tildeP") tildePIdKey
2039	bangPName = libFun (fsLit "bangP") bangPIdKey
2040	asPName = libFun (fsLit "asP") asPIdKey
2041	wildPName = libFun (fsLit "wildP") wildPIdKey
2042	recPName = libFun (fsLit "recP") recPIdKey
2043	listPName = libFun (fsLit "listP") listPIdKey
2044	sigPName = libFun (fsLit "sigP") sigPIdKey
2045	viewPName = libFun (fsLit "viewP") viewPIdKey
2046
2047	-- type FieldPat = ...
2048	fieldPatName :: Name
2049	fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
2050
2051	-- data Match = ...
2052	matchName :: Name
2053	matchName = libFun (fsLit "match") matchIdKey
2054
2055	-- data Clause = ...
2056	clauseName :: Name
2057	clauseName = libFun (fsLit "clause") clauseIdKey
2058
2059	-- data Exp = ...
2060	varEName, conEName, litEName, appEName, infixEName, infixAppName,
2061	sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName,
2062	letEName, caseEName, doEName, compEName :: Name
2063	varEName = libFun (fsLit "varE") varEIdKey
2064	conEName = libFun (fsLit "conE") conEIdKey
2065	litEName = libFun (fsLit "litE") litEIdKey
2066	appEName = libFun (fsLit "appE") appEIdKey
2067	infixEName = libFun (fsLit "infixE") infixEIdKey
2068	infixAppName = libFun (fsLit "infixApp") infixAppIdKey
2069	sectionLName = libFun (fsLit "sectionL") sectionLIdKey
2070	sectionRName = libFun (fsLit "sectionR") sectionRIdKey
2071	lamEName = libFun (fsLit "lamE") lamEIdKey
2072	tupEName = libFun (fsLit "tupE") tupEIdKey
2073	unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
2074	condEName = libFun (fsLit "condE") condEIdKey
2075	letEName = libFun (fsLit "letE") letEIdKey
2076	caseEName = libFun (fsLit "caseE") caseEIdKey
2077	doEName = libFun (fsLit "doE") doEIdKey
2078	compEName = libFun (fsLit "compE") compEIdKey
2079	-- ArithSeq skips a level
2080	fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
2081	fromEName = libFun (fsLit "fromE") fromEIdKey
2082	fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
2083	fromToEName = libFun (fsLit "fromToE") fromToEIdKey
2084	fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
2085	-- end ArithSeq
2086	listEName, sigEName, recConEName, recUpdEName :: Name
2087	listEName = libFun (fsLit "listE") listEIdKey
2088	sigEName = libFun (fsLit "sigE") sigEIdKey
2089	recConEName = libFun (fsLit "recConE") recConEIdKey
2090	recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
2091
2092	-- type FieldExp = ...
2093	fieldExpName :: Name
2094	fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
2095
2096	-- data Body = ...
2097	guardedBName, normalBName :: Name
2098	guardedBName = libFun (fsLit "guardedB") guardedBIdKey
2099	normalBName = libFun (fsLit "normalB") normalBIdKey
2100
2101	-- data Guard = ...
2102	normalGEName, patGEName :: Name
2103	normalGEName = libFun (fsLit "normalGE") normalGEIdKey
2104	patGEName = libFun (fsLit "patGE") patGEIdKey
2105
2106	-- data Stmt = ...
2107	bindSName, letSName, noBindSName, parSName :: Name
2108	bindSName = libFun (fsLit "bindS") bindSIdKey
2109	letSName = libFun (fsLit "letS") letSIdKey
2110	noBindSName = libFun (fsLit "noBindS") noBindSIdKey
2111	parSName = libFun (fsLit "parS") parSIdKey
2112
2113	-- data Dec = ...
2114	funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
2115	instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
2116	pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
2117	newtypeInstDName, tySynInstDName,
2118	infixLDName, infixRDName, infixNDName :: Name
2119	funDName = libFun (fsLit "funD") funDIdKey
2120	valDName = libFun (fsLit "valD") valDIdKey
2121	dataDName = libFun (fsLit "dataD") dataDIdKey
2122	newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
2123	tySynDName = libFun (fsLit "tySynD") tySynDIdKey
2124	classDName = libFun (fsLit "classD") classDIdKey
2125	instanceDName = libFun (fsLit "instanceD") instanceDIdKey
2126	sigDName = libFun (fsLit "sigD") sigDIdKey
2127	forImpDName = libFun (fsLit "forImpD") forImpDIdKey
2128	pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
2129	pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
2130	pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
2131	familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
2132	familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
2133	dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
2134	newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
2135	tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
2136	infixLDName = libFun (fsLit "infixLD") infixLDIdKey
2137	infixRDName = libFun (fsLit "infixRD") infixRDIdKey
2138	infixNDName = libFun (fsLit "infixND") infixNDIdKey
2139
2140	-- type Ctxt = ...
2141	cxtName :: Name
2142	cxtName = libFun (fsLit "cxt") cxtIdKey
2143
2144	-- data Pred = ...
2145	classPName, equalPName :: Name
2146	classPName = libFun (fsLit "classP") classPIdKey
2147	equalPName = libFun (fsLit "equalP") equalPIdKey
2148
2149	-- data Strict = ...
2150	isStrictName, notStrictName, unpackedName :: Name
2151	isStrictName = libFun (fsLit "isStrict") isStrictKey
2152	notStrictName = libFun (fsLit "notStrict") notStrictKey
2153	unpackedName = libFun (fsLit "unpacked") unpackedKey
2154
2155	-- data Con = ...
2156	normalCName, recCName, infixCName, forallCName :: Name
2157	normalCName = libFun (fsLit "normalC") normalCIdKey
2158	recCName = libFun (fsLit "recC") recCIdKey
2159	infixCName = libFun (fsLit "infixC") infixCIdKey
2160	forallCName = libFun (fsLit "forallC") forallCIdKey
2161
2162	-- type StrictType = ...
2163	strictTypeName :: Name
2164	strictTypeName = libFun (fsLit "strictType") strictTKey
2165
2166	-- type VarStrictType = ...
2167	varStrictTypeName :: Name
2168	varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
2169
2170	-- data Type = ...
2171	forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
2172	listTName, appTName, sigTName, litTName,
2173	promotedTName, promotedTupleTName,
2174	promotedNilTName, promotedConsTName :: Name
2175	forallTName = libFun (fsLit "forallT") forallTIdKey
2176	varTName = libFun (fsLit "varT") varTIdKey
2177	conTName = libFun (fsLit "conT") conTIdKey
2178	tupleTName = libFun (fsLit "tupleT") tupleTIdKey
2179	unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey
2180	arrowTName = libFun (fsLit "arrowT") arrowTIdKey
2181	listTName = libFun (fsLit "listT") listTIdKey
2182	appTName = libFun (fsLit "appT") appTIdKey
2183	sigTName = libFun (fsLit "sigT") sigTIdKey
2184	litTName = libFun (fsLit "litT") litTIdKey
2185	promotedTName = libFun (fsLit "promotedT") promotedTIdKey
2186	promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
2187	promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey
2188	promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey
2189
2190	-- data TyLit = ...
2191	numTyLitName, strTyLitName :: Name
2192	numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey
2193	strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
2194
2195	-- data TyVarBndr = ...
2196	plainTVName, kindedTVName :: Name
2197	plainTVName = libFun (fsLit "plainTV") plainTVIdKey
2198	kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
2199
2200	-- data Kind = ...
2201	varKName, conKName, tupleKName, arrowKName, listKName, appKName,
2202	starKName, constraintKName :: Name
2203	varKName = libFun (fsLit "varK") varKIdKey
2204	conKName = libFun (fsLit "conK") conKIdKey
2205	tupleKName = libFun (fsLit "tupleK") tupleKIdKey
2206	arrowKName = libFun (fsLit "arrowK") arrowKIdKey
2207	listKName = libFun (fsLit "listK") listKIdKey
2208	appKName = libFun (fsLit "appK") appKIdKey
2209	starKName = libFun (fsLit "starK") starKIdKey
2210	constraintKName = libFun (fsLit "constraintK") constraintKIdKey
2211
2212	-- data Callconv = ...
2213	cCallName, stdCallName :: Name
2214	cCallName = libFun (fsLit "cCall") cCallIdKey
2215	stdCallName = libFun (fsLit "stdCall") stdCallIdKey
2216
2217	-- data Safety = ...
2218	unsafeName, safeName, interruptibleName :: Name
2219	unsafeName = libFun (fsLit "unsafe") unsafeIdKey
2220	safeName = libFun (fsLit "safe") safeIdKey
2221	interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
2222
2223	-- data Inline = ...
2224	noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
2225	noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey
2226	inlineDataConName = thCon (fsLit "Inline") inlineDataConKey
2227	inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
2228
2229	-- data InlineSpec = ...
2230	inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
2231	inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
2232	inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
2233
2234	-- data FunDep = ...
2235	funDepName :: Name
2236	funDepName = libFun (fsLit "funDep") funDepIdKey
2237
2238	-- data FamFlavour = ...
2239	typeFamName, dataFamName :: Name
2240	typeFamName = libFun (fsLit "typeFam") typeFamIdKey
2241	dataFamName = libFun (fsLit "dataFam") dataFamIdKey
2242
2243	matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
2244	decQTyConName, conQTyConName, strictTypeQTyConName,
2245	varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
2246	patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
2247	matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
2248	clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
2249	expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
2250	stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
2251	decQTyConName = libTc (fsLit "DecQ") decQTyConKey
2252	decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
2253	conQTyConName = libTc (fsLit "ConQ") conQTyConKey
2254	strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
2255	varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
2256	typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
2257	fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
2258	patQTyConName = libTc (fsLit "PatQ") patQTyConKey
2259	fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
2260	predQTyConName = libTc (fsLit "PredQ") predQTyConKey
2261
2262	-- quasiquoting
2263	quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
2264	quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
2265	quotePatName = qqFun (fsLit "quotePat") quotePatKey
2266	quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
2267	quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
2268
2269	-- TyConUniques available: 200-299
2270	-- Check in PrelNames if you want to change this
2271
2272	expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2273	decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2274	stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2275	decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2276	fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2277	fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2278	predQTyConKey, decsQTyConKey :: Unique
2279	expTyConKey = mkPreludeTyConUnique 200
2280	matchTyConKey = mkPreludeTyConUnique 201
2281	clauseTyConKey = mkPreludeTyConUnique 202
2282	qTyConKey = mkPreludeTyConUnique 203
2283	expQTyConKey = mkPreludeTyConUnique 204
2284	decQTyConKey = mkPreludeTyConUnique 205
2285	patTyConKey = mkPreludeTyConUnique 206
2286	matchQTyConKey = mkPreludeTyConUnique 207
2287	clauseQTyConKey = mkPreludeTyConUnique 208
2288	stmtQTyConKey = mkPreludeTyConUnique 209
2289	conQTyConKey = mkPreludeTyConUnique 210
2290	typeQTyConKey = mkPreludeTyConUnique 211
2291	typeTyConKey = mkPreludeTyConUnique 212
2292	decTyConKey = mkPreludeTyConUnique 213
2293	varStrictTypeQTyConKey = mkPreludeTyConUnique 214
2294	strictTypeQTyConKey = mkPreludeTyConUnique 215
2295	fieldExpTyConKey = mkPreludeTyConUnique 216
2296	fieldPatTyConKey = mkPreludeTyConUnique 217
2297	nameTyConKey = mkPreludeTyConUnique 218
2298	patQTyConKey = mkPreludeTyConUnique 219
2299	fieldPatQTyConKey = mkPreludeTyConUnique 220
2300	fieldExpQTyConKey = mkPreludeTyConUnique 221
2301	funDepTyConKey = mkPreludeTyConUnique 222
2302	predTyConKey = mkPreludeTyConUnique 223
2303	predQTyConKey = mkPreludeTyConUnique 224
2304	tyVarBndrTyConKey = mkPreludeTyConUnique 225
2305	decsQTyConKey = mkPreludeTyConUnique 226
2306
2307	-- IdUniques available: 200-499
2308	-- If you want to change this, make sure you check in PrelNames
2309
2310	returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2311	mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2312	mkNameLIdKey :: Unique
2313	returnQIdKey = mkPreludeMiscIdUnique 200
2314	bindQIdKey = mkPreludeMiscIdUnique 201
2315	sequenceQIdKey = mkPreludeMiscIdUnique 202
2316	liftIdKey = mkPreludeMiscIdUnique 203
2317	newNameIdKey = mkPreludeMiscIdUnique 204
2318	mkNameIdKey = mkPreludeMiscIdUnique 205
2319	mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2320	mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2321	mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2322	mkNameLIdKey = mkPreludeMiscIdUnique 209
2323
2324
2325	-- data Lit = ...
2326	charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2327	floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2328	charLIdKey = mkPreludeMiscIdUnique 220
2329	stringLIdKey = mkPreludeMiscIdUnique 221
2330	integerLIdKey = mkPreludeMiscIdUnique 222
2331	intPrimLIdKey = mkPreludeMiscIdUnique 223
2332	wordPrimLIdKey = mkPreludeMiscIdUnique 224
2333	floatPrimLIdKey = mkPreludeMiscIdUnique 225
2334	doublePrimLIdKey = mkPreludeMiscIdUnique 226
2335	rationalLIdKey = mkPreludeMiscIdUnique 227
2336
2337	liftStringIdKey :: Unique
2338	liftStringIdKey = mkPreludeMiscIdUnique 228
2339
2340	-- data Pat = ...
2341	litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2342	asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
2343	litPIdKey = mkPreludeMiscIdUnique 240
2344	varPIdKey = mkPreludeMiscIdUnique 241
2345	tupPIdKey = mkPreludeMiscIdUnique 242
2346	unboxedTupPIdKey = mkPreludeMiscIdUnique 243
2347	conPIdKey = mkPreludeMiscIdUnique 244
2348	infixPIdKey = mkPreludeMiscIdUnique 245
2349	tildePIdKey = mkPreludeMiscIdUnique 246
2350	bangPIdKey = mkPreludeMiscIdUnique 247
2351	asPIdKey = mkPreludeMiscIdUnique 248
2352	wildPIdKey = mkPreludeMiscIdUnique 249
2353	recPIdKey = mkPreludeMiscIdUnique 250
2354	listPIdKey = mkPreludeMiscIdUnique 251
2355	sigPIdKey = mkPreludeMiscIdUnique 252
2356	viewPIdKey = mkPreludeMiscIdUnique 253
2357
2358	-- type FieldPat = ...
2359	fieldPatIdKey :: Unique
2360	fieldPatIdKey = mkPreludeMiscIdUnique 260
2361
2362	-- data Match = ...
2363	matchIdKey :: Unique
2364	matchIdKey = mkPreludeMiscIdUnique 261
2365
2366	-- data Clause = ...
2367	clauseIdKey :: Unique
2368	clauseIdKey = mkPreludeMiscIdUnique 262
2369
2370
2371	-- data Exp = ...
2372	varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2373	sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey,
2374	condEIdKey,
2375	letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2376	fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2377	listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2378	varEIdKey = mkPreludeMiscIdUnique 270
2379	conEIdKey = mkPreludeMiscIdUnique 271
2380	litEIdKey = mkPreludeMiscIdUnique 272
2381	appEIdKey = mkPreludeMiscIdUnique 273
2382	infixEIdKey = mkPreludeMiscIdUnique 274
2383	infixAppIdKey = mkPreludeMiscIdUnique 275
2384	sectionLIdKey = mkPreludeMiscIdUnique 276
2385	sectionRIdKey = mkPreludeMiscIdUnique 277
2386	lamEIdKey = mkPreludeMiscIdUnique 278
2387	tupEIdKey = mkPreludeMiscIdUnique 279
2388	unboxedTupEIdKey = mkPreludeMiscIdUnique 280
2389	condEIdKey = mkPreludeMiscIdUnique 281
2390	letEIdKey = mkPreludeMiscIdUnique 282
2391	caseEIdKey = mkPreludeMiscIdUnique 283
2392	doEIdKey = mkPreludeMiscIdUnique 284
2393	compEIdKey = mkPreludeMiscIdUnique 285
2394	fromEIdKey = mkPreludeMiscIdUnique 286
2395	fromThenEIdKey = mkPreludeMiscIdUnique 287
2396	fromToEIdKey = mkPreludeMiscIdUnique 288
2397	fromThenToEIdKey = mkPreludeMiscIdUnique 289
2398	listEIdKey = mkPreludeMiscIdUnique 290
2399	sigEIdKey = mkPreludeMiscIdUnique 291
2400	recConEIdKey = mkPreludeMiscIdUnique 292
2401	recUpdEIdKey = mkPreludeMiscIdUnique 293
2402
2403	-- type FieldExp = ...
2404	fieldExpIdKey :: Unique
2405	fieldExpIdKey = mkPreludeMiscIdUnique 310
2406
2407	-- data Body = ...
2408	guardedBIdKey, normalBIdKey :: Unique
2409	guardedBIdKey = mkPreludeMiscIdUnique 311
2410	normalBIdKey = mkPreludeMiscIdUnique 312
2411
2412	-- data Guard = ...
2413	normalGEIdKey, patGEIdKey :: Unique
2414	normalGEIdKey = mkPreludeMiscIdUnique 313
2415	patGEIdKey = mkPreludeMiscIdUnique 314
2416
2417	-- data Stmt = ...
2418	bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2419	bindSIdKey = mkPreludeMiscIdUnique 320
2420	letSIdKey = mkPreludeMiscIdUnique 321
2421	noBindSIdKey = mkPreludeMiscIdUnique 322
2422	parSIdKey = mkPreludeMiscIdUnique 323
2423
2424	-- data Dec = ...
2425	funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2426	classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2427	pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2428	dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
2429	infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
2430	funDIdKey = mkPreludeMiscIdUnique 330
2431	valDIdKey = mkPreludeMiscIdUnique 331
2432	dataDIdKey = mkPreludeMiscIdUnique 332
2433	newtypeDIdKey = mkPreludeMiscIdUnique 333
2434	tySynDIdKey = mkPreludeMiscIdUnique 334
2435	classDIdKey = mkPreludeMiscIdUnique 335
2436	instanceDIdKey = mkPreludeMiscIdUnique 336
2437	sigDIdKey = mkPreludeMiscIdUnique 337
2438	forImpDIdKey = mkPreludeMiscIdUnique 338
2439	pragInlDIdKey = mkPreludeMiscIdUnique 339
2440	pragSpecDIdKey = mkPreludeMiscIdUnique 340
2441	pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
2442	familyNoKindDIdKey = mkPreludeMiscIdUnique 342
2443	familyKindDIdKey = mkPreludeMiscIdUnique 343
2444	dataInstDIdKey = mkPreludeMiscIdUnique 344
2445	newtypeInstDIdKey = mkPreludeMiscIdUnique 345
2446	tySynInstDIdKey = mkPreludeMiscIdUnique 346
2447	infixLDIdKey = mkPreludeMiscIdUnique 347
2448	infixRDIdKey = mkPreludeMiscIdUnique 348
2449	infixNDIdKey = mkPreludeMiscIdUnique 349
2450
2451	-- type Cxt = ...
2452	cxtIdKey :: Unique
2453	cxtIdKey = mkPreludeMiscIdUnique 360
2454
2455	-- data Pred = ...
2456	classPIdKey, equalPIdKey :: Unique
2457	classPIdKey = mkPreludeMiscIdUnique 361
2458	equalPIdKey = mkPreludeMiscIdUnique 362
2459
2460	-- data Strict = ...
2461	isStrictKey, notStrictKey, unpackedKey :: Unique
2462	isStrictKey = mkPreludeMiscIdUnique 363
2463	notStrictKey = mkPreludeMiscIdUnique 364
2464	unpackedKey = mkPreludeMiscIdUnique 365
2465
2466	-- data Con = ...
2467	normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2468	normalCIdKey = mkPreludeMiscIdUnique 370
2469	recCIdKey = mkPreludeMiscIdUnique 371
2470	infixCIdKey = mkPreludeMiscIdUnique 372
2471	forallCIdKey = mkPreludeMiscIdUnique 373
2472
2473	-- type StrictType = ...
2474	strictTKey :: Unique
2475	strictTKey = mkPreludeMiscIdUnique 374
2476
2477	-- type VarStrictType = ...
2478	varStrictTKey :: Unique
2479	varStrictTKey = mkPreludeMiscIdUnique 375
2480
2481	-- data Type = ...
2482	forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
2483	listTIdKey, appTIdKey, sigTIdKey, litTIdKey,
2484	promotedTIdKey, promotedTupleTIdKey,
2485	promotedNilTIdKey, promotedConsTIdKey :: Unique
2486	forallTIdKey = mkPreludeMiscIdUnique 380
2487	varTIdKey = mkPreludeMiscIdUnique 381
2488	conTIdKey = mkPreludeMiscIdUnique 382
2489	tupleTIdKey = mkPreludeMiscIdUnique 383
2490	unboxedTupleTIdKey = mkPreludeMiscIdUnique 384
2491	arrowTIdKey = mkPreludeMiscIdUnique 385
2492	listTIdKey = mkPreludeMiscIdUnique 386
2493	appTIdKey = mkPreludeMiscIdUnique 387
2494	sigTIdKey = mkPreludeMiscIdUnique 388
2495	litTIdKey = mkPreludeMiscIdUnique 389
2496	promotedTIdKey = mkPreludeMiscIdUnique 390
2497	promotedTupleTIdKey = mkPreludeMiscIdUnique 391
2498	promotedNilTIdKey = mkPreludeMiscIdUnique 392
2499	promotedConsTIdKey = mkPreludeMiscIdUnique 393
2500
2501	-- data TyLit = ...
2502	numTyLitIdKey, strTyLitIdKey :: Unique
2503	numTyLitIdKey = mkPreludeMiscIdUnique 394
2504	strTyLitIdKey = mkPreludeMiscIdUnique 395
2505
2506	-- data TyVarBndr = ...
2507	plainTVIdKey, kindedTVIdKey :: Unique
2508	plainTVIdKey = mkPreludeMiscIdUnique 396
2509	kindedTVIdKey = mkPreludeMiscIdUnique 397
2510
2511	-- data Kind = ...
2512	varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
2513	starKIdKey, constraintKIdKey :: Unique
2514	varKIdKey = mkPreludeMiscIdUnique 398
2515	conKIdKey = mkPreludeMiscIdUnique 399
2516	tupleKIdKey = mkPreludeMiscIdUnique 400
2517	arrowKIdKey = mkPreludeMiscIdUnique 401
2518	listKIdKey = mkPreludeMiscIdUnique 402
2519	appKIdKey = mkPreludeMiscIdUnique 403
2520	starKIdKey = mkPreludeMiscIdUnique 404
2521	constraintKIdKey = mkPreludeMiscIdUnique 405
2522
2523	-- data Callconv = ...
2524	cCallIdKey, stdCallIdKey :: Unique
2525	cCallIdKey = mkPreludeMiscIdUnique 406
2526	stdCallIdKey = mkPreludeMiscIdUnique 407
2527
2528	-- data Safety = ...
2529	unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
2530	unsafeIdKey = mkPreludeMiscIdUnique 408
2531	safeIdKey = mkPreludeMiscIdUnique 409
2532	interruptibleIdKey = mkPreludeMiscIdUnique 411
2533
2534	-- data Inline = ...
2535	noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
2536	noInlineDataConKey = mkPreludeDataConUnique 40
2537	inlineDataConKey = mkPreludeDataConUnique 41
2538	inlinableDataConKey = mkPreludeDataConUnique 42
2539
2540	-- data InlineSpec =
2541	inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2542	inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 412
2543	inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 413
2544
2545	-- data FunDep = ...
2546	funDepIdKey :: Unique
2547	funDepIdKey = mkPreludeMiscIdUnique 414
2548
2549	-- data FamFlavour = ...
2550	typeFamIdKey, dataFamIdKey :: Unique
2551	typeFamIdKey = mkPreludeMiscIdUnique 415
2552	dataFamIdKey = mkPreludeMiscIdUnique 416
2553
2554	-- quasiquoting
2555	quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2556	quoteExpKey = mkPreludeMiscIdUnique 418
2557	quotePatKey = mkPreludeMiscIdUnique 419
2558	quoteDecKey = mkPreludeMiscIdUnique 420
2559	quoteTypeKey = mkPreludeMiscIdUnique 421

Note: See TracBrowser for help on using the browser.

Context Navigation

root/compiler/deSugar/DsMeta.hs

Download in other formats: