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 DerivAuxBind(..), DerivAuxBinds, isDupAux,
28 con2tag_RDR, tag2con_RDR, maxtag_RDR
31 #include "HsVersions.h"
55 import Data.List ( partition, intersperse )
59 type DerivAuxBinds = [DerivAuxBind]
61 data DerivAuxBind -- Please add these auxiliary top-level bindings
62 = DerivAuxBind (LHsBind RdrName)
63 | GenCon2Tag TyCon -- The con2Tag for given TyCon
64 | GenTag2Con TyCon -- ...ditto tag2Con
65 | GenMaxTag TyCon -- ...and maxTag
67 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
68 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
69 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
70 isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2
75 %************************************************************************
79 %************************************************************************
81 Here are the heuristics for the code we generate for @Eq@:
84 Let's assume we have a data type with some (possibly zero) nullary
85 data constructors and some ordinary, non-nullary ones (the rest,
86 also possibly zero of them). Here's an example, with both \tr{N}ullary
87 and \tr{O}rdinary data cons.
89 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
93 For the ordinary constructors (if any), we emit clauses to do The
97 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
98 (==) (O2 a1) (O2 a2) = a1 == a2
99 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
102 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
103 \tr{a2} are \tr{Float#}s, then we have to generate
105 case (a1 `eqFloat#` a2) of
108 for that particular test.
111 If there are any nullary constructors, we emit a catch-all clause of
115 (==) a b = case (con2tag_Foo a) of { a# ->
116 case (con2tag_Foo b) of { b# ->
117 case (a# ==# b#) of {
122 If there aren't any nullary constructors, we emit a simpler
129 For the @(/=)@ method, we normally just use the default method.
131 If the type is an enumeration type, we could/may/should? generate
132 special code that calls @con2tag_Foo@, much like for @(==)@ shown
136 We thought about doing this: If we're also deriving @Ord@ for this
139 instance ... Eq (Foo ...) where
140 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
141 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
143 However, that requires that \tr{Ord <whatever>} was put in the context
144 for the instance decl, which it probably wasn't, so the decls
145 produced don't get through the typechecker.
150 gen_Eq_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
152 = (method_binds, aux_binds)
154 tycon_loc = getSrcSpan tycon
156 (nullary_cons, nonnullary_cons)
157 | isNewTyCon tycon = ([], tyConDataCons tycon)
158 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
160 no_nullary_cons = null nullary_cons
162 rest | no_nullary_cons
163 = case maybeTyConSingleCon tycon of
165 Nothing -> -- if cons don't match, then False
166 [([nlWildPat, nlWildPat], false_Expr)]
167 | otherwise -- calc. and compare the tags
169 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
170 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
172 aux_binds | no_nullary_cons = []
173 | otherwise = [GenCon2Tag tycon]
175 method_binds = listToBag [
176 mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
177 mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
178 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
180 ------------------------------------------------------------------
183 con1_pat = nlConVarPat data_con_RDR as_needed
184 con2_pat = nlConVarPat data_con_RDR bs_needed
186 data_con_RDR = getRdrName data_con
187 con_arity = length tys_needed
188 as_needed = take con_arity as_RDRs
189 bs_needed = take con_arity bs_RDRs
190 tys_needed = dataConOrigArgTys data_con
192 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
194 nested_eq_expr [] [] [] = true_Expr
195 nested_eq_expr tys as bs
196 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
198 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
201 %************************************************************************
205 %************************************************************************
207 For a derived @Ord@, we concentrate our attentions on @compare@
209 compare :: a -> a -> Ordering
210 data Ordering = LT | EQ | GT deriving ()
213 We will use the same example data type as above:
215 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
220 We do all the other @Ord@ methods with calls to @compare@:
222 instance ... (Ord <wurble> <wurble>) where
223 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
224 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
225 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
226 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
228 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
229 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
231 -- compare to come...
235 @compare@ always has two parts. First, we use the compared
236 data-constructors' tags to deal with the case of different
239 compare a b = case (con2tag_Foo a) of { a# ->
240 case (con2tag_Foo b) of { b# ->
241 case (a# ==# b#) of {
243 False -> case (a# <# b#) of
248 cmp_eq = ... to come ...
252 We are only left with the ``help'' function @cmp_eq@, to deal with
253 comparing data constructors with the same tag.
255 For the ordinary constructors (if any), we emit the sorta-obvious
256 compare-style stuff; for our example:
258 cmp_eq (O1 a1 b1) (O1 a2 b2)
259 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
261 cmp_eq (O2 a1) (O2 a2)
264 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
265 = case (compare a1 a2) of {
268 EQ -> case compare b1 b2 of {
276 Again, we must be careful about unlifted comparisons. For example,
277 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
281 cmp_eq lt eq gt (O2 a1) (O2 a2)
283 -- or maybe the unfolded equivalent
287 For the remaining nullary constructors, we already know that the
294 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
298 gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
301 | Just (con, prim_tc) <- primWrapperType_maybe tycon
302 = gen_PrimOrd_binds con prim_tc
305 = (unitBag compare, aux_binds)
306 -- `AndMonoBinds` compare
307 -- The default declaration in PrelBase handles this
309 tycon_loc = getSrcSpan tycon
310 --------------------------------------------------------------------
311 aux_binds | single_con_type = []
312 | otherwise = [GenCon2Tag tycon]
314 compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
315 compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
316 cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
319 | single_con_type = cmp_eq_Expr a_Expr b_Expr
321 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
322 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
323 (cmp_eq_Expr a_Expr b_Expr) -- True case
324 -- False case; they aren't equal
325 -- So we need to do a less-than comparison on the tags
326 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
328 tycon_data_cons = tyConDataCons tycon
329 single_con_type = isSingleton tycon_data_cons
330 (nullary_cons, nonnullary_cons)
331 | isNewTyCon tycon = ([], tyConDataCons tycon)
332 | otherwise = partition isNullarySrcDataCon tycon_data_cons
334 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
336 | isEnumerationTyCon tycon
337 -- We know the tags are equal, so if it's an enumeration TyCon,
338 -- then there is nothing left to do
339 -- Catch this specially to avoid warnings
340 -- about overlapping patterns from the desugarer,
341 -- and to avoid unnecessary pattern-matching
342 = [([nlWildPat,nlWildPat], eqTag_Expr)]
344 = map pats_etc nonnullary_cons ++
345 (if single_con_type then -- Omit wildcards when there's just one
346 [] -- constructor, to silence desugarer
348 [([nlWildPat, nlWildPat], default_rhs)])
350 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
351 -- inexhaustive patterns
352 | otherwise = eqTag_Expr -- Some nullary constructors;
353 -- Tags are equal, no args => return EQ
355 = ([con1_pat, con2_pat],
356 nested_compare_expr tys_needed as_needed bs_needed)
358 con1_pat = nlConVarPat data_con_RDR as_needed
359 con2_pat = nlConVarPat data_con_RDR bs_needed
361 data_con_RDR = getRdrName data_con
362 con_arity = length tys_needed
363 as_needed = take con_arity as_RDRs
364 bs_needed = take con_arity bs_RDRs
365 tys_needed = dataConOrigArgTys data_con
367 nested_compare_expr [ty] [a] [b]
368 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
370 nested_compare_expr (ty:tys) (a:as) (b:bs)
371 = let eq_expr = nested_compare_expr tys as bs
372 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
374 nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
377 Note [Comparision of primitive types]
378 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
379 The general plan does not work well for data types like
380 data T = MkT Int# deriving( Ord )
381 The general plan defines the 'compare' method, gets (<) etc from it. But
382 that means we get silly code like:
384 (>) (I# x) (I# y) = case <# x y of
386 False -> case ==# x y of
389 We would prefer to use the (>#) primop. See also Trac #2130
393 gen_PrimOrd_binds :: DataCon -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
394 -- See Note [Comparison of primitive types]
395 gen_PrimOrd_binds data_con prim_tc
396 = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op,
397 mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
399 mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR
400 [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
401 con_RDR = getRdrName data_con
402 apat = nlConVarPat con_RDR [a_RDR]
403 bpat = nlConVarPat con_RDR [b_RDR]
405 (lt_op, le_op, ge_op, gt_op)
406 | prim_tc == charPrimTyCon = (CharLtOp, CharLeOp, CharGeOp, CharGtOp)
407 | prim_tc == intPrimTyCon = (IntLtOp, IntLeOp, IntGeOp, IntGtOp)
408 | prim_tc == wordPrimTyCon = (WordLtOp, WordLeOp, WordGeOp, WordGtOp)
409 | prim_tc == addrPrimTyCon = (AddrLtOp, AddrLeOp, AddrGeOp, AddrGtOp)
410 | prim_tc == floatPrimTyCon = (FloatLtOp, FloatLeOp, FloatGeOp, FloatGtOp)
411 | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
412 | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
415 primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
416 -- True of data types that are wrappers around prmitive types
417 -- data T = MkT Word#
418 -- For these we want to generate all the (<), (<=) etc operations individually
419 primWrapperType_maybe tc
420 | [con] <- tyConDataCons tc
421 , [ty] <- dataConOrigArgTys con
422 , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
423 , isPrimTyCon prim_tc
424 = Just (con, prim_tc)
429 %************************************************************************
433 %************************************************************************
435 @Enum@ can only be derived for enumeration types. For a type
437 data Foo ... = N1 | N2 | ... | Nn
440 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
441 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
444 instance ... Enum (Foo ...) where
445 succ x = toEnum (1 + fromEnum x)
446 pred x = toEnum (fromEnum x - 1)
448 toEnum i = tag2con_Foo i
450 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
454 = case con2tag_Foo a of
455 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
458 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
462 = case con2tag_Foo a of { a# ->
463 case con2tag_Foo b of { b# ->
464 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
468 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
471 gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
473 = (method_binds, aux_binds)
475 method_binds = listToBag [
483 aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
485 tycon_loc = getSrcSpan tycon
486 occ_nm = getOccString tycon
489 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
490 untag_Expr tycon [(a_RDR, ah_RDR)] $
491 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
492 nlHsVarApps intDataCon_RDR [ah_RDR]])
493 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
494 (nlHsApp (nlHsVar (tag2con_RDR tycon))
495 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
499 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
500 untag_Expr tycon [(a_RDR, ah_RDR)] $
501 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
502 nlHsVarApps intDataCon_RDR [ah_RDR]])
503 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
504 (nlHsApp (nlHsVar (tag2con_RDR tycon))
505 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
506 nlHsLit (HsInt (-1))]))
509 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
510 nlHsIf (nlHsApps and_RDR
511 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
512 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
513 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
514 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
517 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
518 untag_Expr tycon [(a_RDR, ah_RDR)] $
520 [nlHsVar (tag2con_RDR tycon),
521 nlHsPar (enum_from_to_Expr
522 (nlHsVarApps intDataCon_RDR [ah_RDR])
523 (nlHsVar (maxtag_RDR tycon)))]
526 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
527 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
528 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
529 nlHsPar (enum_from_then_to_Expr
530 (nlHsVarApps intDataCon_RDR [ah_RDR])
531 (nlHsVarApps intDataCon_RDR [bh_RDR])
532 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
533 nlHsVarApps intDataCon_RDR [bh_RDR]])
535 (nlHsVar (maxtag_RDR tycon))
539 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
540 untag_Expr tycon [(a_RDR, ah_RDR)] $
541 (nlHsVarApps intDataCon_RDR [ah_RDR])
544 %************************************************************************
548 %************************************************************************
551 gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
552 gen_Bounded_binds tycon
553 | isEnumerationTyCon tycon
554 = (listToBag [ min_bound_enum, max_bound_enum ], [])
556 = ASSERT(isSingleton data_cons)
557 (listToBag [ min_bound_1con, max_bound_1con ], [])
559 data_cons = tyConDataCons tycon
560 tycon_loc = getSrcSpan tycon
562 ----- enum-flavored: ---------------------------
563 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
564 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
566 data_con_1 = head data_cons
567 data_con_N = last data_cons
568 data_con_1_RDR = getRdrName data_con_1
569 data_con_N_RDR = getRdrName data_con_N
571 ----- single-constructor-flavored: -------------
572 arity = dataConSourceArity data_con_1
574 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
575 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
576 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
577 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
580 %************************************************************************
584 %************************************************************************
586 Deriving @Ix@ is only possible for enumeration types and
587 single-constructor types. We deal with them in turn.
589 For an enumeration type, e.g.,
591 data Foo ... = N1 | N2 | ... | Nn
593 things go not too differently from @Enum@:
595 instance ... Ix (Foo ...) where
597 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
601 = case (con2tag_Foo a) of { a# ->
602 case (con2tag_Foo b) of { b# ->
603 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
606 -- Generate code for unsafeIndex, becuase using index leads
607 -- to lots of redundant range tests
608 unsafeIndex c@(a, b) d
609 = case (con2tag_Foo d -# con2tag_Foo a) of
614 p_tag = con2tag_Foo c
616 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
620 = case (con2tag_Foo a) of { a_tag ->
621 case (con2tag_Foo b) of { b_tag ->
622 case (con2tag_Foo c) of { c_tag ->
623 if (c_tag >=# a_tag) then
629 (modulo suitable case-ification to handle the unlifted tags)
631 For a single-constructor type (NB: this includes all tuples), e.g.,
633 data Foo ... = MkFoo a b Int Double c c
635 we follow the scheme given in Figure~19 of the Haskell~1.2 report
639 gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
642 | isEnumerationTyCon tycon
643 = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
645 = (single_con_ixes, [GenCon2Tag tycon])
647 tycon_loc = getSrcSpan tycon
649 --------------------------------------------------------------
650 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
653 = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
654 untag_Expr tycon [(a_RDR, ah_RDR)] $
655 untag_Expr tycon [(b_RDR, bh_RDR)] $
656 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
657 nlHsPar (enum_from_to_Expr
658 (nlHsVarApps intDataCon_RDR [ah_RDR])
659 (nlHsVarApps intDataCon_RDR [bh_RDR]))
662 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
663 [noLoc (AsPat (noLoc c_RDR)
664 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
666 untag_Expr tycon [(a_RDR, ah_RDR)] (
667 untag_Expr tycon [(d_RDR, dh_RDR)] (
669 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
672 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
673 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
678 = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
679 untag_Expr tycon [(a_RDR, ah_RDR)] (
680 untag_Expr tycon [(b_RDR, bh_RDR)] (
681 untag_Expr tycon [(c_RDR, ch_RDR)] (
682 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
683 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
688 --------------------------------------------------------------
690 = listToBag [single_con_range, single_con_index, single_con_inRange]
693 = case maybeTyConSingleCon tycon of -- just checking...
694 Nothing -> panic "get_Ix_binds"
695 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
696 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
699 con_arity = dataConSourceArity data_con
700 data_con_RDR = getRdrName data_con
702 as_needed = take con_arity as_RDRs
703 bs_needed = take con_arity bs_RDRs
704 cs_needed = take con_arity cs_RDRs
706 con_pat xs = nlConVarPat data_con_RDR xs
707 con_expr = nlHsVarApps data_con_RDR cs_needed
709 --------------------------------------------------------------
711 = mk_easy_FunBind tycon_loc range_RDR
712 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
713 nlHsDo ListComp stmts con_expr
715 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
717 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
718 (nlHsApp (nlHsVar range_RDR)
719 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
723 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
724 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
726 -- We need to reverse the order we consider the components in
728 -- range (l,u) !! index (l,u) i == i -- when i is in range
729 -- (from http://haskell.org/onlinereport/ix.html) holds.
730 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
732 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
733 mk_index [] = nlHsIntLit 0
734 mk_index [(l,u,i)] = mk_one l u i
735 mk_index ((l,u,i) : rest)
740 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
741 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
742 ) times_RDR (mk_index rest)
745 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
749 = mk_easy_FunBind tycon_loc inRange_RDR
750 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
752 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
754 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
758 %************************************************************************
762 %************************************************************************
772 instance Read T where
776 do x <- ReadP.step Read.readPrec
777 Symbol "%%" <- Lex.lex
778 y <- ReadP.step Read.readPrec
782 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
783 -- Record construction binds even more tightly than application
784 do Ident "T1" <- Lex.lex
786 Ident "f1" <- Lex.lex
788 x <- ReadP.reset Read.readPrec
790 return (T1 { f1 = x }))
793 do Ident "T2" <- Lex.lexP
794 x <- ReadP.step Read.readPrec
798 readListPrec = readListPrecDefault
799 readList = readListDefault
803 gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
805 gen_Read_binds get_fixity tycon
806 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
808 -----------------------------------------------------------------------
810 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
813 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
814 -----------------------------------------------------------------------
816 loc = getSrcSpan tycon
817 data_cons = tyConDataCons tycon
818 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
820 read_prec = mkVarBind loc readPrec_RDR
821 (nlHsApp (nlHsVar parens_RDR) read_cons)
823 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
824 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
827 = case nullary_cons of
829 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
830 (result_expr con [])]
831 _ -> [nlHsApp (nlHsVar choose_RDR)
832 (nlList (map mk_pair nullary_cons))]
834 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
838 read_non_nullary_con data_con
839 | is_infix = mk_parser infix_prec infix_stmts body
840 | is_record = mk_parser record_prec record_stmts body
841 -- Using these two lines instead allows the derived
842 -- read for infix and record bindings to read the prefix form
843 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
844 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
845 | otherwise = prefix_parser
847 body = result_expr data_con as_needed
848 con_str = data_con_str data_con
850 prefix_parser = mk_parser prefix_prec prefix_stmts body
851 prefix_stmts -- T a b c
852 = (if not (isSym con_str) then
853 [bindLex (ident_pat con_str)]
854 else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
857 infix_stmts -- a %% b, or a `T` b
860 then [bindLex (symbol_pat con_str)]
861 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
864 record_stmts -- T { f1 = a, f2 = b }
865 = [bindLex (ident_pat (wrapOpParens con_str)),
867 ++ concat (intersperse [read_punc ","] field_stmts)
870 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
872 con_arity = dataConSourceArity data_con
873 labels = dataConFieldLabels data_con
874 dc_nm = getName data_con
875 is_infix = dataConIsInfix data_con
876 is_record = length labels > 0
877 as_needed = take con_arity as_RDRs
878 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
879 (read_a1:read_a2:_) = read_args
881 prefix_prec = appPrecedence
882 infix_prec = getPrecedence get_fixity dc_nm
883 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
884 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
886 ------------------------------------------------------------------------
888 ------------------------------------------------------------------------
889 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
890 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
891 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
892 con_app con as = nlHsVarApps (getRdrName con) as -- con as
893 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
895 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
896 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
897 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
899 data_con_str con = occNameString (getOccName con)
901 read_punc c = bindLex (punc_pat c)
903 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
904 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
906 read_field lbl a = read_lbl lbl ++
908 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
910 -- When reading field labels we might encounter
915 read_lbl lbl | isSym lbl_str
917 bindLex (symbol_pat lbl_str),
920 = [bindLex (ident_pat lbl_str)]
922 lbl_str = occNameString (getOccName lbl)
926 %************************************************************************
930 %************************************************************************
936 data Tree a = Leaf a | Tree a :^: Tree a
938 instance (Show a) => Show (Tree a) where
940 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
942 showStr = showString "Leaf " . showsPrec (app_prec+1) m
944 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
946 showStr = showsPrec (up_prec+1) u .
948 showsPrec (up_prec+1) v
949 -- Note: right-associativity of :^: ignored
951 up_prec = 5 -- Precedence of :^:
952 app_prec = 10 -- Application has precedence one more than
953 -- the most tightly-binding operator
956 gen_Show_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
958 gen_Show_binds get_fixity tycon
959 = (listToBag [shows_prec, show_list], [])
961 tycon_loc = getSrcSpan tycon
962 -----------------------------------------------------------------------
963 show_list = mkVarBind tycon_loc showList_RDR
964 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
965 -----------------------------------------------------------------------
966 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
969 | nullary_con = -- skip the showParen junk...
970 ASSERT(null bs_needed)
971 ([nlWildPat, con_pat], mk_showString_app con_str)
974 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
975 (nlHsPar (nested_compose_Expr show_thingies)))
977 data_con_RDR = getRdrName data_con
978 con_arity = dataConSourceArity data_con
979 bs_needed = take con_arity bs_RDRs
980 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
981 con_pat = nlConVarPat data_con_RDR bs_needed
982 nullary_con = con_arity == 0
983 labels = dataConFieldLabels data_con
984 lab_fields = length labels
985 record_syntax = lab_fields > 0
987 dc_nm = getName data_con
988 dc_occ_nm = getOccName data_con
989 con_str = occNameString dc_occ_nm
990 op_con_str = wrapOpParens con_str
991 backquote_str = wrapOpBackquotes con_str
994 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
995 | record_syntax = mk_showString_app (op_con_str ++ " {") :
996 show_record_args ++ [mk_showString_app "}"]
997 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
999 show_label l = mk_showString_app (nm ++ " = ")
1000 -- Note the spaces around the "=" sign. If we don't have them
1001 -- then we get Foo { x=-1 } and the "=-" parses as a single
1002 -- lexeme. Only the space after the '=' is necessary, but
1003 -- it seems tidier to have them both sides.
1005 occ_nm = getOccName l
1006 nm = wrapOpParens (occNameString occ_nm)
1008 show_args = zipWith show_arg bs_needed arg_tys
1009 (show_arg1:show_arg2:_) = show_args
1010 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1012 -- Assumption for record syntax: no of fields == no of labelled fields
1013 -- (and in same order)
1014 show_record_args = concat $
1015 intersperse [mk_showString_app ", "] $
1016 [ [show_label lbl, arg]
1017 | (lbl,arg) <- zipEqual "gen_Show_binds"
1020 -- Generates (showsPrec p x) for argument x, but it also boxes
1021 -- the argument first if necessary. Note that this prints unboxed
1022 -- things without any '#' decorations; could change that if need be
1023 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1024 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1027 is_infix = dataConIsInfix data_con
1028 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1029 arg_prec | record_syntax = 0 -- Record fields don't need parens
1030 | otherwise = con_prec_plus_one
1032 wrapOpParens :: String -> String
1033 wrapOpParens s | isSym s = '(' : s ++ ")"
1036 wrapOpBackquotes :: String -> String
1037 wrapOpBackquotes s | isSym s = s
1038 | otherwise = '`' : s ++ "`"
1040 isSym :: String -> Bool
1042 isSym (c : _) = startsVarSym c || startsConSym c
1044 mk_showString_app :: String -> LHsExpr RdrName
1045 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1049 getPrec :: Bool -> FixityEnv -> Name -> Integer
1050 getPrec is_infix get_fixity nm
1051 | not is_infix = appPrecedence
1052 | otherwise = getPrecedence get_fixity nm
1054 appPrecedence :: Integer
1055 appPrecedence = fromIntegral maxPrecedence + 1
1056 -- One more than the precedence of the most
1057 -- tightly-binding operator
1059 getPrecedence :: FixityEnv -> Name -> Integer
1060 getPrecedence get_fixity nm
1061 = case lookupFixity get_fixity nm of
1062 Fixity x _assoc -> fromIntegral x
1063 -- NB: the Report says that associativity is not taken
1064 -- into account for either Read or Show; hence we
1065 -- ignore associativity here
1069 %************************************************************************
1071 \subsection{Typeable}
1073 %************************************************************************
1081 instance Typeable2 T where
1082 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1084 We are passed the Typeable2 class as well as T
1087 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1088 gen_Typeable_binds tycon
1090 mk_easy_FunBind tycon_loc
1091 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1093 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1095 tycon_loc = getSrcSpan tycon
1096 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1098 mk_typeOf_RDR :: TyCon -> RdrName
1099 -- Use the arity of the TyCon to make the right typeOfn function
1100 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1102 arity = tyConArity tycon
1103 suffix | arity == 0 = ""
1104 | otherwise = show arity
1109 %************************************************************************
1113 %************************************************************************
1117 data T a b = T1 a b | T2
1121 $cT1 = mkDataCon $dT "T1" Prefix
1122 $cT2 = mkDataCon $dT "T2" Prefix
1123 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1124 -- the [] is for field labels.
1126 instance (Data a, Data b) => Data (T a b) where
1127 gfoldl k z (T1 a b) = z T `k` a `k` b
1128 gfoldl k z T2 = z T2
1129 -- ToDo: add gmapT,Q,M, gfoldr
1131 gunfold k z c = case conIndex c of
1132 I# 1# -> k (k (z T1))
1135 toConstr (T1 _ _) = $cT1
1141 gen_Data_binds :: FixityEnv
1143 -> (LHsBinds RdrName, -- The method bindings
1144 DerivAuxBinds) -- Auxiliary bindings
1145 gen_Data_binds _ tycon
1146 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1147 -- Auxiliary definitions: the data type and constructors
1148 DerivAuxBind datatype_bind : map mk_con_bind data_cons)
1150 tycon_loc = getSrcSpan tycon
1151 tycon_name = tyConName tycon
1152 data_cons = tyConDataCons tycon
1153 n_cons = length data_cons
1154 one_constr = n_cons == 1
1157 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1158 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1159 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1162 con_name = getRdrName con
1163 as_needed = take (dataConSourceArity con) as_RDRs
1164 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1166 ------------ gunfold
1167 gunfold_bind = mk_FunBind tycon_loc
1169 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1173 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1174 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1175 (map gunfold_alt data_cons)
1177 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1178 mk_unfold_rhs dc = foldr nlHsApp
1179 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1180 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1182 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1183 -- redundant test, and annoying warning
1184 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1185 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1189 ------------ toConstr
1190 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1191 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1193 ------------ dataTypeOf
1194 dataTypeOf_bind = mk_easy_FunBind
1198 (nlHsVar data_type_name)
1202 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1203 datatype_bind = mkVarBind
1206 ( nlHsVar mkDataType_RDR
1207 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1208 `nlHsApp` nlList constrs
1210 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1213 ------------ $cT1 etc
1214 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1215 mk_con_bind dc = DerivAuxBind $
1219 (nlHsApps mkConstr_RDR (constr_args dc))
1221 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1222 nlHsVar data_type_name, -- DataType
1223 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1224 nlList labels, -- Field labels
1225 nlHsVar fixity] -- Fixity
1227 labels = map (nlHsLit . mkHsString . getOccString)
1228 (dataConFieldLabels dc)
1229 dc_occ = getOccName dc
1230 is_infix = isDataSymOcc dc_occ
1231 fixity | is_infix = infix_RDR
1232 | otherwise = prefix_RDR
1234 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1235 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName
1236 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1237 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1238 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1239 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1240 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1241 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1242 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1243 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1244 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1247 %************************************************************************
1249 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1251 %************************************************************************
1256 con2tag_Foo :: Foo ... -> Int#
1257 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1258 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1261 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1265 genAuxBind :: DerivAuxBind -> LHsBind RdrName
1267 genAuxBind (DerivAuxBind bind)
1270 genAuxBind (GenCon2Tag tycon)
1271 | lots_of_constructors
1272 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1275 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1278 rdr_name = con2tag_RDR tycon
1279 tycon_loc = getSrcSpan tycon
1281 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1282 -- We can't use gerRdrName because that makes an Exact RdrName
1283 -- and we can't put them in the LocalRdrEnv
1285 -- Give a signature to the bound variable, so
1286 -- that the case expression generated by getTag is
1287 -- monomorphic. In the push-enter model we get better code.
1288 get_tag_rhs = noLoc $ ExprWithTySig
1289 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1290 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1291 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1293 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1295 nlHsTyVar (getRdrName intPrimTyCon)
1297 lots_of_constructors = tyConFamilySize tycon > 8
1298 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1299 -- but we don't do vectored returns any more.
1301 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1302 mk_stuff con = ([nlWildConPat con],
1303 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1305 genAuxBind (GenTag2Con tycon)
1306 = mk_FunBind (getSrcSpan tycon) rdr_name
1307 [([nlConVarPat intDataCon_RDR [a_RDR]],
1308 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1309 (nlHsTyVar (getRdrName tycon))))]
1311 rdr_name = tag2con_RDR tycon
1313 genAuxBind (GenMaxTag tycon)
1314 = mkVarBind (getSrcSpan tycon) rdr_name
1315 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1317 rdr_name = maxtag_RDR tycon
1318 max_tag = case (tyConDataCons tycon) of
1319 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1322 %************************************************************************
1324 \subsection{Utility bits for generating bindings}
1326 %************************************************************************
1329 ToDo: Better SrcLocs.
1333 LHsExpr RdrName -- What to do for equality
1334 -> LHsExpr RdrName -> LHsExpr RdrName
1336 careful_compare_Case :: -- checks for primitive types...
1337 TyCon -- The tycon we are deriving for
1339 -> LHsExpr RdrName -- What to do for equality
1340 -> LHsExpr RdrName -> LHsExpr RdrName
1343 cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1344 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1345 -- Was: compare_gen_Case cmp_eq_RDR
1347 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1348 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1349 compare_gen_Case eq a b -- General case
1350 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1351 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1352 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1353 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1355 careful_compare_Case tycon ty eq a b
1356 | not (isUnLiftedType ty)
1357 = compare_gen_Case eq a b
1358 | otherwise -- We have to do something special for primitive things...
1359 = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter
1360 ltTag_Expr -- is true less often, so putting it first would
1361 -- mean more tests (dynamically)
1362 (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1364 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1365 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1368 box_if_necy :: String -- The class involved
1369 -> TyCon -- The tycon involved
1370 -> LHsExpr RdrName -- The argument
1371 -> Type -- The argument type
1372 -> LHsExpr RdrName -- Boxed version of the arg
1373 box_if_necy cls_str tycon arg arg_ty
1374 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1377 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1379 assoc_ty_id :: String -- The class involved
1380 -> TyCon -- The tycon involved
1381 -> [(Type,a)] -- The table
1383 -> a -- The result of the lookup
1384 assoc_ty_id cls_str _ tbl ty
1385 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1386 text "for primitive type" <+> ppr ty)
1387 | otherwise = head res
1389 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1391 eq_op_tbl :: [(Type, PrimOp)]
1393 [(charPrimTy, CharEqOp)
1394 ,(intPrimTy, IntEqOp)
1395 ,(wordPrimTy, WordEqOp)
1396 ,(addrPrimTy, AddrEqOp)
1397 ,(floatPrimTy, FloatEqOp)
1398 ,(doublePrimTy, DoubleEqOp)
1401 lt_op_tbl :: [(Type, PrimOp)]
1403 [(charPrimTy, CharLtOp)
1404 ,(intPrimTy, IntLtOp)
1405 ,(wordPrimTy, WordLtOp)
1406 ,(addrPrimTy, AddrLtOp)
1407 ,(floatPrimTy, FloatLtOp)
1408 ,(doublePrimTy, DoubleLtOp)
1411 box_con_tbl :: [(Type, RdrName)]
1413 [(charPrimTy, getRdrName charDataCon)
1414 ,(intPrimTy, getRdrName intDataCon)
1415 ,(wordPrimTy, wordDataCon_RDR)
1416 ,(floatPrimTy, getRdrName floatDataCon)
1417 ,(doublePrimTy, getRdrName doubleDataCon)
1420 -----------------------------------------------------------------------
1422 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1423 and_Expr a b = genOpApp a and_RDR b
1425 -----------------------------------------------------------------------
1427 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1428 eq_Expr tycon ty a b = genOpApp a eq_op b
1431 | not (isUnLiftedType ty) = eq_RDR
1432 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1433 -- we have to do something special for primitive things...
1437 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1438 untag_Expr _ [] expr = expr
1439 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1440 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1441 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1443 cmp_tags_Expr :: RdrName -- Comparison op
1444 -> RdrName -> RdrName -- Things to compare
1445 -> LHsExpr RdrName -- What to return if true
1446 -> LHsExpr RdrName -- What to return if false
1449 cmp_tags_Expr op a b true_case false_case
1450 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1453 :: LHsExpr RdrName -> LHsExpr RdrName
1455 enum_from_then_to_Expr
1456 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1459 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1460 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1463 :: LHsExpr RdrName -> LHsExpr RdrName
1466 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1468 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1470 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1471 nested_compose_Expr [e] = parenify e
1472 nested_compose_Expr (e:es)
1473 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1475 -- impossible_Expr is used in case RHSs that should never happen.
1476 -- We generate these to keep the desugarer from complaining that they *might* happen!
1477 impossible_Expr :: LHsExpr RdrName
1478 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1480 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1481 -- method. It is currently only used by Enum.{succ,pred}
1482 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
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 :: String -> RdrName -> LHsExpr RdrName
1489 illegal_toEnum_tag tp maxtag =
1490 nlHsApp (nlHsVar error_RDR)
1491 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1492 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1493 (nlHsApp (nlHsApp (nlHsApp
1494 (nlHsVar showsPrec_RDR)
1498 (nlHsVar append_RDR)
1499 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1500 (nlHsApp (nlHsApp (nlHsApp
1501 (nlHsVar showsPrec_RDR)
1504 (nlHsLit (mkHsString ")"))))))
1506 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1507 parenify e@(L _ (HsVar _)) = e
1508 parenify e = mkHsPar e
1510 -- genOpApp wraps brackets round the operator application, so that the
1511 -- renamer won't subsequently try to re-associate it.
1512 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1513 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1517 a_RDR, b_RDR, c_RDR, d_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR,
1518 cmp_eq_RDR :: RdrName
1519 a_RDR = mkVarUnqual (fsLit "a")
1520 b_RDR = mkVarUnqual (fsLit "b")
1521 c_RDR = mkVarUnqual (fsLit "c")
1522 d_RDR = mkVarUnqual (fsLit "d")
1523 k_RDR = mkVarUnqual (fsLit "k")
1524 z_RDR = mkVarUnqual (fsLit "z")
1525 ah_RDR = mkVarUnqual (fsLit "a#")
1526 bh_RDR = mkVarUnqual (fsLit "b#")
1527 ch_RDR = mkVarUnqual (fsLit "c#")
1528 dh_RDR = mkVarUnqual (fsLit "d#")
1529 cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq")
1531 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1532 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1533 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1534 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1536 a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1537 false_Expr, true_Expr :: LHsExpr RdrName
1538 a_Expr = nlHsVar a_RDR
1539 b_Expr = nlHsVar b_RDR
1540 c_Expr = nlHsVar c_RDR
1541 ltTag_Expr = nlHsVar ltTag_RDR
1542 eqTag_Expr = nlHsVar eqTag_RDR
1543 gtTag_Expr = nlHsVar gtTag_RDR
1544 false_Expr = nlHsVar false_RDR
1545 true_Expr = nlHsVar true_RDR
1547 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
1548 a_Pat = nlVarPat a_RDR
1549 b_Pat = nlVarPat b_RDR
1550 c_Pat = nlVarPat c_RDR
1551 d_Pat = nlVarPat d_RDR
1552 k_Pat = nlVarPat k_RDR
1553 z_Pat = nlVarPat z_RDR
1555 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1556 -- Generates Orig s RdrName, for the binding positions
1557 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1558 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1559 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1561 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1562 mk_tc_deriv_name tycon fun = mkDerivedRdrName (tyConName tycon) fun
1565 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1566 PrelNames, so PrelNames can't import PrimOp.
1569 primOpRdrName :: PrimOp -> RdrName
1570 primOpRdrName op = getRdrName (primOpId op)
1572 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
1573 tagToEnum_RDR :: RdrName
1574 minusInt_RDR = primOpRdrName IntSubOp
1575 eqInt_RDR = primOpRdrName IntEqOp
1576 ltInt_RDR = primOpRdrName IntLtOp
1577 geInt_RDR = primOpRdrName IntGeOp
1578 leInt_RDR = primOpRdrName IntLeOp
1579 tagToEnum_RDR = primOpRdrName TagToEnumOp
1581 error_RDR :: RdrName
1582 error_RDR = getRdrName eRROR_ID