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"
56 import Data.List ( partition, intersperse )
59 %************************************************************************
61 \subsection{Generating code, by derivable class}
63 %************************************************************************
65 %************************************************************************
67 \subsubsection{Generating @Eq@ instance declarations}
69 %************************************************************************
71 Here are the heuristics for the code we generate for @Eq@:
74 Let's assume we have a data type with some (possibly zero) nullary
75 data constructors and some ordinary, non-nullary ones (the rest,
76 also possibly zero of them). Here's an example, with both \tr{N}ullary
77 and \tr{O}rdinary data cons.
79 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
83 For the ordinary constructors (if any), we emit clauses to do The
87 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
88 (==) (O2 a1) (O2 a2) = a1 == a2
89 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
92 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
93 \tr{a2} are \tr{Float#}s, then we have to generate
95 case (a1 `eqFloat#` a2) of
98 for that particular test.
101 If there are any nullary constructors, we emit a catch-all clause of
105 (==) a b = case (con2tag_Foo a) of { a# ->
106 case (con2tag_Foo b) of { b# ->
107 case (a# ==# b#) of {
112 If there aren't any nullary constructors, we emit a simpler
119 For the @(/=)@ method, we normally just use the default method.
121 If the type is an enumeration type, we could/may/should? generate
122 special code that calls @con2tag_Foo@, much like for @(==)@ shown
126 We thought about doing this: If we're also deriving @Ord@ for this
129 instance ... Eq (Foo ...) where
130 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
131 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
133 However, that requires that \tr{Ord <whatever>} was put in the context
134 for the instance decl, which it probably wasn't, so the decls
135 produced don't get through the typechecker.
140 gen_Eq_binds :: TyCon -> LHsBinds RdrName
144 tycon_loc = getSrcSpan tycon
146 (nullary_cons, nonnullary_cons)
147 | isNewTyCon tycon = ([], tyConDataCons tycon)
148 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
151 = if (null nullary_cons) then
152 case maybeTyConSingleCon tycon of
154 Nothing -> -- if cons don't match, then False
155 [([nlWildPat, nlWildPat], false_Expr)]
156 else -- calc. and compare the tags
158 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
159 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
162 mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
163 mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
164 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
167 ------------------------------------------------------------------
170 con1_pat = nlConVarPat data_con_RDR as_needed
171 con2_pat = nlConVarPat data_con_RDR bs_needed
173 data_con_RDR = getRdrName data_con
174 con_arity = length tys_needed
175 as_needed = take con_arity as_RDRs
176 bs_needed = take con_arity bs_RDRs
177 tys_needed = dataConOrigArgTys data_con
179 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
181 nested_eq_expr [] [] [] = true_Expr
182 nested_eq_expr tys as bs
183 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
185 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
188 %************************************************************************
190 \subsubsection{Generating @Ord@ instance declarations}
192 %************************************************************************
194 For a derived @Ord@, we concentrate our attentions on @compare@
196 compare :: a -> a -> Ordering
197 data Ordering = LT | EQ | GT deriving ()
200 We will use the same example data type as above:
202 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
207 We do all the other @Ord@ methods with calls to @compare@:
209 instance ... (Ord <wurble> <wurble>) where
210 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
211 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
212 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
213 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
215 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
216 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
218 -- compare to come...
222 @compare@ always has two parts. First, we use the compared
223 data-constructors' tags to deal with the case of different
226 compare a b = case (con2tag_Foo a) of { a# ->
227 case (con2tag_Foo b) of { b# ->
228 case (a# ==# b#) of {
230 False -> case (a# <# b#) of
235 cmp_eq = ... to come ...
239 We are only left with the ``help'' function @cmp_eq@, to deal with
240 comparing data constructors with the same tag.
242 For the ordinary constructors (if any), we emit the sorta-obvious
243 compare-style stuff; for our example:
245 cmp_eq (O1 a1 b1) (O1 a2 b2)
246 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
248 cmp_eq (O2 a1) (O2 a2)
251 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
252 = case (compare a1 a2) of {
255 EQ -> case compare b1 b2 of {
263 Again, we must be careful about unlifted comparisons. For example,
264 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
268 cmp_eq lt eq gt (O2 a1) (O2 a2)
270 -- or maybe the unfolded equivalent
274 For the remaining nullary constructors, we already know that the
281 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
285 gen_Ord_binds :: TyCon -> LHsBinds RdrName
288 = unitBag compare -- `AndMonoBinds` compare
289 -- The default declaration in PrelBase handles this
291 tycon_loc = getSrcSpan tycon
292 --------------------------------------------------------------------
294 compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
295 compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
296 cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
299 | single_con_type = cmp_eq_Expr a_Expr b_Expr
301 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
302 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
303 (cmp_eq_Expr a_Expr b_Expr) -- True case
304 -- False case; they aren't equal
305 -- So we need to do a less-than comparison on the tags
306 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
308 tycon_data_cons = tyConDataCons tycon
309 single_con_type = isSingleton tycon_data_cons
310 (nullary_cons, nonnullary_cons)
311 | isNewTyCon tycon = ([], tyConDataCons tycon)
312 | otherwise = partition isNullarySrcDataCon tycon_data_cons
314 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
316 | isEnumerationTyCon tycon
317 -- We know the tags are equal, so if it's an enumeration TyCon,
318 -- then there is nothing left to do
319 -- Catch this specially to avoid warnings
320 -- about overlapping patterns from the desugarer,
321 -- and to avoid unnecessary pattern-matching
322 = [([nlWildPat,nlWildPat], eqTag_Expr)]
324 = map pats_etc nonnullary_cons ++
325 (if single_con_type then -- Omit wildcards when there's just one
326 [] -- constructor, to silence desugarer
328 [([nlWildPat, nlWildPat], default_rhs)])
332 = ([con1_pat, con2_pat],
333 nested_compare_expr tys_needed as_needed bs_needed)
335 con1_pat = nlConVarPat data_con_RDR as_needed
336 con2_pat = nlConVarPat data_con_RDR bs_needed
338 data_con_RDR = getRdrName data_con
339 con_arity = length tys_needed
340 as_needed = take con_arity as_RDRs
341 bs_needed = take con_arity bs_RDRs
342 tys_needed = dataConOrigArgTys data_con
344 nested_compare_expr [ty] [a] [b]
345 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
347 nested_compare_expr (ty:tys) (a:as) (b:bs)
348 = let eq_expr = nested_compare_expr tys as bs
349 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
351 nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
353 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
354 -- inexhaustive patterns
355 | otherwise = eqTag_Expr -- Some nullary constructors;
356 -- Tags are equal, no args => return EQ
359 %************************************************************************
361 \subsubsection{Generating @Enum@ instance declarations}
363 %************************************************************************
365 @Enum@ can only be derived for enumeration types. For a type
367 data Foo ... = N1 | N2 | ... | Nn
370 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
371 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
374 instance ... Enum (Foo ...) where
375 succ x = toEnum (1 + fromEnum x)
376 pred x = toEnum (fromEnum x - 1)
378 toEnum i = tag2con_Foo i
380 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
384 = case con2tag_Foo a of
385 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
388 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
392 = case con2tag_Foo a of { a# ->
393 case con2tag_Foo b of { b# ->
394 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
398 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
401 gen_Enum_binds :: TyCon -> LHsBinds RdrName
413 tycon_loc = getSrcSpan tycon
414 occ_nm = getOccString tycon
417 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
418 untag_Expr tycon [(a_RDR, ah_RDR)] $
419 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
420 nlHsVarApps intDataCon_RDR [ah_RDR]])
421 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
422 (nlHsApp (nlHsVar (tag2con_RDR tycon))
423 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
427 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
428 untag_Expr tycon [(a_RDR, ah_RDR)] $
429 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
430 nlHsVarApps intDataCon_RDR [ah_RDR]])
431 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
432 (nlHsApp (nlHsVar (tag2con_RDR tycon))
433 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
434 nlHsLit (HsInt (-1))]))
437 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
438 nlHsIf (nlHsApps and_RDR
439 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
440 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
441 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
442 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
445 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
446 untag_Expr tycon [(a_RDR, ah_RDR)] $
448 [nlHsVar (tag2con_RDR tycon),
449 nlHsPar (enum_from_to_Expr
450 (nlHsVarApps intDataCon_RDR [ah_RDR])
451 (nlHsVar (maxtag_RDR tycon)))]
454 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
455 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
456 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
457 nlHsPar (enum_from_then_to_Expr
458 (nlHsVarApps intDataCon_RDR [ah_RDR])
459 (nlHsVarApps intDataCon_RDR [bh_RDR])
460 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
461 nlHsVarApps intDataCon_RDR [bh_RDR]])
463 (nlHsVar (maxtag_RDR tycon))
467 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
468 untag_Expr tycon [(a_RDR, ah_RDR)] $
469 (nlHsVarApps intDataCon_RDR [ah_RDR])
472 %************************************************************************
474 \subsubsection{Generating @Bounded@ instance declarations}
476 %************************************************************************
479 gen_Bounded_binds tycon
480 = if isEnumerationTyCon tycon then
481 listToBag [ min_bound_enum, max_bound_enum ]
483 ASSERT(isSingleton data_cons)
484 listToBag [ min_bound_1con, max_bound_1con ]
486 data_cons = tyConDataCons tycon
487 tycon_loc = getSrcSpan tycon
489 ----- enum-flavored: ---------------------------
490 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
491 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
493 data_con_1 = head data_cons
494 data_con_N = last data_cons
495 data_con_1_RDR = getRdrName data_con_1
496 data_con_N_RDR = getRdrName data_con_N
498 ----- single-constructor-flavored: -------------
499 arity = dataConSourceArity data_con_1
501 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
502 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
503 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
504 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
507 %************************************************************************
509 \subsubsection{Generating @Ix@ instance declarations}
511 %************************************************************************
513 Deriving @Ix@ is only possible for enumeration types and
514 single-constructor types. We deal with them in turn.
516 For an enumeration type, e.g.,
518 data Foo ... = N1 | N2 | ... | Nn
520 things go not too differently from @Enum@:
522 instance ... Ix (Foo ...) where
524 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
528 = case (con2tag_Foo a) of { a# ->
529 case (con2tag_Foo b) of { b# ->
530 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
533 -- Generate code for unsafeIndex, becuase using index leads
534 -- to lots of redundant range tests
535 unsafeIndex c@(a, b) d
536 = case (con2tag_Foo d -# con2tag_Foo a) of
541 p_tag = con2tag_Foo c
543 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
547 = case (con2tag_Foo a) of { a_tag ->
548 case (con2tag_Foo b) of { b_tag ->
549 case (con2tag_Foo c) of { c_tag ->
550 if (c_tag >=# a_tag) then
556 (modulo suitable case-ification to handle the unlifted tags)
558 For a single-constructor type (NB: this includes all tuples), e.g.,
560 data Foo ... = MkFoo a b Int Double c c
562 we follow the scheme given in Figure~19 of the Haskell~1.2 report
566 gen_Ix_binds :: TyCon -> LHsBinds RdrName
569 = if isEnumerationTyCon tycon
573 tycon_loc = getSrcSpan tycon
575 --------------------------------------------------------------
576 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
579 = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
580 untag_Expr tycon [(a_RDR, ah_RDR)] $
581 untag_Expr tycon [(b_RDR, bh_RDR)] $
582 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
583 nlHsPar (enum_from_to_Expr
584 (nlHsVarApps intDataCon_RDR [ah_RDR])
585 (nlHsVarApps intDataCon_RDR [bh_RDR]))
588 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
589 [noLoc (AsPat (noLoc c_RDR)
590 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
592 untag_Expr tycon [(a_RDR, ah_RDR)] (
593 untag_Expr tycon [(d_RDR, dh_RDR)] (
595 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
598 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
599 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
604 = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
605 untag_Expr tycon [(a_RDR, ah_RDR)] (
606 untag_Expr tycon [(b_RDR, bh_RDR)] (
607 untag_Expr tycon [(c_RDR, ch_RDR)] (
608 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
609 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
614 --------------------------------------------------------------
616 = listToBag [single_con_range, single_con_index, single_con_inRange]
619 = case maybeTyConSingleCon tycon of -- just checking...
620 Nothing -> panic "get_Ix_binds"
621 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
622 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
625 con_arity = dataConSourceArity data_con
626 data_con_RDR = getRdrName data_con
628 as_needed = take con_arity as_RDRs
629 bs_needed = take con_arity bs_RDRs
630 cs_needed = take con_arity cs_RDRs
632 con_pat xs = nlConVarPat data_con_RDR xs
633 con_expr = nlHsVarApps data_con_RDR cs_needed
635 --------------------------------------------------------------
637 = mk_easy_FunBind tycon_loc range_RDR
638 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
639 nlHsDo ListComp stmts con_expr
641 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
643 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
644 (nlHsApp (nlHsVar range_RDR)
645 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
649 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
650 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
652 (mk_index (zip3 as_needed bs_needed cs_needed))
654 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
655 mk_index [] = nlHsIntLit 0
656 mk_index [(l,u,i)] = mk_one l u i
657 mk_index ((l,u,i) : rest)
662 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
663 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
664 ) times_RDR (mk_index rest)
667 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
671 = mk_easy_FunBind tycon_loc inRange_RDR
672 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
674 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
676 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
680 %************************************************************************
682 \subsubsection{Generating @Read@ instance declarations}
684 %************************************************************************
694 instance Read T where
698 do x <- ReadP.step Read.readPrec
699 Symbol "%%" <- Lex.lex
700 y <- ReadP.step Read.readPrec
704 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
705 -- Record construction binds even more tightly than application
706 do Ident "T1" <- Lex.lex
708 Ident "f1" <- Lex.lex
710 x <- ReadP.reset Read.readPrec
712 return (T1 { f1 = x }))
715 do Ident "T2" <- Lex.lexP
716 x <- ReadP.step Read.readPrec
720 readListPrec = readListPrecDefault
721 readList = readListDefault
725 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
727 gen_Read_binds get_fixity tycon
728 = listToBag [read_prec, default_readlist, default_readlistprec]
730 -----------------------------------------------------------------------
732 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
735 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
736 -----------------------------------------------------------------------
738 loc = getSrcSpan tycon
739 data_cons = tyConDataCons tycon
740 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
742 read_prec = mkVarBind loc readPrec_RDR
743 (nlHsApp (nlHsVar parens_RDR) read_cons)
745 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
746 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
749 = case nullary_cons of
751 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
752 (result_expr con [])]
753 _ -> [nlHsApp (nlHsVar choose_RDR)
754 (nlList (map mk_pair nullary_cons))]
756 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
760 read_non_nullary_con data_con
761 | is_infix = mk_parser infix_prec infix_stmts body
762 | is_record = mk_parser record_prec record_stmts body
763 -- Using these two lines instead allows the derived
764 -- read for infix and record bindings to read the prefix form
765 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
766 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
767 | otherwise = prefix_parser
769 body = result_expr data_con as_needed
770 con_str = data_con_str data_con
772 prefix_parser = mk_parser prefix_prec prefix_stmts body
773 prefix_stmts -- T a b c
774 = (if not (isSym con_str) then
775 [bindLex (ident_pat con_str)]
776 else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
779 infix_stmts -- a %% b, or a `T` b
782 then [bindLex (symbol_pat con_str)]
783 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
786 record_stmts -- T { f1 = a, f2 = b }
787 = [bindLex (ident_pat (wrapOpParens con_str)),
789 ++ concat (intersperse [read_punc ","] field_stmts)
792 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
794 con_arity = dataConSourceArity data_con
795 labels = dataConFieldLabels data_con
796 dc_nm = getName data_con
797 is_infix = dataConIsInfix data_con
798 is_record = length labels > 0
799 as_needed = take con_arity as_RDRs
800 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
801 (read_a1:read_a2:_) = read_args
803 prefix_prec = appPrecedence
804 infix_prec = getPrecedence get_fixity dc_nm
805 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
806 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
808 ------------------------------------------------------------------------
810 ------------------------------------------------------------------------
811 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
812 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
813 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
814 con_app con as = nlHsVarApps (getRdrName con) as -- con as
815 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
817 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
818 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
819 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
821 data_con_str con = occNameString (getOccName con)
823 read_punc c = bindLex (punc_pat c)
825 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
826 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
828 read_field lbl a = read_lbl lbl ++
830 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
832 -- When reading field labels we might encounter
837 read_lbl lbl | isSym lbl_str
839 bindLex (symbol_pat lbl_str),
842 = [bindLex (ident_pat lbl_str)]
844 lbl_str = occNameString (getOccName lbl)
848 %************************************************************************
850 \subsubsection{Generating @Show@ instance declarations}
852 %************************************************************************
858 data Tree a = Leaf a | Tree a :^: Tree a
860 instance (Show a) => Show (Tree a) where
862 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
864 showStr = showString "Leaf " . showsPrec (app_prec+1) m
866 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
868 showStr = showsPrec (up_prec+1) u .
870 showsPrec (up_prec+1) v
871 -- Note: right-associativity of :^: ignored
873 up_prec = 5 -- Precedence of :^:
874 app_prec = 10 -- Application has precedence one more than
875 -- the most tightly-binding operator
878 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
880 gen_Show_binds get_fixity tycon
881 = listToBag [shows_prec, show_list]
883 tycon_loc = getSrcSpan tycon
884 -----------------------------------------------------------------------
885 show_list = mkVarBind tycon_loc showList_RDR
886 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
887 -----------------------------------------------------------------------
888 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
891 | nullary_con = -- skip the showParen junk...
892 ASSERT(null bs_needed)
893 ([nlWildPat, con_pat], mk_showString_app con_str)
896 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
897 (nlHsPar (nested_compose_Expr show_thingies)))
899 data_con_RDR = getRdrName data_con
900 con_arity = dataConSourceArity data_con
901 bs_needed = take con_arity bs_RDRs
902 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
903 con_pat = nlConVarPat data_con_RDR bs_needed
904 nullary_con = con_arity == 0
905 labels = dataConFieldLabels data_con
906 lab_fields = length labels
907 record_syntax = lab_fields > 0
909 dc_nm = getName data_con
910 dc_occ_nm = getOccName data_con
911 con_str = occNameString dc_occ_nm
912 op_con_str = wrapOpParens con_str
913 backquote_str = wrapOpBackquotes con_str
916 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
917 | record_syntax = mk_showString_app (op_con_str ++ " {") :
918 show_record_args ++ [mk_showString_app "}"]
919 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
921 show_label l = mk_showString_app (nm ++ " = ")
922 -- Note the spaces around the "=" sign. If we don't have them
923 -- then we get Foo { x=-1 } and the "=-" parses as a single
924 -- lexeme. Only the space after the '=' is necessary, but
925 -- it seems tidier to have them both sides.
927 occ_nm = getOccName l
928 nm = wrapOpParens (occNameString occ_nm)
930 show_args = zipWith show_arg bs_needed arg_tys
931 (show_arg1:show_arg2:_) = show_args
932 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
934 -- Assumption for record syntax: no of fields == no of labelled fields
935 -- (and in same order)
936 show_record_args = concat $
937 intersperse [mk_showString_app ", "] $
938 [ [show_label lbl, arg]
939 | (lbl,arg) <- zipEqual "gen_Show_binds"
942 -- Generates (showsPrec p x) for argument x, but it also boxes
943 -- the argument first if necessary. Note that this prints unboxed
944 -- things without any '#' decorations; could change that if need be
945 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
946 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
949 is_infix = dataConIsInfix data_con
950 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
951 arg_prec | record_syntax = 0 -- Record fields don't need parens
952 | otherwise = con_prec_plus_one
954 wrapOpParens :: String -> String
955 wrapOpParens s | isSym s = '(' : s ++ ")"
958 wrapOpBackquotes :: String -> String
959 wrapOpBackquotes s | isSym s = s
960 | otherwise = '`' : s ++ "`"
962 isSym :: String -> Bool
964 isSym (c:cs) = startsVarSym c || startsConSym c
966 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
970 getPrec :: Bool -> FixityEnv -> Name -> Integer
971 getPrec is_infix get_fixity nm
972 | not is_infix = appPrecedence
973 | otherwise = getPrecedence get_fixity nm
975 appPrecedence :: Integer
976 appPrecedence = fromIntegral maxPrecedence + 1
977 -- One more than the precedence of the most
978 -- tightly-binding operator
980 getPrecedence :: FixityEnv -> Name -> Integer
981 getPrecedence get_fixity nm
982 = case lookupFixity get_fixity nm of
983 Fixity x _ -> fromIntegral x
987 %************************************************************************
989 \subsection{Typeable}
991 %************************************************************************
999 instance Typeable2 T where
1000 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1002 We are passed the Typeable2 class as well as T
1005 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1006 gen_Typeable_binds tycon
1008 mk_easy_FunBind tycon_loc
1009 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1011 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1013 tycon_loc = getSrcSpan tycon
1014 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1016 mk_typeOf_RDR :: TyCon -> RdrName
1017 -- Use the arity of the TyCon to make the right typeOfn function
1018 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1020 arity = tyConArity tycon
1021 suffix | arity == 0 = ""
1022 | otherwise = show arity
1027 %************************************************************************
1031 %************************************************************************
1035 data T a b = T1 a b | T2
1039 $cT1 = mkDataCon $dT "T1" Prefix
1040 $cT2 = mkDataCon $dT "T2" Prefix
1041 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1042 -- the [] is for field labels.
1044 instance (Data a, Data b) => Data (T a b) where
1045 gfoldl k z (T1 a b) = z T `k` a `k` b
1046 gfoldl k z T2 = z T2
1047 -- ToDo: add gmapT,Q,M, gfoldr
1049 gunfold k z c = case conIndex c of
1050 I# 1# -> k (k (z T1))
1053 toConstr (T1 _ _) = $cT1
1059 gen_Data_binds :: FixityEnv
1061 -> (LHsBinds RdrName, -- The method bindings
1062 LHsBinds RdrName) -- Auxiliary bindings
1063 gen_Data_binds fix_env tycon
1064 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1065 -- Auxiliary definitions: the data type and constructors
1066 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1068 tycon_loc = getSrcSpan tycon
1069 tycon_name = tyConName tycon
1070 data_cons = tyConDataCons tycon
1071 n_cons = length data_cons
1072 one_constr = n_cons == 1
1075 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1076 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1077 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1080 con_name = getRdrName con
1081 as_needed = take (dataConSourceArity con) as_RDRs
1082 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1084 ------------ gunfold
1085 gunfold_bind = mk_FunBind tycon_loc
1087 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1091 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1092 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1093 (map gunfold_alt data_cons)
1095 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1096 mk_unfold_rhs dc = foldr nlHsApp
1097 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1098 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1100 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1101 -- redundant test, and annoying warning
1102 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1103 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1107 ------------ toConstr
1108 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1109 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1111 ------------ dataTypeOf
1112 dataTypeOf_bind = mk_easy_FunBind
1116 (nlHsVar data_type_name)
1120 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1121 datatype_bind = mkVarBind
1124 ( nlHsVar mkDataType_RDR
1125 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1126 `nlHsApp` nlList constrs
1128 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1131 ------------ $cT1 etc
1132 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1133 mk_con_bind dc = mkVarBind
1136 (nlHsApps mkConstr_RDR (constr_args dc))
1138 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1139 nlHsVar data_type_name, -- DataType
1140 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1141 nlList labels, -- Field labels
1142 nlHsVar fixity] -- Fixity
1144 labels = map (nlHsLit . mkHsString . getOccString)
1145 (dataConFieldLabels dc)
1146 dc_occ = getOccName dc
1147 is_infix = isDataSymOcc dc_occ
1148 fixity | is_infix = infix_RDR
1149 | otherwise = prefix_RDR
1151 gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl")
1152 gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold")
1153 toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr")
1154 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1155 mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
1156 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1157 conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
1158 prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
1159 infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
1162 %************************************************************************
1164 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1166 %************************************************************************
1171 con2tag_Foo :: Foo ... -> Int#
1172 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1173 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1176 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1181 = GenCon2Tag | GenTag2Con | GenMaxTag
1183 gen_tag_n_con_monobind
1184 :: ( RdrName, -- (proto)Name for the thing in question
1185 TyCon, -- tycon in question
1189 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1190 | lots_of_constructors
1191 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1194 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1197 tycon_loc = getSrcSpan tycon
1199 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1200 -- We can't use gerRdrName because that makes an Exact RdrName
1201 -- and we can't put them in the LocalRdrEnv
1203 -- Give a signature to the bound variable, so
1204 -- that the case expression generated by getTag is
1205 -- monomorphic. In the push-enter model we get better code.
1206 get_tag_rhs = noLoc $ ExprWithTySig
1207 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1208 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1209 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1211 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1214 nlHsTyVar (getRdrName intPrimTyCon)
1216 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
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 getSrcSpan = srcLocSpan . getSrcLoc
1428 a_RDR = mkVarUnqual FSLIT("a")
1429 b_RDR = mkVarUnqual FSLIT("b")
1430 c_RDR = mkVarUnqual FSLIT("c")
1431 d_RDR = mkVarUnqual FSLIT("d")
1432 k_RDR = mkVarUnqual FSLIT("k")
1433 z_RDR = mkVarUnqual FSLIT("z")
1434 ah_RDR = mkVarUnqual FSLIT("a#")
1435 bh_RDR = mkVarUnqual FSLIT("b#")
1436 ch_RDR = mkVarUnqual FSLIT("c#")
1437 dh_RDR = mkVarUnqual FSLIT("d#")
1438 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1440 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1441 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1442 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1444 a_Expr = nlHsVar a_RDR
1445 b_Expr = nlHsVar b_RDR
1446 c_Expr = nlHsVar c_RDR
1447 ltTag_Expr = nlHsVar ltTag_RDR
1448 eqTag_Expr = nlHsVar eqTag_RDR
1449 gtTag_Expr = nlHsVar gtTag_RDR
1450 false_Expr = nlHsVar false_RDR
1451 true_Expr = nlHsVar true_RDR
1453 a_Pat = nlVarPat a_RDR
1454 b_Pat = nlVarPat b_RDR
1455 c_Pat = nlVarPat c_RDR
1456 d_Pat = nlVarPat d_RDR
1457 k_Pat = nlVarPat k_RDR
1458 z_Pat = nlVarPat z_RDR
1460 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1461 -- Generates Orig s RdrName, for the binding positions
1462 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1463 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1464 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1466 mk_tc_deriv_name tycon str
1467 = mkDerivedRdrName tc_name mk_occ
1469 tc_name = tyConName tycon
1470 mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1472 new_str = str ++ occNameString tc_occ ++ "#"
1475 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1476 PrelNames, so PrelNames can't import PrimOp.
1479 primOpRdrName op = getRdrName (primOpId op)
1481 minusInt_RDR = primOpRdrName IntSubOp
1482 eqInt_RDR = primOpRdrName IntEqOp
1483 ltInt_RDR = primOpRdrName IntLtOp
1484 geInt_RDR = primOpRdrName IntGeOp
1485 leInt_RDR = primOpRdrName IntLeOp
1486 tagToEnum_RDR = primOpRdrName TagToEnumOp
1488 error_RDR = getRdrName eRROR_ID