Broken Read instance for Data.Fixed ("no parse" in legitimate cases).

[navaati]

read "Just 12.30" :: Maybe Centi throws "*** Exception: Prelude.read: no parse", as do read " 12.30" :: Centi.

[simonpj]

This commit claims to fix it. Close?

commit 3fb1aacabbded36e9203adf922af197db0652646
Author: Ian Lynagh <ian@well-typed.com>
Date:   Wed Jan 2 23:18:18 2013 +0000

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

>---------------------------------------------------------------

 Data/Fixed.hs             |   37 ++++++++++++++-----------------------
 GHC/Read.lhs              |    1 +
 Text/Read/Lex.hs          |   18 +++++++++++++++++-
 tests/all.T               |    1 +
 tests/readFixed001.hs     |   13 +++++++++++++
 tests/readFixed001.stdout |    6 ++++++
 6 files changed, 52 insertions(+), 24 deletions(-)

diff --git a/Data/Fixed.hs b/Data/Fixed.hs index b4a9857..fd0ca01 100644
--- a/Data/Fixed.hs
+++ b/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/GHC/Read.lhs b/GHC/Read.lhs index c542274..5ad9527 100644
--- a/GHC/Read.lhs
+++ b/GHC/Read.lhs
@@ -38,6 +38,7 @@ module GHC.Read
   , list
   , choose
   , readListDefault, readListPrecDefault
+  , readNumber
 
   -- Temporary
   , readParen
diff --git a/Text/Read/Lex.hs b/Text/Read/Lex.hs index 8a64e21..c1592c6 100644
--- a/Text/Read/Lex.hs
+++ b/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/tests/all.T b/tests/all.T index 8e11cf2..59354fe 100644
--- a/tests/all.T
+++ b/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/tests/readFixed001.hs b/tests/readFixed001.hs new file mode 100644 index 0000000..5336f9b
--- /dev/null
+++ b/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/tests/readFixed001.stdout b/tests/readFixed001.stdout new file mode 100644 index 0000000..82b2030
--- /dev/null
+++ b/tests/readFixed001.stdout
@@ -0,0 +1,6 @@
+[(12.34,"  ")]
+[(12.30,"  ")]
+[]
+[(12.00,"  ")]
+[]
+[(-12.34,"  ")]

[igloo]

Fixed by above patch.