Skip to content

Commit 51de66e

Browse files
functorafunctora
committed
WIP
1 parent 3ecfbbd commit 51de66e

File tree

5 files changed

+185
-54
lines changed

5 files changed

+185
-54
lines changed

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

Lines changed: 11 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,8 @@ import Functora.Miso.Prelude
3737
import Functora.Miso.Types as X hiding (Asset (..))
3838
import Functora.Money hiding (Currency, Money, Text)
3939
import qualified Functora.Prelude as Prelude
40+
import qualified Functora.Rates as Rates
41+
import qualified Functora.Web as Web
4042
import qualified Paths_delivery_calculator as Paths
4143
import qualified Text.URI as URI
4244

@@ -50,7 +52,10 @@ data Model = Model
5052
modelUriViewer :: [FieldPair DynamicField Unique],
5153
modelDonateViewer :: [FieldPair DynamicField Unique],
5254
modelProducerQueue :: TChan (InstantOrDelayed (Model -> JSM Model)),
53-
modelConsumerQueue :: TChan (InstantOrDelayed (Model -> JSM Model))
55+
modelConsumerQueue :: TChan (InstantOrDelayed (Model -> JSM Model)),
56+
modelCurrencies :: NonEmpty CurrencyInfo,
57+
modelWebOpts :: Web.Opts,
58+
modelMarket :: MVar Rates.Market
5459
}
5560
deriving stock (Eq, Generic)
5661

@@ -63,9 +68,10 @@ data Action
6368

6469
data St f = St
6570
{ stAssets :: [Asset f],
66-
stPayment :: Money f,
71+
stPaymentMoney :: Money f,
6772
stMerchantTele :: Field Unicode f,
6873
stMerchantFeePercent :: Field Rational f,
74+
stOnlineOrOffline :: OnlineOrOffline,
6975
stDefAssetCurrency :: Currency f,
7076
stFavName :: Field Unicode f,
7177
stPreview :: Field Unicode f,
@@ -90,17 +96,18 @@ deriving via GenericType (St Identity) instance Binary (St Identity)
9096
newSt :: (MonadIO m) => m (St Unique)
9197
newSt = do
9298
fee <- newRatioField 2
93-
payment <- newMoney 0 rub
99+
paymentMoney <- newMoney 0 rub
94100
defAssetCur <- newCurrency cny
95101
fav <- newTextField mempty
96102
pre <- newTextField "Delivery Calculator"
97103
tele <- newTextField "Functora"
98104
pure
99105
St
100106
{ stAssets = mempty,
101-
stPayment = payment,
107+
stPaymentMoney = paymentMoney,
102108
stMerchantTele = tele,
103109
stMerchantFeePercent = fee,
110+
stOnlineOrOffline = Online,
104111
stDefAssetCurrency = defAssetCur,
105112
stFavName = fav,
106113
stPreview = pre & #fieldType .~ FieldTypeTitle,

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -145,7 +145,7 @@ favItem st label Fav {favUri = uri} =
145145
--
146146
-- TODO : Implement here pure, less costly equivalent of newModel.
147147
--
148-
next <- newModel (Just st) uri
148+
next <- newModel (st ^. #modelWebOpts) (Just st) uri
149149
pure
150150
$ nextSt
151151
& #modelFav

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

Lines changed: 107 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -9,11 +9,14 @@ import qualified Functora.Miso.Css as Css
99
import qualified Functora.Miso.Jsm as Jsm
1010
import Functora.Miso.Prelude
1111
import qualified Functora.Miso.Widgets.BrowserLink as BrowserLink
12+
import qualified Functora.Miso.Widgets.Currency as Currency
1213
import qualified Functora.Miso.Widgets.Field as Field
1314
import qualified Functora.Miso.Widgets.Grid as Grid
1415
import qualified Material.Button as Button
1516
import qualified Material.Dialog as Dialog
1617
import qualified Material.IconButton as IconButton
18+
import qualified Material.Select as Select
19+
import qualified Material.Select.Item as SelectItem
1720
import qualified Material.Theme as Theme
1821
import qualified Material.TopAppBar as TopAppBar
1922
import qualified Text.URI as URI
@@ -114,44 +117,69 @@ menu st =
114117
Nothing
115118
[ Grid.grid
116119
mempty
117-
$ [ Grid.mediumCell
118-
[ Button.raised
119-
( Button.config
120-
& Button.setOnClick
121-
( screen
122-
$ if isQrCode sc
123-
then Main
124-
else QrCode sc
120+
$ [ Currency.selectCurrency
121+
Currency.Args
122+
{ Currency.argsModel = st,
123+
Currency.argsOptic =
124+
#modelState . #stDefAssetCurrency,
125+
Currency.argsAction =
126+
PushUpdate . Instant,
127+
Currency.argsCurrencies =
128+
#modelCurrencies
129+
}
130+
Currency.Opts
131+
{ Currency.optsExtraOnClick = (& #modelLoading .~ True)
132+
},
133+
Currency.selectCurrency
134+
Currency.Args
135+
{ Currency.argsModel = st,
136+
Currency.argsOptic =
137+
#modelState . #stPaymentMoney . #moneyCurrency,
138+
Currency.argsAction =
139+
PushUpdate . Instant,
140+
Currency.argsCurrencies =
141+
#modelCurrencies
142+
}
143+
Currency.Opts
144+
{ Currency.optsExtraOnClick = (& #modelLoading .~ True)
145+
},
146+
let item :| items = enumerateNE @OnlineOrOffline
147+
in Grid.mediumCell
148+
[ Select.outlined
149+
( Select.config
150+
& Select.setLabel
151+
( Just "Exchange rate"
152+
)
153+
& Select.setSelected
154+
( Just
155+
$ st
156+
^. #modelState
157+
. #stOnlineOrOffline
158+
)
159+
& Select.setOnChange
160+
( \x ->
161+
PushUpdate
162+
. Instant
163+
$ pure
164+
. ( &
165+
#modelState
166+
. #stOnlineOrOffline
167+
.~ x
168+
)
169+
)
170+
)
171+
( SelectItem.selectItem
172+
(SelectItem.config item)
173+
[text $ inspect item]
174+
)
175+
$ fmap
176+
( \x ->
177+
SelectItem.selectItem
178+
(SelectItem.config x)
179+
[text $ inspect x]
125180
)
126-
& Button.setIcon
127-
( Just
128-
$ if isQrCode sc
129-
then "local_shipping"
130-
else "qr_code_2"
131-
)
132-
& Button.setAttributes
133-
[ Theme.secondaryBg,
134-
Css.fullWidth
135-
]
136-
)
137-
$ if isQrCode sc
138-
then "Delivery Calculator"
139-
else "QR"
140-
],
141-
Grid.mediumCell
142-
[ Field.textField
143-
Field.Args
144-
{ Field.argsModel = st,
145-
Field.argsOptic = #modelState . #stPreview,
146-
Field.argsAction = PushUpdate . Instant
147-
}
148-
( Field.defOpts @Model @Action
149-
& #optsPlaceholder
150-
.~ ("QR title" :: Unicode)
151-
& #optsFilledOrOutlined
152-
.~ Outlined
153-
)
154-
],
181+
items
182+
],
155183
Grid.mediumCell
156184
[ Field.ratioField
157185
Field.Args
@@ -181,6 +209,44 @@ menu st =
181209
& #optsFilledOrOutlined
182210
.~ Outlined
183211
)
212+
],
213+
Grid.mediumCell
214+
[ Field.textField
215+
Field.Args
216+
{ Field.argsModel = st,
217+
Field.argsOptic = #modelState . #stPreview,
218+
Field.argsAction = PushUpdate . Instant
219+
}
220+
( Field.defOpts @Model @Action
221+
& #optsPlaceholder
222+
.~ ("QR title" :: Unicode)
223+
& #optsFilledOrOutlined
224+
.~ Outlined
225+
)
226+
],
227+
Grid.mediumCell
228+
[ Button.raised
229+
( Button.config
230+
& Button.setOnClick
231+
( screen
232+
$ if isQrCode sc
233+
then Main
234+
else QrCode sc
235+
)
236+
& Button.setIcon
237+
( Just
238+
$ if isQrCode sc
239+
then "local_shipping"
240+
else "qr_code_2"
241+
)
242+
& Button.setAttributes
243+
[ Theme.secondaryBg,
244+
Css.fullWidth
245+
]
246+
)
247+
$ if isQrCode sc
248+
then "Delivery Calculator"
249+
else "QR"
184250
]
185251
]
186252
<> linksWidget st
@@ -238,7 +304,10 @@ linksWidget st =
238304
( Button.config
239305
& Button.setOnClick openWidget
240306
& Button.setIcon (Just "android")
241-
& Button.setAttributes [Css.fullWidth]
307+
& Button.setAttributes
308+
[ Css.fullWidth,
309+
Theme.secondaryBg
310+
]
242311
)
243312
"App"
244313
]

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

Lines changed: 17 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -5,14 +5,24 @@ where
55

66
import App.Types
77
import Functora.Miso.Prelude
8+
import qualified Functora.Rates as Rates
9+
import qualified Functora.Web as Web
810

9-
newModel :: (MonadThrow m, MonadUnliftIO m) => Maybe Model -> URI -> m Model
10-
newModel mSt uri = do
11+
newModel ::
12+
( MonadThrow m,
13+
MonadUnliftIO m
14+
) =>
15+
Web.Opts ->
16+
Maybe Model ->
17+
URI ->
18+
m Model
19+
newModel webOpts mSt uri = do
1120
prod <- liftIO newBroadcastTChanIO
1221
cons <- liftIO . atomically $ dupTChan prod
1322
defSt <- maybe (liftIO newSt) pure $ mSt ^? _Just . #modelState
1423
mApp <- unShareUri uri
1524
donate <- newDonateViewer
25+
market <- maybe Rates.newMarket pure $ mSt ^? _Just . #modelMarket
1626
pure
1727
Model
1828
{ modelFav = Closed,
@@ -24,7 +34,11 @@ newModel mSt uri = do
2434
modelUriViewer = mempty,
2535
modelDonateViewer = donate,
2636
modelProducerQueue = prod,
27-
modelConsumerQueue = cons
37+
modelConsumerQueue = cons,
38+
modelCurrencies =
39+
fromMaybe [btc, usd, rub, cny] (mSt ^? _Just . #modelCurrencies),
40+
modelWebOpts = webOpts,
41+
modelMarket = market
2842
}
2943

3044
newDonateViewer :: (MonadIO m) => m [FieldPair DynamicField Unique]

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

Lines changed: 49 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,10 @@ import qualified Data.Generics as Syb
2323
import qualified Data.Map as Map
2424
import qualified Functora.Miso.Jsm as Jsm
2525
import Functora.Miso.Prelude
26+
import qualified Functora.Money as Money
2627
import qualified Functora.Prelude as Prelude
28+
import qualified Functora.Rates as Rates
29+
import qualified Functora.Web as Web
2730
import Language.Javascript.JSaddle ((!), (!!))
2831
import qualified Language.Javascript.JSaddle as JS
2932
import qualified Miso
@@ -43,7 +46,8 @@ main =
4346
$ do
4447
uri <- URI.mkURI . inspect =<< getCurrentURI
4548
mSt <- unShareUri uri
46-
st <- newModel Nothing uri
49+
web <- getWebOpts
50+
st <- newModel web Nothing uri
4751
startApp
4852
App
4953
{ model = st,
@@ -56,6 +60,15 @@ main =
5660
logLevel = Off
5761
}
5862

63+
getWebOpts :: JSM Web.Opts
64+
getWebOpts = do
65+
#ifdef wasi_HOST_OS
66+
ctx <- JS.askJSM
67+
pure $ Web.defOpts ctx
68+
#else
69+
pure Web.defOpts
70+
#endif
71+
5972
#if !defined(__GHCJS__) && !defined(ghcjs_HOST_OS) && !defined(wasi_HOST_OS)
6073
runApp :: JSM () -> IO ()
6174
runApp app = do
@@ -133,7 +146,7 @@ updateModel (InitUpdate ext) prevSt = do
133146
. (& #modelFavMap %~ fav)
134147
. (& #modelLoading .~ False)
135148
Just uri -> do
136-
finSt <- newModel (Just nextSt) uri
149+
finSt <- newModel (nextSt ^. #modelWebOpts) (Just nextSt) uri
137150
Misc.pushActionQueue nextSt
138151
$ Instant
139152
( const
@@ -287,12 +300,40 @@ syncInputs st = do
287300
unless elActive $ el ^. JS.jss ("value" :: Unicode) (txt ^. #uniqueValue)
288301
pure txt
289302

290-
evalModel :: (MonadThrow m) => Model -> m Model
291-
evalModel st@Model {} =
292-
--
293-
-- TODO !!!!
294-
--
295-
pure st
303+
evalModel :: (MonadThrow m, MonadUnliftIO m) => Model -> m Model
304+
evalModel raw = do
305+
let oof = raw ^. #modelState . #stOnlineOrOffline
306+
new <-
307+
case oof of
308+
Online ->
309+
Syb.everywhereM
310+
( Syb.mkM $ \cur ->
311+
Rates.withMarket (raw ^. #modelWebOpts) (raw ^. #modelMarket)
312+
. fmap (fromRight cur)
313+
. Rates.tryMarket
314+
. Rates.getCurrencyInfo (raw ^. #modelWebOpts)
315+
$ Money.currencyInfoCode cur
316+
)
317+
( raw ^. #modelState
318+
)
319+
Offline ->
320+
pure $ raw ^. #modelState
321+
curs <-
322+
case oof of
323+
Online ->
324+
Rates.withMarket (raw ^. #modelWebOpts) (raw ^. #modelMarket)
325+
. fmap (fromRight $ raw ^. #modelCurrencies)
326+
. Rates.tryMarket
327+
. fmap (^. #currenciesList)
328+
$ Rates.getCurrencies (raw ^. #modelWebOpts)
329+
Offline ->
330+
pure $ raw ^. #modelCurrencies
331+
pure
332+
$ raw
333+
& #modelState
334+
.~ new
335+
& #modelCurrencies
336+
.~ curs
296337

297338
syncUri :: URI -> JSM ()
298339
syncUri uri = do

0 commit comments

Comments
 (0)