2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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.
12 #include "HsVersions.h"
23 gen_tag_n_con_monobind,
25 con2tag_RDR, tag2con_RDR, maxtag_RDR,
31 IMPORT_1_3(List(partition,intersperse))
33 import HsSyn ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
34 GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..),
35 SYN_IE(RecFlag), recursive,
36 ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake )
37 import RdrHsSyn ( RdrName(..), varQual, varUnqual, mkOpApp,
38 SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
40 import BasicTypes ( IfaceFlavour(..) )
41 import FieldLabel ( fieldLabelName )
42 import Id ( GenId, isNullaryDataCon, dataConTag,
43 dataConRawArgTys, fIRST_TAG,
44 isDataCon, SYN_IE(DataCon), SYN_IE(ConTag),
45 dataConFieldLabels, SYN_IE(Id) )
46 import Maybes ( maybeToBool )
47 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
48 modAndOcc, OccName, Name )
50 import PrimOp ( PrimOp(..) )
51 import PrelInfo -- Lots of RdrNames
52 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
53 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
54 import Type ( eqTy, isPrimType, SYN_IE(Type) )
55 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
56 floatPrimTy, doublePrimTy
58 import Util ( mapAccumL, zipEqual, zipWithEqual,
59 zipWith3Equal, nOfThem, panic, assertPanic )
62 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 200
63 intersperse :: a -> [a] -> [a]
65 intersperse s [x] = [x]
66 intersperse s (x:xs) = x : s : intersperse s xs
71 %************************************************************************
73 \subsection{Generating code, by derivable class}
75 %************************************************************************
77 %************************************************************************
79 \subsubsection{Generating @Eq@ instance declarations}
81 %************************************************************************
83 Here are the heuristics for the code we generate for @Eq@:
86 Let's assume we have a data type with some (possibly zero) nullary
87 data constructors and some ordinary, non-nullary ones (the rest,
88 also possibly zero of them). Here's an example, with both \tr{N}ullary
89 and \tr{O}rdinary data cons.
91 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
95 For the ordinary constructors (if any), we emit clauses to do The
99 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
100 (==) (O2 a1) (O2 a2) = a1 == a2
101 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
104 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
105 \tr{a2} are \tr{Float#}s, then we have to generate
107 case (a1 `eqFloat#` a2) of
110 for that particular test.
113 If there are any nullary constructors, we emit a catch-all clause of
117 (==) a b = case (con2tag_Foo a) of { a# ->
118 case (con2tag_Foo b) of { b# ->
119 case (a# ==# b#) of {
124 If there aren't any nullary constructors, we emit a simpler
131 For the @(/=)@ method, we normally just use the default method.
133 If the type is an enumeration type, we could/may/should? generate
134 special code that calls @con2tag_Foo@, much like for @(==)@ shown
138 We thought about doing this: If we're also deriving @Ord@ for this
141 instance ... Eq (Foo ...) where
142 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
143 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
145 However, that requires that \tr{Ord <whatever>} was put in the context
146 for the instance decl, which it probably wasn't, so the decls
147 produced don't get through the typechecker.
151 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
155 tycon_loc = getSrcLoc tycon
156 (nullary_cons, nonnullary_cons)
157 | isNewTyCon tycon = ([], tyConDataCons tycon)
158 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
161 = if (null nullary_cons) then
162 case maybeTyConSingleCon tycon of
164 Nothing -> -- if cons don't match, then False
165 [([a_Pat, b_Pat], false_Expr)]
166 else -- calc. and compare the tags
168 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
169 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
171 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
173 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
174 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
176 ------------------------------------------------------------------
179 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
180 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
182 data_con_RDR = qual_orig_name data_con
183 con_arity = length tys_needed
184 as_needed = take con_arity as_RDRs
185 bs_needed = take con_arity bs_RDRs
186 tys_needed = dataConRawArgTys data_con
188 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
190 nested_eq_expr [] [] [] = true_Expr
191 nested_eq_expr tys as bs
192 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
194 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
197 %************************************************************************
199 \subsubsection{Generating @Ord@ instance declarations}
201 %************************************************************************
203 For a derived @Ord@, we concentrate our attentions on @compare@
205 compare :: a -> a -> Ordering
206 data Ordering = LT | EQ | GT deriving ()
209 We will use the same example data type as above:
211 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
216 We do all the other @Ord@ methods with calls to @compare@:
218 instance ... (Ord <wurble> <wurble>) where
219 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
220 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
221 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
222 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
224 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
225 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
227 -- compare to come...
231 @compare@ always has two parts. First, we use the compared
232 data-constructors' tags to deal with the case of different
235 compare a b = case (con2tag_Foo a) of { a# ->
236 case (con2tag_Foo b) of { b# ->
237 case (a# ==# b#) of {
239 False -> case (a# <# b#) of
244 cmp_eq = ... to come ...
248 We are only left with the ``help'' function @cmp_eq@, to deal with
249 comparing data constructors with the same tag.
251 For the ordinary constructors (if any), we emit the sorta-obvious
252 compare-style stuff; for our example:
254 cmp_eq (O1 a1 b1) (O1 a2 b2)
255 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
257 cmp_eq (O2 a1) (O2 a2)
260 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
261 = case (compare a1 a2) of {
264 EQ -> case compare b1 b2 of {
272 Again, we must be careful about unboxed comparisons. For example,
273 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
276 cmp_eq lt eq gt (O2 a1) (O2 a2)
278 -- or maybe the unfolded equivalent
282 For the remaining nullary constructors, we already know that the
290 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
293 = defaulted `AndMonoBinds` compare
295 tycon_loc = getSrcLoc tycon
296 --------------------------------------------------------------------
297 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
300 (if maybeToBool (maybeTyConSingleCon tycon) then
301 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
303 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
304 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
305 -- True case; they are equal
306 -- If an enumeration type we are done; else
307 -- recursively compare their components
308 (if isEnumerationTyCon tycon then
311 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
313 -- False case; they aren't equal
314 -- So we need to do a less-than comparison on the tags
315 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
317 (nullary_cons, nonnullary_cons)
318 | isNewTyCon tycon = ([], tyConDataCons tycon)
319 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
322 = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++
323 [([WildPatIn, WildPatIn], default_rhs)])
326 = ([con1_pat, con2_pat],
327 nested_compare_expr tys_needed as_needed bs_needed)
329 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
330 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
332 data_con_RDR = qual_orig_name data_con
333 con_arity = length tys_needed
334 as_needed = take con_arity as_RDRs
335 bs_needed = take con_arity bs_RDRs
336 tys_needed = dataConRawArgTys data_con
338 nested_compare_expr [ty] [a] [b]
339 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
341 nested_compare_expr (ty:tys) (a:as) (b:bs)
342 = let eq_expr = nested_compare_expr tys as bs
343 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
345 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
346 -- inexhaustive patterns
347 | otherwise = eqTag_Expr -- Some nullary constructors;
348 -- Tags are equal, no args => return EQ
349 --------------------------------------------------------------------
351 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
353 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
354 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
355 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
356 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
357 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
358 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
359 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
360 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
362 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
363 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
364 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
365 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
368 %************************************************************************
370 \subsubsection{Generating @Enum@ instance declarations}
372 %************************************************************************
374 @Enum@ can only be derived for enumeration types. For a type
376 data Foo ... = N1 | N2 | ... | Nn
379 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
380 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
383 instance ... Enum (Foo ...) where
384 toEnum i = tag2con_Foo i
386 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
390 = case con2tag_Foo a of
391 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
394 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
398 = case con2tag_Foo a of { a# ->
399 case con2tag_Foo b of { b# ->
400 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
404 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
407 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
410 = to_enum `AndMonoBinds`
411 enum_from `AndMonoBinds`
412 enum_from_then `AndMonoBinds`
415 tycon_loc = getSrcLoc tycon
418 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
419 mk_easy_App (tag2con_RDR tycon) [a_RDR]
422 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
423 untag_Expr tycon [(a_RDR, ah_RDR)] $
424 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
425 HsPar (enum_from_to_Expr
426 (mk_easy_App mkInt_RDR [ah_RDR])
427 (HsVar (maxtag_RDR tycon)))
430 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
431 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
432 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
433 HsPar (enum_from_then_to_Expr
434 (mk_easy_App mkInt_RDR [ah_RDR])
435 (mk_easy_App mkInt_RDR [bh_RDR])
436 (HsVar (maxtag_RDR tycon)))
439 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
440 untag_Expr tycon [(a_RDR, ah_RDR)] $
441 (mk_easy_App mkInt_RDR [ah_RDR])
444 %************************************************************************
446 \subsubsection{Generating @Eval@ instance declarations}
448 %************************************************************************
451 gen_Eval_binds tycon = EmptyMonoBinds
454 %************************************************************************
456 \subsubsection{Generating @Bounded@ instance declarations}
458 %************************************************************************
461 gen_Bounded_binds tycon
462 = if isEnumerationTyCon tycon then
463 min_bound_enum `AndMonoBinds` max_bound_enum
465 ASSERT(length data_cons == 1)
466 min_bound_1con `AndMonoBinds` max_bound_1con
468 data_cons = tyConDataCons tycon
469 tycon_loc = getSrcLoc tycon
471 ----- enum-flavored: ---------------------------
472 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
473 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
475 data_con_1 = head data_cons
476 data_con_N = last data_cons
477 data_con_1_RDR = qual_orig_name data_con_1
478 data_con_N_RDR = qual_orig_name data_con_N
480 ----- single-constructor-flavored: -------------
481 arity = argFieldCount data_con_1
483 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
484 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
485 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
486 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
489 %************************************************************************
491 \subsubsection{Generating @Ix@ instance declarations}
493 %************************************************************************
495 Deriving @Ix@ is only possible for enumeration types and
496 single-constructor types. We deal with them in turn.
498 For an enumeration type, e.g.,
500 data Foo ... = N1 | N2 | ... | Nn
502 things go not too differently from @Enum@:
504 instance ... Ix (Foo ...) where
506 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
510 = case (con2tag_Foo a) of { a# ->
511 case (con2tag_Foo b) of { b# ->
512 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
517 then case (con2tag_Foo d -# con2tag_Foo a) of
519 else error "Ix.Foo.index: out of range"
523 p_tag = con2tag_Foo c
525 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
529 = case (con2tag_Foo a) of { a_tag ->
530 case (con2tag_Foo b) of { b_tag ->
531 case (con2tag_Foo c) of { c_tag ->
532 if (c_tag >=# a_tag) then
538 (modulo suitable case-ification to handle the unboxed tags)
540 For a single-constructor type (NB: this includes all tuples), e.g.,
542 data Foo ... = MkFoo a b Int Double c c
544 we follow the scheme given in Figure~19 of the Haskell~1.2 report
548 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
551 = if isEnumerationTyCon tycon
555 tycon_str = getOccString tycon
556 tycon_loc = getSrcLoc tycon
558 --------------------------------------------------------------
559 enum_ixes = enum_range `AndMonoBinds`
560 enum_index `AndMonoBinds` enum_inRange
563 = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
564 untag_Expr tycon [(a_RDR, ah_RDR)] $
565 untag_Expr tycon [(b_RDR, bh_RDR)] $
566 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
567 HsPar (enum_from_to_Expr
568 (mk_easy_App mkInt_RDR [ah_RDR])
569 (mk_easy_App mkInt_RDR [bh_RDR]))
572 = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
573 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
574 untag_Expr tycon [(a_RDR, ah_RDR)] (
575 untag_Expr tycon [(d_RDR, dh_RDR)] (
577 grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc]
580 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
581 [PatMatch (VarPatIn c_RDR)
582 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
586 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
591 = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
592 untag_Expr tycon [(a_RDR, ah_RDR)] (
593 untag_Expr tycon [(b_RDR, bh_RDR)] (
594 untag_Expr tycon [(c_RDR, ch_RDR)] (
595 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
596 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
601 --------------------------------------------------------------
603 = single_con_range `AndMonoBinds`
604 single_con_index `AndMonoBinds`
608 = case maybeTyConSingleCon tycon of -- just checking...
609 Nothing -> panic "get_Ix_binds"
610 Just dc -> if (any isPrimType (dataConRawArgTys dc)) then
611 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
615 con_arity = argFieldCount data_con
616 data_con_RDR = qual_orig_name data_con
618 as_needed = take con_arity as_RDRs
619 bs_needed = take con_arity bs_RDRs
620 cs_needed = take con_arity cs_RDRs
622 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
623 con_expr = mk_easy_App data_con_RDR cs_needed
625 --------------------------------------------------------------
627 = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $
628 HsDo ListComp stmts tycon_loc
630 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
632 [ReturnStmt con_expr]
634 mk_qual a b c = BindStmt (VarPatIn c)
635 (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
640 = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
641 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
643 mk_index multiply_by (l, u, i)
645 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
648 (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
649 ) times_RDR multiply_by
653 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
655 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
656 ) plus_RDR (HsLit (HsInt 1)))
660 = mk_easy_FunMonoBind tycon_loc inRange_RDR
661 [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
663 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
665 in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
668 %************************************************************************
670 \subsubsection{Generating @Read@ instance declarations}
672 %************************************************************************
674 Ignoring all the infix-ery mumbo jumbo (ToDo)
677 gen_Read_binds :: TyCon -> RdrNameMonoBinds
680 = reads_prec `AndMonoBinds` read_list
682 tycon_loc = getSrcLoc tycon
683 -----------------------------------------------------------------------
684 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
685 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
686 -----------------------------------------------------------------------
689 read_con_comprehensions
690 = map read_con (tyConDataCons tycon)
692 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
693 foldr1 append_Expr read_con_comprehensions
696 read_con data_con -- note: "b" is the string being "read"
698 data_con_RDR = qual_orig_name data_con
699 data_con_str= occNameString (getOccName data_con)
700 con_arity = argFieldCount data_con
701 con_expr = mk_easy_App data_con_RDR as_needed
702 nullary_con = con_arity == 0
703 labels = dataConFieldLabels data_con
704 lab_fields = length labels
706 as_needed = take con_arity as_RDRs
708 | lab_fields == 0 = take con_arity bs_RDRs
709 | otherwise = take (4*lab_fields + 1) bs_RDRs
710 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
713 (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
714 (HsApp (HsVar lex_RDR) c_Expr)
717 str_qual str res draw_from
719 (TuplePatIn [LitPatIn (HsString str), VarPatIn res])
720 (HsApp (HsVar lex_RDR) draw_from)
724 = let nm = occNameString (getOccName (fieldLabelName f))
726 [str_qual nm, str_qual SLIT("=")]
727 -- There might be spaces between the label and '='
731 snd (mapAccumL mk_qual
733 (zipWithEqual "as_needed"
734 (\ con_field draw_from -> (mk_read_qual con_field,
736 as_needed bs_needed))
739 mapAccumL mk_qual d_Expr
740 (zipEqual "bs_needed"
741 ((str_qual (SLIT("{")):
743 intersperse ([str_qual (_CONS_ ',' _NIL_)]) $
746 (\ as b -> as ++ [b])
748 (map read_label labels)
750 (map mk_read_qual as_needed))) ++ [str_qual (SLIT("}"))])
753 mk_qual draw_from (f, str_left)
754 = (HsVar str_left, -- what to draw from down the line...
755 f str_left draw_from)
757 mk_read_qual con_field res draw_from =
759 (TuplePatIn [VarPatIn con_field, VarPatIn res])
760 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
763 result_expr = ExplicitTuple [con_expr, if null bs_needed
765 else HsVar (last bs_needed)]
767 stmts = con_qual:field_quals ++ [ReturnStmt result_expr]
770 = if nullary_con then -- must be False (parens are surely optional)
772 else -- parens depend on precedence...
773 HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9)))
776 readParen_Expr read_paren_arg $ HsPar $
777 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
778 HsDo ListComp stmts tycon_loc)
783 %************************************************************************
785 \subsubsection{Generating @Show@ instance declarations}
787 %************************************************************************
789 Ignoring all the infix-ery mumbo jumbo (ToDo)
792 gen_Show_binds :: TyCon -> RdrNameMonoBinds
795 = shows_prec `AndMonoBinds` show_list
797 tycon_loc = getSrcLoc tycon
798 -----------------------------------------------------------------------
799 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
800 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
801 -----------------------------------------------------------------------
803 = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
807 data_con_RDR = qual_orig_name data_con
808 con_arity = argFieldCount data_con
809 bs_needed = take con_arity bs_RDRs
810 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
811 nullary_con = con_arity == 0
812 labels = dataConFieldLabels data_con
813 lab_fields = length labels
816 = let nm = occNameString (getOccName data_con)
818 | nullary_con = _NIL_
819 | lab_fields == 0 = SLIT(" ")
820 | otherwise = SLIT("{")
823 mk_showString_app (nm _APPEND_ space_ocurly_maybe)
828 | lab_fields > 0 = [mk_showString_app (SLIT("}"))]
831 con:fs ++ ccurly_maybe
833 show_thingies = show_all show_con real_show_thingies_with_labs
836 = let nm = occNameString (getOccName (fieldLabelName l))
838 mk_showString_app (nm _APPEND_ SLIT("="))
840 mk_showString_app str = HsApp (HsVar showString_RDR)
841 (HsLit (HsString str))
844 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
847 real_show_thingies_with_labs
848 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
849 | otherwise = --Assumption: no of fields == no of labelled fields
850 -- (and in same order)
852 intersperse ([mk_showString_app (_CONS_ ',' _NIL_ )]) $ -- Using SLIT() is not cool here.
853 zipWithEqual "gen_Show_binds"
855 (map show_label labels)
860 if nullary_con then -- skip the showParen junk...
861 ASSERT(null bs_needed)
862 ([a_Pat, con_pat], show_con)
865 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
866 (HsPar (nested_compose_Expr show_thingies)))
869 %************************************************************************
871 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
873 %************************************************************************
878 con2tag_Foo :: Foo ... -> Int#
879 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
880 maxtag_Foo :: Int -- ditto (NB: not unboxed)
883 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
888 = GenCon2Tag | GenTag2Con | GenMaxTag
890 gen_tag_n_con_monobind
891 :: (RdrName, -- (proto)Name for the thing in question
892 TyCon, -- tycon in question
896 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
897 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
899 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
902 = ASSERT(isDataCon var)
903 ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
905 pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
906 var_RDR = qual_orig_name var
908 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
909 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++
910 [([WildPatIn], impossible_Expr)])
912 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
915 = ASSERT(isDataCon var)
916 ([lit_pat], HsVar var_RDR)
918 lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
919 var_RDR = qual_orig_name var
921 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
922 = mk_easy_FunMonoBind (getSrcLoc tycon)
923 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
925 max_tag = case (tyConDataCons tycon) of
926 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
930 %************************************************************************
932 \subsection{Utility bits for generating bindings}
934 %************************************************************************
936 @mk_easy_FunMonoBind fun pats binds expr@ generates:
938 fun pat1 pat2 ... patN = expr where binds
941 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
942 multi-clause definitions; it generates:
944 fun p1a p1b ... p1N = e1
945 fun p2a p2b ... p2N = e2
947 fun pMa pMb ... pMN = eM
951 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
952 -> [RdrNameMonoBinds] -> RdrNameHsExpr
955 mk_easy_FunMonoBind loc fun pats binds expr
956 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
958 mk_easy_Match loc pats binds expr
959 = mk_match loc pats expr (mkbind binds)
961 mkbind [] = EmptyBinds
962 mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] recursive
963 -- The renamer expects everything in its input to be a
964 -- "recursive" MonoBinds, and it is its job to sort things out
967 mk_FunMonoBind :: SrcLoc -> RdrName
968 -> [([RdrNamePat], RdrNameHsExpr)]
971 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
972 mk_FunMonoBind loc fun pats_and_exprs
973 = FunMonoBind fun False{-not infix-}
974 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
977 mk_match loc pats expr binds
979 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr loc] binds))
982 paren p@(VarPatIn _) = p
983 paren other_p = ParPatIn other_p
987 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
990 ToDo: Better SrcLocs.
993 compare_Case, cmp_eq_Expr ::
994 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
995 -> RdrNameHsExpr -> RdrNameHsExpr
999 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1000 -> RdrNameHsExpr -> RdrNameHsExpr
1002 careful_compare_Case :: -- checks for primitive types...
1004 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1005 -> RdrNameHsExpr -> RdrNameHsExpr
1008 compare_Case = compare_gen_Case compare_RDR
1009 cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
1011 compare_gen_Case fun lt eq gt a b
1012 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1013 [PatMatch (ConPatIn ltTag_RDR [])
1014 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
1016 PatMatch (ConPatIn eqTag_RDR [])
1017 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
1019 PatMatch (ConPatIn gtTag_RDR [])
1020 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
1023 careful_compare_Case ty lt eq gt a b
1024 = if not (isPrimType ty) then
1025 compare_gen_Case compare_RDR lt eq gt a b
1027 else -- we have to do something special for primitive things...
1028 HsIf (genOpApp a relevant_eq_op b)
1030 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1033 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1034 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1036 assoc_ty_id tyids ty
1037 = if null res then panic "assoc_ty"
1040 res = [id | (ty',id) <- tyids, eqTy ty ty']
1043 [(charPrimTy, eqH_Char_RDR)
1044 ,(intPrimTy, eqH_Int_RDR)
1045 ,(wordPrimTy, eqH_Word_RDR)
1046 ,(addrPrimTy, eqH_Addr_RDR)
1047 ,(floatPrimTy, eqH_Float_RDR)
1048 ,(doublePrimTy, eqH_Double_RDR)
1052 [(charPrimTy, ltH_Char_RDR)
1053 ,(intPrimTy, ltH_Int_RDR)
1054 ,(wordPrimTy, ltH_Word_RDR)
1055 ,(addrPrimTy, ltH_Addr_RDR)
1056 ,(floatPrimTy, ltH_Float_RDR)
1057 ,(doublePrimTy, ltH_Double_RDR)
1060 -----------------------------------------------------------------------
1062 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1064 and_Expr a b = genOpApp a and_RDR b
1065 append_Expr a b = genOpApp a append_RDR b
1067 -----------------------------------------------------------------------
1069 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1071 = if not (isPrimType ty) then
1073 else -- we have to do something special for primitive things...
1074 genOpApp a relevant_eq_op b
1076 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1080 argFieldCount :: Id -> Int -- Works on data and newtype constructors
1081 argFieldCount con = length (dataConRawArgTys con)
1085 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1086 untag_Expr tycon [] expr = expr
1087 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1088 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1089 [PatMatch (VarPatIn put_tag_here)
1090 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
1093 grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
1095 cmp_tags_Expr :: RdrName -- Comparison op
1096 -> RdrName -> RdrName -- Things to compare
1097 -> RdrNameHsExpr -- What to return if true
1098 -> RdrNameHsExpr -- What to return if false
1101 cmp_tags_Expr op a b true_case false_case
1102 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1105 :: RdrNameHsExpr -> RdrNameHsExpr
1107 enum_from_then_to_Expr
1108 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1111 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1112 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1114 showParen_Expr, readParen_Expr
1115 :: RdrNameHsExpr -> RdrNameHsExpr
1118 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1119 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1121 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1123 nested_compose_Expr [e] = parenify e
1124 nested_compose_Expr (e:es)
1125 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1127 -- impossible_Expr is used in case RHSs that should never happen.
1128 -- We generate these to keep the desugarer from complaining that they *might* happen!
1129 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1131 parenify e@(HsVar _) = e
1132 parenify e = HsPar e
1134 -- genOpApp wraps brackets round the operator application, so that the
1135 -- renamer won't subsequently try to re-associate it.
1136 -- For some reason the renamer doesn't reassociate it right, and I can't
1137 -- be bothered to find out why just now.
1139 genOpApp e1 op e2 = mkOpApp e1 op e2
1143 qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }
1145 a_RDR = varUnqual SLIT("a")
1146 b_RDR = varUnqual SLIT("b")
1147 c_RDR = varUnqual SLIT("c")
1148 d_RDR = varUnqual SLIT("d")
1149 ah_RDR = varUnqual SLIT("a#")
1150 bh_RDR = varUnqual SLIT("b#")
1151 ch_RDR = varUnqual SLIT("c#")
1152 dh_RDR = varUnqual SLIT("d#")
1153 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1154 rangeSize_RDR = varUnqual SLIT("rangeSize")
1156 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1157 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1158 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1160 a_Expr = HsVar a_RDR
1161 b_Expr = HsVar b_RDR
1162 c_Expr = HsVar c_RDR
1163 d_Expr = HsVar d_RDR
1164 ltTag_Expr = HsVar ltTag_RDR
1165 eqTag_Expr = HsVar eqTag_RDR
1166 gtTag_Expr = HsVar gtTag_RDR
1167 false_Expr = HsVar false_RDR
1168 true_Expr = HsVar true_RDR
1170 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1172 a_Pat = VarPatIn a_RDR
1173 b_Pat = VarPatIn b_RDR
1174 c_Pat = VarPatIn c_RDR
1175 d_Pat = VarPatIn d_RDR
1177 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1179 con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1180 tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1181 maxtag_RDR tycon = varUnqual (SLIT("maxtag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))