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 ( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..),
30 Match(..), GRHSs(..), Stmt(..), HsLit(..),
31 HsBinds(..), HsType(..), HsStmtContext(..),
32 unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
35 import RdrName ( RdrName, mkUnqual, nameRdrName, getRdrName )
36 import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
37 import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
41 import FieldLabel ( fieldLabelName )
42 import DataCon ( isNullaryDataCon, dataConTag,
43 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
46 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
47 occNameUserString, varName,
49 isDataSymOcc, isSymOcc
52 import HscTypes ( FixityEnv, lookupFixity )
53 import PrelNames -- Lots of Names
54 import PrimOp -- Lots of Names
55 import SrcLoc ( generatedSrcLoc, SrcLoc )
56 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
57 maybeTyConSingleCon, tyConFamilySize
59 import TcType ( isUnLiftedType, tcEqType, Type )
60 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
61 floatPrimTy, doublePrimTy
63 import Util ( zipWithEqual, isSingleton,
64 zipWith3Equal, nOfThem, zipEqual )
65 import Panic ( panic, assertPanic )
66 import Char ( ord, isAlpha )
68 import List ( partition, intersperse )
73 %************************************************************************
75 \subsection{Generating code, by derivable class}
77 %************************************************************************
79 %************************************************************************
81 \subsubsection{Generating @Eq@ instance declarations}
83 %************************************************************************
85 Here are the heuristics for the code we generate for @Eq@:
88 Let's assume we have a data type with some (possibly zero) nullary
89 data constructors and some ordinary, non-nullary ones (the rest,
90 also possibly zero of them). Here's an example, with both \tr{N}ullary
91 and \tr{O}rdinary data cons.
93 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
97 For the ordinary constructors (if any), we emit clauses to do The
101 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
102 (==) (O2 a1) (O2 a2) = a1 == a2
103 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
106 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
107 \tr{a2} are \tr{Float#}s, then we have to generate
109 case (a1 `eqFloat#` a2) of
112 for that particular test.
115 If there are any nullary constructors, we emit a catch-all clause of
119 (==) a b = case (con2tag_Foo a) of { a# ->
120 case (con2tag_Foo b) of { b# ->
121 case (a# ==# b#) of {
126 If there aren't any nullary constructors, we emit a simpler
133 For the @(/=)@ method, we normally just use the default method.
135 If the type is an enumeration type, we could/may/should? generate
136 special code that calls @con2tag_Foo@, much like for @(==)@ shown
140 We thought about doing this: If we're also deriving @Ord@ for this
143 instance ... Eq (Foo ...) where
144 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
145 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
147 However, that requires that \tr{Ord <whatever>} was put in the context
148 for the instance decl, which it probably wasn't, so the decls
149 produced don't get through the typechecker.
153 deriveEq :: RdrName -- Class
154 -> RdrName -- Type constructor
155 -> [ (RdrName, [RdrType]) ] -- Constructors
156 -> (RdrContext, -- Context for the inst decl
157 [RdrBind], -- Binds in the inst decl
158 [RdrBind]) -- Extra value bindings outside
160 deriveEq clas tycon constrs
161 = (context, [eq_bind, ne_bind], [])
163 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
166 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
167 is_nullary (_, args) = null args
170 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
174 tycon_loc = getSrcLoc tycon
175 (nullary_cons, nonnullary_cons)
176 | isNewTyCon tycon = ([], tyConDataCons tycon)
177 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
180 = if (null nullary_cons) then
181 case maybeTyConSingleCon tycon of
183 Nothing -> -- if cons don't match, then False
184 [([wildPat, wildPat], false_Expr)]
185 else -- calc. and compare the tags
187 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
188 (genOpApp (HsVar ah_RDR) eqInt_RDR (HsVar bh_RDR)))]
190 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
192 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
193 HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR])))
195 ------------------------------------------------------------------
198 con1_pat = mkConPat data_con_RDR as_needed
199 con2_pat = mkConPat data_con_RDR bs_needed
201 data_con_RDR = getRdrName data_con
202 con_arity = length tys_needed
203 as_needed = take con_arity as_RDRs
204 bs_needed = take con_arity bs_RDRs
205 tys_needed = dataConOrigArgTys data_con
207 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
209 nested_eq_expr [] [] [] = true_Expr
210 nested_eq_expr tys as bs
211 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
213 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
216 %************************************************************************
218 \subsubsection{Generating @Ord@ instance declarations}
220 %************************************************************************
222 For a derived @Ord@, we concentrate our attentions on @compare@
224 compare :: a -> a -> Ordering
225 data Ordering = LT | EQ | GT deriving ()
228 We will use the same example data type as above:
230 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
235 We do all the other @Ord@ methods with calls to @compare@:
237 instance ... (Ord <wurble> <wurble>) where
238 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
239 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
240 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
241 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
243 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
244 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
246 -- compare to come...
250 @compare@ always has two parts. First, we use the compared
251 data-constructors' tags to deal with the case of different
254 compare a b = case (con2tag_Foo a) of { a# ->
255 case (con2tag_Foo b) of { b# ->
256 case (a# ==# b#) of {
258 False -> case (a# <# b#) of
263 cmp_eq = ... to come ...
267 We are only left with the ``help'' function @cmp_eq@, to deal with
268 comparing data constructors with the same tag.
270 For the ordinary constructors (if any), we emit the sorta-obvious
271 compare-style stuff; for our example:
273 cmp_eq (O1 a1 b1) (O1 a2 b2)
274 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
276 cmp_eq (O2 a1) (O2 a2)
279 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
280 = case (compare a1 a2) of {
283 EQ -> case compare b1 b2 of {
291 Again, we must be careful about unlifted comparisons. For example,
292 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
296 cmp_eq lt eq gt (O2 a1) (O2 a2)
298 -- or maybe the unfolded equivalent
302 For the remaining nullary constructors, we already know that the
309 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
313 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
316 = compare -- `AndMonoBinds` compare
317 -- The default declaration in PrelBase handles this
319 tycon_loc = getSrcLoc tycon
320 --------------------------------------------------------------------
321 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
322 [a_Pat, b_Pat] [cmp_eq] compare_rhs
324 | single_con_type = cmp_eq_Expr a_Expr b_Expr
326 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
327 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
328 (cmp_eq_Expr a_Expr b_Expr) -- True case
329 -- False case; they aren't equal
330 -- So we need to do a less-than comparison on the tags
331 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
333 tycon_data_cons = tyConDataCons tycon
334 single_con_type = isSingleton tycon_data_cons
335 (nullary_cons, nonnullary_cons)
336 | isNewTyCon tycon = ([], tyConDataCons tycon)
337 | otherwise = partition isNullaryDataCon tycon_data_cons
339 cmp_eq = mk_FunMonoBind tycon_loc cmp_eq_RDR cmp_eq_match
341 | isEnumerationTyCon tycon
342 -- We know the tags are equal, so if it's an enumeration TyCon,
343 -- then there is nothing left to do
344 -- Catch this specially to avoid warnings
345 -- about overlapping patterns from the desugarer,
346 -- and to avoid unnecessary pattern-matching
347 = [([wildPat,wildPat], eqTag_Expr)]
349 = map pats_etc nonnullary_cons ++
350 (if single_con_type then -- Omit wildcards when there's just one
351 [] -- constructor, to silence desugarer
353 [([wildPat, wildPat], default_rhs)])
357 = ([con1_pat, con2_pat],
358 nested_compare_expr tys_needed as_needed bs_needed)
360 con1_pat = mkConPat data_con_RDR as_needed
361 con2_pat = mkConPat data_con_RDR bs_needed
363 data_con_RDR = getRdrName data_con
364 con_arity = length tys_needed
365 as_needed = take con_arity as_RDRs
366 bs_needed = take con_arity bs_RDRs
367 tys_needed = dataConOrigArgTys data_con
369 nested_compare_expr [ty] [a] [b]
370 = careful_compare_Case ty eqTag_Expr (HsVar a) (HsVar b)
372 nested_compare_expr (ty:tys) (a:as) (b:bs)
373 = let eq_expr = nested_compare_expr tys as bs
374 in careful_compare_Case ty eq_expr (HsVar a) (HsVar b)
376 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
377 -- inexhaustive patterns
378 | otherwise = eqTag_Expr -- Some nullary constructors;
379 -- Tags are equal, no args => return EQ
382 %************************************************************************
384 \subsubsection{Generating @Enum@ instance declarations}
386 %************************************************************************
388 @Enum@ can only be derived for enumeration types. For a type
390 data Foo ... = N1 | N2 | ... | Nn
393 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
394 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
397 instance ... Enum (Foo ...) where
398 succ x = toEnum (1 + fromEnum x)
399 pred x = toEnum (fromEnum x - 1)
401 toEnum i = tag2con_Foo i
403 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
407 = case con2tag_Foo a of
408 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
411 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
415 = case con2tag_Foo a of { a# ->
416 case con2tag_Foo b of { b# ->
417 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
421 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
424 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
427 = succ_enum `AndMonoBinds`
428 pred_enum `AndMonoBinds`
429 to_enum `AndMonoBinds`
430 enum_from `AndMonoBinds`
431 enum_from_then `AndMonoBinds`
434 tycon_loc = getSrcLoc tycon
435 occ_nm = getOccString tycon
438 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
439 untag_Expr tycon [(a_RDR, ah_RDR)] $
440 HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon),
441 mkHsVarApps mkInt_RDR [ah_RDR]])
442 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
443 (HsApp (HsVar (tag2con_RDR tycon))
444 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
449 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
450 untag_Expr tycon [(a_RDR, ah_RDR)] $
451 HsIf (mkHsApps eq_RDR [mkHsIntLit 0,
452 mkHsVarApps mkInt_RDR [ah_RDR]])
453 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
454 (HsApp (HsVar (tag2con_RDR tycon))
455 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
456 HsLit (HsInt (-1))]))
460 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
461 HsIf (mkHsApps and_RDR
462 [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0],
463 mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]])
464 (mkHsVarApps (tag2con_RDR tycon) [a_RDR])
465 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
469 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
470 untag_Expr tycon [(a_RDR, ah_RDR)] $
472 [HsVar (tag2con_RDR tycon),
473 HsPar (enum_from_to_Expr
474 (mkHsVarApps mkInt_RDR [ah_RDR])
475 (HsVar (maxtag_RDR tycon)))]
478 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
479 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
480 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
481 HsPar (enum_from_then_to_Expr
482 (mkHsVarApps mkInt_RDR [ah_RDR])
483 (mkHsVarApps mkInt_RDR [bh_RDR])
484 (HsIf (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
485 mkHsVarApps mkInt_RDR [bh_RDR]])
487 (HsVar (maxtag_RDR tycon))
491 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
492 untag_Expr tycon [(a_RDR, ah_RDR)] $
493 (mkHsVarApps mkInt_RDR [ah_RDR])
496 %************************************************************************
498 \subsubsection{Generating @Bounded@ instance declarations}
500 %************************************************************************
503 gen_Bounded_binds tycon
504 = if isEnumerationTyCon tycon then
505 min_bound_enum `AndMonoBinds` max_bound_enum
507 ASSERT(isSingleton data_cons)
508 min_bound_1con `AndMonoBinds` max_bound_1con
510 data_cons = tyConDataCons tycon
511 tycon_loc = getSrcLoc tycon
513 ----- enum-flavored: ---------------------------
514 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
515 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
517 data_con_1 = head data_cons
518 data_con_N = last data_cons
519 data_con_1_RDR = getRdrName data_con_1
520 data_con_N_RDR = getRdrName data_con_N
522 ----- single-constructor-flavored: -------------
523 arity = dataConSourceArity data_con_1
525 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
526 mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
527 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
528 mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
531 %************************************************************************
533 \subsubsection{Generating @Ix@ instance declarations}
535 %************************************************************************
537 Deriving @Ix@ is only possible for enumeration types and
538 single-constructor types. We deal with them in turn.
540 For an enumeration type, e.g.,
542 data Foo ... = N1 | N2 | ... | Nn
544 things go not too differently from @Enum@:
546 instance ... Ix (Foo ...) where
548 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
552 = case (con2tag_Foo a) of { a# ->
553 case (con2tag_Foo b) of { b# ->
554 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
559 then case (con2tag_Foo d -# con2tag_Foo a) of
561 else error "Ix.Foo.index: out of range"
565 p_tag = con2tag_Foo c
567 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
571 = case (con2tag_Foo a) of { a_tag ->
572 case (con2tag_Foo b) of { b_tag ->
573 case (con2tag_Foo c) of { c_tag ->
574 if (c_tag >=# a_tag) then
580 (modulo suitable case-ification to handle the unlifted tags)
582 For a single-constructor type (NB: this includes all tuples), e.g.,
584 data Foo ... = MkFoo a b Int Double c c
586 we follow the scheme given in Figure~19 of the Haskell~1.2 report
590 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
593 = if isEnumerationTyCon tycon
597 tycon_str = getOccString tycon
598 tycon_loc = getSrcLoc tycon
600 --------------------------------------------------------------
601 enum_ixes = enum_range `AndMonoBinds`
602 enum_index `AndMonoBinds` enum_inRange
605 = mk_easy_FunMonoBind tycon_loc range_RDR
606 [TuplePat [a_Pat, b_Pat] Boxed] [] $
607 untag_Expr tycon [(a_RDR, ah_RDR)] $
608 untag_Expr tycon [(b_RDR, bh_RDR)] $
609 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
610 HsPar (enum_from_to_Expr
611 (mkHsVarApps mkInt_RDR [ah_RDR])
612 (mkHsVarApps mkInt_RDR [bh_RDR]))
615 = mk_easy_FunMonoBind tycon_loc index_RDR
616 [AsPat c_RDR (TuplePat [a_Pat, wildPat] Boxed),
618 HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
619 untag_Expr tycon [(a_RDR, ah_RDR)] (
620 untag_Expr tycon [(d_RDR, dh_RDR)] (
622 rhs = mkHsVarApps mkInt_RDR [c_RDR]
625 (genOpApp (HsVar dh_RDR) minusInt_RDR (HsVar ah_RDR))
626 [mkSimpleMatch [VarPat c_RDR] rhs placeHolderType tycon_loc]
630 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
635 = mk_easy_FunMonoBind tycon_loc inRange_RDR
636 [TuplePat [a_Pat, b_Pat] Boxed, c_Pat] [] (
637 untag_Expr tycon [(a_RDR, ah_RDR)] (
638 untag_Expr tycon [(b_RDR, bh_RDR)] (
639 untag_Expr tycon [(c_RDR, ch_RDR)] (
640 HsIf (genOpApp (HsVar ch_RDR) geInt_RDR (HsVar ah_RDR)) (
641 (genOpApp (HsVar ch_RDR) leInt_RDR (HsVar bh_RDR))
646 --------------------------------------------------------------
648 = single_con_range `AndMonoBinds`
649 single_con_index `AndMonoBinds`
653 = case maybeTyConSingleCon tycon of -- just checking...
654 Nothing -> panic "get_Ix_binds"
655 Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
656 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
660 con_arity = dataConSourceArity data_con
661 data_con_RDR = getRdrName data_con
663 as_needed = take con_arity as_RDRs
664 bs_needed = take con_arity bs_RDRs
665 cs_needed = take con_arity cs_RDRs
667 con_pat xs = mkConPat data_con_RDR xs
668 con_expr = mkHsVarApps data_con_RDR cs_needed
670 --------------------------------------------------------------
672 = mk_easy_FunMonoBind tycon_loc range_RDR
673 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed] [] $
674 mkHsDo ListComp stmts tycon_loc
676 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
678 [ResultStmt con_expr tycon_loc]
680 mk_qual a b c = BindStmt (VarPat c)
681 (HsApp (HsVar range_RDR)
682 (ExplicitTuple [HsVar a, HsVar b] Boxed))
687 = mk_easy_FunMonoBind tycon_loc index_RDR
688 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
689 con_pat cs_needed] [range_size] (
690 foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
692 mk_index multiply_by (l, u, i)
694 (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,
698 (HsApp (HsVar rangeSize_RDR)
699 (ExplicitTuple [HsVar l, HsVar u] Boxed))
700 ) times_RDR multiply_by
704 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
705 [TuplePat [a_Pat, b_Pat] Boxed] [] (
707 (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
709 ) plus_RDR (mkHsIntLit 1))
713 = mk_easy_FunMonoBind tycon_loc inRange_RDR
714 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
717 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
719 in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
723 %************************************************************************
725 \subsubsection{Generating @Read@ instance declarations}
727 %************************************************************************
737 instance Read T where
741 do x <- ReadP.step Read.readPrec
742 Symbol "%%" <- Lex.lex
743 y <- ReadP.step Read.readPrec
747 do Ident "T1" <- Lex.lex
749 Ident "f1" <- Lex.lex
751 x <- ReadP.reset Read.readPrec
753 return (T1 { f1 = x }))
756 do Ident "T2" <- Lex.lexP
757 x <- ReadP.step Read.readPrec
761 readListPrec = readListPrecDefault
762 readList = readListDefault
766 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
768 gen_Read_binds get_fixity tycon
769 = read_prec `AndMonoBinds` default_binds
771 -----------------------------------------------------------------------
773 = mk_easy_FunMonoBind loc readList_RDR [] [] (HsVar readListDefault_RDR)
775 mk_easy_FunMonoBind loc readListPrec_RDR [] [] (HsVar readListPrecDefault_RDR)
776 -----------------------------------------------------------------------
778 loc = getSrcLoc tycon
779 data_cons = tyConDataCons tycon
780 (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
782 read_prec = mk_easy_FunMonoBind loc readPrec_RDR [] []
783 (HsApp (HsVar parens_RDR) read_cons)
785 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
786 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
789 = case nullary_cons of
791 [con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
792 result_stmt con []] loc]
793 _ -> [HsApp (HsVar choose_RDR)
794 (ExplicitList placeHolderType (map mk_pair nullary_cons))]
796 mk_pair con = ExplicitTuple [HsLit (data_con_str con),
797 HsApp (HsVar returnM_RDR) (HsVar (getRdrName con))]
800 read_non_nullary_con data_con
801 = mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc]
803 stmts | is_infix = infix_stmts
804 | length labels > 0 = lbl_stmts
805 | otherwise = prefix_stmts
807 prefix_stmts -- T a b c
808 = [bindLex (ident_pat (data_con_str data_con))]
809 ++ map read_arg as_needed
810 ++ [result_stmt data_con as_needed]
812 infix_stmts -- a %% b
814 bindLex (symbol_pat (data_con_str data_con)),
816 result_stmt data_con [a1,a2]]
818 lbl_stmts -- T { f1 = a, f2 = b }
819 = [bindLex (ident_pat (data_con_str data_con)),
821 ++ concat (intersperse [read_punc ","] field_stmts)
822 ++ [read_punc "}", result_stmt data_con as_needed]
824 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
826 con_arity = dataConSourceArity data_con
827 nullary_con = con_arity == 0
828 labels = dataConFieldLabels data_con
829 lab_fields = length labels
830 dc_nm = getName data_con
831 is_infix = isDataSymOcc (getOccName dc_nm)
832 as_needed = take con_arity as_RDRs
833 (a1:a2:_) = as_needed
834 prec = getPrec is_infix get_fixity dc_nm
836 ------------------------------------------------------------------------
838 ------------------------------------------------------------------------
839 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
840 bindLex pat = BindStmt pat (HsVar lexP_RDR) loc
841 result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
842 con_app c as = mkHsVarApps (getRdrName c) as
844 punc_pat s = ConPatIn punc_RDR (PrefixCon [LitPat (mkHsString s)]) -- Punc 'c'
845 ident_pat s = ConPatIn ident_RDR (PrefixCon [LitPat s]) -- Ident "foo"
846 symbol_pat s = ConPatIn symbol_RDR (PrefixCon [LitPat s]) -- Symbol ">>"
848 data_con_str con = mkHsString (occNameUserString (getOccName con))
850 read_punc c = bindLex (punc_pat c)
851 read_arg a = BindStmt (VarPat a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
853 read_field lbl a = read_lbl lbl ++
855 BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
857 -- When reading field labels we might encounter
861 read_lbl lbl | isAlpha (head lbl_str)
862 = [bindLex (ident_pat lbl_lit)]
865 bindLex (symbol_pat lbl_lit),
868 lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
869 lbl_lit = mkHsString lbl_str
873 %************************************************************************
875 \subsubsection{Generating @Show@ instance declarations}
877 %************************************************************************
883 data Tree a = Leaf a | Tree a :^: Tree a
885 instance (Show a) => Show (Tree a) where
887 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
889 showStr = showString "Leaf " . showsPrec (app_prec+1) m
891 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
893 showStr = showsPrec (up_prec+1) u .
895 showsPrec (up_prec+1) v
896 -- Note: right-associativity of :^: ignored
898 up_prec = 5 -- Precedence of :^:
899 app_prec = 10 -- Application has precedence one more than
900 -- the most tightly-binding operator
903 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
905 gen_Show_binds get_fixity tycon
906 = shows_prec `AndMonoBinds` show_list
908 tycon_loc = getSrcLoc tycon
909 -----------------------------------------------------------------------
910 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
911 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
912 -----------------------------------------------------------------------
913 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
916 | nullary_con = -- skip the showParen junk...
917 ASSERT(null bs_needed)
918 ([wildPat, con_pat], mk_showString_app con_str)
921 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one))))
922 (HsPar (nested_compose_Expr show_thingies)))
924 data_con_RDR = getRdrName data_con
925 con_arity = dataConSourceArity data_con
926 bs_needed = take con_arity bs_RDRs
927 con_pat = mkConPat data_con_RDR bs_needed
928 nullary_con = con_arity == 0
929 labels = dataConFieldLabels data_con
930 lab_fields = length labels
931 record_syntax = lab_fields > 0
933 dc_nm = getName data_con
934 dc_occ_nm = getOccName data_con
935 con_str = occNameUserString dc_occ_nm
938 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
939 | record_syntax = mk_showString_app (con_str ++ " {") :
940 show_record_args ++ [mk_showString_app "}"]
941 | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
943 show_label l = mk_showString_app (the_name ++ " = ")
944 -- Note the spaces around the "=" sign. If we don't have them
945 -- then we get Foo { x=-1 } and the "=-" parses as a single
946 -- lexeme. Only the space after the '=' is necessary, but
947 -- it seems tidier to have them both sides.
949 occ_nm = getOccName (fieldLabelName l)
950 nm = occNameUserString occ_nm
952 is_op = isSymOcc occ_nm -- Legal, but rare.
954 | is_op = '(':nm ++ ")"
957 show_args = [ mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec), HsVar b]
959 (show_arg1:show_arg2:_) = show_args
960 show_prefix_args = intersperse (HsVar showSpace_RDR) show_args
962 -- Assumption for record syntax: no of fields == no of labelled fields
963 -- (and in same order)
964 show_record_args = concat $
965 intersperse [mk_showString_app ", "] $
966 [ [show_label lbl, arg]
967 | (lbl,arg) <- zipEqual "gen_Show_binds"
971 is_infix = isDataSymOcc dc_occ_nm
972 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
973 arg_prec | record_syntax = 0 -- Record fields don't need parens
974 | otherwise = con_prec_plus_one
976 mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str))
980 getPrec :: Bool -> FixityEnv -> Name -> Integer
981 getPrec is_infix get_fixity nm
982 | not is_infix = appPrecedence
983 | otherwise = getPrecedence get_fixity nm
985 appPrecedence :: Integer
986 appPrecedence = fromIntegral maxPrecedence + 1
987 -- One more than the precedence of the most
988 -- tightly-binding operator
990 getPrecedence :: FixityEnv -> Name -> Integer
991 getPrecedence get_fixity nm
992 = case lookupFixity get_fixity nm of
993 Fixity x _ -> fromIntegral x
995 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
996 isLRAssoc get_fixity nm =
997 case lookupFixity get_fixity nm of
998 Fixity _ InfixN -> (False, False)
999 Fixity _ InfixR -> (False, True)
1000 Fixity _ InfixL -> (True, False)
1004 %************************************************************************
1006 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1008 %************************************************************************
1013 con2tag_Foo :: Foo ... -> Int#
1014 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1015 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1018 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1023 = GenCon2Tag | GenTag2Con | GenMaxTag
1025 gen_tag_n_con_monobind
1026 :: (RdrName, -- (proto)Name for the thing in question
1027 TyCon, -- tycon in question
1031 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1032 | lots_of_constructors
1033 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1034 [([VarPat a_RDR], HsApp getTag_Expr a_Expr)]
1037 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1040 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1042 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1044 = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1046 pat = ConPatIn var_RDR (PrefixCon (nOfThem (dataConSourceArity var) wildPat))
1047 var_RDR = getRdrName var
1049 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1050 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1051 [([mkConPat mkInt_RDR [a_RDR]],
1052 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1053 (HsTyVar (getRdrName tycon)))]
1055 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1056 = mk_easy_FunMonoBind (getSrcLoc tycon)
1057 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1059 max_tag = case (tyConDataCons tycon) of
1060 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1064 %************************************************************************
1066 \subsection{Utility bits for generating bindings}
1068 %************************************************************************
1070 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1072 fun pat1 pat2 ... patN = expr where binds
1075 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1076 multi-clause definitions; it generates:
1078 fun p1a p1b ... p1N = e1
1079 fun p2a p2b ... p2N = e2
1081 fun pMa pMb ... pMN = eM
1085 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1086 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1089 mk_easy_FunMonoBind loc fun pats binds expr
1090 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1092 mk_easy_Match loc pats binds expr
1093 = mk_match loc pats expr (mkMonoBind Recursive (andMonoBindList binds))
1094 -- The renamer expects everything in its input to be a
1095 -- "recursive" MonoBinds, and it is its job to sort things out
1098 mk_FunMonoBind :: SrcLoc -> RdrName
1099 -> [([RdrNamePat], RdrNameHsExpr)]
1102 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1103 mk_FunMonoBind loc fun pats_and_exprs
1104 = FunMonoBind fun False{-not infix-}
1105 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1108 mk_match loc pats expr binds
1109 = Match (map paren pats) Nothing
1110 (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1112 paren p@(VarPat _) = p
1113 paren other_p = ParPat other_p
1117 mkHsApps f xs = foldl HsApp (HsVar f) xs
1118 mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs)
1120 mkHsIntLit n = HsLit (HsInt n)
1121 mkHsString s = HsString (mkFastString s)
1122 mkHsChar c = HsChar (ord c)
1124 mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars))
1125 mkNullaryConPat con = ConPatIn con (PrefixCon [])
1128 ToDo: Better SrcLocs.
1132 RdrNameHsExpr -- What to do for equality
1133 -> RdrNameHsExpr -> RdrNameHsExpr
1135 careful_compare_Case :: -- checks for primitive types...
1137 -> RdrNameHsExpr -- What to do for equality
1138 -> RdrNameHsExpr -> RdrNameHsExpr
1141 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1142 -- Was: compare_gen_Case cmp_eq_RDR
1144 compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR
1145 = HsApp (HsApp (HsVar compare_RDR) a) b -- Simple case
1146 compare_gen_Case eq a b -- General case
1147 = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-}
1148 [mkSimpleMatch [mkNullaryConPat ltTag_RDR] ltTag_Expr placeHolderType generatedSrcLoc,
1149 mkSimpleMatch [mkNullaryConPat eqTag_RDR] eq placeHolderType generatedSrcLoc,
1150 mkSimpleMatch [mkNullaryConPat gtTag_RDR] gtTag_Expr placeHolderType generatedSrcLoc]
1153 careful_compare_Case ty eq a b
1154 | not (isUnLiftedType ty) =
1155 compare_gen_Case eq a b
1157 -- we have to do something special for primitive things...
1158 HsIf (genOpApp a relevant_eq_op b)
1160 (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc)
1163 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1164 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1166 assoc_ty_id tyids ty
1167 = if null res then panic "assoc_ty"
1170 res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
1173 [(charPrimTy, eqChar_RDR)
1174 ,(intPrimTy, eqInt_RDR)
1175 ,(wordPrimTy, eqWord_RDR)
1176 ,(addrPrimTy, eqAddr_RDR)
1177 ,(floatPrimTy, eqFloat_RDR)
1178 ,(doublePrimTy, eqDouble_RDR)
1182 [(charPrimTy, ltChar_RDR)
1183 ,(intPrimTy, ltInt_RDR)
1184 ,(wordPrimTy, ltWord_RDR)
1185 ,(addrPrimTy, ltAddr_RDR)
1186 ,(floatPrimTy, ltFloat_RDR)
1187 ,(doublePrimTy, ltDouble_RDR)
1190 -----------------------------------------------------------------------
1192 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1194 and_Expr a b = genOpApp a and_RDR b
1195 append_Expr a b = genOpApp a append_RDR b
1197 -----------------------------------------------------------------------
1199 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1200 eq_Expr ty a b = genOpApp a eq_op b
1203 | not (isUnLiftedType ty) = eq_RDR
1205 -- we have to do something special for primitive things...
1206 assoc_ty_id eq_op_tbl ty
1211 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1212 untag_Expr tycon [] expr = expr
1213 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1214 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1215 [mkSimpleMatch [VarPat put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
1218 cmp_tags_Expr :: RdrName -- Comparison op
1219 -> RdrName -> RdrName -- Things to compare
1220 -> RdrNameHsExpr -- What to return if true
1221 -> RdrNameHsExpr -- What to return if false
1224 cmp_tags_Expr op a b true_case false_case
1225 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1228 :: RdrNameHsExpr -> RdrNameHsExpr
1230 enum_from_then_to_Expr
1231 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1234 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1235 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1238 :: RdrNameHsExpr -> RdrNameHsExpr
1241 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1243 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1245 nested_compose_Expr [e] = parenify e
1246 nested_compose_Expr (e:es)
1247 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1249 -- impossible_Expr is used in case RHSs that should never happen.
1250 -- We generate these to keep the desugarer from complaining that they *might* happen!
1251 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv")))
1253 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1254 -- method. It is currently only used by Enum.{succ,pred}
1255 illegal_Expr meth tp msg =
1256 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg))))
1258 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1259 -- to include the value of a_RDR in the error string.
1260 illegal_toEnum_tag tp maxtag =
1261 HsApp (HsVar error_RDR)
1262 (HsApp (HsApp (HsVar append_RDR)
1263 (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag (")))))
1264 (HsApp (HsApp (HsApp
1265 (HsVar showsPrec_RDR)
1270 (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,"))))
1271 (HsApp (HsApp (HsApp
1272 (HsVar showsPrec_RDR)
1275 (HsLit (HsString (mkFastString ")")))))))
1277 parenify e@(HsVar _) = e
1278 parenify e = HsPar e
1280 -- genOpApp wraps brackets round the operator application, so that the
1281 -- renamer won't subsequently try to re-associate it.
1282 -- For some reason the renamer doesn't reassociate it right, and I can't
1283 -- be bothered to find out why just now.
1285 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1289 varUnqual n = mkUnqual OccName.varName n
1291 zz_a_RDR = varUnqual FSLIT("_a")
1292 a_RDR = varUnqual FSLIT("a")
1293 b_RDR = varUnqual FSLIT("b")
1294 c_RDR = varUnqual FSLIT("c")
1295 d_RDR = varUnqual FSLIT("d")
1296 ah_RDR = varUnqual FSLIT("a#")
1297 bh_RDR = varUnqual FSLIT("b#")
1298 ch_RDR = varUnqual FSLIT("c#")
1299 dh_RDR = varUnqual FSLIT("d#")
1300 cmp_eq_RDR = varUnqual FSLIT("cmp_eq")
1301 rangeSize_RDR = varUnqual FSLIT("rangeSize")
1303 as_RDRs = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1304 bs_RDRs = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1305 cs_RDRs = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1307 zz_a_Expr = HsVar zz_a_RDR
1308 a_Expr = HsVar a_RDR
1309 b_Expr = HsVar b_RDR
1310 c_Expr = HsVar c_RDR
1311 d_Expr = HsVar d_RDR
1312 ltTag_Expr = HsVar ltTag_RDR
1313 eqTag_Expr = HsVar eqTag_RDR
1314 gtTag_Expr = HsVar gtTag_RDR
1315 false_Expr = HsVar false_RDR
1316 true_Expr = HsVar true_RDR
1318 getTag_Expr = HsVar getTag_RDR
1319 tagToEnum_Expr = HsVar tagToEnum_RDR
1320 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1322 wildPat = WildPat placeHolderType
1323 zz_a_Pat = VarPat zz_a_RDR
1324 a_Pat = VarPat a_RDR
1325 b_Pat = VarPat b_RDR
1326 c_Pat = VarPat c_RDR
1327 d_Pat = VarPat d_RDR
1329 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1331 con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1332 tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1333 maxtag_RDR tycon = varUnqual (mkFastString ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))
1336 RdrNames for PrimOps. Can't be done in PrelNames, because PrimOp imports
1337 PrelNames, so PrelNames can't import PrimOp.
1340 minusInt_RDR = nameRdrName minusIntName
1341 eqInt_RDR = nameRdrName eqIntName
1342 ltInt_RDR = nameRdrName ltIntName
1343 geInt_RDR = nameRdrName geIntName
1344 leInt_RDR = nameRdrName leIntName
1345 eqChar_RDR = nameRdrName eqCharName
1346 eqWord_RDR = nameRdrName eqWordName
1347 eqAddr_RDR = nameRdrName eqAddrName
1348 eqFloat_RDR = nameRdrName eqFloatName
1349 eqDouble_RDR = nameRdrName eqDoubleName
1350 ltChar_RDR = nameRdrName ltCharName
1351 ltWord_RDR = nameRdrName ltWordName
1352 ltAddr_RDR = nameRdrName ltAddrName
1353 ltFloat_RDR = nameRdrName ltFloatName
1354 ltDouble_RDR = nameRdrName ltDoubleName
1355 tagToEnum_RDR = nameRdrName tagToEnumName