Skip to content

Commit d386adc

Browse files
functorafunctora
committed
optimize contacts
1 parent 5e152ba commit d386adc

File tree

3 files changed

+84
-84
lines changed

3 files changed

+84
-84
lines changed

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

Lines changed: 10 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,8 @@ module App.Types
1414
newTotal,
1515
inspectExchangeRate,
1616
unShareUri,
17-
stUri,
17+
stShortUri,
18+
stLongUri,
1819
emitter,
1920
icon,
2021
vsn,
@@ -121,8 +122,8 @@ newSt = do
121122
rate <- newRatioField 1
122123
merchantCur <- newCurrency rub
123124
tele <- newTextField "Functora"
124-
whats <- newTextField "TODO"
125-
email <- newTextField "TODO"
125+
whats <- newTextField mempty
126+
email <- newTextField mempty
126127
fee <- newDynamicField $ DynamicFieldNumber 2
127128
pure
128129
St
@@ -406,6 +407,12 @@ foldFieldPair :: Rational -> FieldPair DynamicField f -> Rational
406407
foldFieldPair acc =
407408
foldField acc . fieldPairValue
408409

410+
stShortUri :: (MonadThrow m) => Model -> m URI
411+
stShortUri = stUri . (#modelState . #stAssets .~ mempty)
412+
413+
stLongUri :: (MonadThrow m) => Model -> m URI
414+
stLongUri = stUri
415+
409416
stUri :: (MonadThrow m) => Model -> m URI
410417
stUri st = do
411418
uri <- mkURI $ from @Unicode @Prelude.Text baseUri

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

Lines changed: 70 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -36,43 +36,22 @@ placeOrder st =
3636
Dialog.argsOptic = #modelPlaceOrder,
3737
Dialog.argsAction = PushUpdate,
3838
Dialog.argsContent =
39-
[ button_
40-
[ onClick
41-
. either impureThrow openBrowser
42-
$ teleUri st
43-
]
44-
[ icon Icon.IconTelegram,
45-
text " Telegram"
46-
],
47-
button_
48-
[ onClick
49-
. either impureThrow openBrowser
50-
$ whatsUri st
51-
]
52-
[ icon Icon.IconWhatsApp,
53-
text " WhatsApp"
54-
],
55-
button_
56-
[ onClick
57-
. either impureThrow openBrowser
58-
$ emailUri st
59-
]
60-
[ icon Icon.IconEmail,
61-
text " Email"
62-
],
63-
button_
64-
[ onClick . PushUpdate . EffectUpdate $ do
65-
let doc = st ^. #modelState
66-
imgs <- Jsm.fetchBlobUris doc
67-
file <- Xlsx.xlsxFile
68-
Jsm.saveFileShare file Xlsx.xlsxMime
69-
. from @BL.ByteString @ByteString
70-
$ Xlsx.newXlsx doc imgs
71-
]
72-
[ icon Icon.IconDownload,
73-
text " Share Excel file"
74-
]
75-
]
39+
teleBtn st
40+
<> whatsBtn st
41+
<> emailBtn st
42+
<> [ button_
43+
[ onClick . PushUpdate . EffectUpdate $ do
44+
let doc = st ^. #modelState
45+
imgs <- Jsm.fetchBlobUris doc
46+
file <- Xlsx.xlsxFile
47+
Jsm.saveFileShare file Xlsx.xlsxMime
48+
. from @BL.ByteString @ByteString
49+
$ Xlsx.newXlsx doc imgs
50+
]
51+
[ icon Icon.IconDownload,
52+
text " Share Excel file"
53+
]
54+
]
7655
}
7756

7857
openBrowser :: URI -> Action
@@ -81,16 +60,25 @@ openBrowser =
8160
. EffectUpdate
8261
. Jsm.openBrowserPage
8362

84-
teleUri :: (MonadThrow m) => Model -> m URI
85-
teleUri st = do
63+
teleBtn :: Model -> [View Action]
64+
teleBtn st =
65+
case st ^. #modelState . #stMerchantTele . #fieldOutput of
66+
user | null user -> mempty
67+
user ->
68+
[ button_
69+
[ onClick
70+
. either impureThrow openBrowser
71+
$ teleUri user
72+
]
73+
[ icon Icon.IconTelegram,
74+
text " Telegram"
75+
]
76+
]
77+
78+
teleUri :: (MonadThrow m) => Unicode -> m URI
79+
teleUri raw = do
8680
base <- URI.mkURI "https://t.me"
87-
user <-
88-
URI.mkPathPiece
89-
. from @Unicode @Text
90-
$ st
91-
^. #modelState
92-
. #stMerchantTele
93-
. #fieldOutput
81+
user <- URI.mkPathPiece $ from @Unicode @Text raw
9482
key <- URI.mkQueryKey "text"
9583
val <- URI.mkQueryValue placeOrderMessage
9684
pure
@@ -99,16 +87,25 @@ teleUri st = do
9987
URI.uriQuery = [URI.QueryParam key val]
10088
}
10189

102-
whatsUri :: (MonadThrow m) => Model -> m URI
103-
whatsUri st = do
90+
whatsBtn :: Model -> [View Action]
91+
whatsBtn st =
92+
case st ^. #modelState . #stMerchantWhats . #fieldOutput of
93+
user | null user -> mempty
94+
user ->
95+
[ button_
96+
[ onClick
97+
. either impureThrow openBrowser
98+
$ whatsUri user
99+
]
100+
[ icon Icon.IconWhatsApp,
101+
text " WhatsApp"
102+
]
103+
]
104+
105+
whatsUri :: (MonadThrow m) => Unicode -> m URI
106+
whatsUri raw = do
104107
base <- URI.mkURI "https://wa.me"
105-
user <-
106-
URI.mkPathPiece
107-
. from @Unicode @Text
108-
$ st
109-
^. #modelState
110-
. #stMerchantWhats
111-
. #fieldOutput
108+
user <- URI.mkPathPiece $ from @Unicode @Text raw
112109
key <- URI.mkQueryKey "text"
113110
val <- URI.mkQueryValue placeOrderMessage
114111
pure
@@ -117,15 +114,24 @@ whatsUri st = do
117114
URI.uriQuery = [URI.QueryParam key val]
118115
}
119116

120-
emailUri :: (MonadThrow m) => Model -> m URI
121-
emailUri st = do
122-
user <-
123-
URI.mkPathPiece
124-
. from @Unicode @Text
125-
$ st
126-
^. #modelState
127-
. #stMerchantEmail
128-
. #fieldOutput
117+
emailBtn :: Model -> [View Action]
118+
emailBtn st =
119+
case st ^. #modelState . #stMerchantEmail . #fieldOutput of
120+
user | null user -> mempty
121+
user ->
122+
[ button_
123+
[ onClick
124+
. either impureThrow openBrowser
125+
$ emailUri user
126+
]
127+
[ icon Icon.IconEmail,
128+
text " Email"
129+
]
130+
]
131+
132+
emailUri :: (MonadThrow m) => Unicode -> m URI
133+
emailUri raw = do
134+
user <- URI.mkPathPiece $ from @Unicode @Text raw
129135
base <- URI.mkURI $ "mailto:" <> URI.unRText user
130136
subjKey <- URI.mkQueryKey "subject"
131137
subjVal <- URI.mkQueryValue "Delivery Calculator"

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

Lines changed: 4 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,6 @@ import qualified Functora.Web as Web
2929
import Language.Javascript.JSaddle ((!))
3030
import qualified Language.Javascript.JSaddle as JS
3131
import qualified Miso
32-
import qualified Network.URI as URI (parseURI)
3332
import qualified Text.URI as URI
3433

3534
#ifdef wasi_HOST_OS
@@ -190,14 +189,14 @@ updateModel (EvalUpdate f) st = do
190189
. PushUpdate
191190
. PureUpdate
192191
$ unload
193-
uri <- stUri next
194-
Jsm.insertStorage ("current-" <> vsn) uri
195-
syncUri uri
192+
longUri <- stLongUri next
193+
Jsm.insertStorage ("current-" <> vsn) longUri
194+
shortUri <- stShortUri next
196195
uriViewer <-
197196
newFieldPair mempty
198197
. DynamicFieldText
199198
. from @String @Unicode
200-
$ URI.renderStr uri
199+
$ URI.renderStr shortUri
201200
pure
202201
. LinkUpdate
203202
$ #modelUriViewer
@@ -431,18 +430,6 @@ evalModel prev = do
431430
.~ rateValue
432431
)
433432

434-
syncUri :: URI -> JSM ()
435-
syncUri uri = do
436-
textUri <- fmap inspect getCurrentURI
437-
prevUri <- URI.mkURI textUri
438-
let nextUri = prevUri {URI.uriQuery = URI.uriQuery uri}
439-
when (nextUri /= prevUri)
440-
$ pushURI
441-
=<< ( maybe (throwString $ "Bad URI " <> textUri) pure
442-
. URI.parseURI
443-
$ URI.renderStr nextUri
444-
)
445-
446433
opfsSync :: (Action -> IO ()) -> Model -> JSM ()
447434
opfsSync sink st = do
448435
opfsRead sink st

0 commit comments

Comments
 (0)