Fix Data.Fixed.Fixed's Read instance; fixes #7483

6 files changed, 52 insertions, 24 deletions

diff --git a/libraries/base/Data/Fixed.hs b/libraries/base/Data/Fixed.hs
index b4a9857d6d..fd0ca01513 100644
--- a/libraries/base/Data/Fixed.hs
+++ b/libraries/base/Data/Fixed.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, PatternGuards #-}
 {-# OPTIONS -Wall -fno-warn-unused-binds #-}
 #ifndef __NHC__
 {-# LANGUAGE DeriveDataTypeable #-}
@@ -40,12 +40,13 @@ module Data.Fixed
 ) where
 
 import Prelude -- necessary to get dependencies right
-import Data.Char
-import Data.List
 #ifndef __NHC__
 import Data.Typeable
 import Data.Data
 #endif
+import GHC.Read
+import Text.ParserCombinators.ReadPrec
+import Text.Read.Lex
 
 #ifndef __NHC__
 default () -- avoid any defaulting shenanigans
@@ -159,30 +160,20 @@ showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZe
     maxnum = 10 ^ digits
     fracNum = div (d * maxnum) res
 
-readsFixed :: (HasResolution a) => ReadS (Fixed a)
-readsFixed = readsSigned
-    where readsSigned ('-' : xs) = [ (negate x, rest)
-                                   | (x, rest) <- readsUnsigned xs ]
-          readsSigned xs = readsUnsigned xs
-          readsUnsigned xs = case span isDigit xs of
-                             ([], _) -> []
-                             (is, xs') ->
-                                 let i = fromInteger (read is)
-                                 in case xs' of
-                                    '.' : xs'' ->
-                                        case span isDigit xs'' of
-                                        ([], _) -> []
-                                        (js, xs''') ->
-                                            let j = fromInteger (read js)
-                                                l = genericLength js :: Integer
-                                            in [(i + (j / (10 ^ l)), xs''')]
-                                    _ -> [(i, xs')]
-
 instance (HasResolution a) => Show (Fixed a) where
     show = showFixed False
 
 instance (HasResolution a) => Read (Fixed a) where
-    readsPrec _ = readsFixed
+    readPrec     = readNumber convertFixed
+    readListPrec = readListPrecDefault
+    readList     = readListDefault
+
+convertFixed :: forall a . HasResolution a => Lexeme -> ReadPrec (Fixed a)
+convertFixed (Number n)
+ | Just (i, f) <- numberToFixed r n =
+    return (fromInteger i + (fromInteger f / (10 ^ r)))
+    where r = resolution (undefined :: Fixed a)
+convertFixed _ = pfail
 
 data E0 = E0
 #ifndef __NHC__
diff --git a/libraries/base/GHC/Read.lhs b/libraries/base/GHC/Read.lhs
index c54227477f..5ad9527361 100644
--- a/libraries/base/GHC/Read.lhs
+++ b/libraries/base/GHC/Read.lhs
@@ -38,6 +38,7 @@ module GHC.Read
   , list
   , choose
   , readListDefault, readListPrecDefault
+  , readNumber
 
   -- Temporary
   , readParen
diff --git a/libraries/base/Text/Read/Lex.hs b/libraries/base/Text/Read/Lex.hs
index 8a64e21b80..c1592c6c5c 100644
--- a/libraries/base/Text/Read/Lex.hs
+++ b/libraries/base/Text/Read/Lex.hs
@@ -19,7 +19,7 @@ module Text.Read.Lex
   -- lexing types
   ( Lexeme(..)
 
-  , numberToInteger, numberToRational, numberToRangedRational
+  , numberToInteger, numberToFixed, numberToRational, numberToRangedRational
 
   -- lexer
   , lex, expect
@@ -82,6 +82,22 @@ numberToInteger (MkNumber base iPart) = Just (val (fromIntegral base) 0 iPart)
 numberToInteger (MkDecimal iPart Nothing Nothing) = Just (val 10 0 iPart)
 numberToInteger _ = Nothing
 
+numberToFixed :: Integer -> Number -> Maybe (Integer, Integer)
+numberToFixed _ (MkNumber base iPart) = Just (val (fromIntegral base) 0 iPart, 0)
+numberToFixed _ (MkDecimal iPart Nothing Nothing) = Just (val 10 0 iPart, 0)
+numberToFixed p (MkDecimal iPart (Just fPart) Nothing)
+    = let i = val 10 0 iPart
+          f = val 10 0 (integerTake p (fPart ++ repeat 0))
+          -- Sigh, we really want genericTake, but that's above us in
+          -- the hierarchy, so we define our own version here (actually
+          -- specialised to Integer)
+          integerTake             :: Integer -> [a] -> [a]
+          integerTake n _ | n <= 0 = []
+          integerTake _ []        =  []
+          integerTake n (x:xs)    =  x : integerTake (n-1) xs
+      in Just (i, f)
+numberToFixed _ _ = Nothing
+
 -- This takes a floatRange, and if the Rational would be outside of
 -- the floatRange then it may return Nothing. Not that it will not
 -- /necessarily/ return Nothing, but it is good enough to fix the
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 8e11cf21ca..59354fe5a2 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -20,6 +20,7 @@ test('data-fixed-show-read', normal, compile_and_run, [''])
 test('showDouble', normal, compile_and_run, [''])
 test('readDouble001', normal, compile_and_run, [''])
 test('readInteger001', normal, compile_and_run, [''])
+test('readFixed001', normal, compile_and_run, [''])
 test('lex001', normal, compile_and_run, [''])
 test('take001', extra_run_opts('1'), compile_and_run, [''])
 test('genericNegative001', extra_run_opts('-1'), compile_and_run, [''])
diff --git a/libraries/base/tests/readFixed001.hs b/libraries/base/tests/readFixed001.hs
new file mode 100644
index 0000000000..5336f9b7b8
--- /dev/null
+++ b/libraries/base/tests/readFixed001.hs
@@ -0,0 +1,13 @@
+
+import Data.Fixed
+
+main :: IO ()
+main = do f "  (( (  12.3456  ) )  )  "
+          f "  (( (  12.3     ) )  )  "
+          f "  (( (  12.      ) )  )  "
+          f "  (( (  12       ) )  )  "
+          f "  (( - (  12.3456  ) )  )  "
+          f "  (( (  -12.3456  ) )  )  "
+
+f :: String -> IO ()
+f str = print (reads str :: [(Centi, String)])
diff --git a/libraries/base/tests/readFixed001.stdout b/libraries/base/tests/readFixed001.stdout
new file mode 100644
index 0000000000..82b2030d63
--- /dev/null
+++ b/libraries/base/tests/readFixed001.stdout
@@ -0,0 +1,6 @@
+[(12.34,"  ")]
+[(12.30,"  ")]
+[]
+[(12.00,"  ")]
+[]
+[(-12.34,"  ")]