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(..), HsType(..), HsDoContext(..),
32 unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
34 import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
35 import RdrName ( RdrName, mkUnqual )
36 import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
40 import FieldLabel ( fieldLabelName )
41 import DataCon ( isNullaryDataCon, dataConTag,
42 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
45 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
46 occNameUserString, nameRdrName, varName,
48 isDataSymOcc, isSymOcc
51 import HscTypes ( FixityEnv, lookupFixity )
52 import PrelInfo -- Lots of RdrNames
53 import SrcLoc ( generatedSrcLoc, SrcLoc )
54 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
55 maybeTyConSingleCon, tyConFamilySize
57 import TcType ( isUnLiftedType, tcEqType, Type )
58 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
59 floatPrimTy, doublePrimTy
61 import Util ( mapAccumL, zipEqual, zipWithEqual, isSingleton,
62 zipWith3Equal, nOfThem )
63 import Panic ( panic, assertPanic )
64 import Maybes ( maybeToBool )
66 import List ( partition, intersperse )
69 %************************************************************************
71 \subsection{Generating code, by derivable class}
73 %************************************************************************
75 %************************************************************************
77 \subsubsection{Generating @Eq@ instance declarations}
79 %************************************************************************
81 Here are the heuristics for the code we generate for @Eq@:
84 Let's assume we have a data type with some (possibly zero) nullary
85 data constructors and some ordinary, non-nullary ones (the rest,
86 also possibly zero of them). Here's an example, with both \tr{N}ullary
87 and \tr{O}rdinary data cons.
89 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
93 For the ordinary constructors (if any), we emit clauses to do The
97 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
98 (==) (O2 a1) (O2 a2) = a1 == a2
99 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
102 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
103 \tr{a2} are \tr{Float#}s, then we have to generate
105 case (a1 `eqFloat#` a2) of
108 for that particular test.
111 If there are any nullary constructors, we emit a catch-all clause of
115 (==) a b = case (con2tag_Foo a) of { a# ->
116 case (con2tag_Foo b) of { b# ->
117 case (a# ==# b#) of {
122 If there aren't any nullary constructors, we emit a simpler
129 For the @(/=)@ method, we normally just use the default method.
131 If the type is an enumeration type, we could/may/should? generate
132 special code that calls @con2tag_Foo@, much like for @(==)@ shown
136 We thought about doing this: If we're also deriving @Ord@ for this
139 instance ... Eq (Foo ...) where
140 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
141 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
143 However, that requires that \tr{Ord <whatever>} was put in the context
144 for the instance decl, which it probably wasn't, so the decls
145 produced don't get through the typechecker.
149 deriveEq :: RdrName -- Class
150 -> RdrName -- Type constructor
151 -> [ (RdrName, [RdrType]) ] -- Constructors
152 -> (RdrContext, -- Context for the inst decl
153 [RdrBind], -- Binds in the inst decl
154 [RdrBind]) -- Extra value bindings outside
156 deriveEq clas tycon constrs
157 = (context, [eq_bind, ne_bind], [])
159 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
162 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
163 is_nullary (_, args) = null args
166 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
170 tycon_loc = getSrcLoc tycon
171 (nullary_cons, nonnullary_cons)
172 | isNewTyCon tycon = ([], tyConDataCons tycon)
173 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
176 = if (null nullary_cons) then
177 case maybeTyConSingleCon tycon of
179 Nothing -> -- if cons don't match, then False
180 [([wildPat, wildPat], false_Expr)]
181 else -- calc. and compare the tags
183 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
184 (genOpApp (HsVar ah_RDR) eqH_Int_RDR (HsVar bh_RDR)))]
186 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
188 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
189 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
191 ------------------------------------------------------------------
194 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
195 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
197 data_con_RDR = qual_orig_name data_con
198 con_arity = length tys_needed
199 as_needed = take con_arity as_RDRs
200 bs_needed = take con_arity bs_RDRs
201 tys_needed = dataConOrigArgTys data_con
203 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
205 nested_eq_expr [] [] [] = true_Expr
206 nested_eq_expr tys as bs
207 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
209 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
212 %************************************************************************
214 \subsubsection{Generating @Ord@ instance declarations}
216 %************************************************************************
218 For a derived @Ord@, we concentrate our attentions on @compare@
220 compare :: a -> a -> Ordering
221 data Ordering = LT | EQ | GT deriving ()
224 We will use the same example data type as above:
226 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
231 We do all the other @Ord@ methods with calls to @compare@:
233 instance ... (Ord <wurble> <wurble>) where
234 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
235 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
236 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
237 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
239 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
240 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
242 -- compare to come...
246 @compare@ always has two parts. First, we use the compared
247 data-constructors' tags to deal with the case of different
250 compare a b = case (con2tag_Foo a) of { a# ->
251 case (con2tag_Foo b) of { b# ->
252 case (a# ==# b#) of {
254 False -> case (a# <# b#) of
259 cmp_eq = ... to come ...
263 We are only left with the ``help'' function @cmp_eq@, to deal with
264 comparing data constructors with the same tag.
266 For the ordinary constructors (if any), we emit the sorta-obvious
267 compare-style stuff; for our example:
269 cmp_eq (O1 a1 b1) (O1 a2 b2)
270 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
272 cmp_eq (O2 a1) (O2 a2)
275 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
276 = case (compare a1 a2) of {
279 EQ -> case compare b1 b2 of {
287 Again, we must be careful about unlifted comparisons. For example,
288 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
292 cmp_eq lt eq gt (O2 a1) (O2 a2)
294 -- or maybe the unfolded equivalent
298 For the remaining nullary constructors, we already know that the
305 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
309 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
312 = compare -- `AndMonoBinds` compare
313 -- The default declaration in PrelBase handles this
315 tycon_loc = getSrcLoc tycon
316 --------------------------------------------------------------------
317 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
320 (if maybeToBool (maybeTyConSingleCon tycon) then
322 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
323 -- Weird. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
325 cmp_eq_Expr a_Expr b_Expr
327 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
328 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
329 -- True case; they are equal
330 -- If an enumeration type we are done; else
331 -- recursively compare their components
332 (if isEnumerationTyCon tycon then
335 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
337 cmp_eq_Expr a_Expr b_Expr
339 -- False case; they aren't equal
340 -- So we need to do a less-than comparison on the tags
341 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
343 tycon_data_cons = tyConDataCons tycon
344 (nullary_cons, nonnullary_cons)
345 | isNewTyCon tycon = ([], tyConDataCons tycon)
346 | otherwise = partition isNullaryDataCon tycon_data_cons
349 mk_FunMonoBind tycon_loc
351 (if null nonnullary_cons && isSingleton nullary_cons then
352 -- catch this specially to avoid warnings
353 -- about overlapping patterns from the desugarer.
355 data_con = head nullary_cons
356 data_con_RDR = qual_orig_name data_con
357 pat = ConPatIn data_con_RDR []
359 [([pat,pat], eqTag_Expr)]
361 map pats_etc nonnullary_cons ++
362 -- leave out wildcards to silence desugarer.
363 (if isSingleton tycon_data_cons then
366 [([WildPatIn, WildPatIn], default_rhs)]))
369 = ([con1_pat, con2_pat],
370 nested_compare_expr tys_needed as_needed bs_needed)
372 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
373 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
375 data_con_RDR = qual_orig_name data_con
376 con_arity = length tys_needed
377 as_needed = take con_arity as_RDRs
378 bs_needed = take con_arity bs_RDRs
379 tys_needed = dataConOrigArgTys data_con
381 nested_compare_expr [ty] [a] [b]
382 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
384 nested_compare_expr (ty:tys) (a:as) (b:bs)
385 = let eq_expr = nested_compare_expr tys as bs
386 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
388 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
389 -- inexhaustive patterns
390 | otherwise = eqTag_Expr -- Some nullary constructors;
391 -- Tags are equal, no args => return EQ
394 %************************************************************************
396 \subsubsection{Generating @Enum@ instance declarations}
398 %************************************************************************
400 @Enum@ can only be derived for enumeration types. For a type
402 data Foo ... = N1 | N2 | ... | Nn
405 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
406 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
409 instance ... Enum (Foo ...) where
410 succ x = toEnum (1 + fromEnum x)
411 pred x = toEnum (fromEnum x - 1)
413 toEnum i = tag2con_Foo i
415 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
419 = case con2tag_Foo a of
420 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
423 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
427 = case con2tag_Foo a of { a# ->
428 case con2tag_Foo b of { b# ->
429 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
433 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
436 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
439 = succ_enum `AndMonoBinds`
440 pred_enum `AndMonoBinds`
441 to_enum `AndMonoBinds`
442 enum_from `AndMonoBinds`
443 enum_from_then `AndMonoBinds`
446 tycon_loc = getSrcLoc tycon
447 occ_nm = getOccString tycon
450 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
451 untag_Expr tycon [(a_RDR, ah_RDR)] $
452 HsIf (HsApp (HsApp (HsVar eq_RDR)
453 (HsVar (maxtag_RDR tycon)))
454 (mk_easy_App mkInt_RDR [ah_RDR]))
455 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
456 (HsApp (HsVar (tag2con_RDR tycon))
457 (HsApp (HsApp (HsVar plus_RDR)
458 (mk_easy_App mkInt_RDR [ah_RDR]))
463 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
464 untag_Expr tycon [(a_RDR, ah_RDR)] $
465 HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
466 (mk_easy_App mkInt_RDR [ah_RDR]))
467 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
468 (HsApp (HsVar (tag2con_RDR tycon))
469 (HsApp (HsApp (HsVar plus_RDR)
470 (mk_easy_App mkInt_RDR [ah_RDR]))
471 (HsLit (HsInt (-1)))))
475 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
478 (HsApp (HsApp (HsVar ge_RDR)
481 (HsApp (HsApp (HsVar le_RDR)
483 (HsVar (maxtag_RDR tycon))))
484 (mk_easy_App (tag2con_RDR tycon) [a_RDR])
485 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
489 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
490 untag_Expr tycon [(a_RDR, ah_RDR)] $
491 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
492 HsPar (enum_from_to_Expr
493 (mk_easy_App mkInt_RDR [ah_RDR])
494 (HsVar (maxtag_RDR tycon)))
497 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
498 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
499 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
500 HsPar (enum_from_then_to_Expr
501 (mk_easy_App mkInt_RDR [ah_RDR])
502 (mk_easy_App mkInt_RDR [bh_RDR])
503 (HsIf (HsApp (HsApp (HsVar gt_RDR)
504 (mk_easy_App mkInt_RDR [ah_RDR]))
505 (mk_easy_App mkInt_RDR [bh_RDR]))
507 (HsVar (maxtag_RDR tycon))
511 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
512 untag_Expr tycon [(a_RDR, ah_RDR)] $
513 (mk_easy_App mkInt_RDR [ah_RDR])
516 %************************************************************************
518 \subsubsection{Generating @Bounded@ instance declarations}
520 %************************************************************************
523 gen_Bounded_binds tycon
524 = if isEnumerationTyCon tycon then
525 min_bound_enum `AndMonoBinds` max_bound_enum
527 ASSERT(isSingleton data_cons)
528 min_bound_1con `AndMonoBinds` max_bound_1con
530 data_cons = tyConDataCons tycon
531 tycon_loc = getSrcLoc tycon
533 ----- enum-flavored: ---------------------------
534 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
535 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
537 data_con_1 = head data_cons
538 data_con_N = last data_cons
539 data_con_1_RDR = qual_orig_name data_con_1
540 data_con_N_RDR = qual_orig_name data_con_N
542 ----- single-constructor-flavored: -------------
543 arity = dataConSourceArity data_con_1
545 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
546 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
547 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
548 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
551 %************************************************************************
553 \subsubsection{Generating @Ix@ instance declarations}
555 %************************************************************************
557 Deriving @Ix@ is only possible for enumeration types and
558 single-constructor types. We deal with them in turn.
560 For an enumeration type, e.g.,
562 data Foo ... = N1 | N2 | ... | Nn
564 things go not too differently from @Enum@:
566 instance ... Ix (Foo ...) where
568 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
572 = case (con2tag_Foo a) of { a# ->
573 case (con2tag_Foo b) of { b# ->
574 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
579 then case (con2tag_Foo d -# con2tag_Foo a) of
581 else error "Ix.Foo.index: out of range"
585 p_tag = con2tag_Foo c
587 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
591 = case (con2tag_Foo a) of { a_tag ->
592 case (con2tag_Foo b) of { b_tag ->
593 case (con2tag_Foo c) of { c_tag ->
594 if (c_tag >=# a_tag) then
600 (modulo suitable case-ification to handle the unlifted tags)
602 For a single-constructor type (NB: this includes all tuples), e.g.,
604 data Foo ... = MkFoo a b Int Double c c
606 we follow the scheme given in Figure~19 of the Haskell~1.2 report
610 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
613 = if isEnumerationTyCon tycon
617 tycon_str = getOccString tycon
618 tycon_loc = getSrcLoc tycon
620 --------------------------------------------------------------
621 enum_ixes = enum_range `AndMonoBinds`
622 enum_index `AndMonoBinds` enum_inRange
625 = mk_easy_FunMonoBind tycon_loc range_RDR
626 [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
627 untag_Expr tycon [(a_RDR, ah_RDR)] $
628 untag_Expr tycon [(b_RDR, bh_RDR)] $
629 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
630 HsPar (enum_from_to_Expr
631 (mk_easy_App mkInt_RDR [ah_RDR])
632 (mk_easy_App mkInt_RDR [bh_RDR]))
635 = mk_easy_FunMonoBind tycon_loc index_RDR
636 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
638 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
639 untag_Expr tycon [(a_RDR, ah_RDR)] (
640 untag_Expr tycon [(d_RDR, dh_RDR)] (
642 rhs = mk_easy_App mkInt_RDR [c_RDR]
645 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
646 [mkSimpleMatch [VarPatIn c_RDR] rhs placeHolderType tycon_loc]
650 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
655 = mk_easy_FunMonoBind tycon_loc inRange_RDR
656 [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
657 untag_Expr tycon [(a_RDR, ah_RDR)] (
658 untag_Expr tycon [(b_RDR, bh_RDR)] (
659 untag_Expr tycon [(c_RDR, ch_RDR)] (
660 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
661 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
666 --------------------------------------------------------------
668 = single_con_range `AndMonoBinds`
669 single_con_index `AndMonoBinds`
673 = case maybeTyConSingleCon tycon of -- just checking...
674 Nothing -> panic "get_Ix_binds"
675 Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
676 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
680 con_arity = dataConSourceArity data_con
681 data_con_RDR = qual_orig_name data_con
683 as_needed = take con_arity as_RDRs
684 bs_needed = take con_arity bs_RDRs
685 cs_needed = take con_arity cs_RDRs
687 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
688 con_expr = mk_easy_App data_con_RDR cs_needed
690 --------------------------------------------------------------
692 = mk_easy_FunMonoBind tycon_loc range_RDR
693 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
694 HsDo ListComp stmts tycon_loc
696 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
698 [ResultStmt con_expr tycon_loc]
700 mk_qual a b c = BindStmt (VarPatIn c)
701 (HsApp (HsVar range_RDR)
702 (ExplicitTuple [HsVar a, HsVar b] Boxed))
707 = mk_easy_FunMonoBind tycon_loc index_RDR
708 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
709 con_pat cs_needed] [range_size] (
710 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
712 mk_index multiply_by (l, u, i)
714 (HsApp (HsApp (HsVar index_RDR)
715 (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i))
718 (HsApp (HsVar rangeSize_RDR)
719 (ExplicitTuple [HsVar l, HsVar u] Boxed))
720 ) times_RDR multiply_by
724 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
725 [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
727 (HsApp (HsApp (HsVar index_RDR)
728 (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr)
729 ) plus_RDR (HsLit (HsInt 1)))
733 = mk_easy_FunMonoBind tycon_loc inRange_RDR
734 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
737 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
739 in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
740 (ExplicitTuple [HsVar a, HsVar b] Boxed))
744 %************************************************************************
746 \subsubsection{Generating @Read@ instance declarations}
748 %************************************************************************
751 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
753 gen_Read_binds get_fixity tycon
754 = reads_prec `AndMonoBinds` read_list
756 tycon_loc = getSrcLoc tycon
757 -----------------------------------------------------------------------
758 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
759 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
760 -----------------------------------------------------------------------
763 read_con_comprehensions
764 = map read_con (tyConDataCons tycon)
766 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] (
767 foldr1 append_Expr read_con_comprehensions
770 read_con data_con -- note: "b" is the string being "read"
772 readParen_Expr read_paren_arg $ HsPar $
773 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
774 HsDo ListComp stmts tycon_loc)
777 data_con_RDR = qual_orig_name data_con
778 data_con_str = occNameUserString (getOccName data_con)
779 con_arity = dataConSourceArity data_con
780 con_expr = mk_easy_App data_con_RDR as_needed
781 nullary_con = con_arity == 0
782 labels = dataConFieldLabels data_con
783 lab_fields = length labels
784 dc_nm = getName data_con
785 is_infix = isDataSymOcc (getOccName dc_nm)
787 as_needed = take con_arity as_RDRs
789 | is_infix = take (1 + con_arity) bs_RDRs
790 | lab_fields == 0 = take con_arity bs_RDRs
791 | otherwise = take (4*lab_fields + 1) bs_RDRs
792 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
794 (as1:as2:_) = as_needed
795 (bs1:bs2:bs3:_) = bs_needed
800 (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed)
801 (HsApp (HsVar lex_RDR) c_Expr)
805 (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed)
806 (HsApp (HsVar lex_RDR) (HsVar bs1))
810 str_qual str res draw_from =
812 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
813 (HsApp (HsVar lex_RDR) draw_from)
816 str_qual_paren str res draw_from =
818 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
819 (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
822 read_label f = [rd_lab, str_qual "="]
823 -- There might be spaces between the label and '='
826 | is_op = str_qual_paren nm
827 | otherwise = str_qual nm
829 occ_nm = getOccName (fieldLabelName f)
830 is_op = isSymOcc occ_nm
831 nm = occNameUserString occ_nm
835 snd (mapAccumL mk_qual_infix
837 [ (mk_read_qual lp as1, bs1, bs2)
838 , (mk_read_qual rp as2, bs3, bs3)
840 | lab_fields == 0 = -- common case.
841 snd (mapAccumL mk_qual
843 (zipWithEqual "as_needed"
844 (\ con_field draw_from -> (mk_read_qual 10 con_field,
846 as_needed bs_needed))
849 mapAccumL mk_qual d_Expr
850 (zipEqual "bs_needed"
853 intersperse [str_qual ","] $
856 (\ as b -> as ++ [b])
858 (map read_label labels)
860 (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
863 mk_qual_infix draw_from (f, str_left, str_left2) =
864 (HsVar str_left2, -- what to draw from down the line...
865 f str_left draw_from)
867 mk_qual draw_from (f, str_left) =
868 (HsVar str_left, -- what to draw from down the line...
869 f str_left draw_from)
871 mk_read_qual p con_field res draw_from =
873 (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed)
874 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
877 result_expr = ExplicitTuple [con_expr, if null bs_needed
879 else HsVar (last bs_needed)] Boxed
881 [lp,rp] = getLRPrecs is_infix get_fixity dc_nm
884 | is_infix = let (h:t) = field_quals in (h:con_qual:t)
885 | otherwise = con_qual:field_quals
887 stmts = quals ++ [ResultStmt result_expr tycon_loc]
890 c.f. Figure 18 in Haskell 1.1 report.
893 | not is_infix = defaultPrecedence
894 | otherwise = getPrecedence get_fixity dc_nm
896 read_paren_arg -- parens depend on precedence...
897 | nullary_con = false_Expr -- it's optional.
898 | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
901 %************************************************************************
903 \subsubsection{Generating @Show@ instance declarations}
905 %************************************************************************
908 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
910 gen_Show_binds get_fixity tycon
911 = shows_prec `AndMonoBinds` show_list
913 tycon_loc = getSrcLoc tycon
914 -----------------------------------------------------------------------
915 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
916 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
917 -----------------------------------------------------------------------
918 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
921 | nullary_con = -- skip the showParen junk...
922 ASSERT(null bs_needed)
923 ([wildPat, con_pat], show_con)
926 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
927 (HsPar (nested_compose_Expr show_thingies)))
929 data_con_RDR = qual_orig_name data_con
930 con_arity = dataConSourceArity data_con
931 bs_needed = take con_arity bs_RDRs
932 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
933 nullary_con = con_arity == 0
934 labels = dataConFieldLabels data_con
935 lab_fields = length labels
937 dc_nm = getName data_con
938 dc_occ_nm = getOccName data_con
939 dc_occ_nm_str = occNameUserString dc_occ_nm
941 is_infix = isDataSymOcc dc_occ_nm
945 | is_infix = mk_showString_app (' ':dc_occ_nm_str)
946 | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
950 | lab_fields == 0 = " "
954 show_all con fs@(x:xs)
955 | is_infix = x:con:xs
959 | lab_fields > 0 = [mk_showString_app "}"]
962 con:fs ++ ccurly_maybe
964 show_thingies = show_all show_con real_show_thingies_with_labs
966 show_label l = mk_showString_app (the_name ++ "=")
968 occ_nm = getOccName (fieldLabelName l)
970 is_op = isSymOcc occ_nm
972 | is_op = '(':nm ++ ")"
975 nm = occNameUserString occ_nm
978 mk_showString_app str = HsApp (HsVar showString_RDR)
979 (HsLit (mkHsString str))
981 prec_cons = getLRPrecs is_infix get_fixity dc_nm
985 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
986 | (p,b) <- zip prec_cons bs_needed ]
988 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
991 real_show_thingies_with_labs
992 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
993 | otherwise = --Assumption: no of fields == no of labelled fields
994 -- (and in same order)
996 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
997 zipWithEqual "gen_Show_binds"
999 (map show_label labels)
1003 c.f. Figure 16 and 17 in Haskell 1.1 report
1006 | not is_infix = defaultPrecedence + 1
1007 | otherwise = getPrecedence get_fixity dc_nm + 1
1012 getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer]
1013 getLRPrecs is_infix get_fixity nm = [lp, rp]
1016 Figuring out the fixities of the arguments to a constructor,
1017 cf. Figures 16-18 in Haskell 1.1 report.
1019 (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm
1020 paren_con_prec = getPrecedence get_fixity nm
1023 | not is_infix = defaultPrecedence + 1
1024 | con_left_assoc = paren_con_prec
1025 | otherwise = paren_con_prec + 1
1028 | not is_infix = defaultPrecedence + 1
1029 | con_right_assoc = paren_con_prec
1030 | otherwise = paren_con_prec + 1
1032 defaultPrecedence :: Integer
1033 defaultPrecedence = fromIntegral maxPrecedence
1035 getPrecedence :: FixityEnv -> Name -> Integer
1036 getPrecedence get_fixity nm
1037 = case lookupFixity get_fixity nm of
1038 Fixity x _ -> fromIntegral x
1040 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
1041 isLRAssoc get_fixity nm =
1042 case lookupFixity get_fixity nm of
1043 Fixity _ InfixN -> (False, False)
1044 Fixity _ InfixR -> (False, True)
1045 Fixity _ InfixL -> (True, False)
1049 %************************************************************************
1051 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1053 %************************************************************************
1058 con2tag_Foo :: Foo ... -> Int#
1059 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1060 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1063 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1068 = GenCon2Tag | GenTag2Con | GenMaxTag
1070 gen_tag_n_con_monobind
1071 :: (RdrName, -- (proto)Name for the thing in question
1072 TyCon, -- tycon in question
1076 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1077 | lots_of_constructors
1078 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1079 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1082 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1085 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1087 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1089 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1091 pat = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
1092 var_RDR = qual_orig_name var
1094 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1095 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1096 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1097 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1098 (HsTyVar (qual_orig_name tycon)))]
1100 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1101 = mk_easy_FunMonoBind (getSrcLoc tycon)
1102 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1104 max_tag = case (tyConDataCons tycon) of
1105 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1109 %************************************************************************
1111 \subsection{Utility bits for generating bindings}
1113 %************************************************************************
1115 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1117 fun pat1 pat2 ... patN = expr where binds
1120 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1121 multi-clause definitions; it generates:
1123 fun p1a p1b ... p1N = e1
1124 fun p2a p2b ... p2N = e2
1126 fun pMa pMb ... pMN = eM
1130 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1131 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1134 mk_easy_FunMonoBind loc fun pats binds expr
1135 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1137 mk_easy_Match loc pats binds expr
1138 = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
1139 -- The renamer expects everything in its input to be a
1140 -- "recursive" MonoBinds, and it is its job to sort things out
1143 mk_FunMonoBind :: SrcLoc -> RdrName
1144 -> [([RdrNamePat], RdrNameHsExpr)]
1147 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1148 mk_FunMonoBind loc fun pats_and_exprs
1149 = FunMonoBind fun False{-not infix-}
1150 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1153 mk_match loc pats expr binds
1154 = Match (map paren pats) Nothing
1155 (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1157 paren p@(VarPatIn _) = p
1158 paren other_p = ParPatIn other_p
1162 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1165 ToDo: Better SrcLocs.
1170 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1171 -> RdrNameHsExpr -> RdrNameHsExpr
1173 careful_compare_Case :: -- checks for primitive types...
1175 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1176 -> RdrNameHsExpr -> RdrNameHsExpr
1179 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1180 -- Was: compare_gen_Case cmp_eq_RDR
1182 compare_gen_Case fun lt eq gt a b
1183 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1184 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt placeHolderType generatedSrcLoc,
1185 mkSimpleMatch [ConPatIn eqTag_RDR []] eq placeHolderType generatedSrcLoc,
1186 mkSimpleMatch [ConPatIn gtTag_RDR []] gt placeHolderType generatedSrcLoc]
1189 careful_compare_Case ty lt eq gt a b
1190 | not (isUnLiftedType ty) =
1191 compare_gen_Case compare_RDR lt eq gt a b
1193 -- we have to do something special for primitive things...
1194 HsIf (genOpApp a relevant_eq_op b)
1196 (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc)
1199 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1200 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1202 assoc_ty_id tyids ty
1203 = if null res then panic "assoc_ty"
1206 res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
1209 [(charPrimTy, eqH_Char_RDR)
1210 ,(intPrimTy, eqH_Int_RDR)
1211 ,(wordPrimTy, eqH_Word_RDR)
1212 ,(addrPrimTy, eqH_Addr_RDR)
1213 ,(floatPrimTy, eqH_Float_RDR)
1214 ,(doublePrimTy, eqH_Double_RDR)
1218 [(charPrimTy, ltH_Char_RDR)
1219 ,(intPrimTy, ltH_Int_RDR)
1220 ,(wordPrimTy, ltH_Word_RDR)
1221 ,(addrPrimTy, ltH_Addr_RDR)
1222 ,(floatPrimTy, ltH_Float_RDR)
1223 ,(doublePrimTy, ltH_Double_RDR)
1226 -----------------------------------------------------------------------
1228 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1230 and_Expr a b = genOpApp a and_RDR b
1231 append_Expr a b = genOpApp a append_RDR b
1233 -----------------------------------------------------------------------
1235 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1236 eq_Expr ty a b = genOpApp a eq_op b
1239 | not (isUnLiftedType ty) = eq_RDR
1241 -- we have to do something special for primitive things...
1242 assoc_ty_id eq_op_tbl ty
1247 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1248 untag_Expr tycon [] expr = expr
1249 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1250 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1251 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
1254 cmp_tags_Expr :: RdrName -- Comparison op
1255 -> RdrName -> RdrName -- Things to compare
1256 -> RdrNameHsExpr -- What to return if true
1257 -> RdrNameHsExpr -- What to return if false
1260 cmp_tags_Expr op a b true_case false_case
1261 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1264 :: RdrNameHsExpr -> RdrNameHsExpr
1266 enum_from_then_to_Expr
1267 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1270 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1271 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1273 showParen_Expr, readParen_Expr
1274 :: RdrNameHsExpr -> RdrNameHsExpr
1277 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1278 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1280 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1282 nested_compose_Expr [e] = parenify e
1283 nested_compose_Expr (e:es)
1284 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1286 -- impossible_Expr is used in case RHSs that should never happen.
1287 -- We generate these to keep the desugarer from complaining that they *might* happen!
1288 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1290 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1291 -- method. It is currently only used by Enum.{succ,pred}
1292 illegal_Expr meth tp msg =
1293 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1295 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1296 -- to include the value of a_RDR in the error string.
1297 illegal_toEnum_tag tp maxtag =
1298 HsApp (HsVar error_RDR)
1299 (HsApp (HsApp (HsVar append_RDR)
1300 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1301 (HsApp (HsApp (HsApp
1302 (HsVar showsPrec_RDR)
1307 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1308 (HsApp (HsApp (HsApp
1309 (HsVar showsPrec_RDR)
1312 (HsLit (HsString (_PK_ ")")))))))
1314 parenify e@(HsVar _) = e
1315 parenify e = HsPar e
1317 -- genOpApp wraps brackets round the operator application, so that the
1318 -- renamer won't subsequently try to re-associate it.
1319 -- For some reason the renamer doesn't reassociate it right, and I can't
1320 -- be bothered to find out why just now.
1322 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1326 qual_orig_name n = nameRdrName (getName n)
1327 varUnqual n = mkUnqual varName n
1329 zz_a_RDR = varUnqual FSLIT("_a")
1330 a_RDR = varUnqual FSLIT("a")
1331 b_RDR = varUnqual FSLIT("b")
1332 c_RDR = varUnqual FSLIT("c")
1333 d_RDR = varUnqual FSLIT("d")
1334 ah_RDR = varUnqual FSLIT("a#")
1335 bh_RDR = varUnqual FSLIT("b#")
1336 ch_RDR = varUnqual FSLIT("c#")
1337 dh_RDR = varUnqual FSLIT("d#")
1338 cmp_eq_RDR = varUnqual FSLIT("cmp_eq")
1339 rangeSize_RDR = varUnqual FSLIT("rangeSize")
1341 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1342 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1343 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1345 mkHsString s = HsString (_PK_ s)
1347 zz_a_Expr = HsVar zz_a_RDR
1348 a_Expr = HsVar a_RDR
1349 b_Expr = HsVar b_RDR
1350 c_Expr = HsVar c_RDR
1351 d_Expr = HsVar d_RDR
1352 ltTag_Expr = HsVar ltTag_RDR
1353 eqTag_Expr = HsVar eqTag_RDR
1354 gtTag_Expr = HsVar gtTag_RDR
1355 false_Expr = HsVar false_RDR
1356 true_Expr = HsVar true_RDR
1358 getTag_Expr = HsVar getTag_RDR
1359 tagToEnum_Expr = HsVar tagToEnumH_RDR
1360 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1363 zz_a_Pat = VarPatIn zz_a_RDR
1364 a_Pat = VarPatIn a_RDR
1365 b_Pat = VarPatIn b_RDR
1366 c_Pat = VarPatIn c_RDR
1367 d_Pat = VarPatIn d_RDR
1369 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1371 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1372 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1373 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))