Record the original text along with parsed Rationals: fixes #2245

[ghc-hetmet.git] / compiler / deSugar / MatchLit.lhs

diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index be8ea23..4842b16 100644 (file)
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -31,8 +31,9 @@ import PrelNames
 import TysWiredIn
 import Literal
 import SrcLoc
 import TysWiredIn
 import Literal
 import SrcLoc

-import Ratio
+import Data.Ratio

 import Outputable
 import Outputable

+import BasicTypes

 import Util
 import FastString
 \end{code}
 import Util
 import FastString
 \end{code}

@@ -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 :: 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}
 
 litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr s
 \end{code}
 

@@ -152,8 +153,14 @@ tidyLitPat (HsString s)
 tidyLitPat lit = LitPat lit
 
 ----------------
 tidyLitPat lit = LitPat lit
 
 ----------------

-tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
-tidyNPat (OverLit val False _ ty) mb_neg _
+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 
        -- 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 

@@ -169,7 +176,7 @@ tidyNPat (OverLit val False _ ty) mb_neg _
   | 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)
   | 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 = tidyLitPat (HsString str_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)
   where
     mk_con_pat :: DataCon -> HsLit -> Pat Id
     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)

@@ -184,8 +191,8 @@ tidyNPat (OverLit val False _ ty) mb_neg _
     mb_rat_lit = case (mb_neg, val) of
                   (Nothing, HsIntegral   i) -> Just (fromInteger i)
                   (Just _,  HsIntegral   i) -> Just (fromInteger (-i))
     mb_rat_lit = case (mb_neg, val) of
                   (Nothing, HsIntegral   i) -> Just (fromInteger i)
                   (Just _,  HsIntegral   i) -> Just (fromInteger (-i))

-                  (Nothing, HsFractional f) -> Just f
-                  (Just _, HsFractional f)  -> Just (-f)
+                  (Nothing, HsFractional f) -> Just (fl_value f)
+                  (Just _, HsFractional f)  -> Just (negate (fl_value f))

                   _ -> Nothing
        
     mb_str_lit :: Maybe FastString
                   _ -> Nothing
        
     mb_str_lit :: Maybe FastString

@@ -193,7 +200,7 @@ tidyNPat (OverLit val False _ ty) mb_neg _
                   (Nothing, HsIsString s) -> Just s
                   _ -> Nothing
 
                   (Nothing, HsIsString s) -> Just s
                   _ -> Nothing
 

-tidyNPat over_lit mb_neg eq 
+tidyNPat _ over_lit mb_neg eq 

   = NPat over_lit mb_neg eq
 \end{code}
 
   = NPat over_lit mb_neg eq
 \end{code}