WIP

functora · functora · commit 24db52d47836 · 2024-09-20T13:41:04.000-03:00
diff --git a/ghcjs/delivery-calculator/delivery-calculator.cabal b/ghcjs/delivery-calculator/delivery-calculator.cabal
@@ -105,6 +105,7 @@ common pkg
     , functora-ghcjs
     , fuzzy
     , jsaddle
+    , microlens
     , miso
     , miso-components
     , miso-widgets
diff --git a/ghcjs/delivery-calculator/src/App/Types.hs b/ghcjs/delivery-calculator/src/App/Types.hs
@@ -9,6 +9,7 @@ module App.Types
     Asset (..),
     newAsset,
     newFieldPair,
+    newFieldPairId,
     Screen (..),
     isQrCode,
     unQrCode,
@@ -37,7 +38,12 @@ import Data.Functor.Barbie
 import qualified Data.Version as Version
 import Functora.Cfg
 import Functora.Miso.Prelude
-import Functora.Miso.Types as X hiding (Asset (..), newAsset, newFieldPair)
+import Functora.Miso.Types as X hiding
+  ( Asset (..),
+    newAsset,
+    newFieldPair,
+    newFieldPairId,
+  )
 import qualified Functora.Miso.Types as FM
 import Functora.Money hiding (Currency, Money, Text)
 import qualified Functora.Prelude as Prelude
@@ -77,7 +83,7 @@ data St f = St
     stExchangeRateAt :: UTCTime,
     stMerchantCurrency :: Currency f,
     stMerchantTele :: Field Unicode f,
-    stMerchantFeePercent :: Field Rational f,
+    stMerchantFeePercent :: Field DynamicField f,
     stOnlineOrOffline :: OnlineOrOffline,
     stFavName :: Field Unicode f,
     stPreview :: Field Unicode f,
@@ -106,7 +112,7 @@ newSt = do
   ct <- getCurrentTime
   merchantCur <- newCurrency rub
   tele <- newTextField "Functora"
-  fee <- newRatioField 2
+  fee <- newDynamicField $ DynamicFieldNumber 2
   fav <- newTextField mempty
   pre <- newTextField "Delivery Calculator"
   pure
@@ -117,7 +123,7 @@ newSt = do
         stExchangeRateAt = ct,
         stMerchantCurrency = merchantCur,
         stMerchantTele = tele,
-        stMerchantFeePercent = fee,
+        stMerchantFeePercent = fee & #fieldType .~ FieldTypePercent,
         stOnlineOrOffline = Online,
         stFavName = fav,
         stPreview = pre & #fieldType .~ FieldTypeTitle,
@@ -153,7 +159,7 @@ newAsset = do
     newFieldPair "Photo"
       $ DynamicFieldText "https://bitcoin.org/img/home/bitcoin-img.svg?1725887272"
   price <-
-    newFieldPair "Price" $ DynamicFieldNumber 0
+    newFieldPair "Price" $ DynamicFieldNumber 10
   qty <-
     newFieldPair "Quantity" $ DynamicFieldNumber 1
   pure
@@ -177,6 +183,17 @@ newFieldPair key val = do
     . #fieldOptsQrState
     .~ Nothing
 
+newFieldPairId ::
+  Unicode ->
+  DynamicField ->
+  FieldPair DynamicField Identity
+newFieldPairId key val = do
+  FM.newFieldPairId key val
+    & #fieldPairValue
+    . #fieldOpts
+    . #fieldOptsQrState
+    .~ Nothing
+
 data Screen
   = Main
   | Donate
@@ -218,10 +235,19 @@ stQuery st = do
 
 stTeleUri :: (MonadThrow m) => Model -> m URI
 stTeleUri st = do
-  base <- URI.mkURI "https://t.me"
-  user <- URI.mkPathPiece $ st ^. #modelState . #stMerchantTele . #fieldOutput
-  link <- stUri st
-  key <- URI.mkQueryKey "text"
+  base <-
+    URI.mkURI "https://t.me"
+  user <-
+    URI.mkPathPiece
+      . from @Unicode @Text
+      $ st
+      ^. #modelState
+      . #stMerchantTele
+      . #fieldOutput
+  link <-
+    stUri st
+  key <-
+    URI.mkQueryKey "text"
   val <-
     URI.mkQueryValue
       $ "Hello, I have a question about the delivery of the following items: "
diff --git a/ghcjs/delivery-calculator/src/App/Widgets/Asset.hs b/ghcjs/delivery-calculator/src/App/Widgets/Asset.hs
@@ -6,6 +6,7 @@ where
 import qualified App.Misc as Misc
 import App.Types
 import qualified Functora.Miso.Css as Css
+import qualified Functora.Miso.Jsm as Jsm
 import Functora.Miso.Prelude
 import qualified Functora.Miso.Widgets.FieldPairs as FieldPairs
 import qualified Functora.Miso.Widgets.Grid as Grid
@@ -38,7 +39,6 @@ assetViewer st idx =
         )
         "settings"
     ]
-    <> FieldPairs.fieldPairsViewer args
     <> ( if st ^? cloneTraversal modalOptic /= Just Opened
           then mempty
           else
@@ -51,27 +51,46 @@ assetViewer st idx =
                     Nothing
                     [ Grid.grid
                         mempty
-                        $ ( FieldPairs.fieldPairsEditor
+                        $ Header.headerViewer title mempty
+                        <> ( FieldPairs.fieldPairsEditor
                               args
                               $ FieldPairs.defOpts
                               & #optsAdvanced
                               .~ False
-                          )
-                        <> [ Grid.bigCell
+                           )
+                        <> [ Grid.mediumCell
+                              [ Button.raised
+                                  ( Button.config
+                                      & Button.setIcon (Just "delete_forever")
+                                      & Button.setAttributes [Css.fullWidth]
+                                      & Button.setOnClick
+                                        ( PushUpdate
+                                            . Instant
+                                            $ Jsm.removeAt
+                                              ( #modelState
+                                                  . #stAssets
+                                              )
+                                              idx
+                                        )
+                                  )
+                                  "Remove"
+                              ],
+                             Grid.mediumCell
                               [ Button.raised
                                   ( Button.config
                                       & Button.setOnClick closeAction
-                                      & Button.setIcon (Just "arrow_back")
+                                      & Button.setIcon (Just "save")
                                       & Button.setAttributes [Css.fullWidth]
                                   )
-                                  "Back"
+                                  "Save"
                               ]
                            ]
                     ]
                     mempty
                 )
             ]
        )
+    <> FieldPairs.fieldPairsViewer args
   where
     args =
       FieldPairs.Args
diff --git a/ghcjs/delivery-calculator/src/App/Widgets/Main.hs b/ghcjs/delivery-calculator/src/App/Widgets/Main.hs
@@ -1,4 +1,4 @@
-module App.Widgets.Main (mainWidget, pasteWidget) where
+module App.Widgets.Main (mainWidget) where
 
 import qualified App.Misc as Misc
 import App.Types
@@ -12,6 +12,8 @@ import qualified Functora.Miso.Widgets.Field as Field
 import qualified Functora.Miso.Widgets.FieldPairs as FieldPairs
 import qualified Functora.Miso.Widgets.Grid as Grid
 import qualified Functora.Miso.Widgets.Header as Header
+import qualified Functora.Money as Money
+import Lens.Micro ((^..))
 import qualified Material.Button as Button
 import qualified Material.LayoutGrid as LayoutGrid
 import qualified Material.Theme as Theme
@@ -106,8 +108,19 @@ screenWidget st@Model {modelState = St {stScreen = Donate}} =
           ]
        ]
 screenWidget st@Model {modelState = St {stScreen = Main}} =
-  Asset.assetsViewer st
-    <> [ Grid.mediumCell
+  ( if null assets
+      then mempty
+      else buttons
+  )
+    <> Asset.assetsViewer st
+    <> totalViewer st
+    <> buttons
+  where
+    assets :: [View Action]
+    assets = Asset.assetsViewer st
+    buttons :: [View Action]
+    buttons =
+      [ Grid.mediumCell
           [ Button.raised
               ( Button.config
                   & Button.setIcon (Just "add_box")
@@ -120,7 +133,7 @@ screenWidget st@Model {modelState = St {stScreen = Main}} =
               )
               "Add item"
           ],
-         Grid.mediumCell
+        Grid.mediumCell
           [ Button.raised
               ( Button.config
                   & Button.setIcon (Just "send")
@@ -133,30 +146,92 @@ screenWidget st@Model {modelState = St {stScreen = Main}} =
               )
               "Order via Telegram"
           ]
-       ]
+      ]
+
+totalViewer :: Model -> [View Action]
+totalViewer st =
+  if base == 0
+    then mempty
+    else
+      Header.headerViewer "Total" mempty
+        <> FieldPairs.fieldPairsViewer
+          FieldPairs.Args
+            { FieldPairs.argsModel = st,
+              FieldPairs.argsOptic =
+                constTraversal
+                  [ newFieldPairId ("Subtotal " <> baseCur)
+                      . DynamicFieldText
+                      $ inspectRatioDef base,
+                    newFieldPairId ("Subtotal " <> quoteCur)
+                      . DynamicFieldText
+                      $ inspectRatioDef quote,
+                    FieldPair (newTextFieldId "Fee %")
+                      $ uniqueToIdentity fee
+                      & #fieldOpts
+                      . #fieldOptsQrState
+                      .~ Nothing,
+                    newFieldPairId ("Total " <> quoteCur)
+                      . DynamicFieldText
+                      . inspectRatioDef
+                      . foldField quote
+                      $ fee
+                  ],
+              FieldPairs.argsAction = PushUpdate . Instant,
+              FieldPairs.argsEmitter = Misc.pushActionQueue st . Instant
+            }
+  where
+    fee = st ^. #modelState . #stMerchantFeePercent
+    rate = st ^. #modelState . #stExchangeRate . #fieldOutput
+    base =
+      foldl
+        ( \acc fps ->
+            if any
+              ((== FieldTypeNumber) . (^. #fieldPairValue . #fieldType))
+              fps
+              then acc + foldl foldFieldPair 1 fps
+              else acc
+        )
+        0
+        ( st
+            ^.. #modelState
+              . #stAssets
+              . each
+              . #assetFieldPairs
+        )
+    quote =
+      rate * base
+    baseCur =
+      st
+        ^. #modelState
+        . #stAssetCurrency
+        . #currencyOutput
+        . #currencyInfoCode
+        . to Money.inspectCurrencyCode
+        . to toUpper
+    quoteCur =
+      st
+        ^. #modelState
+        . #stMerchantCurrency
+        . #currencyOutput
+        . #currencyInfoCode
+        . to Money.inspectCurrencyCode
+        . to toUpper
+
+foldField :: Rational -> Field DynamicField f -> Rational
+foldField acc Field {fieldType = typ, fieldOutput = out} =
+  case out of
+    DynamicFieldNumber x
+      | typ == FieldTypeNumber ->
+          acc * x
+    DynamicFieldNumber x
+      | typ == FieldTypePercent ->
+          acc * (1 + (x / 100))
+    _ ->
+      acc
 
-pasteWidget ::
-  Unicode ->
-  ((Maybe Unicode -> JSM ()) -> JSM ()) ->
-  ATraversal' Model (Field Unicode Unique) ->
-  Maybe (Field.OptsWidget Model Action)
-pasteWidget icon selector optic =
-  Just
-    . Field.ActionWidget icon mempty
-    . PushUpdate
-    . Instant
-    $ \prev -> do
-      selector $ \case
-        Nothing ->
-          Jsm.popupText @Unicode "Failure!"
-        Just res -> do
-          Misc.pushActionQueue prev
-            . Instant
-            $ pure
-            . (& cloneTraversal optic . #fieldOutput .~ res)
-            . (& cloneTraversal optic . #fieldInput . #uniqueValue .~ res)
-          Jsm.popupText @Unicode "Success!"
-      pure prev
+foldFieldPair :: Rational -> FieldPair DynamicField f -> Rational
+foldFieldPair acc =
+  foldField acc . fieldPairValue
 
 tosWidget :: View Action
 tosWidget =
diff --git a/ghcjs/delivery-calculator/src/App/Widgets/Menu.hs b/ghcjs/delivery-calculator/src/App/Widgets/Menu.hs
@@ -244,7 +244,7 @@ menu st =
                               )
                           ],
                         Grid.mediumCell
-                          [ Field.ratioField
+                          [ Field.dynamicField
                               Field.Args
                                 { Field.argsModel = st,
                                   Field.argsOptic =
diff --git a/ghcjs/delivery-calculator/static/logo.png b/ghcjs/delivery-calculator/static/logo.png
diff --git a/ghcjs/miso-widgets/src/Functora/Miso/Types.hs b/ghcjs/miso-widgets/src/Functora/Miso/Types.hs
@@ -14,6 +14,7 @@ module Functora.Miso.Types
     newFieldId,
     newRatioField,
     newTextField,
+    newTextFieldId,
     newPasswordField,
     newDynamicField,
     newDynamicFieldId,
@@ -197,6 +198,10 @@ newTextField :: (MonadIO m) => Unicode -> m (Field Unicode Unique)
 newTextField output =
   newField FieldTypeText output id
 
+newTextFieldId :: Unicode -> Field Unicode Identity
+newTextFieldId output =
+  newFieldId FieldTypeText id output
+
 newPasswordField :: (MonadIO m) => Unicode -> m (Field Unicode Unique)
 newPasswordField output =
   newField FieldTypePassword output id

Original file line number	Diff line number	Diff line change
`@@ -244,7 +244,7 @@ menu st =`
`244`	`244`	`)`
`245`	`245`	`],`
`246`	`246`	`Grid.mediumCell`
`247`		`- [ Field.ratioField`
	`247`	`+ [ Field.dynamicField`
`248`	`248`	`Field.Args`
`249`	`249`	`{ Field.argsModel = st,`
`250`	`250`	`Field.argsOptic =`