diff --git a/marlowe-dashboard-client/src/Forms.purs b/marlowe-dashboard-client/src/Forms.purs index 44ea9a0df8..b153d31f2e 100644 --- a/marlowe-dashboard-client/src/Forms.purs +++ b/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 diff --git a/marlowe-dashboard-client/src/Halogen/Form.purs b/marlowe-dashboard-client/src/Halogen/Form.purs index 8536916268..f2122a44f4 100644 --- a/marlowe-dashboard-client/src/Halogen/Form.purs +++ b/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,10 +135,9 @@ 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 @@ -147,7 +145,7 @@ runForm => 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 diff --git a/marlowe-dashboard-client/src/Halogen/Form/FormM.purs b/marlowe-dashboard-client/src/Halogen/Form/FormM.purs index 6bc7ec28b1..c80aeb3a6f 100644 --- a/marlowe-dashboard-client/src/Halogen/Form/FormM.purs +++ b/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,10 +59,7 @@ 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 @@ -77,11 +67,3 @@ instance MonadState s m => MonadState s (FormM i m) where 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