Skip to content

Commit 35ccaa4

Browse files
functorafunctora
committed
tags refactoring wip
1 parent 0757ab1 commit 35ccaa4

File tree

7 files changed

+74
-87
lines changed

7 files changed

+74
-87
lines changed

‎pub/bfx/src/Bfx.hs‎

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -268,8 +268,7 @@ submitOrderMaker ::
268268
ToRequestParam (Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos)),
269269
MoneyTags (Tags 'Unsigned |+| 'Base |+| bos),
270270
MoneyTags (Tags 'Unsigned |+| 'QuotePerBase |+| bos),
271-
GetTag bos (Tags 'Unsigned |+| 'QuotePerBase |+| bos),
272-
Typeable bos
271+
HasTag bos (Tags 'Unsigned |+| 'QuotePerBase |+| bos)
273272
) =>
274273
Env ->
275274
Money (Tags 'Unsigned |+| 'Base |+| bos) ->
@@ -294,8 +293,7 @@ submitOrderMakerRec ::
294293
ToRequestParam (Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos)),
295294
MoneyTags (Tags 'Unsigned |+| 'Base |+| bos),
296295
MoneyTags (Tags 'Unsigned |+| 'QuotePerBase |+| bos),
297-
GetTag bos (Tags 'Unsigned |+| 'QuotePerBase |+| bos),
298-
Typeable bos
296+
HasTag bos (Tags 'Unsigned |+| 'QuotePerBase |+| bos)
299297
) =>
300298
Env ->
301299
Money (Tags 'Unsigned |+| 'Base |+| bos) ->

‎pub/bfx/src/Bfx/Class/FromRpc.hs‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -73,7 +73,12 @@ instance (SingI act) => FromRpc 'SubmitOrder (Order act 'Remote) where
7373
Nothing -> Left "Incorrect ExchangeAction"
7474
Just Refl -> pure order
7575

76-
instance (RateTags tags) => FromRpc 'MarketAveragePrice (Money tags) where
76+
instance
77+
( RateTags tags,
78+
Ratio (IntRep tags) ~ a
79+
) =>
80+
FromRpc 'MarketAveragePrice (Tagged tags a)
81+
where
7782
fromRpc (RawResponse raw) = do
7883
x <-
7984
maybeToRight

‎pub/bfx/src/Bfx/Class/ToRequestParam.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -59,9 +59,10 @@ instance ToRequestParam Text where
5959
--
6060
instance
6161
( CashTags tags,
62-
GetTag (bos :: BuyOrSell) tags
62+
Ratio (IntRep tags) ~ a,
63+
HasTag (bos :: BuyOrSell) tags
6364
) =>
64-
ToRequestParam (Money tags)
65+
ToRequestParam (Tagged tags a)
6566
where
6667
toTextParam amt =
6768
case sing :: Sing bos of

‎pub/bfx/src/Bfx/Data/Metro.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@ import Bfx.Import.External
1212

1313
type CashTags tags =
1414
( MoneyTags tags,
15-
GetTag 'Unsigned tags
15+
HasTag 'Unsigned tags
1616
)
1717

1818
roundMoney ::
@@ -35,8 +35,8 @@ roundMoney money =
3535

3636
type RateTags tags =
3737
( MoneyTags tags,
38-
GetTag 'Unsigned tags,
39-
GetTag 'QuotePerBase tags
38+
HasTag 'Unsigned tags,
39+
HasTag 'QuotePerBase tags
4040
)
4141

4242
roundQuotePerBase ::

‎pub/bfx/src/Bfx/Math.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -16,8 +16,8 @@ import Bfx.Import.External
1616
tweakMoneyPip ::
1717
forall tags bos m.
1818
( CashTags tags,
19-
GetTag 'Base tags,
20-
GetTag (bos :: BuyOrSell) tags,
19+
HasTag 'Base tags,
20+
HasTag (bos :: BuyOrSell) tags,
2121
MonadThrow m
2222
) =>
2323
Money tags ->
@@ -32,7 +32,7 @@ tweakMoneyPip amt =
3232

3333
tweakMoneyPip' ::
3434
( CashTags tags,
35-
GetTag 'Base tags,
35+
HasTag 'Base tags,
3636
MonadThrow m
3737
) =>
3838
(Money tags -> Money tags) ->
@@ -47,7 +47,7 @@ tweakMoneyPip' expr amt = do
4747
tweakMakerRate ::
4848
forall tags bos m.
4949
( RateTags tags,
50-
GetTag (bos :: BuyOrSell) tags,
50+
HasTag (bos :: BuyOrSell) tags,
5151
MonadThrow m
5252
) =>
5353
Money tags ->

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

Lines changed: 45 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -70,52 +70,33 @@ type NewMoneyTags lhs rhs =
7070
MoneyTags lhs
7171
)
7272

73-
data Money tags where
74-
Money ::
75-
forall tags.
76-
( MoneyTags tags
77-
) =>
78-
Ratio (IntRep tags) ->
79-
Money tags
80-
81-
deriving stock instance Eq (Money tags)
82-
83-
deriving stock instance Ord (Money tags)
84-
85-
deriving stock instance (MoneyTags tags) => Show (Money tags)
86-
87-
deriving stock instance (MoneyTags tags) => Read (Money tags)
88-
89-
deriving stock instance (MoneyTags tags) => Data (Money tags)
73+
type Money tags = Tagged tags (Ratio (IntRep tags))
9074

9175
unMoney :: Money tags -> Ratio (IntRep tags)
92-
unMoney (Money x) = x
76+
unMoney (Tagged x) = x
9377

9478
tagMoney ::
95-
forall prevTag prevTags nextTags.
96-
( NewMoneyTags nextTags (prevTags |+| prevTag),
97-
IntRep prevTags ~ IntRep nextTags
79+
forall tag tags.
80+
( IntRep tags ~ IntRep (tags |+| tag)
9881
) =>
99-
Money prevTags ->
100-
Money nextTags
82+
Money tags ->
83+
Money (tags |+| tag)
10184
tagMoney = newMoney . unMoney
10285

10386
unTagMoney ::
104-
forall prevTag prevTags nextTags.
105-
( NewMoneyTags nextTags (prevTags |-| prevTag),
106-
IntRep prevTags ~ IntRep nextTags
87+
forall tag tags.
88+
( IntRep tags ~ IntRep (tags |-| tag)
10789
) =>
108-
Money prevTags ->
109-
Money nextTags
90+
Money tags ->
91+
Money (tags |-| tag)
11092
unTagMoney = newMoney . unMoney
11193

11294
reTagMoney ::
113-
forall prevTag nextTag prevTags nextTags.
114-
( NewMoneyTags nextTags (prevTags |-| prevTag |+| nextTag),
115-
IntRep prevTags ~ IntRep nextTags
95+
forall prev next tags.
96+
( IntRep tags ~ IntRep (tags |-| prev |+| next)
11697
) =>
117-
Money prevTags ->
118-
Money nextTags
98+
Money tags ->
99+
Money (tags |-| prev |+| next)
119100
reTagMoney = newMoney . unMoney
120101

121102
parseMoney ::
@@ -129,7 +110,7 @@ parseMoney ::
129110
str ->
130111
m (Money tags)
131112
parseMoney =
132-
fmap Money . parseRatio
113+
fmap Tagged . parseRatio
133114

134115
addMoney :: (MoneyTags tags) => Money tags -> Money tags -> Money tags
135116
addMoney lhs rhs =
@@ -160,11 +141,9 @@ deriving stock instance Show (SomeMoney k tags)
160141

161142
newMoney ::
162143
forall tags.
163-
( MoneyTags tags
164-
) =>
165144
Ratio (IntRep tags) ->
166145
Money tags
167-
newMoney = Money
146+
newMoney = Tagged
168147

169148
newUnsignedMoneyBOS ::
170149
forall tags buy sell.
@@ -176,8 +155,8 @@ newUnsignedMoneyBOS ::
176155
Rational ->
177156
SomeMoney BuyOrSell (tags |+| 'Unsigned)
178157
newUnsignedMoneyBOS raw
179-
| raw < 0 = SomeMoney (sing :: Sing 'Sell) (Money uns :: Money sell)
180-
| otherwise = SomeMoney (sing :: Sing 'Buy) (Money uns :: Money buy)
158+
| raw < 0 = SomeMoney (sing :: Sing 'Sell) (Tagged uns :: Money sell)
159+
| otherwise = SomeMoney (sing :: Sing 'Buy) (Tagged uns :: Money buy)
181160
where
182161
uns = unsafeFrom @Rational @(Ratio Natural) $ abs raw
183162

@@ -191,26 +170,22 @@ newUnsignedMoneyGOL ::
191170
Rational ->
192171
SomeMoney GainOrLose (tags |+| 'Unsigned)
193172
newUnsignedMoneyGOL raw
194-
| raw < 0 = SomeMoney (sing :: Sing 'Lose) (Money uns :: Money lose)
195-
| otherwise = SomeMoney (sing :: Sing 'Gain) (Money uns :: Money gain)
173+
| raw < 0 = SomeMoney (sing :: Sing 'Lose) (Tagged uns :: Money lose)
174+
| otherwise = SomeMoney (sing :: Sing 'Gain) (Tagged uns :: Money gain)
196175
where
197176
uns = unsafeFrom @Rational @(Ratio Natural) $ abs raw
198177

199178
newFeeRate ::
200-
forall prev next.
201-
( NewMoneyTags next (prev |+| 'FeeRate)
202-
) =>
203-
Ratio (IntRep next) ->
204-
Money next
205-
newFeeRate = Money
179+
forall tags.
180+
Ratio (IntRep (tags |+| 'FeeRate)) ->
181+
Money (tags |+| 'FeeRate)
182+
newFeeRate = Tagged
206183

207184
newProfitRate ::
208-
forall prev next.
209-
( NewMoneyTags next (prev |+| 'ProfitRate)
210-
) =>
211-
Ratio (IntRep next) ->
212-
Money next
213-
newProfitRate = Money
185+
forall tags.
186+
Ratio (IntRep (tags |+| 'ProfitRate)) ->
187+
Money (tags |+| 'ProfitRate)
188+
newProfitRate = Tagged
214189

215190
addFee ::
216191
forall fee amt tags.
@@ -221,8 +196,8 @@ addFee ::
221196
Money fee ->
222197
Money amt ->
223198
Money tags
224-
addFee (Money fee) (Money amt) =
225-
Money $ amt / (1 - fee)
199+
addFee (Tagged fee) (Tagged amt) =
200+
Tagged $ amt / (1 - fee)
226201

227202
deductFee ::
228203
forall fee amt tags.
@@ -233,8 +208,8 @@ deductFee ::
233208
Money fee ->
234209
Money amt ->
235210
Money tags
236-
deductFee (Money fee) (Money amt) =
237-
Money $ amt * (1 - fee)
211+
deductFee (Tagged fee) (Tagged amt) =
212+
Tagged $ amt * (1 - fee)
238213

239214
addProfit ::
240215
forall tags.
@@ -245,8 +220,8 @@ addProfit ::
245220
Money (tags |+| 'ProfitRate) ->
246221
Money tags ->
247222
Money (tags |+| 'Revenue)
248-
addProfit (Money rate) (Money amt) =
249-
Money $ amt * (1 + rate)
223+
addProfit (Tagged rate) (Tagged amt) =
224+
Tagged $ amt * (1 + rate)
250225

251226
exchangeMoney ::
252227
forall tags.
@@ -257,8 +232,8 @@ exchangeMoney ::
257232
Money (tags |+| 'QuotePerBase) ->
258233
Money (tags |+| 'Base) ->
259234
Money (tags |+| 'Quote)
260-
exchangeMoney (Money rate) (Money base) =
261-
Money $ rate * base
235+
exchangeMoney (Tagged rate) (Tagged base) =
236+
Tagged $ rate * base
262237

263238
newQuotePerBase ::
264239
forall tags.
@@ -269,11 +244,17 @@ newQuotePerBase ::
269244
Money (tags |+| 'Quote) ->
270245
Money (tags |+| 'Base) ->
271246
Money (tags |+| 'QuotePerBase)
272-
newQuotePerBase (Money quote) (Money base) =
273-
Money $ quote / base
247+
newQuotePerBase (Tagged quote) (Tagged base) =
248+
Tagged $ quote / base
274249

275250
data Funds tags where
276-
Funds :: Money tags -> CurrencyCode -> Funds tags
251+
Funds ::
252+
forall tags.
253+
( MoneyTags tags
254+
) =>
255+
Money tags ->
256+
CurrencyCode ->
257+
Funds tags
277258

278259
fundsMoneyAmount :: Funds tags -> Money tags
279260
fundsMoneyAmount (Funds amt _) = amt

‎pub/functora/src/sql/Functora/SqlOrphan.hs‎

Lines changed: 11 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -72,19 +72,12 @@ instance PersistField Integer where
7272

7373
deriving via Int64 instance PersistFieldSql Integer
7474

75-
deriving via
76-
Rational
77-
instance
78-
( MoneyTags tags,
79-
HasTag (sig :: SignedOrUnsigned) tags
80-
) =>
81-
PersistFieldSql (Money tags)
82-
8375
instance
8476
( MoneyTags tags,
77+
Ratio (IntRep tags) ~ a,
8578
HasTag (sig :: SignedOrUnsigned) tags
8679
) =>
87-
PersistField (Money tags)
80+
PersistField (Tagged tags a)
8881
where
8982
toPersistValue money =
9083
let rep = unMoney money
@@ -107,3 +100,12 @@ instance
107100
inspectType @(Money tags)
108101
<> " PersistValue is invalid "
109102
<> inspect raw
103+
104+
deriving via
105+
Rational
106+
instance
107+
( MoneyTags tags,
108+
Ratio (IntRep tags) ~ a,
109+
HasTag (sig :: SignedOrUnsigned) tags
110+
) =>
111+
PersistFieldSql (Tagged tags a)

0 commit comments

Comments
 (0)