X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=20e59ebefc0bb32ddc5760a5dd0b1720781a1c04;hb=3ca33229d4b9c1ed2829318631e73e748154f3ff;hp=b043f7dc5bec2f1248df4a077b42191ea13f7ba0;hpb=2d74238376e28afe2585674d78391ef0e8092ea4;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index b043f7d..20e59eb 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -29,20 +29,23 @@ 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 BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) + , maxPrecedence, defaultFixity + ) 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 +59,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 +182,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 +203,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 +314,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 +381,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 +396,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 +413,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 +565,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) @@ -646,7 +658,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] True{-boxed-}), d_Pat] [] ( HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) ( untag_Expr tycon [(a_RDR, ah_RDR)] ( @@ -685,12 +697,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 @@ -776,7 +788,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 +801,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 @@ -826,10 +838,22 @@ gen_Read_binds fixities tycon (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] True) + (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 = @@ -879,7 +903,7 @@ gen_Read_binds fixities tycon then d_Expr else HsVar (last bs_needed)] True - [lp,rp] = getLRPrecs fixities dc_nm + [lp,rp] = getLRPrecs is_infix fixities dc_nm quals | is_infix = let (h:t) = field_quals in (h:con_qual:t) @@ -887,14 +911,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 + | not is_infix = fromInt maxPrecedence | otherwise = getFixity fixities 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} %************************************************************************ @@ -919,36 +945,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 +988,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 fixs_assoc dc_nm real_show_thingies | is_infix = @@ -993,40 +1026,51 @@ gen_Show_binds fixs_assoc tycon (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc 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 fixs_assoc dc_nm + 1 \end{code} \begin{code} -getLRPrecs :: Fixities -> Name -> [Integer] -getLRPrecs fixs_assoc nm = [lp, rp] +getLRPrecs :: Bool -> Fixities -> Name -> [Integer] +getLRPrecs is_infix fixs_assoc 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 fixs_assoc nm + paren_con_prec = getFixity fixs_assoc 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 :: Fixities -> Name -> Integer getFixity fixs_assoc nm = - case assocMaybe fixs_assoc nm of - Nothing -> 9 - Just (Fixity x _) -> fromInt x + 1 + case lookupFixity fixs_assoc nm of + Fixity x _ -> fromInt x isLRAssoc :: Fixities -> 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) + +lookupFixity :: Fixities -> Name -> Fixity +lookupFixity fixs_assoc nm = assocDefault defaultFixity fixs_assoc nm isInfixOccName :: String -> Bool isInfixOccName str = @@ -1079,7 +1123,7 @@ 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) @@ -1126,10 +1170,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 +1283,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 +1365,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 +1383,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 +1398,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