refactor FixNonNeg

Author: functora

pub/functora/src/prelude/Functora/Prelude.hs

@@ -126,6 +126,7 @@ module Functora.Prelude
     Fix (..),
     FixNonNeg (..),
     inspectFixed,
+    inspectFix,
 
     -- * DerivingVia
     -- $derivingVia
@@ -1213,7 +1214,7 @@ instance From Fix Rational where
   from = via @(Fixed E30) @Fix @Rational
 
 newtype FixNonNeg = FixNonNeg
-  { unFixNonNeg :: Fixed E30
+  { unFixNonNeg :: Fix
   }
   deriving stock
     ( Eq,
@@ -1224,68 +1225,88 @@ newtype FixNonNeg = FixNonNeg
       Generic
     )
 
-instance TryFrom (Fixed E30) FixNonNeg where
-  tryFrom src =
+mkViaFix ::
+  forall a.
+  ( From a Fix
+  ) =>
+  a ->
+  Either (TryFromException a FixNonNeg) FixNonNeg
+mkViaFix src =
+  first (withSource src)
+    . tryFrom @Fix @FixNonNeg
+    $ from @a @Fix src
+
+instance TryFrom Fix FixNonNeg where
+  tryFrom src = do
     if src >= 0
       then pure $ FixNonNeg src
       else Left . TryFromException src . Just $ SomeException Exception.Underflow
 
+instance TryFrom (Fixed E30) FixNonNeg where
+  tryFrom = mkViaFix @(Fixed E30)
+
 instance TryFrom Integer FixNonNeg where
-  tryFrom src =
-    first (withSource src)
-      . tryFrom @(Fixed E30) @FixNonNeg
-      $ from @Integer @(Fixed E30) src
+  tryFrom = mkViaFix @Integer
 
 instance TryFrom Natural FixNonNeg where
-  tryFrom src =
-    first (withSource src)
-      . tryFrom @(Fixed E30) @FixNonNeg
-      $ via @Integer @Natural @(Fixed E30) src
+  tryFrom = mkViaFix @Natural
 
 instance TryFrom Rational FixNonNeg where
-  tryFrom = tryVia @(Fixed E30) @Rational @FixNonNeg
+  tryFrom = tryVia @Fix @Rational @FixNonNeg
 
 instance TryFrom Scientific FixNonNeg where
-  tryFrom src =
-    first (withSource src)
-      . tryFrom @Rational @FixNonNeg
-      $ toRational @Scientific src
+  tryFrom = tryVia @Fix @Scientific @FixNonNeg
 
-instance From FixNonNeg (Fixed E30) where
+instance From FixNonNeg Fix where
   from = unFixNonNeg
 
+instance From FixNonNeg (Fixed E30) where
+  from = unFix . unFixNonNeg
+
 instance From FixNonNeg Rational where
-  from = via @(Fixed E30) @FixNonNeg @Rational
+  from = via @Fix @FixNonNeg @Rational
 
 inspectFixed ::
-  forall a e.
-  ( From String a,
-    HasResolution e
+  forall str e.
+  ( HasResolution e,
+    From String str
   ) =>
   Fixed e ->
-  a
+  str
 inspectFixed =
-  from @String @a . showFixed True
+  from @String @str
+    . showFixed True
+
+inspectFix ::
+  forall str fix.
+  ( From fix (Fixed E30),
+    From String str
+  ) =>
+  fix ->
+  str
+inspectFix =
+  inspectFixed
+    . from @fix @(Fixed E30)
 
 instance Num FixNonNeg where
-  lhs + rhs = unsafeFrom @(Fixed E30) @FixNonNeg $ unFixNonNeg lhs + unFixNonNeg rhs
-  lhs - rhs = unsafeFrom @(Fixed E30) @FixNonNeg $ unFixNonNeg lhs - unFixNonNeg rhs
-  lhs * rhs = unsafeFrom @(Fixed E30) @FixNonNeg $ unFixNonNeg lhs * unFixNonNeg rhs
-  negate = unsafeFrom @(Fixed E30) @FixNonNeg . negate . unFixNonNeg
-  abs = unsafeFrom @(Fixed E30) @FixNonNeg . abs . unFixNonNeg
-  signum = unsafeFrom @(Fixed E30) @FixNonNeg . signum . unFixNonNeg
+  lhs + rhs = unsafeFrom @Fix @FixNonNeg $ unFixNonNeg lhs + unFixNonNeg rhs
+  lhs - rhs = unsafeFrom @Fix @FixNonNeg $ unFixNonNeg lhs - unFixNonNeg rhs
+  lhs * rhs = unsafeFrom @Fix @FixNonNeg $ unFixNonNeg lhs * unFixNonNeg rhs
+  negate = unsafeFrom @Fix @FixNonNeg . negate . unFixNonNeg
+  abs = unsafeFrom @Fix @FixNonNeg . abs . unFixNonNeg
+  signum = unsafeFrom @Fix @FixNonNeg . signum . unFixNonNeg
   fromInteger = unsafeFrom @Integer @FixNonNeg
 
 instance Real FixNonNeg where
   toRational = toRational . unFixNonNeg
 
 instance Fractional FixNonNeg where
   fromRational = unsafeFrom @Rational @FixNonNeg
-  lhs / rhs = unsafeFrom @(Fixed E30) @FixNonNeg $ unFixNonNeg lhs / unFixNonNeg rhs
+  lhs / rhs = unsafeFrom @Fix @FixNonNeg $ unFixNonNeg lhs / unFixNonNeg rhs
 
 instance RealFrac FixNonNeg where
   properFraction x =
-    (lhs, unsafeFrom @(Fixed E30) @FixNonNeg rhs)
+    (lhs, unsafeFrom @Fix @FixNonNeg rhs)
     where
       (lhs, rhs) = properFraction $ unFixNonNeg x
 

pub/functora/src/test/Functora/PreludeSpec.hs

@@ -49,8 +49,11 @@ spec = do
     unsafeFrom @(UTF_8 ByteString) @Text (htmlUid $ addUid nilUid nilUid)
       `shouldBe` "uid-HXugtXVfQbdnt1bHDJcE9HU6kDMaPEJSQhN3moaHr6Hp"
   it "inspectFixed" $ do
-    inspectFixed @Text (unFix 2.5) `shouldBe` "2.5"
-    inspectFixed @Text (unFixNonNeg 2.500) `shouldBe` "2.5"
+    inspectFix @Text @Fix 2.5 `shouldBe` "2.5"
+    inspectFix @Text @Fix 0 `shouldBe` "0"
+    inspectFix @Text @Fix (-2.5) `shouldBe` "-2.5"
+    inspectFix @Text @FixNonNeg 2.500 `shouldBe` "2.5"
+    inspectFix @Text @FixNonNeg 0 `shouldBe` "0"
   it "parseRatio/overflow"
     $ inspect @Text (parseRatio @Text @Word8 @(Either SomeException) "0.333")
     `shouldBe` "Left (ParseException {parseExceptionSource = \"0.333\", parseExceptionSourceType = Text, parseExceptionTargetType = Ratio Word8, parseExceptionFailure = \"Word8 numerator or denominator seems to be out of bounds, expected 333 % 1000 but got 77 % 232\"})"

pub/functora/src/test/Functora/RoundSpec.hs

@@ -1,10 +1,9 @@
 module Functora.RoundSpec (spec) where
 
-import Data.Fixed (E12, Fixed)
 --
 -- NOTE : Round functions will fail for FixNonNeg because of impl details.
 --
-import Functora.Prelude (E30, Fix, throw, throwString, try)
+import Functora.Prelude (Fix, throw, throwString, try)
 import Functora.Round (dpRound, sdRound)
 import Numeric.Natural (Natural)
 import System.Exit (ExitCode (..))
@@ -29,14 +28,10 @@ spec = do
         "src/round/Functora/Round.hs"
       ]
 
-  mkRoundSpec @(Fixed E30) "dpRound/Fixed/E30" dpRound dpRoundTestData
-  mkRoundSpec @(Fixed E12) "dpRound/Fixed/E12" dpRound dpRoundTestData
   mkRoundSpec @Rational "dpRound/Rational" dpRound dpRoundTestData
   mkRoundSpec @Double "dpRound/Double" dpRound dpRoundTestData
   mkRoundSpec @Fix "dpRound/Fix" dpRound dpRoundTestData
 
-  mkRoundSpec @(Fixed E30) "sdRound/Fixed/E30" sdRound sdRoundTestData
-  mkRoundSpec @(Fixed E12) "sdRound/Fixed/E12" sdRound sdRoundTestData
   mkRoundSpec @Rational "sdRound/Rational" sdRound sdRoundTestData
   mkRoundSpec @Double "sdRound/Double" sdRound sdRoundTestData
   mkRoundSpec @Fix "sdRound/Fix" sdRound sdRoundTestData