From ea445ffd9e5b41e51a14eb1cb7738d837292e420 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Tue, 21 Jan 2020 21:36:17 +0100
Subject: [PATCH] Use Applicative on top of Monad for Forms
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This is a completely different approach that merits further exploration.
Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>
---
hikaru.cabal | 4 +-
lib/Hikaru/Form.hs | 558 +++++++++++++++++++++++++++++++--------------
package.yaml | 1 -
3 files changed, 391 insertions(+), 172 deletions(-)
diff --git a/hikaru.cabal b/hikaru.cabal
index 4694605..1624ede 100644
--- a/hikaru.cabal
+++ b/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
diff --git a/lib/Hikaru/Form.hs b/lib/Hikaru/Form.hs
index 24e2ed1..4ace1e3 100644
--- a/lib/Hikaru/Form.hs
+++ b/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 (Functor, Applicative, Monad)
+ 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)
+ }
- type Form l m a = Maybe a -> FormT l m (Maybe a)
+ instance (Monad m) => Functor (Form l m) where
+ fmap f Form{..} = Form do
+ x <- unForm
+ return $ fmap f x
+ instance (Monad m) => Applicative (Form l m) where
+ pure x = Form $ return $ Just x
- data Env
+ Form{unForm = unFormL} <*> Form{unForm = unFormR} = Form do
+ l <- unFormL
+ r <- unFormR
+ return $ l <*> r
+
+ 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
- , envFiles = files
- , envRunChecks = True
- }
+ let view = FormFields [] []
+ env = Env { envPrefix = [name]
+ , envParams = filter (("" /=) . snd) fields
+ , envFiles = files
+ , 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'
- button :: (Monad m) => Text -> l -> FormT l m Bool
- button name label = do
- fullName <- makeName name
+ let value' = value <|> orig
+ view = HiddenField { viewName = name'
+ , viewValue = toParam <$> value'
+ , viewNotes = []
+ , viewAttrs = []
+ }
- appendElement
- Button { elemName = fullName
- , elemLabel = label
- , elemAttrs = []
- }
+ view' <- runFieldT field value' view
- value <- formParamMaybe name
- case value of
- Nothing -> return False
- Just () -> return True
+ modify (<> view')
+ return value'
+ -- |
+ -- 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
+ => 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 textOrig = toParam <$> orig
- in appendElement
- InputField { elemName = fullName
- , elemLabel = label
- , elemValue = textValue <|> textOrig
- , elemAttrs = []
- , elemNotes = []
- }
+ let value' = value <|> orig
+ view = InputField { viewName = name'
+ , viewLabel = label
+ , viewValue = toParam <$> value'
+ , viewNotes = []
+ , viewAttrs = []
+ }
- formParamMaybe fullName
+ view' <- runFieldT field value' view
+ modify (<> view')
+ return value'
- 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
- }
+ -- |
+ -- 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
+
- formParamMaybe fullName
+ -- |
+ -- 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 = []
+ }
+ view' <- runFieldT field value' view
- textField :: (Monad m, ToParam a, FromParam a)
- => Text -> l -> Form l m a
- textField name label orig = do
- fullName <- makeName name
- textValue <- formParamMaybe fullName
+ modify (<> view')
+ return value'
- let textOrig = toParam <$> orig
- in appendElement
- TextField { elemName = fullName
- , elemLabel = label
- , elemValue = textValue <|> textOrig
- , elemAttrs = []
- , elemNotes = []
- }
- formParamMaybe fullName
+ -- |
+ -- 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
- }
-
- case value of
- Just v -> if v `elem` options
- then return value
- else return Nothing
- Nothing -> return Nothing
+ => 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
+ }
+
+ 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
+ => 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
+ }
+
+ 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 ()
- 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
- }
- return $ [ v | v <- values, v `elem` options ]
+ -- |
+ -- 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)
diff --git a/package.yaml b/package.yaml
index 91bfee6..e4e6ef6 100644
--- a/package.yaml
+++ b/package.yaml
@@ -23,7 +23,6 @@ extra-source-files: README.md
ghc-options: -Wall -Wcompat
default-extensions:
- - ApplicativeDo
- BlockArguments
- DeriveGeneric
- FlexibleInstances
--
GitLab