Fix Data.Fixed.Fixed's Read instance; fixes #7483
authorIan Lynagh <ian@well-typed.com>
Wed, 2 Jan 2013 23:18:18 +0000 (23:18 +0000)
committerIan Lynagh <ian@well-typed.com>
Thu, 3 Jan 2013 00:12:25 +0000 (00:12 +0000)
Data/Fixed.hs
GHC/Read.lhs
Text/Read/Lex.hs
tests/all.T
tests/readFixed001.hs [new file with mode: 0644]
tests/readFixed001.stdout [new file with mode: 0644]

index b4a9857..fd0ca01 100644 (file)
@@ -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__
index c542274..5ad9527 100644 (file)
@@ -38,6 +38,7 @@ module GHC.Read
   , list
   , choose
   , readListDefault, readListPrecDefault
+  , readNumber
 
   -- Temporary
   , readParen
index 8a64e21..c1592c6 100644 (file)
@@ -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
index 8e11cf2..59354fe 100644 (file)
@@ -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 (file)
index 0000000..5336f9b
--- /dev/null
@@ -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 (file)
index 0000000..82b2030
--- /dev/null
@@ -0,0 +1,6 @@
+[(12.34,"  ")]
+[(12.30,"  ")]
+[]
+[(12.00,"  ")]
+[]
+[(-12.34,"  ")]