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(..)
37 , maxPrecedence, defaultFixity
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 PrelInfo -- Lots of RdrNames
52 import SrcLoc ( generatedSrcLoc, SrcLoc )
53 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
54 maybeTyConSingleCon, tyConFamilySize
56 import TcType ( isUnLiftedType, tcEqType, Type )
57 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
58 floatPrimTy, doublePrimTy
60 import Util ( mapAccumL, zipEqual, zipWithEqual, isSingleton,
61 zipWith3Equal, nOfThem )
62 import Panic ( panic, assertPanic )
63 import Maybes ( maybeToBool, orElse )
65 import List ( partition, intersperse )
67 #if __GLASGOW_HASKELL__ >= 404
68 import GlaExts ( fromInt )
72 %************************************************************************
74 \subsection{Generating code, by derivable class}
76 %************************************************************************
78 %************************************************************************
80 \subsubsection{Generating @Eq@ instance declarations}
82 %************************************************************************
84 Here are the heuristics for the code we generate for @Eq@:
87 Let's assume we have a data type with some (possibly zero) nullary
88 data constructors and some ordinary, non-nullary ones (the rest,
89 also possibly zero of them). Here's an example, with both \tr{N}ullary
90 and \tr{O}rdinary data cons.
92 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
96 For the ordinary constructors (if any), we emit clauses to do The
100 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
101 (==) (O2 a1) (O2 a2) = a1 == a2
102 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
105 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
106 \tr{a2} are \tr{Float#}s, then we have to generate
108 case (a1 `eqFloat#` a2) of
111 for that particular test.
114 If there are any nullary constructors, we emit a catch-all clause of
118 (==) a b = case (con2tag_Foo a) of { a# ->
119 case (con2tag_Foo b) of { b# ->
120 case (a# ==# b#) of {
125 If there aren't any nullary constructors, we emit a simpler
132 For the @(/=)@ method, we normally just use the default method.
134 If the type is an enumeration type, we could/may/should? generate
135 special code that calls @con2tag_Foo@, much like for @(==)@ shown
139 We thought about doing this: If we're also deriving @Ord@ for this
142 instance ... Eq (Foo ...) where
143 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
144 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
146 However, that requires that \tr{Ord <whatever>} was put in the context
147 for the instance decl, which it probably wasn't, so the decls
148 produced don't get through the typechecker.
152 deriveEq :: RdrName -- Class
153 -> RdrName -- Type constructor
154 -> [ (RdrName, [RdrType]) ] -- Constructors
155 -> (RdrContext, -- Context for the inst decl
156 [RdrBind], -- Binds in the inst decl
157 [RdrBind]) -- Extra value bindings outside
159 deriveEq clas tycon constrs
160 = (context, [eq_bind, ne_bind], [])
162 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
165 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
166 is_nullary (_, args) = null args
169 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
173 tycon_loc = getSrcLoc tycon
174 (nullary_cons, nonnullary_cons)
175 | isNewTyCon tycon = ([], tyConDataCons tycon)
176 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
179 = if (null nullary_cons) then
180 case maybeTyConSingleCon tycon of
182 Nothing -> -- if cons don't match, then False
183 [([wildPat, wildPat], false_Expr)]
184 else -- calc. and compare the tags
186 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
187 (genOpApp (HsVar ah_RDR) eqH_Int_RDR (HsVar bh_RDR)))]
189 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
191 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
192 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
194 ------------------------------------------------------------------
197 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
198 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
200 data_con_RDR = qual_orig_name data_con
201 con_arity = length tys_needed
202 as_needed = take con_arity as_RDRs
203 bs_needed = take con_arity bs_RDRs
204 tys_needed = dataConOrigArgTys data_con
206 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
208 nested_eq_expr [] [] [] = true_Expr
209 nested_eq_expr tys as bs
210 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
212 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
215 %************************************************************************
217 \subsubsection{Generating @Ord@ instance declarations}
219 %************************************************************************
221 For a derived @Ord@, we concentrate our attentions on @compare@
223 compare :: a -> a -> Ordering
224 data Ordering = LT | EQ | GT deriving ()
227 We will use the same example data type as above:
229 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
234 We do all the other @Ord@ methods with calls to @compare@:
236 instance ... (Ord <wurble> <wurble>) where
237 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
238 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
239 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
240 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
242 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
243 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
245 -- compare to come...
249 @compare@ always has two parts. First, we use the compared
250 data-constructors' tags to deal with the case of different
253 compare a b = case (con2tag_Foo a) of { a# ->
254 case (con2tag_Foo b) of { b# ->
255 case (a# ==# b#) of {
257 False -> case (a# <# b#) of
262 cmp_eq = ... to come ...
266 We are only left with the ``help'' function @cmp_eq@, to deal with
267 comparing data constructors with the same tag.
269 For the ordinary constructors (if any), we emit the sorta-obvious
270 compare-style stuff; for our example:
272 cmp_eq (O1 a1 b1) (O1 a2 b2)
273 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
275 cmp_eq (O2 a1) (O2 a2)
278 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
279 = case (compare a1 a2) of {
282 EQ -> case compare b1 b2 of {
290 Again, we must be careful about unlifted comparisons. For example,
291 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
295 cmp_eq lt eq gt (O2 a1) (O2 a2)
297 -- or maybe the unfolded equivalent
301 For the remaining nullary constructors, we already know that the
308 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
312 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
315 = compare -- `AndMonoBinds` compare
316 -- The default declaration in PrelBase handles this
318 tycon_loc = getSrcLoc tycon
319 --------------------------------------------------------------------
320 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
323 (if maybeToBool (maybeTyConSingleCon tycon) then
325 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
326 -- Weird. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
328 cmp_eq_Expr a_Expr b_Expr
330 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
331 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
332 -- True case; they are equal
333 -- If an enumeration type we are done; else
334 -- recursively compare their components
335 (if isEnumerationTyCon tycon then
338 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
340 cmp_eq_Expr a_Expr b_Expr
342 -- False case; they aren't equal
343 -- So we need to do a less-than comparison on the tags
344 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
346 tycon_data_cons = tyConDataCons tycon
347 (nullary_cons, nonnullary_cons)
348 | isNewTyCon tycon = ([], tyConDataCons tycon)
349 | otherwise = partition isNullaryDataCon tycon_data_cons
352 mk_FunMonoBind tycon_loc
354 (if null nonnullary_cons && isSingleton nullary_cons then
355 -- catch this specially to avoid warnings
356 -- about overlapping patterns from the desugarer.
358 data_con = head nullary_cons
359 data_con_RDR = qual_orig_name data_con
360 pat = ConPatIn data_con_RDR []
362 [([pat,pat], eqTag_Expr)]
364 map pats_etc nonnullary_cons ++
365 -- leave out wildcards to silence desugarer.
366 (if isSingleton tycon_data_cons then
369 [([WildPatIn, WildPatIn], default_rhs)]))
372 = ([con1_pat, con2_pat],
373 nested_compare_expr tys_needed as_needed bs_needed)
375 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
376 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
378 data_con_RDR = qual_orig_name data_con
379 con_arity = length tys_needed
380 as_needed = take con_arity as_RDRs
381 bs_needed = take con_arity bs_RDRs
382 tys_needed = dataConOrigArgTys data_con
384 nested_compare_expr [ty] [a] [b]
385 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
387 nested_compare_expr (ty:tys) (a:as) (b:bs)
388 = let eq_expr = nested_compare_expr tys as bs
389 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
391 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
392 -- inexhaustive patterns
393 | otherwise = eqTag_Expr -- Some nullary constructors;
394 -- Tags are equal, no args => return EQ
397 %************************************************************************
399 \subsubsection{Generating @Enum@ instance declarations}
401 %************************************************************************
403 @Enum@ can only be derived for enumeration types. For a type
405 data Foo ... = N1 | N2 | ... | Nn
408 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
409 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
412 instance ... Enum (Foo ...) where
413 succ x = toEnum (1 + fromEnum x)
414 pred x = toEnum (fromEnum x - 1)
416 toEnum i = tag2con_Foo i
418 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
422 = case con2tag_Foo a of
423 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
426 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
430 = case con2tag_Foo a of { a# ->
431 case con2tag_Foo b of { b# ->
432 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
436 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
439 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
442 = succ_enum `AndMonoBinds`
443 pred_enum `AndMonoBinds`
444 to_enum `AndMonoBinds`
445 enum_from `AndMonoBinds`
446 enum_from_then `AndMonoBinds`
449 tycon_loc = getSrcLoc tycon
450 occ_nm = getOccString tycon
453 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
454 untag_Expr tycon [(a_RDR, ah_RDR)] $
455 HsIf (HsApp (HsApp (HsVar eq_RDR)
456 (HsVar (maxtag_RDR tycon)))
457 (mk_easy_App mkInt_RDR [ah_RDR]))
458 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
459 (HsApp (HsVar (tag2con_RDR tycon))
460 (HsApp (HsApp (HsVar plus_RDR)
461 (mk_easy_App mkInt_RDR [ah_RDR]))
466 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
467 untag_Expr tycon [(a_RDR, ah_RDR)] $
468 HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
469 (mk_easy_App mkInt_RDR [ah_RDR]))
470 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
471 (HsApp (HsVar (tag2con_RDR tycon))
472 (HsApp (HsApp (HsVar plus_RDR)
473 (mk_easy_App mkInt_RDR [ah_RDR]))
474 (HsLit (HsInt (-1)))))
478 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
481 (HsApp (HsApp (HsVar ge_RDR)
484 (HsApp (HsApp (HsVar le_RDR)
486 (HsVar (maxtag_RDR tycon))))
487 (mk_easy_App (tag2con_RDR tycon) [a_RDR])
488 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
492 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
493 untag_Expr tycon [(a_RDR, ah_RDR)] $
494 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
495 HsPar (enum_from_to_Expr
496 (mk_easy_App mkInt_RDR [ah_RDR])
497 (HsVar (maxtag_RDR tycon)))
500 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
501 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
502 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
503 HsPar (enum_from_then_to_Expr
504 (mk_easy_App mkInt_RDR [ah_RDR])
505 (mk_easy_App mkInt_RDR [bh_RDR])
506 (HsIf (HsApp (HsApp (HsVar gt_RDR)
507 (mk_easy_App mkInt_RDR [ah_RDR]))
508 (mk_easy_App mkInt_RDR [bh_RDR]))
510 (HsVar (maxtag_RDR tycon))
514 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
515 untag_Expr tycon [(a_RDR, ah_RDR)] $
516 (mk_easy_App mkInt_RDR [ah_RDR])
519 %************************************************************************
521 \subsubsection{Generating @Bounded@ instance declarations}
523 %************************************************************************
526 gen_Bounded_binds tycon
527 = if isEnumerationTyCon tycon then
528 min_bound_enum `AndMonoBinds` max_bound_enum
530 ASSERT(isSingleton data_cons)
531 min_bound_1con `AndMonoBinds` max_bound_1con
533 data_cons = tyConDataCons tycon
534 tycon_loc = getSrcLoc tycon
536 ----- enum-flavored: ---------------------------
537 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
538 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
540 data_con_1 = head data_cons
541 data_con_N = last data_cons
542 data_con_1_RDR = qual_orig_name data_con_1
543 data_con_N_RDR = qual_orig_name data_con_N
545 ----- single-constructor-flavored: -------------
546 arity = dataConSourceArity data_con_1
548 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
549 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
550 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
551 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
554 %************************************************************************
556 \subsubsection{Generating @Ix@ instance declarations}
558 %************************************************************************
560 Deriving @Ix@ is only possible for enumeration types and
561 single-constructor types. We deal with them in turn.
563 For an enumeration type, e.g.,
565 data Foo ... = N1 | N2 | ... | Nn
567 things go not too differently from @Enum@:
569 instance ... Ix (Foo ...) where
571 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
575 = case (con2tag_Foo a) of { a# ->
576 case (con2tag_Foo b) of { b# ->
577 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
582 then case (con2tag_Foo d -# con2tag_Foo a) of
584 else error "Ix.Foo.index: out of range"
588 p_tag = con2tag_Foo c
590 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
594 = case (con2tag_Foo a) of { a_tag ->
595 case (con2tag_Foo b) of { b_tag ->
596 case (con2tag_Foo c) of { c_tag ->
597 if (c_tag >=# a_tag) then
603 (modulo suitable case-ification to handle the unlifted tags)
605 For a single-constructor type (NB: this includes all tuples), e.g.,
607 data Foo ... = MkFoo a b Int Double c c
609 we follow the scheme given in Figure~19 of the Haskell~1.2 report
613 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
616 = if isEnumerationTyCon tycon
620 tycon_str = getOccString tycon
621 tycon_loc = getSrcLoc tycon
623 --------------------------------------------------------------
624 enum_ixes = enum_range `AndMonoBinds`
625 enum_index `AndMonoBinds` enum_inRange
628 = mk_easy_FunMonoBind tycon_loc range_RDR
629 [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
630 untag_Expr tycon [(a_RDR, ah_RDR)] $
631 untag_Expr tycon [(b_RDR, bh_RDR)] $
632 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
633 HsPar (enum_from_to_Expr
634 (mk_easy_App mkInt_RDR [ah_RDR])
635 (mk_easy_App mkInt_RDR [bh_RDR]))
638 = mk_easy_FunMonoBind tycon_loc index_RDR
639 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
641 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
642 untag_Expr tycon [(a_RDR, ah_RDR)] (
643 untag_Expr tycon [(d_RDR, dh_RDR)] (
645 rhs = mk_easy_App mkInt_RDR [c_RDR]
648 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
649 [mkSimpleMatch [VarPatIn c_RDR] rhs placeHolderType tycon_loc]
653 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
658 = mk_easy_FunMonoBind tycon_loc inRange_RDR
659 [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
660 untag_Expr tycon [(a_RDR, ah_RDR)] (
661 untag_Expr tycon [(b_RDR, bh_RDR)] (
662 untag_Expr tycon [(c_RDR, ch_RDR)] (
663 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
664 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
669 --------------------------------------------------------------
671 = single_con_range `AndMonoBinds`
672 single_con_index `AndMonoBinds`
676 = case maybeTyConSingleCon tycon of -- just checking...
677 Nothing -> panic "get_Ix_binds"
678 Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
679 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
683 con_arity = dataConSourceArity data_con
684 data_con_RDR = qual_orig_name data_con
686 as_needed = take con_arity as_RDRs
687 bs_needed = take con_arity bs_RDRs
688 cs_needed = take con_arity cs_RDRs
690 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
691 con_expr = mk_easy_App data_con_RDR cs_needed
693 --------------------------------------------------------------
695 = mk_easy_FunMonoBind tycon_loc range_RDR
696 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
697 HsDo ListComp stmts tycon_loc
699 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
701 [ResultStmt con_expr tycon_loc]
703 mk_qual a b c = BindStmt (VarPatIn c)
704 (HsApp (HsVar range_RDR)
705 (ExplicitTuple [HsVar a, HsVar b] Boxed))
710 = mk_easy_FunMonoBind tycon_loc index_RDR
711 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
712 con_pat cs_needed] [range_size] (
713 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
715 mk_index multiply_by (l, u, i)
717 (HsApp (HsApp (HsVar index_RDR)
718 (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i))
721 (HsApp (HsVar rangeSize_RDR)
722 (ExplicitTuple [HsVar l, HsVar u] Boxed))
723 ) times_RDR multiply_by
727 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
728 [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
730 (HsApp (HsApp (HsVar index_RDR)
731 (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr)
732 ) plus_RDR (HsLit (HsInt 1)))
736 = mk_easy_FunMonoBind tycon_loc inRange_RDR
737 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
740 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
742 in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
743 (ExplicitTuple [HsVar a, HsVar b] Boxed))
747 %************************************************************************
749 \subsubsection{Generating @Read@ instance declarations}
751 %************************************************************************
754 gen_Read_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
756 gen_Read_binds get_fixity tycon
757 = reads_prec `AndMonoBinds` read_list
759 tycon_loc = getSrcLoc tycon
760 -----------------------------------------------------------------------
761 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
762 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
763 -----------------------------------------------------------------------
766 read_con_comprehensions
767 = map read_con (tyConDataCons tycon)
769 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] (
770 foldr1 append_Expr read_con_comprehensions
773 read_con data_con -- note: "b" is the string being "read"
775 readParen_Expr read_paren_arg $ HsPar $
776 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
777 HsDo ListComp stmts tycon_loc)
780 data_con_RDR = qual_orig_name data_con
781 data_con_str = occNameUserString (getOccName data_con)
782 con_arity = dataConSourceArity data_con
783 con_expr = mk_easy_App data_con_RDR as_needed
784 nullary_con = con_arity == 0
785 labels = dataConFieldLabels data_con
786 lab_fields = length labels
787 dc_nm = getName data_con
788 is_infix = isDataSymOcc (getOccName dc_nm)
790 as_needed = take con_arity as_RDRs
792 | is_infix = take (1 + con_arity) bs_RDRs
793 | lab_fields == 0 = take con_arity bs_RDRs
794 | otherwise = take (4*lab_fields + 1) bs_RDRs
795 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
797 (as1:as2:_) = as_needed
798 (bs1:bs2:bs3:_) = bs_needed
803 (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed)
804 (HsApp (HsVar lex_RDR) c_Expr)
808 (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed)
809 (HsApp (HsVar lex_RDR) (HsVar bs1))
813 str_qual str res draw_from =
815 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
816 (HsApp (HsVar lex_RDR) draw_from)
819 str_qual_paren str res draw_from =
821 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
822 (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
825 read_label f = [rd_lab, str_qual "="]
826 -- There might be spaces between the label and '='
829 | is_op = str_qual_paren nm
830 | otherwise = str_qual nm
832 occ_nm = getOccName (fieldLabelName f)
833 is_op = isSymOcc occ_nm
834 nm = occNameUserString occ_nm
838 snd (mapAccumL mk_qual_infix
840 [ (mk_read_qual lp as1, bs1, bs2)
841 , (mk_read_qual rp as2, bs3, bs3)
843 | lab_fields == 0 = -- common case.
844 snd (mapAccumL mk_qual
846 (zipWithEqual "as_needed"
847 (\ con_field draw_from -> (mk_read_qual 10 con_field,
849 as_needed bs_needed))
852 mapAccumL mk_qual d_Expr
853 (zipEqual "bs_needed"
856 intersperse [str_qual ","] $
859 (\ as b -> as ++ [b])
861 (map read_label labels)
863 (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
866 mk_qual_infix draw_from (f, str_left, str_left2) =
867 (HsVar str_left2, -- what to draw from down the line...
868 f str_left draw_from)
870 mk_qual draw_from (f, str_left) =
871 (HsVar str_left, -- what to draw from down the line...
872 f str_left draw_from)
874 mk_read_qual p con_field res draw_from =
876 (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed)
877 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
880 result_expr = ExplicitTuple [con_expr, if null bs_needed
882 else HsVar (last bs_needed)] Boxed
884 [lp,rp] = getLRPrecs is_infix get_fixity dc_nm
887 | is_infix = let (h:t) = field_quals in (h:con_qual:t)
888 | otherwise = con_qual:field_quals
890 stmts = quals ++ [ResultStmt result_expr tycon_loc]
893 c.f. Figure 18 in Haskell 1.1 report.
896 | not is_infix = defaultPrecedence
897 | otherwise = getPrecedence get_fixity dc_nm
899 read_paren_arg -- parens depend on precedence...
900 | nullary_con = false_Expr -- it's optional.
901 | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
904 %************************************************************************
906 \subsubsection{Generating @Show@ instance declarations}
908 %************************************************************************
911 gen_Show_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
913 gen_Show_binds get_fixity tycon
914 = shows_prec `AndMonoBinds` show_list
916 tycon_loc = getSrcLoc tycon
917 -----------------------------------------------------------------------
918 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
919 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
920 -----------------------------------------------------------------------
921 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
924 | nullary_con = -- skip the showParen junk...
925 ASSERT(null bs_needed)
926 ([wildPat, con_pat], show_con)
929 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
930 (HsPar (nested_compose_Expr show_thingies)))
932 data_con_RDR = qual_orig_name data_con
933 con_arity = dataConSourceArity data_con
934 bs_needed = take con_arity bs_RDRs
935 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
936 nullary_con = con_arity == 0
937 labels = dataConFieldLabels data_con
938 lab_fields = length labels
940 dc_nm = getName data_con
941 dc_occ_nm = getOccName data_con
942 dc_occ_nm_str = occNameUserString dc_occ_nm
944 is_infix = isDataSymOcc dc_occ_nm
948 | is_infix = mk_showString_app (' ':dc_occ_nm_str)
949 | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
953 | lab_fields == 0 = " "
957 show_all con fs@(x:xs)
958 | is_infix = x:con:xs
962 | lab_fields > 0 = [mk_showString_app "}"]
965 con:fs ++ ccurly_maybe
967 show_thingies = show_all show_con real_show_thingies_with_labs
969 show_label l = mk_showString_app (the_name ++ "=")
971 occ_nm = getOccName (fieldLabelName l)
973 is_op = isSymOcc occ_nm
975 | is_op = '(':nm ++ ")"
978 nm = occNameUserString occ_nm
981 mk_showString_app str = HsApp (HsVar showString_RDR)
982 (HsLit (mkHsString str))
984 prec_cons = getLRPrecs is_infix get_fixity dc_nm
988 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
989 | (p,b) <- zip prec_cons bs_needed ]
991 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
994 real_show_thingies_with_labs
995 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
996 | otherwise = --Assumption: no of fields == no of labelled fields
997 -- (and in same order)
999 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
1000 zipWithEqual "gen_Show_binds"
1002 (map show_label labels)
1006 c.f. Figure 16 and 17 in Haskell 1.1 report
1009 | not is_infix = defaultPrecedence + 1
1010 | otherwise = getPrecedence get_fixity dc_nm + 1
1015 getLRPrecs :: Bool -> (Name -> Maybe Fixity) -> Name -> [Integer]
1016 getLRPrecs is_infix get_fixity nm = [lp, rp]
1019 Figuring out the fixities of the arguments to a constructor,
1020 cf. Figures 16-18 in Haskell 1.1 report.
1022 (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm
1023 paren_con_prec = getPrecedence get_fixity nm
1026 | not is_infix = defaultPrecedence + 1
1027 | con_left_assoc = paren_con_prec
1028 | otherwise = paren_con_prec + 1
1031 | not is_infix = defaultPrecedence + 1
1032 | con_right_assoc = paren_con_prec
1033 | otherwise = paren_con_prec + 1
1035 defaultPrecedence :: Integer
1036 defaultPrecedence = fromInt maxPrecedence
1038 getPrecedence :: (Name -> Maybe Fixity) -> Name -> Integer
1039 getPrecedence get_fixity nm
1040 = case get_fixity nm of
1041 Just (Fixity x _) -> fromInt x
1042 other -> defaultPrecedence
1044 isLRAssoc :: (Name -> Maybe Fixity) -> Name -> (Bool, Bool)
1045 isLRAssoc get_fixity nm =
1046 case get_fixity nm `orElse` defaultFixity of
1047 Fixity _ InfixN -> (False, False)
1048 Fixity _ InfixR -> (False, True)
1049 Fixity _ InfixL -> (True, False)
1053 %************************************************************************
1055 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1057 %************************************************************************
1062 con2tag_Foo :: Foo ... -> Int#
1063 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1064 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1067 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1072 = GenCon2Tag | GenTag2Con | GenMaxTag
1074 gen_tag_n_con_monobind
1075 :: (RdrName, -- (proto)Name for the thing in question
1076 TyCon, -- tycon in question
1080 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1081 | lots_of_constructors
1082 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1083 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1086 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1089 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1091 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1093 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1095 pat = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
1096 var_RDR = qual_orig_name var
1098 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1099 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1100 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1101 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1102 (HsTyVar (qual_orig_name tycon)))]
1104 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1105 = mk_easy_FunMonoBind (getSrcLoc tycon)
1106 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1108 max_tag = case (tyConDataCons tycon) of
1109 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1113 %************************************************************************
1115 \subsection{Utility bits for generating bindings}
1117 %************************************************************************
1119 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1121 fun pat1 pat2 ... patN = expr where binds
1124 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1125 multi-clause definitions; it generates:
1127 fun p1a p1b ... p1N = e1
1128 fun p2a p2b ... p2N = e2
1130 fun pMa pMb ... pMN = eM
1134 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1135 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1138 mk_easy_FunMonoBind loc fun pats binds expr
1139 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1141 mk_easy_Match loc pats binds expr
1142 = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
1143 -- The renamer expects everything in its input to be a
1144 -- "recursive" MonoBinds, and it is its job to sort things out
1147 mk_FunMonoBind :: SrcLoc -> RdrName
1148 -> [([RdrNamePat], RdrNameHsExpr)]
1151 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1152 mk_FunMonoBind loc fun pats_and_exprs
1153 = FunMonoBind fun False{-not infix-}
1154 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1157 mk_match loc pats expr binds
1158 = Match (map paren pats) Nothing
1159 (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1161 paren p@(VarPatIn _) = p
1162 paren other_p = ParPatIn other_p
1166 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1169 ToDo: Better SrcLocs.
1174 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1175 -> RdrNameHsExpr -> RdrNameHsExpr
1177 careful_compare_Case :: -- checks for primitive types...
1179 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1180 -> RdrNameHsExpr -> RdrNameHsExpr
1183 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1184 -- Was: compare_gen_Case cmp_eq_RDR
1186 compare_gen_Case fun lt eq gt a b
1187 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1188 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt placeHolderType generatedSrcLoc,
1189 mkSimpleMatch [ConPatIn eqTag_RDR []] eq placeHolderType generatedSrcLoc,
1190 mkSimpleMatch [ConPatIn gtTag_RDR []] gt placeHolderType generatedSrcLoc]
1193 careful_compare_Case ty lt eq gt a b
1194 | not (isUnLiftedType ty) =
1195 compare_gen_Case compare_RDR lt eq gt a b
1197 -- we have to do something special for primitive things...
1198 HsIf (genOpApp a relevant_eq_op b)
1200 (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc)
1203 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1204 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1206 assoc_ty_id tyids ty
1207 = if null res then panic "assoc_ty"
1210 res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
1213 [(charPrimTy, eqH_Char_RDR)
1214 ,(intPrimTy, eqH_Int_RDR)
1215 ,(wordPrimTy, eqH_Word_RDR)
1216 ,(addrPrimTy, eqH_Addr_RDR)
1217 ,(floatPrimTy, eqH_Float_RDR)
1218 ,(doublePrimTy, eqH_Double_RDR)
1222 [(charPrimTy, ltH_Char_RDR)
1223 ,(intPrimTy, ltH_Int_RDR)
1224 ,(wordPrimTy, ltH_Word_RDR)
1225 ,(addrPrimTy, ltH_Addr_RDR)
1226 ,(floatPrimTy, ltH_Float_RDR)
1227 ,(doublePrimTy, ltH_Double_RDR)
1230 -----------------------------------------------------------------------
1232 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1234 and_Expr a b = genOpApp a and_RDR b
1235 append_Expr a b = genOpApp a append_RDR b
1237 -----------------------------------------------------------------------
1239 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1240 eq_Expr ty a b = genOpApp a eq_op b
1243 | not (isUnLiftedType ty) = eq_RDR
1245 -- we have to do something special for primitive things...
1246 assoc_ty_id eq_op_tbl ty
1251 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1252 untag_Expr tycon [] expr = expr
1253 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1254 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1255 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
1258 cmp_tags_Expr :: RdrName -- Comparison op
1259 -> RdrName -> RdrName -- Things to compare
1260 -> RdrNameHsExpr -- What to return if true
1261 -> RdrNameHsExpr -- What to return if false
1264 cmp_tags_Expr op a b true_case false_case
1265 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1268 :: RdrNameHsExpr -> RdrNameHsExpr
1270 enum_from_then_to_Expr
1271 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1274 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1275 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1277 showParen_Expr, readParen_Expr
1278 :: RdrNameHsExpr -> RdrNameHsExpr
1281 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1282 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1284 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1286 nested_compose_Expr [e] = parenify e
1287 nested_compose_Expr (e:es)
1288 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1290 -- impossible_Expr is used in case RHSs that should never happen.
1291 -- We generate these to keep the desugarer from complaining that they *might* happen!
1292 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1294 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1295 -- method. It is currently only used by Enum.{succ,pred}
1296 illegal_Expr meth tp msg =
1297 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1299 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1300 -- to include the value of a_RDR in the error string.
1301 illegal_toEnum_tag tp maxtag =
1302 HsApp (HsVar error_RDR)
1303 (HsApp (HsApp (HsVar append_RDR)
1304 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1305 (HsApp (HsApp (HsApp
1306 (HsVar showsPrec_RDR)
1311 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1312 (HsApp (HsApp (HsApp
1313 (HsVar showsPrec_RDR)
1316 (HsLit (HsString (_PK_ ")")))))))
1318 parenify e@(HsVar _) = e
1319 parenify e = HsPar e
1321 -- genOpApp wraps brackets round the operator application, so that the
1322 -- renamer won't subsequently try to re-associate it.
1323 -- For some reason the renamer doesn't reassociate it right, and I can't
1324 -- be bothered to find out why just now.
1326 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1330 qual_orig_name n = nameRdrName (getName n)
1331 varUnqual n = mkUnqual varName n
1333 zz_a_RDR = varUnqual SLIT("_a")
1334 a_RDR = varUnqual SLIT("a")
1335 b_RDR = varUnqual SLIT("b")
1336 c_RDR = varUnqual SLIT("c")
1337 d_RDR = varUnqual SLIT("d")
1338 ah_RDR = varUnqual SLIT("a#")
1339 bh_RDR = varUnqual SLIT("b#")
1340 ch_RDR = varUnqual SLIT("c#")
1341 dh_RDR = varUnqual SLIT("d#")
1342 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1343 rangeSize_RDR = varUnqual SLIT("rangeSize")
1345 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1346 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1347 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1349 mkHsString s = HsString (_PK_ s)
1351 zz_a_Expr = HsVar zz_a_RDR
1352 a_Expr = HsVar a_RDR
1353 b_Expr = HsVar b_RDR
1354 c_Expr = HsVar c_RDR
1355 d_Expr = HsVar d_RDR
1356 ltTag_Expr = HsVar ltTag_RDR
1357 eqTag_Expr = HsVar eqTag_RDR
1358 gtTag_Expr = HsVar gtTag_RDR
1359 false_Expr = HsVar false_RDR
1360 true_Expr = HsVar true_RDR
1362 getTag_Expr = HsVar getTag_RDR
1363 tagToEnum_Expr = HsVar tagToEnumH_RDR
1364 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1367 zz_a_Pat = VarPatIn zz_a_RDR
1368 a_Pat = VarPatIn a_RDR
1369 b_Pat = VarPatIn b_RDR
1370 c_Pat = VarPatIn c_RDR
1371 d_Pat = VarPatIn d_RDR
1373 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1375 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1376 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1377 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))