-----------------------------------------------------------------------------
--
-- Module      :  Control.MessageFlow.Forms.XHtml
-- Copyright   :
-- License     :  BSD3
--
-- Maintainer  :  agocorona@gmail.com
-- Stability   :  experimental
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------
{- Instantiation of "MFlow.Forms" for the xhtml package "Text.XHtml" module
it includes additional XHtml style operators for embedding widgets within XHtml formatting

-}

{-# OPTIONS -XMultiParamTypeClasses
            -XFlexibleInstances
            -XUndecidableInstances
            -XTypeSynonymInstances
            -XFlexibleContexts
            #-}


module MFlow.Forms.XHtml((<++), (<+>), (++>), (<<<))
 where


import MFlow.Forms
import Text.XHtml as X
import Control.Monad.Trans
import Data.Typeable


-- | encloses a widget in Html formatting
--
-- @table <<< (
--      tr <<< (td << widget widget1)
--      tr <<< (td << widget widget2))@

(<<<) :: Monad m => (Html -> Html) -> View Html m a -> View Html m a
tag <<< d= wrap tag d
infixr 7 <<<

infixr 3 <++
-- | prepend Html formatting to a widget
--
-- @bold << "hi there"
--  <++
--  widget widget1@

(<++) :: Monad m => Html -> View Html m a -> View Html m a
html <++ digest =  (html +++) <<< digest

infix 3 ++>
-- | append Html to a widget
--
-- @widget widget1
-- ++>
-- H1 << "hi there"@
(++>) :: Monad m => View Html m a -> Html -> View Html m a
digest ++> html = addToForm digest html


-- | join two widgets in the same pages
-- the resulting widget, when `ask`ed with it, returns a either one or the other
--
--  @r <- ask widget widget1 <+> widget widget2@
--
infixr 2 <+>
(<+>) ::  Monad m
          => View Html m a'
          -> View Html m b'
          -> View Html m (Either a' b')
(<+>) = mix




instance Typeable X.Html where
     typeOf =  \_ -> mkTyConApp (mkTyCon "Text.XHtml.Strict.Html") []

instance    FormInput  Html  where
--    column vs= concatHtml [tr  v  | v <- vs]
--    row vs= concatHtml [td v  | v <- vs]
--    hsep = spaceHtml
--    vsep = br
    inred = X.bold ![X.thestyle "color:red"]
    finput n t v f c= X.input ! ([thetype t ,name n, value v]++ if f then [checked]  else []
                              ++ case c of Just s ->[strAttr "onclick" s]; _ -> [] )
    ftextarea name text= X.textarea ! [X.name name] << text

    foption name list msel=  select ![ X.name name] << (concatHtml
            $ map (\(n,v) -> X.option ! ([value n] ++ selected msel n) << v ) list)

            where
            selected msel n= if Just n == msel then [X.selected] else []




    fformAction action form = X.form ! [X.action action, method "post"] << form
    fromString = stringToHtml
--    bold =  X.bold
--    fs = h3
--    ts = h4
--    style st content = thespan ![thestyle st] << content

    ftable title head rows=
          X.table << (
            (if not . isNoHtml  $ title then caption << title   else noHtml ) +++
            (if not . null $ head then tr << (concatHtml [th h | h <- head]) else noHtml) +++
            (concatHtml[tr << concatHtml[td v| v <- row] | row <- rows]))

    flink  v str = p << hotlink  v << str