{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, TypeFamilies, UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-}
module HSP.Formlets where

--import Control.Arrow (second)
import Control.Applicative
import Control.Applicative.Error
--import Control.Concurrent(forkIO)
--import Control.Monad(ap)
--import Control.Monad.Trans(liftIO)
import Data.List
import Data.Maybe (fromMaybe)
import Data.Monoid
import HSP
import qualified HSX.XMLGenerator as HSX
import Text.Formlets
import Text.Formlets.Markup
-- import HAppS.Server (Response,ServerPart,Method(POST,GET), method, withDataFn, lookPairs, dir, ok, WebT(..), toResponse, simpleHTTP, nullConf, validateConf, waitForTermination, Result(..), multi, anyRequest)

-- | An alternative to optionalInput, you can supply a default result.
defaultResultInput :: Monad m => (String -> String -> xml) -> String -> Maybe String -> Form xml m String
defaultResultInput i defaultResult defaultValue = generalInput i' `check` (Success . maybe defaultResult id)
    where i' n v = i n (fromMaybe (fromMaybe "" defaultValue) v)

-- * FormHSXT

type FormHSXT x v a = Form [XMLGenT x (HSX.XML x)] v a
{-
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> ])

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 = (input' (\n _ -> [<input type="submit" name=n value=val />]) Nothing) `check` (pure . (/= ""))

-}
-- |Most inputs have this as their default result, the result used
-- when there is nothing in the form data for the input's id.  This is
-- because most inputs always appear in the form data, but not when
-- their disabled attribute is set.  The empty string is used because
-- it is short, but "disabled" might be a better choice.
dv :: String
dv = ""

-- instance (HSX.XMLGenerator m, HSX.XMLGen m, [XMLGenT m (HSX.XML m)] ~ x) => Markup x where
{-
instance (XMLGenerator m, [XMLGenT m (HSX.XML m)] ~ x) => Markup x where
    input = inputF True
    textarea dimsFn init = textareaF dimsFn True init
    password = passwordF True
    hidden = hiddenF . fromMaybe ""
    file = undefined
    radio = radioF True
    label = undefined
    selectRaw = selectRawF True
    submit = submitF True
    checkbox = checkboxF True
    param = undefined
-}
-- |An input field with an optional value
inputF :: (Monad v, HSX.XMLGenerator x) => Bool -> Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
inputF True = defaultResultInput (\n v -> [<input type="text" id=n name=n value=v />]) dv
inputF False = defaultResultInput (\n v -> [<input type="text" id=n name=n value=v disabled="disabled" />]) dv

-- |A text input field with a size attribute.
text :: (Monad v, HSX.XMLGenerator x) => (Maybe String -> Int) -> Bool -> Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
text sizeFn True init = defaultResultInput (\n v -> [<input type="text" id=n name=n value=v size=(show (sizeFn init)) />]) dv init
text sizeFn False init = defaultResultInput (\n v -> [<input type="text" id=n name=n value=v disabled="disabled" size=(show (sizeFn init)) />]) dv init

-- |An input text area with optional initial value, and an optional
-- result in case the element is disabled.  It also takes two functions
-- that compute the number of rows and columns from the initial text.
textareaF :: (Monad v, HSX.XMLGenerator x) => (String -> Rect) -> Bool -> Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
textareaF dimsFn enabled init =
    case enabled of
      True -> defaultResultInput (\n v -> [<textarea id=n name=n rows=r cols=c><% v %></textarea>]) dv init
      False -> defaultResultInput (\n v -> [<textarea id=n name=n rows=r cols=c disabled="disabled"><% v %></textarea>]) dv init
    where Rect {rectRows = r, rectCols = c} = dimsFn (fromMaybe "" init)

-- |An input text area with optional initial value, and an optional
-- result in case the element is disabled.

-- |A version of textarea that computes an appropriate number of rows
-- from the initial text and the number of columns.

textarea' :: (Monad v, HSX.XMLGenerator x) => (Maybe String -> Int) -> Bool -> Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
textarea' colsFn enabled init =
    textarea (\ s -> Rect {rectRows = textRows cols (Just s), rectCols = cols}) init
    where cols = colsFn init
          textarea dimsFn init = textareaF dimsFn True init

textRows :: Int -> Maybe String -> Int
textRows cols init = foldr (+) 0 (map (\ line -> 1 + (length line) `Prelude.div` cols) (lines (maybe "" id init)))

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

-- |A hidden field
hiddenF :: (Monad v, HSX.XMLGenerator x) => String -> Form [XMLGenT x (HSX.XML x)] v String
hiddenF s = defaultResultInput (\n v -> [<input type="hidden" id=n name=n value=v />]) dv (Just s)

-- |Hide a value of any instance of Show and Read.
hidden' :: (Read a, Show a, Monad v, HSX.XMLGenerator x) => a -> Form [XMLGenT x (HSX.XML x)] v a
hidden' x = hidden (Just (show x)) `check` (`maybeRead'` ("Read failure in hidden: " ++ show x))
    where
      hidden = hiddenF . fromMaybe ""

-- |A Submit button
submitF :: (Monad v, HSX.XMLGenerator x) => Bool -> String -> (Form [XMLGenT x (HSX.XML x)] v Bool)
submitF True value = defaultResultInput (\n v -> [<input type="submit" name=n value=v />]) dv (Just value) `check` (Success . (== value))
submitF False value = defaultResultInput (\n v -> [<input type="submit" name=n value=v disabled="disabled" />]) dv (Just value) `check` (Success . (== value))

-- |A validated integer component
inputInteger :: (Monad v, HSX.XMLGenerator x) => Bool -> Maybe Integer -> Form [XMLGenT x (HSX.XML x)] v Integer
inputInteger e x =
    inputF True (fmap show x) `check` asInteger'
    where
      -- This function is like Control.Applicative.Error.asInteger,
      -- except that when a default value is provided it is used it
      -- when the input string is empty.
      asInteger' :: String -> Failing Integer
      asInteger' "" = maybe (Failure [show "" ++ " is not a valid integer"]) Success x
      asInteger' s = maybeRead' s (show s ++ " is not a valid integer")

-- | A radio choice
radioF :: (Monad v, HSX.XMLGenerator x) => Bool -> [(String, String)] -> Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
radioF e choices = defaultResultInput mkRadios "0" -- todo: validate that the result was in the choices
    where mkRadios name selected = map (mkRadio name selected) (zip choices [1..])
          mkRadio  name selected ((value, label), idx) = 
              <span>
                <% radio e name value ident (selected == value) %> -- ! attrs 
                <label for=ident class=name><% label %></label>
              </span>
              where
                ident = name ++ "_" ++ show idx
          radio True n v i True  = <input type="radio" name=n id=i class=n value=v checked="checked" />
          radio True n v i False = <input type="radio" name=n id=i class=n value=v />
          radio False n v i True  = <input type="radio" name=n id=i class=n value=v checked="checked" disabled="disabled" />
          radio False n v i False = <input type="radio" name=n id=i class=n value=v disabled="disabled" />

-- |Version of radio whose type signature matches HSP.Formlets.select.
radio' :: (Eq a, Monad v, HSX.XMLGenerator x) => Bool -> [(a, String)] -> Maybe a -> Form [XMLGenT x (HSX.XML x)] v (Maybe a)
radio' e ls v =
    radioF True (map f $ zip [0..] ls) selected `check` asInt `check` convert
    where selected       = show <$> (v >>= flip elemIndex (map fst ls))
          f (idx, (_,l)) = (show idx, l)
          convert Nothing = Success Nothing
          convert (Just i) | i >= length ls || i < 0 = Failure ["Out of bounds"]
                           | otherwise               = Success $ Just $ fst $ ls !! i
          -- Assume that any invalid result means control is disabled
          asInt   s      = Success (maybeRead s)
          --asInt   s      = maybeRead' s (s ++ " is not a valid int")


-- | An radio choice for Enums
enumRadio :: (Enum a, Monad v, HSX.XMLGenerator x) => Bool -> [(a, String)] -> Maybe a -> Form [XMLGenT x (HSX.XML x)] v a
enumRadio e values defaultValue = radioF True (map toS values) (fmap (show . fromEnum) defaultValue) 
                                  `check` convert `check` tryToEnum
 where toS = fmapFst (show . fromEnum)
       convert v = maybeRead' v "Conversion error" 


selectRawF :: (Monad v, HSX.XMLGenerator x) => Bool -> [(String, String)] -> Maybe String -> Form [XMLGenT x (HSX.XML x)] v String
selectRawF e choices = defaultResultInput (mkChoices e) dv -- todo: validate that the result was in the choices
 where mkChoices True name selected =
           [ <select name=name>
                   <% mapM (mkChoice selected) choices %>
             </select>
           ]
       mkChoices False name selected =
           [ <select name=name disabled="disabled">
                   <% mapM (mkChoice selected) choices %>
             </select>
           ]
       mkChoice  selected (value, label)
           | selected == value = <option value=value selected="selected"><% label %></option> --  X.option ! (attrs ++ [X.value value]) << label
           | otherwise = <option value=value><% label %></option>

-- | A drop-down for anything that is an instance of Eq.  When the
-- form is disabled the result string will be empty, in which case
-- the result value is Nothing.
select :: (Eq a, Monad v, HSX.XMLGenerator x) => Bool -> [(a, String)] -> Maybe a -> Form [XMLGenT x (HSX.XML x)] v (Maybe a)
select e ls v = selectRawF True (map f $ zip [0..] ls) selected `check` asInt `check` convert
 where selected       = show <$> (v >>= flip elemIndex (map fst ls))
       f (idx, (_,l)) = (show idx, l)
       convert (Nothing) = Success Nothing
       convert (Just i) | i >= length ls || i < 0 = Failure ["Out of bounds"]
                        | otherwise               = Success . Just $ fst $ ls !! i
       asInt   ""     = Success Nothing
       asInt   s      = maybe (Failure [show s ++ " is not a valid int"])
                              (Success . Just) (maybeRead s :: Maybe Int)

-- | An input which returns True or False.  The checkbox id only
-- appears in the returned data if it is checked, so we need to
-- provide a default result here as the second argument to
-- defaultResultInput which we can turn to a False value.
checkboxF :: (Monad v, HSX.XMLGenerator x) => Bool -> Bool -> Form [XMLGenT x (HSX.XML x)] v Bool
checkboxF enabled checked =
    defaultResultInput xml "" (Just "t") `check` (\ s' -> Success $ s' == "t")
    where
      xml n v =
          case (enabled, checked) of
            (True, True) -> [<input type="checkbox" id=n name=n value=v class=n checked="checked" />]
            (True, False) -> [<input type="checkbox" id=n name=n value=v class=n />]
            (False, True) -> [<input type="checkbox" id=n name=n value=v class=n checked="checked" disabled="disabled" />]
            (False, False) -> [<input type="checkbox" id=n name=n value=v class=n disabled="disabled" />]

-- |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