content: -----------------------------------------------------------------------------
  --
  -- Module      :  View
  -- Copyright   :
  -- License     :  BSD3
  --
  -- Maintainer  :  agocorona@gmail.com
  -- Stability   :  experimental
  -- Portability :
  --
  -- | The haste-hplayground framework.  <http://github.com/agocorona/hplayground>
  --
  -----------------------------------------------------------------------------
  
  {-# LANGUAGE  FlexibleContexts, FlexibleInstances, ForeignFunctionInterface, CPP
      , TypeFamilies, DeriveDataTypeable, UndecidableInstances, ExistentialQuantification
      , GADTs, MultiParamTypeClasses, FunctionalDependencies
      #-}
  module Haste.HPlay.View(
  Widget,
  -- * re-exported
  module Control.Applicative,
  
  -- * widget combinators and modifiers
  
  (<+>), (**>), (<**), validate
  ,firstOf, manyOf, allOf
  ,(<<<),(<<),(<++),(++>),(<!)
  ,wcallback
  
  -- * basic widgets
  ,wprint
  ,getString,inputString, getInteger,inputInteger,
  getInt, inputInt,inputFloat, inputDouble,getPassword,inputPassword,
  setRadio,setRadioActive,getRadio
  ,setCheckBox, getCheckBoxes
  ,getTextBox, getMultilineText,textArea,getBool
  ,getSelect,setOption,setSelectedOption, wlabel,
  resetButton,inputReset, submitButton,
  inputSubmit, wbutton, wlink, noWidget, stop,wraw, isEmpty
  
  -- * out of flow updates
  ,at,at', UpdateMethod(..)
  
  -- * Session data storage
  ,getSessionData,getSData,setSessionData,setSData
  ,delSessionData,delSData
  
  -- * reactive and events
  ,resetEventData,getEventData, getMEventData, setIOEventData, setEventData, IsEvent(..), EventData(..),EvData(..)
  ,raiseEvent, fire, wake, react, pass
  ,continueIf, wtimeout, Event(..)
  
  -- * running it
  ,runWidget,runWidgetId, runBody, addHeader,static , dynamic
  
  -- * Perch is reexported
  ,module Haste.Perch
  
  -- * communications
  ,ajax,Method(..)
  
  -- * low level and internals
  ,getNextId,genNewId, continuePerch
  ,getParam, getCont,runCont
  ,FormInput(..)
  ,View(..),FormElm(..),EventF(..), MFlowState(..)
  
  )  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 hiding (attr)
  import Haste.Prim
  import Haste.Foreign
  import Haste.JSON hiding ((!))
  import Unsafe.Coerce
  import System.IO.Unsafe
  import Control.Concurrent.MVar
  import Data.IORef
  import qualified Data.Map as M
  import Control.Monad.Trans.Maybe
  import Prelude hiding(id,span)
  import Haste.Perch
  import Haste.Ajax
  import Data.Dynamic
  
  --import Debug.Trace
  --(!>)= flip trace
  
  data NeedForm= HasForm | HasElems  | NoElems deriving Show
  type SData= ()
  
  
  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
                              , lastEvent :: Dynamic
                              , 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
                          (toDyn $toDyn $ EventData "OnLoad" NoData)
                          M.empty
  
  noid= error "noId error"
  
  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, Monad(View view m)) => Functor (View view m) where
    fmap f mx= do -- View $   fmap (fmap f) $ runView mx
         x <- mx
         return $ f x
  
  instance (Monoid view,Functor m, Monad m,Monad (View view 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,Monad(View view 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 f mx <- runView x
      put st'
      return $ FormElm mempty mx
  
  setEventCont :: Widget a -> (a -> Widget b)  -> ElemID -> StateT MFlowState IO EventF
  setEventCont x f  id= do
     st <- get
     let conf = process st
     case conf of
       EventF  _ fs  -> do
         let idx=  runWidgetId (strip st x) "noid"
         put st{process= EventF idx ( \x ->   runWidgetId ( f x) id `bind` unsafeCoerce fs)  }
     return conf
  --   where
  --   at id 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 ->  do
  --                     clearChildren e
  --                     build render e
  --                     return ()
  
  
  resetEventCont cont= modify $ \s -> s {process= cont}
  
  instance Monad (View Perch IO) where
      x >>= f = View $ do
         fix <- gets fixed
         id1 <- genNewId
         contold <- setEventCont x  f  id1
         FormElm form1 mk <- runView x
         resetEventCont contold
         case mk of
           Just k  -> do
              FormElm form2 mk <- runView $ f k
              return $ FormElm (form1 <> maybeSpan fix id1 form2) mk
           Nothing ->
              return $ FormElm  (form1 <> maybeSpan fix id1 noHtml)  Nothing
         where
         maybeSpan True id1 form= form
         maybeSpan False id1 form= span ! id id1 $ form
  
  
  
      return = View .  return . FormElm  mempty . Just
      fail msg= View . return $ FormElm (inred $ fromStr msg) Nothing
  
  
  -- | To produce updates, each line of html produced by a "do" sequence in the Widget monad is included
  -- within a 'span' tag. When the line is reexecuted after a event, the span is updated with the new
  -- rendering.
  --
  -- static tell to the rendering that this widget does not change, so the extra 'span' tag for each
  -- line in the sequence and the rewriting is not necessary. Thus the size of the HTML and the
  -- performance is improved.
  
  static w= View $ do
     st <- get
     let was = fixed st
     put st{fixed=True}
     r <- runView $ w
     modify $ \st -> st{fixed= was}
     return r
  
  -- | override static locally to permit dynamic effects inside a static widget. It is useful
  -- when a monadic Widget computation which perform no rendering changes has a to do some update:
  --
  -- > launchMissiles= static $ do
  -- >    t <- armLauncher
  -- >    c <- fixTarget t
  -- >    f <- fire c
  -- >    dynamic $ displayUpdate t c f
  -- >    return ()
  
  dynamic w= View $ do
     st <- get
     let was = fixed st
     put st{fixed= False}
     r <- runView $ w
     modify $ \st -> st{fixed= was}
     return r
  
  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 rendering of the second parameter substitutes the rendering
  -- of the first paramenter when the latter validates without afecting the rendering of other widgets.
  -- This allow the simultaneous execution of different dynamic behaviours in different page locations
  -- at the same page.
  wcallback
    ::  Widget a -> (a ->Widget b) -> Widget b
  
  wcallback x f= View $ do
     nid <-  genNewId
     FormElm form mx <- runView $ do
               r <-  at nid Insert x
               at nid Insert $ f r
  
     return $ FormElm ((Haste.Perch.span ! atr "id" nid $ noHtml) <> form) mx
  
  
  
  identified id w= View $ do
       let span= nelem "span" `attr` ("id", id)
       FormElm f mx <- runView w
       return $ FormElm (span `child` f) mx
  
  
  
  
  
  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
    :: Widget a
       -> (a -> WState Perch IO (Maybe Perch))
       -> Widget a
  validate  w val= static $ do
     idn <- genNewId
     wraw $ span ! id idn $ noHtml
     x <-  w
     View $ do
            me <- val x
            case me of
               Just str -> do
                    liftIO $ withElem idn $ build $ clear >> inred  str
                    return $ FormElm mempty Nothing
               Nothing  -> do
                    liftIO $ withElem idn $ build $ clear
                    return $ FormElm mempty $ Just x
  
  
  
  
  -- | 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
  
  inputFloat :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) =>
       Maybe Float -> View view m Float
  inputFloat =  getTextBox
  
  inputDouble :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) =>
       Maybe Double -> View view m Double
  inputDouble =  getTextBox
  
  -- | 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 :: (Typeable a, Eq a, Show a) =>
                      a -> String -> Widget (Radio a)
  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 a= CheckBoxes [a]
  
  instance Monoid (CheckBoxes a) 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, Typeable a , Show a) =>
                  Bool -> a -> View view m  (CheckBoxes a)
  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
        showv= case typeOf v== typeOf (undefined ::String) of
                 True -> unsafeCoerce v
                 False -> show v
    return $ FormElm
        ( finput n "checkbox" showv ( checked' ) Nothing)
        ret
  
  
  getCheckBoxes :: (Monad m, FormInput view) =>  View view m  (CheckBoxes a) ->  View view m  [a]
  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,Monad(View view 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
  
  
  -- passive reset button.
  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
  
  -- passive submit button. Submit a form, but it is not trigger any event.
  -- Unless you attach it with `trigger`
  submitButton :: (Monad (View view m),StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) => String -> View view m String
  submitButton label=  getParam Nothing "submit" $ Just label
  
  
  inputSubmit :: (Monad (View view m),StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) => String -> View view m String
  inputSubmit= submitButton
  
  -- | active button. When clicked, return the first parameter
  wbutton :: a -> String -> Widget a
  wbutton x label= static $ do
          input  ! atr "type" "submit" ! id label ! atr "value" label `pass` OnClick
          return x
        `continuePerch`  label
  
  -- | when creating a complex widget with many tags, this call indentifies which tag will receive the attributes of the (!) operator.
  continuePerch :: Widget a -> ElemID -> Widget a
  continuePerch w eid= View $ do
        FormElm f mx <- runView w
        return $ FormElm (c f) mx
        where
        c f =Perch $ \e' ->  do
           build f e'
           elemid eid
  
        elemid id= elemById id >>= return . fromJust
  
  
  -- | Present a link. Return the first parameter when clicked
  wlink :: (Show a, Typeable a) => a -> Perch -> Widget a
  wlink x v= static $ do
      (a ! href ("#/"++show1 x)   $ v) `pass` OnClick
      return x
  
     where
     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 ::  [Widget a]  -> Widget a
  firstOf xs= Prelude.foldl (<|>) noWidget xs
  
  -- | from a list of widgets, it return the validated ones.
  manyOf :: [Widget a]  -> Widget [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
  
  -- | show something enclosed in the <pre> tag, so ASCII formatting chars are honored
  wprint :: ToElem a => a -> Widget ()
  wprint = wraw . pre
  
  -- | 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.
  --
  
  (<<<) :: (Perch ->Perch)
           -> Widget a
           -> Widget 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
  (++>) ::  Perch -> Widget a -> Widget 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 ::  Widget a
  noWidget= Control.Applicative.empty
  
  -- | a sinonym of noWidget that can be used in a monadic expression in the View monad. it stop the
  -- computation in the Widget monad.
  stop :: 
       Widget a
  stop= Control.Applicative.empty
  
  
  -- | Render raw view formatting. It is useful for displaying information.
  wraw ::  Perch -> Widget ()
  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) | MouseOut | Key Int deriving (Show,Eq,Typeable)
  data EventData= EventData{ evName :: String, evData :: EvData} deriving (Show,Typeable)
  
  --eventData :: MVar Dynamic
  --eventData= unsafePerformIO . newMVar . toDyn $ EventData "OnLoad" NoData
  
  resetEventData :: (StateType m ~ MFlowState, MonadState  m) => m ()
  resetEventData=   modify $ \st -> st{ lastEvent= toDyn $ EventData "Onload" NoData}
  
  
  getEventData :: Typeable a => Widget a
  getEventData =  View $ do
         mr <- getMEventData
         return $ FormElm noHtml mr
  
  -- gets lastEvent >>= return . (flip fromDyn) (error "getEventData: event type not expected")
  
  setEventData ::  (Typeable a, StateType m ~ MFlowState, MonadState  m) => a-> m ()
  setEventData dat=  modify $ \st -> st{ lastEvent= toDyn dat}
  
  getMEventData :: (Typeable a, StateType m ~ MFlowState, MonadState  m) => m (Maybe a)
  getMEventData= gets lastEvent >>= return . fromDynamic
  
  setIOEventData :: Typeable a => a -> IO ()
  setIOEventData dat= do
    st <- takeMVar globalState
    putMVar globalState st{ lastEvent= toDyn dat}
  
  
  
  class IsEvent a b | a -> b where
     eventName :: a -> String
     buildHandler :: a  -> IO () -> b
  
  instance  IsEvent (Event m a)  a   where
     eventName= evtName
  
     buildHandler event iohandler=
       let nevent= eventName event
           setDat :: EventData -> m ()
           setDat d=  unsafeCoerce $ do
              setIOEventData d
              iohandler
  
       in case event of
          OnLoad    ->  setDat (EventData nevent NoData)
          OnUnload  ->  setDat (EventData nevent NoData)
          OnChange  ->  setDat (EventData nevent NoData)
          OnFocus   ->  setDat (EventData nevent NoData)
          OnBlur    ->  setDat (EventData nevent NoData)
  
          OnMouseMove ->   \(x,y) ->  setDat $ EventData nevent $ Mouse(x,y)
  
  
          OnMouseOver ->   \(x,y) ->  setDat $  EventData nevent $ Mouse(x,y)
  
  
          OnMouseOut ->     setDat $  EventData nevent $ MouseOut
  
  
          OnClick ->       \i (x,y) -> setDat $  EventData nevent $ Click i (x,y)
  
  
          OnDblClick ->   \i (x,y) ->  setDat $ EventData nevent $ Click i (x,y)
  
  
          OnMouseDown ->   \i (x,y) -> setDat $ EventData nevent $ Click i (x,y)
  
  
          OnMouseUp ->   \i (x,y) ->  setDat $ EventData nevent $ Click i (x,y)
  
  
          OnKeyPress ->   \i ->  setDat $ EventData nevent $ Key i
  
  
          OnKeyUp  ->   \i ->  setDat $ EventData nevent $ Key i
  
  
          OnKeyDown ->   \i ->  setDat $ EventData nevent $ Key i
  
  
  
  
  
  -- | 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 ::  IsEvent event callback => Widget a -> event -> Widget a
  raiseEvent w event = View $ do
     cont <- getCont
     FormElm render mx <- runView  w
     let iohandler = runCont cont
         nevent = eventName event
  
         render' = addEvent' (render :: Perch) event iohandler
  
     return $ FormElm render' mx
     where
     -- | create an element and add any event handler to it.
     -- This is a generalized version of addEvent
     addEvent' :: IsEvent a b => Perch -> a -> IO() -> Perch
     addEvent' be eevent iohandler= Perch $ \e -> do
          e' <- build be e
          let event= eventName eevent
  
          let hand =  buildHandler eevent iohandler
          listen  e' event  $ hand
          return e'
  
  -- | A shorter synonym for `raiseEvent`
  fire ::   IsEvent event callback=> Widget a -> event -> Widget a
  fire = raiseEvent
  
  -- | A shorter and smoother synonym for `raiseEvent`
  wake ::   IsEvent event callback=> Widget a -> event -> Widget a
  wake = raiseEvent
  
  -- | A professional synonym for `raiseEvent`
  react ::  IsEvent event callback=> Widget a -> event -> 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= static $ 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
  
  -- getting and running continuations
  
  getCont ::(StateType m ~ MFlowState, MonadState  m) => m EventF
  getCont = gets process
  
  
  runCont :: EventF -> IO()
  runCont (EventF x  fs)= x `bind` fs  >> return ()
  
  
  bind :: IO (Maybe a) -> (a -> IO (Maybe  b)) -> IO (Maybe b)
  bind x  f= do
     mr <- x
     case mr of
       Just r -> f r
       Nothing -> return Nothing
  
  --bind x f = View $ do
  --    FormElm form1 mk <- runView x
  --    case mk of
  --      Just k  -> do
  --         FormElm form2 mk <- runView $ f k
  --         return $ FormElm (form1 <> form2) mk
  --      Nothing ->
  --         return $ FormElm  form1  Nothing
  
  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 and it is substituted by the new rendering
  runWidgetId :: Widget b -> ElemID  -> IO (Maybe b)
  runWidgetId ac id =  do
     me <- elemById id
     case me of
       Just e ->  do
        clearChildren e
        runWidget ac e
       Nothing -> do
            st <- unsafeCoerce $ takeMVar globalState
            (FormElm render mx, s) <- runStateT (runView ac) st
            liftIO $ putMVar globalState s
            return mx
  
  
  -- | run the widget as the content of a DOM element
  -- the new rendering is added to the element
  runWidget :: Widget b -> Elem  -> IO (Maybe b)
  runWidget action e = do
       st <- takeMVar globalState
       (FormElm render mx, s) <- runStateT (runView action) st
       liftIO $ putMVar globalState s
       build render e
       return mx
  
  
  
  -- | add a header in the <header> tag
  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 | Outer 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 internal(Insert) or external(Outer) content depending on the
  -- update method.
  at ::  String -> UpdateMethod -> Widget a -> Widget  a
  at ident= at' ('#':ident)
  
  -- | A generalized version of `at` that include the widget rendering at the elements that meet the selector criteria
  -- (the first parameter) in the style of jQuery. the selector can match  classes etc not only identifiers.
  at' ::  String -> 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 $  case method of
               Insert -> do
                       forElems' id $ clear >> render
                       return ()
               Outer  -> do
                       forElems' id $ this `outer` render
                       return()
               Append -> do
                       forElems' id render
                       return ()
               Prepend -> do
                      forElems' id  $ Perch $ \e -> do
                       es <- getChildren e
                       case es of
                         [] -> build render e >> return e
                         e':es -> do
                               span <- newElem "span"
                               addChildBefore span e e'
                               build render span
                               return e
  
  -- ajax
  
  responseAjax :: IORef [(String,Maybe JSString)]
  responseAjax = unsafePerformIO $ newIORef []
  
  
  -- | Invoke AJAX. `ToJSString` is a class coverter to-from JavaScript strings
  -- `(a,b)` are the lists of parameters, a is normally `String` or `JSString`.
  -- JSON is also supported for `b` and `c`. If you want to handle your data types, make a instance of
  -- `JSType`
  --
  -- Note the de-inversion of control. There is no callback.
  --
  -- `ajax` can be combined with other Widgets using monadic, applicative or alternative combinators.
  ajax :: (JSType  a, JSType  b, JSType  c,Typeable c)
       => Method -> URL -> [(a, b)] -> Widget (Maybe c)
  ajax method url kv= View $ do
        id <- genNewId
        rs <- liftIO $ readIORef responseAjax
        case lookup id rs of
          Just rec -> liftIO $ do
                 writeIORef responseAjax $ filter ((/= id). fst) rs
  
                 return $ FormElm  mempty $  fmap fromJSString rec
          _ -> do
                proc <- gets process
                liftIO $ textRequest'  method url kv $ cb id proc
                return $ FormElm mempty Nothing
  
  
    where
    -- cb :: String -> (Widget a) -> [(b -> Widget c,ElemID)] -> Maybe d -> IO()
    cb id cont rec= do
      responses <- readIORef responseAjax
      liftIO $ writeIORef responseAjax $  (id, rec):responses
      runCont cont
      return ()
  
  
  
  
  
  textRequest' :: (JSType a, JSType b, JSType c)
          => Method
          -> URL
          -> [(a, b)]
          -> (Maybe c -> IO ())
          -> IO ()
  textRequest' m url kv cb = do
          _ <- ajaxReq (toJSString $ show m) url' True pd cb'     -- here postdata is ""
          return ()
          where
          cb' = mkCallback $ cb . fmap fromJSS'
          url' = case m of
                 GET -> if null kv then toJSString url else catJSStr (toJSString "?") [toJSString url, toQueryString kv]
                 POST -> toJSString url
          pd = case m of
                 GET ->  toJSString ""
                 POST -> if null kv then  toJSString "" else toQueryString kv
  
          fromJSS'= fromJust . fromJSString
  
  
  toQueryString :: (JSType a, JSType b) =>[(a, b)] -> JSString
  toQueryString = catJSStr (toJSString "&") . Prelude.map (\(k,v) -> catJSStr (toJSString "=") [toJSString k,toJSString v])
  
  #ifdef __HASTE__
  foreign import ccall ajaxReq :: JSString    -- method
                               -> JSString    -- url
                               -> Bool        -- async?
                               -> JSString    -- POST data
                               -> JSFun (Maybe JSString -> IO ())
                               -> IO ()
  foreign import ccall jsSetCB :: Elem -> JSString -> JSFun a -> IO Bool
  #else
  ajaxReq= undefined
  jsSetCB= undefined
  #endif
  
  listen :: JSType event => Elem -> event -> a -> IO Bool
  listen e event f= jsSetCB e (toJSString event) (mkCallback $! f)
  
  
  
  
  
  