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(..), HsType(..),
32 unguardedRHS, mkSimpleMatch
34 import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
35 import RdrName ( RdrName, mkSrcUnqual )
36 import RnMonad ( Fixities )
37 import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) )
38 import FieldLabel ( fieldLabelName )
39 import DataCon ( isNullaryDataCon, dataConTag,
40 dataConRawArgTys, fIRST_TAG,
43 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
44 occNameUserString, nameRdrName, varName,
45 OccName, Name, NamedThing(..), NameSpace
48 import PrimOp ( PrimOp(..) )
49 import PrelInfo -- Lots of RdrNames
50 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
51 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
52 maybeTyConSingleCon, tyConFamilySize
54 import Type ( isUnLiftedType, isUnboxedType, Type )
55 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
56 floatPrimTy, doublePrimTy
58 import Util ( mapAccumL, zipEqual, zipWithEqual,
59 zipWith3Equal, nOfThem )
60 import Panic ( panic, assertPanic )
61 import Maybes ( maybeToBool, assocMaybe )
63 import List ( partition, intersperse )
66 %************************************************************************
68 \subsection{Generating code, by derivable class}
70 %************************************************************************
72 %************************************************************************
74 \subsubsection{Generating @Eq@ instance declarations}
76 %************************************************************************
78 Here are the heuristics for the code we generate for @Eq@:
81 Let's assume we have a data type with some (possibly zero) nullary
82 data constructors and some ordinary, non-nullary ones (the rest,
83 also possibly zero of them). Here's an example, with both \tr{N}ullary
84 and \tr{O}rdinary data cons.
86 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
90 For the ordinary constructors (if any), we emit clauses to do The
94 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
95 (==) (O2 a1) (O2 a2) = a1 == a2
96 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
99 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
100 \tr{a2} are \tr{Float#}s, then we have to generate
102 case (a1 `eqFloat#` a2) of
105 for that particular test.
108 If there are any nullary constructors, we emit a catch-all clause of
112 (==) a b = case (con2tag_Foo a) of { a# ->
113 case (con2tag_Foo b) of { b# ->
114 case (a# ==# b#) of {
119 If there aren't any nullary constructors, we emit a simpler
126 For the @(/=)@ method, we normally just use the default method.
128 If the type is an enumeration type, we could/may/should? generate
129 special code that calls @con2tag_Foo@, much like for @(==)@ shown
133 We thought about doing this: If we're also deriving @Ord@ for this
136 instance ... Eq (Foo ...) where
137 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
138 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
140 However, that requires that \tr{Ord <whatever>} was put in the context
141 for the instance decl, which it probably wasn't, so the decls
142 produced don't get through the typechecker.
146 deriveEq :: RdrName -- Class
147 -> RdrName -- Type constructor
148 -> [ (RdrName, [RdrType]) ] -- Constructors
149 -> (RdrContext, -- Context for the inst decl
150 [RdrBind], -- Binds in the inst decl
151 [RdrBind]) -- Extra value bindings outside
153 deriveEq clas tycon constrs
154 = (context, [eq_bind, ne_bind], [])
156 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
159 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
160 is_nullary (_, args) = null args
163 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
167 tycon_loc = getSrcLoc tycon
168 (nullary_cons, nonnullary_cons)
169 | isNewTyCon tycon = ([], tyConDataCons tycon)
170 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
173 = if (null nullary_cons) then
174 case maybeTyConSingleCon tycon of
176 Nothing -> -- if cons don't match, then False
177 [([a_Pat, b_Pat], false_Expr)]
178 else -- calc. and compare the tags
180 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
181 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
183 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
185 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
186 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
188 ------------------------------------------------------------------
191 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
192 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
194 data_con_RDR = qual_orig_name data_con
195 con_arity = length tys_needed
196 as_needed = take con_arity as_RDRs
197 bs_needed = take con_arity bs_RDRs
198 tys_needed = dataConRawArgTys data_con
200 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
202 nested_eq_expr [] [] [] = true_Expr
203 nested_eq_expr tys as bs
204 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
206 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
209 %************************************************************************
211 \subsubsection{Generating @Ord@ instance declarations}
213 %************************************************************************
215 For a derived @Ord@, we concentrate our attentions on @compare@
217 compare :: a -> a -> Ordering
218 data Ordering = LT | EQ | GT deriving ()
221 We will use the same example data type as above:
223 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
228 We do all the other @Ord@ methods with calls to @compare@:
230 instance ... (Ord <wurble> <wurble>) where
231 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
232 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
233 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
234 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
236 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
237 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
239 -- compare to come...
243 @compare@ always has two parts. First, we use the compared
244 data-constructors' tags to deal with the case of different
247 compare a b = case (con2tag_Foo a) of { a# ->
248 case (con2tag_Foo b) of { b# ->
249 case (a# ==# b#) of {
251 False -> case (a# <# b#) of
256 cmp_eq = ... to come ...
260 We are only left with the ``help'' function @cmp_eq@, to deal with
261 comparing data constructors with the same tag.
263 For the ordinary constructors (if any), we emit the sorta-obvious
264 compare-style stuff; for our example:
266 cmp_eq (O1 a1 b1) (O1 a2 b2)
267 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
269 cmp_eq (O2 a1) (O2 a2)
272 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
273 = case (compare a1 a2) of {
276 EQ -> case compare b1 b2 of {
284 Again, we must be careful about unboxed comparisons. For example,
285 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
289 cmp_eq lt eq gt (O2 a1) (O2 a2)
291 -- or maybe the unfolded equivalent
295 For the remaining nullary constructors, we already know that the
302 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
306 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
309 = defaulted `AndMonoBinds` compare
311 tycon_loc = getSrcLoc tycon
312 --------------------------------------------------------------------
313 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
316 (if maybeToBool (maybeTyConSingleCon tycon) then
318 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
319 -- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
321 cmp_eq_Expr a_Expr b_Expr
323 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
324 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
325 -- True case; they are equal
326 -- If an enumeration type we are done; else
327 -- recursively compare their components
328 (if isEnumerationTyCon tycon then
331 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
333 cmp_eq_Expr a_Expr b_Expr
335 -- False case; they aren't equal
336 -- So we need to do a less-than comparison on the tags
337 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
339 tycon_data_cons = tyConDataCons tycon
340 (nullary_cons, nonnullary_cons)
341 | isNewTyCon tycon = ([], tyConDataCons tycon)
342 | otherwise = partition isNullaryDataCon tycon_data_cons
345 mk_FunMonoBind tycon_loc
347 (if null nonnullary_cons && (length nullary_cons == 1) then
348 -- catch this specially to avoid warnings
349 -- about overlapping patterns from the desugarer.
351 data_con = head nullary_cons
352 data_con_RDR = qual_orig_name data_con
353 pat = ConPatIn data_con_RDR []
355 [([pat,pat], eqTag_Expr)]
357 map pats_etc nonnullary_cons ++
358 -- leave out wildcards to silence desugarer.
359 (if length tycon_data_cons == 1 then
362 [([WildPatIn, WildPatIn], default_rhs)]))
365 = ([con1_pat, con2_pat],
366 nested_compare_expr tys_needed as_needed bs_needed)
368 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
369 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
371 data_con_RDR = qual_orig_name data_con
372 con_arity = length tys_needed
373 as_needed = take con_arity as_RDRs
374 bs_needed = take con_arity bs_RDRs
375 tys_needed = dataConRawArgTys data_con
377 nested_compare_expr [ty] [a] [b]
378 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
380 nested_compare_expr (ty:tys) (a:as) (b:bs)
381 = let eq_expr = nested_compare_expr tys as bs
382 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
384 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
385 -- inexhaustive patterns
386 | otherwise = eqTag_Expr -- Some nullary constructors;
387 -- Tags are equal, no args => return EQ
388 --------------------------------------------------------------------
390 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
392 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
393 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
394 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
395 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
396 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
397 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
398 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
399 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
401 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
402 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
403 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
404 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
407 %************************************************************************
409 \subsubsection{Generating @Enum@ instance declarations}
411 %************************************************************************
413 @Enum@ can only be derived for enumeration types. For a type
415 data Foo ... = N1 | N2 | ... | Nn
418 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
419 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
422 instance ... Enum (Foo ...) where
423 succ x = toEnum (1 + fromEnum x)
424 pred x = toEnum (fromEnum x - 1)
426 toEnum i = tag2con_Foo i
428 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
432 = case con2tag_Foo a of
433 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
436 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
440 = case con2tag_Foo a of { a# ->
441 case con2tag_Foo b of { b# ->
442 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
446 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
449 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
452 = succ_enum `AndMonoBinds`
453 pred_enum `AndMonoBinds`
454 to_enum `AndMonoBinds`
455 enum_from `AndMonoBinds`
456 enum_from_then `AndMonoBinds`
459 tycon_loc = getSrcLoc tycon
460 occ_nm = getOccString tycon
463 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
464 untag_Expr tycon [(a_RDR, ah_RDR)] $
465 HsIf (HsApp (HsApp (HsVar eq_RDR)
466 (HsVar (maxtag_RDR tycon)))
467 (mk_easy_App mkInt_RDR [ah_RDR]))
468 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
469 (HsApp (HsVar (tag2con_RDR tycon))
470 (HsApp (HsApp (HsVar plus_RDR)
471 (mk_easy_App mkInt_RDR [ah_RDR]))
476 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
477 untag_Expr tycon [(a_RDR, ah_RDR)] $
478 HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
479 (mk_easy_App mkInt_RDR [ah_RDR]))
480 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
481 (HsApp (HsVar (tag2con_RDR tycon))
482 (HsApp (HsApp (HsVar plus_RDR)
483 (mk_easy_App mkInt_RDR [ah_RDR]))
484 (HsLit (HsInt (-1)))))
488 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
491 (HsApp (HsApp (HsVar ge_RDR)
494 (HsApp (HsApp (HsVar le_RDR)
496 (HsVar (maxtag_RDR tycon))))
497 (mk_easy_App (tag2con_RDR tycon) [a_RDR])
498 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
502 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
503 untag_Expr tycon [(a_RDR, ah_RDR)] $
504 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
505 HsPar (enum_from_to_Expr
506 (mk_easy_App mkInt_RDR [ah_RDR])
507 (HsVar (maxtag_RDR tycon)))
510 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
511 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
512 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
513 HsPar (enum_from_then_to_Expr
514 (mk_easy_App mkInt_RDR [ah_RDR])
515 (mk_easy_App mkInt_RDR [bh_RDR])
516 (HsIf (HsApp (HsApp (HsVar gt_RDR)
517 (mk_easy_App mkInt_RDR [ah_RDR]))
518 (mk_easy_App mkInt_RDR [bh_RDR]))
520 (HsVar (maxtag_RDR tycon))
524 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
525 untag_Expr tycon [(a_RDR, ah_RDR)] $
526 (mk_easy_App mkInt_RDR [ah_RDR])
529 %************************************************************************
531 \subsubsection{Generating @Bounded@ instance declarations}
533 %************************************************************************
536 gen_Bounded_binds tycon
537 = if isEnumerationTyCon tycon then
538 min_bound_enum `AndMonoBinds` max_bound_enum
540 ASSERT(length data_cons == 1)
541 min_bound_1con `AndMonoBinds` max_bound_1con
543 data_cons = tyConDataCons tycon
544 tycon_loc = getSrcLoc tycon
546 ----- enum-flavored: ---------------------------
547 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
548 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
550 data_con_1 = head data_cons
551 data_con_N = last data_cons
552 data_con_1_RDR = qual_orig_name data_con_1
553 data_con_N_RDR = qual_orig_name data_con_N
555 ----- single-constructor-flavored: -------------
556 arity = argFieldCount data_con_1
558 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
559 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
560 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
561 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
564 %************************************************************************
566 \subsubsection{Generating @Ix@ instance declarations}
568 %************************************************************************
570 Deriving @Ix@ is only possible for enumeration types and
571 single-constructor types. We deal with them in turn.
573 For an enumeration type, e.g.,
575 data Foo ... = N1 | N2 | ... | Nn
577 things go not too differently from @Enum@:
579 instance ... Ix (Foo ...) where
581 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
585 = case (con2tag_Foo a) of { a# ->
586 case (con2tag_Foo b) of { b# ->
587 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
592 then case (con2tag_Foo d -# con2tag_Foo a) of
594 else error "Ix.Foo.index: out of range"
598 p_tag = con2tag_Foo c
600 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
604 = case (con2tag_Foo a) of { a_tag ->
605 case (con2tag_Foo b) of { b_tag ->
606 case (con2tag_Foo c) of { c_tag ->
607 if (c_tag >=# a_tag) then
613 (modulo suitable case-ification to handle the unboxed tags)
615 For a single-constructor type (NB: this includes all tuples), e.g.,
617 data Foo ... = MkFoo a b Int Double c c
619 we follow the scheme given in Figure~19 of the Haskell~1.2 report
623 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
626 = if isEnumerationTyCon tycon
630 tycon_str = getOccString tycon
631 tycon_loc = getSrcLoc tycon
633 --------------------------------------------------------------
634 enum_ixes = enum_range `AndMonoBinds`
635 enum_index `AndMonoBinds` enum_inRange
638 = mk_easy_FunMonoBind tycon_loc range_RDR
639 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $
640 untag_Expr tycon [(a_RDR, ah_RDR)] $
641 untag_Expr tycon [(b_RDR, bh_RDR)] $
642 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
643 HsPar (enum_from_to_Expr
644 (mk_easy_App mkInt_RDR [ah_RDR])
645 (mk_easy_App mkInt_RDR [bh_RDR]))
648 = mk_easy_FunMonoBind tycon_loc index_RDR
649 [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat] True{-boxed-}),
651 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
652 untag_Expr tycon [(a_RDR, ah_RDR)] (
653 untag_Expr tycon [(d_RDR, dh_RDR)] (
655 rhs = mk_easy_App mkInt_RDR [c_RDR]
658 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
659 [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
663 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
668 = mk_easy_FunMonoBind tycon_loc inRange_RDR
669 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] (
670 untag_Expr tycon [(a_RDR, ah_RDR)] (
671 untag_Expr tycon [(b_RDR, bh_RDR)] (
672 untag_Expr tycon [(c_RDR, ch_RDR)] (
673 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
674 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
679 --------------------------------------------------------------
681 = single_con_range `AndMonoBinds`
682 single_con_index `AndMonoBinds`
686 = case maybeTyConSingleCon tycon of -- just checking...
687 Nothing -> panic "get_Ix_binds"
688 Just dc -> if (any isUnLiftedType (dataConRawArgTys dc)) then
689 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
693 con_arity = argFieldCount data_con
694 data_con_RDR = qual_orig_name data_con
696 as_needed = take con_arity as_RDRs
697 bs_needed = take con_arity bs_RDRs
698 cs_needed = take con_arity cs_RDRs
700 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
701 con_expr = mk_easy_App data_con_RDR cs_needed
703 --------------------------------------------------------------
705 = mk_easy_FunMonoBind tycon_loc range_RDR
706 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $
707 HsDo ListComp stmts tycon_loc
709 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
711 [ReturnStmt con_expr]
713 mk_qual a b c = BindStmt (VarPatIn c)
714 (HsApp (HsVar range_RDR)
715 (ExplicitTuple [HsVar a, HsVar b] True))
720 = mk_easy_FunMonoBind tycon_loc index_RDR
721 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
722 con_pat cs_needed] [range_size] (
723 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
725 mk_index multiply_by (l, u, i)
727 (HsApp (HsApp (HsVar index_RDR)
728 (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i))
731 (HsApp (HsVar rangeSize_RDR)
732 (ExplicitTuple [HsVar l, HsVar u] True))
733 ) times_RDR multiply_by
737 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
738 [TuplePatIn [a_Pat, b_Pat] True] [] (
740 (HsApp (HsApp (HsVar index_RDR)
741 (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr)
742 ) plus_RDR (HsLit (HsInt 1)))
746 = mk_easy_FunMonoBind tycon_loc inRange_RDR
747 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
750 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
752 in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
753 (ExplicitTuple [HsVar a, HsVar b] True))
757 %************************************************************************
759 \subsubsection{Generating @Read@ instance declarations}
761 %************************************************************************
764 gen_Read_binds :: Fixities -> TyCon -> RdrNameMonoBinds
766 gen_Read_binds fixities tycon
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 readParen_Expr read_paren_arg $ HsPar $
786 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
787 HsDo ListComp stmts tycon_loc)
790 data_con_RDR = qual_orig_name data_con
791 data_con_str = occNameUserString (getOccName data_con)
792 con_arity = argFieldCount data_con
793 con_expr = mk_easy_App data_con_RDR as_needed
794 nullary_con = con_arity == 0
795 labels = dataConFieldLabels data_con
796 lab_fields = length labels
797 dc_nm = getName data_con
798 is_infix = isInfixOccName data_con_str
800 as_needed = take con_arity as_RDRs
802 | is_infix = take (1 + con_arity) bs_RDRs
803 | lab_fields == 0 = take con_arity bs_RDRs
804 | otherwise = take (4*lab_fields + 1) bs_RDRs
805 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
807 (as1:as2:_) = as_needed
808 (bs1:bs2:bs3:_) = bs_needed
813 (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] True)
814 (HsApp (HsVar lex_RDR) c_Expr)
818 (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] True)
819 (HsApp (HsVar lex_RDR) (HsVar bs1))
823 str_qual str res draw_from =
825 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
826 (HsApp (HsVar lex_RDR) draw_from)
829 read_label f = [str_qual nm, str_qual "="]
830 -- There might be spaces between the label and '='
832 nm = occNameUserString (getOccName (fieldLabelName f))
836 snd (mapAccumL mk_qual_infix
838 [ (mk_read_qual lp as1, bs1, bs2)
839 , (mk_read_qual rp as2, bs3, bs3)
841 | lab_fields == 0 = -- common case.
842 snd (mapAccumL mk_qual
844 (zipWithEqual "as_needed"
845 (\ con_field draw_from -> (mk_read_qual 10 con_field,
847 as_needed bs_needed))
850 mapAccumL mk_qual c_Expr
851 (zipEqual "bs_needed"
854 intersperse [str_qual ","] $
857 (\ as b -> as ++ [b])
859 (map read_label labels)
861 (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
864 mk_qual_infix draw_from (f, str_left, str_left2) =
865 (HsVar str_left2, -- what to draw from down the line...
866 f str_left draw_from)
868 mk_qual draw_from (f, str_left) =
869 (HsVar str_left, -- what to draw from down the line...
870 f str_left draw_from)
872 mk_read_qual p con_field res draw_from =
874 (TuplePatIn [VarPatIn con_field, VarPatIn res] True)
875 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
878 result_expr = ExplicitTuple [con_expr, if null bs_needed
880 else HsVar (last bs_needed)] True
882 [lp,rp] = getLRPrecs fixities dc_nm
885 | is_infix = let (h:t) = field_quals in (h:con_qual:t)
886 | otherwise = con_qual:field_quals
888 stmts = quals ++ [ReturnStmt result_expr]
892 | otherwise = getFixity fixities dc_nm
894 read_paren_arg = -- parens depend on precedence...
895 HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
899 %************************************************************************
901 \subsubsection{Generating @Show@ instance declarations}
903 %************************************************************************
906 gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds
908 gen_Show_binds fixs_assoc tycon
909 = shows_prec `AndMonoBinds` show_list
911 tycon_loc = getSrcLoc tycon
912 -----------------------------------------------------------------------
913 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
914 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
915 -----------------------------------------------------------------------
916 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
919 | nullary_con = -- skip the showParen junk...
920 ASSERT(null bs_needed)
921 ([a_Pat, con_pat], show_con)
924 showParen_Expr (HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit))))
925 (HsPar (nested_compose_Expr show_thingies)))
927 data_con_RDR = qual_orig_name data_con
928 con_arity = argFieldCount data_con
929 bs_needed = take con_arity bs_RDRs
930 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
931 nullary_con = con_arity == 0
932 labels = dataConFieldLabels data_con
933 lab_fields = length labels
935 dc_occ_nm = occNameUserString (getOccName data_con)
936 dc_nm = getName data_con
938 is_infix = isInfixOccName dc_occ_nm
942 | is_infix = mk_showString_app (' ':dc_occ_nm)
947 | lab_fields == 0 = " "
950 mk_showString_app (dc_occ_nm ++ space_ocurly_maybe)
952 show_all con fs@(x:xs)
953 | is_infix = x:con:xs
957 | lab_fields > 0 = [mk_showString_app "}"]
960 con:fs ++ ccurly_maybe
962 show_thingies = show_all show_con real_show_thingies_with_labs
964 show_label l = mk_showString_app (nm ++ "=")
966 nm = occNameUserString (getOccName (fieldLabelName l))
969 mk_showString_app str = HsApp (HsVar showString_RDR)
970 (HsLit (mkHsString str))
972 prec_cons = getLRPrecs fixs_assoc dc_nm
976 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
977 | (p,b) <- zip prec_cons bs_needed ]
979 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
982 real_show_thingies_with_labs
983 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
984 | otherwise = --Assumption: no of fields == no of labelled fields
985 -- (and in same order)
987 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
988 zipWithEqual "gen_Show_binds"
990 (map show_label labels)
993 (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc dc_nm
997 | otherwise = getFixity fixs_assoc dc_nm
1002 getLRPrecs :: Fixities -> Name -> [Integer]
1003 getLRPrecs fixs_assoc nm = [lp, rp]
1005 ( con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm
1006 paren_prec_limit = 9
1009 | con_left_assoc = paren_prec_limit
1010 | otherwise = paren_prec_limit + 1
1013 | con_right_assoc = paren_prec_limit
1014 | otherwise = paren_prec_limit + 1
1017 getFixity :: Fixities -> Name -> Integer
1018 getFixity fixs_assoc nm =
1019 case assocMaybe fixs_assoc nm of
1021 Just (Fixity x _) -> fromInt x + 1
1023 isLRAssoc :: Fixities -> Name -> (Bool, Bool)
1024 isLRAssoc fixs_assoc nm =
1025 case assocMaybe fixs_assoc nm of
1026 Just (Fixity _ InfixL) -> (True, False)
1027 Just (Fixity _ InfixR) -> (False, True)
1030 isInfixOccName :: String -> Bool
1031 isInfixOccName str =
1039 %************************************************************************
1041 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1043 %************************************************************************
1048 con2tag_Foo :: Foo ... -> Int#
1049 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1050 maxtag_Foo :: Int -- ditto (NB: not unboxed)
1053 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1058 = GenCon2Tag | GenTag2Con | GenMaxTag
1060 gen_tag_n_con_monobind
1061 :: (RdrName, -- (proto)Name for the thing in question
1062 TyCon, -- tycon in question
1066 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1067 | lots_of_constructors
1068 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1069 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1072 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1075 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1077 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1079 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1081 pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
1082 var_RDR = qual_orig_name var
1084 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1085 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1086 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1087 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1088 (MonoTyVar (qual_orig_name tycon)))]
1090 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1091 = mk_easy_FunMonoBind (getSrcLoc tycon)
1092 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1094 max_tag = case (tyConDataCons tycon) of
1095 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1099 %************************************************************************
1101 \subsection{Utility bits for generating bindings}
1103 %************************************************************************
1105 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1107 fun pat1 pat2 ... patN = expr where binds
1110 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1111 multi-clause definitions; it generates:
1113 fun p1a p1b ... p1N = e1
1114 fun p2a p2b ... p2N = e2
1116 fun pMa pMb ... pMN = eM
1120 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1121 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1124 mk_easy_FunMonoBind loc fun pats binds expr
1125 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1127 mk_easy_Match loc pats binds expr
1128 = mk_match loc pats expr (mkbind binds)
1130 mkbind [] = EmptyBinds
1131 mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
1132 -- The renamer expects everything in its input to be a
1133 -- "recursive" MonoBinds, and it is its job to sort things out
1136 mk_FunMonoBind :: SrcLoc -> RdrName
1137 -> [([RdrNamePat], RdrNameHsExpr)]
1140 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1141 mk_FunMonoBind loc fun pats_and_exprs
1142 = FunMonoBind fun False{-not infix-}
1143 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1146 mk_match loc pats expr binds
1147 = Match [] (map paren pats) Nothing
1148 (GRHSs (unguardedRHS expr loc) binds Nothing)
1150 paren p@(VarPatIn _) = p
1151 paren other_p = ParPatIn other_p
1155 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1158 ToDo: Better SrcLocs.
1162 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1163 -> RdrNameHsExpr -> RdrNameHsExpr
1167 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1168 -> RdrNameHsExpr -> RdrNameHsExpr
1170 careful_compare_Case :: -- checks for primitive types...
1172 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1173 -> RdrNameHsExpr -> RdrNameHsExpr
1176 compare_Case = compare_gen_Case compare_RDR
1177 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1178 -- Was: compare_gen_Case cmp_eq_RDR
1180 compare_gen_Case fun lt eq gt a b
1181 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1182 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc,
1183 mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc,
1184 mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc]
1187 careful_compare_Case ty lt eq gt a b
1188 = if not (isUnboxedType ty) then
1189 compare_gen_Case compare_RDR lt eq gt a b
1191 else -- we have to do something special for primitive things...
1192 HsIf (genOpApp a relevant_eq_op b)
1194 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1197 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1198 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1200 assoc_ty_id tyids ty
1201 = if null res then panic "assoc_ty"
1204 res = [id | (ty',id) <- tyids, ty == ty']
1207 [(charPrimTy, eqH_Char_RDR)
1208 ,(intPrimTy, eqH_Int_RDR)
1209 ,(wordPrimTy, eqH_Word_RDR)
1210 ,(addrPrimTy, eqH_Addr_RDR)
1211 ,(floatPrimTy, eqH_Float_RDR)
1212 ,(doublePrimTy, eqH_Double_RDR)
1216 [(charPrimTy, ltH_Char_RDR)
1217 ,(intPrimTy, ltH_Int_RDR)
1218 ,(wordPrimTy, ltH_Word_RDR)
1219 ,(addrPrimTy, ltH_Addr_RDR)
1220 ,(floatPrimTy, ltH_Float_RDR)
1221 ,(doublePrimTy, ltH_Double_RDR)
1224 -----------------------------------------------------------------------
1226 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1228 and_Expr a b = genOpApp a and_RDR b
1229 append_Expr a b = genOpApp a append_RDR b
1231 -----------------------------------------------------------------------
1233 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1235 = if not (isUnboxedType ty) then
1237 else -- we have to do something special for primitive things...
1238 genOpApp a relevant_eq_op b
1240 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1244 argFieldCount :: DataCon -> Int -- Works on data and newtype constructors
1245 argFieldCount con = length (dataConRawArgTys con)
1249 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1250 untag_Expr tycon [] expr = expr
1251 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1252 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1253 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc]
1256 cmp_tags_Expr :: RdrName -- Comparison op
1257 -> RdrName -> RdrName -- Things to compare
1258 -> RdrNameHsExpr -- What to return if true
1259 -> RdrNameHsExpr -- What to return if false
1262 cmp_tags_Expr op a b true_case false_case
1263 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1266 :: RdrNameHsExpr -> RdrNameHsExpr
1268 enum_from_then_to_Expr
1269 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1272 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1273 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1275 showParen_Expr, readParen_Expr
1276 :: RdrNameHsExpr -> RdrNameHsExpr
1279 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1280 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1282 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1284 nested_compose_Expr [e] = parenify e
1285 nested_compose_Expr (e:es)
1286 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1288 -- impossible_Expr is used in case RHSs that should never happen.
1289 -- We generate these to keep the desugarer from complaining that they *might* happen!
1290 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1292 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1293 -- method. It is currently only used by Enum.{succ,pred}
1294 illegal_Expr meth tp msg =
1295 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1297 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1298 -- to include the value of a_RDR in the error string.
1299 illegal_toEnum_tag tp maxtag =
1300 HsApp (HsVar error_RDR)
1301 (HsApp (HsApp (HsVar append_RDR)
1302 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1303 (HsApp (HsApp (HsApp
1304 (HsVar showsPrec_RDR)
1309 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1310 (HsApp (HsApp (HsApp
1311 (HsVar showsPrec_RDR)
1314 (HsLit (HsString (_PK_ ")")))))))
1316 parenify e@(HsVar _) = e
1317 parenify e = HsPar e
1319 -- genOpApp wraps brackets round the operator application, so that the
1320 -- renamer won't subsequently try to re-associate it.
1321 -- For some reason the renamer doesn't reassociate it right, and I can't
1322 -- be bothered to find out why just now.
1324 genOpApp e1 op e2 = mkOpApp e1 op e2
1328 qual_orig_name n = nameRdrName (getName n)
1329 varUnqual n = mkSrcUnqual varName n
1331 a_RDR = varUnqual SLIT("a")
1332 b_RDR = varUnqual SLIT("b")
1333 c_RDR = varUnqual SLIT("c")
1334 d_RDR = varUnqual SLIT("d")
1335 ah_RDR = varUnqual SLIT("a#")
1336 bh_RDR = varUnqual SLIT("b#")
1337 ch_RDR = varUnqual SLIT("c#")
1338 dh_RDR = varUnqual SLIT("d#")
1339 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1340 rangeSize_RDR = varUnqual SLIT("rangeSize")
1342 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1343 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1344 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1346 mkHsString s = HsString (_PK_ s)
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)
1362 a_Pat = VarPatIn a_RDR
1363 b_Pat = VarPatIn b_RDR
1364 c_Pat = VarPatIn c_RDR
1365 d_Pat = VarPatIn d_RDR
1367 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1369 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1370 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1371 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))