How do I dynamically generate forms with a varying number of input fields?
The closest I managed is:
listEditForm :: [String] -> Html -> MForm App App (FormResult Text, Widget)
listEditForm xs = renderDivs $ mconcat [ areq textField (String.fromString x) Nothing | x <- xs]
but this has the result type Text and not [Text] as intended, owning to the coincidence that Text is an instance of Monoid, e.g. it fails with Int.
I have a working alternate attempt, which combines several forms, but somehow it only works for this toy example, while the real attempt fails strangely. Anyhow, I don't think this is the correct approach:
data MapPair = MapPair { mpKey :: T.Text, mpValue :: Maybe T.Text }
editForm mmp = renderTable $ MapPair
<$> areq textField "Key" (mpKey <$> mmp)
<*> aopt textField "Value" (mpValue <$> mmp)
pair2mp (v,k) = MapPair { mpKey = v, mpValue = Just k }
getEditR = do
sess <- getSession
let sesslist = Map.toList $ Map.map (decodeUtf8With lenientDecode) sess
forms <- forM sesslist (\a -> generateFormPost $ editForm $ Just $ pair2mp a)
defaultLayout [whamlet|
<h1>Edit Value Pairs
$forall (widget,enctype) <- forms
<form method=post action=#{EditR} enctype=#{enctype}>
^{widget}
<input type=submit>
|]
postEditR = do
sess <- getSession
let sesslist = Map.toList $ Map.map (decodeUtf8With lenientDecode) sess
forM_ sesslist (\a -> do
((res,_),_) <- runFormPost $ editForm $ Just $ pair2mp a
case res of
(FormSuccess (MapPair {mpKey=mk, mpValue=(Just mv)})) -> setSession mk mv
_ -> return ()
)
defaultLayout [whamlet|ok|]
Duh, it is actually easy using monadic forms (see code below).
My major headache is the extra text fields to make sure that the handler which receives the answer may also infer the corresponding question. Maybe I can hide those text fields, make them uneditable, or find another way around that (but I don't know much about Html yet).
listEditMForm :: [(String,Int)] -> Html -> MForm App App (FormResult [(FormResult Int, FormResult Text)], Widget)
listEditMForm xs extra = do
ifields <- forM xs (\(s,i) -> mreq intField (String.fromString s) (Just i))
tfields <- forM xs (\(s,i) -> mreq textField (String.fromString s) (Just $ pack s))
let (iresults,iviews) = unzip ifields
let (tresults,tviews) = unzip tfields
let results = zip iresults tresults
let views = zip iviews tviews
let widget = [whamlet|
#{extra}
<h1>Multi Field Form
$forall (iv,tv) <- views
Field #
#{fvLabel iv}: #
^{fvInput tv} #
^{fvInput iv}
<div>
|]
return ((FormSuccess results), widget)
There are also still some ugly things that I have no clue about, like always wrapping the result always in an outermost FormSuccess constructor, but I guess that really depends on each use-case (e.g. a single FormFailure or FormMissing should probably make the whole form fail/missing as well, but maybe in some case this is not wanted.)
All the zipping and unzipping can probably be done more neatly, but I guess in my case I just create a combined field textintField. I think I know how to do it, but it would be neat if there were a function to combine fields.
The tricky thing with having a dynamic number of fields is that the number of rows/fields need to be known when the form is parsed in the handler.
Let's say we have a regular form that looks like this:
type Form m a b =
(MonadHandler m, m ~ HandlerFor App) =>
Maybe a ->
Html ->
MForm m (FormResult b, Widget)
nameAndAgeForm :: Form m (Text, Int) (Text, Int)
nameAndAgeForm mPair extra = do
let nameSettings =
FieldSettings
{ fsLabel = "name"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = []
}
(nameResult, nameField) <- mreq textField nameSettings (fst <$> mPair)
let ageSettings =
FieldSettings
{ fsLabel = "age"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = []
}
(ageResult, ageField) <- mreq intField ageSettings (snd <$> mPair)
let result = (,) <$> nameResult <*> ageResult
let widget = [whamlet|age: ^{fvInput nameField}, age: ^{fvInput ageField}^{extra}|]
pure (result, widget)
NOTE it's important that fsName = Nothing in all of the fields or they will collide with themselves when we try to repeat the form in a list.
We can turn it into a form of lists of pairs with a function with that has the following signature Form m a b -> Form m [a] [b].
We can write such a function if we use a trick to get around the problem that the number of fields must be known when parsing. We can send the number of rows as the first field to be parsed.
listifyForm :: Form m a b -> Form m [a] [b]
listifyForm form items csrf = do
let countSettings =
FieldSettings
{ fsLabel = "rowCount"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Just "listifiedFormRowCount"
, fsAttrs = []
}
(rowCountResult, rowCountField) <- mreq hiddenField countSettings (length <$> items)
case (rowCountResult, items) of
(FormSuccess rowCount, _) -> constructForms rowCountField $ replicate rowCount Nothing
(FormMissing, Just items') -> constructForms rowCountField $ Just <$> items'
(FormFailure err, _) -> pure (FormFailure err, [whamlet|Something went wrong with the form. Do all the fields have unique ID's?|])
(FormMissing, _) -> pure (FormMissing, [whamlet|Something went wrong with the form|])
where
constructForms rowCountField mItems =
fmap ([whamlet|^{csrf}^{fvInput rowCountField}|] <>) . bimap sequenceA mconcat . unzip
<$> traverse (flip form mempty) mItems
Now we can convert the nameAndAgeForm into a nameAndAgeListForm:
nameAndAgeListForm :: Form m [(Text, Int)] [(Text, Int)]
nameAndAgeListForm = listifyForm nameAndAgeForm
That can then be called like this in the handler that displays the form:
((_, namesAndAgesWidget), _) <- runFormPost $ nameAndAgeListForm $ Just [("Alice", 12), ("Bob", 34)]
And like this in the handler that handles the input:
((result, _), _) <- runFormPost $ nameAndAgeListForm Nothing
Related
I wrote such permutation parsing example:
data Entry = Entry {
first_name :: String
, last_name :: String
, date_of_birth :: Maybe String
, nationality :: Maybe String
, parentage :: Maybe String
} deriving (Show)
nameParser :: Parser (String, String)
nameParser = do
first_name <- many1 upper
endOfLine
last_name <- many1 letter
endOfLine
return $ (first_name, last_name)
attributeParser :: String -> Parser String
attributeParser field = do
string $ field ++ ": "
value <- many1 (noneOf "\n")
endOfLine
return value
entryParser :: Parser Entry
entryParser = do
(f, l) <- nameParser
(d, n, p) <- permute ((,,)
<$?> (Nothing, liftM Just (try $ attributeParser "Date of Birth"))
<|?> (Nothing, liftM Just (try $ attributeParser "Nationality"))
<|?> (Nothing, liftM Just (try $ attributeParser "Parentage"))
)
return $ Entry f l d n p
main = do
mapM_ putStrLn . map (show . parse entryParser "") $ goodTests
goodTests =
"AAKVAAG\nTorvild\nDate of Birth: 1 July\nNationality: Norwegian\nParentage: business executive\n" :
"AAKVAAG\nTorvild\nNationality: Norwegian\nParentage: business executive\n" :
"AAKVAAG\nTorvild\nParentage: business executive\nNationality: Norwegian\n" :
"AAKVAAG\nTorvild\nParentage: business executive\n" :
"AAKVAAG\nTorvild\nNationality: Norwegian\n" : []
It would be good to extend Entry data with new fields in future, but doing that will require to put even more repetitive code in entryParser function. Is there a way to make this function accept list of parsers?
I started with this:
attributeParsers =
map attributeParser ["Date of Birth", "Nationality", "Parentage"]
permuteParams =
map (\p -> (Nothing, liftM Just (try p))) attributeParsers
But could not come of with correct way to fold permuteParams together with <|?> operator (I guess it would require something smarter than (,,) tuple constructor then).
As a first step, you can abstract the stuff you do for every component:
attr txt = (Nothing, liftM Just (try $ attributeParser txt))
With this, you can go to:
entryParser :: Parser Entry
entryParser = do
(f, l) <- nameParser
(d, n, p) <- permute ((,,)
<$?> attr "Date of Birth"
<|?> attr "Nationality"
<|?> attr "Parentage"
)
return $ Entry f l d n p
Then, if you want, you can combine the infix combinators and the attr calls:
f .$ x = f <$?> attr x
f .| x = f <|?> attr x
infixl 2 .$
infixl 2 .|
This gives you:
entryParser :: Parser Entry
entryParser = do
(f, l) <- nameParser
(d, n, p) <- permute ((,,)
.$ "Date of Birth"
.| "Nationality"
.| "Parentage"
)
return $ Entry f l d n p
Then you can further simplify by getting rid of the intermediate triple. All you're doing is to build it and then apply its components to Entry f l, so you can as well apply the result of the permutation parser to Entry f l directly:
entryParser :: Parser Entry
entryParser = do
(f, l) <- nameParser
permute (Entry f l
.$ "Date of Birth"
.| "Nationality"
.| "Parentage"
)
I think this is compact enough. If you really want some kind of fold, you'll either have to introduce an intermediate list and collect the permutation results in a list. This, however, only works as long as all the permutable attributes are of the same type (they currently are), and is not so nice because you'll make assumptions about the number of elements in this list. Or you'll have to use a heterogeneous list / some type class magic, which will lead to more complexity with the types and is, I think, not worth it here.
(<|?>) does not play nicely with folding because the type of the StreamPermParser you pass as its first argument isn't the same than that of the StreamPermParser result. For a simpler yet analogous issue, you would run into similar problems if you were trying to use (,,) with (<$>) and (<*>) in applicative style (e.g. (,,) <$> foo <*> bar <*> baz).
If you want to cut down some of the repetition, my prosaic suggestion would be using a local definition:
entryParser :: Parser Entry
entryParser = do
(f, l) <- nameParser
(d, n, p) <- permute ((,,)
<$?> optField "Date of Birth"
<|?> optField "Nationality"
<|?> optField "Parentage"
)
return $ Entry f l d n p
where
optField fieldName = (Nothing, liftM Just (try $ attributeParser fieldName))
Hi i want create a file that only accept values that exist in a table (with more that 20000 rows) so i have the following code
demoForm :: Maybe Demo -> AForm Handler Demo
demoForm demo = Demo
<$> areq nitField (bfs (MsgName)) (demoFieldOne <$> demo)
<*> areq intField (bfs (MsgName)) (demoFieldTwo <$> demo)
where
errorMessage :: Text
errorMessage = "the company no exist!"
nitField = check validateNit textField
validateNit nit
| companiesMatch nit = Left errorMessage
| otherwise = Right nit
companiesMatch name = do
entities <- runDB $ selectList [CompanyName ==. name] []
return (null entities)
but I get the error Couldn't match expected type ‘Bool’with actual type ‘m0 (HandlerT site0 IO Bool)’ so how can get the bool value from the monad or exist a better way to do this validations?
thanks #Michael Snoyman you are rigth I just have to use checkM
demoForm :: Maybe Demo -> AForm Handler Demo
demoForm demo = Demo
<$> areq nitField (bfs (MsgName)) (demoFieldOne <$> demo)
<*> areq intField (bfs (MsgName)) (demoFieldTwo <$> demo)
where
nitField = checkM validateNit textField
validateNit input = do
mbNit <- runDB $ selectList [CompanyName ==. input] []
return $ case null mbNit of
True -> Left (MsgErrNit :: AppMessage)
False -> Right input
I have the following handler/template combination:
handler/automation.hs
data AutomationRequest = AutomationRequest {
arEnabled :: Bool
, arTemplate :: Text
, arSchedules :: Textarea
}
getAutomationR :: Handler Html
getAutomationR = do
(formWidget, formEnctype) <- generateFormPost form
defaultLayout $(widgetFile "automation")
form :: Form AutomationRequest
form extra = do
(enabledRes, enabledView) <- mreq checkBoxField "" Nothing
(templateRes, templateView) <- mreq textField (withPlaceholder "..." $ bfs (""::Text)) Nothing
(schedulesRes, schedulesView) <- mreq textareaField (withPlaceholder "..." $ bfs (""::Text)) Nothing
(_, submitView) <- mbootstrapSubmit $ BootstrapSubmit ("Save"::Text) ("btn-primary"::Text) []
let requestRes = AutomationRequest <$> enabledRes <*> templateRes <*> schedulesRes
widget = $(widgetFile "automation-form")
return (requestRes, widget)
templates/automation.hamlet
<form method=post role=form action=#{AutomationR} enctype=#{formEnctype}>
^{formWidget}
templates/automation-form.hamlet
#{extra}
<div .panel .panel-default>
<div .panel-heading>^{fvInput enabledView} ...
<div .panel-body>
^{fvInput templateView}
^{fvInput schedulesView}
^{fvInput submitView}
This works as expected, but I want additional functionality:
a) I want to be able to nest data structures like:
data AutomationRequestCollection = AutomationRequestCollection {
arcItemAbc :: AutomationRequest
, arcItemDef :: AutomationRequest
... -- 10 Items
}
data AutomationRequest = AutomationRequest {
arEnabled :: Bool
, arTemplate :: Text
, arSchedules :: Textarea
}
I don't know how to apply the nesting to let requestRes = AutomationRequest <$> enabledRes <*> templateRes <*> schedulesRes
b) Reuse the HTML panel for itemAbc, itemDef, ...:
-- loop somehow
<div .panel .panel-default>
<div .panel-heading>^{fvInput enabledView} ...
<div .panel-body>
^{fvInput templateView}
^{fvInput schedulesView}
Any ideas that could push me into the right direction?
I'm not sure about (b), but (a) should be straightforward Applicative composition, e.g.:
Foo <$> (Bar <$> baz <*> bin) <*> qux
It can also be easier to see if you break this into multiple functions:
bar = Bar <$> baz <*> bin
foo = Foo <$> bar <*> qux
I'm getting the following error when trying to compile my Yesod project (built out from the scaffolding).
No instance for (PersistBackend (GGHandler Scheduler Scheduler) IO)
arising from a use of `checkDateStatus'
Possible fix:
add an instance declaration for
(PersistBackend (GGHandler Scheduler Scheduler) IO)
In the first argument of `checkM', namely `checkDateStatus'
In the expression: checkM checkDateStatus
In the expression:
checkM checkDateStatus
$ (jqueryDayField
(def {jdsChangeYear = True, jdsYearRange = "2011:2012"}))
I believe this is because Haskell's type inference is failing. If this is the case, all I need to do is to give an accurate definition for checkDateStatus. If not a push in the right direction would be welcome. If I'm right, I'm still stuck as to what the type definition of checkDateStatus should be. I've been getting away with depending on type inference. Included below is the code I think is relevant. If I am missing something, please inform.
getManagerR :: Handler RepHtml
getManagerR = do
((res, widget), enctype) <- runFormGet productForm
let findTestId = 1
res' = prepST res
scheduledTest = makeScheduledTest res'
dataInsert <- runDB $ insert scheduledTest
defaultLayout [whamlet|
<p>Result:#{show res}
<form enctype=#{enctype}>
^{widget}
|]
productForm :: Html
-> Form Scheduler Scheduler (FormResult SelectedProduct, Widget)
productForm extra = do
pInfo <- liftIO getUIdata
let products = V.toList $ V.map productACC $ fst pInfo
versions = V.toList $ V.map versionsACC $ snd pInfo
(productRes, productView) <- mreq (radioField products) "Placeholder" Nothing
versionInfo <- mapM generateVersionSelectFields versions
(dateRes, dateView) <- mreq requestedDayField "Schedule" Nothing
-- (dateRes, dateView) <- mreq (jqueryDayField def
-- { jdsChangeYear = True
-- , jdsYearRange = "2011:2012"
-- }) "Schedule" Nothing
let versionRes = map fst versionInfo
versionViews = map snd versionInfo
widget = do
toWidget [whamlet|
#{extra}
<p>
^{fvInput productView}
$forall versionView <- versionViews
^{fvInput versionView}
^{fvInput dateView}
<input type=submit value="Request Test">
|]
return (makeSelected productRes versionRes dateRes, widget)
requestedDayField = checkM checkDateStatus $ (jqueryDayField def
{ jdsChangeYear = True
, jdsYearRange = "2011:2012"
})
errorMessage :: Text
errorMessage = "I can't go for that, no can do."
checkDateStatus date = do
maybeTaken <- getBy $ UniqueStartDate date
case maybeTaken of
Nothing -> return $ Left errorMessage
otherwise -> return $ Right date
You're missing a runDB in front of the getBy.
I've written a simple XML parser in Haskell.
The function convertXML recieves contents of a XML file and returns a list of extracted values that are further processed.
One attribute of XML tag contains also an URL of a product image and I would like to extend the function to also download it if the tag is found.
convertXML :: (Text.XML.Light.Lexer.XmlSource s) => s -> [String]
convertXML xml = productToCSV products
where
productToCSV [] = []
productToCSV (x:xs) = (getFields x) ++ (productToCSV
(elChildren x)) ++ (productToCSV xs)
getFields elm = case (qName . elName) elm of
"product" -> [attrField "uid", attrField "code"]
"name" -> [trim $ strContent elm]
"annotation" -> [trim $ strContent elm]
"text" -> [trim $ strContent elm]
"category" -> [attrField "uid", attrField "name"]
"manufacturer" -> [attrField "uid",
attrField "name"]
"file" -> [getImgName]
_ -> []
where
attrField fldName = trim . fromJust $
findAttr (unqual fldName) elm
getImgName = if (map toUpper $ attrField "type") == "FULL"
then
-- here I need some IO code
-- to download an image
-- fetchFile :: String -> IO String
attrField "file"
else []
products = findElements (unqual "product") productsTree
productsTree = fromJust $ findElement (unqual "products") xmlTree
xmlTree = fromJust $ parseXMLDoc xml
Any idea how to insert an IO code in the getImgName function or do I have to completely rewrite convertXML function to an impure version ?
UPDATE II
Final version of convertXML function. Hybrid pure/impure but clean way suggested by Carl. Second parameter of returned pair is an IO action that runs images downloading and saving to disk and wraps list of local paths where are images stored.
convertXML :: (Text.XML.Light.Lexer.XmlSource s) => s -> ([String], IO [String])
convertXML xml = productToCSV products (return [])
where
productToCSV :: [Element] -> IO String -> ([String], IO [String])
productToCSV [] _ = ([], return [])
productToCSV (x:xs) (ys) = storeFields (getFields x)
( storeFields (productToCSV (elChildren x) (return []))
(productToCSV xs ys) )
getFields elm = case (qName . elName) elm of
"product" -> ([attrField "uid", attrField "code"], return [])
"name" -> ([trim $ strContent elm], return [])
"annotation" -> ([trim $ strContent elm], return [])
"text" -> ([trim $ strContent elm], return [])
"category" -> ([attrField "uid", attrField "name"], return [])
"manufacturer" -> ([attrField "uid",
attrField "name"], return [])
"file" -> getImg
_ -> ([], return [])
where
attrField fldName = trim . fromJust $
findAttr (unqual fldName) elm
getImg = if (map toUpper $ attrField "type") == "FULL"
then
( [attrField "file"], fetchFile url >>=
saveFile localPath >>
return [localPath] )
else ([], return [])
where
fName = attrField "file"
localPath = imagesDir ++ "/" ++ fName
url = attrField "folderUrl" ++ "/" ++ fName
storeFields (x1s, y1s) (x2s, y2s) = (x1s ++ x2s, liftM2 (++) y1s y2s)
products = findElements (unqual "product") productsTree
productsTree = fromJust $ findElement (unqual "products") xmlTree
xmlTree = fromJust $ parseXMLDoc xml
The better approach would be to have the function return the list of files to download as part of the result:
convertXML :: (Text.XML.Light.Lexer.XmlSource s) => s -> ([String], [URL])
and download them in a separate function.
The entire point of the type system in Haskell is that you can't do IO except with IO actions - values of type IO a. There are ways to violate this, but they run the risk of behaving entirely unlike what you'd expect, due to interactions with optimizations and lazy evaluation. So until you understand why IO works the way it does, don't try to make it work differently.
But a very important consequence of this design is that IO actions are first class. With a bit of cleverness, you could write your function as this:
convertXML :: (Text.XML.Light.Lexer.XmlSource s) => s -> ([String], IO [Image])
The second item in the pair would be an IO action that, when executed, would give a list of the images present. That would avoid the need to have image loading code outside of convertXML, and it would allow you to do IO only if you actually needed the images.
I basically see to approaches:
let the function give out a list of found images too and process them with an impure function afterwards. Laziness will do the rest.
Make the whole beast impure
I generally like the first approach more. d