-----------------------------------------------------------------------------
--
-- Module      :  View
-- Copyright   :
-- License     :  BSD3
--
-- Maintainer  :  agocorona@gmail.com
-- Stability   :  experimental
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

{-# LANGUAGE  FlexibleContexts, FlexibleInstances
    , TypeFamilies, DeriveDataTypeable, UndecidableInstances, ExistentialQuantification
    , GADTs
    #-}
module Haste.HPlay.View(
Widget,

-- * widget combinators and modifiers

wcallback, (<+>), (**>), (<**), validate
,firstOf, manyOf, allOf
,(<<<),(<<),(<++),(++>),(<!)

-- * basic widgets

,getString,inputString, getInteger,inputInteger,
getInt, inputInt,getPassword,inputPassword,
setRadio,setRadioActive,getRadio
,setCheckBox, getCheckBoxes
,getTextBox, getMultilineText,textArea,getBool
,getSelect,setOption,setSelectedOption, wlabel,
resetButton,inputReset, submitButton,
inputSubmit, wlink, noWidget, stop,wraw, isEmpty

-- * out of flow updates
,at, UpdateMethod(..)

-- * Session data storage
,getSessionData,getSData,setSessionData,setSData
,delSessionData,delSData

-- * reactive and events
,resetEventData,getEventData,EventData(..),EvData(..)
,raiseEvent, fire, wake, react, pass
,continueIf, wtimeout, Event(..)

-- * running it
,runWidget, runWidgetId, runBody, addHeader

-- * Perch is reexported
,module Haste.Perch

-- * low level and internals
,getNextId,genNewId
,getParam
,FormInput(..)
,View(..),FormElm(..)

)  where
import Control.Applicative
import Data.Monoid
import Control.Monad.State
import Control.Monad.IO.Class
import Data.Typeable
import Unsafe.Coerce
import Data.Maybe
import Haste
import Haste.Prim
import Haste.Foreign(ffi)
import Unsafe.Coerce
import System.IO.Unsafe
import Control.Concurrent.MVar
import qualified Data.Map as M
import Control.Monad.Trans.Maybe
import Prelude hiding(id)
import Haste.Perch
-- | @View v m a@ is a widget (formlet)  with formatting `v`  running the monad `m` (usually `IO`) and which return a value of type `a`
--
-- It has 'Applicative', 'Alternative' and 'Monad' instances.
--
-- Things to know about these instances:
--
--   If the View expression does not validate, ask will present the page again.
--
-- /Alternative instance/: Both alternatives are executed. The rest is as usual
--
-- /Monad Instance/:
--
--  The rendering of each statement is added to the previous. If you want to avoid this, use 'wcallback'
--
--  The execution is stopped when the statement has a formlet-widget that does not validate and
-- return an invalid response (So it will present the page again if no other widget in the expression validates).
--
--  The monadic code is executed from the beginning each time the page is presented or refreshed
--
--  use 'pageFlow' if your page has more than one monadic computation with dynamic behaviour
--
-- use 'pageFlow' to identify each subflow branch of a conditional
--
--  For example:
--
--  > pageFlow "myid" $ do
--  >      r <- formlet1
--  >      liftIO $ ioaction1 r
--  >      s <- formlet2
--  >      liftIO $ ioaction2 s
--  >      case s of
--  >       True  -> pageFlow "idtrue" $ do ....
--  >       False -> paeFlow "idfalse" $ do ...
--  >      ...
--
--  Here if  @formlet2@ do not validate, @ioaction2@ is not executed. But if @formLet1@ validates and the
--  page is refreshed two times (because @formlet2@ has failed, see above),then @ioaction1@ is executed two times.
--  use 'cachedByKey' if you want to avoid repeated IO executions.
data NeedForm= HasForm | HasElems  | NoElems deriving Show
type SData= ()

--instance MonadState (  Widget) where
--  type StateType (  Widget)=  MFlowState
--
--instance MonadState IO where
--  type StateType IO=  MFlowState

data EventF= forall b c.EventF (IO (Maybe b)) (b -> IO (Maybe c)) --

data MFlowState= MFlowState { mfPrefix :: String,mfSequence :: Int
                            , needForm :: NeedForm, process :: EventF
                            , fixed :: Bool
                            , mfData :: M.Map TypeRep SData}

type Widget a=  View Perch IO a

type WState view m = StateT MFlowState m
data FormElm view a = FormElm view (Maybe a)
newtype View v m a = View { runView :: WState v m (FormElm v a)}

mFlowState0= MFlowState "" 0 NoElems  (EventF (return Nothing)
                        (const $ return Nothing) ) False M.empty


instance Functor (FormElm view ) where
  fmap f (FormElm form x)= FormElm form (fmap f x)

instance (Monoid view) => Monoid (FormElm view a) where
  mempty= FormElm mempty Nothing
  mappend (FormElm f1 x1) (FormElm f2 x2)= FormElm (f1 <> f2) (x1 <|> x2)

instance  (Monad m,Functor m) => Functor (View view m) where
  fmap f x= View $   fmap (fmap f) $ runView x

  
instance (Monoid view,Functor m, Monad m) => Applicative (View view m) where
  pure a  = View  .  return . FormElm mempty $ Just a
  View f <*> View g= View $
                   f >>= \(FormElm form1 k) ->
                   g >>= \(FormElm form2 x) ->
                   return $ FormElm (form1 `mappend` form2) (k <*> x) 

instance (Monoid view, Functor m, Monad m) => Alternative (View view m) where
  empty= View $ return $ FormElm mempty Nothing
  View f <|> View g= View $ do
                   FormElm form1 x <- f
                   FormElm form2 y <- g
                   return $ FormElm (form1 <> form2) (x <|> y) 


strip st x= View $ do
    st' <- get
    put st'{mfSequence= mfSequence st}
    FormElm _ mx <- runView x
    put st'
    return $ FormElm mempty mx

setEventCont :: Widget a -> (a -> Widget b)  -> String -> StateT MFlowState IO EventF
setEventCont x f  id= do
   st <- get
   let conf = process st
   case conf of
     EventF x' f'  -> do
       let addto f f'= \x -> do
             mr <- runWidgetId (f x) id
             case mr of
               Nothing -> return Nothing
               Just x' ->  f' x'
           idx= runWidgetId ( strip st  x) id
       put st{process= EventF idx (f `addto` unsafeCoerce f') }
   return conf

resetEventCont cont= modify $ \s -> s {process= cont}

instance Monad (View Perch IO) where
    x >>= f = View $ do
           id <- genNewId
           contold <- setEventCont x f  id
           FormElm form1 mk <- runView x
           resetEventCont contold
           let span= nelem "span" `attrs` [("id", id)]
           case mk of
             Just k  -> do
                FormElm form2 mk <- runView $ f k
                return $ FormElm (form1 <> (span `child`  form2)) mk
             Nothing -> 
                return $ FormElm  (form1 <> span)  Nothing
                        

    return = View .  return . FormElm  mempty . Just
--    fail msg= View . return $ FormElm [inRed msg] Nothing


--static w= View $ do
--   modify $ \st -> st{fixed=True}
--   runView w

instance (FormInput v,Monad (View v m), Monad m, Functor m, Monoid a) => Monoid (View v m a) where
  mappend x y = mappend <$> x <*> y  -- beware that both operands must validate to generate a sum
  mempty= return mempty


-- | It is a callback in the view monad. The callback rendering substitutes the widget rendering
-- when the latter is validated, without afecting the rendering of other widgets. This allow
-- the simultaneous execution of different behaviours in different widgets in the
-- same page.
wcallback
  ::  Widget a -> (a ->Widget b) -> Widget b
wcallback  x f = View $ do
   idhide <- genNewId
   id <- genNewId
   runView $ identified idhide x >>= delBefore idhide f                        
   where
   delBefore id f = \x -> View $ do
     FormElm render mx <- runView $ f x
     return $ FormElm (del id <> render ) mx
     where
     del id= Perch $ \e' -> do
           withElem id $ \e -> do
             par <- parent e
             removeChild e par
           return e'

identified id w= View $ do
     let span= nelem "span" `attr` ("id", id)
     FormElm f mx <- runView w
     return $ FormElm (span `child` f) mx


--wcallback
--  ::  Widget a -> (a -> Widget b) -> Widget b                      
--wcallback  x' f = View $ do
--   id <- genNewId
--   let x = identified id x'
--
--   contold <- setEventCont x f  id
--   FormElm form1 mk <- runView x
--   resetEventCont contold
--   case mk of
--     Just k  -> do
--        FormElm form2 mk <- runView $ f k
--        return $ FormElm  form2 mk
--     Nothing -> 
--        return $ FormElm  form1  Nothing



instance  (FormInput view,Monad m,Monad (View view m)) => MonadState (View view m) where
  type StateType (View view m)= MFlowState
  get = View $  get >>=  return . FormElm mempty . Just 
  put st = View $  put st >>=  return . FormElm mempty . Just 


instance (FormInput view,Monad (View view m),MonadIO m) => MonadIO (View view m) where
    liftIO io=   let x= liftIO io in x `seq` lift x 


----- some combinators ----

-- | Join two widgets in the same page
-- the resulting widget, when `ask`ed with it, return a 2 tuple of their validation results
-- if both return Noting, the widget return @Nothing@ (invalid).
--
-- it has a low infix priority: @infixr 2@
--
--  > r <- ask  widget1 <+>  widget2
--  > case r of (Just x, Nothing) -> ..
(<+>) , mix ::  (Monad m, FormInput view)
      => View view m a
      -> View view m b
      -> View view m (Maybe a, Maybe b)
mix digest1 digest2= View $ do
  FormElm f1 mx' <- runView  digest1
  s1 <- get
  FormElm f2 my' <- runView  digest2
  s2 <- get
  return $ FormElm (f1 <> f2)
         $ case (mx',my') of
              (Nothing, Nothing) -> Nothing
              other              -> Just other

infixr 2 <+>

(<+>)  = mix



-- | The first elem result (even if it is not validated) is discarded, and the secod is returned
-- . This contrast with the applicative operator '*>' which fails the whole validation if
-- the validation of the first elem fails.
--
-- The first element is displayed however, as happens in the case of '*>' .
--
-- Here @w\'s@ are widgets and @r\'s@ are returned values
--
--   @(w1 <* w2)@  will return @Just r1@ only if w1 and w2 are validated
--
--   @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated
--
--  it has a low infix priority: @infixr 1@

(**>) :: (Functor m, Monad m, FormInput view)
      => View view m a -> View view m b -> View view m b

(**>) f g = View $ do
   FormElm form1 k <- runView $ valid f
   FormElm form2 x <- runView g
   return $ FormElm (form1 <> form2) (k *> x)



valid form= View $ do
   FormElm form mx <- runView form
   return $ FormElm form $ Just undefined

infixr 1  **>  ,  <** 

-- | The second elem result (even if it is not validated) is discarded, and the first is returned
-- . This contrast with the applicative operator '*>' which fails the whole validation if
-- the validation of the second elem fails.
-- The second element is displayed however, as in the case of '<*'.
-- see the `<**` examples
--
--  it has a low infix priority: @infixr 1@
(<**) :: (Functor m, Monad m, FormInput view) =>
     View view m a -> View view m b -> View view m a
-- (<**) form1 form2 =  form1 <* valid form2
(<**) f g = View $ do
   FormElm form1 k <- runView f
   s1 <- get
   FormElm form2 x <- runView $ valid g
   s2 <- get


   return $ FormElm (form1 <> form2) (k <* x)





instance Monoid view => MonadTrans (View view) where
  lift f = View $  (lift  f) >>= \x ->  return $ FormElm mempty $ Just x


type Name= String
type Type= String
type Value= String
type Checked= Bool
type OnClick= Maybe String


-- | Minimal interface for defining the basic form and link elements. The core of MFlow is agnostic
-- about the rendering package used. Every formatting (either HTML or not) used with MFlow must have an
-- instance of this class.
-- See "MFlow.Forms.Blaze.Html for the instance for blaze-html" "MFlow.Forms.XHtml" for the instance
-- for @Text.XHtml@ and MFlow.Forms.HSP for the instance for Haskell Server Pages.
class (Monoid view,Typeable view)   => FormInput view where
    fromStr :: String -> view
    fromStrNoEncode :: String -> view
    ftag :: String -> view  -> view
    inred   :: view -> view
    flink ::  String -> view -> view 
    flink1:: String -> view
    flink1 verb = flink verb (fromStr  verb) 
    finput :: Name -> Type -> Value -> Checked -> OnClick -> view 
    ftextarea :: String -> String -> view
    fselect :: String -> view -> view
    foption :: String -> view -> Bool -> view
    foption1 :: String -> Bool -> view
    foption1   val msel= foption val (fromStr val) msel
    formAction  :: String -> String -> view -> view
    attrs :: view -> Attribs -> view

type Attribs= [(String, String)]


data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show)

valToMaybe (Validated x)= Just x
valToMaybe _= Nothing

isValidated (Validated x)= True
isValidated _= False

fromValidated (Validated x)= x
fromValidated NoParam= error $ "fromValidated : NoParam"
fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s

getParam1 :: (MonadIO m, MonadState  m, Typeable a, Read a, FormInput v)
          => String ->  m (ParamResult v a)
getParam1 par = do
   me <- elemById par
   case me of
     Nothing -> return  NoParam
     Just e ->  do
       mv <- getValue e
       case mv of
         Nothing -> return NoParam
         Just v -> do
           readParam v  


type Params= Attribs


  
readParam :: (Monad m, MonadState  m, Typeable a, Read a, FormInput v)
           => String -> m (ParamResult v a)
readParam x1 = r
 where
 r= maybeRead x1
      
 getType ::  m (ParamResult v a) -> a
 getType= undefined
 x= getType r
 maybeRead str= do
   let typeofx = typeOf x
   if typeofx == typeOf  ( undefined :: String)   then
           return . Validated $ unsafeCoerce str
    else case readsPrec 0 $ str of
              [(x,"")] ->  return $ Validated x
              _ -> do
                   let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++  show (typeOf x)
                   return $ NotValidated str err

-- | Validates a form or widget result against a validating procedure
--
-- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then  Nothing else Just "only odd numbers, please")@
validate
  :: (FormInput view,  Monad m,Monad (View view m)) =>
     View view m a
     -> (a -> WState view m (Maybe view))
     -> View view m a
validate  formt val= do
   mx <- View $ do
         FormElm form mx <- runView  formt
         return $ FormElm form (Just mx)
   View $ do
     case mx of
        Just x -> do
          me <- val x
          case me of
             Just str -> return $ FormElm (inred  str) Nothing
             Nothing  -> return $ FormElm mempty mx
        _ -> return $ FormElm mempty Nothing

-- | Generate a new string. Useful for creating tag identifiers and other attributes.
--
-- if the page is refreshed, the identifiers generated are the same.
genNewId :: (StateType m ~ MFlowState, MonadState  m) =>  m String
genNewId=  do
      st <- get
      let n= mfSequence st
          prefseq=  mfPrefix st
      put $ st{mfSequence= n+1}

      return $ 'p':show n++prefseq  


-- | get the next ideitifier that will be created by genNewId
getNextId :: (StateType m ~ MFlowState,MonadState  m) =>  m String
getNextId=  do
      st <- get
      let n= mfSequence st
          prefseq=  mfPrefix st
      return $ 'p':show n++prefseq


-- | Display a text box and return a non empty String
getString  :: (StateType (View view m) ~ MFlowState,FormInput view,Monad(View view m),MonadIO m) =>
     Maybe String -> View view m String
getString ms = getTextBox ms
--     `validate`
--     \s -> if Prelude.null s then return (Just $ fromStr "")
--                    else return Nothing

inputString  :: (StateType (View view m) ~ MFlowState,FormInput view,Monad(View view m),MonadIO m) =>
     Maybe String -> View view m String
inputString= getString

-- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation)
getInteger :: (StateType (View view m) ~ MFlowState,FormInput view,  MonadIO m) =>
     Maybe Integer -> View view m  Integer
getInteger =  getTextBox

inputInteger :: (StateType (View view m) ~ MFlowState,FormInput view,  MonadIO m) =>
     Maybe Integer -> View view m  Integer
inputInteger= getInteger

-- | Display a text box and return a Int (if the value entered is not an Int, fails the validation)
getInt :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) =>
     Maybe Int -> View view m Int
getInt =  getTextBox

inputInt :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) =>
     Maybe Int -> View view m Int
inputInt =  getInt

-- | Display a password box
getPassword :: (FormInput view,StateType (View view m) ~ MFlowState,
     MonadIO m) =>
     View view m String
getPassword = getParam Nothing "password" Nothing

inputPassword :: (StateType (View view m) ~ MFlowState,FormInput view,
     MonadIO m) =>
     View view m String
inputPassword= getPassword

newtype Radio a= Radio a



-- | Implement a radio button
-- the parameter is the name of the radio group
setRadio :: (FormInput view,  MonadIO m,
             Typeable a, Eq a, Show a) =>
            a -> String -> View view m  (Radio a)
setRadio v n= View $ do
  id <- genNewId
  st <- get
  put st{needForm= HasElems}
  me <- liftIO $ elemById id
  checked <- case me of
       Nothing -> return ""
       Just e  -> liftIO $   getProp e "checked"
  let strs= if  checked=="true" then Just v else Nothing
--  let mn= if null strs then False else True
      ret= fmap  Radio  strs 
      str = if typeOf v == typeOf(undefined :: String)
                   then unsafeCoerce v else show v
  return $ FormElm
      ( finput id "radio" str ( isJust strs ) Nothing `attrs` [("name",n)])
      ret
 

setRadioActive rs x= setRadio rs x `raiseEvent` OnClick

-- | encloses a set of Radio boxes. Return the option selected
getRadio
  :: (Monad (View view m), Monad m, Functor m, FormInput view) =>
     [String -> View view m (Radio a)] -> View view m a
getRadio ws = View $ do
   id <- genNewId
   fs <- mapM (\w -> runView (w id)) ws
   let FormElm render mx = mconcat fs
   return $ FormElm render $ fmap (\(Radio r) -> r) mx


data CheckBoxes = CheckBoxes [String]

instance Monoid CheckBoxes where
  mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
  mempty= CheckBoxes []


-- | Display a text box and return the value entered if it is readable( Otherwise, fail the validation)
setCheckBox :: (FormInput view,  MonadIO m) =>
                Bool -> String -> View view m  CheckBoxes
setCheckBox checked' v= View $ do
  n  <- genNewId
  st <- get
  put st{needForm= HasElems}
  me <- liftIO $ elemById n
  checked <- case me of
       Nothing ->  return $ if checked' then "true" else ""
       Just e  -> liftIO $  getProp e "checked"
  let strs= if  checked=="true"  then [v] else []
--  let mn= if null strs then False else True
      ret= Just $ CheckBoxes  strs 

  return $ FormElm
      ( finput n "checkbox" v ( checked' ) Nothing)
      ret
 

getCheckBoxes :: (Monad m, FormInput view) =>  View view m  CheckBoxes ->  View view m  [String]
getCheckBoxes w= View $ do
   FormElm render mcb <- runView w
   return $ FormElm render $ case mcb of
     Just(CheckBoxes rs) -> Just rs
     _                   -> Nothing



whidden :: (MonadIO m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a
whidden x= res where
 res= View $ do
      n <- genNewId
      let showx= case cast x of
                  Just x' -> x'
                  Nothing -> show x
      r <- getParam1 n `asTypeOf` typef res
      return . FormElm (finput n "hidden" showx False Nothing) $ valToMaybe r
      where
      typef :: View v m a -> StateT MFlowState m (ParamResult v a)
      typef = undefined




getTextBox
  :: (FormInput view, StateType (View view m) ~ MFlowState,
      MonadIO  m,
      Typeable a,
      Show a,
      Read a) =>
     Maybe a ->  View view m a
getTextBox ms  = getParam Nothing "text" ms


getParam
  :: (FormInput view,StateType (View view m) ~ MFlowState,
      MonadIO m,
      Typeable a,
      Show a,
      Read a) =>
     Maybe String -> String -> Maybe a -> View view m  a
getParam  look type1 mvalue= View $ getParamS look type1 mvalue

getParamS look type1 mvalue= do
    tolook <- case look of
       Nothing  -> genNewId
       Just n -> return n
    let nvalue x = case x of
           Nothing  -> ""
           Just v   ->
               case cast v of
                 Just v' -> v'
                 Nothing -> show v
    st <- get

    put st{needForm= HasElems}
    r <- getParam1 tolook 
    case r of
       Validated x        -> return $ FormElm (finput tolook type1 (nvalue $ Just x) False Nothing) $ Just x
       NotValidated s err -> return $ FormElm (finput tolook type1 s False Nothing <> err) $ Nothing
       NoParam            -> return $ FormElm (finput tolook type1 (nvalue mvalue) False Nothing) $ Nothing




-- | Display a multiline text box and return its content
getMultilineText :: (FormInput view
                 ,  MonadIO m)
                   => String
                 ->  View view m String
getMultilineText nvalue = res where
 res= View $ do
    tolook <- genNewId
    r <- getParam1 tolook  `asTypeOf` typef res
    case r of
       Validated x        -> return $ FormElm (ftextarea tolook  x) $ Just x
       NotValidated s err -> return $ FormElm (ftextarea tolook   s)  Nothing
       NoParam            -> return $ FormElm (ftextarea tolook  nvalue)  Nothing
    where
    typef :: View v m String -> StateT MFlowState m (ParamResult v a)
    typef = undefined

-- | A synonim of getMultilineText
textArea :: (FormInput view
                 ,  MonadIO m)
                   => String
                 ->  View view m String
textArea= getMultilineText


--getBool :: (FormInput view,
--      Monad m, Monad (View view m), Functor m) =>
--      Bool -> String -> String -> View view m Bool
getBool mv truestr falsestr= do
   r <- getSelect $   setOption truestr (fromStr truestr)  <! (if mv then [("selected","true")] else [])
                  <|> setOption falsestr(fromStr falsestr) <! if not mv then [("selected","true")] else []
   if  r == truestr  then return True else return False



-- | Display a dropdown box with the options in the first parameter is optionally selected
-- . It returns the selected option.
getSelect :: (FormInput view,
      MonadIO m,Typeable a, Read a) =>
      View view m (MFOption a) ->  View view m  a
getSelect opts = res where
  res= View $ do
    tolook <- genNewId
    st <- get
    put st{needForm= HasElems}
    r <- getParam1 tolook `asTypeOf` typef res
--    setSessionData $ fmap MFOption $ valToMaybe r
    FormElm form mr <- (runView opts)
--
    return $ FormElm (fselect tolook  form)  $ valToMaybe r

    where
    typef :: View v m a -> StateT MFlowState m (ParamResult v a)
    typef = undefined

newtype MFOption a= MFOption a deriving Typeable

instance (FormInput view,Monad m, Functor m) => Monoid (View view m (MFOption a)) where
  mappend =  (<|>)
  mempty = Control.Applicative.empty

-- | Set the option for getSelect. Options are concatenated with `<|>`
setOption
  :: (Monad m, Monad (View view m), Show a, Eq a, Typeable a, FormInput view) =>
     a -> view -> View view m (MFOption a)
setOption n v = View $ do
--  mo <- getSessionData
  runView $ setOption1 n v False


-- | Set the selected option for getSelect. Options are concatenated with `<|>`
setSelectedOption
  :: (Monad m, Monad(View view m), Show a, Eq a, Typeable a, FormInput view) =>
     a -> view -> View view m (MFOption a)
setSelectedOption n v= View $ do
--  mo <- getSessionData
  runView $ setOption1 n v True
--   Just Nothing -> setOption1 n v True
--   Just (Just o) -> setOption1 n v $   n == o


setOption1 :: (FormInput view,
      Monad m, Typeable a, Eq a, Show a) =>
      a -> view -> Bool ->  View view m  (MFOption a)
setOption1 nam  val check= View $ do
    let n = if typeOf nam == typeOf(undefined :: String)
                   then unsafeCoerce nam
                   else show nam

    return . FormElm (foption n val check)  . Just $ MFOption nam


wlabel
  :: (Monad m, FormInput view) => view -> View view m a -> View view m a
wlabel str w =View $ do
   id <- getNextId
   FormElm render mx <- runView w
   return $ FormElm (ftag "label" str `attrs` [("for",id)] <> render) mx


resetButton :: (FormInput view, Monad m) => String -> View view m ()
resetButton label= View $ return $ FormElm (finput  "reset" "reset" label False Nothing)
                        $ Just ()

inputReset :: (FormInput view, Monad m) => String -> View view m ()
inputReset= resetButton

submitButton :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) => String -> View view m String
submitButton label= getParam Nothing "submit" $ Just label

inputSubmit :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) => String -> View view m String
inputSubmit= submitButton


linkPressed= unsafePerformIO $ newMVar Nothing

wlink :: (Show a, Typeable a) => a -> Perch -> Widget a
wlink x v= do
    (a ! href ("#/"++show1 x)   $ v) `pass` OnClick
    return x

   where
   show1 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x
           | otherwise= show x


--wlink x v= View $ do
--    ide <- genNewId
--    FormElm render _ <- runView $ (wraw $ addEvent(a ! href ("#/"++show1 x)  $ v)
--                                          OnClick (setId ide))
----                           `raiseEvent` OnClick
--
--    mi <- liftIO $ readMVar linkPressed
--    if mi==  Just ide
--     then return $ FormElm render $ Just x
--     else return $ FormElm render Nothing
--   where
--   addEvent be event action= Perch $ \e -> do
--     e' <- build be e
--     onEvent e' event  action 
--     return e'
--
--   setId ide _ _= do
--     modifyMVar_ linkPressed . const .  return $ Just ide
--
--   show1 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x
--           | otherwise= show x

           
-- | Concat a list of widgets of the same type, return a the first validated result
firstOf :: (FormInput view, Monad m, Functor m)=> [View view m a]  -> View view m a
firstOf xs= Prelude.foldl (<|>) noWidget xs

-- | from a list of widgets, it return the validated ones.
manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a]  -> View view m [a]
manyOf xs=  (View $ do
      forms <- mapM runView  xs
      let vs  = mconcat $ Prelude.map (\(FormElm v _) ->   v) forms
          res1= catMaybes $ Prelude.map (\(FormElm _ r) -> r) forms
      return . FormElm vs $ Just res1)

-- | like manyOf, but does not validate if one or more of the widgets does not validate
allOf xs= manyOf xs `validate` \rs ->
      if length rs== length xs
         then return Nothing
         else return $ Just mempty

-- | Enclose Widgets within some formating.
-- @view@ is intended to be instantiated to a particular format
--
-- NOTE: It has a infix priority : @infixr 5@ less than the one of @++>@ and @<++@ of the operators, so use parentheses when appropriate,
-- unless the we want to enclose all the widgets in the right side.
-- Most of the type errors in the DSL are due to the low priority of this operator.
--

(<<<) :: (Monad m,  Monoid view)
          => (view ->view)
         -> View view m a
         -> View view m a
(<<<) v form= View $ do
  FormElm f mx <- runView form 
  return $ FormElm (v  f) mx


infixr 5 <<<

-- | A parameter application with lower priority than ($) and direct function application
(<<) :: (t1 -> t) -> t1 -> t
(<<) tag content= tag  content

infixr 7 <<


-- | Append formatting code to a widget
--
-- @ getString "hi" <++ H1 << "hi there"@
--
-- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators
(<++) :: (Monad m, Monoid v)
      => View v m a
      -> v
      -> View v m a
(<++) form v= View $ do
  FormElm f mx <-  runView  form
  return $  FormElm ( f <> v) mx

infixr 6  ++> 
infixr 6 <++ 
-- | Prepend formatting code to a widget
--
-- @bold << "enter name" ++> getString Nothing @
--
-- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators
(++>) :: (Monad m,  Monoid view)
       => view -> View view m a -> View view m a
html ++> w =  --  (html <>) <<< digest
 View $ do
  FormElm f mx <- runView w 
  return $ FormElm (html  <>  f) mx



-- | Add attributes to the topmost tag of a widget
--
-- it has a fixity @infix 8@
infixl 8 <!
widget <! attribs= View $ do
      FormElm fs  mx <- runView widget
      return $ FormElm  (fs `attrs` attribs) mx -- (head fs `attrs` attribs:tail fs) mx
--      case fs of
--        [hfs] -> return $ FormElm  [hfs `attrs` attribs] mx
--        _ -> error $ "operator <! : malformed widget: "++ concatMap (unpack. toByteString) fs



instance  Attributable (Widget a) where
 (!) widget atrib =View $ do
      FormElm fs  mx <- runView widget
      return $ FormElm  (fs `attr` atrib) mx
 


-- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets.
--
-- It returns a non valid value.
noWidget ::  (FormInput view,
     Monad m, Functor m) =>
     View view m a
noWidget= Control.Applicative.empty

-- | a sinonym of noWidget that can be used in a monadic expression in the View monad does not continue
stop :: (FormInput view,
     Monad m, Functor m) =>
     View view m a
stop= Control.Applicative.empty

-- | Render a Show-able  value and return it
--wrender
--  :: (Monad m, Functor m, Show a,Monad (View view m), FormInput view) =>
--     a -> View view m a
--wrender x = (fromStr $ show x) ++> return x

-- | Render raw view formatting. It is useful for displaying information.
wraw :: Monad m => view -> View view m ()
wraw x= View . return . FormElm x $ Just ()

-- | True if the widget has no valid input
isEmpty :: Widget a -> Widget Bool
isEmpty w= View $ do
  FormElm r mv <- runView w
  return $ FormElm r $ Just $ isNothing mv


-------------------------
instance   FormInput Perch  where
    fromStr = toElem
    fromStrNoEncode  = toElem
    ftag n v =  nelem n `child` v

    attrs tag  [] = tag
    attrs tag (nv:attribs) = attrs (attr tag nv) attribs

    inred msg=  ftag "b" msg `attrs` [("style","color:red")]

    finput n t v f c=
       let
        tag= ftag "input" mempty `attrs` [("type",  t), ("id",  n), ("value",  v)]
        tag1= if f then tag `attrs` [("checked", "")] else tag
       in case c of Just s -> tag1 `attrs` [("onclick", s)] ; _ -> tag1

    ftextarea nam text=
        ftag "textarea" mempty `attrs` [("id",  nam)] `child` text


    fselect nam list = ftag "select" mempty `attrs` [("id", nam)] `child` list
    foption  name v msel=
      let tag=  ftag "option" mempty `attrs` [("value", name)]  `child`  v
      in if msel then tag `attrs` [("selected", "")] else tag


    formAction action method1 form = ftag "form" mempty `attrs` [("acceptCharset", "UTF-8")
                                                         ,( "action", action)
                                                         ,("method",  method1)]
                                                         `child` form


    flink  v str = ftag "a" mempty `attrs` [("href",  v)] `child` str

-- | Get the session data of the desired type if there is any.
getSessionData ::  (StateType m ~ MFlowState,MonadState m,Typeable a) =>  m (Maybe a)
getSessionData =  resp where
 resp= gets mfData >>= \list  ->
    case M.lookup ( typeOf $ typeResp resp ) list of
      Just x  -> return . Just $ unsafeCoerce x
      Nothing -> return $ Nothing
 typeResp :: m (Maybe x) -> x
 typeResp= undefined

-- | getSessionData specialized for the View monad. if Nothing, the monadic computation
-- does not continue. getSData is a widget that does not validate when there is no data
--  of that type in the session.
getSData :: Typeable a =>Widget  a
getSData= View $ do
    r <- getSessionData
    return $ FormElm mempty r

--setSessionData ::  (StateType m ~ MFlowState, Typeable a) => a -> m ()  
setSessionData  x=
  modify $ \st -> st{mfData= M.insert  (typeOf x ) (unsafeCoerce x) (mfData st)}

-- | a shorter name for setSessionData
setSData ::  (StateType m ~ MFlowState, MonadState  m,Typeable a) => a -> m ()
setSData= setSessionData

delSessionData x=
  modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}

delSData :: (StateType m ~ MFlowState, MonadState  m,Typeable a) => a -> m ()
delSData= delSessionData

---------------------------
data EvData =  NoData | Click Int (Int, Int) | Mouse (Int, Int) | Key Int deriving (Show,Eq)
data EventData= EventData{ evName :: String, evData :: EvData} deriving Show

eventData= unsafePerformIO . newMVar $ EventData "OnLoad" NoData

resetEventData :: MonadIO m => m ()
resetEventData= liftIO . modifyMVar_ eventData . const . return $ EventData "Onload" NoData

getEventData :: MonadIO m => m EventData
getEventData= liftIO $ readMVar eventData

-- triggers the event when it happens in the widget.
--
-- What happens then?
--
-- 1)The event reexecutes all the monadic sentence where the widget is, (with no re-rendering)
--
-- 2) with the result of this reevaluaution, executes the rest of the monadic computation
--
-- 3) update the DOM tree with the rendering of the reevaluation in 2).
--
-- As usual, If one step of the monadic computation return empty, the reevaluation finish
-- So the effect of an event can be restricted as much as you may need.
--
-- Neither the computation nor the tree in the upstream flow is touched.
-- (unless you use out of stream directives, like `at`)
--
-- monadic computations inside monadic computations are executed following recursively
-- the steps mentioned above. So an event in a component deep down could or could not
-- trigger the reexecution of the rest of the whole.
raiseEvent ::  Widget a -> Event IO b ->Widget a
raiseEvent w event = View $ do
 r <- gets process
 case r of
  EventF x f  -> do
   FormElm render mx <- runView  w
   let proc = x `addto` f  >> return ()
   let nevent= evtName event :: String
   let putevdata dat= modifyMVar_ eventData $ const $ return dat
   let render' =  case event of
        OnLoad    -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc
        OnUnload  -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc
        OnChange  -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc
        OnFocus   -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc
        OnBlur    -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc

        OnMouseMove -> addEvent (render :: Perch) event $ \(x,y) -> do
                         putevdata $ EventData nevent $ Mouse(x,y)
                         proc

        OnMouseOver -> addEvent (render :: Perch) event $ \(x,y) -> do
                         putevdata $  EventData nevent $ Mouse(x,y)
                         proc

        OnMouseOut -> addEvent (render :: Perch) event proc
        OnClick -> addEvent (render :: Perch) event $ \i (x,y) -> do
                         putevdata $  EventData nevent $ Click i (x,y)
                         proc

        OnDblClick -> addEvent (render :: Perch) event $ \i (x,y) -> do
                         putevdata $ EventData nevent $ Click i (x,y)
                         proc

        OnMouseDown -> addEvent (render :: Perch) event $ \i (x,y) -> do
                         putevdata $ EventData nevent $ Click i (x,y)
                         proc

        OnMouseUp -> addEvent (render :: Perch) event $ \i (x,y) -> do
                         putevdata $ EventData nevent $ Click i (x,y)
                         proc

        OnKeyPress -> addEvent (render :: Perch) event $ \i -> do
                         putevdata $ EventData nevent $ Key i
                         proc

        OnKeyUp  -> addEvent (render :: Perch) event $ \i -> do
                         putevdata $ EventData nevent $ Key i
                         proc

        OnKeyDown -> addEvent (render :: Perch) event $ \i -> do
                         putevdata $ EventData nevent $ Key i
                         proc


   return $ FormElm render' mx
   where
   addto f f'=  do
     mr <- f
     case mr of
       Nothing -> return Nothing
       Just x' ->  f' x'

-- A shorter synonym for `raiseEvent`
fire ::  Widget a -> Event IO b ->Widget a
fire = raiseEvent

-- A shorter and smoother synonym for `raiseEvent`
wake ::  Widget a -> Event IO b -> Widget a
wake = raiseEvent

-- A professional synonym for `raiseEvent`
react :: Widget a -> Event IO b -> Widget a
react = raiseEvent

-- | pass trough only if the event is fired in this DOM element.
-- Otherwise, if the code is executing from a previous event, the computation will stop
pass :: Perch -> Event IO b -> Widget EventData
pass v event= do
        resetEventData
        wraw v `wake` event
        e@(EventData typ _) <- getEventData
        continueIf (evtName event== typ) e

-- | return empty and the monadic computation stop if the condition is false.
-- If true, return the second parameter.
continueIf :: Bool -> a -> Widget a
continueIf True x  = return x
continueIf False _ = empty

-- | executes a widget each t milliseconds until it validates and return ()
wtimeout :: Int -> Widget () -> Widget ()
wtimeout t w= View $ do
    id <- genNewId
    let f= setTimeout t $ do
        me <- elemById  id
        case me of
         Nothing -> return ()
         Just e ->do
            r <- clearChildren e >> runWidget w e
            case r of
              Nothing -> f
              Just ()  -> return ()

    liftIO  f
    runView $ identified id w


globalState= unsafePerformIO $ newMVar mFlowState0

-- run the widget as the content of a DOM element, the id is passed as parameter. All the
-- content of the element is erased previously
runWidgetId :: Widget b -> ElemID  -> IO (Maybe b)
runWidgetId ac id =  do

   withElem id $  \e -> do
      clearChildren e
      runWidget ac e


-- run the widget as the content of a DOM element
runWidget :: Widget b -> Elem  -> IO (Maybe b)
runWidget action e = do
     st <- takeMVar globalState
     (FormElm render mx, s) <- runStateT (runView action') st
     case fixed st of
       False -> build render e
       True  -> build (this `goParent` render)  e
     return mx
     where
     action' = action <** -- force the execution of the code below, even if action fails
        (View $ do
          st <- get
          liftIO $ putMVar globalState st{fixed= False}
          return $ FormElm mempty Nothing)

-- add a header content
addHeader :: Perch -> IO ()
addHeader format= do
    head <- getHead
    build format head
    return ()
    where
    getHead :: IO Elem
    getHead= ffi $ toJSStr "(function(){return document.head;})"

-- | run the widget as the body of the HTML
runBody :: Widget a -> IO (Maybe a)
runBody w= do
  body <- getBody
  (flip runWidget) body w
  where
  getBody :: IO Elem
  getBody= ffi $ toJSStr "(function(){return document.body;})"

data UpdateMethod= Append | Prepend | Insert deriving Show

-- | run the widget as the content of the element with the given id. The content can
-- be appended, prepended to the previous content or it can be the only content depending on the
-- update method.
at :: ElemID -> UpdateMethod -> Widget a -> Widget  a
at id method w= View $ do
 FormElm render mx <- (runView w)
 return $ FormElm  (set  render)  mx
 where
 set render= liftIO $ do
         me <- elemById id
         case me of
          Nothing -> return ()
          Just e -> case method of
             Insert -> do
                     clearChildren e
                     build render e
                     return ()
             Append -> do
                     build render e
                     return ()
             Prepend -> do
                     es <- getChildren e
                     case es of
                       [] -> build render e >> return ()
                       e':es -> do
                             span <- newElem "span"
                             addChildBefore span e e'
                             build render span
                             return()