Use Applicative on top of Monad for Forms

This is a completely different approach that merits further exploration.

Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>

hikaru.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: b5ce075070487e21e8dc52b2afc5f1995311580f4978d92703fc77c3208c217c
+-- hash: 00d0ac3f76ad05002c67411c92f1e77aeee6a21668bc86d354917560a1f0ae2f
 
 name:           hikaru
 version:        0.1.0.0
@@ -46,7 +46,7 @@ library
       Paths_hikaru
   hs-source-dirs:
       lib
-  default-extensions: ApplicativeDo BlockArguments DeriveGeneric FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving DataKinds
+  default-extensions: BlockArguments DeriveGeneric FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving DataKinds
   ghc-options: -Wall -Wcompat
   build-depends:
       aeson >=1.4 && <1.5

lib/Hikaru/Form.hs

@@ -6,23 +6,36 @@ License     :  AGPL-3
 Maintainer  :  mordae@anilinux.org
 Stability   :  unstable
 Portability :  non-portable (ghc)
+
+This module provides applicative form handling.
 -}
 
 module Hikaru.Form
-  ( FormView(..)
-  , FormElement(..)
+  ( View(..)
   , FormNote(..)
-  , FormT
   , Form
   , newForm
   , getForm
   , postForm
-  , button
   , inputField
+  , inputField'
   , hiddenField
-  , textField
+  , hiddenField'
+  , textArea
+  , textArea'
   , selectField
+  , selectField'
+  , selectFieldEnum
+  , selectFieldEnum'
   , multiSelectField
+  , multiSelectField'
+  , opt
+  , req
+  , addNote
+  , addAttribute
+  , fieldCheck
+  , fieldValue
+  , hasErrors
   )
 where
   import BasePrelude
@@ -31,49 +44,66 @@ where
   import Control.Monad.State
   import Data.Text (Text)
   import Hikaru.Action
+  import Hikaru.Localize
   import Hikaru.Types
+  import Lucid
 
 
-  data FormView l
-    = FormView
-      { formElements   :: [FormElement l]
-      , formNotes      :: [FormNote l]
-      }
+  -- Form Types --------------------------------------------------------------
 
 
-  data FormElement l
-    = HiddenField
-      { elemName       :: Text
-      , elemValue      :: Maybe Text
+  data View l
+    = FormFields
+      { viewFields     :: [View l]
+      , viewNotes      :: [FormNote l]
       }
-    | Button
-      { elemName       :: Text
-      , elemLabel      :: l
-      , elemAttrs      :: [(Text, Dynamic)]
+    | HiddenField
+      { viewName       :: Text
+      , viewValue      :: Maybe Text
+      , viewNotes      :: [FormNote l]
+      , viewAttrs      :: [(Text, Dynamic)]
       }
     | InputField
-      { elemName       :: Text
-      , elemLabel      :: l
-      , elemValue      :: Maybe Text
-      , elemNotes      :: [FormNote l]
-      , elemAttrs      :: [(Text, Dynamic)]
+      { viewName       :: Text
+      , viewLabel      :: l
+      , viewValue      :: Maybe Text
+      , viewNotes      :: [FormNote l]
+      , viewAttrs      :: [(Text, Dynamic)]
       }
-    | TextField
-      { elemName       :: Text
-      , elemLabel      :: l
-      , elemValue      :: Maybe Text
-      , elemNotes      :: [FormNote l]
-      , elemAttrs      :: [(Text, Dynamic)]
+    | TextArea
+      { viewName       :: Text
+      , viewLabel      :: l
+      , viewValue      :: Maybe Text
+      , viewNotes      :: [FormNote l]
+      , viewAttrs      :: [(Text, Dynamic)]
       }
     | SelectField
-      { elemName       :: Text
-      , elemLabel      :: l
-      , elemOptions    :: [(Text, l, Bool)]
-      , elemNotes      :: [FormNote l]
-      , elemAttrs      :: [(Text, Dynamic)]
-      , elemMulti      :: Bool
+      { viewName       :: Text
+      , viewLabel      :: l
+      , viewOptions    :: [(Text, l, Bool)]
+      , viewNotes      :: [FormNote l]
+      , viewAttrs      :: [(Text, Dynamic)]
+      , viewMulti      :: Bool
       }
 
+  instance Semigroup (View l) where
+    FormFields [] [] <> view = view
+    view <> FormFields [] [] = view
+
+    FormFields fs1 ns1 <> FormFields fs2 ns2
+      = FormFields (fs1 <> fs2) (ns1 <> ns2)
+
+    FormFields fs ns <> view
+      = FormFields (fs <> [view]) ns
+
+    view <> FormFields fs ns
+      = FormFields ([view] <> fs) ns
+
+    v1 <> v2 = FormFields ([v1, v2]) []
+
+  instance Monoid (View l) where
+    mempty = FormFields [] []
+
 
   data FormNote l
     = NoteError
@@ -87,221 +117,411 @@ where
       }
     deriving (Eq, Ord)
 
+  instance (ToHtml l) => ToHtml (FormNote l) where
+    toHtml    = toHtml . noteLabel
+    toHtmlRaw = toHtmlRaw . noteLabel
+
+  instance (Localized l) => Localized (FormNote l) where
+    localize lang = localize lang . noteLabel
+
 
   newtype FormT l m a
     = FormT
-      { unFormT        :: ReaderT Env (StateT (FormView l) m) a
+      { unFormT        :: ReaderT (Env l) (StateT (View l) m) a
+      }
+    deriving (Monad, Applicative, Functor)
+
+  deriving instance (Monad m) => MonadReader (Env l) (FormT l m)
+  deriving instance (Monad m) => MonadState (View l) (FormT l m)
+
+  instance MonadTrans (FormT l) where
+    lift = FormT . lift . lift
+
+
+  newtype Form l m a
+    = Form
+      { unForm         :: FormT l m (Maybe a)
       }
-    deriving (Functor, Applicative, Monad)
 
+  instance (Monad m) => Functor (Form l m) where
+    fmap f Form{..} = Form do
+      x <- unForm
+      return $ fmap f x
 
-  type Form l m a = Maybe a -> FormT l m (Maybe a)
+  instance (Monad m) => Applicative (Form l m) where
+    pure x = Form $ return $ Just x
 
+    Form{unForm = unFormL} <*> Form{unForm = unFormR} = Form do
+      l <- unFormL
+      r <- unFormR
+      return $ l <*> r
 
-  data Env
+  instance MonadTrans (Form l) where
+    lift = Form . fmap Just . lift
+
+
+  data Env l
     = Env
       { envPrefix      :: [Text]
       , envParams      :: [(Text, Text)]
       , envFiles       :: [(Text, FileInfo FilePath)]
-      , envRunChecks   :: Bool
+      , envCheck       :: Bool
       }
 
-  emptyEnv :: Env
-  emptyEnv = Env { envPrefix    = []
-                 , envParams    = []
-                 , envFiles     = []
-                 , envRunChecks = False
+
+  newtype FieldT l a m b
+    = FieldT
+      { unFieldT       :: ReaderT (Bool, Maybe a) (StateT (View l) m) b
       }
+    deriving (Monad, Applicative, Functor)
+
+  instance MonadTrans (FieldT l a) where
+    lift = FieldT . lift . lift
 
 
   -- |
-  -- Build an unchecked form.
+  -- Build a fresh form without using any request data.
   --
-  newForm :: (MonadAction m) => Text -> FormT l m a -> m (FormView l)
-  newForm name form = do
-    (_, view) <- runForm form emptyEnv { envPrefix = [name] }
-    return view
+  newForm :: (MonadAction m) => Text -> Form l m a -> m (View l)
+  newForm name = flip execStateT view . flip runReaderT env . unFormT . unForm
+    where
+      view = FormFields [] []
+      env  = Env { envPrefix = [name]
+                 , envParams = []
+                 , envFiles  = []
+                 , envCheck  = False
+                 }
 
 
   -- |
-  -- Build & process a checked form with parameters in the query string.
+  -- Process the form using parameters in the query string.
   --
-  getForm :: (MonadAction m) => Text -> FormT l m a -> m (a, FormView l)
+  getForm :: (MonadAction m) => Text -> Form l m a -> m (View l, Maybe a)
   getForm name form = do
     params <- getParams
 
-    runForm form emptyEnv { envPrefix    = [name]
-                          , envParams    = params
-                          , envRunChecks = True
+    let view = FormFields [] []
+        env  = Env { envPrefix = [name]
+                   , envParams = filter (("" /=) . snd) params
+                   , envFiles  = []
+                   , envCheck  = True
                    }
 
+    (value, view') <- runStateT (runReaderT (unFormT $ unForm form) env) view
+
+    if hasErrors view'
+       then return (view', Nothing)
+       else return (view', value)
+
 
   -- |
-  -- Build & process a checked form with parameters in the form fields.
+  -- Process the form using parameters in the request body.
   --
-  postForm :: (MonadAction m) => Text -> FormT l m a -> m (a, FormView l)
+  postForm :: (MonadAction m) => Text -> Form l m a -> m (View l, Maybe a)
   postForm name form = do
     fields <- getFields
     files  <- getFiles
 
-    runForm form emptyEnv { envPrefix    = [name]
-                          , envParams    = fields
+    let view = FormFields [] []
+        env  = Env { envPrefix = [name]
+                   , envParams = filter (("" /=) . snd) fields
                    , envFiles  = files
-                          , envRunChecks = True
+                   , envCheck  = True
                    }
 
+    (value, view') <- runStateT (runReaderT (unFormT $ unForm form) env) view
+
+    if hasErrors view'
+       then return (view', Nothing)
+       else return (view', value)
+
 
   -- |
-  -- Unwrap the transformer stack and run the form.
+  -- TODO
   --
-  runForm :: (MonadAction m) => FormT l m a -> Env -> m (a, FormView l)
-  runForm form env = runStateT (runReaderT (unFormT form) env)
-                               FormView { formElements = []
-                                        , formNotes    = []
-                                        }
+  hiddenField' :: (Monad m, ToParam a, FromParam a)
+               => Text -> FieldT l a m b -> Form l m a
+  hiddenField' name field = hiddenField name Nothing field
 
 
+  -- |
+  -- TODO
+  --
+  hiddenField :: (Monad m, ToParam a, FromParam a)
+              => Text -> Maybe a -> FieldT l a m b -> Form l m a
+  hiddenField name orig field = Form do
+    name' <- makeName name
+    value <- formParamMaybe name'
+
+    let value' = value <|> orig
+        view   = HiddenField { viewName  = name'
+                             , viewValue = toParam <$> value'
+                             , viewNotes = []
+                             , viewAttrs = []
+                             }
 
-  button :: (Monad m) => Text -> l -> FormT l m Bool
-  button name label = do
-    fullName <- makeName name
+    view' <- runFieldT field value' view
 
-    appendElement
-      Button { elemName  = fullName
-             , elemLabel = label
-             , elemAttrs = []
-             }
+    modify (<> view')
+    return value'
 
-    value <- formParamMaybe name
-    case value of
-      Nothing -> return False
-      Just () -> return True
+
+  -- |
+  -- TODO
+  --
+  inputField' :: (Monad m, ToParam a, FromParam a)
+              => Text -> l -> FieldT l a m b -> Form l m a
+  inputField' name label field = inputField name label Nothing field
 
 
+  -- |
+  -- TODO
+  --
   inputField :: (Monad m, ToParam a, FromParam a)
-             => Text -> l -> Form l m a
-  inputField name label orig = do
-    fullName  <- makeName name
-    textValue <- formParamMaybe fullName
-
-    let textOrig = toParam <$> orig
-     in appendElement
-          InputField { elemName  = fullName
-                     , elemLabel = label
-                     , elemValue = textValue <|> textOrig
-                     , elemAttrs = []
-                     , elemNotes = []
+             => Text -> l -> Maybe a -> FieldT l a m b -> Form l m a
+  inputField name label orig field = Form do
+    name' <- makeName name
+    value <- formParamMaybe name'
+
+    let value' = value <|> orig
+        view   = InputField { viewName  = name'
+                            , viewLabel = label
+                            , viewValue = toParam <$> value'
+                            , viewNotes = []
+                            , viewAttrs = []
                             }
 
-    formParamMaybe fullName
-
+    view' <- runFieldT field value' view
 
-  hiddenField :: (Monad m, ToParam a, FromParam a)
-              => Text -> Form l m a
-  hiddenField name orig = do
-    fullName  <- makeName name
-    textValue <- formParamMaybe fullName
-
-    let textOrig = toParam <$> orig
-     in appendElement
-          HiddenField { elemName  = fullName
-                      , elemValue = textValue <|> textOrig
-                      }
+    modify (<> view')
+    return value'
 
-    formParamMaybe fullName
 
+  -- |
+  -- TODO
+  --
+  textArea' :: (Monad m, ToParam a, FromParam a)
+            => Text -> l -> FieldT l a m b -> Form l m a
+  textArea' name label field = textArea name label Nothing field
 
-  textField :: (Monad m, ToParam a, FromParam a)
-            => Text -> l -> Form l m a
-  textField name label orig = do
-    fullName  <- makeName name
-    textValue <- formParamMaybe fullName
 
-    let textOrig = toParam <$> orig
-     in appendElement
-          TextField { elemName  = fullName
-                    , elemLabel = label
-                    , elemValue = textValue <|> textOrig
-                    , elemAttrs = []
-                    , elemNotes = []
+  -- |
+  -- TODO
+  --
+  textArea :: (Monad m, ToParam a, FromParam a)
+            => Text -> l -> Maybe a -> FieldT l a m b -> Form l m a
+  textArea name label orig field = Form do
+    name' <- makeName name
+    value <- formParamMaybe name'
+
+    let value' = value <|> orig
+        view   = TextArea { viewName  = name'
+                          , viewLabel = label
+                          , viewValue = toParam <$> value'
+                          , viewNotes = []
+                          , viewAttrs = []
                           }
 
-    formParamMaybe fullName
+    view' <- runFieldT field value' view
+
+    modify (<> view')
+    return value'
 
 
+  -- |
+  -- TODO
+  --
+  selectField' :: (Monad m, ToParam a, FromParam a, Eq a)
+               => Text -> l -> (a -> l) -> [a]
+               -> FieldT l a m b -> Form l m a
+  selectField' name label optlabel options field
+    = selectField name label optlabel options Nothing field
+
+
+  -- |
+  -- TODO
+  --
   selectField :: (Monad m, ToParam a, FromParam a, Eq a)
-              => Text -> l -> (a -> l) -> [a] -> Form l m a
-  selectField name label optlabel options orig = do
-    fullName  <- makeName name
-    value     <- formParamMaybe fullName
-
-    let textOptions = [ (toParam o, optlabel o, isSel o) | o <- options ]
-        isSel o     = Just o == (value <|> orig)
-     in appendElement
-          SelectField { elemName    = fullName
-                      , elemLabel   = label
-                      , elemOptions = textOptions
-                      , elemAttrs   = []
-                      , elemNotes   = []
-                      , elemMulti   = False
+              => Text -> l -> (a -> l) -> [a] -> Maybe a
+              -> FieldT l a m b -> Form l m a
+  selectField name label optlabel options orig field = Form do
+    name' <- makeName name
+    value <- formParamMaybe name'
+
+    let value' = value <|> orig
+        opts   = [ (toParam x, optlabel x, Just x == value) | x <- options ]
+        view   = SelectField { viewName    = name'
+                             , viewLabel   = label
+                             , viewOptions = opts
+                             , viewNotes   = []
+                             , viewAttrs   = []
+                             , viewMulti   = False
                              }
 
-    case value of
-      Just v -> if v `elem` options
-                   then return value
-                   else return Nothing
-      Nothing -> return Nothing
+    view' <- runFieldT field value' view
 
+    modify (<> view')
+    return value'
 
+
+  -- |
+  -- TODO
+  --
+  selectFieldEnum' :: (Monad m, ToParam a, FromParam a, Eq a, Bounded a, Enum a)
+                   => Text -> l -> (a -> l) -> FieldT l a m b -> Form l m a
+  selectFieldEnum' name label optlabel field
+    = selectFieldEnum name label optlabel Nothing field
+
+
+  -- |
+  -- Alternative to the 'selectField' for enumerable, bounded value types.
+  --
+  -- TODO: Example
+  --
+  selectFieldEnum :: (Monad m, ToParam a, FromParam a, Eq a, Bounded a, Enum a)
+                  => Text -> l -> (a -> l) -> Maybe a
+                  -> FieldT l a m b -> Form l m a
+  selectFieldEnum name label optlabel orig field
+    = selectField name label optlabel [minBound..maxBound] orig field
+
+
+  -- |
+  -- TODO
+  --
+  multiSelectField' :: (Monad m, ToParam a, FromParam a, Eq a)
+                    => Text -> l -> (a -> l) -> [a]
+                    -> FieldT l [a] m b -> Form l m [a]
+  multiSelectField' name label optlabel options field
+    = multiSelectField name label optlabel options Nothing field
+
+
+  -- |
+  -- TODO
+  --
   multiSelectField :: (Monad m, ToParam a, FromParam a, Eq a)
-                   => Text -> l -> (a -> l) -> [a] -> [a] -> FormT l m [a]
-  multiSelectField name label optlabel options orig = do
-    fullName     <- makeName name
-    values       <- formParamList fullName
-
-    let textOptions = [ (toParam o, optlabel o, isSel o) | o <- options ]
-        isSel o     = o `elem` (values <|> orig)
-     in appendElement
-          SelectField { elemName     = fullName
-                      , elemLabel    = label
-                      , elemOptions  = textOptions
-                      , elemAttrs    = []
-                      , elemNotes    = []
-                      , elemMulti    = True
+                   => Text -> l -> (a -> l) -> [a] -> Maybe [a]
+                   -> FieldT l [a] m b -> Form l m [a]
+  multiSelectField name label optlabel options orig field = Form do
+    name'  <- makeName name
+    params <- formParams name'
+
+    let found  = nub $ params <> fromMaybe [] orig
+        opts   = [ (toParam x, optlabel x, x `elem` found) | x <- options ]
+        view   = SelectField { viewName    = name'
+                             , viewLabel   = label
+                             , viewOptions = opts
+                             , viewNotes   = []
+                             , viewAttrs   = []
+                             , viewMulti   = False
                              }
 
-    return $ [ v | v <- values, v `elem` options ]
+    view' <- runFieldT field (Just found) view
+
+    modify (<> view')
+    return $ Just found
+
+
+  -- |
+  -- TODO
+  --
+  opt :: (Monad m) => FieldT l a m ()
+  opt = return ()
+
+
+  -- |
+  -- TODO
+  --
+  req :: (Monad m) => l -> FieldT l a m ()
+  req label = do
+    shouldCheck <- fieldCheck
+
+    if shouldCheck
+       then do
+         value <- fieldValue
+         case value of
+           Nothing -> addNote $ NoteError label
+           Just _v -> return ()
+
+        else do
+          return ()
+
+
+  -- |
+  -- TODO
+  --
+  addNote :: (Monad m) => FormNote l -> FieldT l a m ()
+  addNote note = FieldT do
+    modify \view -> view { viewNotes = viewNotes view <> [note] }
+
+
+  -- |
+  -- TODO
+  --
+  addAttribute :: (Monad m, Typeable v) => Text -> v -> FieldT l a m ()
+  addAttribute name value = FieldT do
+    modify \view ->
+      view { viewAttrs = viewAttrs view <> [(name, toDyn value)] }
+
+
+  -- |
+  -- TODO
+  --
+  fieldCheck :: (Monad m) => FieldT l a m Bool
+  fieldCheck = FieldT (fst <$> ask)
+
+
+  -- |
+  -- TODO
+  --
+  fieldValue :: (Monad m) => FieldT l a m (Maybe a)
+  fieldValue = FieldT (snd <$> ask)
+
+
+  -- |
+  -- Determine whether the view has any (possibly nested) errors.
+  --
+  hasErrors :: View l -> Bool
+  hasErrors FormFields{..} = any isErrorNote viewNotes || any hasErrors viewFields
+  hasErrors view           = any isErrorNote (viewNotes view)
 
 
   -- Form Internals ---------------------------------------------------------
 
 
-  appendElement :: (Monad m) => FormElement l -> FormT l m ()
-  appendElement element = FormT do
-    view@FormView{formElements} <- get
-    put $ view { formElements = formElements <> [element] }
+  runFieldT :: (Monad m) => FieldT l a m b -> Maybe a -> View l
+             -> FormT l m (View l)
+  runFieldT field value view = do
+    Env{envCheck} <- ask
+    lift $ execStateT (runReaderT (unFieldT field) (envCheck, value)) view
 
 
-  formParamMaybe :: (Monad m, FromParam a) => Text -> FormT l m (Maybe a)
-  formParamMaybe name = FormT do
-    Env{envParams} <- ask
-    return $ fromParam =<< lookup name envParams
+  isErrorNote :: FormNote l -> Bool
+  isErrorNote NoteError{} = True
+  isErrorNote _           = False
 
 
-  formParamList :: (Monad m, FromParam a) => Text -> FormT l m [a]
-  formParamList name = FormT do
+  formParamMaybe :: (Monad m, FromParam a) => Text -> FormT l m (Maybe a)
+  formParamMaybe name = do
     Env{envParams} <- ask
-    return $ mapMaybe (fromParam . snd) $ filter ((name ==) . fst) $ envParams
+    return $ fromParam =<< lookup name envParams
 
 
   formFileMaybe :: (Monad m) => Text -> FormT l m (Maybe (FileInfo FilePath))
-  formFileMaybe name = FormT do
+  formFileMaybe name = do
     Env{envFiles} <- ask
     return $ lookup name envFiles
 
 
+  formParams :: (Monad m, FromParam a) => Text -> FormT l m [a]
+  formParams name = do
+    Env{envParams} <- ask
+    let match = (name ==) . fst
+        conv  = fromParam . snd
+     in return $ mapMaybe conv $ filter match $ envParams
+
+
   makeName :: (Monad m) => Text -> FormT l m Text
-  makeName name = FormT do
+  makeName name = do
     Env{envPrefix} <- ask
     return $ mconcat $ intersperse "." $ reverse (name : envPrefix)
 

package.yaml

@@ -23,7 +23,6 @@ extra-source-files: README.md
 
 ghc-options: -Wall -Wcompat
 default-extensions:
-  - ApplicativeDo
   - BlockArguments
   - DeriveGeneric
   - FlexibleInstances