Skip to content

Commit 243297e

Browse files
functorafunctora
committed
wip
1 parent 8775227 commit 243297e

File tree

7 files changed

+133
-66
lines changed

7 files changed

+133
-66
lines changed

‎ghcjs/delivery-calculator/delivery-calculator.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ common pkg
2727
other-modules:
2828
App.Misc
2929
App.Types
30+
App.Widgets.Assets
3031
App.Widgets.Fav
3132
App.Widgets.Main
3233
App.Widgets.Menu

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

Lines changed: 32 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module App.Types
88
newSt,
99
Asset (..),
1010
newAsset,
11+
newFieldPair,
1112
Screen (..),
1213
isQrCode,
1314
unQrCode,
@@ -36,7 +37,8 @@ import Data.Functor.Barbie
3637
import qualified Data.Version as Version
3738
import Functora.Cfg
3839
import Functora.Miso.Prelude
39-
import Functora.Miso.Types as X hiding (Asset (..), newAsset)
40+
import Functora.Miso.Types as X hiding (Asset (..), newAsset, newFieldPair)
41+
import qualified Functora.Miso.Types as FM
4042
import Functora.Money hiding (Currency, Money, Text)
4143
import qualified Functora.Prelude as Prelude
4244
import qualified Functora.Rates as Rates
@@ -123,11 +125,8 @@ newSt = do
123125
}
124126

125127
data Asset f = Asset
126-
{ assetLink :: Field Unicode f,
127-
assetPhoto :: Field Unicode f,
128-
assetPrice :: Field Rational f,
129-
assetQty :: Field Rational f,
130-
assetOoc :: OpenedOrClosed
128+
{ assetFieldPairs :: [FieldPair DynamicField f],
129+
assetModalState :: OpenedOrClosed
131130
}
132131
deriving stock (Generic)
133132

@@ -147,19 +146,37 @@ deriving via GenericType (Asset Identity) instance Binary (Asset Identity)
147146

148147
newAsset :: (MonadIO m) => m (Asset Unique)
149148
newAsset = do
150-
link <- newTextField mempty
151-
photo <- newTextField mempty
152-
price <- newRatioField 0
153-
qty <- newRatioField 1
149+
link <-
150+
newFieldPair "Link"
151+
$ DynamicFieldText "https://bitcoin.org/en/"
152+
photo <-
153+
newFieldPair "Photo"
154+
$ DynamicFieldText "https://bitcoin.org/img/home/bitcoin-img.svg?1725887272"
155+
price <-
156+
newFieldPair "Price" $ DynamicFieldNumber 0
157+
qty <-
158+
newFieldPair "Quantity" $ DynamicFieldNumber 1
154159
pure
155160
Asset
156-
{ assetLink = link,
157-
assetPhoto = photo,
158-
assetPrice = price,
159-
assetQty = qty,
160-
assetOoc = Opened
161+
{ assetFieldPairs = [link, photo, price, qty],
162+
assetModalState = Opened
161163
}
162164

165+
newFieldPair ::
166+
( MonadIO m
167+
) =>
168+
Unicode ->
169+
DynamicField ->
170+
m (FieldPair DynamicField Unique)
171+
newFieldPair key val = do
172+
res <- FM.newFieldPair key val
173+
pure
174+
$ res
175+
& #fieldPairValue
176+
. #fieldOpts
177+
. #fieldOptsQrState
178+
.~ Nothing
179+
163180
data Screen
164181
= Main
165182
| Donate

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

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
module App.Widgets.Assets
2+
( assetsViewer,
3+
)
4+
where
5+
6+
import App.Types
7+
import Functora.Miso.Prelude
8+
import qualified Functora.Miso.Widgets.FieldPairs as FieldPairs
9+
10+
assetsViewer :: Model -> [View Action]
11+
assetsViewer st = do
12+
idx <- fmap fst . zip [0 ..] $ st ^. #modelState . #stAssets
13+
assetViewer st idx
14+
15+
assetViewer :: Model -> Int -> [View Action]
16+
assetViewer st idx =
17+
FieldPairs.fieldPairsViewer
18+
FieldPairs.Args
19+
{ FieldPairs.argsModel = st,
20+
FieldPairs.argsOptic = #modelState . #stAssets . ix idx . #assetFieldPairs,
21+
FieldPairs.argsAction = PushUpdate . Instant
22+
}

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

Lines changed: 30 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@ module App.Widgets.Main (mainWidget, pasteWidget) where
22

33
import qualified App.Misc as Misc
44
import App.Types
5+
import qualified App.Widgets.Assets as Assets
56
import qualified App.Widgets.Menu as Menu
67
import qualified Functora.Miso.Css as Css
78
import qualified Functora.Miso.Jsm as Jsm
@@ -101,34 +102,35 @@ screenWidget st@Model {modelState = St {stScreen = Donate}} =
101102
"Open"
102103
]
103104
]
104-
screenWidget Model {modelState = St {stScreen = Main}} =
105-
[ Grid.mediumCell
106-
[ Button.raised
107-
( Button.config
108-
& Button.setIcon (Just "add_box")
109-
& Button.setAttributes [Css.fullWidth]
110-
& Button.setOnClick
111-
( PushUpdate . Instant $ \st -> do
112-
asset <- newAsset
113-
pure $ st & #modelState . #stAssets %~ flip snoc asset
114-
)
115-
)
116-
"Add item"
117-
],
118-
Grid.mediumCell
119-
[ Button.raised
120-
( Button.config
121-
& Button.setIcon (Just "send")
122-
& Button.setAttributes [Css.fullWidth]
123-
& Button.setOnClick
124-
( PushUpdate
125-
. Instant
126-
$ \next -> flip Jsm.openBrowserPage next =<< stTeleUri next
127-
)
128-
)
129-
"Order via Telegram"
130-
]
131-
]
105+
screenWidget st@Model {modelState = St {stScreen = Main}} =
106+
Assets.assetsViewer st
107+
<> [ Grid.mediumCell
108+
[ Button.raised
109+
( Button.config
110+
& Button.setIcon (Just "add_box")
111+
& Button.setAttributes [Css.fullWidth]
112+
& Button.setOnClick
113+
( PushUpdate . Instant $ \next -> do
114+
asset <- newAsset
115+
pure $ next & #modelState . #stAssets %~ flip snoc asset
116+
)
117+
)
118+
"Add item"
119+
],
120+
Grid.mediumCell
121+
[ Button.raised
122+
( Button.config
123+
& Button.setIcon (Just "send")
124+
& Button.setAttributes [Css.fullWidth]
125+
& Button.setOnClick
126+
( PushUpdate
127+
. Instant
128+
$ \next -> flip Jsm.openBrowserPage next =<< stTeleUri next
129+
)
130+
)
131+
"Order via Telegram"
132+
]
133+
]
132134

133135
pasteWidget ::
134136
Unicode ->

‎ghcjs/delivery-calculator/test/App/TypesSpec.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ import App.Widgets.Templates
55
import qualified Data.Aeson as A
66
import qualified Data.Generics as Syb
77
import Functora.Miso.Prelude hiding (prop)
8+
import qualified Functora.Web as Web
89
import qualified Optics.Generic as Ops
910
import qualified Optics.Setter as Ops
1011
import Test.Hspec
@@ -55,8 +56,8 @@ spec = do
5556
-- $ over soplate fun expr
5657
-- `shouldBe` Mul (Sub (Lit 2) (Lit 3)) (Lit 4)
5758
it "serialization" $ do
58-
st0 <- newModel Nothing =<< URI.mkURI "http://localhost"
59+
st0 <- newModel Web.defOpts Nothing =<< URI.mkURI "http://localhost"
5960
uri <- stUri st0
60-
st1 <- newModel Nothing uri
61+
st1 <- newModel Web.defOpts Nothing uri
6162
(st0 ^. #modelState . to uniqueToIdentity)
6263
`shouldBe` (st1 ^. #modelState . to uniqueToIdentity)

‎ghcjs/miso-widgets/src/Functora/Miso/Types.hs‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,7 @@ module Functora.Miso.Types
4444
qsGet,
4545
uniqueToIdentity,
4646
identityToUnique,
47+
keyed,
4748
TopOrBottom (..),
4849
HeaderOrFooter (..),
4950
OnlineOrOffline (..),
@@ -61,6 +62,7 @@ import qualified Data.Generics as Syb
6162
import Functora.Cfg
6263
import Functora.Miso.Prelude
6364
import Functora.Money hiding (Currency, Money)
65+
import qualified Miso.Html.Types as Miso
6466
import qualified Text.URI as URI
6567

6668
type Typ a =
@@ -553,6 +555,25 @@ identityToUnique :: (TraversableB f, MonadIO m) => f Identity -> m (f Unique)
553555
identityToUnique =
554556
btraverse $ newUnique . runIdentity
555557

558+
keyed :: Uid -> View action -> View action
559+
keyed uid = \case
560+
Node x0 x1 Nothing x2 x3
561+
| not (nullUid uid) ->
562+
Node
563+
x0
564+
x1
565+
( Just
566+
. Miso.Key
567+
. either impureThrow id
568+
. decodeUtf8Strict
569+
. unTagged
570+
$ htmlUid uid
571+
)
572+
x2
573+
x3
574+
x ->
575+
x
576+
556577
data TopOrBottom
557578
= Top
558579
| Bottom

‎ghcjs/miso-widgets/src/Functora/Miso/Widgets/Field.hs‎

Lines changed: 24 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -129,9 +129,10 @@ field Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts =
129129
_ -> mempty
130130
fieldModal args x1
131131
)
132-
<> [ case opts ^. #optsFilledOrOutlined of
133-
Filled -> TextField.filled
134-
Outlined -> TextField.outlined
132+
<> [ keyed uid
133+
$ case opts ^. #optsFilledOrOutlined of
134+
Filled -> TextField.filled
135+
Outlined -> TextField.outlined
135136
$ TextField.config
136137
& TextField.setType
137138
( fmap htmlFieldType (st ^? cloneTraversal optic . #fieldType)
@@ -895,24 +896,26 @@ genericFieldViewer args widget =
895896
)
896897
)
897898
)
898-
<> ( do
899-
let icon = case stateQr of
900-
Closed -> "qr_code_2"
901-
Opened -> "grid_off"
902-
pure
903-
. fieldViewerIcon icon
904-
. action
905-
$ pure
906-
. ( &
907-
cloneTraversal optic
908-
. #fieldOpts
909-
. #fieldOptsQrState
910-
. _Just
911-
%~ ( \case
912-
Closed -> Opened
913-
Opened -> Closed
914-
)
915-
)
899+
<> ( if isNothing $ opts ^. #fieldOptsQrState
900+
then mempty
901+
else do
902+
let icon = case stateQr of
903+
Closed -> "qr_code_2"
904+
Opened -> "grid_off"
905+
pure
906+
. fieldViewerIcon icon
907+
. action
908+
$ pure
909+
. ( &
910+
cloneTraversal optic
911+
. #fieldOpts
912+
. #fieldOptsQrState
913+
. _Just
914+
%~ ( \case
915+
Closed -> Opened
916+
Opened -> Closed
917+
)
918+
)
916919
)
917920
<> ( if not allowCopy
918921
then mempty

0 commit comments

Comments
 (0)