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.
15 -- The above warning supression flag is a temporary kludge.
16 -- While working on this module you are encouraged to remove it and fix
17 -- any warnings in the module. See
18 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
22 DerivAuxBind(..), DerivAuxBinds, isDupAux,
35 con2tag_RDR, tag2con_RDR, maxtag_RDR
38 #include "HsVersions.h"
62 import Data.List ( partition, intersperse )
66 type DerivAuxBinds = [DerivAuxBind]
68 data DerivAuxBind -- Please add these auxiliary top-level bindings
69 = DerivAuxBind (LHsBind RdrName)
70 | GenCon2Tag TyCon -- The con2Tag for given TyCon
71 | GenTag2Con TyCon -- ...ditto tag2Con
72 | GenMaxTag TyCon -- ...and maxTag
74 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
75 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1==tc2
76 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1==tc2
77 isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1==tc2
78 isDupAux b1 b2 = False
82 %************************************************************************
86 %************************************************************************
88 Here are the heuristics for the code we generate for @Eq@:
91 Let's assume we have a data type with some (possibly zero) nullary
92 data constructors and some ordinary, non-nullary ones (the rest,
93 also possibly zero of them). Here's an example, with both \tr{N}ullary
94 and \tr{O}rdinary data cons.
96 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
100 For the ordinary constructors (if any), we emit clauses to do The
104 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
105 (==) (O2 a1) (O2 a2) = a1 == a2
106 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
109 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
110 \tr{a2} are \tr{Float#}s, then we have to generate
112 case (a1 `eqFloat#` a2) of
115 for that particular test.
118 If there are any nullary constructors, we emit a catch-all clause of
122 (==) a b = case (con2tag_Foo a) of { a# ->
123 case (con2tag_Foo b) of { b# ->
124 case (a# ==# b#) of {
129 If there aren't any nullary constructors, we emit a simpler
136 For the @(/=)@ method, we normally just use the default method.
138 If the type is an enumeration type, we could/may/should? generate
139 special code that calls @con2tag_Foo@, much like for @(==)@ shown
143 We thought about doing this: If we're also deriving @Ord@ for this
146 instance ... Eq (Foo ...) where
147 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
148 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
150 However, that requires that \tr{Ord <whatever>} was put in the context
151 for the instance decl, which it probably wasn't, so the decls
152 produced don't get through the typechecker.
157 gen_Eq_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
159 = (method_binds, aux_binds)
161 tycon_loc = getSrcSpan tycon
163 (nullary_cons, nonnullary_cons)
164 | isNewTyCon tycon = ([], tyConDataCons tycon)
165 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
167 no_nullary_cons = null nullary_cons
169 rest | no_nullary_cons
170 = case maybeTyConSingleCon tycon of
172 Nothing -> -- if cons don't match, then False
173 [([nlWildPat, nlWildPat], false_Expr)]
174 | otherwise -- calc. and compare the tags
176 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
177 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
179 aux_binds | no_nullary_cons = []
180 | otherwise = [GenCon2Tag tycon]
182 method_binds = listToBag [
183 mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
184 mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
185 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
187 ------------------------------------------------------------------
190 con1_pat = nlConVarPat data_con_RDR as_needed
191 con2_pat = nlConVarPat data_con_RDR bs_needed
193 data_con_RDR = getRdrName data_con
194 con_arity = length tys_needed
195 as_needed = take con_arity as_RDRs
196 bs_needed = take con_arity bs_RDRs
197 tys_needed = dataConOrigArgTys data_con
199 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
201 nested_eq_expr [] [] [] = true_Expr
202 nested_eq_expr tys as bs
203 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
205 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
208 %************************************************************************
212 %************************************************************************
214 For a derived @Ord@, we concentrate our attentions on @compare@
216 compare :: a -> a -> Ordering
217 data Ordering = LT | EQ | GT deriving ()
220 We will use the same example data type as above:
222 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
227 We do all the other @Ord@ methods with calls to @compare@:
229 instance ... (Ord <wurble> <wurble>) where
230 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
231 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
232 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
233 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
235 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
236 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
238 -- compare to come...
242 @compare@ always has two parts. First, we use the compared
243 data-constructors' tags to deal with the case of different
246 compare a b = case (con2tag_Foo a) of { a# ->
247 case (con2tag_Foo b) of { b# ->
248 case (a# ==# b#) of {
250 False -> case (a# <# b#) of
255 cmp_eq = ... to come ...
259 We are only left with the ``help'' function @cmp_eq@, to deal with
260 comparing data constructors with the same tag.
262 For the ordinary constructors (if any), we emit the sorta-obvious
263 compare-style stuff; for our example:
265 cmp_eq (O1 a1 b1) (O1 a2 b2)
266 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
268 cmp_eq (O2 a1) (O2 a2)
271 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
272 = case (compare a1 a2) of {
275 EQ -> case compare b1 b2 of {
283 Again, we must be careful about unlifted comparisons. For example,
284 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
288 cmp_eq lt eq gt (O2 a1) (O2 a2)
290 -- or maybe the unfolded equivalent
294 For the remaining nullary constructors, we already know that the
301 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
305 gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
308 = (unitBag compare, aux_binds)
309 -- `AndMonoBinds` compare
310 -- The default declaration in PrelBase handles this
312 tycon_loc = getSrcSpan tycon
313 --------------------------------------------------------------------
314 aux_binds | single_con_type = []
315 | otherwise = [GenCon2Tag tycon]
317 compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
318 compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
319 cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
322 | single_con_type = cmp_eq_Expr a_Expr b_Expr
324 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
325 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
326 (cmp_eq_Expr a_Expr b_Expr) -- True case
327 -- False case; they aren't equal
328 -- So we need to do a less-than comparison on the tags
329 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
331 tycon_data_cons = tyConDataCons tycon
332 single_con_type = isSingleton tycon_data_cons
333 (nullary_cons, nonnullary_cons)
334 | isNewTyCon tycon = ([], tyConDataCons tycon)
335 | otherwise = partition isNullarySrcDataCon tycon_data_cons
337 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
339 | isEnumerationTyCon tycon
340 -- We know the tags are equal, so if it's an enumeration TyCon,
341 -- then there is nothing left to do
342 -- Catch this specially to avoid warnings
343 -- about overlapping patterns from the desugarer,
344 -- and to avoid unnecessary pattern-matching
345 = [([nlWildPat,nlWildPat], eqTag_Expr)]
347 = map pats_etc nonnullary_cons ++
348 (if single_con_type then -- Omit wildcards when there's just one
349 [] -- constructor, to silence desugarer
351 [([nlWildPat, nlWildPat], default_rhs)])
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
358 = ([con1_pat, con2_pat],
359 nested_compare_expr tys_needed as_needed bs_needed)
361 con1_pat = nlConVarPat data_con_RDR as_needed
362 con2_pat = nlConVarPat data_con_RDR bs_needed
364 data_con_RDR = getRdrName data_con
365 con_arity = length tys_needed
366 as_needed = take con_arity as_RDRs
367 bs_needed = take con_arity bs_RDRs
368 tys_needed = dataConOrigArgTys data_con
370 nested_compare_expr [ty] [a] [b]
371 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
373 nested_compare_expr (ty:tys) (a:as) (b:bs)
374 = let eq_expr = nested_compare_expr tys as bs
375 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
377 nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
381 %************************************************************************
385 %************************************************************************
387 @Enum@ can only be derived for enumeration types. For a type
389 data Foo ... = N1 | N2 | ... | Nn
392 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
393 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
396 instance ... Enum (Foo ...) where
397 succ x = toEnum (1 + fromEnum x)
398 pred x = toEnum (fromEnum x - 1)
400 toEnum i = tag2con_Foo i
402 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
406 = case con2tag_Foo a of
407 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
410 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
414 = case con2tag_Foo a of { a# ->
415 case con2tag_Foo b of { b# ->
416 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
420 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
423 gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
425 = (method_binds, aux_binds)
427 method_binds = listToBag [
435 aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
437 tycon_loc = getSrcSpan tycon
438 occ_nm = getOccString tycon
441 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
442 untag_Expr tycon [(a_RDR, ah_RDR)] $
443 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
444 nlHsVarApps intDataCon_RDR [ah_RDR]])
445 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
446 (nlHsApp (nlHsVar (tag2con_RDR tycon))
447 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
451 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
452 untag_Expr tycon [(a_RDR, ah_RDR)] $
453 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
454 nlHsVarApps intDataCon_RDR [ah_RDR]])
455 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
456 (nlHsApp (nlHsVar (tag2con_RDR tycon))
457 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
458 nlHsLit (HsInt (-1))]))
461 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
462 nlHsIf (nlHsApps and_RDR
463 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
464 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
465 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
466 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
469 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
470 untag_Expr tycon [(a_RDR, ah_RDR)] $
472 [nlHsVar (tag2con_RDR tycon),
473 nlHsPar (enum_from_to_Expr
474 (nlHsVarApps intDataCon_RDR [ah_RDR])
475 (nlHsVar (maxtag_RDR tycon)))]
478 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
479 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
480 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
481 nlHsPar (enum_from_then_to_Expr
482 (nlHsVarApps intDataCon_RDR [ah_RDR])
483 (nlHsVarApps intDataCon_RDR [bh_RDR])
484 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
485 nlHsVarApps intDataCon_RDR [bh_RDR]])
487 (nlHsVar (maxtag_RDR tycon))
491 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
492 untag_Expr tycon [(a_RDR, ah_RDR)] $
493 (nlHsVarApps intDataCon_RDR [ah_RDR])
496 %************************************************************************
500 %************************************************************************
503 gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
504 gen_Bounded_binds tycon
505 | isEnumerationTyCon tycon
506 = (listToBag [ min_bound_enum, max_bound_enum ], [])
508 = ASSERT(isSingleton data_cons)
509 (listToBag [ min_bound_1con, max_bound_1con ], [])
511 data_cons = tyConDataCons tycon
512 tycon_loc = getSrcSpan tycon
514 ----- enum-flavored: ---------------------------
515 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
516 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
518 data_con_1 = head data_cons
519 data_con_N = last data_cons
520 data_con_1_RDR = getRdrName data_con_1
521 data_con_N_RDR = getRdrName data_con_N
523 ----- single-constructor-flavored: -------------
524 arity = dataConSourceArity data_con_1
526 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
527 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
528 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
529 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
532 %************************************************************************
536 %************************************************************************
538 Deriving @Ix@ is only possible for enumeration types and
539 single-constructor types. We deal with them in turn.
541 For an enumeration type, e.g.,
543 data Foo ... = N1 | N2 | ... | Nn
545 things go not too differently from @Enum@:
547 instance ... Ix (Foo ...) where
549 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
553 = case (con2tag_Foo a) of { a# ->
554 case (con2tag_Foo b) of { b# ->
555 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
558 -- Generate code for unsafeIndex, becuase using index leads
559 -- to lots of redundant range tests
560 unsafeIndex c@(a, b) d
561 = case (con2tag_Foo d -# con2tag_Foo a) of
566 p_tag = con2tag_Foo c
568 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
572 = case (con2tag_Foo a) of { a_tag ->
573 case (con2tag_Foo b) of { b_tag ->
574 case (con2tag_Foo c) of { c_tag ->
575 if (c_tag >=# a_tag) then
581 (modulo suitable case-ification to handle the unlifted tags)
583 For a single-constructor type (NB: this includes all tuples), e.g.,
585 data Foo ... = MkFoo a b Int Double c c
587 we follow the scheme given in Figure~19 of the Haskell~1.2 report
591 gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
594 | isEnumerationTyCon tycon
595 = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
597 = (single_con_ixes, [GenCon2Tag tycon])
599 tycon_loc = getSrcSpan tycon
601 --------------------------------------------------------------
602 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
605 = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
606 untag_Expr tycon [(a_RDR, ah_RDR)] $
607 untag_Expr tycon [(b_RDR, bh_RDR)] $
608 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
609 nlHsPar (enum_from_to_Expr
610 (nlHsVarApps intDataCon_RDR [ah_RDR])
611 (nlHsVarApps intDataCon_RDR [bh_RDR]))
614 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
615 [noLoc (AsPat (noLoc c_RDR)
616 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
618 untag_Expr tycon [(a_RDR, ah_RDR)] (
619 untag_Expr tycon [(d_RDR, dh_RDR)] (
621 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
624 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
625 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
630 = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
631 untag_Expr tycon [(a_RDR, ah_RDR)] (
632 untag_Expr tycon [(b_RDR, bh_RDR)] (
633 untag_Expr tycon [(c_RDR, ch_RDR)] (
634 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
635 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
640 --------------------------------------------------------------
642 = listToBag [single_con_range, single_con_index, single_con_inRange]
645 = case maybeTyConSingleCon tycon of -- just checking...
646 Nothing -> panic "get_Ix_binds"
647 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
648 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
651 con_arity = dataConSourceArity data_con
652 data_con_RDR = getRdrName data_con
654 as_needed = take con_arity as_RDRs
655 bs_needed = take con_arity bs_RDRs
656 cs_needed = take con_arity cs_RDRs
658 con_pat xs = nlConVarPat data_con_RDR xs
659 con_expr = nlHsVarApps data_con_RDR cs_needed
661 --------------------------------------------------------------
663 = mk_easy_FunBind tycon_loc range_RDR
664 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
665 nlHsDo ListComp stmts con_expr
667 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
669 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
670 (nlHsApp (nlHsVar range_RDR)
671 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
675 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
676 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
678 (mk_index (zip3 as_needed bs_needed cs_needed))
680 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
681 mk_index [] = nlHsIntLit 0
682 mk_index [(l,u,i)] = mk_one l u i
683 mk_index ((l,u,i) : rest)
688 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
689 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
690 ) times_RDR (mk_index rest)
693 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
697 = mk_easy_FunBind tycon_loc inRange_RDR
698 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
700 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
702 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
706 %************************************************************************
710 %************************************************************************
720 instance Read T where
724 do x <- ReadP.step Read.readPrec
725 Symbol "%%" <- Lex.lex
726 y <- ReadP.step Read.readPrec
730 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
731 -- Record construction binds even more tightly than application
732 do Ident "T1" <- Lex.lex
734 Ident "f1" <- Lex.lex
736 x <- ReadP.reset Read.readPrec
738 return (T1 { f1 = x }))
741 do Ident "T2" <- Lex.lexP
742 x <- ReadP.step Read.readPrec
746 readListPrec = readListPrecDefault
747 readList = readListDefault
751 gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
753 gen_Read_binds get_fixity tycon
754 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
756 -----------------------------------------------------------------------
758 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
761 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
762 -----------------------------------------------------------------------
764 loc = getSrcSpan tycon
765 data_cons = tyConDataCons tycon
766 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
768 read_prec = mkVarBind loc readPrec_RDR
769 (nlHsApp (nlHsVar parens_RDR) read_cons)
771 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
772 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
775 = case nullary_cons of
777 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
778 (result_expr con [])]
779 _ -> [nlHsApp (nlHsVar choose_RDR)
780 (nlList (map mk_pair nullary_cons))]
782 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
786 read_non_nullary_con data_con
787 | is_infix = mk_parser infix_prec infix_stmts body
788 | is_record = mk_parser record_prec record_stmts body
789 -- Using these two lines instead allows the derived
790 -- read for infix and record bindings to read the prefix form
791 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
792 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
793 | otherwise = prefix_parser
795 body = result_expr data_con as_needed
796 con_str = data_con_str data_con
798 prefix_parser = mk_parser prefix_prec prefix_stmts body
799 prefix_stmts -- T a b c
800 = (if not (isSym con_str) then
801 [bindLex (ident_pat con_str)]
802 else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
805 infix_stmts -- a %% b, or a `T` b
808 then [bindLex (symbol_pat con_str)]
809 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
812 record_stmts -- T { f1 = a, f2 = b }
813 = [bindLex (ident_pat (wrapOpParens con_str)),
815 ++ concat (intersperse [read_punc ","] field_stmts)
818 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
820 con_arity = dataConSourceArity data_con
821 labels = dataConFieldLabels data_con
822 dc_nm = getName data_con
823 is_infix = dataConIsInfix data_con
824 is_record = length labels > 0
825 as_needed = take con_arity as_RDRs
826 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
827 (read_a1:read_a2:_) = read_args
829 prefix_prec = appPrecedence
830 infix_prec = getPrecedence get_fixity dc_nm
831 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
832 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
834 ------------------------------------------------------------------------
836 ------------------------------------------------------------------------
837 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
838 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
839 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
840 con_app con as = nlHsVarApps (getRdrName con) as -- con as
841 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
843 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
844 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
845 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
847 data_con_str con = occNameString (getOccName con)
849 read_punc c = bindLex (punc_pat c)
851 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
852 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
854 read_field lbl a = read_lbl lbl ++
856 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
858 -- When reading field labels we might encounter
863 read_lbl lbl | isSym lbl_str
865 bindLex (symbol_pat lbl_str),
868 = [bindLex (ident_pat lbl_str)]
870 lbl_str = occNameString (getOccName lbl)
874 %************************************************************************
878 %************************************************************************
884 data Tree a = Leaf a | Tree a :^: Tree a
886 instance (Show a) => Show (Tree a) where
888 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
890 showStr = showString "Leaf " . showsPrec (app_prec+1) m
892 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
894 showStr = showsPrec (up_prec+1) u .
896 showsPrec (up_prec+1) v
897 -- Note: right-associativity of :^: ignored
899 up_prec = 5 -- Precedence of :^:
900 app_prec = 10 -- Application has precedence one more than
901 -- the most tightly-binding operator
904 gen_Show_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
906 gen_Show_binds get_fixity tycon
907 = (listToBag [shows_prec, show_list], [])
909 tycon_loc = getSrcSpan tycon
910 -----------------------------------------------------------------------
911 show_list = mkVarBind tycon_loc showList_RDR
912 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
913 -----------------------------------------------------------------------
914 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
917 | nullary_con = -- skip the showParen junk...
918 ASSERT(null bs_needed)
919 ([nlWildPat, con_pat], mk_showString_app con_str)
922 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
923 (nlHsPar (nested_compose_Expr show_thingies)))
925 data_con_RDR = getRdrName data_con
926 con_arity = dataConSourceArity data_con
927 bs_needed = take con_arity bs_RDRs
928 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
929 con_pat = nlConVarPat data_con_RDR bs_needed
930 nullary_con = con_arity == 0
931 labels = dataConFieldLabels data_con
932 lab_fields = length labels
933 record_syntax = lab_fields > 0
935 dc_nm = getName data_con
936 dc_occ_nm = getOccName data_con
937 con_str = occNameString dc_occ_nm
938 op_con_str = wrapOpParens con_str
939 backquote_str = wrapOpBackquotes con_str
942 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
943 | record_syntax = mk_showString_app (op_con_str ++ " {") :
944 show_record_args ++ [mk_showString_app "}"]
945 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
947 show_label l = mk_showString_app (nm ++ " = ")
948 -- Note the spaces around the "=" sign. If we don't have them
949 -- then we get Foo { x=-1 } and the "=-" parses as a single
950 -- lexeme. Only the space after the '=' is necessary, but
951 -- it seems tidier to have them both sides.
953 occ_nm = getOccName l
954 nm = wrapOpParens (occNameString occ_nm)
956 show_args = zipWith show_arg bs_needed arg_tys
957 (show_arg1:show_arg2:_) = show_args
958 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
960 -- Assumption for record syntax: no of fields == no of labelled fields
961 -- (and in same order)
962 show_record_args = concat $
963 intersperse [mk_showString_app ", "] $
964 [ [show_label lbl, arg]
965 | (lbl,arg) <- zipEqual "gen_Show_binds"
968 -- Generates (showsPrec p x) for argument x, but it also boxes
969 -- the argument first if necessary. Note that this prints unboxed
970 -- things without any '#' decorations; could change that if need be
971 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
972 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
975 is_infix = dataConIsInfix data_con
976 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
977 arg_prec | record_syntax = 0 -- Record fields don't need parens
978 | otherwise = con_prec_plus_one
980 wrapOpParens :: String -> String
981 wrapOpParens s | isSym s = '(' : s ++ ")"
984 wrapOpBackquotes :: String -> String
985 wrapOpBackquotes s | isSym s = s
986 | otherwise = '`' : s ++ "`"
988 isSym :: String -> Bool
990 isSym (c:cs) = startsVarSym c || startsConSym c
992 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
996 getPrec :: Bool -> FixityEnv -> Name -> Integer
997 getPrec is_infix get_fixity nm
998 | not is_infix = appPrecedence
999 | otherwise = getPrecedence get_fixity nm
1001 appPrecedence :: Integer
1002 appPrecedence = fromIntegral maxPrecedence + 1
1003 -- One more than the precedence of the most
1004 -- tightly-binding operator
1006 getPrecedence :: FixityEnv -> Name -> Integer
1007 getPrecedence get_fixity nm
1008 = case lookupFixity get_fixity nm of
1009 Fixity x _assoc -> fromIntegral x
1010 -- NB: the Report says that associativity is not taken
1011 -- into account for either Read or Show; hence we
1012 -- ignore associativity here
1016 %************************************************************************
1018 \subsection{Typeable}
1020 %************************************************************************
1028 instance Typeable2 T where
1029 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1031 We are passed the Typeable2 class as well as T
1034 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1035 gen_Typeable_binds tycon
1037 mk_easy_FunBind tycon_loc
1038 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1040 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1042 tycon_loc = getSrcSpan tycon
1043 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1045 mk_typeOf_RDR :: TyCon -> RdrName
1046 -- Use the arity of the TyCon to make the right typeOfn function
1047 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1049 arity = tyConArity tycon
1050 suffix | arity == 0 = ""
1051 | otherwise = show arity
1056 %************************************************************************
1060 %************************************************************************
1064 data T a b = T1 a b | T2
1068 $cT1 = mkDataCon $dT "T1" Prefix
1069 $cT2 = mkDataCon $dT "T2" Prefix
1070 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1071 -- the [] is for field labels.
1073 instance (Data a, Data b) => Data (T a b) where
1074 gfoldl k z (T1 a b) = z T `k` a `k` b
1075 gfoldl k z T2 = z T2
1076 -- ToDo: add gmapT,Q,M, gfoldr
1078 gunfold k z c = case conIndex c of
1079 I# 1# -> k (k (z T1))
1082 toConstr (T1 _ _) = $cT1
1088 gen_Data_binds :: FixityEnv
1090 -> (LHsBinds RdrName, -- The method bindings
1091 DerivAuxBinds) -- Auxiliary bindings
1092 gen_Data_binds fix_env tycon
1093 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1094 -- Auxiliary definitions: the data type and constructors
1095 DerivAuxBind datatype_bind : map mk_con_bind data_cons)
1097 tycon_loc = getSrcSpan tycon
1098 tycon_name = tyConName tycon
1099 data_cons = tyConDataCons tycon
1100 n_cons = length data_cons
1101 one_constr = n_cons == 1
1104 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1105 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1106 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1109 con_name = getRdrName con
1110 as_needed = take (dataConSourceArity con) as_RDRs
1111 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1113 ------------ gunfold
1114 gunfold_bind = mk_FunBind tycon_loc
1116 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1120 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1121 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1122 (map gunfold_alt data_cons)
1124 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1125 mk_unfold_rhs dc = foldr nlHsApp
1126 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1127 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1129 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1130 -- redundant test, and annoying warning
1131 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1132 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1136 ------------ toConstr
1137 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1138 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1140 ------------ dataTypeOf
1141 dataTypeOf_bind = mk_easy_FunBind
1145 (nlHsVar data_type_name)
1149 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1150 datatype_bind = mkVarBind
1153 ( nlHsVar mkDataType_RDR
1154 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1155 `nlHsApp` nlList constrs
1157 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1160 ------------ $cT1 etc
1161 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1162 mk_con_bind dc = DerivAuxBind $
1166 (nlHsApps mkConstr_RDR (constr_args dc))
1168 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1169 nlHsVar data_type_name, -- DataType
1170 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1171 nlList labels, -- Field labels
1172 nlHsVar fixity] -- Fixity
1174 labels = map (nlHsLit . mkHsString . getOccString)
1175 (dataConFieldLabels dc)
1176 dc_occ = getOccName dc
1177 is_infix = isDataSymOcc dc_occ
1178 fixity | is_infix = infix_RDR
1179 | otherwise = prefix_RDR
1181 gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl")
1182 gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold")
1183 toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr")
1184 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1185 mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
1186 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1187 conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
1188 prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
1189 infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
1192 %************************************************************************
1194 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1196 %************************************************************************
1201 con2tag_Foo :: Foo ... -> Int#
1202 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1203 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1206 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1210 genAuxBind :: DerivAuxBind -> LHsBind RdrName
1212 genAuxBind (DerivAuxBind bind)
1215 genAuxBind (GenCon2Tag tycon)
1216 | lots_of_constructors
1217 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1220 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1223 rdr_name = con2tag_RDR tycon
1224 tycon_loc = getSrcSpan tycon
1226 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1227 -- We can't use gerRdrName because that makes an Exact RdrName
1228 -- and we can't put them in the LocalRdrEnv
1230 -- Give a signature to the bound variable, so
1231 -- that the case expression generated by getTag is
1232 -- monomorphic. In the push-enter model we get better code.
1233 get_tag_rhs = noLoc $ ExprWithTySig
1234 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1235 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1236 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1238 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1240 nlHsTyVar (getRdrName intPrimTyCon)
1242 lots_of_constructors = tyConFamilySize tycon > 8
1243 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1244 -- but we don't do vectored returns any more.
1246 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1247 mk_stuff con = ([nlWildConPat con],
1248 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1250 genAuxBind (GenTag2Con tycon)
1251 = mk_FunBind (getSrcSpan tycon) rdr_name
1252 [([nlConVarPat intDataCon_RDR [a_RDR]],
1253 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1254 (nlHsTyVar (getRdrName tycon))))]
1256 rdr_name = tag2con_RDR tycon
1258 genAuxBind (GenMaxTag tycon)
1259 = mkVarBind (getSrcSpan tycon) rdr_name
1260 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1262 rdr_name = maxtag_RDR tycon
1263 max_tag = case (tyConDataCons tycon) of
1264 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1267 %************************************************************************
1269 \subsection{Utility bits for generating bindings}
1271 %************************************************************************
1274 ToDo: Better SrcLocs.
1278 LHsExpr RdrName -- What to do for equality
1279 -> LHsExpr RdrName -> LHsExpr RdrName
1281 careful_compare_Case :: -- checks for primitive types...
1282 TyCon -- The tycon we are deriving for
1284 -> LHsExpr RdrName -- What to do for equality
1285 -> LHsExpr RdrName -> LHsExpr RdrName
1288 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1289 -- Was: compare_gen_Case cmp_eq_RDR
1291 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1292 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1293 compare_gen_Case eq a b -- General case
1294 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1295 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1296 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1297 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1299 careful_compare_Case tycon ty eq a b
1300 | not (isUnLiftedType ty)
1301 = compare_gen_Case eq a b
1302 | otherwise -- We have to do something special for primitive things...
1303 = nlHsIf (genOpApp a relevant_eq_op b)
1305 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1307 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1308 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1311 box_if_necy :: String -- The class involved
1312 -> TyCon -- The tycon involved
1313 -> LHsExpr RdrName -- The argument
1314 -> Type -- The argument type
1315 -> LHsExpr RdrName -- Boxed version of the arg
1316 box_if_necy cls_str tycon arg arg_ty
1317 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1320 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1322 assoc_ty_id :: String -- The class involved
1323 -> TyCon -- The tycon involved
1324 -> [(Type,a)] -- The table
1326 -> a -- The result of the lookup
1327 assoc_ty_id cls_str tycon tbl ty
1328 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1329 text "for primitive type" <+> ppr ty)
1330 | otherwise = head res
1332 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1334 eq_op_tbl :: [(Type, PrimOp)]
1336 [(charPrimTy, CharEqOp)
1337 ,(intPrimTy, IntEqOp)
1338 ,(wordPrimTy, WordEqOp)
1339 ,(addrPrimTy, AddrEqOp)
1340 ,(floatPrimTy, FloatEqOp)
1341 ,(doublePrimTy, DoubleEqOp)
1344 lt_op_tbl :: [(Type, PrimOp)]
1346 [(charPrimTy, CharLtOp)
1347 ,(intPrimTy, IntLtOp)
1348 ,(wordPrimTy, WordLtOp)
1349 ,(addrPrimTy, AddrLtOp)
1350 ,(floatPrimTy, FloatLtOp)
1351 ,(doublePrimTy, DoubleLtOp)
1355 [(charPrimTy, getRdrName charDataCon)
1356 ,(intPrimTy, getRdrName intDataCon)
1357 ,(wordPrimTy, wordDataCon_RDR)
1358 ,(floatPrimTy, getRdrName floatDataCon)
1359 ,(doublePrimTy, getRdrName doubleDataCon)
1362 -----------------------------------------------------------------------
1364 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1365 and_Expr a b = genOpApp a and_RDR b
1367 -----------------------------------------------------------------------
1369 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1370 eq_Expr tycon ty a b = genOpApp a eq_op b
1373 | not (isUnLiftedType ty) = eq_RDR
1374 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1375 -- we have to do something special for primitive things...
1379 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1380 untag_Expr tycon [] expr = expr
1381 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1382 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1383 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1385 cmp_tags_Expr :: RdrName -- Comparison op
1386 -> RdrName -> RdrName -- Things to compare
1387 -> LHsExpr RdrName -- What to return if true
1388 -> LHsExpr RdrName -- What to return if false
1391 cmp_tags_Expr op a b true_case false_case
1392 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1395 :: LHsExpr RdrName -> LHsExpr RdrName
1397 enum_from_then_to_Expr
1398 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1401 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1402 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1405 :: LHsExpr RdrName -> LHsExpr RdrName
1408 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1410 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1412 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1413 nested_compose_Expr [e] = parenify e
1414 nested_compose_Expr (e:es)
1415 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1417 -- impossible_Expr is used in case RHSs that should never happen.
1418 -- We generate these to keep the desugarer from complaining that they *might* happen!
1419 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1421 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1422 -- method. It is currently only used by Enum.{succ,pred}
1423 illegal_Expr meth tp msg =
1424 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1426 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1427 -- to include the value of a_RDR in the error string.
1428 illegal_toEnum_tag tp maxtag =
1429 nlHsApp (nlHsVar error_RDR)
1430 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1431 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1432 (nlHsApp (nlHsApp (nlHsApp
1433 (nlHsVar showsPrec_RDR)
1437 (nlHsVar append_RDR)
1438 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1439 (nlHsApp (nlHsApp (nlHsApp
1440 (nlHsVar showsPrec_RDR)
1443 (nlHsLit (mkHsString ")"))))))
1445 parenify e@(L _ (HsVar _)) = e
1446 parenify e = mkHsPar e
1448 -- genOpApp wraps brackets round the operator application, so that the
1449 -- renamer won't subsequently try to re-associate it.
1450 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1454 a_RDR = mkVarUnqual FSLIT("a")
1455 b_RDR = mkVarUnqual FSLIT("b")
1456 c_RDR = mkVarUnqual FSLIT("c")
1457 d_RDR = mkVarUnqual FSLIT("d")
1458 k_RDR = mkVarUnqual FSLIT("k")
1459 z_RDR = mkVarUnqual FSLIT("z")
1460 ah_RDR = mkVarUnqual FSLIT("a#")
1461 bh_RDR = mkVarUnqual FSLIT("b#")
1462 ch_RDR = mkVarUnqual FSLIT("c#")
1463 dh_RDR = mkVarUnqual FSLIT("d#")
1464 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1466 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1467 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1468 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1470 a_Expr = nlHsVar a_RDR
1471 b_Expr = nlHsVar b_RDR
1472 c_Expr = nlHsVar c_RDR
1473 ltTag_Expr = nlHsVar ltTag_RDR
1474 eqTag_Expr = nlHsVar eqTag_RDR
1475 gtTag_Expr = nlHsVar gtTag_RDR
1476 false_Expr = nlHsVar false_RDR
1477 true_Expr = nlHsVar true_RDR
1479 a_Pat = nlVarPat a_RDR
1480 b_Pat = nlVarPat b_RDR
1481 c_Pat = nlVarPat c_RDR
1482 d_Pat = nlVarPat d_RDR
1483 k_Pat = nlVarPat k_RDR
1484 z_Pat = nlVarPat z_RDR
1486 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1487 -- Generates Orig s RdrName, for the binding positions
1488 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1489 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1490 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1492 mk_tc_deriv_name tycon str
1493 = mkDerivedRdrName tc_name mk_occ
1495 tc_name = tyConName tycon
1496 mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1498 new_str = str ++ occNameString tc_occ ++ "#"
1501 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1502 PrelNames, so PrelNames can't import PrimOp.
1505 primOpRdrName op = getRdrName (primOpId op)
1507 minusInt_RDR = primOpRdrName IntSubOp
1508 eqInt_RDR = primOpRdrName IntEqOp
1509 ltInt_RDR = primOpRdrName IntLtOp
1510 geInt_RDR = primOpRdrName IntGeOp
1511 leInt_RDR = primOpRdrName IntLeOp
1512 tagToEnum_RDR = primOpRdrName TagToEnumOp
1514 error_RDR = getRdrName eRROR_ID