Factor our FormM module

marlowe-dashboard-client/spago.dhall

@@ -23,7 +23,9 @@ You can edit this file as you like.
   , "foldable-traversable"
   , "foreign-object"
   , "formatters"
+  , "free"
   , "halogen"
+  , "halogen-hooks"
   , "halogen-store"
   , "halogen-subscriptions"
   , "http-methods"
@@ -37,18 +39,23 @@ You can edit this file as you like.
   , "partial"
   , "polyform"
   , "prelude"
+  , "profunctor"
   , "profunctor-lenses"
   , "psci-support"
+  , "refs"
   , "remotedata"
   , "servant-support"
   , "strings"
+  , "tailrec"
   , "transformers"
   , "tuples"
   , "unfoldable"
   , "unicode"
   , "uuid"
+  , "validation"
   , "web-common"
   , "web-dom"
+  , "web-events"
   , "web-html"
   , "web-socket"
   ]

marlowe-dashboard-client/src/Forms.purs

@@ -24,6 +24,7 @@ import Halogen as H
 import Halogen.Css (classNames)
 import Halogen.Form (Form)
 import Halogen.Form as Form
+import Halogen.Form.FormM (setInput, uniqueId)
 import Halogen.HTML as HH
 import Halogen.HTML.Properties as HP
 import Halogen.Hooks as Hooks
@@ -102,10 +103,10 @@ inputAsync baseId label validator renderError =
         case value of
           "" -> pure $ NotAsked
           _ -> do
-            Form.setInput (AsyncInput value Loading)
+            setInput (AsyncInput value Loading)
             V result <- lift $ Validator.runValidator validator value
             let newRemote = fromEither result
-            Form.setInput (AsyncInput value newRemote)
+            setInput (AsyncInput value newRemote)
             pure newRemote
       r -> pure r
     case remote' of
@@ -120,7 +121,7 @@ inputAsync baseId label validator renderError =
 
   where
   mkResult value output error = do
-    id <- Form.uniqueId baseId
+    id <- uniqueId baseId
     let
       componentInput =
         { value
@@ -154,7 +155,7 @@ input baseId label validator renderError = Form.form \value -> do
       mkResult value (Just a) Nothing
   where
   mkResult value output error = do
-    id <- Form.uniqueId baseId
+    id <- uniqueId baseId
     let
       componentInput =
         { value

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

@@ -1,54 +1,37 @@
 -- TODO move this to its own library
 module Halogen.Form
   ( Form(..)
-  , FormF
-  , FormM(..)
-  , FormState
   , FormResult
   , form
   , useForm
   , hoistForm
-  , nest
-  , setInput
   , split
   , subform
-  , uniqueId
   ) where
 
 import Prelude
 
-import Control.Monad.Error.Class (class MonadThrow, throwError)
-import Control.Monad.Free (Free, hoistFree, liftF, substFree)
+import Control.Monad.Free (Free, hoistFree, substFree)
 import Control.Monad.Maybe.Trans (MaybeT(..), mapMaybeT)
-import Control.Monad.Reader (class MonadAsk, class MonadReader, ask, local)
-import Control.Monad.Rec.Class (class MonadRec)
-import Control.Monad.State
-  ( class MonadState
-  , StateT
-  , evalStateT
-  , gets
-  , mapStateT
-  )
-import Control.Monad.Trans.Class (class MonadTrans, lift)
-import Control.Monad.Writer (WriterT(..), censor, mapWriterT)
+import Control.Monad.State (StateT, evalStateT, mapStateT)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Writer (WriterT(..), mapWriterT)
 import Data.Bifunctor (bimap, lmap)
 import Data.Foldable (for_)
-import Data.Lens (Lens', _1, _2, appendModifying, set, view)
-import Data.Map (SemigroupMap(..))
-import Data.Map as Map
+import Data.Lens (Lens', _1, _2, set, view)
 import Data.Maybe (Maybe(..))
-import Data.Monoid.Additive (Additive(..))
-import Data.Newtype (class Newtype, over, unwrap)
+import Data.Newtype (over, unwrap)
 import Data.Profunctor.Star (Star(..))
 import Data.Tuple (Tuple(..))
 import Effect.AVar (AVar)
 import Effect.Aff.AVar as AVar
 import Effect.Aff.Class (class MonadAff, liftAff)
-import Effect.Class (class MonadEffect, liftEffect)
+import Effect.Class (liftEffect)
 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.HTML as HH
 import Halogen.HTML.Events as HE
 import Halogen.Hooks (type (<>), Hook)
@@ -58,99 +41,20 @@ import Polyform.Reporter (R)
 import Polyform.Reporter as Reporter
 import Web.Event.Event (preventDefault)
 
-type FormState = SemigroupMap String (Additive Int)
-
 type Form slots m input a =
   Reporter
     (StateT FormState (Free (FormF input m)))
     (Array (H.ComponentHTML input slots m))
     input
     a
 
-data FormF input m a
-  = SetInput input a
-  | Lift (m a)
-
-derive instance functorFormF :: Functor m => Functor (FormF input m)
-
-newtype FormM :: forall k. k -> Type -> (Type -> Type) -> Type -> Type
-newtype FormM slots input m a =
-  FormM (StateT FormState (Free (FormF input m)) a)
-
-setInput :: forall s i m. i -> FormM s i m Unit
-setInput i = FormM $ lift $ liftF $ SetInput i unit
-
-derive instance newtypeFormM :: Newtype (FormM s i m a) _
-derive instance functorFormM :: Functor m => Functor (FormM s i m)
-derive newtype instance applyFormM :: Apply m => Apply (FormM s i m)
-derive newtype instance applicativeFormM ::
-  Applicative m =>
-  Applicative (FormM s i m)
-
-derive newtype instance bindFormM :: Bind m => Bind (FormM s i m)
-instance monadFormM :: Monad m => Monad (FormM s i m)
-derive newtype instance monadRecFormM :: MonadRec m => MonadRec (FormM s i m)
-
-derive newtype instance semigroupFormM ::
-  ( Apply m
-  , Semigroup a
-  ) =>
-  Semigroup (FormM s i m a)
-
-derive newtype instance monoidFormM ::
-  ( Applicative m
-  , Monoid a
-  ) =>
-  Monoid (FormM s i m a)
-
-instance monadTransFormM :: MonadTrans (FormM s i) where
-  lift = FormM <<< lift <<< liftF <<< Lift
-
-instance monadEffectFormM :: MonadEffect m => MonadEffect (FormM s i m) where
-  liftEffect = lift <<< liftEffect
-
-instance monadAffFormM :: MonadAff m => MonadAff (FormM s i m) where
-  liftAff = lift <<< liftAff
-
-instance monadThrowFormM :: MonadThrow e m => MonadThrow e (FormM s i m) where
-  throwError = lift <<< throwError
-
-instance monadAskFormM :: MonadAsk r m => MonadAsk r (FormM s i m) where
-  ask = lift ask
-
-instance monadReaderFormM :: MonadReader r m => MonadReader r (FormM s i m) where
-  local f =
-    over FormM
-      $ mapStateT
-      $ hoistFree (hoistFormF (local f))
-
-derive newtype instance monadStateFormM ::
-  Monad m =>
-  MonadState FormState (FormM sl i m)
-
-nest
-  :: forall s m i a
-   . Monad m
-  => (Array (H.ComponentHTML i s m) -> H.ComponentHTML i s m)
-  -> Form s m i a
-  -> Form s m i a
-nest parent = over Reporter $ over Star $ map $ censor (pure <<< parent)
-
 form
   :: forall s m i a
    . Functor m
   => (i -> FormM s i m (R (Array (H.ComponentHTML i s m)) a))
   -> Form s m i a
 form = Reporter <<< Star <<< map (MaybeT <<< WriterT <<< unwrap)
 
-uniqueId :: forall m. MonadState FormState m => String -> m String
-uniqueId candidate = 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
-
 split
   :: forall s m i j a b
    . Monad m
@@ -183,10 +87,6 @@ subform lens (Reporter (Star f)) = Reporter $ Star \i ->
       )
       (f (view lens i))
 
-hoistFormF :: forall i m n. (m ~> n) -> FormF i m ~> FormF i n
-hoistFormF _ (SetInput i a) = SetInput i a
-hoistFormF a (Lift m) = Lift $ a m
-
 hoistForm
   :: forall i s m1 m2 a
    . Functor m1
@@ -231,7 +131,6 @@ useForm
   :: forall s m i a
    . MonadAff m
   => Eq i
-  => Show i
   => Eq a
   => Form s m i a
   -> i

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

@@ -0,0 +1,98 @@
+-- TODO move this to its own library
+module Halogen.Form.FormM where
+
+import Prelude
+
+import Control.Monad.Error.Class (class MonadThrow, throwError)
+import Control.Monad.Free (Free, hoistFree, liftF)
+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)
+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 Effect.Aff.Class (class MonadAff, liftAff)
+import Effect.Class (class MonadEffect, liftEffect)
+
+type FormState = SemigroupMap String (Additive Int)
+
+data FormF input m a
+  = SetInput input a
+  | Lift (m a)
+
+derive instance functorFormF :: Functor m => Functor (FormF input m)
+
+newtype FormM :: forall k. k -> Type -> (Type -> Type) -> Type -> Type
+newtype FormM slots input m a =
+  FormM (StateT FormState (Free (FormF input m)) a)
+
+setInput :: forall s i m. i -> FormM s i m Unit
+setInput i = FormM $ lift $ liftF $ SetInput i unit
+
+derive instance newtypeFormM :: Newtype (FormM s i m a) _
+derive instance functorFormM :: Functor m => Functor (FormM s i m)
+derive newtype instance applyFormM :: Apply m => Apply (FormM s i m)
+derive newtype instance applicativeFormM ::
+  Applicative m =>
+  Applicative (FormM s i m)
+
+derive newtype instance bindFormM :: Bind m => Bind (FormM s i m)
+instance monadFormM :: Monad m => Monad (FormM s i m)
+derive newtype instance monadRecFormM :: MonadRec m => MonadRec (FormM s i m)
+
+derive newtype instance semigroupFormM ::
+  ( Apply m
+  , Semigroup a
+  ) =>
+  Semigroup (FormM s i m a)
+
+derive newtype instance monoidFormM ::
+  ( Applicative m
+  , Monoid a
+  ) =>
+  Monoid (FormM s i m a)
+
+instance monadTransFormM :: MonadTrans (FormM s i) where
+  lift = FormM <<< lift <<< liftF <<< Lift
+
+instance monadEffectFormM :: MonadEffect m => MonadEffect (FormM s i m) where
+  liftEffect = lift <<< liftEffect
+
+instance monadAffFormM :: MonadAff m => MonadAff (FormM s i m) where
+  liftAff = lift <<< liftAff
+
+instance monadThrowFormM :: MonadThrow e m => MonadThrow e (FormM s i m) where
+  throwError = lift <<< throwError
+
+instance monadtellFormM :: MonadTell w m => MonadTell w (FormM s i m) where
+  tell = lift <<< tell
+
+instance monadAskFormM :: MonadAsk r m => MonadAsk r (FormM s i m) where
+  ask = lift ask
+
+instance monadReaderFormM :: MonadReader r m => MonadReader r (FormM s i m) where
+  local f =
+    over FormM
+      $ mapStateT
+      $ hoistFree (hoistFormF (local f))
+
+derive newtype instance monadStateFormM ::
+  Monad m =>
+  MonadState FormState (FormM sl i m)
+
+uniqueId :: forall s i m. Monad m => String -> FormM s i m String
+uniqueId candidate = 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
+
+hoistFormF :: forall i m n. (m ~> n) -> FormF i m ~> FormF i n
+hoistFormF _ (SetInput i a) = SetInput i a
+hoistFormF a (Lift m) = Lift $ a m