1 files changed, 103 insertions, 7 deletions

diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs
index 46fb352e61..f7168190e4 100644
--- a/compiler/GHC/Utils/Misc.hs
+++ b/compiler/GHC/Utils/Misc.hs
@@ -99,7 +99,9 @@ module GHC.Utils.Misc (
 
         -- * Floating point
         readRational,
+        readSignificandExponentPair,
         readHexRational,
+        readHexSignificandExponentPair,
 
         -- * IO-ish utilities
         doesDirNameExist,
@@ -1161,9 +1163,28 @@ exactLog2 x
 
 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 readRational__ r = do
+      ((i, e), t) <- readSignificandExponentPair__ r
+      return ((i%1)*10^^e, t)
+
+readRational :: String -> Rational -- NB: *does* handle a leading "-"
+readRational top_s
+  = case top_s of
+      '-' : xs -> - (read_me xs)
+      xs       -> read_me xs
+  where
+    read_me s
+      = case (do { (x,"") <- readRational__ s ; return x }) of
+          [x] -> x
+          []  -> error ("readRational: no parse:"        ++ top_s)
+          _   -> error ("readRational: ambiguous parse:" ++ top_s)
+
+
+readSignificandExponentPair__ :: ReadS (Integer, Integer) -- NB: doesn't handle leading "-"
+readSignificandExponentPair__ r = do
      (n,d,s) <- readFix r
      (k,t)   <- readExp s
-     return ((n%1)*10^^(k-d), t)
+     let pair = (n, toInteger (k - d))
+     return (pair, t)
  where
      readFix r = do
         (ds,s)  <- lexDecDigits r
@@ -1197,17 +1218,25 @@ readRational__ r = do
                | p x       =  let (ys,zs) = span' p xs' in (x:ys,zs)
                | otherwise =  ([],xs)
 
-readRational :: String -> Rational -- NB: *does* handle a leading "-"
-readRational top_s
+-- | Parse a string into a significand and exponent.
+-- A trivial example might be:
+--   ghci> readSignificandExponentPair "1E2"
+--   (1,2)
+-- In a more complex case we might return a exponent different than that
+-- which the user wrote. This is needed in order to use a Integer significand.
+--   ghci> readSignificandExponentPair "-1.11E5"
+--   (-111,3)
+readSignificandExponentPair :: String -> (Integer, Integer) -- NB: *does* handle a leading "-"
+readSignificandExponentPair top_s
   = case top_s of
-      '-' : xs -> - (read_me xs)
+      '-' : xs -> let (i, e) = read_me xs in (-i, e)
       xs       -> read_me xs
   where
     read_me s
-      = case (do { (x,"") <- readRational__ s ; return x }) of
+      = case (do { (x,"") <- readSignificandExponentPair__ s ; return x }) of
           [x] -> x
-          []  -> error ("readRational: no parse:"        ++ top_s)
-          _   -> error ("readRational: ambiguous parse:" ++ top_s)
+          []  -> error ("readSignificandExponentPair: no parse:"        ++ top_s)
+          _   -> error ("readSignificandExponentPair: ambiguous parse:" ++ top_s)
 
 
 readHexRational :: String -> Rational
@@ -1265,6 +1294,73 @@ readHexRational__ ('0' : x : rest)
 
 readHexRational__ _ = Nothing
 
+-- | Parse a string into a significand and exponent according to
+-- the "Hexadecimal Floats in Haskell" proposal.
+-- A trivial example might be:
+--   ghci> readHexSignificandExponentPair "0x1p+1"
+--   (1,1)
+-- Behaves similar to readSignificandExponentPair but the base is 16
+-- and numbers are given in hexadecimal:
+--   ghci> readHexSignificandExponentPair "0xAp-4"
+--   (10,-4)
+--   ghci> readHexSignificandExponentPair "0x1.2p3"
+--   (18,-1)
+readHexSignificandExponentPair :: String -> (Integer, Integer)
+readHexSignificandExponentPair str =
+  case str of
+    '-' : xs -> let (i, e) = readMe xs in (-i, e)
+    xs       -> readMe xs
+  where
+  readMe as =
+    case readHexSignificandExponentPair__ as of
+      Just n -> n
+      _      -> error ("readHexSignificandExponentPair: no parse:" ++ str)
+
+
+readHexSignificandExponentPair__ :: String -> Maybe (Integer, Integer)
+readHexSignificandExponentPair__ ('0' : x : rest)
+  | x == 'X' || x == 'x' =
+  do let (front,rest2) = span' isHexDigit rest
+     guard (not (null front))
+     let frontNum = steps 16 0 front
+     case rest2 of
+       '.' : rest3 ->
+          do let (back,rest4) = span' isHexDigit rest3
+             guard (not (null back))
+             let backNum = steps 16 frontNum back
+                 exp1    = -4 * length back
+             case rest4 of
+               p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps)
+               _ -> return (mk backNum exp1)
+       p : ps | isExp p -> fmap (mk frontNum) (getExp ps)
+       _ -> Nothing
+
+  where
+  isExp p = p == 'p' || p == 'P'
+
+  getExp ('+' : ds) = dec ds
+  getExp ('-' : ds) = fmap negate (dec ds)
+  getExp ds         = dec ds
+
+  mk :: Integer -> Int -> (Integer, Integer)
+  mk n e = (n, fromIntegral e)
+
+  dec cs = case span' isDigit cs of
+             (ds,"") | not (null ds) -> Just (steps 10 0 ds)
+             _ -> Nothing
+
+  steps base n ds = foldl' (step base) n ds
+  step  base n d  = base * n + fromIntegral (digitToInt d)
+
+  span' _ xs@[]         =  (xs, xs)
+  span' p xs@(x:xs')
+            | x == '_'  = span' p xs'   -- skip "_"  (#14473)
+            | p x       =  let (ys,zs) = span' p xs' in (x:ys,zs)
+            | otherwise =  ([],xs)
+
+readHexSignificandExponentPair__ _ = Nothing
+
+
 -----------------------------------------------------------------------------
 -- Verify that the 'dirname' portion of a FilePath exists.
 --