{-# 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)
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)] -> Form [XMLGenT x (HSX.XML x)] v [a]
checkboxes items = checkboxes' (map (first show) items) `check` (\strs -> sequenceA $ map (flip maybeRead' "Could not parse checkbox data") strs)

{-
Normally checkboxes all have the same 'name' element, and you get an
array of results back. But we don't want to parse the array, so we use
a trick and just give each checkbox a unique name.
-}
checkboxes' :: (XMLGenerator x, Monad v, Applicative v) => [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v [String]
checkboxes' items =
    plug (\listItems -> [<ul class="checkboxes"><% listItems %></ul>]) (catMaybes <$> (sequenceA $ map mkCheckbox items))
    where 
      mkCheckbox (val, labelText) =
          generalInput (\n mv ->
                      if mv == (Just val)
                      then [<li><input type="checkbox" name=n value=val checked="checked"/><% labelText %></li>]
                      else [<li><input type="checkbox" name=n value=val />                 <% labelText %></li>])

-- todo: make the label be any valid markup, not just a string
radio :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe a)
radio items = radio'' (map (first show) items) `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)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe String)
radio'' items = generalInput (\n mv -> [<ul class="radios"><% concatMap (radioItem n mv) items %></ul>])

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