2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcGenDeriv: Generating derived instance declarations
8 This module is nominally ``subordinate'' to @TcDeriv@, which is the
9 ``official'' interface to deriving-related things.
11 This is where we do all the grimy bindings' generation.
24 gen_tag_n_con_monobind,
26 con2tag_RDR, tag2con_RDR, maxtag_RDR,
31 #include "HsVersions.h"
55 import Data.List ( partition, intersperse )
58 %************************************************************************
60 \subsection{Generating code, by derivable class}
62 %************************************************************************
64 %************************************************************************
66 \subsubsection{Generating @Eq@ instance declarations}
68 %************************************************************************
70 Here are the heuristics for the code we generate for @Eq@:
73 Let's assume we have a data type with some (possibly zero) nullary
74 data constructors and some ordinary, non-nullary ones (the rest,
75 also possibly zero of them). Here's an example, with both \tr{N}ullary
76 and \tr{O}rdinary data cons.
78 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
82 For the ordinary constructors (if any), we emit clauses to do The
86 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
87 (==) (O2 a1) (O2 a2) = a1 == a2
88 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
91 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
92 \tr{a2} are \tr{Float#}s, then we have to generate
94 case (a1 `eqFloat#` a2) of
97 for that particular test.
100 If there are any nullary constructors, we emit a catch-all clause of
104 (==) a b = case (con2tag_Foo a) of { a# ->
105 case (con2tag_Foo b) of { b# ->
106 case (a# ==# b#) of {
111 If there aren't any nullary constructors, we emit a simpler
118 For the @(/=)@ method, we normally just use the default method.
120 If the type is an enumeration type, we could/may/should? generate
121 special code that calls @con2tag_Foo@, much like for @(==)@ shown
125 We thought about doing this: If we're also deriving @Ord@ for this
128 instance ... Eq (Foo ...) where
129 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
130 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
132 However, that requires that \tr{Ord <whatever>} was put in the context
133 for the instance decl, which it probably wasn't, so the decls
134 produced don't get through the typechecker.
139 gen_Eq_binds :: TyCon -> LHsBinds RdrName
143 tycon_loc = getSrcSpan tycon
145 (nullary_cons, nonnullary_cons)
146 | isNewTyCon tycon = ([], tyConDataCons tycon)
147 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
150 = if (null nullary_cons) then
151 case maybeTyConSingleCon tycon of
153 Nothing -> -- if cons don't match, then False
154 [([nlWildPat, nlWildPat], false_Expr)]
155 else -- calc. and compare the tags
157 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
158 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
161 mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
162 mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
163 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
166 ------------------------------------------------------------------
169 con1_pat = nlConVarPat data_con_RDR as_needed
170 con2_pat = nlConVarPat data_con_RDR bs_needed
172 data_con_RDR = getRdrName data_con
173 con_arity = length tys_needed
174 as_needed = take con_arity as_RDRs
175 bs_needed = take con_arity bs_RDRs
176 tys_needed = dataConOrigArgTys data_con
178 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
180 nested_eq_expr [] [] [] = true_Expr
181 nested_eq_expr tys as bs
182 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
184 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
187 %************************************************************************
189 \subsubsection{Generating @Ord@ instance declarations}
191 %************************************************************************
193 For a derived @Ord@, we concentrate our attentions on @compare@
195 compare :: a -> a -> Ordering
196 data Ordering = LT | EQ | GT deriving ()
199 We will use the same example data type as above:
201 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
206 We do all the other @Ord@ methods with calls to @compare@:
208 instance ... (Ord <wurble> <wurble>) where
209 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
210 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
211 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
212 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
214 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
215 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
217 -- compare to come...
221 @compare@ always has two parts. First, we use the compared
222 data-constructors' tags to deal with the case of different
225 compare a b = case (con2tag_Foo a) of { a# ->
226 case (con2tag_Foo b) of { b# ->
227 case (a# ==# b#) of {
229 False -> case (a# <# b#) of
234 cmp_eq = ... to come ...
238 We are only left with the ``help'' function @cmp_eq@, to deal with
239 comparing data constructors with the same tag.
241 For the ordinary constructors (if any), we emit the sorta-obvious
242 compare-style stuff; for our example:
244 cmp_eq (O1 a1 b1) (O1 a2 b2)
245 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
247 cmp_eq (O2 a1) (O2 a2)
250 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
251 = case (compare a1 a2) of {
254 EQ -> case compare b1 b2 of {
262 Again, we must be careful about unlifted comparisons. For example,
263 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
267 cmp_eq lt eq gt (O2 a1) (O2 a2)
269 -- or maybe the unfolded equivalent
273 For the remaining nullary constructors, we already know that the
280 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
284 gen_Ord_binds :: TyCon -> LHsBinds RdrName
287 = unitBag compare -- `AndMonoBinds` compare
288 -- The default declaration in PrelBase handles this
290 tycon_loc = getSrcSpan tycon
291 --------------------------------------------------------------------
293 compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
294 compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
295 cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
298 | single_con_type = cmp_eq_Expr a_Expr b_Expr
300 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
301 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
302 (cmp_eq_Expr a_Expr b_Expr) -- True case
303 -- False case; they aren't equal
304 -- So we need to do a less-than comparison on the tags
305 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
307 tycon_data_cons = tyConDataCons tycon
308 single_con_type = isSingleton tycon_data_cons
309 (nullary_cons, nonnullary_cons)
310 | isNewTyCon tycon = ([], tyConDataCons tycon)
311 | otherwise = partition isNullarySrcDataCon tycon_data_cons
313 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
315 | isEnumerationTyCon tycon
316 -- We know the tags are equal, so if it's an enumeration TyCon,
317 -- then there is nothing left to do
318 -- Catch this specially to avoid warnings
319 -- about overlapping patterns from the desugarer,
320 -- and to avoid unnecessary pattern-matching
321 = [([nlWildPat,nlWildPat], eqTag_Expr)]
323 = map pats_etc nonnullary_cons ++
324 (if single_con_type then -- Omit wildcards when there's just one
325 [] -- constructor, to silence desugarer
327 [([nlWildPat, nlWildPat], default_rhs)])
331 = ([con1_pat, con2_pat],
332 nested_compare_expr tys_needed as_needed bs_needed)
334 con1_pat = nlConVarPat data_con_RDR as_needed
335 con2_pat = nlConVarPat data_con_RDR bs_needed
337 data_con_RDR = getRdrName data_con
338 con_arity = length tys_needed
339 as_needed = take con_arity as_RDRs
340 bs_needed = take con_arity bs_RDRs
341 tys_needed = dataConOrigArgTys data_con
343 nested_compare_expr [ty] [a] [b]
344 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
346 nested_compare_expr (ty:tys) (a:as) (b:bs)
347 = let eq_expr = nested_compare_expr tys as bs
348 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
350 nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
352 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
353 -- inexhaustive patterns
354 | otherwise = eqTag_Expr -- Some nullary constructors;
355 -- Tags are equal, no args => return EQ
358 %************************************************************************
360 \subsubsection{Generating @Enum@ instance declarations}
362 %************************************************************************
364 @Enum@ can only be derived for enumeration types. For a type
366 data Foo ... = N1 | N2 | ... | Nn
369 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
370 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
373 instance ... Enum (Foo ...) where
374 succ x = toEnum (1 + fromEnum x)
375 pred x = toEnum (fromEnum x - 1)
377 toEnum i = tag2con_Foo i
379 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
383 = case con2tag_Foo a of
384 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
387 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
391 = case con2tag_Foo a of { a# ->
392 case con2tag_Foo b of { b# ->
393 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
397 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
400 gen_Enum_binds :: TyCon -> LHsBinds RdrName
412 tycon_loc = getSrcSpan tycon
413 occ_nm = getOccString tycon
416 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
417 untag_Expr tycon [(a_RDR, ah_RDR)] $
418 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
419 nlHsVarApps intDataCon_RDR [ah_RDR]])
420 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
421 (nlHsApp (nlHsVar (tag2con_RDR tycon))
422 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
426 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
427 untag_Expr tycon [(a_RDR, ah_RDR)] $
428 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
429 nlHsVarApps intDataCon_RDR [ah_RDR]])
430 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
431 (nlHsApp (nlHsVar (tag2con_RDR tycon))
432 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
433 nlHsLit (HsInt (-1))]))
436 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
437 nlHsIf (nlHsApps and_RDR
438 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
439 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
440 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
441 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
444 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
445 untag_Expr tycon [(a_RDR, ah_RDR)] $
447 [nlHsVar (tag2con_RDR tycon),
448 nlHsPar (enum_from_to_Expr
449 (nlHsVarApps intDataCon_RDR [ah_RDR])
450 (nlHsVar (maxtag_RDR tycon)))]
453 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
454 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
455 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
456 nlHsPar (enum_from_then_to_Expr
457 (nlHsVarApps intDataCon_RDR [ah_RDR])
458 (nlHsVarApps intDataCon_RDR [bh_RDR])
459 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
460 nlHsVarApps intDataCon_RDR [bh_RDR]])
462 (nlHsVar (maxtag_RDR tycon))
466 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
467 untag_Expr tycon [(a_RDR, ah_RDR)] $
468 (nlHsVarApps intDataCon_RDR [ah_RDR])
471 %************************************************************************
473 \subsubsection{Generating @Bounded@ instance declarations}
475 %************************************************************************
478 gen_Bounded_binds tycon
479 = if isEnumerationTyCon tycon then
480 listToBag [ min_bound_enum, max_bound_enum ]
482 ASSERT(isSingleton data_cons)
483 listToBag [ min_bound_1con, max_bound_1con ]
485 data_cons = tyConDataCons tycon
486 tycon_loc = getSrcSpan tycon
488 ----- enum-flavored: ---------------------------
489 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
490 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
492 data_con_1 = head data_cons
493 data_con_N = last data_cons
494 data_con_1_RDR = getRdrName data_con_1
495 data_con_N_RDR = getRdrName data_con_N
497 ----- single-constructor-flavored: -------------
498 arity = dataConSourceArity data_con_1
500 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
501 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
502 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
503 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
506 %************************************************************************
508 \subsubsection{Generating @Ix@ instance declarations}
510 %************************************************************************
512 Deriving @Ix@ is only possible for enumeration types and
513 single-constructor types. We deal with them in turn.
515 For an enumeration type, e.g.,
517 data Foo ... = N1 | N2 | ... | Nn
519 things go not too differently from @Enum@:
521 instance ... Ix (Foo ...) where
523 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
527 = case (con2tag_Foo a) of { a# ->
528 case (con2tag_Foo b) of { b# ->
529 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
532 -- Generate code for unsafeIndex, becuase using index leads
533 -- to lots of redundant range tests
534 unsafeIndex c@(a, b) d
535 = case (con2tag_Foo d -# con2tag_Foo a) of
540 p_tag = con2tag_Foo c
542 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
546 = case (con2tag_Foo a) of { a_tag ->
547 case (con2tag_Foo b) of { b_tag ->
548 case (con2tag_Foo c) of { c_tag ->
549 if (c_tag >=# a_tag) then
555 (modulo suitable case-ification to handle the unlifted tags)
557 For a single-constructor type (NB: this includes all tuples), e.g.,
559 data Foo ... = MkFoo a b Int Double c c
561 we follow the scheme given in Figure~19 of the Haskell~1.2 report
565 gen_Ix_binds :: TyCon -> LHsBinds RdrName
568 = if isEnumerationTyCon tycon
572 tycon_loc = getSrcSpan tycon
574 --------------------------------------------------------------
575 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
578 = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
579 untag_Expr tycon [(a_RDR, ah_RDR)] $
580 untag_Expr tycon [(b_RDR, bh_RDR)] $
581 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
582 nlHsPar (enum_from_to_Expr
583 (nlHsVarApps intDataCon_RDR [ah_RDR])
584 (nlHsVarApps intDataCon_RDR [bh_RDR]))
587 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
588 [noLoc (AsPat (noLoc c_RDR)
589 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
591 untag_Expr tycon [(a_RDR, ah_RDR)] (
592 untag_Expr tycon [(d_RDR, dh_RDR)] (
594 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
597 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
598 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
603 = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
604 untag_Expr tycon [(a_RDR, ah_RDR)] (
605 untag_Expr tycon [(b_RDR, bh_RDR)] (
606 untag_Expr tycon [(c_RDR, ch_RDR)] (
607 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
608 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
613 --------------------------------------------------------------
615 = listToBag [single_con_range, single_con_index, single_con_inRange]
618 = case maybeTyConSingleCon tycon of -- just checking...
619 Nothing -> panic "get_Ix_binds"
620 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
621 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
624 con_arity = dataConSourceArity data_con
625 data_con_RDR = getRdrName data_con
627 as_needed = take con_arity as_RDRs
628 bs_needed = take con_arity bs_RDRs
629 cs_needed = take con_arity cs_RDRs
631 con_pat xs = nlConVarPat data_con_RDR xs
632 con_expr = nlHsVarApps data_con_RDR cs_needed
634 --------------------------------------------------------------
636 = mk_easy_FunBind tycon_loc range_RDR
637 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
638 nlHsDo ListComp stmts con_expr
640 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
642 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
643 (nlHsApp (nlHsVar range_RDR)
644 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
648 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
649 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
651 (mk_index (zip3 as_needed bs_needed cs_needed))
653 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
654 mk_index [] = nlHsIntLit 0
655 mk_index [(l,u,i)] = mk_one l u i
656 mk_index ((l,u,i) : rest)
661 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
662 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
663 ) times_RDR (mk_index rest)
666 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
670 = mk_easy_FunBind tycon_loc inRange_RDR
671 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
673 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
675 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
679 %************************************************************************
681 \subsubsection{Generating @Read@ instance declarations}
683 %************************************************************************
693 instance Read T where
697 do x <- ReadP.step Read.readPrec
698 Symbol "%%" <- Lex.lex
699 y <- ReadP.step Read.readPrec
703 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
704 -- Record construction binds even more tightly than application
705 do Ident "T1" <- Lex.lex
707 Ident "f1" <- Lex.lex
709 x <- ReadP.reset Read.readPrec
711 return (T1 { f1 = x }))
714 do Ident "T2" <- Lex.lexP
715 x <- ReadP.step Read.readPrec
719 readListPrec = readListPrecDefault
720 readList = readListDefault
724 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
726 gen_Read_binds get_fixity tycon
727 = listToBag [read_prec, default_readlist, default_readlistprec]
729 -----------------------------------------------------------------------
731 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
734 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
735 -----------------------------------------------------------------------
737 loc = getSrcSpan tycon
738 data_cons = tyConDataCons tycon
739 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
741 read_prec = mkVarBind loc readPrec_RDR
742 (nlHsApp (nlHsVar parens_RDR) read_cons)
744 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
745 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
748 = case nullary_cons of
750 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
751 (result_expr con [])]
752 _ -> [nlHsApp (nlHsVar choose_RDR)
753 (nlList (map mk_pair nullary_cons))]
755 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
759 read_non_nullary_con data_con
760 | is_infix = mk_parser infix_prec infix_stmts body
761 | is_record = mk_parser record_prec record_stmts body
762 -- Using these two lines instead allows the derived
763 -- read for infix and record bindings to read the prefix form
764 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
765 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
766 | otherwise = prefix_parser
768 body = result_expr data_con as_needed
769 con_str = data_con_str data_con
771 prefix_parser = mk_parser prefix_prec prefix_stmts body
772 prefix_stmts -- T a b c
773 = (if not (isSym con_str) then
774 [bindLex (ident_pat con_str)]
775 else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
778 infix_stmts -- a %% b, or a `T` b
781 then [bindLex (symbol_pat con_str)]
782 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
785 record_stmts -- T { f1 = a, f2 = b }
786 = [bindLex (ident_pat (wrapOpParens con_str)),
788 ++ concat (intersperse [read_punc ","] field_stmts)
791 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
793 con_arity = dataConSourceArity data_con
794 labels = dataConFieldLabels data_con
795 dc_nm = getName data_con
796 is_infix = dataConIsInfix data_con
797 is_record = length labels > 0
798 as_needed = take con_arity as_RDRs
799 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
800 (read_a1:read_a2:_) = read_args
802 prefix_prec = appPrecedence
803 infix_prec = getPrecedence get_fixity dc_nm
804 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
805 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
807 ------------------------------------------------------------------------
809 ------------------------------------------------------------------------
810 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
811 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
812 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
813 con_app con as = nlHsVarApps (getRdrName con) as -- con as
814 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
816 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
817 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
818 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
820 data_con_str con = occNameString (getOccName con)
822 read_punc c = bindLex (punc_pat c)
824 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
825 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
827 read_field lbl a = read_lbl lbl ++
829 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
831 -- When reading field labels we might encounter
836 read_lbl lbl | isSym lbl_str
838 bindLex (symbol_pat lbl_str),
841 = [bindLex (ident_pat lbl_str)]
843 lbl_str = occNameString (getOccName lbl)
847 %************************************************************************
849 \subsubsection{Generating @Show@ instance declarations}
851 %************************************************************************
857 data Tree a = Leaf a | Tree a :^: Tree a
859 instance (Show a) => Show (Tree a) where
861 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
863 showStr = showString "Leaf " . showsPrec (app_prec+1) m
865 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
867 showStr = showsPrec (up_prec+1) u .
869 showsPrec (up_prec+1) v
870 -- Note: right-associativity of :^: ignored
872 up_prec = 5 -- Precedence of :^:
873 app_prec = 10 -- Application has precedence one more than
874 -- the most tightly-binding operator
877 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
879 gen_Show_binds get_fixity tycon
880 = listToBag [shows_prec, show_list]
882 tycon_loc = getSrcSpan tycon
883 -----------------------------------------------------------------------
884 show_list = mkVarBind tycon_loc showList_RDR
885 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
886 -----------------------------------------------------------------------
887 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
890 | nullary_con = -- skip the showParen junk...
891 ASSERT(null bs_needed)
892 ([nlWildPat, con_pat], mk_showString_app con_str)
895 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
896 (nlHsPar (nested_compose_Expr show_thingies)))
898 data_con_RDR = getRdrName data_con
899 con_arity = dataConSourceArity data_con
900 bs_needed = take con_arity bs_RDRs
901 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
902 con_pat = nlConVarPat data_con_RDR bs_needed
903 nullary_con = con_arity == 0
904 labels = dataConFieldLabels data_con
905 lab_fields = length labels
906 record_syntax = lab_fields > 0
908 dc_nm = getName data_con
909 dc_occ_nm = getOccName data_con
910 con_str = occNameString dc_occ_nm
911 op_con_str = wrapOpParens con_str
912 backquote_str = wrapOpBackquotes con_str
915 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
916 | record_syntax = mk_showString_app (op_con_str ++ " {") :
917 show_record_args ++ [mk_showString_app "}"]
918 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
920 show_label l = mk_showString_app (nm ++ " = ")
921 -- Note the spaces around the "=" sign. If we don't have them
922 -- then we get Foo { x=-1 } and the "=-" parses as a single
923 -- lexeme. Only the space after the '=' is necessary, but
924 -- it seems tidier to have them both sides.
926 occ_nm = getOccName l
927 nm = wrapOpParens (occNameString occ_nm)
929 show_args = zipWith show_arg bs_needed arg_tys
930 (show_arg1:show_arg2:_) = show_args
931 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
933 -- Assumption for record syntax: no of fields == no of labelled fields
934 -- (and in same order)
935 show_record_args = concat $
936 intersperse [mk_showString_app ", "] $
937 [ [show_label lbl, arg]
938 | (lbl,arg) <- zipEqual "gen_Show_binds"
941 -- Generates (showsPrec p x) for argument x, but it also boxes
942 -- the argument first if necessary. Note that this prints unboxed
943 -- things without any '#' decorations; could change that if need be
944 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
945 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
948 is_infix = dataConIsInfix data_con
949 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
950 arg_prec | record_syntax = 0 -- Record fields don't need parens
951 | otherwise = con_prec_plus_one
953 wrapOpParens :: String -> String
954 wrapOpParens s | isSym s = '(' : s ++ ")"
957 wrapOpBackquotes :: String -> String
958 wrapOpBackquotes s | isSym s = s
959 | otherwise = '`' : s ++ "`"
961 isSym :: String -> Bool
963 isSym (c:cs) = startsVarSym c || startsConSym c
965 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
969 getPrec :: Bool -> FixityEnv -> Name -> Integer
970 getPrec is_infix get_fixity nm
971 | not is_infix = appPrecedence
972 | otherwise = getPrecedence get_fixity nm
974 appPrecedence :: Integer
975 appPrecedence = fromIntegral maxPrecedence + 1
976 -- One more than the precedence of the most
977 -- tightly-binding operator
979 getPrecedence :: FixityEnv -> Name -> Integer
980 getPrecedence get_fixity nm
981 = case lookupFixity get_fixity nm of
982 Fixity x _ -> fromIntegral x
986 %************************************************************************
988 \subsection{Typeable}
990 %************************************************************************
998 instance Typeable2 T where
999 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1001 We are passed the Typeable2 class as well as T
1004 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1005 gen_Typeable_binds tycon
1007 mk_easy_FunBind tycon_loc
1008 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1010 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1012 tycon_loc = getSrcSpan tycon
1013 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1015 mk_typeOf_RDR :: TyCon -> RdrName
1016 -- Use the arity of the TyCon to make the right typeOfn function
1017 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1019 arity = tyConArity tycon
1020 suffix | arity == 0 = ""
1021 | otherwise = show arity
1026 %************************************************************************
1030 %************************************************************************
1034 data T a b = T1 a b | T2
1038 $cT1 = mkDataCon $dT "T1" Prefix
1039 $cT2 = mkDataCon $dT "T2" Prefix
1040 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1041 -- the [] is for field labels.
1043 instance (Data a, Data b) => Data (T a b) where
1044 gfoldl k z (T1 a b) = z T `k` a `k` b
1045 gfoldl k z T2 = z T2
1046 -- ToDo: add gmapT,Q,M, gfoldr
1048 gunfold k z c = case conIndex c of
1049 I# 1# -> k (k (z T1))
1052 toConstr (T1 _ _) = $cT1
1058 gen_Data_binds :: FixityEnv
1060 -> (LHsBinds RdrName, -- The method bindings
1061 LHsBinds RdrName) -- Auxiliary bindings
1062 gen_Data_binds fix_env tycon
1063 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1064 -- Auxiliary definitions: the data type and constructors
1065 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1067 tycon_loc = getSrcSpan tycon
1068 tycon_name = tyConName tycon
1069 data_cons = tyConDataCons tycon
1070 n_cons = length data_cons
1071 one_constr = n_cons == 1
1074 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1075 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1076 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1079 con_name = getRdrName con
1080 as_needed = take (dataConSourceArity con) as_RDRs
1081 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1083 ------------ gunfold
1084 gunfold_bind = mk_FunBind tycon_loc
1086 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1090 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1091 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1092 (map gunfold_alt data_cons)
1094 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1095 mk_unfold_rhs dc = foldr nlHsApp
1096 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1097 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1099 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1100 -- redundant test, and annoying warning
1101 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1102 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1106 ------------ toConstr
1107 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1108 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1110 ------------ dataTypeOf
1111 dataTypeOf_bind = mk_easy_FunBind
1115 (nlHsVar data_type_name)
1119 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1120 datatype_bind = mkVarBind
1123 ( nlHsVar mkDataType_RDR
1124 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1125 `nlHsApp` nlList constrs
1127 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1130 ------------ $cT1 etc
1131 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1132 mk_con_bind dc = mkVarBind
1135 (nlHsApps mkConstr_RDR (constr_args dc))
1137 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1138 nlHsVar data_type_name, -- DataType
1139 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1140 nlList labels, -- Field labels
1141 nlHsVar fixity] -- Fixity
1143 labels = map (nlHsLit . mkHsString . getOccString)
1144 (dataConFieldLabels dc)
1145 dc_occ = getOccName dc
1146 is_infix = isDataSymOcc dc_occ
1147 fixity | is_infix = infix_RDR
1148 | otherwise = prefix_RDR
1150 gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl")
1151 gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold")
1152 toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr")
1153 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1154 mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
1155 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1156 conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
1157 prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
1158 infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
1161 %************************************************************************
1163 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1165 %************************************************************************
1170 con2tag_Foo :: Foo ... -> Int#
1171 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1172 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1175 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1180 = GenCon2Tag | GenTag2Con | GenMaxTag
1182 gen_tag_n_con_monobind
1183 :: ( RdrName, -- (proto)Name for the thing in question
1184 TyCon, -- tycon in question
1188 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1189 | lots_of_constructors
1190 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1193 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1196 tycon_loc = getSrcSpan tycon
1198 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1199 -- We can't use gerRdrName because that makes an Exact RdrName
1200 -- and we can't put them in the LocalRdrEnv
1202 -- Give a signature to the bound variable, so
1203 -- that the case expression generated by getTag is
1204 -- monomorphic. In the push-enter model we get better code.
1205 get_tag_rhs = noLoc $ ExprWithTySig
1206 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1207 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1208 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1210 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1212 nlHsTyVar (getRdrName intPrimTyCon)
1214 lots_of_constructors = tyConFamilySize tycon > 8
1215 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1216 -- but we don't do vectored returns any more.
1218 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1219 mk_stuff con = ([nlWildConPat con],
1220 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1222 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1223 = mk_FunBind (getSrcSpan tycon) rdr_name
1224 [([nlConVarPat intDataCon_RDR [a_RDR]],
1225 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1226 (nlHsTyVar (getRdrName tycon))))]
1228 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1229 = mkVarBind (getSrcSpan tycon) rdr_name
1230 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1232 max_tag = case (tyConDataCons tycon) of
1233 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1237 %************************************************************************
1239 \subsection{Utility bits for generating bindings}
1241 %************************************************************************
1244 ToDo: Better SrcLocs.
1248 LHsExpr RdrName -- What to do for equality
1249 -> LHsExpr RdrName -> LHsExpr RdrName
1251 careful_compare_Case :: -- checks for primitive types...
1252 TyCon -- The tycon we are deriving for
1254 -> LHsExpr RdrName -- What to do for equality
1255 -> LHsExpr RdrName -> LHsExpr RdrName
1258 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1259 -- Was: compare_gen_Case cmp_eq_RDR
1261 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1262 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1263 compare_gen_Case eq a b -- General case
1264 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1265 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1266 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1267 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1269 careful_compare_Case tycon ty eq a b
1270 | not (isUnLiftedType ty)
1271 = compare_gen_Case eq a b
1272 | otherwise -- We have to do something special for primitive things...
1273 = nlHsIf (genOpApp a relevant_eq_op b)
1275 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1277 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1278 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1281 box_if_necy :: String -- The class involved
1282 -> TyCon -- The tycon involved
1283 -> LHsExpr RdrName -- The argument
1284 -> Type -- The argument type
1285 -> LHsExpr RdrName -- Boxed version of the arg
1286 box_if_necy cls_str tycon arg arg_ty
1287 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1290 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1292 assoc_ty_id :: String -- The class involved
1293 -> TyCon -- The tycon involved
1294 -> [(Type,a)] -- The table
1296 -> a -- The result of the lookup
1297 assoc_ty_id cls_str tycon tbl ty
1298 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1299 text "for primitive type" <+> ppr ty)
1300 | otherwise = head res
1302 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1304 eq_op_tbl :: [(Type, PrimOp)]
1306 [(charPrimTy, CharEqOp)
1307 ,(intPrimTy, IntEqOp)
1308 ,(wordPrimTy, WordEqOp)
1309 ,(addrPrimTy, AddrEqOp)
1310 ,(floatPrimTy, FloatEqOp)
1311 ,(doublePrimTy, DoubleEqOp)
1314 lt_op_tbl :: [(Type, PrimOp)]
1316 [(charPrimTy, CharLtOp)
1317 ,(intPrimTy, IntLtOp)
1318 ,(wordPrimTy, WordLtOp)
1319 ,(addrPrimTy, AddrLtOp)
1320 ,(floatPrimTy, FloatLtOp)
1321 ,(doublePrimTy, DoubleLtOp)
1325 [(charPrimTy, getRdrName charDataCon)
1326 ,(intPrimTy, getRdrName intDataCon)
1327 ,(wordPrimTy, wordDataCon_RDR)
1328 ,(floatPrimTy, getRdrName floatDataCon)
1329 ,(doublePrimTy, getRdrName doubleDataCon)
1332 -----------------------------------------------------------------------
1334 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1335 and_Expr a b = genOpApp a and_RDR b
1337 -----------------------------------------------------------------------
1339 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1340 eq_Expr tycon ty a b = genOpApp a eq_op b
1343 | not (isUnLiftedType ty) = eq_RDR
1344 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1345 -- we have to do something special for primitive things...
1349 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1350 untag_Expr tycon [] expr = expr
1351 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1352 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1353 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1355 cmp_tags_Expr :: RdrName -- Comparison op
1356 -> RdrName -> RdrName -- Things to compare
1357 -> LHsExpr RdrName -- What to return if true
1358 -> LHsExpr RdrName -- What to return if false
1361 cmp_tags_Expr op a b true_case false_case
1362 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1365 :: LHsExpr RdrName -> LHsExpr RdrName
1367 enum_from_then_to_Expr
1368 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1371 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1372 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1375 :: LHsExpr RdrName -> LHsExpr RdrName
1378 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1380 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1382 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1383 nested_compose_Expr [e] = parenify e
1384 nested_compose_Expr (e:es)
1385 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1387 -- impossible_Expr is used in case RHSs that should never happen.
1388 -- We generate these to keep the desugarer from complaining that they *might* happen!
1389 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1391 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1392 -- method. It is currently only used by Enum.{succ,pred}
1393 illegal_Expr meth tp msg =
1394 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1396 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1397 -- to include the value of a_RDR in the error string.
1398 illegal_toEnum_tag tp maxtag =
1399 nlHsApp (nlHsVar error_RDR)
1400 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1401 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1402 (nlHsApp (nlHsApp (nlHsApp
1403 (nlHsVar showsPrec_RDR)
1407 (nlHsVar append_RDR)
1408 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1409 (nlHsApp (nlHsApp (nlHsApp
1410 (nlHsVar showsPrec_RDR)
1413 (nlHsLit (mkHsString ")"))))))
1415 parenify e@(L _ (HsVar _)) = e
1416 parenify e = mkHsPar e
1418 -- genOpApp wraps brackets round the operator application, so that the
1419 -- renamer won't subsequently try to re-associate it.
1420 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1424 a_RDR = mkVarUnqual FSLIT("a")
1425 b_RDR = mkVarUnqual FSLIT("b")
1426 c_RDR = mkVarUnqual FSLIT("c")
1427 d_RDR = mkVarUnqual FSLIT("d")
1428 k_RDR = mkVarUnqual FSLIT("k")
1429 z_RDR = mkVarUnqual FSLIT("z")
1430 ah_RDR = mkVarUnqual FSLIT("a#")
1431 bh_RDR = mkVarUnqual FSLIT("b#")
1432 ch_RDR = mkVarUnqual FSLIT("c#")
1433 dh_RDR = mkVarUnqual FSLIT("d#")
1434 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1436 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1437 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1438 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1440 a_Expr = nlHsVar a_RDR
1441 b_Expr = nlHsVar b_RDR
1442 c_Expr = nlHsVar c_RDR
1443 ltTag_Expr = nlHsVar ltTag_RDR
1444 eqTag_Expr = nlHsVar eqTag_RDR
1445 gtTag_Expr = nlHsVar gtTag_RDR
1446 false_Expr = nlHsVar false_RDR
1447 true_Expr = nlHsVar true_RDR
1449 a_Pat = nlVarPat a_RDR
1450 b_Pat = nlVarPat b_RDR
1451 c_Pat = nlVarPat c_RDR
1452 d_Pat = nlVarPat d_RDR
1453 k_Pat = nlVarPat k_RDR
1454 z_Pat = nlVarPat z_RDR
1456 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1457 -- Generates Orig s RdrName, for the binding positions
1458 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1459 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1460 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1462 mk_tc_deriv_name tycon str
1463 = mkDerivedRdrName tc_name mk_occ
1465 tc_name = tyConName tycon
1466 mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1468 new_str = str ++ occNameString tc_occ ++ "#"
1471 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1472 PrelNames, so PrelNames can't import PrimOp.
1475 primOpRdrName op = getRdrName (primOpId op)
1477 minusInt_RDR = primOpRdrName IntSubOp
1478 eqInt_RDR = primOpRdrName IntEqOp
1479 ltInt_RDR = primOpRdrName IntLtOp
1480 geInt_RDR = primOpRdrName IntGeOp
1481 leInt_RDR = primOpRdrName IntLeOp
1482 tagToEnum_RDR = primOpRdrName TagToEnumOp
1484 error_RDR = getRdrName eRROR_ID