Skip to content

Commit ec40795

Browse files
functorafunctora
committed
fixed point numbers refactoring wip
1 parent 644ba00 commit ec40795

File tree

4 files changed

+196
-28
lines changed

4 files changed

+196
-28
lines changed

‎pub/functora/src/cfg/Functora/CfgOrphan.hs‎

Lines changed: 58 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -199,6 +199,30 @@ _Ratio =
199199
. via @Rational @(Ratio a) @Double
200200
)
201201

202+
_Frac ::
203+
forall a.
204+
( TryFrom Rational a,
205+
From a Rational
206+
) =>
207+
Toml.TomlBiMap a Toml.AnyValue
208+
_Frac =
209+
Toml.mkAnyValueBiMap
210+
( \src -> do
211+
let failure =
212+
Toml.MatchError Toml.TDouble
213+
$ Toml.AnyValue src
214+
dbl <-
215+
Toml.matchDouble src
216+
rat <-
217+
first (const failure)
218+
$ tryFrom @Double @Rational dbl
219+
first (const failure)
220+
$ tryFrom @Rational @a rat
221+
)
222+
( Toml.Double
223+
. via @Rational @a @Double
224+
)
225+
202226
--
203227
-- TODO : how to make an instance for a Rational nicely?
204228
--
@@ -220,6 +244,24 @@ instance
220244
where
221245
hasItemCodec = Left $ _Ratio @a
222246

247+
instance (HasResolution e) => Toml.HasCodec (Fixed e) where
248+
hasCodec = Toml.match $ _Frac @(Fixed e)
249+
250+
instance (HasResolution e) => Toml.HasItemCodec (Fixed e) where
251+
hasItemCodec = Left $ _Frac @(Fixed e)
252+
253+
instance Toml.HasCodec Fix where
254+
hasCodec = Toml.match $ _Frac @Fix
255+
256+
instance Toml.HasItemCodec Fix where
257+
hasItemCodec = Left $ _Frac @Fix
258+
259+
instance Toml.HasCodec FixNonNeg where
260+
hasCodec = Toml.match $ _Frac @FixNonNeg
261+
262+
instance Toml.HasItemCodec FixNonNeg where
263+
hasItemCodec = Left $ _Frac @FixNonNeg
264+
223265
{-# INLINE defaultPutList #-}
224266
defaultPutList :: (Binary a) => [a] -> Binary.Put
225267
defaultPutList xs = Binary.put (length xs) <> mapM_ Binary.put xs
@@ -265,3 +307,19 @@ instance Toml.HasItemCodec JSString where
265307
deriving via GenericEnum AscOrDesc instance HasCodec AscOrDesc
266308

267309
deriving via GenericEnum AscOrDesc instance HasItemCodec AscOrDesc
310+
311+
deriving newtype instance Binary Fix
312+
313+
deriving newtype instance ToJSON Fix
314+
315+
deriving newtype instance FromJSON Fix
316+
317+
--
318+
-- TODO : verify FixNonNeg value is acceptable
319+
--
320+
321+
deriving newtype instance Binary FixNonNeg
322+
323+
deriving newtype instance ToJSON FixNonNeg
324+
325+
deriving newtype instance FromJSON FixNonNeg

‎pub/functora/src/money/Functora/Money.hs‎

Lines changed: 55 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ module Functora.Money
1313
ProfitRate (..),
1414
unJsonRational,
1515
unJsonRatio,
16+
unJsonFrac,
1617
)
1718
where
1819

@@ -37,23 +38,43 @@ data Money = Money
3738
via GenericType Money
3839

3940
newtype MoneyAmount = MoneyAmount
40-
{ unMoneyAmount :: Ratio Natural
41+
{ unMoneyAmount :: FixNonNeg
4142
}
4243
deriving stock (Eq, Ord, Show, Read, Data, Generic)
4344
deriving newtype
44-
( Binary,
45+
( --
46+
-- Numeric
47+
--
48+
Num,
49+
Real,
50+
Fractional,
51+
RealFrac,
52+
--
53+
-- Encoding
54+
--
55+
Binary,
4556
ToJSON,
4657
FromJSON,
4758
HasCodec,
4859
HasItemCodec
4960
)
5061

5162
newtype QuotePerBase = QuotePerBase
52-
{ unQuotePerBase :: Ratio Natural
63+
{ unQuotePerBase :: FixNonNeg
5364
}
5465
deriving stock (Eq, Ord, Show, Read, Data, Generic)
5566
deriving newtype
56-
( Binary,
67+
( --
68+
-- Numeric
69+
--
70+
Num,
71+
Real,
72+
Fractional,
73+
RealFrac,
74+
--
75+
-- Encoding
76+
--
77+
Binary,
5778
ToJSON,
5879
FromJSON,
5980
HasCodec,
@@ -101,23 +122,43 @@ inspectCurrencyInfo input =
101122
code = inspectCurrencyCode $ currencyInfoCode input
102123

103124
newtype FeeRate = FeeRate
104-
{ unFeeRate :: Ratio Natural
125+
{ unFeeRate :: FixNonNeg
105126
}
106127
deriving stock (Eq, Ord, Show, Read, Data, Generic)
107128
deriving newtype
108-
( Binary,
129+
( --
130+
-- Numeric
131+
--
132+
Num,
133+
Real,
134+
Fractional,
135+
RealFrac,
136+
--
137+
-- Encoding
138+
--
139+
Binary,
109140
ToJSON,
110141
FromJSON,
111142
HasCodec,
112143
HasItemCodec
113144
)
114145

115146
newtype ProfitRate = ProfitRate
116-
{ unProfitRate :: Ratio Natural
147+
{ unProfitRate :: FixNonNeg
117148
}
118149
deriving stock (Eq, Ord, Show, Read, Data, Generic)
119150
deriving newtype
120-
( Binary,
151+
( --
152+
-- Numeric
153+
--
154+
Num,
155+
Real,
156+
Fractional,
157+
RealFrac,
158+
--
159+
-- Encoding
160+
--
161+
Binary,
121162
ToJSON,
122163
FromJSON,
123164
HasCodec,
@@ -138,3 +179,9 @@ unJsonRatio = do
138179
rat <- unJsonRational
139180
either (fail . inspect) pure
140181
$ tryFrom @Rational @(Ratio a) rat
182+
183+
unJsonFrac :: forall a. (Data a, TryFrom Rational a) => A.Decoder a
184+
unJsonFrac = do
185+
rat <- unJsonRational
186+
either (fail . inspect) pure
187+
$ tryFrom @Rational @a rat

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

Lines changed: 82 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -125,7 +125,6 @@ module Functora.Prelude
125125
E30,
126126
Fix (..),
127127
FixNonNeg (..),
128-
mkFixNonNeg,
129128
inspectFixed,
130129

131130
-- * DerivingVia
@@ -153,6 +152,7 @@ import Control.Concurrent.STM.TChan as X
153152
writeTChan,
154153
)
155154
import qualified Control.Concurrent.Thread.Delay as Delay
155+
import qualified Control.Exception as Exception
156156
import Control.Exception.Safe as X (impureThrow, throw)
157157
import qualified Control.Exception.Safe as Safe
158158
import Control.Lens as X ((^?))
@@ -293,6 +293,7 @@ import qualified Data.Typeable as Typeable
293293
import Functora.PreludeOrphan as X ()
294294
import Functora.Unicode as X (Unicode)
295295
import Functora.Witch as X
296+
import Functora.Witch.Utility (withSource, withTarget)
296297
import GHC.Generics as X (Rep)
297298
import GHC.TypeLits as X (KnownSymbol, Symbol)
298299
import qualified GHC.TypeLits as TypeLits
@@ -1174,6 +1175,7 @@ newtype Fix = Fix
11741175
( Eq,
11751176
Ord,
11761177
Show,
1178+
Read,
11771179
Data,
11781180
Generic
11791181
)
@@ -1184,45 +1186,106 @@ newtype Fix = Fix
11841186
RealFrac
11851187
)
11861188

1189+
instance From (Fixed E30) Fix where
1190+
from = Fix
1191+
1192+
instance From Integer Fix where
1193+
from = Fix . from @Integer @(Fixed E30)
1194+
1195+
instance From Natural Fix where
1196+
from = via @Integer @Natural @Fix
1197+
1198+
instance TryFrom Rational Fix where
1199+
tryFrom =
1200+
bimap withTarget Fix
1201+
. tryFrom @Rational @(Fixed E30)
1202+
1203+
instance TryFrom Scientific Fix where
1204+
tryFrom src =
1205+
first (withSource src)
1206+
. tryFrom @Rational @Fix
1207+
$ toRational @Scientific src
1208+
1209+
instance From Fix (Fixed E30) where
1210+
from = unFix
1211+
1212+
instance From Fix Rational where
1213+
from = via @(Fixed E30) @Fix @Rational
1214+
11871215
newtype FixNonNeg = FixNonNeg
11881216
{ unFixNonNeg :: Fixed E30
11891217
}
11901218
deriving stock
11911219
( Eq,
11921220
Ord,
11931221
Show,
1222+
Read,
11941223
Data,
11951224
Generic
11961225
)
11971226

1198-
mkFixNonNeg :: Fixed E30 -> FixNonNeg
1199-
mkFixNonNeg x =
1200-
if x >= 0
1201-
then FixNonNeg x
1202-
else error $ "Underflow " <> inspect x
1203-
1204-
inspectFixed :: forall a e. (From String a, HasResolution e) => Fixed e -> a
1205-
inspectFixed = from @String @a . showFixed True
1227+
instance TryFrom (Fixed E30) FixNonNeg where
1228+
tryFrom src =
1229+
if src >= 0
1230+
then pure $ FixNonNeg src
1231+
else Left . TryFromException src . Just $ SomeException Exception.Underflow
1232+
1233+
instance TryFrom Integer FixNonNeg where
1234+
tryFrom src =
1235+
first (withSource src)
1236+
. tryFrom @(Fixed E30) @FixNonNeg
1237+
$ from @Integer @(Fixed E30) src
1238+
1239+
instance TryFrom Natural FixNonNeg where
1240+
tryFrom src =
1241+
first (withSource src)
1242+
. tryFrom @(Fixed E30) @FixNonNeg
1243+
$ via @Integer @Natural @(Fixed E30) src
1244+
1245+
instance TryFrom Rational FixNonNeg where
1246+
tryFrom = tryVia @(Fixed E30) @Rational @FixNonNeg
1247+
1248+
instance TryFrom Scientific FixNonNeg where
1249+
tryFrom src =
1250+
first (withSource src)
1251+
. tryFrom @Rational @FixNonNeg
1252+
$ toRational @Scientific src
1253+
1254+
instance From FixNonNeg (Fixed E30) where
1255+
from = unFixNonNeg
1256+
1257+
instance From FixNonNeg Rational where
1258+
from = via @(Fixed E30) @FixNonNeg @Rational
1259+
1260+
inspectFixed ::
1261+
forall a e.
1262+
( From String a,
1263+
HasResolution e
1264+
) =>
1265+
Fixed e ->
1266+
a
1267+
inspectFixed =
1268+
from @String @a . showFixed True
12061269

12071270
instance Num FixNonNeg where
1208-
lhs + rhs = mkFixNonNeg $ unFixNonNeg lhs + unFixNonNeg rhs
1209-
lhs - rhs = mkFixNonNeg $ unFixNonNeg lhs - unFixNonNeg rhs
1210-
lhs * rhs = mkFixNonNeg $ unFixNonNeg lhs * unFixNonNeg rhs
1211-
negate = mkFixNonNeg . negate . unFixNonNeg
1212-
abs = mkFixNonNeg . abs . unFixNonNeg
1213-
signum = mkFixNonNeg . signum . unFixNonNeg
1214-
fromInteger = mkFixNonNeg . Prelude.fromInteger @(Fixed E30)
1271+
lhs + rhs = unsafeFrom @(Fixed E30) @FixNonNeg $ unFixNonNeg lhs + unFixNonNeg rhs
1272+
lhs - rhs = unsafeFrom @(Fixed E30) @FixNonNeg $ unFixNonNeg lhs - unFixNonNeg rhs
1273+
lhs * rhs = unsafeFrom @(Fixed E30) @FixNonNeg $ unFixNonNeg lhs * unFixNonNeg rhs
1274+
negate = unsafeFrom @(Fixed E30) @FixNonNeg . negate . unFixNonNeg
1275+
abs = unsafeFrom @(Fixed E30) @FixNonNeg . abs . unFixNonNeg
1276+
signum = unsafeFrom @(Fixed E30) @FixNonNeg . signum . unFixNonNeg
1277+
fromInteger = unsafeFrom @Integer @FixNonNeg
12151278

12161279
instance Real FixNonNeg where
12171280
toRational = toRational . unFixNonNeg
12181281

12191282
instance Fractional FixNonNeg where
1220-
fromRational = mkFixNonNeg . fromRational
1221-
lhs / rhs = mkFixNonNeg $ unFixNonNeg lhs / unFixNonNeg rhs
1283+
fromRational = unsafeFrom @Rational @FixNonNeg
1284+
lhs / rhs = unsafeFrom @(Fixed E30) @FixNonNeg $ unFixNonNeg lhs / unFixNonNeg rhs
12221285

12231286
instance RealFrac FixNonNeg where
12241287
properFraction x =
1225-
(lhs, mkFixNonNeg rhs)
1288+
(lhs, unsafeFrom @(Fixed E30) @FixNonNeg rhs)
12261289
where
12271290
(lhs, rhs) = properFraction $ unFixNonNeg x
12281291

‎pub/functora/src/rates/Functora/Rates.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -270,7 +270,7 @@ tryFetchQuotesPerBase opts cur uri = tryMarket $ do
270270
$ unCurrencyCode cur
271271
]
272272
. A.mapStrict
273-
$ fmap QuotePerBase unJsonRatio
273+
$ fmap QuotePerBase unJsonFrac
274274
pure
275275
QuotesPerBaseAt
276276
{ quotesPerBaseQuotesMap =

0 commit comments

Comments
 (0)