#7483: Broken Read instance for Data.Fixed ("no parse" in legitimate cases).
---------------------------------+------------------------------------------
Reporter: navaati | Owner:
Type: bug | Status: new
Priority: normal | Milestone:
Component: libraries/base | Version: 7.6.1
Keywords: | Os: Unknown/Multiple
Architecture: Unknown/Multiple | Failure: Incorrect result at runtime
Difficulty: Unknown | Testcase:
Blockedby: | Blocking:
Related: #4502 |
---------------------------------+------------------------------------------
Changes (by simonpj):
* difficulty: => Unknown
Comment:
This commit claims to fix it. Close?
{{{
commit 3fb1aacabbded36e9203adf922af197db0652646
Author: Ian Lynagh <i...@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," ")]
}}}
--
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/7483#comment:1>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler
_______________________________________________
Glasgow-haskell-bugs mailing list
Glasgow-haskell-bugs@haskell.org
http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs
