Remove StateT layer from FormM

marlowe-dashboard-client/src/Forms.purs

@@ -24,7 +24,7 @@ import Halogen as H
 import Halogen.Css (classNames)
 import Halogen.Form (Form)
 import Halogen.Form as Form
-import Halogen.Form.FormM (uniqueId, update)
+import Halogen.Form.FormM (update)
 import Halogen.HTML as HH
 import Halogen.HTML.Properties as HP
 import Halogen.Hooks as Hooks
@@ -96,7 +96,7 @@ inputAsync
   -> Validator m e String a
   -> (e -> String)
   -> Form (InputSlots s) m (AsyncInput String e a) a
-inputAsync baseId label validator renderError =
+inputAsync id label validator renderError =
   Form.form \(AsyncInput value remote) -> do
     remote' <- case remote of
       NotAsked -> do
@@ -121,7 +121,6 @@ inputAsync baseId label validator renderError =
 
   where
   mkResult value output error = do
-    id <- uniqueId baseId
     let
       componentInput =
         { value
@@ -146,7 +145,7 @@ input
   -> Validator m e String a
   -> (e -> String)
   -> Form (InputSlots s) m String a
-input baseId label validator renderError = Form.form \value -> do
+input id label validator renderError = Form.form \value -> do
   V result <- lift $ Validator.runValidator validator value
   case result of
     Left e ->
@@ -155,7 +154,6 @@ input baseId label validator renderError = Form.form \value -> do
       mkResult value (Just a) Nothing
   where
   mkResult value output error = do
-    id <- uniqueId baseId
     let
       componentInput =
         { value

marlowe-dashboard-client/src/Halogen/Form.purs

@@ -1,6 +1,7 @@
 -- TODO move this to its own library
 module Halogen.Form
   ( Form(..)
+  , FormHTML
   , FormResult
   , form
   , useForm
@@ -34,7 +35,7 @@ import Effect.Ref as Ref
 import Halogen as H
 import Halogen.Component (hoistSlot)
 import Halogen.Css as HC
-import Halogen.Form.FormM (FormF(..), FormM, FormState, hoistFormF)
+import Halogen.Form.FormM (FormF(..), FormM, hoistFormF)
 import Halogen.HTML as HH
 import Halogen.HTML.Events as HE
 import Halogen.Hooks (type (<>), Hook)
@@ -56,7 +57,7 @@ type FormEvalResult slots m input a =
 form
   :: forall s m i a
    . Functor m
-  => (i -> FormM i m (R (FormHTML input slots m) a))
+  => (i -> FormM i m (R (FormHTML i s m) a))
   -> Form s m i a
 form = Reporter <<< Star <<< map (MaybeT <<< WriterT <<< unwrap)
 
@@ -70,7 +71,7 @@ split f g = Tuple <$> subform _1 f <*> subform _2 g
 
 multiWithIndex
   :: forall slots m t index i a
-   . TraversableWithIndexe index t
+   . TraversableWithIndex index t
   => Index (t i) index i
   => Monad m
   => (index -> Form slots m i a)
@@ -107,10 +108,8 @@ mapFormResults f =
   in
     mapMaybeT
       ( mapWriterT
-          ( mapStateT
-              ( hoistFree adaptFormF <<< map
-                  (lmap (map (map (bimap (map f) f))))
-              )
+          ( hoistFree adaptFormF <<< map
+              (map (map (bimap (map f) f)))
           )
       )
 
@@ -136,18 +135,17 @@ hoistForm a =
     $ map
     $ mapMaybeT
     $ mapWriterT
-    $ mapStateT
     $ hoistFree (hoistFormF a) <<< map hoistR
   where
-  hoistR = lmap $ map $ map $ lmap $ hoistSlot a
+  hoistR = map $ map $ lmap $ hoistSlot a
 
 runForm
   :: forall s m i a
    . Functor m
   => Form s m i a
   -> i
   -> Free (FormF i m) (Tuple (Maybe a) (FormHTML i s m))
-runForm f = flip evalStateT mempty <<< Reporter.runReporter f
+runForm f = Reporter.runReporter f
 
 type UseForm slots m input output =
   Hooks.UseState input

marlowe-dashboard-client/src/Halogen/Form/FormM.purs

@@ -8,25 +8,18 @@ import Control.Monad.Free (Free, hoistFree, liftF)
 import Control.Monad.Free.Class (class MonadFree, wrapFree)
 import Control.Monad.Reader (class MonadAsk, class MonadReader, ask, local)
 import Control.Monad.Rec.Class (class MonadRec)
-import Control.Monad.State (class MonadState, StateT, gets, mapStateT, state)
+import Control.Monad.State (class MonadState, state)
 import Control.Monad.Trans.Class (class MonadTrans, lift)
 import Control.Monad.Writer (class MonadTell, tell)
-import Data.Lens (appendModifying)
-import Data.Map (SemigroupMap(..))
-import Data.Map as Map
-import Data.Maybe (Maybe(..))
-import Data.Monoid.Additive (Additive(..))
-import Data.Newtype (class Newtype, over, unwrap)
+import Data.Newtype (class Newtype, over)
 import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Class (class MonadEffect, liftEffect)
 
-type FormState = SemigroupMap String (Additive Int)
-
 data FormF input m a
   = Update input a
   | Lift (m a)
 
-newtype FormM input m a = FormM (StateT FormState (Free (FormF input m)) a)
+newtype FormM input m a = FormM (Free (FormF input m) a)
 
 derive instance Functor m => Functor (FormF input m)
 
@@ -48,7 +41,7 @@ derive newtype instance (Apply m, Semigroup a) => Semigroup (FormM i m a)
 derive newtype instance (Applicative m, Monoid a) => Monoid (FormM i m a)
 
 instance MonadTrans (FormM i) where
-  lift = FormM <<< lift <<< liftF <<< Lift
+  lift = FormM <<< liftF <<< Lift
 
 instance MonadEffect m => MonadEffect (FormM i m) where
   liftEffect = lift <<< liftEffect
@@ -66,22 +59,11 @@ instance MonadAsk r m => MonadAsk r (FormM i m) where
   ask = lift ask
 
 instance MonadReader r m => MonadReader r (FormM i m) where
-  local f =
-    over FormM
-      $ mapStateT
-      $ hoistFree (hoistFormF (local f))
+  local f = over FormM $ hoistFree (hoistFormF (local f))
 
 instance MonadState s m => MonadState s (FormM i m) where
   state = lift <<< state
 
 hoistFormF :: forall i m n. (m ~> n) -> FormF i m ~> FormF i n
 hoistFormF _ (Update i a) = Update i a
 hoistFormF a (Lift m) = Lift $ a m
-
-uniqueId :: forall i m. Monad m => String -> FormM i m String
-uniqueId candidate = FormM do
-  count <- gets $ Map.lookup candidate <<< unwrap
-  appendModifying identity (SemigroupMap (Map.singleton candidate (Additive 1)))
-  pure $ candidate <> case count of
-    Nothing -> ""
-    Just (Additive i) -> "-" <> show i