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