From 96578de113a3132591c66112e19189b2b5ac740d Mon Sep 17 00:00:00 2001
From: Taylor Fausak <taylor@fausak.me>
Date: Thu, 18 Nov 2021 10:39:07 -0500
Subject: [PATCH] Fix floating point conversions

Fixes #39.
---
 src/lib/Witch/Instances.hs | 34 ++++++++++++++++++++++++----------
 src/test/Main.hs           |  8 ++++++++
 2 files changed, 32 insertions(+), 10 deletions(-)

diff --git a/src/lib/Witch/Instances.hs b/src/lib/Witch/Instances.hs
index 7fc219e..d45b3cc 100644
--- a/src/lib/Witch/Instances.hs
+++ b/src/lib/Witch/Instances.hs
@@ -17,6 +17,7 @@ import qualified Data.Foldable as Foldable
 import qualified Data.Int as Int
 import qualified Data.IntMap as IntMap
 import qualified Data.IntSet as IntSet
+import qualified Data.List as List
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Map as Map
 import qualified Data.Ratio as Ratio
@@ -32,6 +33,7 @@ import qualified Data.Time.Clock.System as Time
 import qualified Data.Time.Clock.TAI as Time
 import qualified Data.Word as Word
 import qualified GHC.Float as Float
+import qualified Numeric
 import qualified Numeric.Natural as Natural
 import qualified Witch.From as From
 import qualified Witch.TryFrom as TryFrom
@@ -810,11 +812,7 @@ instance TryFrom.TryFrom Float Natural.Natural where
 
 -- | Uses 'toRational' when the input is not NaN or infinity.
 instance TryFrom.TryFrom Float Rational where
-  tryFrom = Utility.eitherTryFrom $ \s -> if isNaN s
-    then Left Exception.LossOfPrecision
-    else if isInfinite s
-      then if s > 0 then Left Exception.Overflow else Left Exception.Underflow
-      else Right $ toRational s
+  tryFrom = Utility.eitherTryFrom realFloatToRational
 
 -- | Uses 'Float.float2Double'.
 instance From.From Float Double where
@@ -878,11 +876,7 @@ instance TryFrom.TryFrom Double Natural.Natural where
 
 -- | Uses 'toRational' when the input is not NaN or infinity.
 instance TryFrom.TryFrom Double Rational where
-  tryFrom = Utility.eitherTryFrom $ \s -> if isNaN s
-    then Left Exception.LossOfPrecision
-    else if isInfinite s
-      then if s > 0 then Left Exception.Overflow else Left Exception.Underflow
-      else Right $ toRational s
+  tryFrom = Utility.eitherTryFrom realFloatToRational
 
 -- | Uses 'Float.double2Float'. This necessarily loses some precision.
 instance From.From Double Float where
@@ -1249,6 +1243,26 @@ instance From.From Time.NominalDiffTime Time.CalendarDiffTime where
 instance From.From Time.ZonedTime Time.UTCTime where
   from = Time.zonedTimeToUTC
 
+--
+
+realFloatToRational :: RealFloat s => s -> Either Exception.ArithException Rational
+realFloatToRational s
+  | isNaN s = Left Exception.LossOfPrecision
+  | isInfinite s = if s > 0 then Left Exception.Overflow else Left Exception.Underflow
+  | otherwise = Right $ overPositive (uncurry makeRational . uncurry fromDigits . Numeric.floatToDigits 10) s
+
+overPositive :: (Eq a, Num a, Num b) => (a -> b) -> a -> b
+overPositive f x = if signum x == -1 then -(f (-x)) else f x
+
+fromDigits :: [Int] -> Int -> (Int, Int)
+fromDigits ds e = List.foldl'
+  (\ (a, n) d -> (a * 10 + d, n - 1))
+  (0, e)
+  ds
+
+makeRational :: Int -> Int -> Rational
+makeRational d e = toRational d * 10 ^^ toInteger e
+
 fromNonNegativeIntegral
   :: (Integral s, Num t) => s -> Either Exception.ArithException t
 fromNonNegativeIntegral x =
diff --git a/src/test/Main.hs b/src/test/Main.hs
index 9d308f2..2544251 100644
--- a/src/test/Main.hs
+++ b/src/test/Main.hs
@@ -1266,6 +1266,8 @@ main = runTestTTAndExit $ "Witch" ~:
       , f (0 / 0) ~?= Nothing
       , f (1 / 0) ~?= Nothing
       , f (-1 / 0) ~?= Nothing
+      , f 0.1 ~?= Just 0.1
+      , f (-0.1) ~?= Just (-0.1)
       ]
     , "From Float Double" ~:
       let f = Witch.from @Float @Double in
@@ -1418,6 +1420,8 @@ main = runTestTTAndExit $ "Witch" ~:
       , f (0 / 0) ~?= Nothing
       , f (1 / 0) ~?= Nothing
       , f (-1 / 0) ~?= Nothing
+      , f 0.1 ~?= Just 0.1
+      , f (-0.1) ~?= Just (-0.1)
       ]
     , "From Double Float" ~:
       let f = Witch.from @Double @Float in
@@ -1448,12 +1452,16 @@ main = runTestTTAndExit $ "Witch" ~:
       [ f 0 ~?= 0
       , f 0.5 ~?= 0.5
       , f (-0.5) ~?= (-0.5)
+      , f 0.1 ~?= 0.1
+      , f (-0.1) ~?= (-0.1)
       ]
     , "From Rational Double" ~:
       let f = Witch.from @Rational @Double in
       [ f 0 ~?= 0
       , f 0.5 ~?= 0.5
       , f (-0.5) ~?= (-0.5)
+      , f 0.1 ~?= 0.1
+      , f (-0.1) ~?= (-0.1)
       ]
     , "TryFrom Rational (Fixed a)" ~:
       let f = hush . Witch.tryFrom @Rational @Fixed.Deci in