X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=d216ae6409b74f1ea6de72ba6c3a5298f4f6ed52;hb=778b2c6bdbabf2c9f394f0ca2b76b55a7123aa5f;hp=b043f7dc5bec2f1248df4a077b42191ea13f7ba0;hpb=2d74238376e28afe2585674d78391ef0e8092ea4;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index b043f7d..d216ae6 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -29,20 +29,24 @@ module TcGenDeriv ( import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), Match(..), GRHSs(..), Stmt(..), HsLit(..), HsBinds(..), StmtCtxt(..), HsType(..), - unguardedRHS, mkSimpleMatch + unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList ) import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) import RdrName ( RdrName, mkSrcUnqual ) -import RnMonad ( Fixities ) -import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) ) +import RnMonad ( FixityEnv, lookupFixity ) +import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) + , maxPrecedence, defaultFixity + , Boxity(..) + ) import FieldLabel ( fieldLabelName ) import DataCon ( isNullaryDataCon, dataConTag, - dataConRawArgTys, fIRST_TAG, + dataConOrigArgTys, dataConSourceArity, fIRST_TAG, DataCon, ConTag, dataConFieldLabels ) import Name ( getOccString, getOccName, getSrcLoc, occNameString, occNameUserString, nameRdrName, varName, - OccName, Name, NamedThing(..), NameSpace + OccName, Name, NamedThing(..), NameSpace, + isDataSymOcc, isSymOcc ) import PrimOp ( PrimOp(..) ) @@ -56,11 +60,16 @@ import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) import Util ( mapAccumL, zipEqual, zipWithEqual, - zipWith3Equal, nOfThem ) + zipWith3Equal, nOfThem, assocDefault ) import Panic ( panic, assertPanic ) -import Maybes ( maybeToBool, assocMaybe ) +import Maybes ( maybeToBool ) import Constants import List ( partition, intersperse ) +import Char ( isAlpha ) + +#if __GLASGOW_HASKELL__ >= 404 +import GlaExts ( fromInt ) +#endif \end{code} %************************************************************************ @@ -174,7 +183,7 @@ gen_Eq_binds tycon case maybeTyConSingleCon tycon of Just _ -> [] Nothing -> -- if cons don't match, then False - [([a_Pat, b_Pat], false_Expr)] + [([wildPat, wildPat], false_Expr)] else -- calc. and compare the tags [([a_Pat, b_Pat], untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] @@ -195,7 +204,7 @@ gen_Eq_binds tycon con_arity = length tys_needed as_needed = take con_arity as_RDRs bs_needed = take con_arity bs_RDRs - tys_needed = dataConRawArgTys data_con + tys_needed = dataConOrigArgTys data_con in ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) where @@ -306,7 +315,8 @@ JJQC-30-Nov-1997 gen_Ord_binds :: TyCon -> RdrNameMonoBinds gen_Ord_binds tycon - = defaulted `AndMonoBinds` compare + = compare -- `AndMonoBinds` compare + -- The default declaration in PrelBase handles this where tycon_loc = getSrcLoc tycon -------------------------------------------------------------------- @@ -372,7 +382,7 @@ gen_Ord_binds tycon con_arity = length tys_needed as_needed = take con_arity as_RDRs bs_needed = take con_arity bs_RDRs - tys_needed = dataConRawArgTys data_con + tys_needed = dataConOrigArgTys data_con nested_compare_expr [ty] [a] [b] = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b) @@ -387,6 +397,8 @@ gen_Ord_binds tycon -- Tags are equal, no args => return EQ -------------------------------------------------------------------- +{- Not necessary: the default decls in PrelBase handle these + defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_] lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] ( @@ -402,6 +414,7 @@ max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] ( compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr) min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] ( compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr) +-} \end{code} %************************************************************************ @@ -553,7 +566,7 @@ gen_Bounded_binds tycon data_con_N_RDR = qual_orig_name data_con_N ----- single-constructor-flavored: ------------- - arity = argFieldCount data_con_1 + arity = dataConSourceArity data_con_1 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $ mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR) @@ -636,7 +649,7 @@ gen_Ix_binds tycon enum_range = mk_easy_FunMonoBind tycon_loc range_RDR - [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $ + [TuplePatIn [a_Pat, b_Pat] Boxed] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $ @@ -646,7 +659,7 @@ gen_Ix_binds tycon enum_index = mk_easy_FunMonoBind tycon_loc index_RDR - [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat] True{-boxed-}), + [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed), d_Pat] [] ( HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) ( untag_Expr tycon [(a_RDR, ah_RDR)] ( @@ -666,7 +679,7 @@ gen_Ix_binds tycon enum_inRange = mk_easy_FunMonoBind tycon_loc inRange_RDR - [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] ( + [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( @@ -685,12 +698,12 @@ gen_Ix_binds tycon data_con = case maybeTyConSingleCon tycon of -- just checking... Nothing -> panic "get_Ix_binds" - Just dc -> if (any isUnLiftedType (dataConRawArgTys dc)) then + Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str) else dc - con_arity = argFieldCount data_con + con_arity = dataConSourceArity data_con data_con_RDR = qual_orig_name data_con as_needed = take con_arity as_RDRs @@ -703,7 +716,7 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range = mk_easy_FunMonoBind tycon_loc range_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $ + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $ HsDo ListComp stmts tycon_loc where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -712,45 +725,45 @@ gen_Ix_binds tycon mk_qual a b c = BindStmt (VarPatIn c) (HsApp (HsVar range_RDR) - (ExplicitTuple [HsVar a, HsVar b] True)) + (ExplicitTuple [HsVar a, HsVar b] Boxed)) tycon_loc ---------------- single_con_index = mk_easy_FunMonoBind tycon_loc index_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True, + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] [range_size] ( foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed)) where mk_index multiply_by (l, u, i) = genOpApp ( (HsApp (HsApp (HsVar index_RDR) - (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i)) + (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i)) ) plus_RDR ( genOpApp ( (HsApp (HsVar rangeSize_RDR) - (ExplicitTuple [HsVar l, HsVar u] True)) + (ExplicitTuple [HsVar l, HsVar u] Boxed)) ) times_RDR multiply_by ) range_size = mk_easy_FunMonoBind tycon_loc rangeSize_RDR - [TuplePatIn [a_Pat, b_Pat] True] [] ( + [TuplePatIn [a_Pat, b_Pat] Boxed] [] ( genOpApp ( (HsApp (HsApp (HsVar index_RDR) - (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr) + (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr) ) plus_RDR (HsLit (HsInt 1))) ------------------ single_con_inRange = mk_easy_FunMonoBind tycon_loc inRange_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True, + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] [] ( foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)) where in_range a b c = HsApp (HsApp (HsVar inRange_RDR) - (ExplicitTuple [HsVar a, HsVar b] True)) + (ExplicitTuple [HsVar a, HsVar b] Boxed)) (HsVar c) \end{code} @@ -761,9 +774,9 @@ gen_Ix_binds tycon %************************************************************************ \begin{code} -gen_Read_binds :: Fixities -> TyCon -> RdrNameMonoBinds +gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds -gen_Read_binds fixities tycon +gen_Read_binds fixity_env tycon = reads_prec `AndMonoBinds` read_list where tycon_loc = getSrcLoc tycon @@ -776,7 +789,7 @@ gen_Read_binds fixities tycon read_con_comprehensions = map read_con (tyConDataCons tycon) in - mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] ( + mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] ( foldr1 append_Expr read_con_comprehensions ) where @@ -789,15 +802,15 @@ gen_Read_binds fixities tycon where data_con_RDR = qual_orig_name data_con data_con_str = occNameUserString (getOccName data_con) - con_arity = argFieldCount data_con + con_arity = dataConSourceArity data_con con_expr = mk_easy_App data_con_RDR as_needed nullary_con = con_arity == 0 labels = dataConFieldLabels data_con lab_fields = length labels dc_nm = getName data_con - is_infix = isInfixOccName data_con_str + is_infix = isDataSymOcc (getOccName dc_nm) - as_needed = take con_arity as_RDRs + as_needed = take con_arity as_RDRs bs_needed | is_infix = take (1 + con_arity) bs_RDRs | lab_fields == 0 = take con_arity bs_RDRs @@ -810,26 +823,38 @@ gen_Read_binds fixities tycon con_qual | not is_infix = BindStmt - (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] True) + (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed) (HsApp (HsVar lex_RDR) c_Expr) tycon_loc | otherwise = BindStmt - (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] True) + (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed) (HsApp (HsVar lex_RDR) (HsVar bs1)) tycon_loc str_qual str res draw_from = BindStmt - (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True) + (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed) (HsApp (HsVar lex_RDR) draw_from) tycon_loc - read_label f = [str_qual nm, str_qual "="] + str_qual_paren str res draw_from = + BindStmt + (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed) + (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from) + tycon_loc + + read_label f = [rd_lab, str_qual "="] -- There might be spaces between the label and '=' where - nm = occNameUserString (getOccName (fieldLabelName f)) + rd_lab + | is_op = str_qual_paren nm + | otherwise = str_qual nm + + occ_nm = getOccName (fieldLabelName f) + is_op = isSymOcc occ_nm + nm = occNameUserString occ_nm field_quals | is_infix = @@ -871,15 +896,15 @@ gen_Read_binds fixities tycon mk_read_qual p con_field res draw_from = BindStmt - (TuplePatIn [VarPatIn con_field, VarPatIn res] True) + (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed) (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from) tycon_loc result_expr = ExplicitTuple [con_expr, if null bs_needed then d_Expr - else HsVar (last bs_needed)] True + else HsVar (last bs_needed)] Boxed - [lp,rp] = getLRPrecs fixities dc_nm + [lp,rp] = getLRPrecs is_infix fixity_env dc_nm quals | is_infix = let (h:t) = field_quals in (h:con_qual:t) @@ -887,14 +912,16 @@ gen_Read_binds fixities tycon stmts = quals ++ [ReturnStmt result_expr] + {- + c.f. Figure 18 in Haskell 1.1 report. + -} paren_prec_limit - | not is_infix = 9 - | otherwise = getFixity fixities dc_nm + | not is_infix = fromInt maxPrecedence + | otherwise = getFixity fixity_env dc_nm read_paren_arg -- parens depend on precedence... | nullary_con = false_Expr -- it's optional. - | otherwise = HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit))) - + | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit))) \end{code} %************************************************************************ @@ -904,9 +931,9 @@ gen_Read_binds fixities tycon %************************************************************************ \begin{code} -gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds +gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds -gen_Show_binds fixs_assoc tycon +gen_Show_binds fixity_env tycon = shows_prec `AndMonoBinds` show_list where tycon_loc = getSrcLoc tycon @@ -919,36 +946,36 @@ gen_Show_binds fixs_assoc tycon pats_etc data_con | nullary_con = -- skip the showParen junk... ASSERT(null bs_needed) - ([a_Pat, con_pat], show_con) + ([wildPat, con_pat], show_con) | otherwise = ([a_Pat, con_pat], - showParen_Expr (HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))) + showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit)))) (HsPar (nested_compose_Expr show_thingies))) where data_con_RDR = qual_orig_name data_con - con_arity = argFieldCount data_con + con_arity = dataConSourceArity data_con bs_needed = take con_arity bs_RDRs con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed) nullary_con = con_arity == 0 labels = dataConFieldLabels data_con lab_fields = length labels - dc_occ_nm = occNameUserString (getOccName data_con) - dc_nm = getName data_con + dc_nm = getName data_con + dc_occ_nm = getOccName data_con + dc_occ_nm_str = occNameUserString dc_occ_nm - is_infix = isInfixOccName dc_occ_nm + is_infix = isDataSymOcc dc_occ_nm show_con - | is_infix = mk_showString_app (' ':dc_occ_nm) - | otherwise = - let + | is_infix = mk_showString_app (' ':dc_occ_nm_str) + | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe) + where space_ocurly_maybe | nullary_con = "" | lab_fields == 0 = " " | otherwise = "{" - in - mk_showString_app (dc_occ_nm ++ space_ocurly_maybe) + show_all con fs@(x:xs) | is_infix = x:con:xs @@ -962,15 +989,22 @@ gen_Show_binds fixs_assoc tycon show_thingies = show_all show_con real_show_thingies_with_labs - show_label l = mk_showString_app (nm ++ "=") + show_label l = mk_showString_app (the_name ++ "=") where - nm = occNameUserString (getOccName (fieldLabelName l)) + occ_nm = getOccName (fieldLabelName l) + -- legal, but rare. + is_op = isSymOcc occ_nm + the_name + | is_op = '(':nm ++ ")" + | otherwise = nm + + nm = occNameUserString occ_nm mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str)) - prec_cons = getLRPrecs fixs_assoc dc_nm + prec_cons = getLRPrecs is_infix fixity_env dc_nm real_show_thingies | is_infix = @@ -991,49 +1025,55 @@ gen_Show_binds fixs_assoc tycon (map show_label labels) real_show_thingies - (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc dc_nm + (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env dc_nm + {- + c.f. Figure 16 and 17 in Haskell 1.1 report + -} paren_prec_limit - | not is_infix = 9 - | otherwise = getFixity fixs_assoc dc_nm + | not is_infix = fromInt maxPrecedence + 1 + | otherwise = getFixity fixity_env dc_nm + 1 \end{code} \begin{code} -getLRPrecs :: Fixities -> Name -> [Integer] -getLRPrecs fixs_assoc nm = [lp, rp] +getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer] +getLRPrecs is_infix fixity_env nm = [lp, rp] where - ( con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm - paren_prec_limit = 9 + {- + Figuring out the fixities of the arguments to a constructor, + cf. Figures 16-18 in Haskell 1.1 report. + -} + (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env nm + paren_con_prec = getFixity fixity_env nm + maxPrec = fromInt maxPrecedence lp - | con_left_assoc = paren_prec_limit - | otherwise = paren_prec_limit + 1 + | not is_infix = maxPrec + 1 + | con_left_assoc = paren_con_prec + | otherwise = paren_con_prec + 1 rp - | con_right_assoc = paren_prec_limit - | otherwise = paren_prec_limit + 1 + | not is_infix = maxPrec + 1 + | con_right_assoc = paren_con_prec + | otherwise = paren_con_prec + 1 +getFixity :: FixityEnv -> Name -> Integer +getFixity fixity_env nm = case lookupFixity fixity_env nm of + Fixity x _ -> fromInt x -getFixity :: Fixities -> Name -> Integer -getFixity fixs_assoc nm = - case assocMaybe fixs_assoc nm of - Nothing -> 9 - Just (Fixity x _) -> fromInt x + 1 - -isLRAssoc :: Fixities -> Name -> (Bool, Bool) +isLRAssoc :: FixityEnv -> Name -> (Bool, Bool) isLRAssoc fixs_assoc nm = - case assocMaybe fixs_assoc nm of - Just (Fixity _ InfixL) -> (True, False) - Just (Fixity _ InfixR) -> (False, True) - _ -> (False, False) + case lookupFixity fixs_assoc nm of + Fixity _ InfixN -> (False, False) + Fixity _ InfixR -> (False, True) + Fixity _ InfixL -> (True, False) isInfixOccName :: String -> Bool isInfixOccName str = case str of (':':_) -> True _ -> False - \end{code} @@ -1079,14 +1119,14 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) mk_stuff var = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))) where - pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn) + pat = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn) var_RDR = qual_orig_name var gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) = mk_FunMonoBind (getSrcLoc tycon) rdr_name [([ConPatIn mkInt_RDR [VarPatIn a_RDR]], ExprWithTySig (HsApp tagToEnum_Expr a_Expr) - (MonoTyVar (qual_orig_name tycon)))] + (HsTyVar (qual_orig_name tycon)))] gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) = mk_easy_FunMonoBind (getSrcLoc tycon) @@ -1126,10 +1166,7 @@ mk_easy_FunMonoBind loc fun pats binds expr = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc mk_easy_Match loc pats binds expr - = mk_match loc pats expr (mkbind binds) - where - mkbind [] = EmptyBinds - mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive + = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive) -- The renamer expects everything in its input to be a -- "recursive" MonoBinds, and it is its job to sort things out -- from there. @@ -1242,11 +1279,6 @@ eq_Expr ty a b \end{code} \begin{code} -argFieldCount :: DataCon -> Int -- Works on data and newtype constructors -argFieldCount con = length (dataConRawArgTys con) -\end{code} - -\begin{code} untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr untag_Expr tycon [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr @@ -1329,6 +1361,7 @@ genOpApp e1 op e2 = mkOpApp e1 op e2 qual_orig_name n = nameRdrName (getName n) varUnqual n = mkSrcUnqual varName n +zz_a_RDR = varUnqual SLIT("_a") a_RDR = varUnqual SLIT("a") b_RDR = varUnqual SLIT("b") c_RDR = varUnqual SLIT("c") @@ -1346,6 +1379,7 @@ cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ] mkHsString s = HsString (_PK_ s) +zz_a_Expr = HsVar zz_a_RDR a_Expr = HsVar a_RDR b_Expr = HsVar b_RDR c_Expr = HsVar c_RDR @@ -1360,6 +1394,8 @@ getTag_Expr = HsVar getTag_RDR tagToEnum_Expr = HsVar tagToEnumH_RDR con2tag_Expr tycon = HsVar (con2tag_RDR tycon) +wildPat = WildPatIn +zz_a_Pat = VarPatIn zz_a_RDR a_Pat = VarPatIn a_RDR b_Pat = VarPatIn b_RDR c_Pat = VarPatIn c_RDR