wip

Author: functora

ghcjs/miso-functora/src/Functora/Miso/Types.hs

@@ -213,7 +213,6 @@ newDynamicField output =
     ( case output of
         DynamicFieldText {} -> FieldTypeText
         DynamicFieldNumber {} -> FieldTypeNumber
-        DynamicFieldRfc2397 {} -> FieldTypeImage
     )
     output
     inspectDynamicField
@@ -224,7 +223,6 @@ newDynamicFieldId output =
     ( case output of
         DynamicFieldText {} -> FieldTypeText
         DynamicFieldNumber {} -> FieldTypeNumber
-        DynamicFieldRfc2397 {} -> FieldTypeImage
     )
     inspectDynamicField
     output
@@ -239,7 +237,6 @@ newDynamicTitleField =
 data DynamicField
   = DynamicFieldText Unicode
   | DynamicFieldNumber Rational
-  | DynamicFieldRfc2397 (Maybe Unicode) Rfc2397
   deriving stock (Eq, Ord, Show, Data, Generic)
   deriving (Binary) via GenericType DynamicField
 
@@ -256,20 +253,12 @@ parseDynamic value str =
   case value ^. #fieldType of
     FieldTypeNumber -> DynamicFieldNumber <$> parseRatio str
     FieldTypePercent -> DynamicFieldNumber <$> parseRatio str
-    FieldTypeImage -> do
-      let mVal = decodeRfc2397 str
-      let mRef = case value ^. #fieldOutput of
-            DynamicFieldRfc2397 ref val | mVal == Just val -> ref
-            _ -> Nothing
-      fmap (DynamicFieldRfc2397 mRef) mVal <|> Just (DynamicFieldText str)
-    _ ->
-      Just $ DynamicFieldText str
+    _ -> Just $ DynamicFieldText str
 
 inspectDynamicField :: DynamicField -> Unicode
 inspectDynamicField = \case
   DynamicFieldText x -> x
   DynamicFieldNumber x -> inspectRatioDef x
-  DynamicFieldRfc2397 _ x -> encodeRfc2397 x
 
 data FieldType
   = -- Rational

ghcjs/miso-functora/src/Functora/Miso/Widgets/Field.hs

@@ -27,7 +27,6 @@ import qualified Functora.Miso.Widgets.Qr as Qr
 import qualified Functora.Miso.Widgets.Select as Select
 import qualified Language.Javascript.JSaddle as JS
 import qualified Miso.String as MS
-import Type.Reflection
 
 data Args model action t f = Args
   { argsModel :: model,
@@ -121,9 +120,6 @@ data ModalWidget' model where
     ModalWidget' model
 
 field ::
-  forall model action t.
-  ( Typeable t
-  ) =>
   Full model action t Unique ->
   Opts model action ->
   [View action]
@@ -157,20 +153,12 @@ field full@Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts
       (optsLabel opts)
       ( ( if typ == FieldTypeImage
             then do
-              out <- maybeToList $ st ^? cloneTraversal optic . #fieldOutput
               src <-
-                case typeRep @t `eqTypeRep` typeRep @DynamicField of
-                  Nothing ->
-                    maybeToList
-                      $ st
-                      ^? cloneTraversal optic
-                      . #fieldInput
-                      . #uniqueValue
-                  Just HRefl ->
-                    case out of
-                      DynamicFieldRfc2397 (Just ref) _ -> [ref]
-                      DynamicFieldRfc2397 {} -> mempty
-                      _ -> [inspectDynamicField out]
+                maybeToList
+                  $ st
+                  ^? cloneTraversal optic
+                  . #fieldInput
+                  . #uniqueValue
               if null src
                 then mempty
                 else
@@ -349,8 +337,6 @@ passwordField args opts =
     )
 
 fieldIcon ::
-  ( Typeable t
-  ) =>
   Full model action t Unique ->
   Opts model action ->
   OptsWidget model action ->
@@ -600,8 +586,7 @@ selectTypeWidget args@Args {argsAction = action} optic =
 -- TODO : support optional copying widgets
 --
 fieldViewer ::
-  ( Typeable t,
-    Foldable1 f
+  ( Foldable1 f
   ) =>
   Opts model action ->
   Args model action t f ->
@@ -657,9 +642,7 @@ header txt =
       ]
 
 genericFieldViewer ::
-  forall model action t f.
-  ( Typeable t,
-    Foldable1 f
+  ( Foldable1 f
   ) =>
   Opts model action ->
   Args model action t f ->
@@ -676,20 +659,11 @@ genericFieldViewer opts0 args widget =
         <> ( optsLeftRightViewer
               opts0
               ( if typ == FieldTypeImage
-                  then do
-                    out <- maybeToList $ st ^? cloneTraversal optic . #fieldOutput
-                    src <-
-                      case typeRep @t `eqTypeRep` typeRep @DynamicField of
-                        Nothing -> [input]
-                        Just HRefl ->
-                          case out of
-                            DynamicFieldRfc2397 (Just ref) _ -> [ref]
-                            DynamicFieldRfc2397 {} -> mempty
-                            _ -> [inspectDynamicField out]
-                    if null src
+                  then
+                    if null input
                       then mempty
                       else
-                        [ img_ [loading_ "lazy", src_ src]
+                        [ img_ [loading_ "lazy", src_ input]
                         ]
                   else
                     [ widget
@@ -815,45 +789,27 @@ expandDynamicField x =
     out = x ^. #fieldOutput
 
 insertAction ::
-  forall model action t.
-  ( Typeable t
-  ) =>
   Full model action t Unique ->
   ((Maybe Unicode -> JSM ()) -> JSM ()) ->
   action
 insertAction Full {fullArgs = args, fullParser = parser} selector =
-  action . ImpureUpdate $ do
-    selector $ \case
-      Nothing -> Jsm.popupText @Unicode "Failure!"
-      Just inp -> do
-        let updateInput =
-              cloneTraversal optic
-                . #fieldInput
-                . #uniqueValue
-                .~ inp
-        case updateInput prev ^? cloneTraversal optic >>= parser of
-          Nothing -> Jsm.popupText @Unicode "Failure!"
-          Just out ->
-            emitter . ImpureUpdate $ do
-              Jsm.popupText @Unicode "Success!"
-              let updateOutput = cloneTraversal optic . #fieldOutput .~ out
-              case typeRep @t `eqTypeRep` typeRep @DynamicField of
-                Nothing -> pure $ updateInput . updateOutput
-                Just HRefl ->
-                  case out of
-                    DynamicFieldRfc2397 Just {} _ ->
-                      pure $ updateInput . updateOutput
-                    DynamicFieldRfc2397 Nothing val -> do
-                      ref <- Jsm.newBlobUrl inp
-                      pure
-                        $ updateInput
-                        . ( cloneTraversal optic
-                              . #fieldOutput
-                              .~ DynamicFieldRfc2397 (Just ref) val
-                          )
-                    _ ->
-                      pure $ updateInput . updateOutput
-    pure id
+  action . EffectUpdate . selector $ \case
+    Nothing -> Jsm.popupText @Unicode "Failure!"
+    Just inp -> do
+      let updateInput =
+            cloneTraversal optic
+              . #fieldInput
+              . #uniqueValue
+              .~ inp
+      case updateInput prev ^? cloneTraversal optic >>= parser of
+        Nothing -> Jsm.popupText @Unicode "Failure!"
+        Just out ->
+          emitter
+            . PureAndEffectUpdate
+              ( updateInput
+                  . (cloneTraversal optic . #fieldOutput .~ out)
+              )
+            $ Jsm.popupText @Unicode "Success!"
   where
     prev = args ^. #argsModel
     optic = args ^. #argsOptic