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,
29 #include "HsVersions.h"
53 import Data.List ( partition, intersperse )
57 type DerivAuxBinds = [DerivAuxBind]
59 data DerivAuxBind -- Please add these auxiliary top-level bindings
60 = DerivAuxBind (LHsBind RdrName)
61 | GenCon2Tag TyCon -- The con2Tag for given TyCon
62 | GenTag2Con TyCon -- ...ditto tag2Con
63 | GenMaxTag TyCon -- ...and maxTag
65 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
66 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
67 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
68 isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2
73 %************************************************************************
77 %************************************************************************
79 Here are the heuristics for the code we generate for @Eq@:
82 Let's assume we have a data type with some (possibly zero) nullary
83 data constructors and some ordinary, non-nullary ones (the rest,
84 also possibly zero of them). Here's an example, with both \tr{N}ullary
85 and \tr{O}rdinary data cons.
87 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
91 For the ordinary constructors (if any), we emit clauses to do The
95 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
96 (==) (O2 a1) (O2 a2) = a1 == a2
97 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
100 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
101 \tr{a2} are \tr{Float#}s, then we have to generate
103 case (a1 `eqFloat#` a2) of
106 for that particular test.
109 If there are any nullary constructors, we emit a catch-all clause of
113 (==) a b = case (con2tag_Foo a) of { a# ->
114 case (con2tag_Foo b) of { b# ->
115 case (a# ==# b#) of {
120 If there aren't any nullary constructors, we emit a simpler
127 For the @(/=)@ method, we normally just use the default method.
129 If the type is an enumeration type, we could/may/should? generate
130 special code that calls @con2tag_Foo@, much like for @(==)@ shown
134 We thought about doing this: If we're also deriving @Ord@ for this
137 instance ... Eq (Foo ...) where
138 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
139 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
141 However, that requires that \tr{Ord <whatever>} was put in the context
142 for the instance decl, which it probably wasn't, so the decls
143 produced don't get through the typechecker.
148 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
149 gen_Eq_binds loc tycon
150 = (method_binds, aux_binds)
152 (nullary_cons, nonnullary_cons)
153 | isNewTyCon tycon = ([], tyConDataCons tycon)
154 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
156 no_nullary_cons = null nullary_cons
158 rest | no_nullary_cons
159 = case maybeTyConSingleCon tycon of
161 Nothing -> -- if cons don't match, then False
162 [([nlWildPat, nlWildPat], false_Expr)]
163 | otherwise -- calc. and compare the tags
165 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
166 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
168 aux_binds | no_nullary_cons = []
169 | otherwise = [GenCon2Tag tycon]
171 method_binds = listToBag [
172 mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
173 mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
174 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
176 ------------------------------------------------------------------
179 con1_pat = nlConVarPat data_con_RDR as_needed
180 con2_pat = nlConVarPat data_con_RDR bs_needed
182 data_con_RDR = getRdrName data_con
183 con_arity = length tys_needed
184 as_needed = take con_arity as_RDRs
185 bs_needed = take con_arity bs_RDRs
186 tys_needed = dataConOrigArgTys data_con
188 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
190 nested_eq_expr [] [] [] = true_Expr
191 nested_eq_expr tys as bs
192 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
194 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
197 %************************************************************************
201 %************************************************************************
203 For a derived @Ord@, we concentrate our attentions on @compare@
205 compare :: a -> a -> Ordering
206 data Ordering = LT | EQ | GT deriving ()
209 We will use the same example data type as above:
211 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
216 We do all the other @Ord@ methods with calls to @compare@:
218 instance ... (Ord <wurble> <wurble>) where
219 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
220 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
221 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
222 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
224 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
225 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
227 -- compare to come...
231 @compare@ always has two parts. First, we use the compared
232 data-constructors' tags to deal with the case of different
235 compare a b = case (con2tag_Foo a) of { a# ->
236 case (con2tag_Foo b) of { b# ->
237 case (a# ==# b#) of {
239 False -> case (a# <# b#) of
244 cmp_eq = ... to come ...
248 We are only left with the ``help'' function @cmp_eq@, to deal with
249 comparing data constructors with the same tag.
251 For the ordinary constructors (if any), we emit the sorta-obvious
252 compare-style stuff; for our example:
254 cmp_eq (O1 a1 b1) (O1 a2 b2)
255 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
257 cmp_eq (O2 a1) (O2 a2)
260 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
261 = case (compare a1 a2) of {
264 EQ -> case compare b1 b2 of {
272 Again, we must be careful about unlifted comparisons. For example,
273 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
277 cmp_eq lt eq gt (O2 a1) (O2 a2)
279 -- or maybe the unfolded equivalent
283 For the remaining nullary constructors, we already know that the
290 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
294 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
296 gen_Ord_binds loc tycon
297 | Just (con, prim_tc) <- primWrapperType_maybe tycon
298 = gen_PrimOrd_binds con prim_tc
301 = (unitBag compare, aux_binds)
302 -- `AndMonoBinds` compare
303 -- The default declaration in PrelBase handles this
305 aux_binds | single_con_type = []
306 | otherwise = [GenCon2Tag tycon]
308 compare = L loc (mkFunBind (L loc compare_RDR) compare_matches)
309 compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
310 cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
313 | single_con_type = cmp_eq_Expr a_Expr b_Expr
315 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
316 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
317 (cmp_eq_Expr a_Expr b_Expr) -- True case
318 -- False case; they aren't equal
319 -- So we need to do a less-than comparison on the tags
320 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
322 tycon_data_cons = tyConDataCons tycon
323 single_con_type = isSingleton tycon_data_cons
324 (nullary_cons, nonnullary_cons)
325 | isNewTyCon tycon = ([], tyConDataCons tycon)
326 | otherwise = partition isNullarySrcDataCon tycon_data_cons
328 cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match
330 | isEnumerationTyCon tycon
331 -- We know the tags are equal, so if it's an enumeration TyCon,
332 -- then there is nothing left to do
333 -- Catch this specially to avoid warnings
334 -- about overlapping patterns from the desugarer,
335 -- and to avoid unnecessary pattern-matching
336 = [([nlWildPat,nlWildPat], eqTag_Expr)]
338 = map pats_etc nonnullary_cons ++
339 (if single_con_type then -- Omit wildcards when there's just one
340 [] -- constructor, to silence desugarer
342 [([nlWildPat, nlWildPat], default_rhs)])
344 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
345 -- inexhaustive patterns
346 | otherwise = eqTag_Expr -- Some nullary constructors;
347 -- Tags are equal, no args => return EQ
349 = ([con1_pat, con2_pat],
350 nested_compare_expr tys_needed as_needed bs_needed)
352 con1_pat = nlConVarPat data_con_RDR as_needed
353 con2_pat = nlConVarPat data_con_RDR bs_needed
355 data_con_RDR = getRdrName data_con
356 con_arity = length tys_needed
357 as_needed = take con_arity as_RDRs
358 bs_needed = take con_arity bs_RDRs
359 tys_needed = dataConOrigArgTys data_con
361 nested_compare_expr [ty] [a] [b]
362 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
364 nested_compare_expr (ty:tys) (a:as) (b:bs)
365 = let eq_expr = nested_compare_expr tys as bs
366 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
368 nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
371 Note [Comparision of primitive types]
372 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
373 The general plan does not work well for data types like
374 data T = MkT Int# deriving( Ord )
375 The general plan defines the 'compare' method, gets (<) etc from it. But
376 that means we get silly code like:
378 (>) (I# x) (I# y) = case <# x y of
380 False -> case ==# x y of
383 We would prefer to use the (>#) primop. See also Trac #2130
387 gen_PrimOrd_binds :: DataCon -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
388 -- See Note [Comparison of primitive types]
389 gen_PrimOrd_binds data_con prim_tc
390 = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op,
391 mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
393 mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR
394 [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
395 con_RDR = getRdrName data_con
396 apat = nlConVarPat con_RDR [a_RDR]
397 bpat = nlConVarPat con_RDR [b_RDR]
399 (lt_op, le_op, ge_op, gt_op)
400 | prim_tc == charPrimTyCon = (CharLtOp, CharLeOp, CharGeOp, CharGtOp)
401 | prim_tc == intPrimTyCon = (IntLtOp, IntLeOp, IntGeOp, IntGtOp)
402 | prim_tc == wordPrimTyCon = (WordLtOp, WordLeOp, WordGeOp, WordGtOp)
403 | prim_tc == addrPrimTyCon = (AddrLtOp, AddrLeOp, AddrGeOp, AddrGtOp)
404 | prim_tc == floatPrimTyCon = (FloatLtOp, FloatLeOp, FloatGeOp, FloatGtOp)
405 | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
406 | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
409 primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
410 -- True of data types that are wrappers around prmitive types
411 -- data T = MkT Word#
412 -- For these we want to generate all the (<), (<=) etc operations individually
413 primWrapperType_maybe tc
414 | [con] <- tyConDataCons tc
415 , [ty] <- dataConOrigArgTys con
416 , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
417 , isPrimTyCon prim_tc
418 = Just (con, prim_tc)
423 %************************************************************************
427 %************************************************************************
429 @Enum@ can only be derived for enumeration types. For a type
431 data Foo ... = N1 | N2 | ... | Nn
434 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
435 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
438 instance ... Enum (Foo ...) where
439 succ x = toEnum (1 + fromEnum x)
440 pred x = toEnum (fromEnum x - 1)
442 toEnum i = tag2con_Foo i
444 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
448 = case con2tag_Foo a of
449 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
452 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
456 = case con2tag_Foo a of { a# ->
457 case con2tag_Foo b of { b# ->
458 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
462 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
465 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
466 gen_Enum_binds loc tycon
467 = (method_binds, aux_binds)
469 method_binds = listToBag [
477 aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
479 occ_nm = getOccString tycon
482 = mk_easy_FunBind loc succ_RDR [a_Pat] $
483 untag_Expr tycon [(a_RDR, ah_RDR)] $
484 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
485 nlHsVarApps intDataCon_RDR [ah_RDR]])
486 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
487 (nlHsApp (nlHsVar (tag2con_RDR tycon))
488 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
492 = mk_easy_FunBind loc pred_RDR [a_Pat] $
493 untag_Expr tycon [(a_RDR, ah_RDR)] $
494 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
495 nlHsVarApps intDataCon_RDR [ah_RDR]])
496 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
497 (nlHsApp (nlHsVar (tag2con_RDR tycon))
498 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
499 nlHsLit (HsInt (-1))]))
502 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
503 nlHsIf (nlHsApps and_RDR
504 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
505 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
506 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
507 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
510 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
511 untag_Expr tycon [(a_RDR, ah_RDR)] $
513 [nlHsVar (tag2con_RDR tycon),
514 nlHsPar (enum_from_to_Expr
515 (nlHsVarApps intDataCon_RDR [ah_RDR])
516 (nlHsVar (maxtag_RDR tycon)))]
519 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
520 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
521 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
522 nlHsPar (enum_from_then_to_Expr
523 (nlHsVarApps intDataCon_RDR [ah_RDR])
524 (nlHsVarApps intDataCon_RDR [bh_RDR])
525 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
526 nlHsVarApps intDataCon_RDR [bh_RDR]])
528 (nlHsVar (maxtag_RDR tycon))
532 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
533 untag_Expr tycon [(a_RDR, ah_RDR)] $
534 (nlHsVarApps intDataCon_RDR [ah_RDR])
537 %************************************************************************
541 %************************************************************************
544 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
545 gen_Bounded_binds loc tycon
546 | isEnumerationTyCon tycon
547 = (listToBag [ min_bound_enum, max_bound_enum ], [])
549 = ASSERT(isSingleton data_cons)
550 (listToBag [ min_bound_1con, max_bound_1con ], [])
552 data_cons = tyConDataCons tycon
554 ----- enum-flavored: ---------------------------
555 min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
556 max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
558 data_con_1 = head data_cons
559 data_con_N = last data_cons
560 data_con_1_RDR = getRdrName data_con_1
561 data_con_N_RDR = getRdrName data_con_N
563 ----- single-constructor-flavored: -------------
564 arity = dataConSourceArity data_con_1
566 min_bound_1con = mkVarBind loc minBound_RDR $
567 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
568 max_bound_1con = mkVarBind loc maxBound_RDR $
569 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
572 %************************************************************************
576 %************************************************************************
578 Deriving @Ix@ is only possible for enumeration types and
579 single-constructor types. We deal with them in turn.
581 For an enumeration type, e.g.,
583 data Foo ... = N1 | N2 | ... | Nn
585 things go not too differently from @Enum@:
587 instance ... Ix (Foo ...) where
589 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
593 = case (con2tag_Foo a) of { a# ->
594 case (con2tag_Foo b) of { b# ->
595 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
598 -- Generate code for unsafeIndex, becuase using index leads
599 -- to lots of redundant range tests
600 unsafeIndex c@(a, b) d
601 = case (con2tag_Foo d -# con2tag_Foo a) of
606 p_tag = con2tag_Foo c
608 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
612 = case (con2tag_Foo a) of { a_tag ->
613 case (con2tag_Foo b) of { b_tag ->
614 case (con2tag_Foo c) of { c_tag ->
615 if (c_tag >=# a_tag) then
621 (modulo suitable case-ification to handle the unlifted tags)
623 For a single-constructor type (NB: this includes all tuples), e.g.,
625 data Foo ... = MkFoo a b Int Double c c
627 we follow the scheme given in Figure~19 of the Haskell~1.2 report
631 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
633 gen_Ix_binds loc tycon
634 | isEnumerationTyCon tycon
635 = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
637 = (single_con_ixes, [GenCon2Tag tycon])
639 --------------------------------------------------------------
640 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
643 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
644 untag_Expr tycon [(a_RDR, ah_RDR)] $
645 untag_Expr tycon [(b_RDR, bh_RDR)] $
646 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
647 nlHsPar (enum_from_to_Expr
648 (nlHsVarApps intDataCon_RDR [ah_RDR])
649 (nlHsVarApps intDataCon_RDR [bh_RDR]))
652 = mk_easy_FunBind loc unsafeIndex_RDR
653 [noLoc (AsPat (noLoc c_RDR)
654 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
656 untag_Expr tycon [(a_RDR, ah_RDR)] (
657 untag_Expr tycon [(d_RDR, dh_RDR)] (
659 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
662 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
663 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
668 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
669 untag_Expr tycon [(a_RDR, ah_RDR)] (
670 untag_Expr tycon [(b_RDR, bh_RDR)] (
671 untag_Expr tycon [(c_RDR, ch_RDR)] (
672 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
673 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
678 --------------------------------------------------------------
680 = listToBag [single_con_range, single_con_index, single_con_inRange]
683 = case maybeTyConSingleCon tycon of -- just checking...
684 Nothing -> panic "get_Ix_binds"
685 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
686 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
689 con_arity = dataConSourceArity data_con
690 data_con_RDR = getRdrName data_con
692 as_needed = take con_arity as_RDRs
693 bs_needed = take con_arity bs_RDRs
694 cs_needed = take con_arity cs_RDRs
696 con_pat xs = nlConVarPat data_con_RDR xs
697 con_expr = nlHsVarApps data_con_RDR cs_needed
699 --------------------------------------------------------------
701 = mk_easy_FunBind loc range_RDR
702 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
703 nlHsDo ListComp stmts con_expr
705 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
707 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
708 (nlHsApp (nlHsVar range_RDR)
709 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
713 = mk_easy_FunBind loc unsafeIndex_RDR
714 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
716 -- We need to reverse the order we consider the components in
718 -- range (l,u) !! index (l,u) i == i -- when i is in range
719 -- (from http://haskell.org/onlinereport/ix.html) holds.
720 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
722 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
723 mk_index [] = nlHsIntLit 0
724 mk_index [(l,u,i)] = mk_one l u i
725 mk_index ((l,u,i) : rest)
730 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
731 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
732 ) times_RDR (mk_index rest)
735 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
739 = mk_easy_FunBind loc inRange_RDR
740 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
742 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
744 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
748 %************************************************************************
752 %************************************************************************
762 instance Read T where
766 do x <- ReadP.step Read.readPrec
767 Symbol "%%" <- Lex.lex
768 y <- ReadP.step Read.readPrec
772 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
773 -- Record construction binds even more tightly than application
774 do Ident "T1" <- Lex.lex
776 Ident "f1" <- Lex.lex
778 x <- ReadP.reset Read.readPrec
780 return (T1 { f1 = x }))
783 do Ident "T2" <- Lex.lexP
784 x <- ReadP.step Read.readPrec
788 readListPrec = readListPrecDefault
789 readList = readListDefault
793 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
795 gen_Read_binds get_fixity loc tycon
796 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
798 -----------------------------------------------------------------------
800 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
803 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
804 -----------------------------------------------------------------------
806 data_cons = tyConDataCons tycon
807 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
809 read_prec = mkVarBind loc readPrec_RDR
810 (nlHsApp (nlHsVar parens_RDR) read_cons)
812 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
813 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
816 = case nullary_cons of
818 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
819 (result_expr con [])]
820 _ -> [nlHsApp (nlHsVar choose_RDR)
821 (nlList (map mk_pair nullary_cons))]
823 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
827 read_non_nullary_con data_con
828 | is_infix = mk_parser infix_prec infix_stmts body
829 | is_record = mk_parser record_prec record_stmts body
830 -- Using these two lines instead allows the derived
831 -- read for infix and record bindings to read the prefix form
832 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
833 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
834 | otherwise = prefix_parser
836 body = result_expr data_con as_needed
837 con_str = data_con_str data_con
839 prefix_parser = mk_parser prefix_prec prefix_stmts body
840 prefix_stmts -- T a b c
841 = (if not (isSym con_str) then
842 [bindLex (ident_pat con_str)]
843 else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
846 infix_stmts -- a %% b, or a `T` b
849 then [bindLex (symbol_pat con_str)]
850 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
853 record_stmts -- T { f1 = a, f2 = b }
854 = [bindLex (ident_pat (wrapOpParens con_str)),
856 ++ concat (intersperse [read_punc ","] field_stmts)
859 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
861 con_arity = dataConSourceArity data_con
862 labels = dataConFieldLabels data_con
863 dc_nm = getName data_con
864 is_infix = dataConIsInfix data_con
865 is_record = length labels > 0
866 as_needed = take con_arity as_RDRs
867 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
868 (read_a1:read_a2:_) = read_args
870 prefix_prec = appPrecedence
871 infix_prec = getPrecedence get_fixity dc_nm
872 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
873 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
875 ------------------------------------------------------------------------
877 ------------------------------------------------------------------------
878 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
879 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
880 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
881 con_app con as = nlHsVarApps (getRdrName con) as -- con as
882 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
884 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
885 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
886 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
888 data_con_str con = occNameString (getOccName con)
890 read_punc c = bindLex (punc_pat c)
892 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
893 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
895 read_field lbl a = read_lbl lbl ++
897 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
899 -- When reading field labels we might encounter
904 read_lbl lbl | isSym lbl_str
906 bindLex (symbol_pat lbl_str),
909 = [bindLex (ident_pat lbl_str)]
911 lbl_str = occNameString (getOccName lbl)
915 %************************************************************************
919 %************************************************************************
925 data Tree a = Leaf a | Tree a :^: Tree a
927 instance (Show a) => Show (Tree a) where
929 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
931 showStr = showString "Leaf " . showsPrec (app_prec+1) m
933 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
935 showStr = showsPrec (up_prec+1) u .
937 showsPrec (up_prec+1) v
938 -- Note: right-associativity of :^: ignored
940 up_prec = 5 -- Precedence of :^:
941 app_prec = 10 -- Application has precedence one more than
942 -- the most tightly-binding operator
945 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
947 gen_Show_binds get_fixity loc tycon
948 = (listToBag [shows_prec, show_list], [])
950 -----------------------------------------------------------------------
951 show_list = mkVarBind loc showList_RDR
952 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
953 -----------------------------------------------------------------------
954 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
957 | nullary_con = -- skip the showParen junk...
958 ASSERT(null bs_needed)
959 ([nlWildPat, con_pat], mk_showString_app con_str)
962 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
963 (nlHsPar (nested_compose_Expr show_thingies)))
965 data_con_RDR = getRdrName data_con
966 con_arity = dataConSourceArity data_con
967 bs_needed = take con_arity bs_RDRs
968 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
969 con_pat = nlConVarPat data_con_RDR bs_needed
970 nullary_con = con_arity == 0
971 labels = dataConFieldLabels data_con
972 lab_fields = length labels
973 record_syntax = lab_fields > 0
975 dc_nm = getName data_con
976 dc_occ_nm = getOccName data_con
977 con_str = occNameString dc_occ_nm
978 op_con_str = wrapOpParens con_str
979 backquote_str = wrapOpBackquotes con_str
982 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
983 | record_syntax = mk_showString_app (op_con_str ++ " {") :
984 show_record_args ++ [mk_showString_app "}"]
985 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
987 show_label l = mk_showString_app (nm ++ " = ")
988 -- Note the spaces around the "=" sign. If we don't have them
989 -- then we get Foo { x=-1 } and the "=-" parses as a single
990 -- lexeme. Only the space after the '=' is necessary, but
991 -- it seems tidier to have them both sides.
993 occ_nm = getOccName l
994 nm = wrapOpParens (occNameString occ_nm)
996 show_args = zipWith show_arg bs_needed arg_tys
997 (show_arg1:show_arg2:_) = show_args
998 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1000 -- Assumption for record syntax: no of fields == no of labelled fields
1001 -- (and in same order)
1002 show_record_args = concat $
1003 intersperse [mk_showString_app ", "] $
1004 [ [show_label lbl, arg]
1005 | (lbl,arg) <- zipEqual "gen_Show_binds"
1008 -- Generates (showsPrec p x) for argument x, but it also boxes
1009 -- the argument first if necessary. Note that this prints unboxed
1010 -- things without any '#' decorations; could change that if need be
1011 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1012 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1015 is_infix = dataConIsInfix data_con
1016 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1017 arg_prec | record_syntax = 0 -- Record fields don't need parens
1018 | otherwise = con_prec_plus_one
1020 wrapOpParens :: String -> String
1021 wrapOpParens s | isSym s = '(' : s ++ ")"
1024 wrapOpBackquotes :: String -> String
1025 wrapOpBackquotes s | isSym s = s
1026 | otherwise = '`' : s ++ "`"
1028 isSym :: String -> Bool
1030 isSym (c : _) = startsVarSym c || startsConSym c
1032 mk_showString_app :: String -> LHsExpr RdrName
1033 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1037 getPrec :: Bool -> FixityEnv -> Name -> Integer
1038 getPrec is_infix get_fixity nm
1039 | not is_infix = appPrecedence
1040 | otherwise = getPrecedence get_fixity nm
1042 appPrecedence :: Integer
1043 appPrecedence = fromIntegral maxPrecedence + 1
1044 -- One more than the precedence of the most
1045 -- tightly-binding operator
1047 getPrecedence :: FixityEnv -> Name -> Integer
1048 getPrecedence get_fixity nm
1049 = case lookupFixity get_fixity nm of
1050 Fixity x _assoc -> fromIntegral x
1051 -- NB: the Report says that associativity is not taken
1052 -- into account for either Read or Show; hence we
1053 -- ignore associativity here
1057 %************************************************************************
1059 \subsection{Typeable}
1061 %************************************************************************
1069 instance Typeable2 T where
1070 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1072 We are passed the Typeable2 class as well as T
1075 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1076 gen_Typeable_binds loc tycon
1079 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1081 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1083 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1085 mk_typeOf_RDR :: TyCon -> RdrName
1086 -- Use the arity of the TyCon to make the right typeOfn function
1087 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1089 arity = tyConArity tycon
1090 suffix | arity == 0 = ""
1091 | otherwise = show arity
1096 %************************************************************************
1100 %************************************************************************
1104 data T a b = T1 a b | T2
1108 $cT1 = mkDataCon $dT "T1" Prefix
1109 $cT2 = mkDataCon $dT "T2" Prefix
1110 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1111 -- the [] is for field labels.
1113 instance (Data a, Data b) => Data (T a b) where
1114 gfoldl k z (T1 a b) = z T `k` a `k` b
1115 gfoldl k z T2 = z T2
1116 -- ToDo: add gmapT,Q,M, gfoldr
1118 gunfold k z c = case conIndex c of
1119 I# 1# -> k (k (z T1))
1122 toConstr (T1 _ _) = $cT1
1128 gen_Data_binds :: SrcSpan
1130 -> (LHsBinds RdrName, -- The method bindings
1131 DerivAuxBinds) -- Auxiliary bindings
1132 gen_Data_binds loc tycon
1133 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1134 -- Auxiliary definitions: the data type and constructors
1135 DerivAuxBind datatype_bind : map mk_con_bind data_cons)
1137 tycon_name = tyConName tycon
1138 data_cons = tyConDataCons tycon
1139 n_cons = length data_cons
1140 one_constr = n_cons == 1
1143 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1144 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1145 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1148 con_name = getRdrName con
1149 as_needed = take (dataConSourceArity con) as_RDRs
1150 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1152 ------------ gunfold
1153 gunfold_bind = mk_FunBind loc
1155 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1159 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1160 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1161 (map gunfold_alt data_cons)
1163 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1164 mk_unfold_rhs dc = foldr nlHsApp
1165 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1166 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1168 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1169 -- redundant test, and annoying warning
1170 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1171 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1175 ------------ toConstr
1176 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1177 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1179 ------------ dataTypeOf
1180 dataTypeOf_bind = mk_easy_FunBind
1184 (nlHsVar data_type_name)
1187 data_type_name = mkAuxBinderName tycon_name mkDataTOcc
1188 datatype_bind = mkVarBind
1191 ( nlHsVar mkDataType_RDR
1192 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1193 `nlHsApp` nlList constrs
1195 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1198 ------------ $cT1 etc
1199 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1200 mk_con_bind dc = DerivAuxBind $
1204 (nlHsApps mkConstr_RDR (constr_args dc))
1206 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1207 nlHsVar data_type_name, -- DataType
1208 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1209 nlList labels, -- Field labels
1210 nlHsVar fixity] -- Fixity
1212 labels = map (nlHsLit . mkHsString . getOccString)
1213 (dataConFieldLabels dc)
1214 dc_occ = getOccName dc
1215 is_infix = isDataSymOcc dc_occ
1216 fixity | is_infix = infix_RDR
1217 | otherwise = prefix_RDR
1219 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1220 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName
1221 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1222 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1223 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1224 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1225 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1226 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1227 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1228 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1229 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1232 %************************************************************************
1234 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1236 %************************************************************************
1241 con2tag_Foo :: Foo ... -> Int#
1242 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1243 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1246 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1250 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1252 genAuxBind _loc (DerivAuxBind bind)
1255 genAuxBind loc (GenCon2Tag tycon)
1256 | lots_of_constructors
1257 = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1260 = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1263 rdr_name = con2tag_RDR tycon
1265 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1266 -- We can't use gerRdrName because that makes an Exact RdrName
1267 -- and we can't put them in the LocalRdrEnv
1269 -- Give a signature to the bound variable, so
1270 -- that the case expression generated by getTag is
1271 -- monomorphic. In the push-enter model we get better code.
1272 get_tag_rhs = L loc $ ExprWithTySig
1273 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1274 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1275 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1277 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1279 nlHsTyVar (getRdrName intPrimTyCon)
1281 lots_of_constructors = tyConFamilySize tycon > 8
1282 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1283 -- but we don't do vectored returns any more.
1285 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1286 mk_stuff con = ([nlWildConPat con],
1287 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1289 genAuxBind loc (GenTag2Con tycon)
1290 = mk_FunBind loc rdr_name
1291 [([nlConVarPat intDataCon_RDR [a_RDR]],
1292 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1293 (nlHsTyVar (getRdrName tycon))))]
1295 rdr_name = tag2con_RDR tycon
1297 genAuxBind loc (GenMaxTag tycon)
1298 = mkVarBind loc rdr_name
1299 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1301 rdr_name = maxtag_RDR tycon
1302 max_tag = case (tyConDataCons tycon) of
1303 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1306 %************************************************************************
1308 \subsection{Utility bits for generating bindings}
1310 %************************************************************************
1313 ToDo: Better SrcLocs.
1317 LHsExpr RdrName -- What to do for equality
1318 -> LHsExpr RdrName -> LHsExpr RdrName
1320 careful_compare_Case :: -- checks for primitive types...
1321 TyCon -- The tycon we are deriving for
1323 -> LHsExpr RdrName -- What to do for equality
1324 -> LHsExpr RdrName -> LHsExpr RdrName
1327 cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1328 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1329 -- Was: compare_gen_Case cmp_eq_RDR
1331 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1332 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1333 compare_gen_Case eq a b -- General case
1334 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1335 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1336 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1337 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1339 careful_compare_Case tycon ty eq a b
1340 | not (isUnLiftedType ty)
1341 = compare_gen_Case eq a b
1342 | otherwise -- We have to do something special for primitive things...
1343 = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter
1344 ltTag_Expr -- is true less often, so putting it first would
1345 -- mean more tests (dynamically)
1346 (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1348 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1349 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1352 box_if_necy :: String -- The class involved
1353 -> TyCon -- The tycon involved
1354 -> LHsExpr RdrName -- The argument
1355 -> Type -- The argument type
1356 -> LHsExpr RdrName -- Boxed version of the arg
1357 box_if_necy cls_str tycon arg arg_ty
1358 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1361 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1363 assoc_ty_id :: String -- The class involved
1364 -> TyCon -- The tycon involved
1365 -> [(Type,a)] -- The table
1367 -> a -- The result of the lookup
1368 assoc_ty_id cls_str _ tbl ty
1369 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1370 text "for primitive type" <+> ppr ty)
1371 | otherwise = head res
1373 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1375 eq_op_tbl :: [(Type, PrimOp)]
1377 [(charPrimTy, CharEqOp)
1378 ,(intPrimTy, IntEqOp)
1379 ,(wordPrimTy, WordEqOp)
1380 ,(addrPrimTy, AddrEqOp)
1381 ,(floatPrimTy, FloatEqOp)
1382 ,(doublePrimTy, DoubleEqOp)
1385 lt_op_tbl :: [(Type, PrimOp)]
1387 [(charPrimTy, CharLtOp)
1388 ,(intPrimTy, IntLtOp)
1389 ,(wordPrimTy, WordLtOp)
1390 ,(addrPrimTy, AddrLtOp)
1391 ,(floatPrimTy, FloatLtOp)
1392 ,(doublePrimTy, DoubleLtOp)
1395 box_con_tbl :: [(Type, RdrName)]
1397 [(charPrimTy, getRdrName charDataCon)
1398 ,(intPrimTy, getRdrName intDataCon)
1399 ,(wordPrimTy, wordDataCon_RDR)
1400 ,(floatPrimTy, getRdrName floatDataCon)
1401 ,(doublePrimTy, getRdrName doubleDataCon)
1404 -----------------------------------------------------------------------
1406 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1407 and_Expr a b = genOpApp a and_RDR b
1409 -----------------------------------------------------------------------
1411 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1412 eq_Expr tycon ty a b = genOpApp a eq_op b
1415 | not (isUnLiftedType ty) = eq_RDR
1416 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1417 -- we have to do something special for primitive things...
1421 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1422 untag_Expr _ [] expr = expr
1423 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1424 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1425 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1427 cmp_tags_Expr :: RdrName -- Comparison op
1428 -> RdrName -> RdrName -- Things to compare
1429 -> LHsExpr RdrName -- What to return if true
1430 -> LHsExpr RdrName -- What to return if false
1433 cmp_tags_Expr op a b true_case false_case
1434 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1437 :: LHsExpr RdrName -> LHsExpr RdrName
1439 enum_from_then_to_Expr
1440 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1443 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1444 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1447 :: LHsExpr RdrName -> LHsExpr RdrName
1450 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1452 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1454 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1455 nested_compose_Expr [e] = parenify e
1456 nested_compose_Expr (e:es)
1457 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1459 -- impossible_Expr is used in case RHSs that should never happen.
1460 -- We generate these to keep the desugarer from complaining that they *might* happen!
1461 impossible_Expr :: LHsExpr RdrName
1462 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1464 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1465 -- method. It is currently only used by Enum.{succ,pred}
1466 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1467 illegal_Expr meth tp msg =
1468 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1470 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1471 -- to include the value of a_RDR in the error string.
1472 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1473 illegal_toEnum_tag tp maxtag =
1474 nlHsApp (nlHsVar error_RDR)
1475 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1476 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1477 (nlHsApp (nlHsApp (nlHsApp
1478 (nlHsVar showsPrec_RDR)
1482 (nlHsVar append_RDR)
1483 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1484 (nlHsApp (nlHsApp (nlHsApp
1485 (nlHsVar showsPrec_RDR)
1488 (nlHsLit (mkHsString ")"))))))
1490 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1491 parenify e@(L _ (HsVar _)) = e
1492 parenify e = mkHsPar e
1494 -- genOpApp wraps brackets round the operator application, so that the
1495 -- renamer won't subsequently try to re-associate it.
1496 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1497 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1501 a_RDR, b_RDR, c_RDR, d_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR,
1502 cmp_eq_RDR :: RdrName
1503 a_RDR = mkVarUnqual (fsLit "a")
1504 b_RDR = mkVarUnqual (fsLit "b")
1505 c_RDR = mkVarUnqual (fsLit "c")
1506 d_RDR = mkVarUnqual (fsLit "d")
1507 k_RDR = mkVarUnqual (fsLit "k")
1508 z_RDR = mkVarUnqual (fsLit "z")
1509 ah_RDR = mkVarUnqual (fsLit "a#")
1510 bh_RDR = mkVarUnqual (fsLit "b#")
1511 ch_RDR = mkVarUnqual (fsLit "c#")
1512 dh_RDR = mkVarUnqual (fsLit "d#")
1513 cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq")
1515 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1516 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1517 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1518 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1520 a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1521 false_Expr, true_Expr :: LHsExpr RdrName
1522 a_Expr = nlHsVar a_RDR
1523 b_Expr = nlHsVar b_RDR
1524 c_Expr = nlHsVar c_RDR
1525 ltTag_Expr = nlHsVar ltTag_RDR
1526 eqTag_Expr = nlHsVar eqTag_RDR
1527 gtTag_Expr = nlHsVar gtTag_RDR
1528 false_Expr = nlHsVar false_RDR
1529 true_Expr = nlHsVar true_RDR
1531 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
1532 a_Pat = nlVarPat a_RDR
1533 b_Pat = nlVarPat b_RDR
1534 c_Pat = nlVarPat c_RDR
1535 d_Pat = nlVarPat d_RDR
1536 k_Pat = nlVarPat k_RDR
1537 z_Pat = nlVarPat z_RDR
1539 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1540 -- Generates Orig s RdrName, for the binding positions
1541 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1542 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1543 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1545 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1546 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1548 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1549 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1550 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1551 -- But: (a) that does not work well for standalone-deriving
1552 -- (b) an unqualified name is just fine, provided it can't clash with user code
1555 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1556 PrelNames, so PrelNames can't import PrimOp.
1559 primOpRdrName :: PrimOp -> RdrName
1560 primOpRdrName op = getRdrName (primOpId op)
1562 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
1563 tagToEnum_RDR :: RdrName
1564 minusInt_RDR = primOpRdrName IntSubOp
1565 eqInt_RDR = primOpRdrName IntEqOp
1566 ltInt_RDR = primOpRdrName IntLtOp
1567 geInt_RDR = primOpRdrName IntGeOp
1568 leInt_RDR = primOpRdrName IntLeOp
1569 tagToEnum_RDR = primOpRdrName TagToEnumOp
1571 error_RDR :: RdrName
1572 error_RDR = getRdrName eRROR_ID