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

1 files changed, 17 insertions, 1 deletions

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