Skip to content

Commit 4d94675

Browse files
functorafunctora
committed
wip
1 parent a437260 commit 4d94675

File tree

3 files changed

+96
-74
lines changed

3 files changed

+96
-74
lines changed

‎ghcjs/delivery-calculator/src/App/Types.hs‎

Lines changed: 79 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module App.Types
1010
newAsset,
1111
newFieldPair,
1212
newFieldPairId,
13+
newTotal,
1314
Screen (..),
1415
isQrCode,
1516
unQrCode,
@@ -49,9 +50,11 @@ import qualified Functora.Miso.Types as FM
4950
import qualified Functora.Miso.Widgets.Field as Field
5051
import qualified Functora.Miso.Widgets.Icon as Icon
5152
import Functora.Money hiding (Currency, Money, Text)
53+
import qualified Functora.Money as Money
5254
import qualified Functora.Prelude as Prelude
5355
import qualified Functora.Rates as Rates
5456
import qualified Functora.Web as Web
57+
import Lens.Micro ((^..))
5558
import qualified Paths_delivery_calculator as Paths
5659
import qualified Text.URI as URI
5760

@@ -205,6 +208,82 @@ newFieldPairId key val = do
205208
. #fieldOptsQrState
206209
.~ Nothing
207210

211+
newTotal :: Model -> [FieldPair DynamicField Identity]
212+
newTotal st =
213+
if base == 0
214+
then mempty
215+
else
216+
[ newFieldPairId ("Subtotal " <> baseCur)
217+
. DynamicFieldText
218+
$ inspectRatioDef base,
219+
newFieldPairId ("Subtotal " <> quoteCur)
220+
. DynamicFieldText
221+
$ inspectRatioDef quote,
222+
FieldPair (newTextFieldId "Fee %")
223+
$ uniqueToIdentity fee
224+
& #fieldOpts
225+
. #fieldOptsQrState
226+
.~ Nothing,
227+
newFieldPairId ("Total " <> quoteCur)
228+
. DynamicFieldText
229+
. inspectRatioDef
230+
. foldField quote
231+
$ fee
232+
]
233+
where
234+
fee = st ^. #modelState . #stMerchantFeePercent
235+
rate = st ^. #modelState . #stExchangeRate . #fieldOutput
236+
base =
237+
foldl
238+
( \acc fps ->
239+
if any
240+
((== FieldTypeNumber) . (^. #fieldPairValue . #fieldType))
241+
fps
242+
then acc + foldl foldFieldPair 1 fps
243+
else acc
244+
)
245+
0
246+
( st
247+
^.. #modelState
248+
. #stAssets
249+
. each
250+
. #assetFieldPairs
251+
)
252+
quote =
253+
rate * base
254+
baseCur =
255+
st
256+
^. #modelState
257+
. #stAssetCurrency
258+
. #currencyOutput
259+
. #currencyInfoCode
260+
. to Money.inspectCurrencyCode
261+
. to toUpper
262+
quoteCur =
263+
st
264+
^. #modelState
265+
. #stMerchantCurrency
266+
. #currencyOutput
267+
. #currencyInfoCode
268+
. to Money.inspectCurrencyCode
269+
. to toUpper
270+
271+
foldField :: Rational -> Field DynamicField f -> Rational
272+
foldField acc Field {fieldType = typ, fieldOutput = out} =
273+
case out of
274+
DynamicFieldNumber x
275+
| typ == FieldTypeNumber ->
276+
acc * x
277+
DynamicFieldNumber x
278+
| typ == FieldTypePercent ->
279+
acc * (1 + (x / 100))
280+
_ ->
281+
acc
282+
283+
foldFieldPair :: Rational -> FieldPair DynamicField f -> Rational
284+
foldFieldPair acc =
285+
foldField acc . fieldPairValue
286+
208287
data Screen
209288
= Main
210289
| Donate

‎ghcjs/delivery-calculator/src/App/Widgets/Main.hs‎

Lines changed: 3 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -11,8 +11,6 @@ import qualified Functora.Miso.Widgets.FieldPairs as FieldPairs
1111
import qualified Functora.Miso.Widgets.Flex as Flex
1212
import qualified Functora.Miso.Widgets.Icon as Icon
1313
import qualified Functora.Miso.Widgets.Spinner as Spinner
14-
import qualified Functora.Money as Money
15-
import Lens.Micro ((^..))
1614
import Miso hiding (at, view)
1715

1816
mainWidget :: Model -> View Action
@@ -150,7 +148,7 @@ screenWidget st@Model {modelState = St {stScreen = Main}} =
150148

151149
totalViewer :: Model -> [View Action]
152150
totalViewer st =
153-
if base == 0
151+
if null total
154152
then mempty
155153
else
156154
singleton
@@ -160,81 +158,12 @@ totalViewer st =
160158
FieldPairs.defOpts
161159
FieldPairs.Args
162160
{ FieldPairs.argsModel = st,
163-
FieldPairs.argsOptic =
164-
constTraversal
165-
[ newFieldPairId ("Subtotal " <> baseCur)
166-
. DynamicFieldText
167-
$ inspectRatioDef base,
168-
newFieldPairId ("Subtotal " <> quoteCur)
169-
. DynamicFieldText
170-
$ inspectRatioDef quote,
171-
FieldPair (newTextFieldId "Fee %")
172-
$ uniqueToIdentity fee
173-
& #fieldOpts
174-
. #fieldOptsQrState
175-
.~ Nothing,
176-
newFieldPairId ("Total " <> quoteCur)
177-
. DynamicFieldText
178-
. inspectRatioDef
179-
. foldField quote
180-
$ fee
181-
],
161+
FieldPairs.argsOptic = constTraversal total,
182162
FieldPairs.argsAction = PushUpdate . Instant,
183163
FieldPairs.argsEmitter = pushActionQueue st . Instant
184164
}
185165
where
186-
fee = st ^. #modelState . #stMerchantFeePercent
187-
rate = st ^. #modelState . #stExchangeRate . #fieldOutput
188-
base =
189-
foldl
190-
( \acc fps ->
191-
if any
192-
((== FieldTypeNumber) . (^. #fieldPairValue . #fieldType))
193-
fps
194-
then acc + foldl foldFieldPair 1 fps
195-
else acc
196-
)
197-
0
198-
( st
199-
^.. #modelState
200-
. #stAssets
201-
. each
202-
. #assetFieldPairs
203-
)
204-
quote =
205-
rate * base
206-
baseCur =
207-
st
208-
^. #modelState
209-
. #stAssetCurrency
210-
. #currencyOutput
211-
. #currencyInfoCode
212-
. to Money.inspectCurrencyCode
213-
. to toUpper
214-
quoteCur =
215-
st
216-
^. #modelState
217-
. #stMerchantCurrency
218-
. #currencyOutput
219-
. #currencyInfoCode
220-
. to Money.inspectCurrencyCode
221-
. to toUpper
222-
223-
foldField :: Rational -> Field DynamicField f -> Rational
224-
foldField acc Field {fieldType = typ, fieldOutput = out} =
225-
case out of
226-
DynamicFieldNumber x
227-
| typ == FieldTypeNumber ->
228-
acc * x
229-
DynamicFieldNumber x
230-
| typ == FieldTypePercent ->
231-
acc * (1 + (x / 100))
232-
_ ->
233-
acc
234-
235-
foldFieldPair :: Rational -> FieldPair DynamicField f -> Rational
236-
foldFieldPair acc =
237-
foldField acc . fieldPairValue
166+
total = newTotal st
238167

239168
tosWidget :: View Action
240169
tosWidget =

‎ghcjs/delivery-calculator/src/App/Xlsx.hs‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,8 @@ newXlsx st imgs = xlsx
1818
xlsx =
1919
fromXlsx 0
2020
$ def
21+
& #xlStyles
22+
.~ renderStyleSheet style
2123
& atSheet "Delivery_Calculator"
2224
?~ sheet
2325
sheet =
@@ -67,6 +69,18 @@ newColProps rows = nubOrd $ do
6769
cpBestFit = False
6870
}
6971

72+
style :: StyleSheet
73+
style =
74+
def
75+
& #styleSheetCellXfs
76+
.~ [ def
77+
& #cellXfAlignment
78+
?~ ( def
79+
& #_alignmentVertical
80+
?~ CellVerticalAlignmentCenter
81+
)
82+
]
83+
7084
addHeader :: St Unique -> Worksheet -> Worksheet
7185
addHeader st sheet =
7286
case sortOn length headers of

0 commit comments

Comments
 (0)