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 RdrName ( RdrName, mkUnqual )
35 import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
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 )
65 import Char ( ord, isAlpha )
67 import List ( partition, intersperse )
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 unlifted 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 deriveEq :: RdrName -- Class
152 -> RdrName -- Type constructor
153 -> [ (RdrName, [RdrType]) ] -- Constructors
154 -> (RdrContext, -- Context for the inst decl
155 [RdrBind], -- Binds in the inst decl
156 [RdrBind]) -- Extra value bindings outside
158 deriveEq clas tycon constrs
159 = (context, [eq_bind, ne_bind], [])
161 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
164 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
165 is_nullary (_, args) = null args
168 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
172 tycon_loc = getSrcLoc tycon
173 (nullary_cons, nonnullary_cons)
174 | isNewTyCon tycon = ([], tyConDataCons tycon)
175 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
178 = if (null nullary_cons) then
179 case maybeTyConSingleCon tycon of
181 Nothing -> -- if cons don't match, then False
182 [([wildPat, wildPat], false_Expr)]
183 else -- calc. and compare the tags
185 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
186 (genOpApp (HsVar ah_RDR) eqH_Int_RDR (HsVar bh_RDR)))]
188 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
190 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
191 HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR])))
193 ------------------------------------------------------------------
196 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
197 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
199 data_con_RDR = qual_orig_name data_con
200 con_arity = length tys_needed
201 as_needed = take con_arity as_RDRs
202 bs_needed = take con_arity bs_RDRs
203 tys_needed = dataConOrigArgTys data_con
205 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
207 nested_eq_expr [] [] [] = true_Expr
208 nested_eq_expr tys as bs
209 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
211 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
214 %************************************************************************
216 \subsubsection{Generating @Ord@ instance declarations}
218 %************************************************************************
220 For a derived @Ord@, we concentrate our attentions on @compare@
222 compare :: a -> a -> Ordering
223 data Ordering = LT | EQ | GT deriving ()
226 We will use the same example data type as above:
228 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
233 We do all the other @Ord@ methods with calls to @compare@:
235 instance ... (Ord <wurble> <wurble>) where
236 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
237 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
238 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
239 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
241 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
242 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
244 -- compare to come...
248 @compare@ always has two parts. First, we use the compared
249 data-constructors' tags to deal with the case of different
252 compare a b = case (con2tag_Foo a) of { a# ->
253 case (con2tag_Foo b) of { b# ->
254 case (a# ==# b#) of {
256 False -> case (a# <# b#) of
261 cmp_eq = ... to come ...
265 We are only left with the ``help'' function @cmp_eq@, to deal with
266 comparing data constructors with the same tag.
268 For the ordinary constructors (if any), we emit the sorta-obvious
269 compare-style stuff; for our example:
271 cmp_eq (O1 a1 b1) (O1 a2 b2)
272 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
274 cmp_eq (O2 a1) (O2 a2)
277 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
278 = case (compare a1 a2) of {
281 EQ -> case compare b1 b2 of {
289 Again, we must be careful about unlifted comparisons. For example,
290 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
294 cmp_eq lt eq gt (O2 a1) (O2 a2)
296 -- or maybe the unfolded equivalent
300 For the remaining nullary constructors, we already know that the
307 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
311 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
314 = compare -- `AndMonoBinds` compare
315 -- The default declaration in PrelBase handles this
317 tycon_loc = getSrcLoc tycon
318 --------------------------------------------------------------------
319 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
322 (if maybeToBool (maybeTyConSingleCon tycon) then
324 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
325 -- Weird. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
327 cmp_eq_Expr a_Expr b_Expr
329 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
330 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
331 -- True case; they are equal
332 -- If an enumeration type we are done; else
333 -- recursively compare their components
334 (if isEnumerationTyCon tycon then
337 -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
339 cmp_eq_Expr a_Expr b_Expr
341 -- False case; they aren't equal
342 -- So we need to do a less-than comparison on the tags
343 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
345 tycon_data_cons = tyConDataCons tycon
346 (nullary_cons, nonnullary_cons)
347 | isNewTyCon tycon = ([], tyConDataCons tycon)
348 | otherwise = partition isNullaryDataCon tycon_data_cons
351 mk_FunMonoBind tycon_loc
353 (if null nonnullary_cons && isSingleton nullary_cons then
354 -- catch this specially to avoid warnings
355 -- about overlapping patterns from the desugarer.
357 data_con = head nullary_cons
358 data_con_RDR = qual_orig_name data_con
359 pat = ConPatIn data_con_RDR []
361 [([pat,pat], eqTag_Expr)]
363 map pats_etc nonnullary_cons ++
364 -- leave out wildcards to silence desugarer.
365 (if isSingleton tycon_data_cons then
368 [([WildPatIn, WildPatIn], default_rhs)]))
371 = ([con1_pat, con2_pat],
372 nested_compare_expr tys_needed as_needed bs_needed)
374 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
375 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
377 data_con_RDR = qual_orig_name data_con
378 con_arity = length tys_needed
379 as_needed = take con_arity as_RDRs
380 bs_needed = take con_arity bs_RDRs
381 tys_needed = dataConOrigArgTys data_con
383 nested_compare_expr [ty] [a] [b]
384 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
386 nested_compare_expr (ty:tys) (a:as) (b:bs)
387 = let eq_expr = nested_compare_expr tys as bs
388 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
390 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
391 -- inexhaustive patterns
392 | otherwise = eqTag_Expr -- Some nullary constructors;
393 -- Tags are equal, no args => return EQ
396 %************************************************************************
398 \subsubsection{Generating @Enum@ instance declarations}
400 %************************************************************************
402 @Enum@ can only be derived for enumeration types. For a type
404 data Foo ... = N1 | N2 | ... | Nn
407 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
408 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
411 instance ... Enum (Foo ...) where
412 succ x = toEnum (1 + fromEnum x)
413 pred x = toEnum (fromEnum x - 1)
415 toEnum i = tag2con_Foo i
417 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
421 = case con2tag_Foo a of
422 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
425 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
429 = case con2tag_Foo a of { a# ->
430 case con2tag_Foo b of { b# ->
431 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
435 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
438 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
441 = succ_enum `AndMonoBinds`
442 pred_enum `AndMonoBinds`
443 to_enum `AndMonoBinds`
444 enum_from `AndMonoBinds`
445 enum_from_then `AndMonoBinds`
448 tycon_loc = getSrcLoc tycon
449 occ_nm = getOccString tycon
452 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
453 untag_Expr tycon [(a_RDR, ah_RDR)] $
454 HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon),
455 mkHsVarApps mkInt_RDR [ah_RDR]])
456 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
457 (HsApp (HsVar (tag2con_RDR tycon))
458 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
463 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
464 untag_Expr tycon [(a_RDR, ah_RDR)] $
465 HsIf (mkHsApps eq_RDR [mkHsIntLit 0,
466 mkHsVarApps mkInt_RDR [ah_RDR]])
467 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
468 (HsApp (HsVar (tag2con_RDR tycon))
469 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
470 HsLit (HsInt (-1))]))
474 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
475 HsIf (mkHsApps and_RDR
476 [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0],
477 mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]])
478 (mkHsVarApps (tag2con_RDR tycon) [a_RDR])
479 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
483 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
484 untag_Expr tycon [(a_RDR, ah_RDR)] $
486 [HsVar (tag2con_RDR tycon),
487 HsPar (enum_from_to_Expr
488 (mkHsVarApps mkInt_RDR [ah_RDR])
489 (HsVar (maxtag_RDR tycon)))]
492 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
493 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
494 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
495 HsPar (enum_from_then_to_Expr
496 (mkHsVarApps mkInt_RDR [ah_RDR])
497 (mkHsVarApps mkInt_RDR [bh_RDR])
498 (HsIf (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
499 mkHsVarApps mkInt_RDR [bh_RDR]])
501 (HsVar (maxtag_RDR tycon))
505 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
506 untag_Expr tycon [(a_RDR, ah_RDR)] $
507 (mkHsVarApps mkInt_RDR [ah_RDR])
510 %************************************************************************
512 \subsubsection{Generating @Bounded@ instance declarations}
514 %************************************************************************
517 gen_Bounded_binds tycon
518 = if isEnumerationTyCon tycon then
519 min_bound_enum `AndMonoBinds` max_bound_enum
521 ASSERT(isSingleton data_cons)
522 min_bound_1con `AndMonoBinds` max_bound_1con
524 data_cons = tyConDataCons tycon
525 tycon_loc = getSrcLoc tycon
527 ----- enum-flavored: ---------------------------
528 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
529 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
531 data_con_1 = head data_cons
532 data_con_N = last data_cons
533 data_con_1_RDR = qual_orig_name data_con_1
534 data_con_N_RDR = qual_orig_name data_con_N
536 ----- single-constructor-flavored: -------------
537 arity = dataConSourceArity data_con_1
539 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
540 mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
541 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
542 mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
545 %************************************************************************
547 \subsubsection{Generating @Ix@ instance declarations}
549 %************************************************************************
551 Deriving @Ix@ is only possible for enumeration types and
552 single-constructor types. We deal with them in turn.
554 For an enumeration type, e.g.,
556 data Foo ... = N1 | N2 | ... | Nn
558 things go not too differently from @Enum@:
560 instance ... Ix (Foo ...) where
562 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
566 = case (con2tag_Foo a) of { a# ->
567 case (con2tag_Foo b) of { b# ->
568 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
573 then case (con2tag_Foo d -# con2tag_Foo a) of
575 else error "Ix.Foo.index: out of range"
579 p_tag = con2tag_Foo c
581 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
585 = case (con2tag_Foo a) of { a_tag ->
586 case (con2tag_Foo b) of { b_tag ->
587 case (con2tag_Foo c) of { c_tag ->
588 if (c_tag >=# a_tag) then
594 (modulo suitable case-ification to handle the unlifted tags)
596 For a single-constructor type (NB: this includes all tuples), e.g.,
598 data Foo ... = MkFoo a b Int Double c c
600 we follow the scheme given in Figure~19 of the Haskell~1.2 report
604 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
607 = if isEnumerationTyCon tycon
611 tycon_str = getOccString tycon
612 tycon_loc = getSrcLoc tycon
614 --------------------------------------------------------------
615 enum_ixes = enum_range `AndMonoBinds`
616 enum_index `AndMonoBinds` enum_inRange
619 = mk_easy_FunMonoBind tycon_loc range_RDR
620 [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
621 untag_Expr tycon [(a_RDR, ah_RDR)] $
622 untag_Expr tycon [(b_RDR, bh_RDR)] $
623 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
624 HsPar (enum_from_to_Expr
625 (mkHsVarApps mkInt_RDR [ah_RDR])
626 (mkHsVarApps mkInt_RDR [bh_RDR]))
629 = mk_easy_FunMonoBind tycon_loc index_RDR
630 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
632 HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
633 untag_Expr tycon [(a_RDR, ah_RDR)] (
634 untag_Expr tycon [(d_RDR, dh_RDR)] (
636 rhs = mkHsVarApps mkInt_RDR [c_RDR]
639 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
640 [mkSimpleMatch [VarPatIn c_RDR] rhs placeHolderType tycon_loc]
644 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
649 = mk_easy_FunMonoBind tycon_loc inRange_RDR
650 [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
651 untag_Expr tycon [(a_RDR, ah_RDR)] (
652 untag_Expr tycon [(b_RDR, bh_RDR)] (
653 untag_Expr tycon [(c_RDR, ch_RDR)] (
654 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
655 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
660 --------------------------------------------------------------
662 = single_con_range `AndMonoBinds`
663 single_con_index `AndMonoBinds`
667 = case maybeTyConSingleCon tycon of -- just checking...
668 Nothing -> panic "get_Ix_binds"
669 Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
670 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
674 con_arity = dataConSourceArity data_con
675 data_con_RDR = qual_orig_name data_con
677 as_needed = take con_arity as_RDRs
678 bs_needed = take con_arity bs_RDRs
679 cs_needed = take con_arity cs_RDRs
681 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
682 con_expr = mkHsVarApps data_con_RDR cs_needed
684 --------------------------------------------------------------
686 = mk_easy_FunMonoBind tycon_loc range_RDR
687 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
688 mkHsDo ListComp stmts tycon_loc
690 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
692 [ResultStmt con_expr tycon_loc]
694 mk_qual a b c = BindStmt (VarPatIn c)
695 (HsApp (HsVar range_RDR)
696 (ExplicitTuple [HsVar a, HsVar b] Boxed))
701 = mk_easy_FunMonoBind tycon_loc index_RDR
702 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
703 con_pat cs_needed] [range_size] (
704 foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
706 mk_index multiply_by (l, u, i)
708 (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,
712 (HsApp (HsVar rangeSize_RDR)
713 (ExplicitTuple [HsVar l, HsVar u] Boxed))
714 ) times_RDR multiply_by
718 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
719 [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
721 (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
723 ) plus_RDR (mkHsIntLit 1))
727 = mk_easy_FunMonoBind tycon_loc inRange_RDR
728 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
731 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
733 in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
737 %************************************************************************
739 \subsubsection{Generating @Read@ instance declarations}
741 %************************************************************************
751 instance Read T where
755 do x <- ReadP.step Read.readPrec
756 Symbol "%%" <- Lex.lex
757 y <- ReadP.step Read.readPrec
761 do Ident "T1" <- Lex.lex
763 Ident "f1" <- Lex.lex
765 x <- ReadP.reset Read.readPrec
767 return (T1 { f1 = x }))
770 do Ident "T2" <- Lex.lexP
771 x <- ReadP.step Read.readPrec
775 readListPrec = readListPrecDefault
776 readList = readListDefault
780 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
782 gen_Read_binds get_fixity tycon
783 = read_prec `AndMonoBinds` default_binds
785 -----------------------------------------------------------------------
787 = mk_easy_FunMonoBind loc readList_RDR [] [] (HsVar readListDefault_RDR)
789 mk_easy_FunMonoBind loc readListPrec_RDR [] [] (HsVar readListPrecDefault_RDR)
790 -----------------------------------------------------------------------
792 loc = getSrcLoc tycon
793 data_cons = tyConDataCons tycon
794 (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
796 read_prec = mk_easy_FunMonoBind loc readPrec_RDR [] []
797 (HsApp (HsVar parens_RDR) read_cons)
799 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
800 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
803 = case nullary_cons of
805 [con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
806 result_stmt con []] loc]
807 _ -> [HsApp (HsVar choose_RDR)
808 (ExplicitList placeHolderType (map mk_pair nullary_cons))]
810 mk_pair con = ExplicitTuple [HsLit (data_con_str con),
811 HsApp (HsVar returnM_RDR) (HsVar (qual_orig_name con))]
814 read_non_nullary_con data_con
815 = mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc]
817 stmts | is_infix = infix_stmts
818 | length labels > 0 = lbl_stmts
819 | otherwise = prefix_stmts
821 prefix_stmts -- T a b c
822 = [bindLex (ident_pat (data_con_str data_con))]
823 ++ map read_arg as_needed
824 ++ [result_stmt data_con as_needed]
826 infix_stmts -- a %% b
828 bindLex (symbol_pat (data_con_str data_con)),
830 result_stmt data_con [a1,a2]]
832 lbl_stmts -- T { f1 = a, f2 = b }
833 = [bindLex (ident_pat (data_con_str data_con)),
835 ++ concat (intersperse [read_punc ","] field_stmts)
836 ++ [read_punc "}", result_stmt data_con as_needed]
838 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
840 con_arity = dataConSourceArity data_con
841 nullary_con = con_arity == 0
842 labels = dataConFieldLabels data_con
843 lab_fields = length labels
844 dc_nm = getName data_con
845 is_infix = isDataSymOcc (getOccName dc_nm)
846 as_needed = take con_arity as_RDRs
847 (a1:a2:_) = as_needed
848 prec = getPrec is_infix get_fixity dc_nm
850 ------------------------------------------------------------------------
852 ------------------------------------------------------------------------
853 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
854 bindLex pat = BindStmt pat (HsVar lexP_RDR) loc
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
858 punc_pat s = ConPatIn punc_RDR [LitPatIn (mkHsString s)] -- Punc 'c'
859 ident_pat s = ConPatIn ident_RDR [LitPatIn s] -- Ident "foo"
860 symbol_pat s = ConPatIn symbol_RDR [LitPatIn s] -- Symbol ">>"
862 data_con_str con = mkHsString (occNameUserString (getOccName con))
864 read_punc c = bindLex (punc_pat c)
865 read_arg a = BindStmt (VarPatIn a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
867 read_field lbl a = read_lbl lbl ++
869 BindStmt (VarPatIn a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
871 -- When reading field labels we might encounter
875 read_lbl lbl | isAlpha (head lbl_str)
876 = [bindLex (ident_pat lbl_lit)]
879 bindLex (symbol_pat lbl_lit),
882 lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
883 lbl_lit = mkHsString lbl_str
887 %************************************************************************
889 \subsubsection{Generating @Show@ instance declarations}
891 %************************************************************************
897 data Tree a = Leaf a | Tree a :^: Tree a
899 instance (Show a) => Show (Tree a) where
901 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
903 showStr = showString "Leaf " . showsPrec (app_prec+1) m
905 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
907 showStr = showsPrec (up_prec+1) u .
909 showsPrec (up_prec+1) v
910 -- Note: right-associativity of :^: ignored
912 up_prec = 5 -- Precedence of :^:
913 app_prec = 10 -- Application has precedence one more than
914 -- the most tightly-binding operator
917 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
919 gen_Show_binds get_fixity tycon
920 = shows_prec `AndMonoBinds` show_list
922 tycon_loc = getSrcLoc tycon
923 -----------------------------------------------------------------------
924 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
925 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
926 -----------------------------------------------------------------------
927 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
930 | nullary_con = -- skip the showParen junk...
931 ASSERT(null bs_needed)
932 ([wildPat, con_pat], mk_showString_app con_str)
935 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one))))
936 (HsPar (nested_compose_Expr show_thingies)))
938 data_con_RDR = qual_orig_name data_con
939 con_arity = dataConSourceArity data_con
940 bs_needed = take con_arity bs_RDRs
941 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
942 nullary_con = con_arity == 0
943 labels = dataConFieldLabels data_con
944 lab_fields = length labels
945 record_syntax = lab_fields > 0
947 dc_nm = getName data_con
948 dc_occ_nm = getOccName data_con
949 con_str = occNameUserString dc_occ_nm
952 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
953 | record_syntax = mk_showString_app (con_str ++ " {") :
954 show_record_args ++ [mk_showString_app "}"]
955 | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
957 show_label l = mk_showString_app (the_name ++ " = ")
958 -- Note the spaces around the "=" sign. If we don't have them
959 -- then we get Foo { x=-1 } and the "=-" parses as a single
960 -- lexeme. Only the space after the '=' is necessary, but
961 -- it seems tidier to have them both sides.
963 occ_nm = getOccName (fieldLabelName l)
964 nm = occNameUserString occ_nm
966 is_op = isSymOcc occ_nm -- Legal, but rare.
968 | is_op = '(':nm ++ ")"
971 show_args = [ mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec), HsVar b]
973 (show_arg1:show_arg2:_) = show_args
974 show_prefix_args = intersperse (HsVar showSpace_RDR) show_args
977 -- Assumption for record syntax: no of fields == no of labelled fields
978 -- (and in same order)
979 show_record_args = concat $
980 intersperse [mk_showString_app ", "] $
981 [ [show_label lbl, arg]
982 | (lbl,arg) <- zipEqual "gen_Show_binds"
986 is_infix = isDataSymOcc dc_occ_nm
987 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
988 arg_prec | record_syntax = 0 -- Record fields don't need parens
989 | otherwise = con_prec_plus_one
991 mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str))
995 getPrec :: Bool -> FixityEnv -> Name -> Integer
996 getPrec is_infix get_fixity nm
997 | not is_infix = appPrecedence
998 | otherwise = getPrecedence get_fixity nm
1000 appPrecedence :: Integer
1001 appPrecedence = fromIntegral maxPrecedence + 1
1002 -- One more than the precedence of the most
1003 -- tightly-binding operator
1005 getPrecedence :: FixityEnv -> Name -> Integer
1006 getPrecedence get_fixity nm
1007 = case lookupFixity get_fixity nm of
1008 Fixity x _ -> fromIntegral x
1010 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
1011 isLRAssoc get_fixity nm =
1012 case lookupFixity get_fixity nm of
1013 Fixity _ InfixN -> (False, False)
1014 Fixity _ InfixR -> (False, True)
1015 Fixity _ InfixL -> (True, False)
1019 %************************************************************************
1021 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1023 %************************************************************************
1028 con2tag_Foo :: Foo ... -> Int#
1029 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1030 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1033 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1038 = GenCon2Tag | GenTag2Con | GenMaxTag
1040 gen_tag_n_con_monobind
1041 :: (RdrName, -- (proto)Name for the thing in question
1042 TyCon, -- tycon in question
1046 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1047 | lots_of_constructors
1048 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1049 [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1052 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1055 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1057 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1059 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1061 pat = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
1062 var_RDR = qual_orig_name var
1064 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1065 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1066 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1067 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1068 (HsTyVar (qual_orig_name tycon)))]
1070 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1071 = mk_easy_FunMonoBind (getSrcLoc tycon)
1072 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1074 max_tag = case (tyConDataCons tycon) of
1075 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1079 %************************************************************************
1081 \subsection{Utility bits for generating bindings}
1083 %************************************************************************
1085 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1087 fun pat1 pat2 ... patN = expr where binds
1090 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1091 multi-clause definitions; it generates:
1093 fun p1a p1b ... p1N = e1
1094 fun p2a p2b ... p2N = e2
1096 fun pMa pMb ... pMN = eM
1100 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1101 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1104 mk_easy_FunMonoBind loc fun pats binds expr
1105 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1107 mk_easy_Match loc pats binds expr
1108 = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
1109 -- The renamer expects everything in its input to be a
1110 -- "recursive" MonoBinds, and it is its job to sort things out
1113 mk_FunMonoBind :: SrcLoc -> RdrName
1114 -> [([RdrNamePat], RdrNameHsExpr)]
1117 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1118 mk_FunMonoBind loc fun pats_and_exprs
1119 = FunMonoBind fun False{-not infix-}
1120 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1123 mk_match loc pats expr binds
1124 = Match (map paren pats) Nothing
1125 (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1127 paren p@(VarPatIn _) = p
1128 paren other_p = ParPatIn other_p
1132 mkHsApps f xs = foldl HsApp (HsVar f) xs
1133 mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs)
1135 mkHsIntLit n = HsLit (HsInt n)
1136 mkHsString s = HsString (mkFastString s)
1137 mkHsChar c = HsChar (ord c)
1140 ToDo: Better SrcLocs.
1145 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1146 -> RdrNameHsExpr -> RdrNameHsExpr
1148 careful_compare_Case :: -- checks for primitive types...
1150 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1151 -> RdrNameHsExpr -> RdrNameHsExpr
1154 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1155 -- Was: compare_gen_Case cmp_eq_RDR
1157 compare_gen_Case fun lt eq gt a b
1158 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1159 [mkSimpleMatch [ConPatIn ltTag_RDR []] lt placeHolderType generatedSrcLoc,
1160 mkSimpleMatch [ConPatIn eqTag_RDR []] eq placeHolderType generatedSrcLoc,
1161 mkSimpleMatch [ConPatIn gtTag_RDR []] gt placeHolderType generatedSrcLoc]
1164 careful_compare_Case ty lt eq gt a b
1165 | not (isUnLiftedType ty) =
1166 compare_gen_Case compare_RDR lt eq gt a b
1168 -- we have to do something special for primitive things...
1169 HsIf (genOpApp a relevant_eq_op b)
1171 (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc)
1174 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1175 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1177 assoc_ty_id tyids ty
1178 = if null res then panic "assoc_ty"
1181 res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
1184 [(charPrimTy, eqH_Char_RDR)
1185 ,(intPrimTy, eqH_Int_RDR)
1186 ,(wordPrimTy, eqH_Word_RDR)
1187 ,(addrPrimTy, eqH_Addr_RDR)
1188 ,(floatPrimTy, eqH_Float_RDR)
1189 ,(doublePrimTy, eqH_Double_RDR)
1193 [(charPrimTy, ltH_Char_RDR)
1194 ,(intPrimTy, ltH_Int_RDR)
1195 ,(wordPrimTy, ltH_Word_RDR)
1196 ,(addrPrimTy, ltH_Addr_RDR)
1197 ,(floatPrimTy, ltH_Float_RDR)
1198 ,(doublePrimTy, ltH_Double_RDR)
1201 -----------------------------------------------------------------------
1203 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1205 and_Expr a b = genOpApp a and_RDR b
1206 append_Expr a b = genOpApp a append_RDR b
1208 -----------------------------------------------------------------------
1210 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1211 eq_Expr ty a b = genOpApp a eq_op b
1214 | not (isUnLiftedType ty) = eq_RDR
1216 -- we have to do something special for primitive things...
1217 assoc_ty_id eq_op_tbl ty
1222 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1223 untag_Expr tycon [] expr = expr
1224 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1225 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1226 [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
1229 cmp_tags_Expr :: RdrName -- Comparison op
1230 -> RdrName -> RdrName -- Things to compare
1231 -> RdrNameHsExpr -- What to return if true
1232 -> RdrNameHsExpr -- What to return if false
1235 cmp_tags_Expr op a b true_case false_case
1236 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1239 :: RdrNameHsExpr -> RdrNameHsExpr
1241 enum_from_then_to_Expr
1242 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1245 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1246 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1249 :: RdrNameHsExpr -> RdrNameHsExpr
1252 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1254 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1256 nested_compose_Expr [e] = parenify e
1257 nested_compose_Expr (e:es)
1258 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1260 -- impossible_Expr is used in case RHSs that should never happen.
1261 -- We generate these to keep the desugarer from complaining that they *might* happen!
1262 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv")))
1264 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1265 -- method. It is currently only used by Enum.{succ,pred}
1266 illegal_Expr meth tp msg =
1267 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg))))
1269 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1270 -- to include the value of a_RDR in the error string.
1271 illegal_toEnum_tag tp maxtag =
1272 HsApp (HsVar error_RDR)
1273 (HsApp (HsApp (HsVar append_RDR)
1274 (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag (")))))
1275 (HsApp (HsApp (HsApp
1276 (HsVar showsPrec_RDR)
1281 (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,"))))
1282 (HsApp (HsApp (HsApp
1283 (HsVar showsPrec_RDR)
1286 (HsLit (HsString (mkFastString ")")))))))
1288 parenify e@(HsVar _) = e
1289 parenify e = HsPar e
1291 -- genOpApp wraps brackets round the operator application, so that the
1292 -- renamer won't subsequently try to re-associate it.
1293 -- For some reason the renamer doesn't reassociate it right, and I can't
1294 -- be bothered to find out why just now.
1296 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1300 qual_orig_name n = nameRdrName (getName n)
1301 varUnqual n = mkUnqual varName n
1303 zz_a_RDR = varUnqual FSLIT("_a")
1304 a_RDR = varUnqual FSLIT("a")
1305 b_RDR = varUnqual FSLIT("b")
1306 c_RDR = varUnqual FSLIT("c")
1307 d_RDR = varUnqual FSLIT("d")
1308 ah_RDR = varUnqual FSLIT("a#")
1309 bh_RDR = varUnqual FSLIT("b#")
1310 ch_RDR = varUnqual FSLIT("c#")
1311 dh_RDR = varUnqual FSLIT("d#")
1312 cmp_eq_RDR = varUnqual FSLIT("cmp_eq")
1313 rangeSize_RDR = varUnqual FSLIT("rangeSize")
1315 as_RDRs = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1316 bs_RDRs = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1317 cs_RDRs = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1319 zz_a_Expr = HsVar zz_a_RDR
1320 a_Expr = HsVar a_RDR
1321 b_Expr = HsVar b_RDR
1322 c_Expr = HsVar c_RDR
1323 d_Expr = HsVar d_RDR
1324 ltTag_Expr = HsVar ltTag_RDR
1325 eqTag_Expr = HsVar eqTag_RDR
1326 gtTag_Expr = HsVar gtTag_RDR
1327 false_Expr = HsVar false_RDR
1328 true_Expr = HsVar true_RDR
1330 getTag_Expr = HsVar getTag_RDR
1331 tagToEnum_Expr = HsVar tagToEnumH_RDR
1332 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1335 zz_a_Pat = VarPatIn zz_a_RDR
1336 a_Pat = VarPatIn a_RDR
1337 b_Pat = VarPatIn b_RDR
1338 c_Pat = VarPatIn c_RDR
1339 d_Pat = VarPatIn d_RDR
1341 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1343 con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1344 tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1345 maxtag_RDR tycon = varUnqual (mkFastString ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))