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 | Just (con, prim_tc) <- primWrapperType_maybe tycon
309 = gen_PrimOrd_binds con prim_tc
312 = (unitBag compare, aux_binds)
313 -- `AndMonoBinds` compare
314 -- The default declaration in PrelBase handles this
316 tycon_loc = getSrcSpan tycon
317 --------------------------------------------------------------------
318 aux_binds | single_con_type = []
319 | otherwise = [GenCon2Tag tycon]
321 compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
322 compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
323 cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
326 | single_con_type = cmp_eq_Expr a_Expr b_Expr
328 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
329 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
330 (cmp_eq_Expr a_Expr b_Expr) -- True case
331 -- False case; they aren't equal
332 -- So we need to do a less-than comparison on the tags
333 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
335 tycon_data_cons = tyConDataCons tycon
336 single_con_type = isSingleton tycon_data_cons
337 (nullary_cons, nonnullary_cons)
338 | isNewTyCon tycon = ([], tyConDataCons tycon)
339 | otherwise = partition isNullarySrcDataCon tycon_data_cons
341 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
343 | isEnumerationTyCon tycon
344 -- We know the tags are equal, so if it's an enumeration TyCon,
345 -- then there is nothing left to do
346 -- Catch this specially to avoid warnings
347 -- about overlapping patterns from the desugarer,
348 -- and to avoid unnecessary pattern-matching
349 = [([nlWildPat,nlWildPat], eqTag_Expr)]
351 = map pats_etc nonnullary_cons ++
352 (if single_con_type then -- Omit wildcards when there's just one
353 [] -- constructor, to silence desugarer
355 [([nlWildPat, nlWildPat], default_rhs)])
357 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
358 -- inexhaustive patterns
359 | otherwise = eqTag_Expr -- Some nullary constructors;
360 -- Tags are equal, no args => return EQ
362 = ([con1_pat, con2_pat],
363 nested_compare_expr tys_needed as_needed bs_needed)
365 con1_pat = nlConVarPat data_con_RDR as_needed
366 con2_pat = nlConVarPat data_con_RDR bs_needed
368 data_con_RDR = getRdrName data_con
369 con_arity = length tys_needed
370 as_needed = take con_arity as_RDRs
371 bs_needed = take con_arity bs_RDRs
372 tys_needed = dataConOrigArgTys data_con
374 nested_compare_expr [ty] [a] [b]
375 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
377 nested_compare_expr (ty:tys) (a:as) (b:bs)
378 = let eq_expr = nested_compare_expr tys as bs
379 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
381 nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
384 Note [Comparision of primitive types]
385 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
386 The general plan does not work well for data types like
387 data T = MkT Int# deriving( Ord )
388 The general plan defines the 'compare' method, gets (<) etc from it. But
389 that means we get silly code like:
391 (>) (I# x) (I# y) = case <# x y of
393 False -> case ==# x y of
396 We would prefer to use the (>#) primop. See also Trac #2130
400 gen_PrimOrd_binds :: DataCon -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
401 -- See Note [Comparison of primitive types]
402 gen_PrimOrd_binds data_con prim_tc
403 = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op,
404 mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
406 mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR
407 [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
408 con_RDR = getRdrName data_con
409 apat = nlConVarPat con_RDR [a_RDR]
410 bpat = nlConVarPat con_RDR [b_RDR]
412 (lt_op, le_op, ge_op, gt_op)
413 | prim_tc == charPrimTyCon = (CharLtOp, CharLeOp, CharGeOp, CharGtOp)
414 | prim_tc == intPrimTyCon = (IntLtOp, IntLeOp, IntGeOp, IntGtOp)
415 | prim_tc == wordPrimTyCon = (WordLtOp, WordLeOp, WordGeOp, WordGtOp)
416 | prim_tc == addrPrimTyCon = (AddrLtOp, AddrLeOp, AddrGeOp, AddrGtOp)
417 | prim_tc == floatPrimTyCon = (FloatLtOp, FloatLeOp, FloatGeOp, FloatGtOp)
418 | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
419 | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
422 primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
423 -- True of data types that are wrappers around prmitive types
424 -- data T = MkT Word#
425 -- For these we want to generate all the (<), (<=) etc operations individually
426 primWrapperType_maybe tc
427 | [con] <- tyConDataCons tc
428 , [ty] <- dataConOrigArgTys con
429 , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
430 , isPrimTyCon prim_tc
431 = Just (con, prim_tc)
436 %************************************************************************
440 %************************************************************************
442 @Enum@ can only be derived for enumeration types. For a type
444 data Foo ... = N1 | N2 | ... | Nn
447 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
448 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
451 instance ... Enum (Foo ...) where
452 succ x = toEnum (1 + fromEnum x)
453 pred x = toEnum (fromEnum x - 1)
455 toEnum i = tag2con_Foo i
457 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
461 = case con2tag_Foo a of
462 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
465 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
469 = case con2tag_Foo a of { a# ->
470 case con2tag_Foo b of { b# ->
471 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
475 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
478 gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
480 = (method_binds, aux_binds)
482 method_binds = listToBag [
490 aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
492 tycon_loc = getSrcSpan tycon
493 occ_nm = getOccString tycon
496 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
497 untag_Expr tycon [(a_RDR, ah_RDR)] $
498 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
499 nlHsVarApps intDataCon_RDR [ah_RDR]])
500 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
501 (nlHsApp (nlHsVar (tag2con_RDR tycon))
502 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
506 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
507 untag_Expr tycon [(a_RDR, ah_RDR)] $
508 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
509 nlHsVarApps intDataCon_RDR [ah_RDR]])
510 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
511 (nlHsApp (nlHsVar (tag2con_RDR tycon))
512 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
513 nlHsLit (HsInt (-1))]))
516 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
517 nlHsIf (nlHsApps and_RDR
518 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
519 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
520 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
521 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
524 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
525 untag_Expr tycon [(a_RDR, ah_RDR)] $
527 [nlHsVar (tag2con_RDR tycon),
528 nlHsPar (enum_from_to_Expr
529 (nlHsVarApps intDataCon_RDR [ah_RDR])
530 (nlHsVar (maxtag_RDR tycon)))]
533 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
534 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
535 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
536 nlHsPar (enum_from_then_to_Expr
537 (nlHsVarApps intDataCon_RDR [ah_RDR])
538 (nlHsVarApps intDataCon_RDR [bh_RDR])
539 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
540 nlHsVarApps intDataCon_RDR [bh_RDR]])
542 (nlHsVar (maxtag_RDR tycon))
546 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
547 untag_Expr tycon [(a_RDR, ah_RDR)] $
548 (nlHsVarApps intDataCon_RDR [ah_RDR])
551 %************************************************************************
555 %************************************************************************
558 gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
559 gen_Bounded_binds tycon
560 | isEnumerationTyCon tycon
561 = (listToBag [ min_bound_enum, max_bound_enum ], [])
563 = ASSERT(isSingleton data_cons)
564 (listToBag [ min_bound_1con, max_bound_1con ], [])
566 data_cons = tyConDataCons tycon
567 tycon_loc = getSrcSpan tycon
569 ----- enum-flavored: ---------------------------
570 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
571 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
573 data_con_1 = head data_cons
574 data_con_N = last data_cons
575 data_con_1_RDR = getRdrName data_con_1
576 data_con_N_RDR = getRdrName data_con_N
578 ----- single-constructor-flavored: -------------
579 arity = dataConSourceArity data_con_1
581 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
582 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
583 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
584 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
587 %************************************************************************
591 %************************************************************************
593 Deriving @Ix@ is only possible for enumeration types and
594 single-constructor types. We deal with them in turn.
596 For an enumeration type, e.g.,
598 data Foo ... = N1 | N2 | ... | Nn
600 things go not too differently from @Enum@:
602 instance ... Ix (Foo ...) where
604 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
608 = case (con2tag_Foo a) of { a# ->
609 case (con2tag_Foo b) of { b# ->
610 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
613 -- Generate code for unsafeIndex, becuase using index leads
614 -- to lots of redundant range tests
615 unsafeIndex c@(a, b) d
616 = case (con2tag_Foo d -# con2tag_Foo a) of
621 p_tag = con2tag_Foo c
623 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
627 = case (con2tag_Foo a) of { a_tag ->
628 case (con2tag_Foo b) of { b_tag ->
629 case (con2tag_Foo c) of { c_tag ->
630 if (c_tag >=# a_tag) then
636 (modulo suitable case-ification to handle the unlifted tags)
638 For a single-constructor type (NB: this includes all tuples), e.g.,
640 data Foo ... = MkFoo a b Int Double c c
642 we follow the scheme given in Figure~19 of the Haskell~1.2 report
646 gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
649 | isEnumerationTyCon tycon
650 = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
652 = (single_con_ixes, [GenCon2Tag tycon])
654 tycon_loc = getSrcSpan tycon
656 --------------------------------------------------------------
657 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
660 = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
661 untag_Expr tycon [(a_RDR, ah_RDR)] $
662 untag_Expr tycon [(b_RDR, bh_RDR)] $
663 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
664 nlHsPar (enum_from_to_Expr
665 (nlHsVarApps intDataCon_RDR [ah_RDR])
666 (nlHsVarApps intDataCon_RDR [bh_RDR]))
669 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
670 [noLoc (AsPat (noLoc c_RDR)
671 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
673 untag_Expr tycon [(a_RDR, ah_RDR)] (
674 untag_Expr tycon [(d_RDR, dh_RDR)] (
676 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
679 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
680 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
685 = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
686 untag_Expr tycon [(a_RDR, ah_RDR)] (
687 untag_Expr tycon [(b_RDR, bh_RDR)] (
688 untag_Expr tycon [(c_RDR, ch_RDR)] (
689 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
690 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
695 --------------------------------------------------------------
697 = listToBag [single_con_range, single_con_index, single_con_inRange]
700 = case maybeTyConSingleCon tycon of -- just checking...
701 Nothing -> panic "get_Ix_binds"
702 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
703 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
706 con_arity = dataConSourceArity data_con
707 data_con_RDR = getRdrName data_con
709 as_needed = take con_arity as_RDRs
710 bs_needed = take con_arity bs_RDRs
711 cs_needed = take con_arity cs_RDRs
713 con_pat xs = nlConVarPat data_con_RDR xs
714 con_expr = nlHsVarApps data_con_RDR cs_needed
716 --------------------------------------------------------------
718 = mk_easy_FunBind tycon_loc range_RDR
719 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
720 nlHsDo ListComp stmts con_expr
722 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
724 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
725 (nlHsApp (nlHsVar range_RDR)
726 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
730 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
731 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
733 -- We need to reverse the order we consider the components in
735 -- range (l,u) !! index (l,u) i == i -- when i is in range
736 -- (from http://haskell.org/onlinereport/ix.html) holds.
737 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
739 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
740 mk_index [] = nlHsIntLit 0
741 mk_index [(l,u,i)] = mk_one l u i
742 mk_index ((l,u,i) : rest)
747 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
748 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
749 ) times_RDR (mk_index rest)
752 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
756 = mk_easy_FunBind tycon_loc inRange_RDR
757 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
759 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
761 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
765 %************************************************************************
769 %************************************************************************
779 instance Read T where
783 do x <- ReadP.step Read.readPrec
784 Symbol "%%" <- Lex.lex
785 y <- ReadP.step Read.readPrec
789 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
790 -- Record construction binds even more tightly than application
791 do Ident "T1" <- Lex.lex
793 Ident "f1" <- Lex.lex
795 x <- ReadP.reset Read.readPrec
797 return (T1 { f1 = x }))
800 do Ident "T2" <- Lex.lexP
801 x <- ReadP.step Read.readPrec
805 readListPrec = readListPrecDefault
806 readList = readListDefault
810 gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
812 gen_Read_binds get_fixity tycon
813 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
815 -----------------------------------------------------------------------
817 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
820 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
821 -----------------------------------------------------------------------
823 loc = getSrcSpan tycon
824 data_cons = tyConDataCons tycon
825 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
827 read_prec = mkVarBind loc readPrec_RDR
828 (nlHsApp (nlHsVar parens_RDR) read_cons)
830 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
831 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
834 = case nullary_cons of
836 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
837 (result_expr con [])]
838 _ -> [nlHsApp (nlHsVar choose_RDR)
839 (nlList (map mk_pair nullary_cons))]
841 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
845 read_non_nullary_con data_con
846 | is_infix = mk_parser infix_prec infix_stmts body
847 | is_record = mk_parser record_prec record_stmts body
848 -- Using these two lines instead allows the derived
849 -- read for infix and record bindings to read the prefix form
850 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
851 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
852 | otherwise = prefix_parser
854 body = result_expr data_con as_needed
855 con_str = data_con_str data_con
857 prefix_parser = mk_parser prefix_prec prefix_stmts body
858 prefix_stmts -- T a b c
859 = (if not (isSym con_str) then
860 [bindLex (ident_pat con_str)]
861 else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
864 infix_stmts -- a %% b, or a `T` b
867 then [bindLex (symbol_pat con_str)]
868 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
871 record_stmts -- T { f1 = a, f2 = b }
872 = [bindLex (ident_pat (wrapOpParens con_str)),
874 ++ concat (intersperse [read_punc ","] field_stmts)
877 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
879 con_arity = dataConSourceArity data_con
880 labels = dataConFieldLabels data_con
881 dc_nm = getName data_con
882 is_infix = dataConIsInfix data_con
883 is_record = length labels > 0
884 as_needed = take con_arity as_RDRs
885 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
886 (read_a1:read_a2:_) = read_args
888 prefix_prec = appPrecedence
889 infix_prec = getPrecedence get_fixity dc_nm
890 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
891 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
893 ------------------------------------------------------------------------
895 ------------------------------------------------------------------------
896 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
897 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
898 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
899 con_app con as = nlHsVarApps (getRdrName con) as -- con as
900 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
902 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
903 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
904 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
906 data_con_str con = occNameString (getOccName con)
908 read_punc c = bindLex (punc_pat c)
910 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
911 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
913 read_field lbl a = read_lbl lbl ++
915 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
917 -- When reading field labels we might encounter
922 read_lbl lbl | isSym lbl_str
924 bindLex (symbol_pat lbl_str),
927 = [bindLex (ident_pat lbl_str)]
929 lbl_str = occNameString (getOccName lbl)
933 %************************************************************************
937 %************************************************************************
943 data Tree a = Leaf a | Tree a :^: Tree a
945 instance (Show a) => Show (Tree a) where
947 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
949 showStr = showString "Leaf " . showsPrec (app_prec+1) m
951 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
953 showStr = showsPrec (up_prec+1) u .
955 showsPrec (up_prec+1) v
956 -- Note: right-associativity of :^: ignored
958 up_prec = 5 -- Precedence of :^:
959 app_prec = 10 -- Application has precedence one more than
960 -- the most tightly-binding operator
963 gen_Show_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
965 gen_Show_binds get_fixity tycon
966 = (listToBag [shows_prec, show_list], [])
968 tycon_loc = getSrcSpan tycon
969 -----------------------------------------------------------------------
970 show_list = mkVarBind tycon_loc showList_RDR
971 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
972 -----------------------------------------------------------------------
973 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
976 | nullary_con = -- skip the showParen junk...
977 ASSERT(null bs_needed)
978 ([nlWildPat, con_pat], mk_showString_app con_str)
981 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
982 (nlHsPar (nested_compose_Expr show_thingies)))
984 data_con_RDR = getRdrName data_con
985 con_arity = dataConSourceArity data_con
986 bs_needed = take con_arity bs_RDRs
987 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
988 con_pat = nlConVarPat data_con_RDR bs_needed
989 nullary_con = con_arity == 0
990 labels = dataConFieldLabels data_con
991 lab_fields = length labels
992 record_syntax = lab_fields > 0
994 dc_nm = getName data_con
995 dc_occ_nm = getOccName data_con
996 con_str = occNameString dc_occ_nm
997 op_con_str = wrapOpParens con_str
998 backquote_str = wrapOpBackquotes con_str
1001 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1002 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1003 show_record_args ++ [mk_showString_app "}"]
1004 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1006 show_label l = mk_showString_app (nm ++ " = ")
1007 -- Note the spaces around the "=" sign. If we don't have them
1008 -- then we get Foo { x=-1 } and the "=-" parses as a single
1009 -- lexeme. Only the space after the '=' is necessary, but
1010 -- it seems tidier to have them both sides.
1012 occ_nm = getOccName l
1013 nm = wrapOpParens (occNameString occ_nm)
1015 show_args = zipWith show_arg bs_needed arg_tys
1016 (show_arg1:show_arg2:_) = show_args
1017 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1019 -- Assumption for record syntax: no of fields == no of labelled fields
1020 -- (and in same order)
1021 show_record_args = concat $
1022 intersperse [mk_showString_app ", "] $
1023 [ [show_label lbl, arg]
1024 | (lbl,arg) <- zipEqual "gen_Show_binds"
1027 -- Generates (showsPrec p x) for argument x, but it also boxes
1028 -- the argument first if necessary. Note that this prints unboxed
1029 -- things without any '#' decorations; could change that if need be
1030 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1031 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1034 is_infix = dataConIsInfix data_con
1035 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1036 arg_prec | record_syntax = 0 -- Record fields don't need parens
1037 | otherwise = con_prec_plus_one
1039 wrapOpParens :: String -> String
1040 wrapOpParens s | isSym s = '(' : s ++ ")"
1043 wrapOpBackquotes :: String -> String
1044 wrapOpBackquotes s | isSym s = s
1045 | otherwise = '`' : s ++ "`"
1047 isSym :: String -> Bool
1049 isSym (c:cs) = startsVarSym c || startsConSym c
1051 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1055 getPrec :: Bool -> FixityEnv -> Name -> Integer
1056 getPrec is_infix get_fixity nm
1057 | not is_infix = appPrecedence
1058 | otherwise = getPrecedence get_fixity nm
1060 appPrecedence :: Integer
1061 appPrecedence = fromIntegral maxPrecedence + 1
1062 -- One more than the precedence of the most
1063 -- tightly-binding operator
1065 getPrecedence :: FixityEnv -> Name -> Integer
1066 getPrecedence get_fixity nm
1067 = case lookupFixity get_fixity nm of
1068 Fixity x _assoc -> fromIntegral x
1069 -- NB: the Report says that associativity is not taken
1070 -- into account for either Read or Show; hence we
1071 -- ignore associativity here
1075 %************************************************************************
1077 \subsection{Typeable}
1079 %************************************************************************
1087 instance Typeable2 T where
1088 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1090 We are passed the Typeable2 class as well as T
1093 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1094 gen_Typeable_binds tycon
1096 mk_easy_FunBind tycon_loc
1097 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1099 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1101 tycon_loc = getSrcSpan tycon
1102 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1104 mk_typeOf_RDR :: TyCon -> RdrName
1105 -- Use the arity of the TyCon to make the right typeOfn function
1106 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1108 arity = tyConArity tycon
1109 suffix | arity == 0 = ""
1110 | otherwise = show arity
1115 %************************************************************************
1119 %************************************************************************
1123 data T a b = T1 a b | T2
1127 $cT1 = mkDataCon $dT "T1" Prefix
1128 $cT2 = mkDataCon $dT "T2" Prefix
1129 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1130 -- the [] is for field labels.
1132 instance (Data a, Data b) => Data (T a b) where
1133 gfoldl k z (T1 a b) = z T `k` a `k` b
1134 gfoldl k z T2 = z T2
1135 -- ToDo: add gmapT,Q,M, gfoldr
1137 gunfold k z c = case conIndex c of
1138 I# 1# -> k (k (z T1))
1141 toConstr (T1 _ _) = $cT1
1147 gen_Data_binds :: FixityEnv
1149 -> (LHsBinds RdrName, -- The method bindings
1150 DerivAuxBinds) -- Auxiliary bindings
1151 gen_Data_binds fix_env tycon
1152 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1153 -- Auxiliary definitions: the data type and constructors
1154 DerivAuxBind datatype_bind : map mk_con_bind data_cons)
1156 tycon_loc = getSrcSpan tycon
1157 tycon_name = tyConName tycon
1158 data_cons = tyConDataCons tycon
1159 n_cons = length data_cons
1160 one_constr = n_cons == 1
1163 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1164 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1165 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1168 con_name = getRdrName con
1169 as_needed = take (dataConSourceArity con) as_RDRs
1170 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1172 ------------ gunfold
1173 gunfold_bind = mk_FunBind tycon_loc
1175 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1179 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1180 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1181 (map gunfold_alt data_cons)
1183 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1184 mk_unfold_rhs dc = foldr nlHsApp
1185 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1186 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1188 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1189 -- redundant test, and annoying warning
1190 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1191 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1195 ------------ toConstr
1196 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1197 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1199 ------------ dataTypeOf
1200 dataTypeOf_bind = mk_easy_FunBind
1204 (nlHsVar data_type_name)
1208 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1209 datatype_bind = mkVarBind
1212 ( nlHsVar mkDataType_RDR
1213 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1214 `nlHsApp` nlList constrs
1216 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1219 ------------ $cT1 etc
1220 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1221 mk_con_bind dc = DerivAuxBind $
1225 (nlHsApps mkConstr_RDR (constr_args dc))
1227 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1228 nlHsVar data_type_name, -- DataType
1229 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1230 nlList labels, -- Field labels
1231 nlHsVar fixity] -- Fixity
1233 labels = map (nlHsLit . mkHsString . getOccString)
1234 (dataConFieldLabels dc)
1235 dc_occ = getOccName dc
1236 is_infix = isDataSymOcc dc_occ
1237 fixity | is_infix = infix_RDR
1238 | otherwise = prefix_RDR
1240 gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl")
1241 gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold")
1242 toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr")
1243 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1244 mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
1245 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1246 conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
1247 prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
1248 infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
1251 %************************************************************************
1253 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1255 %************************************************************************
1260 con2tag_Foo :: Foo ... -> Int#
1261 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1262 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1265 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1269 genAuxBind :: DerivAuxBind -> LHsBind RdrName
1271 genAuxBind (DerivAuxBind bind)
1274 genAuxBind (GenCon2Tag tycon)
1275 | lots_of_constructors
1276 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1279 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1282 rdr_name = con2tag_RDR tycon
1283 tycon_loc = getSrcSpan tycon
1285 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1286 -- We can't use gerRdrName because that makes an Exact RdrName
1287 -- and we can't put them in the LocalRdrEnv
1289 -- Give a signature to the bound variable, so
1290 -- that the case expression generated by getTag is
1291 -- monomorphic. In the push-enter model we get better code.
1292 get_tag_rhs = noLoc $ ExprWithTySig
1293 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1294 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1295 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1297 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1299 nlHsTyVar (getRdrName intPrimTyCon)
1301 lots_of_constructors = tyConFamilySize tycon > 8
1302 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1303 -- but we don't do vectored returns any more.
1305 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1306 mk_stuff con = ([nlWildConPat con],
1307 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1309 genAuxBind (GenTag2Con tycon)
1310 = mk_FunBind (getSrcSpan tycon) rdr_name
1311 [([nlConVarPat intDataCon_RDR [a_RDR]],
1312 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1313 (nlHsTyVar (getRdrName tycon))))]
1315 rdr_name = tag2con_RDR tycon
1317 genAuxBind (GenMaxTag tycon)
1318 = mkVarBind (getSrcSpan tycon) rdr_name
1319 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1321 rdr_name = maxtag_RDR tycon
1322 max_tag = case (tyConDataCons tycon) of
1323 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1326 %************************************************************************
1328 \subsection{Utility bits for generating bindings}
1330 %************************************************************************
1333 ToDo: Better SrcLocs.
1337 LHsExpr RdrName -- What to do for equality
1338 -> LHsExpr RdrName -> LHsExpr RdrName
1340 careful_compare_Case :: -- checks for primitive types...
1341 TyCon -- The tycon we are deriving for
1343 -> LHsExpr RdrName -- What to do for equality
1344 -> LHsExpr RdrName -> LHsExpr RdrName
1347 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1348 -- Was: compare_gen_Case cmp_eq_RDR
1350 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1351 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1352 compare_gen_Case eq a b -- General case
1353 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1354 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1355 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1356 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1358 careful_compare_Case tycon ty eq a b
1359 | not (isUnLiftedType ty)
1360 = compare_gen_Case eq a b
1361 | otherwise -- We have to do something special for primitive things...
1362 = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter
1363 ltTag_Expr -- is true less often, so putting it first would
1364 -- mean more tests (dynamically)
1365 (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1367 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1368 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1371 box_if_necy :: String -- The class involved
1372 -> TyCon -- The tycon involved
1373 -> LHsExpr RdrName -- The argument
1374 -> Type -- The argument type
1375 -> LHsExpr RdrName -- Boxed version of the arg
1376 box_if_necy cls_str tycon arg arg_ty
1377 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1380 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1382 assoc_ty_id :: String -- The class involved
1383 -> TyCon -- The tycon involved
1384 -> [(Type,a)] -- The table
1386 -> a -- The result of the lookup
1387 assoc_ty_id cls_str tycon tbl ty
1388 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1389 text "for primitive type" <+> ppr ty)
1390 | otherwise = head res
1392 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1394 eq_op_tbl :: [(Type, PrimOp)]
1396 [(charPrimTy, CharEqOp)
1397 ,(intPrimTy, IntEqOp)
1398 ,(wordPrimTy, WordEqOp)
1399 ,(addrPrimTy, AddrEqOp)
1400 ,(floatPrimTy, FloatEqOp)
1401 ,(doublePrimTy, DoubleEqOp)
1404 lt_op_tbl :: [(Type, PrimOp)]
1406 [(charPrimTy, CharLtOp)
1407 ,(intPrimTy, IntLtOp)
1408 ,(wordPrimTy, WordLtOp)
1409 ,(addrPrimTy, AddrLtOp)
1410 ,(floatPrimTy, FloatLtOp)
1411 ,(doublePrimTy, DoubleLtOp)
1415 [(charPrimTy, getRdrName charDataCon)
1416 ,(intPrimTy, getRdrName intDataCon)
1417 ,(wordPrimTy, wordDataCon_RDR)
1418 ,(floatPrimTy, getRdrName floatDataCon)
1419 ,(doublePrimTy, getRdrName doubleDataCon)
1422 -----------------------------------------------------------------------
1424 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1425 and_Expr a b = genOpApp a and_RDR b
1427 -----------------------------------------------------------------------
1429 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1430 eq_Expr tycon ty a b = genOpApp a eq_op b
1433 | not (isUnLiftedType ty) = eq_RDR
1434 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1435 -- we have to do something special for primitive things...
1439 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1440 untag_Expr tycon [] expr = expr
1441 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1442 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1443 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1445 cmp_tags_Expr :: RdrName -- Comparison op
1446 -> RdrName -> RdrName -- Things to compare
1447 -> LHsExpr RdrName -- What to return if true
1448 -> LHsExpr RdrName -- What to return if false
1451 cmp_tags_Expr op a b true_case false_case
1452 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1455 :: LHsExpr RdrName -> LHsExpr RdrName
1457 enum_from_then_to_Expr
1458 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1461 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1462 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1465 :: LHsExpr RdrName -> LHsExpr RdrName
1468 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1470 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1472 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1473 nested_compose_Expr [e] = parenify e
1474 nested_compose_Expr (e:es)
1475 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1477 -- impossible_Expr is used in case RHSs that should never happen.
1478 -- We generate these to keep the desugarer from complaining that they *might* happen!
1479 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1481 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1482 -- method. It is currently only used by Enum.{succ,pred}
1483 illegal_Expr meth tp msg =
1484 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1486 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1487 -- to include the value of a_RDR in the error string.
1488 illegal_toEnum_tag tp maxtag =
1489 nlHsApp (nlHsVar error_RDR)
1490 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1491 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1492 (nlHsApp (nlHsApp (nlHsApp
1493 (nlHsVar showsPrec_RDR)
1497 (nlHsVar append_RDR)
1498 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1499 (nlHsApp (nlHsApp (nlHsApp
1500 (nlHsVar showsPrec_RDR)
1503 (nlHsLit (mkHsString ")"))))))
1505 parenify e@(L _ (HsVar _)) = e
1506 parenify e = mkHsPar e
1508 -- genOpApp wraps brackets round the operator application, so that the
1509 -- renamer won't subsequently try to re-associate it.
1510 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1514 a_RDR = mkVarUnqual FSLIT("a")
1515 b_RDR = mkVarUnqual FSLIT("b")
1516 c_RDR = mkVarUnqual FSLIT("c")
1517 d_RDR = mkVarUnqual FSLIT("d")
1518 k_RDR = mkVarUnqual FSLIT("k")
1519 z_RDR = mkVarUnqual FSLIT("z")
1520 ah_RDR = mkVarUnqual FSLIT("a#")
1521 bh_RDR = mkVarUnqual FSLIT("b#")
1522 ch_RDR = mkVarUnqual FSLIT("c#")
1523 dh_RDR = mkVarUnqual FSLIT("d#")
1524 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1526 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1527 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1528 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1530 a_Expr = nlHsVar a_RDR
1531 b_Expr = nlHsVar b_RDR
1532 c_Expr = nlHsVar c_RDR
1533 ltTag_Expr = nlHsVar ltTag_RDR
1534 eqTag_Expr = nlHsVar eqTag_RDR
1535 gtTag_Expr = nlHsVar gtTag_RDR
1536 false_Expr = nlHsVar false_RDR
1537 true_Expr = nlHsVar true_RDR
1539 a_Pat = nlVarPat a_RDR
1540 b_Pat = nlVarPat b_RDR
1541 c_Pat = nlVarPat c_RDR
1542 d_Pat = nlVarPat d_RDR
1543 k_Pat = nlVarPat k_RDR
1544 z_Pat = nlVarPat z_RDR
1546 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1547 -- Generates Orig s RdrName, for the binding positions
1548 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1549 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1550 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1552 mk_tc_deriv_name tycon str
1553 = mkDerivedRdrName tc_name mk_occ
1555 tc_name = tyConName tycon
1556 mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1558 new_str = str ++ occNameString tc_occ ++ "#"
1561 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1562 PrelNames, so PrelNames can't import PrimOp.
1565 primOpRdrName op = getRdrName (primOpId op)
1567 minusInt_RDR = primOpRdrName IntSubOp
1568 eqInt_RDR = primOpRdrName IntEqOp
1569 ltInt_RDR = primOpRdrName IntLtOp
1570 geInt_RDR = primOpRdrName IntGeOp
1571 leInt_RDR = primOpRdrName IntLeOp
1572 tagToEnum_RDR = primOpRdrName TagToEnumOp
1574 error_RDR = getRdrName eRROR_ID