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 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 = GenCon2Tag TyCon -- The con2Tag for given TyCon
61 | GenTag2Con TyCon -- ...ditto tag2Con
62 | GenMaxTag TyCon -- ...and maxTag
64 -- Scrap your boilerplate
65 | MkDataCon DataCon -- For constructor C we get $cC :: Constr
66 | MkTyCon TyCon -- For tycon T we get $tT :: DataType
69 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
70 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
71 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
72 isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2
73 isDupAux (MkDataCon dc1) (MkDataCon dc2) = dc1 == dc2
74 isDupAux (MkTyCon tc1) (MkTyCon tc2) = tc1 == tc2
79 %************************************************************************
83 %************************************************************************
85 Here are the heuristics for the code we generate for @Eq@:
88 Let's assume we have a data type with some (possibly zero) nullary
89 data constructors and some ordinary, non-nullary ones (the rest,
90 also possibly zero of them). Here's an example, with both \tr{N}ullary
91 and \tr{O}rdinary data cons.
93 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
97 For the ordinary constructors (if any), we emit clauses to do The
101 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
102 (==) (O2 a1) (O2 a2) = a1 == a2
103 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
106 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
107 \tr{a2} are \tr{Float#}s, then we have to generate
109 case (a1 `eqFloat#` a2) of
112 for that particular test.
115 If there are any nullary constructors, we emit a catch-all clause of
119 (==) a b = case (con2tag_Foo a) of { a# ->
120 case (con2tag_Foo b) of { b# ->
121 case (a# ==# b#) of {
126 If there aren't any nullary constructors, we emit a simpler
133 For the @(/=)@ method, we normally just use the default method.
135 If the type is an enumeration type, we could/may/should? generate
136 special code that calls @con2tag_Foo@, much like for @(==)@ shown
140 We thought about doing this: If we're also deriving @Ord@ for this
143 instance ... Eq (Foo ...) where
144 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
145 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
147 However, that requires that \tr{Ord <whatever>} was put in the context
148 for the instance decl, which it probably wasn't, so the decls
149 produced don't get through the typechecker.
154 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
155 gen_Eq_binds loc tycon
156 = (method_binds, aux_binds)
158 (nullary_cons, nonnullary_cons)
159 | isNewTyCon tycon = ([], tyConDataCons tycon)
160 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
162 no_nullary_cons = null nullary_cons
164 rest | no_nullary_cons
165 = case tyConSingleDataCon_maybe tycon of
167 Nothing -> -- if cons don't match, then False
168 [([nlWildPat, nlWildPat], false_Expr)]
169 | otherwise -- calc. and compare the tags
171 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
172 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
174 aux_binds | no_nullary_cons = []
175 | otherwise = [GenCon2Tag tycon]
177 method_binds = listToBag [
178 mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
179 mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
180 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
182 ------------------------------------------------------------------
185 con1_pat = nlConVarPat data_con_RDR as_needed
186 con2_pat = nlConVarPat data_con_RDR bs_needed
188 data_con_RDR = getRdrName data_con
189 con_arity = length tys_needed
190 as_needed = take con_arity as_RDRs
191 bs_needed = take con_arity bs_RDRs
192 tys_needed = dataConOrigArgTys data_con
194 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
196 nested_eq_expr [] [] [] = true_Expr
197 nested_eq_expr tys as bs
198 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
200 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
203 %************************************************************************
207 %************************************************************************
209 For a derived @Ord@, we concentrate our attentions on @compare@
211 compare :: a -> a -> Ordering
212 data Ordering = LT | EQ | GT deriving ()
215 We will use the same example data type as above:
217 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
222 We do all the other @Ord@ methods with calls to @compare@:
224 instance ... (Ord <wurble> <wurble>) where
225 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
226 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
227 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
228 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
230 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
231 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
233 -- compare to come...
237 @compare@ always has two parts. First, we use the compared
238 data-constructors' tags to deal with the case of different
241 compare a b = case (con2tag_Foo a) of { a# ->
242 case (con2tag_Foo b) of { b# ->
243 case (a# ==# b#) of {
245 False -> case (a# <# b#) of
250 cmp_eq = ... to come ...
254 We are only left with the ``help'' function @cmp_eq@, to deal with
255 comparing data constructors with the same tag.
257 For the ordinary constructors (if any), we emit the sorta-obvious
258 compare-style stuff; for our example:
260 cmp_eq (O1 a1 b1) (O1 a2 b2)
261 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
263 cmp_eq (O2 a1) (O2 a2)
266 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
267 = case (compare a1 a2) of {
270 EQ -> case compare b1 b2 of {
278 Again, we must be careful about unlifted comparisons. For example,
279 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
283 cmp_eq lt eq gt (O2 a1) (O2 a2)
285 -- or maybe the unfolded equivalent
289 For the remaining nullary constructors, we already know that the
296 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
300 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
302 gen_Ord_binds loc tycon
303 | Just (con, prim_tc) <- primWrapperType_maybe tycon
304 = gen_PrimOrd_binds con prim_tc
307 = (unitBag compare, aux_binds)
308 -- `AndMonoBinds` compare
309 -- The default declaration in PrelBase handles this
311 aux_binds | single_con_type = []
312 | otherwise = [GenCon2Tag tycon]
314 compare = L loc (mkFunBind (L 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 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 :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
472 gen_Enum_binds loc tycon
473 = (method_binds, aux_binds)
475 method_binds = listToBag [
483 aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
485 occ_nm = getOccString tycon
488 = mk_easy_FunBind loc succ_RDR [a_Pat] $
489 untag_Expr tycon [(a_RDR, ah_RDR)] $
490 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
491 nlHsVarApps intDataCon_RDR [ah_RDR]])
492 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
493 (nlHsApp (nlHsVar (tag2con_RDR tycon))
494 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
498 = mk_easy_FunBind loc pred_RDR [a_Pat] $
499 untag_Expr tycon [(a_RDR, ah_RDR)] $
500 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
501 nlHsVarApps intDataCon_RDR [ah_RDR]])
502 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
503 (nlHsApp (nlHsVar (tag2con_RDR tycon))
504 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
505 nlHsLit (HsInt (-1))]))
508 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
509 nlHsIf (nlHsApps and_RDR
510 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
511 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
512 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
513 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
516 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
517 untag_Expr tycon [(a_RDR, ah_RDR)] $
519 [nlHsVar (tag2con_RDR tycon),
520 nlHsPar (enum_from_to_Expr
521 (nlHsVarApps intDataCon_RDR [ah_RDR])
522 (nlHsVar (maxtag_RDR tycon)))]
525 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
526 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
527 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
528 nlHsPar (enum_from_then_to_Expr
529 (nlHsVarApps intDataCon_RDR [ah_RDR])
530 (nlHsVarApps intDataCon_RDR [bh_RDR])
531 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
532 nlHsVarApps intDataCon_RDR [bh_RDR]])
534 (nlHsVar (maxtag_RDR tycon))
538 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
539 untag_Expr tycon [(a_RDR, ah_RDR)] $
540 (nlHsVarApps intDataCon_RDR [ah_RDR])
543 %************************************************************************
547 %************************************************************************
550 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
551 gen_Bounded_binds loc tycon
552 | isEnumerationTyCon tycon
553 = (listToBag [ min_bound_enum, max_bound_enum ], [])
555 = ASSERT(isSingleton data_cons)
556 (listToBag [ min_bound_1con, max_bound_1con ], [])
558 data_cons = tyConDataCons tycon
560 ----- enum-flavored: ---------------------------
561 min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
562 max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
564 data_con_1 = head data_cons
565 data_con_N = last data_cons
566 data_con_1_RDR = getRdrName data_con_1
567 data_con_N_RDR = getRdrName data_con_N
569 ----- single-constructor-flavored: -------------
570 arity = dataConSourceArity data_con_1
572 min_bound_1con = mkVarBind loc minBound_RDR $
573 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
574 max_bound_1con = mkVarBind loc maxBound_RDR $
575 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
578 %************************************************************************
582 %************************************************************************
584 Deriving @Ix@ is only possible for enumeration types and
585 single-constructor types. We deal with them in turn.
587 For an enumeration type, e.g.,
589 data Foo ... = N1 | N2 | ... | Nn
591 things go not too differently from @Enum@:
593 instance ... Ix (Foo ...) where
595 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
599 = case (con2tag_Foo a) of { a# ->
600 case (con2tag_Foo b) of { b# ->
601 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
604 -- Generate code for unsafeIndex, becuase using index leads
605 -- to lots of redundant range tests
606 unsafeIndex c@(a, b) d
607 = case (con2tag_Foo d -# con2tag_Foo a) of
612 p_tag = con2tag_Foo c
614 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
618 = case (con2tag_Foo a) of { a_tag ->
619 case (con2tag_Foo b) of { b_tag ->
620 case (con2tag_Foo c) of { c_tag ->
621 if (c_tag >=# a_tag) then
627 (modulo suitable case-ification to handle the unlifted tags)
629 For a single-constructor type (NB: this includes all tuples), e.g.,
631 data Foo ... = MkFoo a b Int Double c c
633 we follow the scheme given in Figure~19 of the Haskell~1.2 report
637 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
639 gen_Ix_binds loc tycon
640 | isEnumerationTyCon tycon
641 = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
643 = (single_con_ixes, [GenCon2Tag tycon])
645 --------------------------------------------------------------
646 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
649 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
650 untag_Expr tycon [(a_RDR, ah_RDR)] $
651 untag_Expr tycon [(b_RDR, bh_RDR)] $
652 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
653 nlHsPar (enum_from_to_Expr
654 (nlHsVarApps intDataCon_RDR [ah_RDR])
655 (nlHsVarApps intDataCon_RDR [bh_RDR]))
658 = mk_easy_FunBind loc unsafeIndex_RDR
659 [noLoc (AsPat (noLoc c_RDR)
660 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
662 untag_Expr tycon [(a_RDR, ah_RDR)] (
663 untag_Expr tycon [(d_RDR, dh_RDR)] (
665 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
668 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
669 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
674 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
675 untag_Expr tycon [(a_RDR, ah_RDR)] (
676 untag_Expr tycon [(b_RDR, bh_RDR)] (
677 untag_Expr tycon [(c_RDR, ch_RDR)] (
678 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
679 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
684 --------------------------------------------------------------
686 = listToBag [single_con_range, single_con_index, single_con_inRange]
689 = case tyConSingleDataCon_maybe tycon of -- just checking...
690 Nothing -> panic "get_Ix_binds"
691 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
692 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
695 con_arity = dataConSourceArity data_con
696 data_con_RDR = getRdrName data_con
698 as_needed = take con_arity as_RDRs
699 bs_needed = take con_arity bs_RDRs
700 cs_needed = take con_arity cs_RDRs
702 con_pat xs = nlConVarPat data_con_RDR xs
703 con_expr = nlHsVarApps data_con_RDR cs_needed
705 --------------------------------------------------------------
707 = mk_easy_FunBind loc range_RDR
708 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
709 nlHsDo ListComp stmts con_expr
711 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
713 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
714 (nlHsApp (nlHsVar range_RDR)
715 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
719 = mk_easy_FunBind loc unsafeIndex_RDR
720 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
722 -- We need to reverse the order we consider the components in
724 -- range (l,u) !! index (l,u) i == i -- when i is in range
725 -- (from http://haskell.org/onlinereport/ix.html) holds.
726 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
728 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
729 mk_index [] = nlHsIntLit 0
730 mk_index [(l,u,i)] = mk_one l u i
731 mk_index ((l,u,i) : rest)
736 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
737 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
738 ) times_RDR (mk_index rest)
741 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
745 = mk_easy_FunBind loc inRange_RDR
746 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
748 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
750 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
754 %************************************************************************
758 %************************************************************************
768 instance Read T where
772 do x <- ReadP.step Read.readPrec
773 Symbol "%%" <- Lex.lex
774 y <- ReadP.step Read.readPrec
778 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
779 -- Record construction binds even more tightly than application
780 do Ident "T1" <- Lex.lex
782 Ident "f1" <- Lex.lex
784 x <- ReadP.reset Read.readPrec
786 return (T1 { f1 = x }))
789 do Ident "T2" <- Lex.lexP
790 x <- ReadP.step Read.readPrec
794 readListPrec = readListPrecDefault
795 readList = readListDefault
799 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
801 gen_Read_binds get_fixity loc tycon
802 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
804 -----------------------------------------------------------------------
806 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
809 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
810 -----------------------------------------------------------------------
812 data_cons = tyConDataCons tycon
813 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
815 read_prec = mkVarBind loc readPrec_RDR
816 (nlHsApp (nlHsVar parens_RDR) read_cons)
818 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
819 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
822 = case nullary_cons of
824 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
825 (result_expr con [])]
826 _ -> [nlHsApp (nlHsVar choose_RDR)
827 (nlList (map mk_pair nullary_cons))]
829 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
833 read_non_nullary_con data_con
834 | is_infix = mk_parser infix_prec infix_stmts body
835 | is_record = mk_parser record_prec record_stmts body
836 -- Using these two lines instead allows the derived
837 -- read for infix and record bindings to read the prefix form
838 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
839 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
840 | otherwise = prefix_parser
842 body = result_expr data_con as_needed
843 con_str = data_con_str data_con
845 prefix_parser = mk_parser prefix_prec prefix_stmts body
846 prefix_stmts -- T a b c
847 = (if not (isSym con_str) then
848 [bindLex (ident_pat con_str)]
849 else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
852 infix_stmts -- a %% b, or a `T` b
855 then [bindLex (symbol_pat con_str)]
856 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
859 record_stmts -- T { f1 = a, f2 = b }
860 = [bindLex (ident_pat (wrapOpParens con_str)),
862 ++ concat (intersperse [read_punc ","] field_stmts)
865 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
867 con_arity = dataConSourceArity data_con
868 labels = dataConFieldLabels data_con
869 dc_nm = getName data_con
870 is_infix = dataConIsInfix data_con
871 is_record = length labels > 0
872 as_needed = take con_arity as_RDRs
873 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
874 (read_a1:read_a2:_) = read_args
876 prefix_prec = appPrecedence
877 infix_prec = getPrecedence get_fixity dc_nm
878 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
879 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
881 ------------------------------------------------------------------------
883 ------------------------------------------------------------------------
884 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
885 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
886 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
887 con_app con as = nlHsVarApps (getRdrName con) as -- con as
888 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
890 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
891 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
892 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
894 data_con_str con = occNameString (getOccName con)
896 read_punc c = bindLex (punc_pat c)
898 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
899 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
901 read_field lbl a = read_lbl lbl ++
903 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
905 -- When reading field labels we might encounter
910 read_lbl lbl | isSym lbl_str
912 bindLex (symbol_pat lbl_str),
915 = [bindLex (ident_pat lbl_str)]
917 lbl_str = occNameString (getOccName lbl)
921 %************************************************************************
925 %************************************************************************
931 data Tree a = Leaf a | Tree a :^: Tree a
933 instance (Show a) => Show (Tree a) where
935 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
937 showStr = showString "Leaf " . showsPrec (app_prec+1) m
939 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
941 showStr = showsPrec (up_prec+1) u .
943 showsPrec (up_prec+1) v
944 -- Note: right-associativity of :^: ignored
946 up_prec = 5 -- Precedence of :^:
947 app_prec = 10 -- Application has precedence one more than
948 -- the most tightly-binding operator
951 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
953 gen_Show_binds get_fixity loc tycon
954 = (listToBag [shows_prec, show_list], [])
956 -----------------------------------------------------------------------
957 show_list = mkVarBind loc showList_RDR
958 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
959 -----------------------------------------------------------------------
960 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
963 | nullary_con = -- skip the showParen junk...
964 ASSERT(null bs_needed)
965 ([nlWildPat, con_pat], mk_showString_app con_str)
968 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
969 (nlHsPar (nested_compose_Expr show_thingies)))
971 data_con_RDR = getRdrName data_con
972 con_arity = dataConSourceArity data_con
973 bs_needed = take con_arity bs_RDRs
974 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
975 con_pat = nlConVarPat data_con_RDR bs_needed
976 nullary_con = con_arity == 0
977 labels = dataConFieldLabels data_con
978 lab_fields = length labels
979 record_syntax = lab_fields > 0
981 dc_nm = getName data_con
982 dc_occ_nm = getOccName data_con
983 con_str = occNameString dc_occ_nm
984 op_con_str = wrapOpParens con_str
985 backquote_str = wrapOpBackquotes con_str
988 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
989 | record_syntax = mk_showString_app (op_con_str ++ " {") :
990 show_record_args ++ [mk_showString_app "}"]
991 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
993 show_label l = mk_showString_app (nm ++ " = ")
994 -- Note the spaces around the "=" sign. If we don't have them
995 -- then we get Foo { x=-1 } and the "=-" parses as a single
996 -- lexeme. Only the space after the '=' is necessary, but
997 -- it seems tidier to have them both sides.
999 occ_nm = getOccName l
1000 nm = wrapOpParens (occNameString occ_nm)
1002 show_args = zipWith show_arg bs_needed arg_tys
1003 (show_arg1:show_arg2:_) = show_args
1004 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1006 -- Assumption for record syntax: no of fields == no of labelled fields
1007 -- (and in same order)
1008 show_record_args = concat $
1009 intersperse [mk_showString_app ", "] $
1010 [ [show_label lbl, arg]
1011 | (lbl,arg) <- zipEqual "gen_Show_binds"
1014 -- Generates (showsPrec p x) for argument x, but it also boxes
1015 -- the argument first if necessary. Note that this prints unboxed
1016 -- things without any '#' decorations; could change that if need be
1017 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1018 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1021 is_infix = dataConIsInfix data_con
1022 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1023 arg_prec | record_syntax = 0 -- Record fields don't need parens
1024 | otherwise = con_prec_plus_one
1026 wrapOpParens :: String -> String
1027 wrapOpParens s | isSym s = '(' : s ++ ")"
1030 wrapOpBackquotes :: String -> String
1031 wrapOpBackquotes s | isSym s = s
1032 | otherwise = '`' : s ++ "`"
1034 isSym :: String -> Bool
1036 isSym (c : _) = startsVarSym c || startsConSym c
1038 mk_showString_app :: String -> LHsExpr RdrName
1039 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1043 getPrec :: Bool -> FixityEnv -> Name -> Integer
1044 getPrec is_infix get_fixity nm
1045 | not is_infix = appPrecedence
1046 | otherwise = getPrecedence get_fixity nm
1048 appPrecedence :: Integer
1049 appPrecedence = fromIntegral maxPrecedence + 1
1050 -- One more than the precedence of the most
1051 -- tightly-binding operator
1053 getPrecedence :: FixityEnv -> Name -> Integer
1054 getPrecedence get_fixity nm
1055 = case lookupFixity get_fixity nm of
1056 Fixity x _assoc -> fromIntegral x
1057 -- NB: the Report says that associativity is not taken
1058 -- into account for either Read or Show; hence we
1059 -- ignore associativity here
1063 %************************************************************************
1065 \subsection{Typeable}
1067 %************************************************************************
1075 instance Typeable2 T where
1076 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1078 We are passed the Typeable2 class as well as T
1081 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1082 gen_Typeable_binds loc tycon
1085 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1087 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1089 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1091 mk_typeOf_RDR :: TyCon -> RdrName
1092 -- Use the arity of the TyCon to make the right typeOfn function
1093 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1095 arity = tyConArity tycon
1096 suffix | arity == 0 = ""
1097 | otherwise = show arity
1102 %************************************************************************
1106 %************************************************************************
1110 data T a b = T1 a b | T2
1114 $cT1 = mkDataCon $dT "T1" Prefix
1115 $cT2 = mkDataCon $dT "T2" Prefix
1116 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1117 -- the [] is for field labels.
1119 instance (Data a, Data b) => Data (T a b) where
1120 gfoldl k z (T1 a b) = z T `k` a `k` b
1121 gfoldl k z T2 = z T2
1122 -- ToDo: add gmapT,Q,M, gfoldr
1124 gunfold k z c = case conIndex c of
1125 I# 1# -> k (k (z T1))
1128 toConstr (T1 _ _) = $cT1
1134 gen_Data_binds :: SrcSpan
1136 -> (LHsBinds RdrName, -- The method bindings
1137 DerivAuxBinds) -- Auxiliary bindings
1138 gen_Data_binds loc tycon
1139 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1140 -- Auxiliary definitions: the data type and constructors
1141 MkTyCon tycon : map MkDataCon data_cons)
1143 data_cons = tyConDataCons tycon
1144 n_cons = length data_cons
1145 one_constr = n_cons == 1
1148 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1149 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1150 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1153 con_name = getRdrName con
1154 as_needed = take (dataConSourceArity con) as_RDRs
1155 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1157 ------------ gunfold
1158 gunfold_bind = mk_FunBind loc
1160 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1164 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1165 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1166 (map gunfold_alt data_cons)
1168 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1169 mk_unfold_rhs dc = foldr nlHsApp
1170 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1171 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1173 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1174 -- redundant test, and annoying warning
1175 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1176 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1180 ------------ toConstr
1181 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1182 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1184 ------------ dataTypeOf
1185 dataTypeOf_bind = mk_easy_FunBind
1189 (nlHsVar (mk_data_type_name tycon))
1192 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1193 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName
1194 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1195 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1196 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1197 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1198 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1199 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1200 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1201 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1202 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1205 %************************************************************************
1207 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1209 %************************************************************************
1214 con2tag_Foo :: Foo ... -> Int#
1215 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1216 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1219 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1223 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1224 genAuxBind loc (GenCon2Tag tycon)
1225 | lots_of_constructors
1226 = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1229 = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1232 rdr_name = con2tag_RDR tycon
1234 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1235 -- We can't use gerRdrName because that makes an Exact RdrName
1236 -- and we can't put them in the LocalRdrEnv
1238 -- Give a signature to the bound variable, so
1239 -- that the case expression generated by getTag is
1240 -- monomorphic. In the push-enter model we get better code.
1241 get_tag_rhs = L loc $ ExprWithTySig
1242 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1243 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1244 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1246 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1248 nlHsTyVar (getRdrName intPrimTyCon)
1250 lots_of_constructors = tyConFamilySize tycon > 8
1251 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1252 -- but we don't do vectored returns any more.
1254 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1255 mk_stuff con = ([nlWildConPat con],
1256 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1258 genAuxBind loc (GenTag2Con tycon)
1259 = mk_FunBind loc rdr_name
1260 [([nlConVarPat intDataCon_RDR [a_RDR]],
1261 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1262 (nlHsTyVar (getRdrName tycon))))]
1264 rdr_name = tag2con_RDR tycon
1266 genAuxBind loc (GenMaxTag tycon)
1267 = mkVarBind loc rdr_name
1268 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1270 rdr_name = maxtag_RDR tycon
1271 max_tag = case (tyConDataCons tycon) of
1272 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1274 genAuxBind loc (MkTyCon tycon) -- $dT
1275 = mkVarBind loc (mk_data_type_name tycon)
1276 ( nlHsVar mkDataType_RDR
1277 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1278 `nlHsApp` nlList constrs )
1280 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1282 genAuxBind loc (MkDataCon dc) -- $cT1 etc
1283 = mkVarBind loc (mk_constr_name dc)
1284 (nlHsApps mkConstr_RDR constr_args)
1287 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1288 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1289 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1290 nlList labels, -- Field labels
1291 nlHsVar fixity] -- Fixity
1293 labels = map (nlHsLit . mkHsString . getOccString)
1294 (dataConFieldLabels dc)
1295 dc_occ = getOccName dc
1296 is_infix = isDataSymOcc dc_occ
1297 fixity | is_infix = infix_RDR
1298 | otherwise = prefix_RDR
1300 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1301 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1303 mk_constr_name :: DataCon -> RdrName -- "$cC"
1304 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1307 %************************************************************************
1309 \subsection{Utility bits for generating bindings}
1311 %************************************************************************
1314 ToDo: Better SrcLocs.
1318 LHsExpr RdrName -- What to do for equality
1319 -> LHsExpr RdrName -> LHsExpr RdrName
1321 careful_compare_Case :: -- checks for primitive types...
1322 TyCon -- The tycon we are deriving for
1324 -> LHsExpr RdrName -- What to do for equality
1325 -> LHsExpr RdrName -> LHsExpr RdrName
1328 cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1329 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1330 -- Was: compare_gen_Case cmp_eq_RDR
1332 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1333 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1334 compare_gen_Case eq a b -- General case
1335 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1336 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1337 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1338 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1340 careful_compare_Case tycon ty eq a b
1341 | not (isUnLiftedType ty)
1342 = compare_gen_Case eq a b
1343 | otherwise -- We have to do something special for primitive things...
1344 = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter
1345 ltTag_Expr -- is true less often, so putting it first would
1346 -- mean more tests (dynamically)
1347 (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1349 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1350 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1353 box_if_necy :: String -- The class involved
1354 -> TyCon -- The tycon involved
1355 -> LHsExpr RdrName -- The argument
1356 -> Type -- The argument type
1357 -> LHsExpr RdrName -- Boxed version of the arg
1358 box_if_necy cls_str tycon arg arg_ty
1359 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1362 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1364 assoc_ty_id :: String -- The class involved
1365 -> TyCon -- The tycon involved
1366 -> [(Type,a)] -- The table
1368 -> a -- The result of the lookup
1369 assoc_ty_id cls_str _ tbl ty
1370 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1371 text "for primitive type" <+> ppr ty)
1372 | otherwise = head res
1374 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1376 eq_op_tbl :: [(Type, PrimOp)]
1378 [(charPrimTy, CharEqOp)
1379 ,(intPrimTy, IntEqOp)
1380 ,(wordPrimTy, WordEqOp)
1381 ,(addrPrimTy, AddrEqOp)
1382 ,(floatPrimTy, FloatEqOp)
1383 ,(doublePrimTy, DoubleEqOp)
1386 lt_op_tbl :: [(Type, PrimOp)]
1388 [(charPrimTy, CharLtOp)
1389 ,(intPrimTy, IntLtOp)
1390 ,(wordPrimTy, WordLtOp)
1391 ,(addrPrimTy, AddrLtOp)
1392 ,(floatPrimTy, FloatLtOp)
1393 ,(doublePrimTy, DoubleLtOp)
1396 box_con_tbl :: [(Type, RdrName)]
1398 [(charPrimTy, getRdrName charDataCon)
1399 ,(intPrimTy, getRdrName intDataCon)
1400 ,(wordPrimTy, wordDataCon_RDR)
1401 ,(floatPrimTy, getRdrName floatDataCon)
1402 ,(doublePrimTy, getRdrName doubleDataCon)
1405 -----------------------------------------------------------------------
1407 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1408 and_Expr a b = genOpApp a and_RDR b
1410 -----------------------------------------------------------------------
1412 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1413 eq_Expr tycon ty a b = genOpApp a eq_op b
1416 | not (isUnLiftedType ty) = eq_RDR
1417 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1418 -- we have to do something special for primitive things...
1422 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1423 untag_Expr _ [] expr = expr
1424 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1425 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1426 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1428 cmp_tags_Expr :: RdrName -- Comparison op
1429 -> RdrName -> RdrName -- Things to compare
1430 -> LHsExpr RdrName -- What to return if true
1431 -> LHsExpr RdrName -- What to return if false
1434 cmp_tags_Expr op a b true_case false_case
1435 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1438 :: LHsExpr RdrName -> LHsExpr RdrName
1440 enum_from_then_to_Expr
1441 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1444 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1445 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1448 :: LHsExpr RdrName -> LHsExpr RdrName
1451 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1453 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1455 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1456 nested_compose_Expr [e] = parenify e
1457 nested_compose_Expr (e:es)
1458 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1460 -- impossible_Expr is used in case RHSs that should never happen.
1461 -- We generate these to keep the desugarer from complaining that they *might* happen!
1462 impossible_Expr :: LHsExpr RdrName
1463 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1465 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1466 -- method. It is currently only used by Enum.{succ,pred}
1467 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1468 illegal_Expr meth tp msg =
1469 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1471 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1472 -- to include the value of a_RDR in the error string.
1473 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1474 illegal_toEnum_tag tp maxtag =
1475 nlHsApp (nlHsVar error_RDR)
1476 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1477 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1478 (nlHsApp (nlHsApp (nlHsApp
1479 (nlHsVar showsPrec_RDR)
1483 (nlHsVar append_RDR)
1484 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1485 (nlHsApp (nlHsApp (nlHsApp
1486 (nlHsVar showsPrec_RDR)
1489 (nlHsLit (mkHsString ")"))))))
1491 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1492 parenify e@(L _ (HsVar _)) = e
1493 parenify e = mkHsPar e
1495 -- genOpApp wraps brackets round the operator application, so that the
1496 -- renamer won't subsequently try to re-associate it.
1497 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1498 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1502 a_RDR, b_RDR, c_RDR, d_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR,
1503 cmp_eq_RDR :: RdrName
1504 a_RDR = mkVarUnqual (fsLit "a")
1505 b_RDR = mkVarUnqual (fsLit "b")
1506 c_RDR = mkVarUnqual (fsLit "c")
1507 d_RDR = mkVarUnqual (fsLit "d")
1508 k_RDR = mkVarUnqual (fsLit "k")
1509 z_RDR = mkVarUnqual (fsLit "z")
1510 ah_RDR = mkVarUnqual (fsLit "a#")
1511 bh_RDR = mkVarUnqual (fsLit "b#")
1512 ch_RDR = mkVarUnqual (fsLit "c#")
1513 dh_RDR = mkVarUnqual (fsLit "d#")
1514 cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq")
1516 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1517 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1518 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1519 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1521 a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1522 false_Expr, true_Expr :: LHsExpr RdrName
1523 a_Expr = nlHsVar a_RDR
1524 b_Expr = nlHsVar b_RDR
1525 c_Expr = nlHsVar c_RDR
1526 ltTag_Expr = nlHsVar ltTag_RDR
1527 eqTag_Expr = nlHsVar eqTag_RDR
1528 gtTag_Expr = nlHsVar gtTag_RDR
1529 false_Expr = nlHsVar false_RDR
1530 true_Expr = nlHsVar true_RDR
1532 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
1533 a_Pat = nlVarPat a_RDR
1534 b_Pat = nlVarPat b_RDR
1535 c_Pat = nlVarPat c_RDR
1536 d_Pat = nlVarPat d_RDR
1537 k_Pat = nlVarPat k_RDR
1538 z_Pat = nlVarPat z_RDR
1540 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1541 -- Generates Orig s RdrName, for the binding positions
1542 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1543 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1544 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1546 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1547 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1549 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1550 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1551 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1552 -- But: (a) that does not work well for standalone-deriving
1553 -- (b) an unqualified name is just fine, provided it can't clash with user code
1556 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1557 PrelNames, so PrelNames can't import PrimOp.
1560 primOpRdrName :: PrimOp -> RdrName
1561 primOpRdrName op = getRdrName (primOpId op)
1563 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
1564 tagToEnum_RDR :: RdrName
1565 minusInt_RDR = primOpRdrName IntSubOp
1566 eqInt_RDR = primOpRdrName IntEqOp
1567 ltInt_RDR = primOpRdrName IntLtOp
1568 geInt_RDR = primOpRdrName IntGeOp
1569 leInt_RDR = primOpRdrName IntLeOp
1570 tagToEnum_RDR = primOpRdrName TagToEnumOp
1572 error_RDR :: RdrName
1573 error_RDR = getRdrName eRROR_ID