{-# LANGUAGE OverloadedStrings #-}
module Internal.Forms(findForm, prefillForm, modifyForm) where

import Text.XML
import Text.XML.Cursor
import qualified Data.Map as M
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as Txt

import Internal (Session, Session'(..))

import Data.Maybe
import Control.Concurrent.MVar

findForm :: Cursor -> HM.HashMap Txt.Text Cursor -> Element
findForm cursor id2els
    | NodeElement el@(Element (Name "form" _ _) _ _) <- node cursor = el
    | NodeElement el <- node cursor, Just el' <- findForm' el id2els = el'
    | (form:_) <- parent cursor = findForm form id2els -- Propagate id2els for the sake of event dispatch.
    | otherwise = Element "fail" M.empty [] -- Tombstone value

findForm' :: Element -> HM.HashMap Txt.Text Cursor -> Maybe Element
findForm' (Element (Name name _ _) attrs _) id2els
    | name == "label", Just for <- "for" `M.lookup` attrs',
            Just input <- for `HM.lookup` id2els = Just $ findForm input id2els
    | Just form <- "form" `M.lookup` attrs', Just cursor <- form `HM.lookup` id2els,
        NodeElement ret <- node cursor = Just ret
    | otherwise = Nothing
  where attrs' = M.mapKeys nameLocalName attrs

prefillForm (Element (Name "form" _ _) attrs children) root = HM.fromListWith (++) (
    (prefillForm' $ map node $ (descendant >=> checkElement isForForm) root) ++
    prefillForm' children)
  where
    isForForm (Element _ attrs' _) | Just id <- "id" `M.lookup` M.mapKeys nameLocalName attrs,
        Just form <- "form" `M.lookup` M.mapKeys nameLocalName attrs' = id == form
    isForForm _ = False
prefillForm _ _ = HM.empty

prefillForm' (NodeElement (Element (Name "input" _ _) attrs _):nodes)
    | Just type_ <- "type" `M.lookup` attrs', Just name <- "name" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs',
            type_ `notElem` ["radio", "checkbox", "reset", "submit", "button"] || "checked" `M.member` attrs' =
        (name, [value]):prefillForm' nodes
  where attrs' = M.mapKeys nameLocalName attrs
prefillForm' (NodeElement (Element (Name "select" _ _) attrs childs):nodes)
    | Just name <- "name" `M.lookup` attrs' =
        case [value | NodeElement (Element _ attrs2 _) <- childs,
                value <- maybeToList $ M.lookup "value" $ M.mapKeys nameLocalName attrs2] of
            [] -> prefillForm' nodes
            values | "multiple" `M.member` attrs' -> (name, values):prefillForm' nodes
            (value:_) -> (name, [value]):prefillForm' nodes
  where attrs' = M.mapKeys nameLocalName attrs
prefillForm' (NodeElement (Element (Name "textarea" _ _) attrs childs):nodes)
    | Just name <- "name" `M.lookup` attrs =
        (name, [Txt.concat [value | NodeContent value <- childs]]):prefillForm' nodes
prefillForm' (_:nodes) = prefillForm' nodes
prefillForm' [] = []

modifyForm :: ([Txt.Text] -> [Txt.Text]) -> Txt.Text -> Cursor -> Session -> IO ()
modifyForm cb name el session = modifyMVar_ session $ \session' -> do
    let form = findForm el $ id2els session'
    let blanked = prefillForm form $ fromDocument $ document session'
    let old = M.findWithDefault blanked form $ forms session'
    let new = HM.insert name (cb $ HM.lookupDefault [] name old) old
    return $ case form of
        Element (Name "form" _ _) _ _ ->
            session' { forms = M.insert form new $ forms session' }
        _ -> session'