#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

Reply via email to