2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcGenDeriv]{Generating derived instance declarations}
6 This module is nominally ``subordinate'' to @TcDeriv@, which is the
7 ``official'' interface to deriving-related things.
9 This is where we do all the grimy bindings' generation.
20 gen_tag_n_con_monobind,
22 con2tag_RDR, tag2con_RDR, maxtag_RDR,
27 #include "HsVersions.h"
29 import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
30 Match(..), GRHSs(..), Stmt(..), HsLit(..),
31 HsBinds(..), HsType(..), HsDoContext(..),
32 unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
34 import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
35 import RdrName ( RdrName, mkUnqual )
36 import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
40 import FieldLabel ( FieldLabel, fieldLabelName )
41 import DataCon ( isNullaryDataCon, dataConTag,
42 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
45 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
46 occNameUserString, nameRdrName, varName,
48 isDataSymOcc, isSymOcc
51 import HscTypes ( FixityEnv, lookupFixity )
52 import PrelInfo -- Lots of RdrNames
53 import SrcLoc ( generatedSrcLoc, SrcLoc )
54 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
55 maybeTyConSingleCon, tyConFamilySize
57 import TcType ( isUnLiftedType, tcEqType, Type )
58 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
59 floatPrimTy, doublePrimTy
61 import Util ( mapAccumL, zipEqual, zipWithEqual, isSingleton,
62 zipWith3Equal, nOfThem )
63 import Panic ( panic, assertPanic )
64 import Maybes ( maybeToBool )
67 import List ( partition, intersperse )
70 %************************************************************************
72 \subsection{Generating code, by derivable class}
74 %************************************************************************
76 %************************************************************************
78 \subsubsection{Generating @Eq@ instance declarations}
80 %************************************************************************
82 Here are the heuristics for the code we generate for @Eq@:
85 Let's assume we have a data type with some (possibly zero) nullary
86 data constructors and some ordinary, non-nullary ones (the rest,
87 also possibly zero of them). Here's an example, with both \tr{N}ullary
88 and \tr{O}rdinary data cons.
90 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
94 For the ordinary constructors (if any), we emit clauses to do The
98 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
99 (==) (O2 a1) (O2 a2) = a1 == a2
100 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
103 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
104 \tr{a2} are \tr{Float#}s, then we have to generate
106 case (a1 `eqFloat#` a2) of
109 for that particular test.
112 If there are any nullary constructors, we emit a catch-all clause of
116 (==) a b = case (con2tag_Foo a) of { a# ->
117 case (con2tag_Foo b) of { b# ->
118 case (a# ==# b#) of {
123 If there aren't any nullary constructors, we emit a simpler
130 For the @(/=)@ method, we normally just use the default method.
132 If the type is an enumeration type, we could/may/should? generate
133 special code that calls @con2tag_Foo@, much like for @(==)@ shown
137 We thought about doing this: If we're also deriving @Ord@ for this
140 instance ... Eq (Foo ...) where
141 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
142 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
144 However, that requires that \tr{Ord <whatever>} was put in the context
145 for the instance decl, which it probably wasn't, so the decls
146 produced don't get through the typechecker.
150 deriveEq :: RdrName -- Class
151 -> RdrName -- Type constructor
152 -> [ (RdrName, [RdrType]) ] -- Constructors
153 -> (RdrContext, -- Context for the inst decl
154 [RdrBind], -- Binds in the inst decl
155 [RdrBind]) -- Extra value bindings outside
157 deriveEq clas tycon constrs
158 = (context, [eq_bind, ne_bind], [])
160 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
163 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
164 is_nullary (_, args) = null args
167 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
171 tycon_loc = getSrcLoc tycon
172 (nullary_cons, nonnullary_cons)
173 | isNewTyCon tycon = ([], tyConDataCons tycon)
174 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
177 = if (null nullary_cons) then
178 case maybeTyConSingleCon tycon of
180 Nothing -> -- if cons don't match, then False
181 [([wildPat, wildPat], false_Expr)]
182 else -- calc. and compare the tags
184 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
185 (genOpApp (HsVar ah_RDR) eqH_Int_RDR (HsVar bh_RDR)))]
187 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
189 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
190 HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR])))
192 ------------------------------------------------------------------
195 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
196 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
198 data_con_RDR = qual_orig_name data_con
199 con_arity = length tys_needed
200 as_needed = take con_arity as_RDRs
201 bs_needed = take con_arity bs_RDRs
202 tys_needed = dataConOrigArgTys data_con
204 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
206 nested_eq_expr [] [] [] = true_Expr
207 nested_eq_expr tys as bs
208 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
210 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
213 %************************************************************************
215 \subsubsection{Generating @Ord@ instance declarations}
217 %************************************************************************
219 For a derived @Ord@, we concentrate our attentions on @compare@
221 compare :: a -> a -> Ordering
222 data Ordering = LT | EQ | GT deriving ()
225 We will use the same example data type as above:
227 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
232 We do all the other @Ord@ methods with calls to @compare@:
234 instance ... (Ord <wurble> <wurble>) where
235 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
236 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
237 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
238 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
240 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
241 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
243 -- compare to come...
247 @compare@ always has two parts. First, we use the compared
248 data-constructors' tags to deal with the case of different
251 compare a b = case (con2tag_Foo a) of { a# ->
252 case (con2tag_Foo b) of { b# ->
253 case (a# ==# b#) of {
255 False -> case (a# <# b#) of
260 cmp_eq = ... to come ...
264 We are only left with the ``help'' function @cmp_eq@, to deal with
265 comparing data constructors with the same tag.
267 For the ordinary constructors (if any), we emit the sorta-obvious
268 compare-style stuff; for our example:
270 cmp_eq (O1 a1 b1) (O1 a2 b2)
271 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
273 cmp_eq (O2 a1) (O2 a2)
276 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
277 = case (compare a1 a2) of {
280 EQ -> case compare b1 b2 of {
288 Again, we must be careful about unlifted comparisons. For example,
289 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
293 cmp_eq lt eq gt (O2 a1) (O2 a2)
295 -- or maybe the unfolded equivalent
299 For the remaining nullary constructors, we already know that the
306 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
310 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
313 = compare -- `AndMonoBinds` compare
314 -- The default declaration in PrelBase handles this
316 tycon_loc = getSrcLoc tycon
317 --------------------------------------------------------------------
318 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
321 (if maybeToBool (maybeTyConSingleCon tycon) then
323 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
324 -- Weird. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
326 cmp_eq_Expr a_Expr b_Expr
328 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
329 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
330 -- True case; they are equal
331 -- If an enumeration type we are done; else
332 -- recursively compare their components
333 (if isEnumerationTyCon tycon then
336 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
338 cmp_eq_Expr a_Expr b_Expr
340 -- False case; they aren't equal
341 -- So we need to do a less-than comparison on the tags
342 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
344 tycon_data_cons = tyConDataCons tycon
345 (nullary_cons, nonnullary_cons)
346 | isNewTyCon tycon = ([], tyConDataCons tycon)
347 | otherwise = partition isNullaryDataCon tycon_data_cons
350 mk_FunMonoBind tycon_loc
352 (if null nonnullary_cons && isSingleton nullary_cons then
353 -- catch this specially to avoid warnings
354 -- about overlapping patterns from the desugarer.
356 data_con = head nullary_cons
357 data_con_RDR = qual_orig_name data_con
358 pat = ConPatIn data_con_RDR []
360 [([pat,pat], eqTag_Expr)]
362 map pats_etc nonnullary_cons ++
363 -- leave out wildcards to silence desugarer.
364 (if isSingleton tycon_data_cons then
367 [([WildPatIn, WildPatIn], default_rhs)]))
370 = ([con1_pat, con2_pat],
371 nested_compare_expr tys_needed as_needed bs_needed)
373 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
374 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
376 data_con_RDR = qual_orig_name data_con
377 con_arity = length tys_needed
378 as_needed = take con_arity as_RDRs
379 bs_needed = take con_arity bs_RDRs
380 tys_needed = dataConOrigArgTys data_con
382 nested_compare_expr [ty] [a] [b]
383 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
385 nested_compare_expr (ty:tys) (a:as) (b:bs)
386 = let eq_expr = nested_compare_expr tys as bs
387 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
389 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
390 -- inexhaustive patterns
391 | otherwise = eqTag_Expr -- Some nullary constructors;
392 -- Tags are equal, no args => return EQ
395 %************************************************************************
397 \subsubsection{Generating @Enum@ instance declarations}
399 %************************************************************************
401 @Enum@ can only be derived for enumeration types. For a type
403 data Foo ... = N1 | N2 | ... | Nn
406 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
407 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
410 instance ... Enum (Foo ...) where
411 succ x = toEnum (1 + fromEnum x)
412 pred x = toEnum (fromEnum x - 1)
414 toEnum i = tag2con_Foo i
416 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
420 = case con2tag_Foo a of
421 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
424 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
428 = case con2tag_Foo a of { a# ->
429 case con2tag_Foo b of { b# ->
430 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
434 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
437 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
440 = succ_enum `AndMonoBinds`
441 pred_enum `AndMonoBinds`
442 to_enum `AndMonoBinds`
443 enum_from `AndMonoBinds`
444 enum_from_then `AndMonoBinds`
447 tycon_loc = getSrcLoc tycon
448 occ_nm = getOccString tycon
451 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
452 untag_Expr tycon [(a_RDR, ah_RDR)] $
453 HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon),
454 mkHsVarApps mkInt_RDR [ah_RDR]])
455 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
456 (HsApp (HsVar (tag2con_RDR tycon))
457 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
462 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
463 untag_Expr tycon [(a_RDR, ah_RDR)] $
464 HsIf (mkHsApps eq_RDR [mkHsIntLit 0,
465 mkHsVarApps mkInt_RDR [ah_RDR]])
466 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
467 (HsApp (HsVar (tag2con_RDR tycon))
468 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
469 HsLit (HsInt (-1))]))
473 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
474 HsIf (mkHsApps and_RDR
475 [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0],
476 mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]])
477 (mkHsVarApps (tag2con_RDR tycon) [a_RDR])
478 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
482 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
483 untag_Expr tycon [(a_RDR, ah_RDR)] $
485 [HsVar (tag2con_RDR tycon),
486 HsPar (enum_from_to_Expr
487 (mkHsVarApps mkInt_RDR [ah_RDR])
488 (HsVar (maxtag_RDR tycon)))]
491 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
492 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
493 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
494 HsPar (enum_from_then_to_Expr
495 (mkHsVarApps mkInt_RDR [ah_RDR])
496 (mkHsVarApps mkInt_RDR [bh_RDR])
497 (HsIf (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
498 mkHsVarApps mkInt_RDR [bh_RDR]])
500 (HsVar (maxtag_RDR tycon))
504 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
505 untag_Expr tycon [(a_RDR, ah_RDR)] $
506 (mkHsVarApps mkInt_RDR [ah_RDR])
509 %************************************************************************
511 \subsubsection{Generating @Bounded@ instance declarations}
513 %************************************************************************
516 gen_Bounded_binds tycon
517 = if isEnumerationTyCon tycon then
518 min_bound_enum `AndMonoBinds` max_bound_enum
520 ASSERT(isSingleton data_cons)
521 min_bound_1con `AndMonoBinds` max_bound_1con
523 data_cons = tyConDataCons tycon
524 tycon_loc = getSrcLoc tycon
526 ----- enum-flavored: ---------------------------
527 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
528 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
530 data_con_1 = head data_cons
531 data_con_N = last data_cons
532 data_con_1_RDR = qual_orig_name data_con_1
533 data_con_N_RDR = qual_orig_name data_con_N
535 ----- single-constructor-flavored: -------------
536 arity = dataConSourceArity data_con_1
538 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
539 mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
540 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
541 mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
544 %************************************************************************
546 \subsubsection{Generating @Ix@ instance declarations}
548 %************************************************************************
550 Deriving @Ix@ is only possible for enumeration types and
551 single-constructor types. We deal with them in turn.
553 For an enumeration type, e.g.,
555 data Foo ... = N1 | N2 | ... | Nn
557 things go not too differently from @Enum@:
559 instance ... Ix (Foo ...) where
561 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
565 = case (con2tag_Foo a) of { a# ->
566 case (con2tag_Foo b) of { b# ->
567 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
572 then case (con2tag_Foo d -# con2tag_Foo a) of
574 else error "Ix.Foo.index: out of range"
578 p_tag = con2tag_Foo c
580 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
584 = case (con2tag_Foo a) of { a_tag ->
585 case (con2tag_Foo b) of { b_tag ->
586 case (con2tag_Foo c) of { c_tag ->
587 if (c_tag >=# a_tag) then
593 (modulo suitable case-ification to handle the unlifted tags)
595 For a single-constructor type (NB: this includes all tuples), e.g.,
597 data Foo ... = MkFoo a b Int Double c c
599 we follow the scheme given in Figure~19 of the Haskell~1.2 report
603 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
606 = if isEnumerationTyCon tycon
610 tycon_str = getOccString tycon
611 tycon_loc = getSrcLoc tycon
613 --------------------------------------------------------------
614 enum_ixes = enum_range `AndMonoBinds`
615 enum_index `AndMonoBinds` enum_inRange
618 = mk_easy_FunMonoBind tycon_loc range_RDR
619 [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
620 untag_Expr tycon [(a_RDR, ah_RDR)] $
621 untag_Expr tycon [(b_RDR, bh_RDR)] $
622 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
623 HsPar (enum_from_to_Expr
624 (mkHsVarApps mkInt_RDR [ah_RDR])
625 (mkHsVarApps mkInt_RDR [bh_RDR]))
628 = mk_easy_FunMonoBind tycon_loc index_RDR
629 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
631 HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
632 untag_Expr tycon [(a_RDR, ah_RDR)] (
633 untag_Expr tycon [(d_RDR, dh_RDR)] (
635 rhs = mkHsVarApps mkInt_RDR [c_RDR]
638 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
639 [mkSimpleMatch [VarPatIn c_RDR] rhs placeHolderType tycon_loc]
643 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
648 = mk_easy_FunMonoBind tycon_loc inRange_RDR
649 [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
650 untag_Expr tycon [(a_RDR, ah_RDR)] (
651 untag_Expr tycon [(b_RDR, bh_RDR)] (
652 untag_Expr tycon [(c_RDR, ch_RDR)] (
653 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
654 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
659 --------------------------------------------------------------
661 = single_con_range `AndMonoBinds`
662 single_con_index `AndMonoBinds`
666 = case maybeTyConSingleCon tycon of -- just checking...
667 Nothing -> panic "get_Ix_binds"
668 Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
669 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
673 con_arity = dataConSourceArity data_con
674 data_con_RDR = qual_orig_name data_con
676 as_needed = take con_arity as_RDRs
677 bs_needed = take con_arity bs_RDRs
678 cs_needed = take con_arity cs_RDRs
680 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
681 con_expr = mkHsVarApps data_con_RDR cs_needed
683 --------------------------------------------------------------
685 = mk_easy_FunMonoBind tycon_loc range_RDR
686 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
687 HsDo ListComp stmts tycon_loc
689 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
691 [ResultStmt con_expr tycon_loc]
693 mk_qual a b c = BindStmt (VarPatIn c)
694 (HsApp (HsVar range_RDR)
695 (ExplicitTuple [HsVar a, HsVar b] Boxed))
700 = mk_easy_FunMonoBind tycon_loc index_RDR
701 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
702 con_pat cs_needed] [range_size] (
703 foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
705 mk_index multiply_by (l, u, i)
707 (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,
711 (HsApp (HsVar rangeSize_RDR)
712 (ExplicitTuple [HsVar l, HsVar u] Boxed))
713 ) times_RDR multiply_by
717 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
718 [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
720 (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
722 ) plus_RDR (mkHsIntLit 1))
726 = mk_easy_FunMonoBind tycon_loc inRange_RDR
727 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
730 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
732 in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
736 %************************************************************************
738 \subsubsection{Generating @Read@ instance declarations}
740 %************************************************************************
750 instance Read T where
754 do x <- ReadP.step Read.readPrec
755 Symbol "%%" <- Lex.lex
756 y <- ReadP.step Read.readPrec
760 do Ident "T1" <- Lex.lex
761 Single '{' <- Lex.lex
762 Ident "f1" <- Lex.lex
763 Single '=' <- Lex.lex
764 x <- ReadP.reset Read.readPrec
765 Single '}' <- Lex.lex
766 return (T1 { f1 = x }))
769 do Ident "T2" <- Lex.lexP
770 x <- ReadP.step Read.readPrec
774 readListPrec = readListPrecDefault
775 readList = readListDefault
779 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
781 gen_Read_binds get_fixity tycon
782 = read_prec `AndMonoBinds` default_binds
784 -----------------------------------------------------------------------
786 = mk_easy_FunMonoBind loc readList_RDR [] [] (HsVar readListDefault_RDR)
788 mk_easy_FunMonoBind loc readListPrec_RDR [] [] (HsVar readListPrecDefault_RDR)
789 -----------------------------------------------------------------------
791 loc = getSrcLoc tycon
792 data_cons = tyConDataCons tycon
793 (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
795 read_prec = mk_easy_FunMonoBind loc readPrec_RDR [] []
796 (HsApp (HsVar parens_RDR) read_cons)
798 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
799 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
802 = case nullary_cons of
804 [con] -> [HsDo DoExpr [BindStmt (ident_pat (data_con_str con)) lex loc,
805 result_stmt con []] loc]
806 _ -> [HsApp (HsVar choose_RDR)
807 (ExplicitList placeHolderType (map mk_pair nullary_cons))]
809 mk_pair con = ExplicitTuple [HsLit (data_con_str con),
810 HsApp (HsVar returnM_RDR) (HsVar (qual_orig_name con))]
813 read_non_nullary_con data_con
814 = mkHsApps prec_RDR [mkHsIntLit prec, HsDo DoExpr stmts loc]
816 stmts | is_infix = infix_stmts
817 | length labels > 0 = lbl_stmts
818 | otherwise = prefix_stmts
820 prefix_stmts -- T a b c
821 = [BindStmt (ident_pat (data_con_str data_con)) lex loc]
822 ++ map read_arg as_needed
823 ++ [result_stmt data_con as_needed]
825 infix_stmts -- a %% b
827 BindStmt (symbol_pat (data_con_str data_con)) lex loc,
829 result_stmt data_con [a1,a2]]
831 lbl_stmts -- T { f1 = a, f2 = b }
832 = [BindStmt (ident_pat (data_con_str data_con)) lex loc,
834 ++ concat (intersperse [read_punc ','] field_stmts)
835 ++ [read_punc '}', result_stmt data_con as_needed]
837 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
839 con_arity = dataConSourceArity data_con
840 nullary_con = con_arity == 0
841 labels = dataConFieldLabels data_con
842 lab_fields = length labels
843 dc_nm = getName data_con
844 is_infix = isDataSymOcc (getOccName dc_nm)
845 as_needed = take con_arity as_RDRs
846 (a1:a2:_) = as_needed
848 prec | not is_infix = appPrecedence
849 | otherwise = getPrecedence get_fixity dc_nm
851 ------------------------------------------------------------------------
853 ------------------------------------------------------------------------
854 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
855 result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
856 con_app c as = mkHsVarApps (qual_orig_name c) as
859 single_pat c = ConPatIn single_RDR [LitPatIn (mkHsChar c)] -- Single 'x'
860 ident_pat s = ConPatIn ident_RDR [LitPatIn s] -- Ident "foo"
861 symbol_pat s = ConPatIn symbol_RDR [LitPatIn s] -- Symbol ">>"
863 lbl_str :: FieldLabel -> HsLit
864 lbl_str lbl = mkHsString (occNameUserString (getOccName (fieldLabelName lbl)))
865 data_con_str con = mkHsString (occNameUserString (getOccName con))
867 read_punc c = BindStmt (single_pat c) lex loc
868 read_arg a = BindStmt (VarPatIn a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
870 read_field lbl a = [BindStmt (ident_pat (lbl_str lbl)) lex loc,
872 BindStmt (VarPatIn a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
876 %************************************************************************
878 \subsubsection{Generating @Show@ instance declarations}
880 %************************************************************************
883 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
885 gen_Show_binds get_fixity tycon
886 = shows_prec `AndMonoBinds` show_list
888 tycon_loc = getSrcLoc tycon
889 -----------------------------------------------------------------------
890 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
891 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
892 -----------------------------------------------------------------------
893 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
896 | nullary_con = -- skip the showParen junk...
897 ASSERT(null bs_needed)
898 ([wildPat, con_pat], show_con)
901 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
902 (HsPar (nested_compose_Expr show_thingies)))
904 data_con_RDR = qual_orig_name data_con
905 con_arity = dataConSourceArity data_con
906 bs_needed = take con_arity bs_RDRs
907 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
908 nullary_con = con_arity == 0
909 labels = dataConFieldLabels data_con
910 lab_fields = length labels
912 dc_nm = getName data_con
913 dc_occ_nm = getOccName data_con
914 dc_occ_nm_str = occNameUserString dc_occ_nm
916 is_infix = isDataSymOcc dc_occ_nm
920 | is_infix = mk_showString_app (' ':dc_occ_nm_str)
921 | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
925 | lab_fields == 0 = " "
929 show_all con fs@(x:xs)
930 | is_infix = x:con:xs
934 | lab_fields > 0 = [mk_showString_app "}"]
937 con:fs ++ ccurly_maybe
939 show_thingies = show_all show_con real_show_thingies_with_labs
941 show_label l = mk_showString_app (the_name ++ "=")
943 occ_nm = getOccName (fieldLabelName l)
945 is_op = isSymOcc occ_nm
947 | is_op = '(':nm ++ ")"
950 nm = occNameUserString occ_nm
953 mk_showString_app str = HsApp (HsVar showString_RDR)
954 (HsLit (mkHsString str))
956 prec_cons = getLRPrecs is_infix get_fixity dc_nm
960 [ mkHsApps showsPrec_RDR [HsLit (HsInt p), HsVar b]
961 | (p,b) <- zip prec_cons bs_needed ]
963 [ mkHsApps showsPrec_RDR [mkHsIntLit 10, HsVar b]
966 real_show_thingies_with_labs
967 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
968 | otherwise = --Assumption: no of fields == no of labelled fields
969 -- (and in same order)
971 intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
972 zipWithEqual "gen_Show_binds"
974 (map show_label labels)
978 c.f. Figure 16 and 17 in Haskell 1.1 report
981 | not is_infix = appPrecedence + 1
982 | otherwise = getPrecedence get_fixity dc_nm + 1
987 getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer]
988 getLRPrecs is_infix get_fixity nm = [lp, rp]
991 Figuring out the fixities of the arguments to a constructor,
992 cf. Figures 16-18 in Haskell 1.1 report.
994 (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm
995 paren_con_prec = getPrecedence get_fixity nm
998 | not is_infix = appPrecedence + 1
999 | con_left_assoc = paren_con_prec
1000 | otherwise = paren_con_prec + 1
1003 | not is_infix = appPrecedence + 1
1004 | con_right_assoc = paren_con_prec
1005 | otherwise = paren_con_prec + 1
1007 appPrecedence :: Integer
1008 appPrecedence = fromIntegral maxPrecedence
1010 getPrecedence :: FixityEnv -> Name -> Integer
1011 getPrecedence get_fixity nm
1012 = case lookupFixity get_fixity nm of
1013 Fixity x _ -> fromIntegral x
1015 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
1016 isLRAssoc get_fixity nm =
1017 case lookupFixity get_fixity nm of
1018 Fixity _ InfixN -> (False, False)
1019 Fixity _ InfixR -> (False, True)
1020 Fixity _ InfixL -> (True, False)
1024 %************************************************************************
1026 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1028 %************************************************************************
1033 con2tag_Foo :: Foo ... -> Int#
1034 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1035 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1038 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1043 = GenCon2Tag | GenTag2Con | GenMaxTag
1045 gen_tag_n_con_monobind
1046 :: (RdrName, -- (proto)Name for the thing in question
1047 TyCon, -- tycon in question
1051 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1052 | lots_of_constructors
1053 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1054 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1057 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1060 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1062 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1064 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1066 pat = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
1067 var_RDR = qual_orig_name var
1069 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1070 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1071 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1072 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1073 (HsTyVar (qual_orig_name tycon)))]
1075 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1076 = mk_easy_FunMonoBind (getSrcLoc tycon)
1077 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1079 max_tag = case (tyConDataCons tycon) of
1080 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1084 %************************************************************************
1086 \subsection{Utility bits for generating bindings}
1088 %************************************************************************
1090 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1092 fun pat1 pat2 ... patN = expr where binds
1095 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1096 multi-clause definitions; it generates:
1098 fun p1a p1b ... p1N = e1
1099 fun p2a p2b ... p2N = e2
1101 fun pMa pMb ... pMN = eM
1105 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1106 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1109 mk_easy_FunMonoBind loc fun pats binds expr
1110 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1112 mk_easy_Match loc pats binds expr
1113 = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
1114 -- The renamer expects everything in its input to be a
1115 -- "recursive" MonoBinds, and it is its job to sort things out
1118 mk_FunMonoBind :: SrcLoc -> RdrName
1119 -> [([RdrNamePat], RdrNameHsExpr)]
1122 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1123 mk_FunMonoBind loc fun pats_and_exprs
1124 = FunMonoBind fun False{-not infix-}
1125 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1128 mk_match loc pats expr binds
1129 = Match (map paren pats) Nothing
1130 (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1132 paren p@(VarPatIn _) = p
1133 paren other_p = ParPatIn other_p
1137 mkHsApps f xs = foldl HsApp (HsVar f) xs
1138 mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs)
1140 mkHsIntLit n = HsLit (HsInt n)
1141 mkHsString s = HsString (_PK_ s)
1142 mkHsChar c = HsChar (ord c)
1145 ToDo: Better SrcLocs.
1150 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1151 -> RdrNameHsExpr -> RdrNameHsExpr
1153 careful_compare_Case :: -- checks for primitive types...
1155 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1156 -> RdrNameHsExpr -> RdrNameHsExpr
1159 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1160 -- Was: compare_gen_Case cmp_eq_RDR
1162 compare_gen_Case fun lt eq gt a b
1163 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1164 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt placeHolderType generatedSrcLoc,
1165 mkSimpleMatch [ConPatIn eqTag_RDR []] eq placeHolderType generatedSrcLoc,
1166 mkSimpleMatch [ConPatIn gtTag_RDR []] gt placeHolderType generatedSrcLoc]
1169 careful_compare_Case ty lt eq gt a b
1170 | not (isUnLiftedType ty) =
1171 compare_gen_Case compare_RDR lt eq gt a b
1173 -- we have to do something special for primitive things...
1174 HsIf (genOpApp a relevant_eq_op b)
1176 (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc)
1179 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1180 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1182 assoc_ty_id tyids ty
1183 = if null res then panic "assoc_ty"
1186 res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
1189 [(charPrimTy, eqH_Char_RDR)
1190 ,(intPrimTy, eqH_Int_RDR)
1191 ,(wordPrimTy, eqH_Word_RDR)
1192 ,(addrPrimTy, eqH_Addr_RDR)
1193 ,(floatPrimTy, eqH_Float_RDR)
1194 ,(doublePrimTy, eqH_Double_RDR)
1198 [(charPrimTy, ltH_Char_RDR)
1199 ,(intPrimTy, ltH_Int_RDR)
1200 ,(wordPrimTy, ltH_Word_RDR)
1201 ,(addrPrimTy, ltH_Addr_RDR)
1202 ,(floatPrimTy, ltH_Float_RDR)
1203 ,(doublePrimTy, ltH_Double_RDR)
1206 -----------------------------------------------------------------------
1208 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1210 and_Expr a b = genOpApp a and_RDR b
1211 append_Expr a b = genOpApp a append_RDR b
1213 -----------------------------------------------------------------------
1215 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1216 eq_Expr ty a b = genOpApp a eq_op b
1219 | not (isUnLiftedType ty) = eq_RDR
1221 -- we have to do something special for primitive things...
1222 assoc_ty_id eq_op_tbl ty
1227 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1228 untag_Expr tycon [] expr = expr
1229 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1230 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1231 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
1234 cmp_tags_Expr :: RdrName -- Comparison op
1235 -> RdrName -> RdrName -- Things to compare
1236 -> RdrNameHsExpr -- What to return if true
1237 -> RdrNameHsExpr -- What to return if false
1240 cmp_tags_Expr op a b true_case false_case
1241 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1244 :: RdrNameHsExpr -> RdrNameHsExpr
1246 enum_from_then_to_Expr
1247 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1250 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1251 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1254 :: RdrNameHsExpr -> RdrNameHsExpr
1257 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1259 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1261 nested_compose_Expr [e] = parenify e
1262 nested_compose_Expr (e:es)
1263 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1265 -- impossible_Expr is used in case RHSs that should never happen.
1266 -- We generate these to keep the desugarer from complaining that they *might* happen!
1267 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1269 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1270 -- method. It is currently only used by Enum.{succ,pred}
1271 illegal_Expr meth tp msg =
1272 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1274 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1275 -- to include the value of a_RDR in the error string.
1276 illegal_toEnum_tag tp maxtag =
1277 HsApp (HsVar error_RDR)
1278 (HsApp (HsApp (HsVar append_RDR)
1279 (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1280 (HsApp (HsApp (HsApp
1281 (HsVar showsPrec_RDR)
1286 (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1287 (HsApp (HsApp (HsApp
1288 (HsVar showsPrec_RDR)
1291 (HsLit (HsString (_PK_ ")")))))))
1293 parenify e@(HsVar _) = e
1294 parenify e = HsPar e
1296 -- genOpApp wraps brackets round the operator application, so that the
1297 -- renamer won't subsequently try to re-associate it.
1298 -- For some reason the renamer doesn't reassociate it right, and I can't
1299 -- be bothered to find out why just now.
1301 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1305 qual_orig_name n = nameRdrName (getName n)
1306 varUnqual n = mkUnqual varName n
1308 zz_a_RDR = varUnqual FSLIT("_a")
1309 a_RDR = varUnqual FSLIT("a")
1310 b_RDR = varUnqual FSLIT("b")
1311 c_RDR = varUnqual FSLIT("c")
1312 d_RDR = varUnqual FSLIT("d")
1313 ah_RDR = varUnqual FSLIT("a#")
1314 bh_RDR = varUnqual FSLIT("b#")
1315 ch_RDR = varUnqual FSLIT("c#")
1316 dh_RDR = varUnqual FSLIT("d#")
1317 cmp_eq_RDR = varUnqual FSLIT("cmp_eq")
1318 rangeSize_RDR = varUnqual FSLIT("rangeSize")
1320 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1321 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1322 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1324 zz_a_Expr = HsVar zz_a_RDR
1325 a_Expr = HsVar a_RDR
1326 b_Expr = HsVar b_RDR
1327 c_Expr = HsVar c_RDR
1328 d_Expr = HsVar d_RDR
1329 ltTag_Expr = HsVar ltTag_RDR
1330 eqTag_Expr = HsVar eqTag_RDR
1331 gtTag_Expr = HsVar gtTag_RDR
1332 false_Expr = HsVar false_RDR
1333 true_Expr = HsVar true_RDR
1335 getTag_Expr = HsVar getTag_RDR
1336 tagToEnum_Expr = HsVar tagToEnumH_RDR
1337 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1340 zz_a_Pat = VarPatIn zz_a_RDR
1341 a_Pat = VarPatIn a_RDR
1342 b_Pat = VarPatIn b_RDR
1343 c_Pat = VarPatIn c_RDR
1344 d_Pat = VarPatIn d_RDR
1346 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1348 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1349 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1350 maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))