X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FMatchLit.lhs;h=0bd25389376c8a77ecd5e7961239fce2aa47dcc2;hp=b6079d31b1dfeef82ba8c76c9b6f5b359f31df02;hb=927df6486bc0dcb598b82702ca40c8fad0d9b25f;hpb=41f08e8e43a0c1b2080a24a4d9742ea804068f5a diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index b6079d3..0bd2538 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -27,14 +27,13 @@ import TyCon import DataCon import TcHsSyn ( shortCutLit ) import TcType -import Type import PrelNames import TysWiredIn -import Unique import Literal import SrcLoc -import Ratio +import Data.Ratio import Outputable +import BasicTypes import Util import FastString \end{code} @@ -66,17 +65,17 @@ dsLit (HsStringPrim s) = return (Lit (MachStr s)) dsLit (HsCharPrim c) = return (Lit (MachChar c)) dsLit (HsIntPrim i) = return (Lit (MachInt i)) dsLit (HsWordPrim w) = return (Lit (MachWord w)) -dsLit (HsFloatPrim f) = return (Lit (MachFloat f)) -dsLit (HsDoublePrim d) = return (Lit (MachDouble d)) +dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) +dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) dsLit (HsChar c) = return (mkCharExpr c) dsLit (HsString str) = mkStringExprFS str dsLit (HsInteger i _) = mkIntegerExpr i -dsLit (HsInt i) = return (mkIntExpr (fromIntegral i)) +dsLit (HsInt i) = return (mkIntExpr i) dsLit (HsRat r ty) = do - num <- mkIntegerExpr (numerator r) - denom <- mkIntegerExpr (denominator r) + num <- mkIntegerExpr (numerator (fl_value r)) + denom <- mkIntegerExpr (denominator (fl_value r)) return (mkConApp ratio_data_con [Type integer_ty, num, denom]) where (ratio_data_con, integer_ty) @@ -114,8 +113,8 @@ hsLitKey (HsIntPrim i) = mkMachInt i hsLitKey (HsWordPrim w) = mkMachWord w hsLitKey (HsCharPrim c) = MachChar c hsLitKey (HsStringPrim s) = MachStr s -hsLitKey (HsFloatPrim f) = MachFloat f -hsLitKey (HsDoublePrim d) = MachDouble d +hsLitKey (HsFloatPrim f) = MachFloat (fl_value f) +hsLitKey (HsDoublePrim d) = MachDouble (fl_value d) hsLitKey (HsString s) = MachStr s hsLitKey l = pprPanic "hsLitKey" (ppr l) @@ -126,8 +125,8 @@ hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg litValKey :: OverLitVal -> Bool -> Literal litValKey (HsIntegral i) False = MachInt i litValKey (HsIntegral i) True = MachInt (-i) -litValKey (HsFractional r) False = MachFloat r -litValKey (HsFractional r) True = MachFloat (-r) +litValKey (HsFractional r) False = MachFloat (fl_value r) +litValKey (HsFractional r) True = MachFloat (negate (fl_value r)) litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s \end{code} @@ -154,43 +153,54 @@ tidyLitPat (HsString s) tidyLitPat lit = LitPat lit ---------------- -tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id -tidyNPat (OverLit val False _ ty) mb_neg _ - -- Take short cuts only if the literal is not using rebindable syntax - | isIntTy ty = mk_con_pat intDataCon (HsIntPrim int_val) - | isWordTy ty = mk_con_pat wordDataCon (HsWordPrim int_val) - | isFloatTy ty = mk_con_pat floatDataCon (HsFloatPrim rat_val) - | isDoubleTy ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val) --- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val) +tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat + -- We need this argument because tidyNPat is called + -- both by Match and by Check, but they tidy LitPats + -- slightly differently; and we must desugar + -- literals consistently (see Trac #5117) + -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id + -> Pat Id +tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ + -- False: Take short cuts only if the literal is not using rebindable syntax + -- + -- Once that is settled, look for cases where the type of the + -- entire overloaded literal matches the type of the underlying literal, + -- and in that case take the short cut + -- NB: Watch out for wierd cases like Trac #3382 + -- f :: Int -> Int + -- f "blah" = 4 + -- which might be ok if we hvae 'instance IsString Int' + -- + + | isIntTy ty, Just int_lit <- mb_int_lit = mk_con_pat intDataCon (HsIntPrim int_lit) + | isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit) + | isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit) + | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit) + | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit) where mk_con_pat :: DataCon -> HsLit -> Pat Id mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty) - neg_val = case (mb_neg, val) of - (Nothing, _) -> val - (Just _, HsIntegral i) -> HsIntegral (-i) - (Just _, HsFractional f) -> HsFractional (-f) - (Just _, HsIsString _) -> panic "tidyNPat" - - int_val :: Integer - int_val = case neg_val of - HsIntegral i -> i - _ -> panic "tidyNPat" + mb_int_lit :: Maybe Integer + mb_int_lit = case (mb_neg, val) of + (Nothing, HsIntegral i) -> Just i + (Just _, HsIntegral i) -> Just (-i) + _ -> Nothing - rat_val :: Rational - rat_val = case neg_val of - HsIntegral i -> fromInteger i - HsFractional f -> f - _ -> panic "tidyNPat" + mb_rat_lit :: Maybe FractionalLit + mb_rat_lit = case (mb_neg, val) of + (Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i)) + (Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i))) + (Nothing, HsFractional f) -> Just f + (Just _, HsFractional f) -> Just (negateFractionalLit f) + _ -> Nothing -{- - str_val :: FastString - str_val = case val of - HsIsString s -> s - _ -> panic "tidyNPat" --} - -tidyNPat over_lit mb_neg eq + mb_str_lit :: Maybe FastString + mb_str_lit = case (mb_neg, val) of + (Nothing, HsIsString s) -> Just s + _ -> Nothing + +tidyNPat _ over_lit mb_neg eq = NPat over_lit mb_neg eq \end{code} @@ -248,14 +258,8 @@ matchLiterals [] _ _ = panic "matchLiterals []" %************************************************************************ \begin{code} -matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult - -- All NPats, but perhaps for different literals -matchNPats vars ty groups - = do { match_results <- mapM (matchOneNPat vars ty) groups - ; return (foldr1 combineMatchResults match_results) } - -matchOneNPat :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal +matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal = do { let NPat lit mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of @@ -266,7 +270,7 @@ matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal ; let pred_expr = mkApps eq_expr [Var var, neg_lit] ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) ; return (mkGuardedMatchResult pred_expr match_result) } -matchOneNPat vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) +matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) \end{code}