10 files changed, 187 insertions(+), 14 deletions(-)

M bureaucromancy.cabal
A i18n/en
M src/Text/HTML/Form.hs
M src/Text/HTML/Form/Colours.hs
M src/Text/HTML/Form/Query.hs
M src/Text/HTML/Form/Validate.hs
M src/Text/HTML/Form/WebApp.hs
M src/Text/HTML/Form/WebApp/Ginger.hs
M src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs
M src/Text/HTML/Form/WebApp/Ginger/TZ.hs

@@ 20,7 20,7 @@ name:               bureaucromancy
 -- PVP summary:     +-+------- breaking API changes
 --                  | | +----- non-breaking API additions
 --                  | | | +--- code changes with no API change
-version:            0.1.0.0
+version:            0.1.0.1
 
 -- A short (one-line) description of the package.
 synopsis:           Parse webforms & render to interactive hypertext


@@ 74,9 74,12 @@ library
     -- other-extensions:
 
     -- Other library packages from which modules are imported.
-    build-depends:    base ^>=4.16.4.0, ginger, file-embed-lzma, file-embed, mtl,
-            bytestring, text, xml-conduit, network-uri, regex-tdfa, containers,
-            filepath, directory, hourglass >= 0.2.12 && < 0.3, tz >= 0.1 && < 0.2,
+    build-depends:    base >=4.16.4.0 && <5, ginger>0.10 && <1,
+            file-embed-lzma >=0.0.1 && <1, file-embed >=0.0.15 && < 0.1, mtl >2 && <3,
+            bytestring >=0.11 && <1, text >=2 && <3, containers >=0.6 && <1,
+            xml-conduit >= 1.9 && <2, network-uri >=2.6 && <3, regex-tdfa >=1.3 && <2,
+            filepath >=1.4 && <2, directory >=1.2 && <2,
+            hourglass >= 0.2.12 && < 0.3, tz >= 0.1 && < 0.2
 
     -- Directories containing source files.
     hs-source-dirs:   src


@@ 99,8 102,9 @@ executable bureaucromancy
 
     -- Other library packages from which modules are imported.
     build-depends:
-        base ^>=4.16.4.0,
-        bureaucromancy, warp, wai, http-types, text, html-conduit
+        base >=4.16.4.0 && <5, bureaucromancy,
+        warp >= 3.3.31 && < 3.4, wai >= 3.2.3 && < 3.3, http-types >= 0.12.3 && < 0.13,
+        text >= 2.0.1 && < 2.1, html-conduit >= 1.3.2 && < 1.4
 
     -- Directories containing source files.
     hs-source-dirs:   app


@@ 132,5 136,5 @@ test-suite bureaucromancy-test
 
     -- Test dependencies.
     build-depends:
-        base ^>=4.16.4.0,
+        base >=4.16.4.0 && <5,
         bureaucromancy

@@ 1,4 1,5 @@
 {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
+-- | Parse webforms out of webpages
 module Text.HTML.Form (Form(..), Input(..), OptionGroup(..), Option(..),
     FileSelector(..), defaultFileData, ImageData(..), defaultImageData,
     TextArea(..), defaultTextArea, parseElement, parseDocument, ensureButtons) where


@@ 17,101 18,176 @@ import Network.URI (parseURIReference, URI, nullURI)
 import Text.Regex.TDFA (Regex, defaultCompOpt, defaultExecOpt)
 import Text.Regex.TDFA.Text (compile)
 
+-- | A collection of controls intended to be handle by a particular URL endpoint.
 data Form = Form {
+    -- | The URL which should receive valid input from this form.
     action :: URI,
+    -- | How to encode the data to be received by the URL.
     enctype :: Text,
+    -- | Which HTTP method to use.
     method :: Text,
+    -- | Whether to validate the form data before submitting it to the endpoint.
     validate :: Bool,
+    -- | Where to display the response.
     target :: Text,
+    -- | Which character sets to encode the data in.
     acceptCharset :: [Text],
+    -- | Whether to offer autocompletions for all controls.
     autocomplete :: Bool,
+    -- | The name of this form.
     formName :: Text,
+    -- | The purpose of this form, typically using an external vocabulary.
     rel :: Text,
+    -- | What data should be sent to the endpoint.
     inputs :: [Input]
 }
 
+-- | Individual piece of data to send to a webservice.
 data Input = Input {
     -- Core attributes
+    -- | Human-legible yet brief description of this input.
     label :: Text,
+    -- | Human-legible longer-form description of this input.
     description :: Node,
+    -- | How this control should be presented to the user, supporting all the HTML5 input types.
+    -- Support for more types may be added in the future, with any unsupported types
+    -- fallingback to text entry.
     inputType :: Text,
+    -- | In which query parameter should we store the text direction?
     dirname :: Text,
+    -- | In which query parameter should we store this value?
     inputName :: Text,
     -- State
+    -- | The user-provided value or caller-provided default to upload to the server.
     value :: Text,
+    -- | Whether to autocomplete this input, if its enabled on the form.
     inputAutocomplete :: Text,
+    -- | Whether this input has initial focus.
     autofocus :: Bool,
+    -- | Whether (for certain types) to upload the data for this input.
     checked :: Bool,
+    -- | Whether to temporarily-disallow users from editting this value.
     disabled :: Bool,
+    -- | Whether to permanantly-disallow users from editting this value.
     readonly :: Bool,
     -- Input behaviour
+    -- | Whether to allow entering multiple values.
     multiple :: Bool,
+    -- | If this control is used to submit the form, where to upload it.
     formAction :: Maybe URI,
+    -- | If this control is used to submit the form, which text encoding to use in the upload.
     formEnctype :: Maybe Text,
+    -- | If this control is used to submit the form, which HTTP method to use.
     formMethod :: Maybe Text,
+    -- | If this control is used to submit the form, whether to enforce validation.
     formValidate :: Bool,
+    -- | If this control is used to submit the form, where to render the response.
     formTarget :: Maybe Text,
+    -- | Suggests which keyboard to use for the input.
     inputMode :: Text,
+    -- | Autocompletion values provided by caller.
     list :: [OptionGroup],
     -- Validation
+    -- | The minimum & maximum values for the value of this input.
     range :: (Maybe Text, Maybe Text),
+    -- | In which period from start do valid values occur?
     step :: Maybe Text,
+    -- | The minimum & maximum lengths for the value of this input.
     lengthRange :: (Maybe Int, Maybe Int),
+    -- | Optional regex to enforce on the value of this input.
     pattern :: Maybe Regex,
+    -- | Whether this control must have a value for it to be considered valid.
     required :: Bool,
     -- Presentation
+    -- | Sample value, often visual clarity of its role incurs inaccessibility.
+    -- Make sure to communicate what's implied here elsewhere.
     placeholder :: Text,
     -- sort by tabindex?
+    -- | Longform clarifications.
     title :: Text,
+    -- | How wide the control should be.
     size :: Maybe Int,
+    -- | Additional data for inputs of type "file".
     fileData :: FileSelector,
+    -- | Additional data for inputs of type "image".
     imageData :: ImageData,
+    -- | Additional data for inputs of type "textarea".
     textArea :: TextArea
 }
+-- | A labelled-group of options, that can be collectively disabled.
 data OptionGroup = OptGroup {
+    -- | A brief human-legible description of the options on this group.
     optsLabel :: Text,
+    -- | Whether these options can be selected.
     optsDisabled :: Bool,
+    -- | The options in this group.
     subopts :: [Option]
 }
+-- | A possible value for an input.
 data Option = Option {
+    -- | Human-legible text identifying this option.
     optLabel :: Text,
+    -- | Machine-legible text identifying this option.
     optValue :: Text,
+    -- | Whether the option is selected.
     optSelected :: Bool,
+    -- | Whether the option can be selected.
     optDisabled :: Bool
 }
+-- | Data specific to "file" inputs.
 data FileSelector = FileSelector {
+    -- | The MIMEtypes of the files which can be validly entered into this control.
     fileAccept :: [Text],
+    -- | Whether options for capturing from a camera should be offered.
     fileCapture :: Text
 }
+-- | Empty values for file data.
 defaultFileData :: FileSelector
 defaultFileData = FileSelector [] ""
+-- | Data specific to "image" inputs.
 data ImageData = ImageData {
+    -- | Text describing the image, in case the reader can't view it.
     imgAlt :: Maybe Text,
+    -- | How much screenspace the image takes up.
     imgSize :: (Maybe Int, Maybe Int),
-    imgSrc :: Maybe Text
+    -- | The link to the image.
+    imgSrc :: Maybe URI
 }
+-- | Empty values for image data.
 defaultImageData :: ImageData
 defaultImageData = ImageData Nothing (Nothing, Nothing) Nothing
+-- | Data specific to textarea inputs.
 data TextArea = TextArea {
+    -- | Whether to enable autocorrect.
     autocorrect :: Bool,
+    -- | Number of rows to display.
     rows :: Maybe Int,
+    -- | Whether to enable spellcheck.
     spellcheck :: Maybe Bool,
+    -- | Whether to enable text-wrap.
     textwrap :: Maybe Bool
 }
+-- | Empty values for textarea data.
 defaultTextArea :: TextArea
 defaultTextArea = TextArea True Nothing Nothing Nothing
 
+-- | Helper for looking up attributes on a selected element, with fallback.
 attr :: Text -> Cursor -> Text -> Text
 attr n el def | [ret] <- n `laxAttribute` el = ret
     | otherwise = def
+-- | Helper for looking up attributes on a selected element, with fallback & callback.
 attr' :: Text -> Cursor -> (Text -> a) -> Text -> a
 attr' n el cb def = cb $ attr n el def
+-- | Variant of `attr'` which passes which unpacks the callback's argument to a string.
 attr'' :: Text -> Cursor -> (String -> a) -> Text -> a
 attr'' n el cb def = attr' n el (cb . Txt.unpack) def
+-- | Helper for checking whether an attribute is present.
 hasAttr :: Name -> Cursor -> Bool
 hasAttr n = not . null . hasAttribute n
+-- | Helper for looking up an attribute on a selected element if present.
 mAttr :: Text -> Cursor -> Maybe Text
 mAttr n = listToMaybe . laxAttribute n
+-- | Parse a form from the selected HTML element.
 parseElement :: Cursor -> Maybe Form
 parseElement el | _:_ <- laxElement "form" el = Just Form {
         action = attr'' "action" el (fromMaybe nullURI . parseURIReference) ".",


@@ 127,11 203,14 @@ parseElement el | _:_ <- laxElement "form" el = Just Form {
       }
     | otherwise = Nothing
 
+-- | Helper to retrieve the root node of a document.
 root :: Axis
 root = singleton . last . orSelf ancestor
+-- | Case-insensitive element selection.
 laxElements :: [Text] -> Axis
 laxElements ns = checkName (\x -> or [
     on (==) Txt.toCaseFold n $ nameLocalName x | n <- ns])
+-- | Retrieve all the inputs associated with a form element.
 queryInputs :: Cursor -> [Cursor]
 queryInputs form = (allInputs >=> inForm) form
   where


@@ 141,6 220,7 @@ queryInputs form = (allInputs >=> inForm) form
         laxAttribute "form" x == laxAttribute "id" form ||
         nestedInForm x)
     nestedInForm x = listToMaybe ((ancestor >=> laxElement "form") x) == Just form
+-- | Parse an input from the selected element.
 parseInput :: Cursor -> Maybe Input
 parseInput el | _:_ <- laxElement "input" el = Just Input {
         label = fromMaybe


@@ 188,7 268,7 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
             imgAlt = mAttr "alt" el,
             imgSize = (attr'' "width" el readMaybe "",
                 attr'' "height" el readMaybe ""),
-            imgSrc = mAttr "src" el
+            imgSrc = attr'' "src" el (parseURIReference) ""
         },
         textArea = defaultTextArea
       }


@@ 327,6 407,7 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
     filterSelect = descendant >=>
         checkNot (orSelf ancestor >=> laxElement "select") >=>
         content
+-- | Parse the options beneath a selected element.
 parseOptions :: Cursor -> [OptionGroup]
 parseOptions el = [parseGroup opt
     | opt <- (descendant >=> laxElements ["option", "optgroup"] >=>


@@ 348,6 429,7 @@ parseOptions el = [parseGroup opt
         optDisabled = hasAttr "disabled" opt || disabledOverride
       }
 
+-- | Parse a named or numerically-indexed form from an HTML document.
 parseDocument :: Document -> Text -> Maybe Form
 parseDocument doc n
     | Just n' <- readMaybe $ Txt.unpack n, n' < length (forms doc') =


@@ 358,22 440,28 @@ parseDocument doc n
     forms = orSelf descendant >=> laxElement "form"
     doc' = fromDocument doc
 
+-- | Helper to select elements which fail a test.
 checkNot :: Boolean b => (Cursor -> b) -> Axis
 checkNot test = check (not . bool . test)
+-- | Helper to maybe-get the right side of an either.
 rightToMaybe :: Either a b -> Maybe b
 rightToMaybe (Left _)  = Nothing
 rightToMaybe (Right x) = Just x
 instance Eq Cursor where
     a == b = node a == node b
+-- | Helper to return the 1st Just from its 2 arguments.
 orElse :: Maybe a -> Maybe a -> Maybe a
 orElse ret@(Just _) _ = ret
 orElse _ ret = ret
 infixr 0 `orElse`
+-- | Helper to retrieve the concatenated text under a selected element.
 text :: Cursor -> Text
 text = Txt.concat . (descendant >=> content)
+-- | Concise synonym for an XML text node.
 mkEl :: Text -> Node
 mkEl = NodeContent
 
+-- | Add submit & reset buttons to a form if they were missing!
 ensureButtons :: Form -> Form
 ensureButtons = ensureButton "submit" "Submit" . ensureButton "reset" "Reset"
   where

@@ 1,8 1,14 @@
+-- | A decent colour-pallet for users to select between,
+-- for where we can't provide free-form colour selection.
 module Text.HTML.Form.Colours(tailwindColours, Colour) where
 
 -- Finally a good use for Tailwind!
+-- Otherwise it strikes me as little more than an illegible alternative to
+-- the `style` attribute!
 
-type Colour = String -- Stores a hexcode, with preceding "#"
+-- | Stores a CSS hexcode, with preceding "#"
+type Colour = String
+-- | The Tailwind colour pallet: https://v1.tailwindcss.com/docs/customizing-colors#default-color-palette
 tailwindColours :: [(String, [(Int, Colour)])]
 tailwindColours = [
     "Slate"~>[50~>"#f8fafc", 100~>"#f1f5f9", 200~>"#e2e8f0", 300~>"#cbd5e1",

@@ 1,4 1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+-- | Convert query data between parsed form data, multi-maps, & URI query strings.
 module Text.HTML.Form.Query(renderQueryString, renderQueryString', renderQuery',
         applyQuery, applyQuery') where
 


@@ 8,15 9,19 @@ import Data.List (intercalate)
 import Data.Text (unpack)
 import qualified Data.Text as Txt
 
+-- | Serialize a form to a URI query string.
 renderQueryString :: Form -> String
 renderQueryString = renderQueryString' . renderQuery'
+-- | Serialize a key-value multi-map to a URI query string.
 renderQueryString' :: [(String, String)] -> String
 renderQueryString' query = intercalate "&" [
     escape key ++ '=':escape val | (key, val) <- query
   ]
 
+-- | Serialize a form to a key-value multi-map.
 renderQuery' :: Form -> [(String, String)]
 renderQuery' form = concatMap renderInput' $ inputs form
+-- | Serialize an input to a key-value multi-map.
 renderInput' :: Input -> [(String, String)]
 renderInput' Input { inputType = inputType' }
     | inputType' `elem` ["submit", "reset", "button", "file"] = []


@@ 33,13 38,16 @@ renderInput' Input { inputType = "<select>",
             grp <- opts, opt <- subopts grp, optSelected opt]
 renderInput' Input { inputName = k, value = v } = [(unpack k, unpack v)]
 
+-- | escape a URI string.
 escape :: String -> String
 escape = escapeURIString isUnescapedInURIComponent
 
+-- | Adjust an input to store the appropriate values encoded in a key-value multi-map.
 applyQuery :: Input -> [(String, String)] -> Input
 applyQuery input@Input { inputName = n } qs
     | inputType input `notElem` ["submit", "reset", "button", "checkbox", "radio"],
         Just val' <- unpack n `lookup` qs = input { value = Txt.pack val' }
     | otherwise = input
+-- | Adjust all inputs in a form to store the values encoded in a key-value multi-map.
 applyQuery' :: Form -> [(String, String)] -> Form
 applyQuery' form qs = form { inputs = flip applyQuery qs `map` inputs form }

@@ 1,4 1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
+-- | Does the form contain valid data according to specified rules?
+-- Can we normalize it to be more likely to do so?
 module Text.HTML.Form.Validate(isInputValid, isInputValid', isFormValid, isFormValid',
         inputErrorMessage, inputErrorMessage', normalizeInput, normalizeForm) where
 


@@ 10,19 12,24 @@ import Network.URI (parseAbsoluteURI)
 import Data.Maybe (isJust, isNothing)
 import Text.Regex.TDFA ((=~), matchTest)
 
+-- | Are all inputs in a form valid according to their rules?
 isFormValid :: Form -> Bool
 isFormValid = all isInputValid . inputs
 
+-- | Are all inputs in a form valid according to their rules, once normalized?
 isFormValid' :: Form -> Bool
 isFormValid' = all isInputValid' . inputs
 
+-- | Is the given input valid?
 isInputValid :: Input -> Bool
 isInputValid = null . inputErrorMessage
 
+-- | Is the given input once normalized valid?
 isInputValid' :: Input -> Bool
 isInputValid' = null . inputErrorMessage'
 
-inputErrorMessage :: Input -> [Char]
+-- | Describe why a form input is invalid, or return the empty string.
+inputErrorMessage :: Input -> String
 inputErrorMessage Input { inputType = "hidden" } = "" -- Don't validate hiddens!
 inputErrorMessage self@Input { required = True }
     | inputType self == "checkbox", not $ checked self = "Required!"


@@ 88,21 95,28 @@ inputErrorMessage self@Input { inputType = "url" }
 inputErrorMessage self@Input { inputType = "week" } = isTime' self
 inputErrorMessage _ = ""
 
+-- | Describe why an input, once normalized, is invalid? Or returns empty string.
 inputErrorMessage' :: Input -> [Char]
 inputErrorMessage' = inputErrorMessage . normalizeInput
 
+-- | Helper to parse the time stored in an input.
 parseTime :: String -> Maybe DateTime
 parseTime = fmap localTimeUnwrap . localTimeParse ISO8601_DateAndTime
+-- | Does the input store a time?
 isTime :: Input -> Bool
 isTime = isJust . parseTime . Txt.unpack . value
+-- | Emit an error message if an input doesn't store a valid time.
 isTime' :: Input -> String
 isTime' x | isTime x = ""
     | otherwise = "Invalid time format!"
+-- | Parse a Text into any type that can be parsed from strings.
 readMaybe' :: Read a => Txt.Text -> Maybe a
 readMaybe' = readMaybe . Txt.unpack
+-- | Does the input store a valid URL?
 isURL :: Txt.Text -> Bool
 isURL = isNothing . parseAbsoluteURI . Txt.unpack
 
+-- | Implicitly tweak the input to make it more likely to be valid.
 normalizeInput :: Input -> Input
 normalizeInput self@Input { inputType = "url", value = val }
     | not $ ':' `Txt.elem` val = self { -- Is there a better check?


@@ 111,5 125,6 @@ normalizeInput self@Input { inputType = "url", value = val }
 -- Other aspects we wish to normalize?
 normalizeInput self = self
 
+-- | Implicitly tweak all of a form's inputs to make them more likely to be valid.
 normalizeForm :: Form -> Form
 normalizeForm self = self { inputs = map normalizeInput $ inputs self }

@@ 1,5 1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Text.HTML.Form.WebApp (renderPage, Form(..)) where
+-- | Renders forms to an HTML menu, for the sake of highly-constrained browser engines.
+-- Like those dealing with TV remotes.
+module Text.HTML.Form.WebApp (renderPage, Form(..), Query) where
 
 import Data.ByteString as BS
 import Data.ByteString.Char8 as B8


@@ 27,7 29,11 @@ import Text.Ginger.Html (html)
 import Data.Hourglass (Elapsed(..), Seconds(..), timeGetElapsed, localTimeToGlobal)
 import Text.HTML.Form.Colours (tailwindColours)
 
+-- | The query string manipulated by this serverside webapp.
 type Query = [(ByteString, Maybe ByteString)]
+-- | Converts URI path & query to rendered hyper-linked HTML representing menus
+-- for selecting values to upload to the server as prescribed by the given form.
+-- These values are returned to caller on the Left-branch.
 renderPage :: Form -> [Text] -> Query -> IO (Maybe (Either Query Text))
 renderPage form (n:path) query
     | Just ix <- readMaybe $ Txt.unpack n, ix < Prelude.length (inputs form) =


@@ 36,8 42,10 @@ renderPage form [] _ = return $ Just $ Right $ Txt.concat [
     "<a href='/0/?", Txt.pack $ renderQueryString form, "'>Start!</a>"]
 renderPage _ _ _ = return Nothing
 
+-- | Is this input type amongst the date-time family?
 isCalType :: Text -> Bool
 isCalType = flip L.elem ["date", "datetime-local", "datetime", "month", "time", "week"]
+-- | Render an input to the corresponding HTML, or form data to submit.
 renderInput :: Form -> Int -> Input -> [Text] -> [(ByteString, Maybe ByteString)] ->
     IO (Maybe (Either Query Text))
 renderInput form ix input [""] qs = renderInput form ix input [] qs


@@ 216,30 224,39 @@ renderInput form ix input [] qs = do
 renderInput _ _ input _ _ =
     return $ Just $ Right $ Txt.concat ["Unknown input type: ", inputType input]
 
+-- | Coerce Colour Pallet data into dynamically-typed Ginger data.
 colourGVal :: (ToGVal m a1, ToGVal m b, Eq a2, Num a2) => (a1, [(a2, b)]) -> GVal m
 colourGVal (key, hues) = orderedDict ["label"~>key, "value"~>lookup 500 hues]
 shadeGVal :: (ToGVal m a1, ToGVal m a2) => (a1, a2) -> GVal m
 shadeGVal (key, val) = orderedDict ["label"~>key, "value"~>val]
 
+-- | Convert Text to UTF8 ByteString data.
 utf8 :: Text -> ByteString
 utf8 = Txt.encodeUtf8
+-- | Convert String to UTF8 ByteString data.
 utf8' :: String -> ByteString
 utf8' = utf8 . Txt.pack
+-- | Set the given key in the query to the given value.
 set :: Text -> Text -> [(ByteString, Maybe ByteString)]
     -> [(ByteString, Maybe ByteString)]
 set "" _ qs = qs -- Mostly for buttons!
 set k' v' qs = (utf8 k', Just $ utf8 v'):[q | q@(k, _) <- qs, k /= utf8 k']
+-- | Remove given key from the query.
 unset :: Text -> Text -> [(ByteString, Maybe ByteString)]
     -> [(ByteString, Maybe ByteString)]
 unset k' v' qs = [q | q@(k, v) <- qs, not (k == utf8 k' && v == Just (utf8 v'))]
+-- | Retrieve the value corresponding to the given key in the query.
 get :: Text -> [(ByteString, Maybe ByteString)] -> String
 get k' qs
     | Just (Just ret) <- utf8 k' `lookup` qs =
         Txt.unpack $ Txt.decodeUtf8 ret
     | otherwise = ""
+-- | Convert the query data to string-pairs, for use in Query submodule.
 strQuery :: [(ByteString, Maybe ByteString)] -> [(String, String)]
 strQuery qs = [(B8.unpack k, B8.unpack $ fromMaybe "" v) | (k, v) <- qs]
 
+-- | Monadically takes a predicate and a list, and returns the pair of lists
+-- of elements which do and do not satisfy the predicate, respectively.
 partitionM :: Monad f => (a -> f Bool) -> [a] -> f ([a], [a])
 partitionM _ [] = pure ([], [])
 partitionM f (x:xs) = do

@@ 1,4 1,5 @@
 {-# LANGUAGE TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
+-- | Shuttle parsed form data to Ginger's dynamically-typed datamodel.
 module Text.HTML.Form.WebApp.Ginger(template, template', resolveSource, list') where
 
 import Text.HTML.Form


@@ 19,7 20,7 @@ import Data.Text as Txt
 import Data.Text.Encoding as Txt
 import Data.Text.Lazy as Txt (toStrict)
 import Data.ByteString.Char8 as B8
-import Network.URI (uriToString, escapeURIString, isUnescapedInURIComponent)
+import Network.URI (uriToString, escapeURIString, isUnescapedInURIComponent, nullURI)
 import Text.XML (Document(..), Element(..), Prologue(..), Node, def, renderText)
 
 import Data.List (nub)


@@ 29,11 30,14 @@ import qualified Data.Map as M
 import Text.HTML.Form.Validate (inputErrorMessage')
 import Text.HTML.Form.Query (applyQuery)
 
+-- | A key-value query string.
 type Query = [(ByteString, Maybe ByteString)]
+-- | Run the given template with the given Bureaucromancy data.
 template :: Monad m => String -> Form -> Int -> Input -> Query ->
         m (Maybe (Either Query Text))
 template name form ix input query =
     template' name form ix input query $ const $ toGVal ()
+-- | Run the given template with the given Bureaucromancy & Ginger data.
 template' :: Monad m => String -> Form -> Int -> Input -> Query ->
         (Text -> GVal (Run SourcePos (Writer Html) Html)) ->
         m (Maybe (Either Query Text))


@@ 57,12 61,14 @@ template' name form ix input query ctxt'
         return$toGVal$Txt.pack $ escapeURIString isUnescapedInURIComponent uri'
     xURI _ = return $ toGVal ()
 
+-- | Lookup the given template from a compiled-in directory.
 resolveSource :: FilePath -> Maybe (Maybe [Char])
 resolveSource ('/':path) = resolveSource path
 resolveSource path = Just $ fmap utf8 $
     flip lookup $(makeRelativeToProject "tpl" >>= embedRecursiveDir) $
     normalise $ '/':path
 
+-- | Convert a query into Ginger's datamodel.
 query2gval :: Monad m => Query -> GVal m
 query2gval qs =
     (orderedDict [(Txt.decodeUtf8 k, (list1 vs){ asFunction = Just $ gElem vs })


@@ 76,6 82,7 @@ query2gval qs =
     gElem xs [(_, x)] | Just x' <- asBytes x = return$toGVal$Prelude.elem x' xs
     gElem _ _ = return $ toGVal ()
 
+-- | Convert a form to Ginger's datamodel.
 form2gval :: Form -> GVal m
 form2gval form = orderedDict [
     "action"   ~> uriToString id (action form) "",


@@ 89,6 96,7 @@ form2gval form = orderedDict [
     "rel"      ~> rel form
   ]
 
+-- | Convert an input to Ginger's datamodel.
 input2gval :: (Int, Input) -> Query -> GVal m
 input2gval (ix, input) query = orderedDict [
     "index"       ~> ix,


@@ 138,23 146,26 @@ input2gval (ix, input) query = orderedDict [
     "alt"         ~> imgAlt (imageData input),
     "width"       ~> fst (imgSize $ imageData input),
     "height"      ~> snd (imgSize $ imageData input),
-    "src"         ~> imgSrc (imageData input),
+    "src"         ~> uriToString id (fromMaybe nullURI $ imgSrc $ imageData input) "",
     "autocorrect" ~> autocorrect (textArea input),
     "cols"        ~> size input,
     "rows"        ~> rows (textArea input),
     "spellcheck"  ~> spellcheck (textArea input),
     "textwrap"    ~> textwrap (textArea input)
   ]
+-- | Convert an XML node to Ginger's datamodel.
 html :: Node -> Html
 html node = unsafeRawHtml $ Txt.toStrict $ renderText def (
     Document (Prologue [] Nothing []) (Element "div" M.empty [node]) []
   )
+-- | Convert an option group to Ginger's datamodel.
 optgroup2gval :: [ByteString] -> OptionGroup -> GVal m
 optgroup2gval query optgroup = orderedDict [
     "label"    ~> optsLabel optgroup,
     "disabled" ~> optsDisabled optgroup,
     ("opts", list' $ Prelude.map (opt2gval query) $ subopts optgroup)
   ]
+-- | Convert an option to Ginger's datamodel.
 opt2gval :: [ByteString] -> Option -> GVal m
 opt2gval query opt = orderedDict [
     "label"    ~> optLabel opt,


@@ 163,17 174,22 @@ opt2gval query opt = orderedDict [
     "disabled" ~> optDisabled opt
   ]
 
+-- | A ginger list which in most uses looks like its initial value.
 list1 :: ToGVal m a => [a] -> GVal m
 list1 vs@(v:_) = (toGVal v) {
     asList = Just $ Prelude.map toGVal vs,
     V.length = Just $ Prelude.length vs
   }
 list1 [] = (toGVal True) { asList = Just [], V.length = Just 0 }
+-- | Type-constrained conversion of a list to Ginger's datamodel,
+-- serves to avoid type-inference issues.
 list' :: [GVal m] -> GVal m
 list' = toGVal
 
+-- | Aggregates values in a key-value list under their keys.
 groupSort :: Eq k => [(k, Maybe v)] -> [(k, [v])]
 groupSort q = [(k, [v | (k', Just v) <- q, k == k']) | k <- nub $ Prelude.map fst q]
 
+-- | Convert from UTF-8 bytestring to a string.
 utf8 :: ByteString -> String
 utf8 = Txt.unpack . Txt.decodeUtf8

@@ 1,4 1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
+-- | Converts data between Ginger templates & HourGlass,
+-- whilst decomposing the datamodel further.
 module Text.HTML.Form.WebApp.Ginger.Hourglass(
     timeData, modifyTime, modifyTime', timeParseOrNow, gSeqTo, gPad2) where
 


@@ 10,6 12,7 @@ import qualified Data.Text as Txt
 import Text.Read (readMaybe)
 import System.IO.Unsafe (unsafePerformIO) -- For use with localDateCurrent
 
+-- | Converts HourGlass data to Ginger's datamodel.
 timeData :: LocalTime DateTime -> GVal a
 timeData datetime = orderedDict [
     "year" ~> abs (dateYear date),


@@ 33,16 36,20 @@ timeData datetime = orderedDict [
   where
     date = dtDate $ localTimeUnwrap datetime
 
+-- Converts an enum to Ginger's datamodel.
 enumG :: (Enum x, Show x) => x -> GVal a
 enumG = showG fromEnum
+-- | Converts showable data to Ginger's datamodel via a callback.
 showG :: (Show x, ToGVal m a) => (x -> a) -> x -> GVal m
 showG cb x = (toGVal $ cb x) {
     asText = Txt.pack $ show x,
     asHtml = unsafeRawHtml $ Txt.pack $ show x
   }
+-- Retrieves the integral value from HourGlass Nanoseconds.
 unwrapNanos :: NanoSeconds -> Int
 unwrapNanos (NanoSeconds x) = fromEnum x
 
+-- | Interpret an operation upon a given time.
 modifyTime :: Txt.Text -> LocalTime DateTime -> Maybe (LocalTime DateTime)
 modifyTime "-hour" time = modLTime time $ flip timeAdd mempty { durationHours = -1 }
 modifyTime "+hour" time = modLTime time $ flip timeAdd mempty { durationHours = 1 }


@@ 109,27 116,33 @@ modifyTime op time = case op of
     "-date7" -> addPeriod' time mempty { periodDays = -7 }
     "+date7" -> addPeriod' time mempty { periodDays = 7 }
     _ -> Nothing
+-- | Helper for modifying HourGlass data.
 modLTime :: LocalTime a -> (a -> b) -> Maybe (LocalTime b)
 modLTime a = Just . flip fmap a
+-- | Helper for adding an offset to a HourGlass local time.
 addPeriod' :: LocalTime DateTime -> Period -> Maybe (LocalTime DateTime)
 addPeriod' time period = modLTime time $ \time' -> time' {
     dtDate = dtDate time' `dateAddPeriod` period
   }
+-- | Helper for adding an offset to the timezone of a local time as stored by HourGlass.
 offsetTZ :: Time t => LocalTime t -> Int -> Maybe (LocalTime t)
 offsetTZ time mins = Just $ localTimeSetTimezone
     (TimezoneOffset $ timezoneOffsetToMinutes (localTimeGetTimezone time) + mins)
     time
 
+-- | Helper for modifying time component of HourGlass data.
 modifyTime' :: Txt.Text -> String -> Maybe String
 modifyTime' op time
     | Just ret <- modifyTime op $ unsafePerformIO $ timeParseOrNow time =
         Just $ localTimePrint ISO8601_DateAndTime ret
     | otherwise = Nothing
+-- | Parse a string to HourGlass data, falling back to the current time.
 timeParseOrNow :: String -> IO (LocalTime DateTime)
 timeParseOrNow txt = case localTimeParse ISO8601_DateAndTime txt of
     Just ret -> return ret
     Nothing -> localDateCurrent
 
+-- | A sequence to be called from Ginger templates.
 gSeqTo :: [(a, GVal m)] -> GVal m
 gSeqTo [(_, from), (_, to)]
     | Just x <- toInt from, Just y <- toInt to = toGVal [x..y]


@@ 137,6 150,8 @@ gSeqTo [(_, from), (_, than), (_, to)]
     | Just x <- toInt from, Just y <- toInt than, Just z <- toInt to = toGVal [x,y..z]
 gSeqTo _ = toGVal ()
 
+-- | A padding function to be called from Ginger templates,
+-- prepending 0 when needed to get 2 digits.
 gPad2 :: [(a, GVal m)] -> GVal m
 gPad2 [(_, x)] | Just y <- toInt x, y < 10 = toGVal $ '0':show x
     | Just y <- toInt x = toGVal $ show y

@@ 1,4 1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+-- | Exposes data for a menu of timezones.
 module Text.HTML.Form.WebApp.Ginger.TZ(tzdata, continents) where
 
 import Text.Ginger.GVal as V (GVal, toGVal, orderedDict, (~>), list)


@@ 11,6 12,7 @@ import Data.List (nub)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BSC
 
+-- | Parses timezone data into a menu for Ginger templates.
 tzdata :: Int64 -> String -> GVal m
 tzdata now prefix = list [orderedDict [
         "label" ~> label,


@@ 23,6 25,7 @@ tzdata now prefix = list [orderedDict [
     contains "" = BSC.notElem '/'
     contains "..." = BSC.notElem '/'
     contains x = BS.isPrefixOf x
+-- | Serialize an offset to string, ensuring 0 is prepended to minutes when needed.
 formatOffset :: (Show a, Integral a) => a -> [Char]
 formatOffset offset
     | minutes < 10 = show hours ++ ':':'0': show minutes


@@ 31,6 34,7 @@ formatOffset offset
     hours = offset `div` 60
     minutes = abs $ offset `rem` 60
 
+-- | Retrieves continents list for Ginger templates.
 continents :: GVal m
 continents = list $ map toGVal $ nub $ "...":[prefix |
         (label, _) <- M.toList tzNameLabelMap,