2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcGenDeriv]{Generating derived instance declarations}
6 This module is nominally ``subordinate'' to @TcDeriv@, which is the
7 ``official'' interface to deriving-related things.
9 This is where we do all the grimy bindings' generation.
20 gen_tag_n_con_monobind,
22 con2tag_RDR, tag2con_RDR, maxtag_RDR,
27 #include "HsVersions.h"
29 import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
30 Match(..), GRHSs(..), Stmt(..), HsLit(..),
31 HsBinds(..), StmtCtxt(..),
32 unguardedRHS, mkSimpleMatch
34 import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
35 import RdrName ( RdrName, mkSrcUnqual )
36 import BasicTypes ( RecFlag(..) )
37 import FieldLabel ( fieldLabelName )
38 import DataCon ( isNullaryDataCon, dataConTag,
39 dataConRawArgTys, fIRST_TAG,
42 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
43 occNameUserString, nameRdrName, varName,
44 OccName, Name, NamedThing(..), NameSpace
47 import PrimOp ( PrimOp(..) )
48 import PrelInfo -- Lots of RdrNames
49 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
50 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
53 import Type ( isUnLiftedType, isUnboxedType, Type )
54 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
55 floatPrimTy, doublePrimTy
57 import Util ( mapAccumL, zipEqual, zipWithEqual,
58 zipWith3Equal, nOfThem )
59 import Panic ( panic, assertPanic )
60 import Maybes ( maybeToBool )
61 import List ( partition, intersperse )
64 %************************************************************************
66 \subsection{Generating code, by derivable class}
68 %************************************************************************
70 %************************************************************************
72 \subsubsection{Generating @Eq@ instance declarations}
74 %************************************************************************
76 Here are the heuristics for the code we generate for @Eq@:
79 Let's assume we have a data type with some (possibly zero) nullary
80 data constructors and some ordinary, non-nullary ones (the rest,
81 also possibly zero of them). Here's an example, with both \tr{N}ullary
82 and \tr{O}rdinary data cons.
84 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
88 For the ordinary constructors (if any), we emit clauses to do The
92 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
93 (==) (O2 a1) (O2 a2) = a1 == a2
94 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
97 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
98 \tr{a2} are \tr{Float#}s, then we have to generate
100 case (a1 `eqFloat#` a2) of
103 for that particular test.
106 If there are any nullary constructors, we emit a catch-all clause of
110 (==) a b = case (con2tag_Foo a) of { a# ->
111 case (con2tag_Foo b) of { b# ->
112 case (a# ==# b#) of {
117 If there aren't any nullary constructors, we emit a simpler
124 For the @(/=)@ method, we normally just use the default method.
126 If the type is an enumeration type, we could/may/should? generate
127 special code that calls @con2tag_Foo@, much like for @(==)@ shown
131 We thought about doing this: If we're also deriving @Ord@ for this
134 instance ... Eq (Foo ...) where
135 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
136 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
138 However, that requires that \tr{Ord <whatever>} was put in the context
139 for the instance decl, which it probably wasn't, so the decls
140 produced don't get through the typechecker.
144 deriveEq :: RdrName -- Class
145 -> RdrName -- Type constructor
146 -> [ (RdrName, [RdrType]) ] -- Constructors
147 -> (RdrContext, -- Context for the inst decl
148 [RdrBind], -- Binds in the inst decl
149 [RdrBind]) -- Extra value bindings outside
151 deriveEq clas tycon constrs
152 = (context, [eq_bind, ne_bind], [])
154 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
157 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
158 is_nullary (_, args) = null args
161 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
165 tycon_loc = getSrcLoc tycon
166 (nullary_cons, nonnullary_cons)
167 | isNewTyCon tycon = ([], tyConDataCons tycon)
168 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
171 = if (null nullary_cons) then
172 case maybeTyConSingleCon tycon of
174 Nothing -> -- if cons don't match, then False
175 [([a_Pat, b_Pat], false_Expr)]
176 else -- calc. and compare the tags
178 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
179 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
181 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
183 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
184 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
186 ------------------------------------------------------------------
189 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
190 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
192 data_con_RDR = qual_orig_name data_con
193 con_arity = length tys_needed
194 as_needed = take con_arity as_RDRs
195 bs_needed = take con_arity bs_RDRs
196 tys_needed = dataConRawArgTys data_con
198 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
200 nested_eq_expr [] [] [] = true_Expr
201 nested_eq_expr tys as bs
202 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
204 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
207 %************************************************************************
209 \subsubsection{Generating @Ord@ instance declarations}
211 %************************************************************************
213 For a derived @Ord@, we concentrate our attentions on @compare@
215 compare :: a -> a -> Ordering
216 data Ordering = LT | EQ | GT deriving ()
219 We will use the same example data type as above:
221 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
226 We do all the other @Ord@ methods with calls to @compare@:
228 instance ... (Ord <wurble> <wurble>) where
229 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
230 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
231 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
232 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
234 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
235 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
237 -- compare to come...
241 @compare@ always has two parts. First, we use the compared
242 data-constructors' tags to deal with the case of different
245 compare a b = case (con2tag_Foo a) of { a# ->
246 case (con2tag_Foo b) of { b# ->
247 case (a# ==# b#) of {
249 False -> case (a# <# b#) of
254 cmp_eq = ... to come ...
258 We are only left with the ``help'' function @cmp_eq@, to deal with
259 comparing data constructors with the same tag.
261 For the ordinary constructors (if any), we emit the sorta-obvious
262 compare-style stuff; for our example:
264 cmp_eq (O1 a1 b1) (O1 a2 b2)
265 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
267 cmp_eq (O2 a1) (O2 a2)
270 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
271 = case (compare a1 a2) of {
274 EQ -> case compare b1 b2 of {
282 Again, we must be careful about unboxed comparisons. For example,
283 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
287 cmp_eq lt eq gt (O2 a1) (O2 a2)
289 -- or maybe the unfolded equivalent
293 For the remaining nullary constructors, we already know that the
300 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
304 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
307 = defaulted `AndMonoBinds` compare
309 tycon_loc = getSrcLoc tycon
310 --------------------------------------------------------------------
311 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
314 (if maybeToBool (maybeTyConSingleCon tycon) then
316 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
317 -- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
319 cmp_eq_Expr a_Expr b_Expr
321 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
322 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
323 -- True case; they are equal
324 -- If an enumeration type we are done; else
325 -- recursively compare their components
326 (if isEnumerationTyCon tycon then
329 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
331 cmp_eq_Expr a_Expr b_Expr
333 -- False case; they aren't equal
334 -- So we need to do a less-than comparison on the tags
335 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
337 tycon_data_cons = tyConDataCons tycon
338 (nullary_cons, nonnullary_cons)
339 | isNewTyCon tycon = ([], tyConDataCons tycon)
340 | otherwise = partition isNullaryDataCon tycon_data_cons
343 mk_FunMonoBind tycon_loc
345 (if null nonnullary_cons && (length nullary_cons == 1) then
346 -- catch this specially to avoid warnings
347 -- about overlapping patterns from the desugarer.
349 data_con = head nullary_cons
350 data_con_RDR = qual_orig_name data_con
351 pat = ConPatIn data_con_RDR []
353 [([pat,pat], eqTag_Expr)]
355 map pats_etc nonnullary_cons ++
356 -- leave out wildcards to silence desugarer.
357 (if length tycon_data_cons == 1 then
360 [([WildPatIn, WildPatIn], default_rhs)]))
363 = ([con1_pat, con2_pat],
364 nested_compare_expr tys_needed as_needed bs_needed)
366 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
367 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
369 data_con_RDR = qual_orig_name data_con
370 con_arity = length tys_needed
371 as_needed = take con_arity as_RDRs
372 bs_needed = take con_arity bs_RDRs
373 tys_needed = dataConRawArgTys data_con
375 nested_compare_expr [ty] [a] [b]
376 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
378 nested_compare_expr (ty:tys) (a:as) (b:bs)
379 = let eq_expr = nested_compare_expr tys as bs
380 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
382 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
383 -- inexhaustive patterns
384 | otherwise = eqTag_Expr -- Some nullary constructors;
385 -- Tags are equal, no args => return EQ
386 --------------------------------------------------------------------
388 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
390 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
391 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
392 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
393 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
394 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
395 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
396 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
397 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
399 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
400 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
401 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
402 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
405 %************************************************************************
407 \subsubsection{Generating @Enum@ instance declarations}
409 %************************************************************************
411 @Enum@ can only be derived for enumeration types. For a type
413 data Foo ... = N1 | N2 | ... | Nn
416 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
417 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
420 instance ... Enum (Foo ...) where
421 succ x = toEnum (1 + fromEnum x)
422 pred x = toEnum (fromEnum x - 1)
424 toEnum i = tag2con_Foo i
426 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
430 = case con2tag_Foo a of
431 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
434 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
438 = case con2tag_Foo a of { a# ->
439 case con2tag_Foo b of { b# ->
440 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
444 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
447 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
450 = succ_enum `AndMonoBinds`
451 pred_enum `AndMonoBinds`
452 to_enum `AndMonoBinds`
453 enum_from `AndMonoBinds`
454 enum_from_then `AndMonoBinds`
457 tycon_loc = getSrcLoc tycon
458 occ_nm = getOccString tycon
461 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
462 untag_Expr tycon [(a_RDR, ah_RDR)] $
463 HsIf (HsApp (HsApp (HsVar eq_RDR)
464 (HsVar (maxtag_RDR tycon)))
465 (mk_easy_App mkInt_RDR [ah_RDR]))
466 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
467 (HsApp (HsVar (tag2con_RDR tycon))
468 (HsApp (HsApp (HsVar plus_RDR)
469 (mk_easy_App mkInt_RDR [ah_RDR]))
474 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
475 untag_Expr tycon [(a_RDR, ah_RDR)] $
476 HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
477 (mk_easy_App mkInt_RDR [ah_RDR]))
478 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
479 (HsApp (HsVar (tag2con_RDR tycon))
480 (HsApp (HsApp (HsVar plus_RDR)
481 (mk_easy_App mkInt_RDR [ah_RDR]))
482 (HsLit (HsInt (-1)))))
486 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
489 (HsApp (HsApp (HsVar ge_RDR)
492 (HsApp (HsApp (HsVar le_RDR)
494 (HsVar (maxtag_RDR tycon))))
495 (mk_easy_App (tag2con_RDR tycon) [a_RDR])
496 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
500 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
501 untag_Expr tycon [(a_RDR, ah_RDR)] $
502 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
503 HsPar (enum_from_to_Expr
504 (mk_easy_App mkInt_RDR [ah_RDR])
505 (HsVar (maxtag_RDR tycon)))
508 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
509 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
510 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
511 HsPar (enum_from_then_to_Expr
512 (mk_easy_App mkInt_RDR [ah_RDR])
513 (mk_easy_App mkInt_RDR [bh_RDR])
514 (HsIf (HsApp (HsApp (HsVar gt_RDR)
518 (HsVar (maxtag_RDR tycon))
522 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
523 untag_Expr tycon [(a_RDR, ah_RDR)] $
524 (mk_easy_App mkInt_RDR [ah_RDR])
527 %************************************************************************
529 \subsubsection{Generating @Bounded@ instance declarations}
531 %************************************************************************
534 gen_Bounded_binds tycon
535 = if isEnumerationTyCon tycon then
536 min_bound_enum `AndMonoBinds` max_bound_enum
538 ASSERT(length data_cons == 1)
539 min_bound_1con `AndMonoBinds` max_bound_1con
541 data_cons = tyConDataCons tycon
542 tycon_loc = getSrcLoc tycon
544 ----- enum-flavored: ---------------------------
545 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
546 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
548 data_con_1 = head data_cons
549 data_con_N = last data_cons
550 data_con_1_RDR = qual_orig_name data_con_1
551 data_con_N_RDR = qual_orig_name data_con_N
553 ----- single-constructor-flavored: -------------
554 arity = argFieldCount data_con_1
556 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
557 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
558 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
559 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
562 %************************************************************************
564 \subsubsection{Generating @Ix@ instance declarations}
566 %************************************************************************
568 Deriving @Ix@ is only possible for enumeration types and
569 single-constructor types. We deal with them in turn.
571 For an enumeration type, e.g.,
573 data Foo ... = N1 | N2 | ... | Nn
575 things go not too differently from @Enum@:
577 instance ... Ix (Foo ...) where
579 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
583 = case (con2tag_Foo a) of { a# ->
584 case (con2tag_Foo b) of { b# ->
585 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
590 then case (con2tag_Foo d -# con2tag_Foo a) of
592 else error "Ix.Foo.index: out of range"
596 p_tag = con2tag_Foo c
598 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
602 = case (con2tag_Foo a) of { a_tag ->
603 case (con2tag_Foo b) of { b_tag ->
604 case (con2tag_Foo c) of { c_tag ->
605 if (c_tag >=# a_tag) then
611 (modulo suitable case-ification to handle the unboxed tags)
613 For a single-constructor type (NB: this includes all tuples), e.g.,
615 data Foo ... = MkFoo a b Int Double c c
617 we follow the scheme given in Figure~19 of the Haskell~1.2 report
621 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
624 = if isEnumerationTyCon tycon
628 tycon_str = getOccString tycon
629 tycon_loc = getSrcLoc tycon
631 --------------------------------------------------------------
632 enum_ixes = enum_range `AndMonoBinds`
633 enum_index `AndMonoBinds` enum_inRange
636 = mk_easy_FunMonoBind tycon_loc range_RDR
637 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $
638 untag_Expr tycon [(a_RDR, ah_RDR)] $
639 untag_Expr tycon [(b_RDR, bh_RDR)] $
640 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
641 HsPar (enum_from_to_Expr
642 (mk_easy_App mkInt_RDR [ah_RDR])
643 (mk_easy_App mkInt_RDR [bh_RDR]))
646 = mk_easy_FunMonoBind tycon_loc index_RDR
647 [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat] True{-boxed-}),
649 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
650 untag_Expr tycon [(a_RDR, ah_RDR)] (
651 untag_Expr tycon [(d_RDR, dh_RDR)] (
653 rhs = mk_easy_App mkInt_RDR [c_RDR]
656 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
657 [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
661 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
666 = mk_easy_FunMonoBind tycon_loc inRange_RDR
667 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] (
668 untag_Expr tycon [(a_RDR, ah_RDR)] (
669 untag_Expr tycon [(b_RDR, bh_RDR)] (
670 untag_Expr tycon [(c_RDR, ch_RDR)] (
671 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
672 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
677 --------------------------------------------------------------
679 = single_con_range `AndMonoBinds`
680 single_con_index `AndMonoBinds`
684 = case maybeTyConSingleCon tycon of -- just checking...
685 Nothing -> panic "get_Ix_binds"
686 Just dc -> if (any isUnLiftedType (dataConRawArgTys dc)) then
687 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
691 con_arity = argFieldCount data_con
692 data_con_RDR = qual_orig_name data_con
694 as_needed = take con_arity as_RDRs
695 bs_needed = take con_arity bs_RDRs
696 cs_needed = take con_arity cs_RDRs
698 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
699 con_expr = mk_easy_App data_con_RDR cs_needed
701 --------------------------------------------------------------
703 = mk_easy_FunMonoBind tycon_loc range_RDR
704 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $
705 HsDo ListComp stmts tycon_loc
707 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
709 [ReturnStmt con_expr]
711 mk_qual a b c = BindStmt (VarPatIn c)
712 (HsApp (HsVar range_RDR)
713 (ExplicitTuple [HsVar a, HsVar b] True))
718 = mk_easy_FunMonoBind tycon_loc index_RDR
719 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
720 con_pat cs_needed] [range_size] (
721 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
723 mk_index multiply_by (l, u, i)
725 (HsApp (HsApp (HsVar index_RDR)
726 (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i))
729 (HsApp (HsVar rangeSize_RDR)
730 (ExplicitTuple [HsVar l, HsVar u] True))
731 ) times_RDR multiply_by
735 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
736 [TuplePatIn [a_Pat, b_Pat] True] [] (
738 (HsApp (HsApp (HsVar index_RDR)
739 (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr)
740 ) plus_RDR (HsLit (HsInt 1)))
744 = mk_easy_FunMonoBind tycon_loc inRange_RDR
745 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
748 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
750 in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
751 (ExplicitTuple [HsVar a, HsVar b] True))
755 %************************************************************************
757 \subsubsection{Generating @Read@ instance declarations}
759 %************************************************************************
761 Ignoring all the infix-ery mumbo jumbo (ToDo)
764 gen_Read_binds :: TyCon -> RdrNameMonoBinds
767 = reads_prec `AndMonoBinds` read_list
769 tycon_loc = getSrcLoc tycon
770 -----------------------------------------------------------------------
771 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
772 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
773 -----------------------------------------------------------------------
776 read_con_comprehensions
777 = map read_con (tyConDataCons tycon)
779 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
780 foldr1 append_Expr read_con_comprehensions
783 read_con data_con -- note: "b" is the string being "read"
785 data_con_RDR = qual_orig_name data_con
786 data_con_str= occNameUserString (getOccName data_con)
787 con_arity = argFieldCount data_con
788 con_expr = mk_easy_App data_con_RDR as_needed
789 nullary_con = con_arity == 0
790 labels = dataConFieldLabels data_con
791 lab_fields = length labels
793 as_needed = take con_arity as_RDRs
795 | lab_fields == 0 = take con_arity bs_RDRs
796 | otherwise = take (4*lab_fields + 1) bs_RDRs
797 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
800 (TuplePatIn [LitPatIn (mkHsString data_con_str),
802 (HsApp (HsVar lex_RDR) c_Expr)
805 str_qual str res draw_from
807 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
808 (HsApp (HsVar lex_RDR) draw_from)
812 = let nm = occNameUserString (getOccName (fieldLabelName f))
814 [str_qual nm, str_qual "="]
815 -- There might be spaces between the label and '='
819 snd (mapAccumL mk_qual
821 (zipWithEqual "as_needed"
822 (\ con_field draw_from -> (mk_read_qual con_field,
824 as_needed bs_needed))
827 mapAccumL mk_qual d_Expr
828 (zipEqual "bs_needed"
831 intersperse [str_qual ","] $
834 (\ as b -> as ++ [b])
836 (map read_label labels)
838 (map mk_read_qual as_needed))) ++ [str_qual "}"])
841 mk_qual draw_from (f, str_left)
842 = (HsVar str_left, -- what to draw from down the line...
843 f str_left draw_from)
845 mk_read_qual con_field res draw_from =
847 (TuplePatIn [VarPatIn con_field, VarPatIn res] True)
848 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
851 result_expr = ExplicitTuple [con_expr, if null bs_needed
853 else HsVar (last bs_needed)] True
855 stmts = con_qual:field_quals ++ [ReturnStmt result_expr]
858 = if nullary_con then -- must be False (parens are surely optional)
860 else -- parens depend on precedence...
861 HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9)))
864 readParen_Expr read_paren_arg $ HsPar $
865 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
866 HsDo ListComp stmts tycon_loc)
871 %************************************************************************
873 \subsubsection{Generating @Show@ instance declarations}
875 %************************************************************************
877 Ignoring all the infix-ery mumbo jumbo (ToDo)
880 gen_Show_binds :: TyCon -> RdrNameMonoBinds
883 = shows_prec `AndMonoBinds` show_list
885 tycon_loc = getSrcLoc tycon
886 -----------------------------------------------------------------------
887 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
888 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
889 -----------------------------------------------------------------------
891 = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
895 data_con_RDR = qual_orig_name data_con
896 con_arity = argFieldCount data_con
897 bs_needed = take con_arity bs_RDRs
898 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
899 nullary_con = con_arity == 0
900 labels = dataConFieldLabels data_con
901 lab_fields = length labels
904 = let nm = occNameUserString (getOccName data_con)
907 | lab_fields == 0 = " "
911 mk_showString_app (nm ++ space_ocurly_maybe)
916 | lab_fields > 0 = [mk_showString_app "}"]
919 con:fs ++ ccurly_maybe
921 show_thingies = show_all show_con real_show_thingies_with_labs
924 = let nm = occNameUserString (getOccName (fieldLabelName l))
926 mk_showString_app (nm ++ "=")
928 mk_showString_app str = HsApp (HsVar showString_RDR)
929 (HsLit (mkHsString str))
932 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
935 real_show_thingies_with_labs
936 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
937 | otherwise = --Assumption: no of fields == no of labelled fields
938 -- (and in same order)
940 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
941 zipWithEqual "gen_Show_binds"
943 (map show_label labels)
948 if nullary_con then -- skip the showParen junk...
949 ASSERT(null bs_needed)
950 ([a_Pat, con_pat], show_con)
953 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
954 (HsPar (nested_compose_Expr show_thingies)))
957 %************************************************************************
959 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
961 %************************************************************************
966 con2tag_Foo :: Foo ... -> Int#
967 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
968 maxtag_Foo :: Int -- ditto (NB: not unboxed)
971 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
976 = GenCon2Tag | GenTag2Con | GenMaxTag
978 gen_tag_n_con_monobind
979 :: (RdrName, -- (proto)Name for the thing in question
980 TyCon, -- tycon in question
984 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
985 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
987 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
990 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
992 pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
993 var_RDR = qual_orig_name var
995 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
996 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++
997 [([WildPatIn], impossible_Expr)])
999 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1000 mk_stuff var = ([lit_pat], HsVar var_RDR)
1002 lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
1003 var_RDR = qual_orig_name var
1005 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1006 = mk_easy_FunMonoBind (getSrcLoc tycon)
1007 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1009 max_tag = case (tyConDataCons tycon) of
1010 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1014 %************************************************************************
1016 \subsection{Utility bits for generating bindings}
1018 %************************************************************************
1020 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1022 fun pat1 pat2 ... patN = expr where binds
1025 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1026 multi-clause definitions; it generates:
1028 fun p1a p1b ... p1N = e1
1029 fun p2a p2b ... p2N = e2
1031 fun pMa pMb ... pMN = eM
1035 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1036 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1039 mk_easy_FunMonoBind loc fun pats binds expr
1040 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1042 mk_easy_Match loc pats binds expr
1043 = mk_match loc pats expr (mkbind binds)
1045 mkbind [] = EmptyBinds
1046 mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
1047 -- The renamer expects everything in its input to be a
1048 -- "recursive" MonoBinds, and it is its job to sort things out
1051 mk_FunMonoBind :: SrcLoc -> RdrName
1052 -> [([RdrNamePat], RdrNameHsExpr)]
1055 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1056 mk_FunMonoBind loc fun pats_and_exprs
1057 = FunMonoBind fun False{-not infix-}
1058 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1061 mk_match loc pats expr binds
1062 = Match [] (map paren pats) Nothing
1063 (GRHSs (unguardedRHS expr loc) binds Nothing)
1065 paren p@(VarPatIn _) = p
1066 paren other_p = ParPatIn other_p
1070 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1073 ToDo: Better SrcLocs.
1077 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1078 -> RdrNameHsExpr -> RdrNameHsExpr
1082 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1083 -> RdrNameHsExpr -> RdrNameHsExpr
1085 careful_compare_Case :: -- checks for primitive types...
1087 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1088 -> RdrNameHsExpr -> RdrNameHsExpr
1091 compare_Case = compare_gen_Case compare_RDR
1092 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1093 -- Was: compare_gen_Case cmp_eq_RDR
1095 compare_gen_Case fun lt eq gt a b
1096 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1097 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc,
1098 mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc,
1099 mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc]
1102 careful_compare_Case ty lt eq gt a b
1103 = if not (isUnboxedType ty) then
1104 compare_gen_Case compare_RDR lt eq gt a b
1106 else -- we have to do something special for primitive things...
1107 HsIf (genOpApp a relevant_eq_op b)
1109 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1112 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1113 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1115 assoc_ty_id tyids ty
1116 = if null res then panic "assoc_ty"
1119 res = [id | (ty',id) <- tyids, ty == ty']
1122 [(charPrimTy, eqH_Char_RDR)
1123 ,(intPrimTy, eqH_Int_RDR)
1124 ,(wordPrimTy, eqH_Word_RDR)
1125 ,(addrPrimTy, eqH_Addr_RDR)
1126 ,(floatPrimTy, eqH_Float_RDR)
1127 ,(doublePrimTy, eqH_Double_RDR)
1131 [(charPrimTy, ltH_Char_RDR)
1132 ,(intPrimTy, ltH_Int_RDR)
1133 ,(wordPrimTy, ltH_Word_RDR)
1134 ,(addrPrimTy, ltH_Addr_RDR)
1135 ,(floatPrimTy, ltH_Float_RDR)
1136 ,(doublePrimTy, ltH_Double_RDR)
1139 -----------------------------------------------------------------------
1141 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1143 and_Expr a b = genOpApp a and_RDR b
1144 append_Expr a b = genOpApp a append_RDR b
1146 -----------------------------------------------------------------------
1148 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1150 = if not (isUnboxedType ty) then
1152 else -- we have to do something special for primitive things...
1153 genOpApp a relevant_eq_op b
1155 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1159 argFieldCount :: DataCon -> Int -- Works on data and newtype constructors
1160 argFieldCount con = length (dataConRawArgTys con)
1164 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1165 untag_Expr tycon [] expr = expr
1166 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1167 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1168 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc]
1171 cmp_tags_Expr :: RdrName -- Comparison op
1172 -> RdrName -> RdrName -- Things to compare
1173 -> RdrNameHsExpr -- What to return if true
1174 -> RdrNameHsExpr -- What to return if false
1177 cmp_tags_Expr op a b true_case false_case
1178 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1181 :: RdrNameHsExpr -> RdrNameHsExpr
1183 enum_from_then_to_Expr
1184 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1187 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1188 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1190 showParen_Expr, readParen_Expr
1191 :: RdrNameHsExpr -> RdrNameHsExpr
1194 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1195 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1197 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1199 nested_compose_Expr [e] = parenify e
1200 nested_compose_Expr (e:es)
1201 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1203 -- impossible_Expr is used in case RHSs that should never happen.
1204 -- We generate these to keep the desugarer from complaining that they *might* happen!
1205 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1207 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1208 -- method. It is currently only used by Enum.{succ,pred}
1209 illegal_Expr meth tp msg =
1210 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1212 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1213 -- to include the value of a_RDR in the error string.
1214 illegal_toEnum_tag tp maxtag =
1215 HsApp (HsVar error_RDR)
1216 (HsApp (HsApp (HsVar append_RDR)
1217 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1218 (HsApp (HsApp (HsApp
1219 (HsVar showsPrec_RDR)
1224 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1225 (HsApp (HsApp (HsApp
1226 (HsVar showsPrec_RDR)
1229 (HsLit (HsString (_PK_ ")")))))))
1231 parenify e@(HsVar _) = e
1232 parenify e = HsPar e
1234 -- genOpApp wraps brackets round the operator application, so that the
1235 -- renamer won't subsequently try to re-associate it.
1236 -- For some reason the renamer doesn't reassociate it right, and I can't
1237 -- be bothered to find out why just now.
1239 genOpApp e1 op e2 = mkOpApp e1 op e2
1243 qual_orig_name n = nameRdrName (getName n)
1244 varUnqual n = mkSrcUnqual varName n
1246 a_RDR = varUnqual SLIT("a")
1247 b_RDR = varUnqual SLIT("b")
1248 c_RDR = varUnqual SLIT("c")
1249 d_RDR = varUnqual SLIT("d")
1250 ah_RDR = varUnqual SLIT("a#")
1251 bh_RDR = varUnqual SLIT("b#")
1252 ch_RDR = varUnqual SLIT("c#")
1253 dh_RDR = varUnqual SLIT("d#")
1254 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1255 rangeSize_RDR = varUnqual SLIT("rangeSize")
1257 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1258 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1259 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1261 mkHsString s = HsString (_PK_ s)
1263 a_Expr = HsVar a_RDR
1264 b_Expr = HsVar b_RDR
1265 c_Expr = HsVar c_RDR
1266 d_Expr = HsVar d_RDR
1267 ltTag_Expr = HsVar ltTag_RDR
1268 eqTag_Expr = HsVar eqTag_RDR
1269 gtTag_Expr = HsVar gtTag_RDR
1270 false_Expr = HsVar false_RDR
1271 true_Expr = HsVar true_RDR
1273 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1275 a_Pat = VarPatIn a_RDR
1276 b_Pat = VarPatIn b_RDR
1277 c_Pat = VarPatIn c_RDR
1278 d_Pat = VarPatIn d_RDR
1280 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1282 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1283 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1284 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))