X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FMatchLit.lhs;h=0bd25389376c8a77ecd5e7961239fce2aa47dcc2;hp=9d3ff49f620dc09dab2d7bc79604b0b93e82fbdb;hb=0af06ed99ed56341adfdda4a92a0a36678780109;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2

diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 9d3ff49..0bd2538 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -31,8 +31,9 @@ import PrelNames
 import TysWiredIn
 import Literal
 import SrcLoc
-import Ratio
+import Data.Ratio
 import Outputable
+import BasicTypes
 import Util
 import FastString
 \end{code}
@@ -64,8 +65,8 @@ 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
@@ -73,8 +74,8 @@ dsLit (HsInteger i _)  = mkIntegerExpr 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) 
@@ -112,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)
 
@@ -124,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}
 
@@ -152,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}