{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, TypeFamilies, UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-}
module HSP.Formlets 
    ( input
    , textarea
    , file
    , label
    , hidden
    , submit
    , password
    , checkboxes
    , select
    , selectMulti
    , radio
    , div
    , span
    , withAttrs
    , fset
    ) where

import Control.Arrow (first)
import Control.Applicative (Applicative(pure),(<$>))
import Control.Applicative.Error (Failing(Success), maybeRead')
import Data.Maybe (catMaybes, isNothing)
import Data.Monoid (Monoid)
import Data.Traversable (sequenceA)
import HSP
import qualified HSX.XMLGenerator as HSX
import Text.Formlets (Form, File, Rect(rectRows, rectCols), check, generalInput, generalInputMulti, input', inputFile, plug, xml)
import Prelude hiding (div, span)

input :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
input = input' (\n v -> [<input type="text" name=n value=v />])

textarea :: (XMLGenerator x, Monad v) => (String -> Rect) -> Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
textarea calcRect =
        input' (\n v -> 
                    let rect = calcRect v
                    in [ <textarea rows=(rectRows rect) cols=(rectCols rect) name=n ><% v %></textarea> ])

file :: (XMLGenerator x, Monad v) => Form [XMLGenT x (HSX.XML x)] v File
file = inputFile $ \name -> [<input type="file" name=name />]

label :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v ()
label str = xml $ [<label><% str %></label>]

hidden :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
hidden = input' (\n v -> [<input type="hidden" name=n value=v />])

submit :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v Bool
submit val = (generalInput (\n _ -> [<div><input type="submit" name=n value=val /></div>])) `check` 
             (\res -> 
                  case res of
                    Nothing -> pure False
                    (Just "") -> pure False
                    _ -> pure True
             )

-- |A password field with an optional value
password :: (Monad v, HSX.XMLGenerator x) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
password = input' (\n v -> [<input type="password" name=n value=v />])

checkboxes :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => [(a, String)] -> [a] -> Form [XMLGenT x (HSX.XML x)] v [a]
checkboxes items checked = 
    (checkboxes' (map (first show) items) (map show checked))
    `check` 
    (\strs -> sequenceA $ map (flip maybeRead' "Could not parse checkbox data") strs)

checkboxes' :: (XMLGenerator x, Monad v, Applicative v) => [(String, String)] -> [String] -> Form [XMLGenT x (HSX.XML x)] v [String]
checkboxes' items checked =
    generalInputMulti $ \name selectedValues ->
        [<ul class="checkboxes">
          <% mapM (mkOption name selectedValues) items %>
        </ul>]
    where
      mkOption n selectedValues (value, label)
          | value `elem` (if not (null selectedValues) then selectedValues else checked) =
              [<li><span><input type="checkbox" name=n value=value checked="checked"/><% label %></span></li>]
          | otherwise =
              [<li><span><input type="checkbox" name=n value=value /><%                  label %></span></li>]

radio :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => [(a, String)] -> Maybe a -> Form [XMLGenT x (HSX.XML x)] v (Maybe a)
radio items checked = radio'' (map (first show) items) (fmap show checked) `check` checkItem
    where
      checkItem Nothing = Success Nothing
      checkItem (Just str) = Just <$> maybeRead' str ("Could not parse radio data: " ++ str)

radio'' :: (XMLGenerator x, Applicative v, Monad v) => [(String, String)] -> Maybe String -> Form [XMLGenT x (HSX.XML x)] v (Maybe String)
radio'' items checked = generalInput (\n mv -> [<ul class="radios"><% concatMap (radioItem n mv checked) items %></ul>])

radioItem :: (XMLGenerator x) => String -> Maybe String -> Maybe String -> (String, String) -> [XMLGenT x (HSX.XML x)]
radioItem n mv mc (val, labelText) =
    if ((isNothing mv && (mc == Just val)) || (mv == Just val))
       then [<li><span><input type="radio" name=n value=val checked="checked"/><% labelText %></span></li>]
       else [<li><span><input type="radio" name=n value=val />                 <% labelText %></span></li>]

-- |drop down box
select :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => Maybe a -> [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe a)
select defaultSelection items = select' (show <$> defaultSelection) (map (first show) items) `check` checkOption
    where
      checkOption Nothing = Success Nothing
      checkOption (Just str) = Just <$> maybeRead' str ("Could not parse select data: " ++ str)

select' :: (XMLGenerator x, Applicative v, Monad v) => Maybe String -> [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe String)
select' defaultSelection items = generalInput (\n mv -> [<select name=n><% concatMap (selectOption (maybe defaultSelection Just mv)) items %></select>])

selectOption :: (XMLGenerator x) => Maybe String -> (String, String) -> [XMLGenT x (HSX.XML x)]
selectOption mv (val, labelText) =
    if mv == (Just val)
       then [<option value=val selected="selected"><% labelText %></option>]
       else [<option value=val ><% labelText %></option>]

selectMulti :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v [a]
selectMulti items = selectMulti' (map (first show) items) `check` (\strs -> sequenceA $ map (flip maybeRead' "Could not parse select data") strs)

selectMulti' :: (XMLGenerator x, Monad v, Applicative v) => [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v [String]
selectMulti' items =
    generalInputMulti $ \name selectedValues ->
        [<select name=name multiple="multiple">
          <% mapM (mkOption selectedValues) items %>
        </select>]
    where
      mkOption selectedValues (value, label)
          | value `elem` selectedValues =
              [<option value=value selected="selected"><% label %></option>]
          | otherwise =
              [<option value=value ><%                    label %></option>]

-- |A convenience function to wrap a form inside a div.  This could
-- have been defined outside this module, but it is handy to put it
-- here.
div :: (Monad m1, EmbedAsChild m xml, EmbedAsAttr m (Attr [Char] a), Monoid xml) => a -> Form xml m1 b -> Form [XMLGenT m (HSX.XML m)] m1 b
div c frm = (\ xml -> [<div class=c><% xml %></div>]) `plug` frm

-- |Like div, for span.
span :: (Monad m1, EmbedAsChild m xml, EmbedAsAttr m (Attr [Char] a), Monoid xml) => a -> Form xml m1 b -> Form [XMLGenT m (HSX.XML m)] m1 b
span c frm = (\ xml -> [<span class=c><% xml %></span>]) `plug` frm

-- |add additional attributes to the xml element(s)
-- See also: 'fset'
withAttrs :: (EmbedAsAttr x (Attr attr val), XMLGenerator x, Monad v) => [Attr attr val] -> Form [XMLGenT x (HSX.XML x)] v a -> Form [XMLGenT x (HSX.XML x)] v a
withAttrs attrs = plug (map (`set` attrs))

-- |add additional attributes to the xml element(s)
-- same as withAttrs but with the arguments reversed
-- See also: 'withAttrs'
fset :: (EmbedAsAttr x (Attr attr val), XMLGenerator x, Monad v) => Form [XMLGenT x (HSX.XML x)] v a -> [Attr attr val] -> Form [XMLGenT x (HSX.XML x)] v a
fset = flip withAttrs