From de2d2b691b2b7b5891d89e01bad541be153cc5ec Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 6 Sep 2023 14:22:00 +1200
Subject: [PATCH] Parse labels, aria-describedby, datalists, selects, buttons,
 & textareas.

---
 src/Text/HTML/Form.hs | 219 +++++++++++++++++++++++++++++++++++++++---
 1 file changed, 206 insertions(+), 13 deletions(-)

diff --git a/src/Text/HTML/Form.hs b/src/Text/HTML/Form.hs
index 135542c..eeff4fd 100644
--- a/src/Text/HTML/Form.hs
+++ b/src/Text/HTML/Form.hs
@@ -4,14 +4,15 @@ module Text.HTML.Form (Form(..), Input(..), parseElement, parseDocument) where
 import Data.Text (Text)
 import qualified Data.Text as Txt
 import Text.XML.Cursor
-import Text.XML (Document, Name)
+import Text.XML (Document, Name(..), Node(..))
 
 import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
-import Network.URI (parseURIReference, URI, nullURI)
 import Data.Char (isDigit)
-import Data.List (nub)
+import Data.List (singleton)
 import Text.Read (readMaybe)
+import Data.Function (on)
 
+import Network.URI (parseURIReference, URI, nullURI)
 import Text.Regex.TDFA (Regex, defaultCompOpt, defaultExecOpt)
 import Text.Regex.TDFA.Text (compile)
 
@@ -30,6 +31,8 @@ data Form = Form {
 
 data Input = Input {
     -- Core attributes
+    label :: Node,
+    description :: Node,
     inputType :: Text,
     dirname :: Text,
     inputName :: Text,
@@ -48,7 +51,7 @@ data Input = Input {
     formValidate :: Bool,
     formTarget :: Maybe Text,
     inputMode :: Text,
-    list :: [(Text, Text)],
+    list :: [OptionGroup],
     -- Validation
     range :: (Maybe Text, Maybe Text),
     step :: Maybe Text,
@@ -61,17 +64,41 @@ data Input = Input {
     title :: Text,
     size :: Maybe Int,
     fileData :: FileSelector,
-    imageData :: ImageData
+    imageData :: ImageData,
+    textArea :: TextArea
+}
+data OptionGroup = OptGroup {
+    optsLabel :: Text,
+    optsDisabled :: Bool,
+    subopts :: [Option]
+}
+data Option = Option {
+    optLabel :: Text,
+    optValue :: Text,
+    optSelected :: Bool,
+    optDisabled :: Bool
 }
 data FileSelector = FileSelector {
     fileAccept :: [Text],
     fileCapture :: Text
 }
+defaultFileData :: FileSelector
+defaultFileData = FileSelector [] ""
 data ImageData = ImageData {
     imgAlt :: Maybe Text,
     imgSize :: (Maybe Int, Maybe Int),
     imgSrc :: Maybe Text
 }
+defaultImageData :: ImageData
+defaultImageData = ImageData Nothing (Nothing, Nothing) Nothing
+data TextArea = TextArea {
+    autocorrect :: Bool,
+    rows :: Maybe Int,
+    spellcheck :: Maybe Bool,
+    textwrap :: Maybe Bool
+}
+defaultTextArea :: TextArea
+defaultTextArea = TextArea True Nothing Nothing Nothing
 
 attr :: Text -> Cursor -> Text -> Text
 attr n el def | [ret] <- n `laxAttribute` el = ret
@@ -99,18 +126,27 @@ parseElement el | _:_ <- laxElement "form" el = Just Form {
       }
     | otherwise = Nothing
 
+root :: Axis
+root = singleton . last . ancestor
+laxElements :: [Text] -> Axis
+laxElements ns = checkName (\x -> or [
+    on (==) Txt.toCaseFold n $ nameLocalName x | n <- ns])
 queryInputs :: Cursor -> [Cursor]
 queryInputs form = (allInputs >=> inForm) form
   where
-    allInputs = last' ancestor >=> descendant >=> laxElement "input"
-    inForm = check nestedInForm &++
-        check (\x -> laxAttribute "form" x == laxAttribute "id" form)
+    allInputs = root >=> descendant >=> laxElements [
+        "input", "textarea", "button", "select"]
+    inForm = check (\x ->
+        laxAttribute "form" x == laxAttribute "id" form ||
+        nestedInForm x)
     nestedInForm x = listToMaybe ((ancestor >=> laxElement "form") x) == Just form
-    last' f x | ret:_ <- reverse $ f x = [ret]
-        | otherwise = []
-    f &++ g = \x -> nub (f x ++ g x)
 parseInput :: Cursor -> Maybe Input
 parseInput el | _:_ <- laxElement "input" el = Just Input {
+        label = fromMaybe (mkEl $ attr "name" el "") $ fmap node $
+            listToMaybe ((ancestor >=> laxElement "label") el) *>
+            elByAttr "for" (attr "id" el ""),
+        description = fromMaybe (mkEl "") $ fmap node $
+            elByID $ attr "aria-describedby" el "",
         inputType = attr "type" el "text",
         value = attr "value" el "",
         inputAutocomplete = attr "autocomplete" el "on",
@@ -129,7 +165,7 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
         formValidate = not $ hasAttr "formnovalidate" el,
         formTarget = mAttr "formtarget" el,
         inputMode = attr "inputmode" el "text",
-        list = [], -- TODO
+        list = fromMaybe [] $ fmap parseOptions (elByID =<< mAttr "list" el),
         range = (mAttr "min" el, mAttr "max" el),
         step = mAttr "step" el,
         lengthRange = (attr'' "minlength" el readMaybe "",
@@ -149,9 +185,166 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
             imgSize = (attr'' "width" el readMaybe "",
                 attr'' "height" el readMaybe ""),
             imgSrc = mAttr "src" el
-        }
+        },
+        textArea = defaultTextArea
       }
+    | _:_ <- laxElement "textarea" el = Just Input {
+        inputType = "<textarea>",
+        label = fromMaybe (mkEl $ attr "name" el "") $ fmap node $
+            listToMaybe ((ancestor >=> laxElement "label") el) *>
+            elByAttr "for" (attr "id" el ""),
+        description = fromMaybe (mkEl "") $ fmap node $
+            elByID $ attr "aria-describedby" el "",
+        value = Txt.concat $ (descendant >=> content) el,
+
+        inputAutocomplete = attr "autocomplete" el "on",
+        autofocus = hasAttr "autofocus" el,
+        size = attr'' "cols" el readMaybe "",
+        dirname = attr "dirname" el "",
+        disabled = hasAttr "disabled" el,
+        lengthRange = (attr'' "minLength" el readMaybe "",
+            attr'' "maxLength" el readMaybe ""),
+        inputName = attr "name" el "",
+        placeholder = attr "placeholder" el "",
+        readonly = hasAttr "readonly" el,
+        required = hasAttr "required" el,
+        title = attr "title" el "",
+        inputMode = attr "inputMode" el "text",
+        textArea = TextArea {
+            autocorrect = attr "autocorrect" el "on" /= "off",
+            rows = attr'' "rows" el readMaybe "",
+            spellcheck = attr' "spellcheck" el (\x -> case x of
+                "true" -> Just True
+                "false" -> Just False
+                "default" -> Nothing
+                _ -> Nothing) "default",
+            textwrap = attr' "wrap" el (\x -> case x of
+                "hard" -> Just True
+                "soft" -> Just False
+                "off" -> Nothing
+                _ -> Just False) "soft"
+        },
+
+        checked = True,
+        multiple = False,
+        formAction = Nothing,
+        formEnctype = Nothing,
+        formMethod = Nothing,
+        formValidate = False,
+        formTarget = Nothing,
+        list = [],
+        range = (Nothing, Nothing),
+        step = Nothing,
+        pattern = Nothing,
+        fileData = defaultFileData,
+        imageData = defaultImageData
+    }
+    | _:_ <- laxElement "button" el = Just Input {
+        -- Fallingback to the input itself as its label allow for
+        -- the full richness of its children to be rendered!
+        label = fromMaybe (node el) $ fmap node $
+            listToMaybe ((ancestor >=> laxElement "label") el) *>
+            elByAttr "for" (attr "id" el ""),
+        description = fromMaybe (node el) $ fmap node $
+            elByID $ attr "aria-describedby" el "",
+
+        autofocus = hasAttr "autofocus" el,
+        disabled = hasAttr "disabled" el,
+        formAction = if hasAttr "formaction" el
+            then attr' "formaction" el (parseURIReference . Txt.unpack) ""
+            else Nothing,
+        formEnctype = mAttr "formenctype" el,
+        formMethod = mAttr "formmethod" el,
+        formValidate = not $ hasAttr "formnovalidate" el,
+        formTarget = mAttr "formtarget" el,
+        inputName = attr "name" el "",
+        -- Popover buttons should be handled by HTML engine, not form engine.
+        inputType = attr "type" el "submit",
+        value = attr "value" el "",
+        title = attr "title" el "",
+        -- Placeholder makes sense as a place to put the label...
+        placeholder = Txt.concat $ (descendant >=> content) el,
+
+        dirname = "",
+        inputAutocomplete = "",
+        checked = False, -- Switch to true for the activated button!
+        readonly = False,
+        multiple = False,
+        inputMode = "",
+        list = [],
+        range = (Nothing, Nothing),
+        step = Nothing,
+        lengthRange = (Nothing, Nothing),
+        pattern = Nothing,
+        required = False,
+        size = Nothing,
+        fileData = defaultFileData,
+        imageData = defaultImageData,
+        textArea = defaultTextArea
+    }
+    | _:_ <- laxElement "select" el = Just Input {
+        inputType = "<select>",
+        label = fromMaybe (mkEl $ attr "name" el "") $ fmap node $
+            listToMaybe ((ancestor >=> laxElement "label") el) *>
+            elByAttr "for" (attr "id" el ""),
+        description = fromMaybe (mkEl "") $ fmap node $
+            elByID $ attr "aria-describedby" el "",
+
+        inputAutocomplete = attr "autocomplete" el "on",
+        autofocus = hasAttr "autofocus" el,
+        disabled = hasAttr "disabled" el,
+        multiple = hasAttr "multiple" el,
+        inputName = attr "name" el "",
+        required = hasAttr "required" el,
+        size = attr'' "size" el readMaybe "",
+        list = parseOptions el,
+        title = attr "title" el "",
+
+        dirname = "",
+        value = "", -- Sourced from list...
+        checked = True,
+        readonly = False,
+        formAction = Nothing,
+        formEnctype = Nothing,
+        formMethod = Nothing,
+        formValidate = False,
+        formTarget = Nothing,
+        inputMode = "",
+        range = (Nothing, Nothing),
+        step = Nothing,
+        lengthRange = (Nothing, Nothing),
+        pattern = Nothing,
+        placeholder = "",
+        fileData = defaultFileData,
+        imageData = defaultImageData,
+        textArea = defaultTextArea
+    }
     | otherwise = Nothing
+  where
+    elByAttr k v = listToMaybe $ (root >=> descendant >=> attributeIs k v) el
+    elByID = elByAttr "id"
+    mkEl txt = NodeContent txt
+parseOptions :: Cursor -> [OptionGroup]
+parseOptions el = [parseGroup opt
+    | opt <- (descendant >=> laxElements ["option", "optgroup"] >=>
+        checkNot (parent >=> laxElement "optgroup")) el]
+  where
+    checkNot test = check (not . bool . test)
+    parseGroup opt
+        | _:_ <- laxElement "option" opt =
+            OptGroup "" False [parseOption opt False]
+        | _:_ <- laxElement "optgroup" opt = OptGroup {
+            optsLabel = attr "label" opt "",
+            optsDisabled = hasAttr "disabled" opt,
+            subopts = [parseOption o $ hasAttr "disabled" opt | o <- child opt]
+          }
+        | otherwise = OptGroup "" True [] -- Shouldn't happen!
+    parseOption opt disabledOverride = Option {
+        optLabel = attr "label" opt text,
+        optValue = attr "value" opt text,
+        optSelected = hasAttr "selected" opt,
+        optDisabled = hasAttr "disabled" opt || disabledOverride
+      } where text = Txt.concat $ (descendant >=> content) opt
 
 read' :: Read a => Text -> a
 read' = read . Txt.unpack
-- 
2.30.2