{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE ScopedTypeVariables        #-}
module GHCJS.HPlay.View(
    Widget(..)
  -- * Running it
  , module Transient.Move.Utils
  , runBody
  , addHeader
  , render
  -- * Widget Combinators and Modifiers
  , (<<)
  , (<<<)
  , (<!)
  , (<++)
  , (++>)
  , validate
  , wcallback
  , redraw
  -- * Basic Widgets
  , option
  , 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
  , tlink
  , staticNav
  , noWidget
  , wraw
  , rawHtml
  , isEmpty
  -- * Events
  , BrowserEvent(..)
  -- * Out of Flow Updates
  , UpdateMethod(..)
  , at, at'
  -- * Reactive and Events
  , IsEvent(..)
  , EventData(..)
  , EvData(..)
  , resetEventData
  , getEventData
  , setEventData
  , raiseEvent
  , fire
  , wake
  , pass
  -- * Low-level and Internals
  , ElemID
  , getNextId
  , genNewId
  , continuePerch
  , getParam
  , getCont
  , runCont
  , elemById
  , withElem
  , getProp
  , setProp
  , alert
  , fromJSString
  , toJSString
  , getValue
  -- * Re-exported
  , module Control.Applicative
  , module GHCJS.Perch  
  -- remove
  ,CheckBoxes(..)
  ,edit
  ,JSString,pack, unpack
  ,RadioId(..), Radio(..)

)  where


import           Transient.Internals     hiding (input, option, parent)
import           Transient.Logged
import           Transient.Move.Utils
import qualified Prelude(id,span,div)
#ifndef ghcjs_HOST_OS
import           Transient.Parse hiding(parseString)
import           Data.Char(isSpace)
import           System.Directory
import           System.IO.Error
import           Data.List(elemIndices)
import           Control.Exception hiding (try)
import qualified Data.ByteString.Lazy.Char8 as BS
#endif

import           Control.Monad.State
-- import qualified Data.Map                as M

import           Control.Applicative
import           Control.Concurrent
import           Data.Dynamic

import           Data.Maybe
import           Data.Monoid
import           Data.Typeable
import           Prelude                 hiding (id,span,div)
import           System.IO.Unsafe
import           Unsafe.Coerce

import           Data.IORef


#ifdef ghcjs_HOST_OS

import           GHCJS.Foreign
import           GHCJS.Foreign.Callback
import           GHCJS.Foreign.Callback.Internal (Callback(..))
import           GHCJS.Marshal

import           GHCJS.Perch             hiding (JsEvent (..), eventName, option,head,map)
import           GHCJS.Types
import           Transient.Move          hiding (pack)

import qualified Data.JSString           as JS hiding (empty, center,span, strip,foldr,head)
import           Data.JSString (pack,unpack,toLower)
#else
import           Data.List as JS         hiding (span)
import           GHCJS.Perch             hiding (JSVal, JsEvent (..), eventName, option,head, map)
import           Transient.Move          
#endif

#ifndef ghcjs_HOST_OS
type JSString = String

#endif

---- | if invoked from the browser, run A computation in the web server and return to the browser
--atServer :: Loggable a => Cloud a -> Cloud a
--atServer proc= do
--     server <- onAll getSData <|> error "server not set, use 'setData serverNode'"
--     runAt server  proc

toJSString :: (Show a, Typeable a) => a -> JSString
toJSString x =
  if typeOf x == typeOf (undefined :: String )
  then pack $ unsafeCoerce x
  else pack$ show x

fromJSString :: (Typeable a,Read a) => JSString -> a
fromJSString s = x
   where
     x | typeOf x == typeOf (undefined :: JSString) =
         unsafeCoerce x            --  !> "unsafecoerce"
       | typeOf x == typeOf (undefined :: String) =
         unsafeCoerce $ pack$ unsafeCoerce x            -- !!> "packcoerce"
       | otherwise = read $ unpack s            -- !> "readunpack"

getValue :: MonadIO m => Elem -> m (Maybe String)

getName :: MonadIO m => Elem -> m (Maybe String)
#ifdef ghcjs_HOST_OS
getValue e = liftIO $ do
   s <- getValueDOM e
   fromJSVal s -- return $ JS.unpack s

getName e = liftIO $ do
   s <- getNameDOM e
   fromJSVal s
#else
getValue = undefined
getName = undefined
#endif

elemBySeq :: (MonadState EventF m, MonadIO m) => JSString -> m (Maybe Elem)
#ifdef ghcjs_HOST_OS
elemBySeq id = do
    IdLine _ id1 <- getData `onNothing` error ("not found: " ++ show id) --  return (IdLine "none")
    return  ()                                                    !> ("elemBySeq",id1, id)
    liftIO $ do
        let id2= JS.takeWhile (/='p') id
        re <- elemBySeqDOM id1 id2
        fromJSVal re
#else
elemBySeq _ = return Nothing
#endif

#ifdef ghcjs_HOST_OS
attribute :: (MonadIO m)  => Elem -> JSString -> m (Maybe JSString)
attribute elem prop=  liftIO $ do
    rv <- attributeDOM elem "id"
    fromJSVal rv
#else
attribute _ = return Nothing
#endif

elemById :: MonadIO m  => JSString -> m (Maybe Elem)
#ifdef ghcjs_HOST_OS
elemById id= liftIO $ do
   re <- elemByIdDOM id
   fromJSVal re
#else
elemById _= return Nothing
#endif

withElem :: ElemID -> (Elem -> IO a) -> IO a
withElem id f= do
  me <- elemById id
  case me of
     Nothing -> error ("withElem: not found"++ fromJSString id)
     Just e -> f e

--data NeedForm= HasForm | HasElems  | NoElems deriving Show


type ElemID= JSString
newtype Widget a=  Widget{ norender :: TransIO a} deriving(Monad,MonadIO, Alternative, MonadState EventF,MonadPlus,Num)

instance   Functor Widget where
  fmap f mx=   Widget. Transient $ fmap (fmap f) . runTrans $ norender mx



instance Applicative Widget where
  pure= return

  Widget (Transient x) <*> Widget (Transient y) = Widget . Transient $ do
        getData `onNothing` do 
            cont <- get
            let al= Alternative cont
            setData $ Alternative cont
            return al
        mx <- x
        my <- y
        return $ mx <*> my



instance Monoid a => Monoid (Widget a) where
  mempty= return mempty
  mappend x y= do 
     (<>) <$> x  <*> y

instance AdditionalOperators Widget where

    Widget (Transient x) <** Widget (Transient y)= Widget . Transient $ do
                getData `onNothing` do 
                  cont <- get
                  let al= Alternative cont
                  setData $ Alternative cont
                  return al
                 
                mx <- x
                y
                return mx

    (<***) x y= Widget $  norender x <*** norender y

    (**>)  x y= Widget $  norender x **>  norender y



runView :: Widget a -> StateIO (Maybe a)
runView  = runTrans . norender

-- | 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.
wcallback
  ::  Widget a -> (a ->Widget b) -> Widget b

wcallback x f= Widget $ Transient $ do
   nid <-  genNewId
   runView $ do
             r <-  at nid Insert x
             at nid Insert $ f r


-- | execute a widget but redraw itself too when some event happens.
-- The first parameter is the path of the DOM element that hold the widget, used by `at`

redraw :: JSString -> Widget a -> TransIO a
redraw idelem w=  do
   path <- getState <|> return ( Path [])
   r <- render $ at idelem Insert  w
   setState path
   redraw  idelem w   <|> return r



{-
instance Monoid view => MonadTrans (View view) where
  lift f = Transient $  (lift  f) >>= \x ->  returnFormElm mempty $ Just x
-}

type Name= JSString
type Type= JSString
type Value= JSString
type Checked= Bool
type OnClick1= Maybe JSString


-- | 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 :: JSString -> view
--     fromStrNoEncode :: String -> view
--     ftag :: JSString -> view  -> view
--     inred   :: view -> view
--     flink ::  JSString -> view -> view
--     flink1:: JSString -> view
--     flink1 verb = flink verb (fromStr verb)
--     finput :: Name -> Type -> Value -> Checked -> OnClick1 -> view
--     ftextarea :: JSString -> JSString -> view
--     fselect :: JSString -> view -> view
--     foption :: JSString -> view -> Bool -> view
--     foption1 :: JSString -> Bool -> view
--     foption1   val msel= foption val (fromStr val) msel
--     formAction  :: JSString -> JSString -> view -> view
--     attrs :: view -> Attribs -> view

type Attribs= [(JSString, JSString)]


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 :: ( Typeable a, Read a, Show a)
          => Bool -> JSString ->  StateIO (ParamResult Perch a)
getParam1 exact  par = do
   isTemplate <- liftIO $ readIORef execTemplate
   if isTemplate then return NoParam else do
      
       me <- if exact then elemById par else elemBySeq par
                                                !> ("looking for " ++ show par)
       case me of
         Nothing -> return  NoParam
         Just e ->  do
            v <- getValue e                       -- !!> ("exist" ++ show par)
            readParam v                           -- !!> ("getParam for "++ show v)


type Params= Attribs



readParam :: (Typeable a, Read a)=> Maybe String -> StateIO (ParamResult Perch a)
readParam Nothing = return NoParam
readParam (Just 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            -- !!> ("maybread string " ++ str)
   else if typeofx == typeOf(undefined :: JSString) then
           return . Validated $ unsafeCoerce $ pack  str
   else case reads $ str  of          --            -- !!> ("read " ++ str) of
              [(x,"")] ->  return $ Validated x            -- !!> ("readsprec" ++ show x)
              _ -> do
                   let err= inred $ "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 -> StateIO  (Maybe Perch))
     -> Widget a
validate  w val=  do
   idn <- Widget $ Transient $ Just <$> genNewId
   rawHtml $ span ! id idn $ noHtml
   x <-  w
   Widget $ Transient $ do
          me <- val x
          case me of
             Just str -> do
                  liftIO $ withElem idn $ build $ clear >> (inred  str)
                  return Nothing
             Nothing  -> do
                  liftIO $ withElem idn $ build clear
                  return $ 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.


{-#NOINLINE rprefix #-}
rprefix= unsafePerformIO $ newIORef 0
#ifdef ghcjs_HOST_OS
genNewId ::  (MonadState EventF m, MonadIO m) => m  JSString
genNewId=  do
      r <- liftIO $ atomicModifyIORef rprefix (\n -> (n+1,n))
      n <- genId
      let nid= toJSString $  ('n':show n) ++ ('p':show r)
      nid `seq` return  nid



#else
genNewId ::  (MonadState EventF m, MonadIO m) => m  JSString
genNewId= return $ pack ""

--getPrev ::  StateIO  JSString
--getPrev= return $ pack ""
#endif



-- | get the next ideitifier that will be created by genNewId
getNextId :: MonadState EventF  m  =>  m JSString
getNextId=  do
      n <- gets mfSequence

      return $ toJSString $ 'p':show n


-- | Display a text box and return a non empty String
getString  ::  Maybe String -> Widget String
getString = getTextBox
--     `validate`
--     \s -> if Prelude.null s then return (Just $ fromStr "")
--                    else return Nothing

inputString  :: Maybe String -> Widget String
inputString= getString

-- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation)
getInteger :: Maybe Integer -> Widget  Integer
getInteger =  getTextBox

inputInteger ::  Maybe Integer -> Widget  Integer
inputInteger= getInteger

-- | Display a text box and return a Int (if the value entered is not an Int, fails the validation)
getInt :: Maybe Int -> Widget Int
getInt =  getTextBox

inputInt :: Maybe Int -> Widget Int
inputInt =  getInt

inputFloat :: Maybe Float -> Widget Float
inputFloat =  getTextBox

inputDouble :: Maybe Double -> Widget Double
inputDouble =  getTextBox

-- | Display a password box
getPassword :: Widget String
getPassword = getParam Nothing "password" Nothing

inputPassword ::   Widget String
inputPassword= getPassword

newtype Radio a= Radio a

data RadioId= RadioId JSString deriving Typeable

-- | Implement a radio button
setRadio :: (Typeable a, Eq a, Show a,Read a) =>
            Bool -> a ->  Widget  (Radio a)
setRadio ch v = Widget $ Transient $ do
  RadioId name <- getData `onNothing` error "setRadio out of getRadio"
  id <- genNewId
  me <- elemBySeq id  
  checked <-  case me  of
      Nothing -> return ""
      Just e  -> liftIO $ getProp e "checked"
  
  let str = if typeOf v == typeOf(undefined :: String)
                   then unsafeCoerce v else show v
  addSData
      ( finput id "radio" (toJSString str)  ch Nothing `attrs` [("name",name)] :: Perch)
  
  if  checked == "true" !> ("val",v) then Just . Radio . read1 . unpack <$> liftIO (getProp (fromJust me) "value") else return Nothing
  where 
  read1 x=r 
    where
    r= if typeOf r== typeOf (undefined :: String) then unsafeCoerce x 
          else read x 

setRadioActive :: (Typeable a, Eq a, Show a,Read a) =>
                   Bool -> a -> Widget (Radio a)
setRadioActive ch rs = setRadio ch rs `raiseEvent` OnClick


-- | encloses a set of Radio boxes. Return the option selected
getRadio
   ::  [Widget (Radio a)] -> Widget a
getRadio ws =  do
  id <- genNewId
  setData $ RadioId id
  Radio x <- foldr (<|>) empty ws <*** delData (RadioId id)
  return x


newtype CheckBoxes a= CheckBoxes [a] deriving Monoid

-- | present a checkbox
setCheckBox :: (Typeable a , Show a) =>
                Bool -> a -> Widget  (CheckBoxes a)
setCheckBox checked' v= Widget . Transient $ do
  n  <- genNewId
  me <- elemBySeq n
  let showv= toJSString (if typeOf v == typeOf (undefined :: String)
                             then unsafeCoerce v
                             else show v)

  addSData $  ( finput n "checkbox" showv  checked' Nothing :: Perch)

  case me of
       Nothing -> return Nothing
       Just e -> do
            checked <- liftIO $ getProp e "checked"
            return . Just . CheckBoxes $ if  checked=="true"  then [v] else []

-- Read the checkboxes
getCheckBoxes ::  Show a => Widget  (CheckBoxes a) ->  Widget  [a]
getCheckBoxes w =  do
  CheckBoxes rs <-  w
  return rs
 

whidden :: (Read a, Show a, Typeable a) => a -> Widget a
whidden x= res where
 res= Widget . Transient $ do
    n <- genNewId
    let showx= case cast x of
                Just x' -> x'
                Nothing -> show x
    r <- getParam1 False n  `asTypeOf` typef res
    addSData (finput n "hidden" (toJSString showx) False Nothing :: Perch)
    return (valToMaybe r)
    where
    typef :: Widget a -> StateIO (ParamResult Perch a)
    typef = undefined




getTextBox
  :: (Typeable a,
      Show a,
      Read a) =>
     Maybe a ->  Widget a
getTextBox ms  = getParam Nothing "text" ms


getParam
  :: (Typeable a,
      Show a,
      Read a) =>
      Maybe JSString -> JSString -> Maybe a -> Widget  a
getParam look type1 mvalue= Widget . Transient $ 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 -> mempty
          Just v  ->
              if (typeOf v== typeOf (undefined :: String)) then  pack(unsafeCoerce v)
              else if typeOf v== typeOf (undefined :: JSString) then unsafeCoerce v
              else toJSString $ show v             -- !!> "show"

    -- setData HasElems
    r <- getParam1 (isJust look) tolook
    
    case r of
       Validated x        -> do addSData (finput tolook type1 (nvalue $ Just x) False Nothing :: Perch) ; return $ Just x            -- !!> "validated"
       NotValidated s err -> do addSData (finput tolook type1  (toJSString s) False Nothing <> err :: Perch); return Nothing
       NoParam            -> do setData WasParallel;addSData (finput tolook type1 (nvalue mvalue) False Nothing :: Perch); return  Nothing




-- | Display a multiline text box and return its content
getMultilineText :: JSString
                 -> Widget String
getMultilineText nvalue =  res where
 res= Widget. Transient $ do
    tolook <- genNewId   !>  "GETMULTI"
    r <- getParam1 False tolook  `asTypeOf` typef res
    case r of
       Validated x        -> do addSData (ftextarea tolook  $ toJSString x :: Perch); return $ Just x     !> "VALIDATED"
       NotValidated s err -> do addSData (ftextarea tolook   (toJSString s) :: Perch); return  Nothing    !> "NOTVALIDATED"
       NoParam            -> do setData WasParallel;addSData (ftextarea tolook  nvalue :: Perch); return  Nothing  !> "NOTHING"
    where
    typef :: Widget String -> StateIO (ParamResult Perch String)
    typef = undefined

-- | A synonim of getMultilineText
textArea ::  JSString ->Widget String
textArea= getMultilineText



getBool :: Bool -> String -> String -> Widget Bool
getBool mv truestr falsestr= do
   r <- getSelect $   setOption truestr (fromStr $ toJSString truestr)  <! (if mv then [("selected","true")] else [])
                  <|> setOption falsestr(fromStr $ toJSString 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 :: (Typeable a, Read a,Show a) =>
      Widget (MFOption a) ->  Widget  a
getSelect opts = res where
  res= Widget . Transient $ do
    tolook <- genNewId
    -- st <- get
--    setData HasElems
    r <- getParam1 False tolook `asTypeOf` typef res
--    setData $ fmap MFOption $ valToMaybe r
    runView $ fselect tolook <<< opts
--
    return $ valToMaybe r

    where
    typef :: Widget a -> StateIO (ParamResult Perch a)
    typef = undefined


newtype MFOption a = MFOption a deriving (Typeable, Monoid)



-- | Set the option for getSelect. Options are concatenated with `<|>`
setOption
  :: (Show a, Eq a, Typeable a) =>
     a -> Perch -> Widget (MFOption a)
setOption n v = setOption1 n v False


-- | Set the selected option for getSelect. Options are concatenated with `<|>`
setSelectedOption
  :: (Show a, Eq a, Typeable a) =>
     a -> Perch -> Widget (MFOption a)
setSelectedOption n v= setOption1 n v True


setOption1 :: (Typeable a, Eq a, Show a) =>
      a -> Perch -> Bool ->  Widget  (MFOption a)
setOption1 nam  val check= Widget . Transient $ do
    let n = if typeOf nam == typeOf(undefined :: String)
                   then unsafeCoerce nam
                   else show nam

    addSData (foption (toJSString n) val check)

    return  Nothing -- (Just $ MFOption nam)


wlabel:: Perch -> Widget a -> Widget a
wlabel str w = Widget . Transient $ do
   id <- getNextId
   runView $ (ftag "label" str `attrs` [("for",id)] :: Perch) ++> w



-- passive reset button.
resetButton :: JSString -> Widget ()
resetButton label= Widget . Transient $ do
   addSData  (finput  "reset" "reset" label False Nothing :: Perch)
   return $ Just ()

inputReset :: JSString -> Widget ()
inputReset= resetButton

-- passive submit button. Submit a form, but it is not trigger any event.
-- Unless you attach it with `raiseEvent`
submitButton ::  (Read a, Show a, Typeable a) => a -> Widget a
submitButton label=  getParam Nothing "submit" $ Just label


inputSubmit ::  (Read a, Show a, Typeable a) => a -> Widget a
inputSubmit= submitButton

-- | active button. When clicked, return the first parameter
wbutton :: a -> JSString -> Widget a
wbutton x label= Widget $ Transient $ do
     idn <- genNewId
     runView $ do
        input  ! atr "type" "submit" ! id   idn ! atr "value" label `pass` OnClick
        return x
      `continuePerch`  idn


-- | 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=   c <<< w
      where
      c f =Perch $ \e' ->  do
         build f e'
         elemid eid

      elemid id= elemById id >>=  return . fromJust

--      child  e = do
--             jsval <- firstChild e
--             fromJSValUnchecked jsval

rReadIndexPath= unsafePerformIO $ newIORef 0

-- | Present a link. It return the first parameter and execute the continuation when it is clicked.
--
-- It also update the path in the URL.
wlink :: (Show a, Typeable a) => a -> Perch -> Widget a
#ifdef ghcjs_HOST_OS
wlink x v=  do
    (a ! href "#"   $ v)  `pass` OnClick
    Path paths <- Widget $ getSData <|> return (Path  [])

    let paths'= paths ++  [ toLower $ JS.pack $ show1 x ]
    setData $ Path  paths'
--                                                         !> ("paths", paths')
    let fpath= ("/" <> (Prelude.foldl  (\p p' -> p <> "/" <> p') (head paths') $ tail paths')<> ".html")
    liftIO $ replaceState "" "" fpath
    return x
#else
wlink _ _= empty
#endif

show1 :: (Typeable a,Show a) => a -> String
show1 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x
        | otherwise= show x

data Path= Path [JSString]
--pathLength= unsafePerformIO $ newIORef 0

-- | avoid that a recursive widget with links may produce long paths. It is equivalent to tail call elimination
staticNav  x= do
  Path paths <-  getState <|> return (Path  [])
  x <*** setState (Path paths)
  

-- | template link. Besides the wlink behaviour, it loads the page from the server if there is any
--
-- the page may have been saved with `edit`
tlink :: (Show a,  Typeable a) => a -> Perch -> Widget a
tlink x v= Widget  $

    let showx= show1 x
    in do
           logged $  norender $ wlink showx v
           runCloud readPage
           return x

         <|> getPath showx

   where


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

   readPage ::  Cloud ()
   readPage =  do
        url <- local $ do
           Path  path <- getSData <|> return (Path  [])
           return $ (Prelude.foldl  (\p p' -> p <> "/" <> p') (head path) $ tail path)
        mr <- atRemote $ local $
#ifndef ghcjs_HOST_OS
                  do
                    let url' = if  url =="" then "/index" else url :: String
                    let file= "static/out.jsexe/"++ url' ++ ".html"
                    r <- liftIO $ doesFileExist file
                    if r
                      then do
                         s <- liftIO $ BS.readFile  file
                         Just <$> do
                                 r <- filterBody s          --  !> "exist"
                                 return r                   --  !> ("filtered",r)
                      else return Nothing                   --  !> "do not exist"
#else
                  return Nothing
#endif


        case mr of
          Nothing -> return ()                                -- !> "readpage return"
          Just bodycontent -> do


#ifdef ghcjs_HOST_OS
             local $ do
               liftIO $ forElems_ "body" $ this   `setHtml` bodycontent     -- !> bodycontent


             local  $do
               installHandlers                                  -- !> "installHanders"
               delData ExecEvent
               liftIO $ writeIORef execTemplate True
             return()
#else
             localIO $  return()
             localIO $  return()
             return ()
#endif

#ifdef ghcjs_HOST_OS
   installHandlers= do
         setData $ IdLine 0 "n0p0"
         EventSet hs  <- liftIO $ readIORef eventRef -- <- getSData  <|> return (EventSet [])
         mapM_ f  hs                          -- !> ("installhandlers, length=", Prelude.length hs)
         where
         f (id, _, Event event, iohandler)= do
             me <-  elemBySeq id
             case me of
               Nothing -> return()
--                                          !> ("installHandlers: not found", id) -- error $ "not found: "++ show id
               Just e ->

                  liftIO $  buildHandler e event iohandler
--                                   !> ("installHandlers adding event to ", id)
#endif

--   getPath :: Read a => TransIO a
#ifdef ghcjs_HOST_OS


   getPath segment= do
--       return () !> "GETPATH"

       Path  paths <- getSData <|> initPath
       l <- liftIO $ readIORef rReadIndexPath
       let pathelem=  paths !! l
           lpath= Prelude.length paths
       if  l >= lpath
         then   empty                                     --  !> "getPath empty"
         else do
--            setData ExecTemplate     !> "SET EXECTEMPLATE 2"
--            liftIO $ writeIORef execTemplate True
            if unpack pathelem /= segment then  empty else do
                   liftIO $ writeIORef rReadIndexPath $ l + 1
                   asynchronous
                   setData $ Path  paths
                   return x
--                                                     !> ("getPath return", x)


--            liftIO $ writeIORef rReadIndexPath $ l +1
--            r <- async . return . read $ unpack pathelem      -- !> ("pathelem=",pathelem)
--            setData $ Path  paths

--            return r

       where
       asynchronous= async $ return ()
       initPath= do
           path1 <- liftIO $ js_path  >>=   fromJSValUnchecked
           return $ Path  $ split $ JS.drop 1 path1

       split x=
         if JS.null x then [] else
          let (f,s) = JS.break (=='/') x
          in if JS.null s
               then let l1= JS.length f  in [JS.take (l1-5) f]
               else f:split (JS.drop 1 s)
#else
   getPath _= empty
#endif

#ifndef ghcjs_HOST_OS
   filterBody :: BS.ByteString -> TransIO BS.ByteString
   filterBody page= do
       setData $ ParseContext (error "parsing page") page   -- !> "filterBody"
       dropTill "<body>"                                    -- !> "token body"
       dropTill "</script>"                                 -- !> "tojen script"
       stringTill parseString (token "</body>")             -- !> "stringTill"


stringTill p end  = scan where
    scan=  parseString <> ((try end >> return mempty) <|> scan)

dropTill tok=do
    s <- parseString
    return ()
    if s == tok then return ()     -- !> ("FOUND", tok)
    else dropTill tok

token tok= do
    s <- parseString
    return ()
    if s == tok then return ()     -- !> ("FOUND", tok)
      else empty


parseString= do
--    dropSpaces
    tTakeWhile (not . isSeparator)


    where
    isSeparator c=  c == '>'
    --dropSpaces= parse $ \str ->((),BS.dropWhile isSpace str)


-- tTakeWhile :: (Char -> Bool) -> TransIO BS.ByteString
-- tTakeWhile cond= parse (span' cond)
--   where
--   span' cond s=
--      let (h,t) = BS.span cond s
--          c= BS.head t
--      in (BS.snoc h c,BS.drop 1 t)


-- parse ::  (BS.ByteString -> (b, BS.ByteString)) -> TransIO b
-- parse split= do
--     ParseContext readit str <- getSData
--                                 <|> error "parse: ParseContext not found"
--                                 :: TransIO (ParseContext BS.ByteString)

--     if BS.null str then empty else do
--        let (ret,str3) = split str
--        setData $ ParseContext readit  str3
--        return ret



#endif

-- | 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= Widget . Transient $ do
  rest <- getData `onNothing` return noHtml
  delData rest
  mx <- runView form
  f <- getData `onNothing` return noHtml
  setData $ rest <> v f
  return mx


infixr 5 <<<





-- | A parameter application with lower priority than ($) and direct function application
(<<) :: (Perch -> Perch) -> Perch -> Perch
(<<) tag content= tag $ toElem 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
(<++) :: Widget a
      -> Perch
      -> Widget a
(<++) form v= Widget . Transient $ do
              mx <-  runView  form
              addSData v
              return mx

infixr 6  ++>
infixr 6 <++
-- | Prepend formatting code to a widget
--
-- @bold << "enter name" ++> getString Nothing @
--
-- It has a infix prority: @infixr 6@ higher that '<<<' and most other operators
(++>) :: Perch -> Widget a -> Widget a
html ++> w =
  Widget . Transient $ do
      addSData html
      runView w




-- | Add attributes to the topmost tag of a widget

--  it has a fixity @infix 8@
infixl 8 <!
widget <! attribs=  Widget . Transient $ do
      rest <- getData `onNothing` return mempty
      delData rest
      mx <- runView widget
      fs <- getData `onNothing` return (mempty :: Perch)
      setData  $ rest <> (fs `attrs` attribs :: Perch)
      return mx


instance  Attributable (Widget a) where
 (!) widget atrib = Widget $ Transient $ do   -- widget <! [atrib]
              rest <- getData `onNothing` return (mempty:: Perch)
              delData rest
              mx <- runView widget
              fs <- getData `onNothing` return (mempty :: Perch)
              setData  $ do rest ; (child $ mspan "noid" fs) ! atrib :: Perch
              return mx
     where
     child render = Perch $ \e -> do
             e'    <- build render e
             jsval <- firstChild e'
             fromJSValUnchecked jsval

instance Attributable   (Perch -> Widget a) where 
    w ! attr = \p -> w p ! attr

mspan id cont=  Perch $ \e -> do
        n <- liftIO $ getName e
--        alert $ toJSString $ show n
        if  n == Just "EVENT"
           then build cont e
           else build (nelem' "event" ! atr "id" id $  cont) e
  where
  nelem' x cont= nelem x `child` cont
-- | 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

-- | Render raw view formatting. It is useful for displaying information.
wraw ::  Perch -> Widget ()
wraw x= Widget $ addSData x >> return () -- x ++> return ()

-- |  wraw synonym
rawHtml= wraw

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


-------------------------
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= input ! atr "type" t ! id   n ! atr "value"   v
        tag1= if f then tag ! atr "checked" "" else tag
       in case c of Just s -> tag1 ! atr "onclick" s; _ -> tag1


ftextarea nam text=
         textarea ! id  nam $ text


fselect nam list = select ! id nam $ list

foption  name v msel=
      let tag=  nelem "option" ! atr "value" name  `child`  v
      in if msel then tag ! atr "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


---------------------------
data EvData =  NoData | Click Int (Int, Int) | Mouse (Int, Int) | MouseOut | Key Int deriving (Show,Eq,Typeable)




resetEventData :: Widget ()
resetEventData= Widget . Transient $ do
    setData $ EventData "Onload" $ toDyn NoData
    return $ Just ()            -- !!> "RESETEVENTDATA"


getEventData ::  Widget EventData
getEventData =  Widget getSData <|> return  (EventData "Onload" $ toDyn NoData) -- (error "getEventData: event type not expected")

setEventData ::   EventData -> Widget ()
setEventData =  Widget . setData


class Typeable a => IsEvent a where
   eventName :: a -> JSString
   buildHandler :: Elem -> a  ->(EventData -> IO()) -> IO()



data BrowserEvent= OnLoad | OnUnload | OnChange | OnFocus | OnMouseMove | OnMouseOver |
 OnMouseOut | OnClick | OnDblClick | OnMouseDown | OnMouseUp | OnBlur |
 OnKeyPress | OnKeyUp | OnKeyDown deriving (Show, Typeable)

data EventData= EventData{ evName :: JSString, evData :: Dynamic} deriving (Show,Typeable)

--data OnLoad= OnLoad
instance  IsEvent  BrowserEvent  where
--  data EData _= EventData{ evName :: JSString, evData :: EvData} deriving (Show,Typeable)
  eventName e =
#ifdef ghcjs_HOST_OS
    JS.toLower $ JS.drop 2 (toJSString $ show e) -- const "load"
#else
    ""
#endif
  buildHandler elem e io =
    case e of
     OnLoad -> do
      cb <- syncCallback1 ContinueAsync (const $ setDat elem (io
                                           (EventData (eventName e) $ toDyn NoData)) )
      js_addEventListener elem (eventName e) cb

--data OnUnload = OnUnLoad
--instance  IsEvent  OnUnload   where
--  eventName= const "unload"
--  buildHandler elem e io = do
     OnUnload -> do
      cb <- syncCallback1 ContinueAsync (const $ setDat elem  $ io
                                           (EventData (eventName e) $ toDyn NoData) )
      js_addEventListener elem (eventName e) cb
--data OnChange= OnChange
--instance  IsEvent  OnChange   where
--  eventName= const "onchange"
--  buildHandler elem e io = do
     OnChange -> do
      cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
                                           (EventData (eventName e) $ toDyn NoData) )
      js_addEventListener elem (eventName e) cb

--data OnFocus= OnFocus
--instance  IsEvent  OnFocus   where
--  eventName= const "focus"
--  buildHandler elem e io = do
     OnFocus -> do
      cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
                                           (EventData (eventName e) $ toDyn NoData) )
      js_addEventListener elem (eventName e) cb

--data OnBlur= OnBlur
--instance  IsEvent  OnBlur   where
--  eventName= const "blur"
--  buildHandler elem e io = do
     OnBlur -> do
       cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
                                           (EventData (eventName e)$ toDyn NoData) )
       js_addEventListener elem (eventName e) cb

--data OnMouseMove= OnMouseMove Int Int
--instance  IsEvent  OnMouseMove  where
--  eventName= const "mousemove"
--  buildHandler elem e io= do
     OnMouseMove -> do
       cb <- syncCallback1 ContinueAsync
               (\r -> do
                 (x,y) <-fromJSValUnchecked r
                 stopPropagation r
                 setDat elem $ io $  EventData (eventName e) $  toDyn $ Mouse(x,y))
       js_addEventListener elem (eventName e) cb

--data OnMouseOver= OnMouseOver
--instance  IsEvent  OnMouseOver  where
--  eventName= const "mouseover"
--  buildHandler elem e io= do
     OnMouseOver -> do
       cb <- syncCallback1 ContinueAsync
                (\r -> do
                 (x,y) <-fromJSValUnchecked r
                 stopPropagation r
                 setDat elem $ io $ EventData (nevent e) $ toDyn $  Mouse(x,y))
       js_addEventListener elem (eventName e) cb

--data OnMouseOut= OnMouseOut
--instance  IsEvent  OnMouseOut   where
--  eventName= const "mouseout"
--  buildHandler elem e io = do
     OnMouseOut -> do
      cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
                                           (EventData (nevent e) $ toDyn $  NoData) )
      js_addEventListener elem (eventName e) cb

--data OnClick= OnClick
--
--instance  IsEvent  OnClick      where
--  eventName= const "click"
--  buildHandler elem e io= do
     OnClick -> do
      cb <- syncCallback1 ContinueAsync  $ \r -> do
          (i,x,y)<- fromJSValUnchecked r
          stopPropagation r
          setDat elem $ io $   EventData (nevent e) $ toDyn $  Click i (x,y)
      js_addEventListener elem (eventName e) cb

--data OnDblClick= OnDblClick
--instance  IsEvent  OnDblClick   where
--  eventName= const "dblclick"
--  buildHandler elem e io= do
     OnDblClick -> do
      cb <- syncCallback1 ContinueAsync  $ \r -> do
          (i,x,y)<- fromJSValUnchecked r
          stopPropagation r
          setDat elem $ io $   EventData (nevent e) $ toDyn $  Click i (x,y)
      js_addEventListener elem (eventName e) cb

--
--data OnMouseDown= OnMouseDown
--instance  IsEvent  OnMouseDown  where
--  eventName= const "mousedowm"
--  buildHandler elem e io= do
     OnMouseDown -> do
      cb <- syncCallback1 ContinueAsync $ \r -> do
          (i,x,y)<- fromJSValUnchecked r
          stopPropagation r
          setDat elem  $ io $   EventData (nevent e) $ toDyn $  Click i (x,y)
      js_addEventListener elem (eventName e) cb


--data OnMouseUp= OnMouseUp
--instance  IsEvent  OnMouseUp    where
--  eventName= const "mouseup"
--  buildHandler elem e io= do
     OnMouseUp -> do
      cb <- syncCallback1 ContinueAsync $ \r -> do
          (i,x,y)<- fromJSValUnchecked r
          stopPropagation r
          setDat elem $ io $   EventData (nevent e) $ toDyn $  Click i (x,y)
      js_addEventListener elem (eventName e) cb


--data OnKeyPress= OnKeyPress
--instance  IsEvent  OnKeyPress  where
--  eventName= const "keypress"
--  buildHandler elem e io = do
     OnKeyPress -> do
      cb <- syncCallback1 ContinueAsync $ \r -> do
            i <-  fromJSValUnchecked r
            stopPropagation r
            setDat elem  $ io $  EventData (nevent e) $ toDyn $  Key i
      js_addEventListener elem (eventName e) cb

--data OnKeyUp= OnKeyUp
--instance  IsEvent OnKeyUp    where
--  eventName= const "keyup"
--  buildHandler elem e io = do
     OnKeyUp -> do
      cb <- syncCallback1 ContinueAsync $ \r -> do
            i <-  fromJSValUnchecked r
            stopPropagation r
            setDat elem  $ io $ EventData (nevent e) $ toDyn $  Key i
      js_addEventListener elem (eventName e) cb

--data OnKeyDown= OnKeyDown
--instance  IsEvent  OnKeyDown   where
--  eventName= const "keydown"
--  buildHandler elem e io = do
     OnKeyDown -> do
      cb <- syncCallback1 ContinueAsync $ \r -> do
            i <-  fromJSValUnchecked r
            stopPropagation r
            setDat elem $ io $  EventData (nevent e) $ toDyn $ Key i
      js_addEventListener elem (eventName e) cb

   where


   nevent =  eventName

   setDat ::  Elem -> IO()  -> IO ()
   setDat elem action  = do
         action            -- !!> "begin action"
         return ()            -- !!> "end action"


addSData :: (MonadState EventF m,Typeable a ,Monoid a) => a -> m ()
addSData y=  do
  x <- getData `onNothing` return  mempty
  setData (x <> y)

-- stores the identifier of the element to append new rendering
-- must be an identifier instead of an DOM element since links may reload the whole page

data IdLine= IdLine Int JSString  -- deriving(Read,Show)
data ExecMode= ExecEvent   deriving (Eq, Read, Show)

execTemplate= unsafePerformIO $ newIORef False

-- first identifier for an applicative widget expression
-- needed for applictives in the widget monad that are executed differently than in the TransIO monad
-- newtype IDNUM = IDNUM Int deriving Show

data Event= forall ev.IsEvent ev => Event ev

data EventSet=  EventSet [(JSString, Int, Event, ( EventData -> IO ()))] deriving Typeable

{-# NOINLINE eventRef #-}
eventRef= unsafePerformIO $ newIORef $ EventSet []

-- | triggers the event that happens in a widget. The effects are the following:
--
-- 1)The event reexecutes the monadic sentence where the widget is, (with no re-rendering)
--
-- 2) with the result of this reevaluaution of 1), the rest of the monadic computation is executed
--
-- 3) update the DOM tree with the rendering generated by the reevaluation of 2).
--
-- As usual, If one step of the monadic computation return `empty` (`stop`), the reevaluation finish
-- So the effect of an event can be restricted as much as you may need.
--
-- The part of the monadic expression that is before the event is not evaluated and his rendering is untouched.
-- (but, at any moment, you can choose the element to be updated in the page using `at`)

-- to store the identifier number of the form elements to be set for that event



raiseEvent ::  IsEvent event  => Widget a -> event -> Widget a
#ifdef ghcjs_HOST_OS
raiseEvent w event = Widget . Transient $ do
       Alternative cont <- getData  `onNothing` (Alternative <$> get)
       let iohandler :: EventData -> IO ()
           iohandler eventdata =do
                runStateT (setData eventdata >> runCont' cont) cont  --  !> "runCont INIT"
                return ()                                            --  !> "runCont finished"

       id <- genNewId
       let id'= JS.takeWhile (/='p') id
       addEventList id' event iohandler
       template <-liftIO $ readIORef execTemplate 
       if not template then runView $ addEvent  id event iohandler <<< w  
       else do
          me <- elemBySeq id'                                          --  !> ("adding event to",  id')
          case me of

            Nothing -> runView $ addEvent  id event iohandler <<< w      !> "do not exist, creating elem"
            Just e -> do
              mr <- getData                                              !> "exist adding event to current element"
              when (mr /= Just ExecEvent) $ liftIO (buildHandler e event iohandler)
              r <- runView w
              delData noHtml
              return r

   where
   -- to restore event handlers when a new template is loaded
   addEventList a b c= do
     IdLine level _ <- getData `onNothing` error "IdLine not set"
     liftIO $ atomicModifyIORef eventRef $ \(EventSet mlist) ->
       let (cut,rest)= Prelude.span (\(x,l,_,_) -> x < a) mlist
           rest'= Prelude.takeWhile(\(_,l,_,_) -> l <= level) $ tail1 rest
       in (EventSet $ cut ++ (a,level, Event b, c):rest' ,())
   tail1 []= []
   tail1 xs= tail xs


   runCont' cont= do
     setData ExecEvent                              --  !> "REPEAT: SET EXECEVENT"

     liftIO $ writeIORef execTemplate False
     mr <- runClosure cont
     return ()
     case mr of
         Nothing -> return Nothing
         Just r -> runContinuation cont r     -- !> "continue"

       -- create an element and add any event handler to it.
   addEvent :: IsEvent a => JSString ->  a -> (EventData -> IO()) -> Perch -> Perch
   addEvent id event iohandler be= Perch $ \e -> do
            e' <- build (mspan id be) e
            buildHandler e' event iohandler
            return e




#else
raiseEvent w _ = w
#endif

#ifdef ghcjs_HOST_OS
foreign import javascript unsafe
  "$1.stopPropagation()"
  stopPropagation :: JSVal -> IO ()
#else
stopPropagation= undefined
#endif



-- | A shorter synonym for `raiseEvent`
fire ::   IsEvent event => Widget a -> event -> Widget a
fire = raiseEvent

-- | A shorter and smoother synonym for `raiseEvent`
wake ::   IsEvent event => Widget a -> event -> Widget a
wake = 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 :: IsEvent event => Perch -> event -> Widget EventData
pass v event= do
        resetEventData
        wraw v `wake` event
        e@(EventData typ _) <- getEventData
        guard (eventName event== typ)

        return e


-- | 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
     (mx, s) <- runTransient . norender $ runWidget' action e
     return mx


runWidget' :: Widget b -> Elem   -> Widget b
runWidget' action e  = Widget $ Transient $ do

      mx <- runView action                          -- !> "runVidget'"
      render <- getData `onNothing` (return  noHtml)

      liftIO $ build render e

      delData render
      return mx


-- | add a header in the <header> tag
addHeader :: Perch -> IO ()
#ifdef ghcjs_HOST_OS
addHeader format= do
    head <- getHead
    build format head
    return ()
#else
addHeader _ = return ()
#endif


-- | run the widget as the body of the HTML. It adds the rendering to the body of the document.
--
-- Use only for pure client-side applications, like the ones of <http://http://tryplayg.herokuapp.com>
runBody :: Widget a -> IO (Maybe a)
runBody w= do
  body <- getBody
  runWidget  w body


newtype AlternativeBranch= Alternative EventF deriving Typeable

-- | executes the computation and  add the effect of "hanging" the generated rendering from the one generated by the
-- previous `render` sentence, or from the body of the document, if there isn't any. If an event happens within
-- the `render` parameter, it deletes the rendering of all subsequent ones.
-- so that the sucessive sequence of `render` in the code will reconstruct them again.
-- However the rendering of elements combined with `<|>` or `<>` or `<*>`  are independent.
-- This allows for full dynamic and composable client-side Web apps.
render :: Widget a -> TransIO a
#ifdef ghcjs_HOST_OS
render  mx = Transient $ do
       isTemplate <- liftIO $ readIORef execTemplate !> "RENDER"
       idline1@(IdLine level id1')
             <- getData `onNothing` do
                    id1 <- genNewId                                -- !> "ONNOTHING"
                    -- if is being edited or not
                    top <-  liftIO  $ (elemById "edited") `onNothing` getBody
                    when (not isTemplate) $ do
                         liftIO $ build (span ! id id1 $ noHtml) top
                         return ()
                    return $ IdLine 0 id1



       ma <- getData
       mw <- getData 
       
       id1 <- if (isJust (ma :: Maybe AlternativeBranch) || mw == Just WasParallel )   !> (mw)
               then do
                 id3 <- do
                     id3 <- genNewId !> "ALTERNATIVE"
                     -- create id3 hanging from id1 parent
                     if (not isTemplate) then do
                        liftIO $ withElem id1' $ build $ this `goParent` (span ! atr "ALTERNATIVE" "" ! id id3 $ noHtml)
                        return id3
                      else do
                            -- template look for real id3
                            me <- liftIO $   elemById id1' >>= \x ->
                                              case x of
                                                 Nothing -> return Nothing
                                                 Just x  -> nextSibling x
                            case me of
                              Nothing -> return id3 -- should not happen
                              Just e  -> attribute e "id" >>= return . fromJust

                 setData (IdLine level id3)                              !> ("setDataAL1",id3)
                 delData $ Alternative  undefined                                   !> ("alternative, creating", id3)
                 return id3
               else setData idline1 >> return id1'

       id2 <-  genNewId
       n <- gets mfSequence
      --  setData $ IDNUM n




--       r <- runWidgetId' (mx' id1 id2 <++ (span ! id id2 $ noHtml)) id1
       r <-runTrans $ norender mx <***

        (Transient $ do

           meid2 <- elemBySeq id2                                    !> ("checking",id1,id2)

           case meid2 of
            Nothing -> return ()
            Just eid2 -> do
               -- we are in a template. Look for the true id2 in it
               id2' <- attribute eid2 "id" >>= return . fromJust
--               let n= read (tail $ JS.unpack  $ JS.dropWhile (/= 'p') id2') + 1
--               liftIO $ writeIORef rprefix n   !>  ("N",n)
               (setData (IdLine (level +1) id2'))                    !>  ("set IdLine",id2')

           execmode <- getData

           case execmode of
             Just ExecEvent -> do
                -- an event has happened. Clean previous rendering
                when (isJust meid2) $ liftIO $ do
                        deleteSiblings $ fromJust meid2                  !> "EVENT"
                        clearChildren $ fromJust meid2
                delData ExecEvent

                delData noHtml
                return ()

             _ -> do

                 return ()                                                !> ("EXECTEMPLATE", isTemplate)
                 if isTemplate then delData noHtml  else do
                     render <- getData `onNothing` (return  noHtml)      -- !> "TEMPLATE"

                     eid1 <- liftIO $ elemById id1 `onNothing`  error ("not found: " ++ show id1)

                     liftIO $ build (render <> (span ! id id2 $ noHtml)) eid1
--                     setData (IdLine (level +1) id2 )                     !> ("set2 idLine", id2)
                     delData render
           return $ Just ())
       if(isJust r)
         then  delData (Alternative undefined) >> setData (IdLine (level +1) id2 )    -- !> ("setDataAl",id2)
         else do 
               cont <- get
               setData (Alternative cont)  !> "SETDATA ALTERNATIVE"
       return r


#else
render (Widget x)= empty
#endif


    --   st@(EventF eff e x (fs) d n  r applic  ch rc bs)  <- get

    --   let cont=  EventF eff e x fs  d n  r applic  ch rc bs
    --   put cont
    --   liftIO $ print ("length1",Prelude.length fs)


-- | use this instead of `Transient.Base.option` when runing in the browser
option :: (Typeable b, Show b) =>  b -> String -> Widget b
option x v=  wlink x (toElem v) <++ " "


--foreign import javascript unsafe "document.body" getBody :: IO Elem



data UpdateMethod= Append | Prepend | Insert deriving Show



-- | Run the widget as the content of the element with the given path identifier. The content can
-- be appended, prepended to the previous content or it can erase the previous content depending on the
-- update method.
at ::  JSString -> UpdateMethod -> Widget a -> Widget  a
at id method w= setAt id method <<< do
  original@(IdLine level i) <- Widget $ getState <|> error "IdLine not defined"
  setState $ IdLine level  $ JS.tail id -- "n0p0"
  w  `with` setState original
  where
  with    (Widget (Transient x)) (Widget (Transient y))=
    Widget . Transient $ do
           mx <- x
           y
           return mx

setAt :: JSString -> UpdateMethod -> Perch  -> Perch
setAt id method render  = liftIO $   case method of
     Insert -> do
             forElems_ id $ clear >> render
             return ()
     Append -> do
             forElems_ id render
             return ()
     Prepend -> do
            forElems_ id $ Perch $ \e -> do
             jsval <- getChildren e
             es <- fromJSValUncheckedListOf jsval
             case es of
                       [] -> build render e >> return e
                       e':es -> do
                             span <- newElem "span"
                             addChildBefore span e e'
                             build render span
                             return e

at' ::  JSString -> UpdateMethod -> Cloud a -> Cloud  a
at'  id method w= setAt id method `insert` w
    where
    insert v comp=   Cloud . Transient $ do
          rest <- getData `onNothing` return noHtml
          delData rest
          mx <-  runTrans  $ runCloud comp
          f <- getData `onNothing` return noHtml
          setData $ rest <> v f
          return mx



#ifdef ghcjs_HOST_OS

foreign import javascript unsafe  "$1[$2].toString()" getProp :: Elem -> JSString -> IO JSString



foreign import javascript unsafe  "$1[$2] = $3" setProp :: Elem -> JSString -> JSString -> IO ()

foreign import javascript unsafe  "alert($1)" js_alert ::  JSString -> IO ()

alert ::  (Show a,MonadIO m) => a -> m ()
alert= liftIO . js_alert . pack . show 

foreign import javascript unsafe  "document.getElementById($1)" elemByIdDOM
      :: JSString -> IO JSVal

foreign import javascript unsafe  "document.getElementById($1).querySelector(\"[id^='\"+$2+\"']\")"
        elemBySeqDOM
        :: JSString -> JSString -> IO JSVal

foreign import javascript unsafe  "$1.value"   getValueDOM :: Elem -> IO JSVal
foreign import javascript unsafe  "$1.tagName" getNameDOM :: Elem -> IO JSVal

foreign import javascript unsafe "$1.getAttribute($2)"
          attributeDOM
          :: Elem -> JSString -> IO JSVal
#else
unpack= undefined
getProp :: Elem -> JSString -> IO JSString
getProp = error "getProp: undefined in server"
setProp :: Elem -> JSString -> JSString -> IO ()
setProp = error "setProp: undefined in server"
alert ::  (Show a,MonadIO m) => a -> m ()
alert= liftIO . print
data Callback a= Callback a
data ContinueAsync=ContinueAsync
syncCallback1= undefined
fromJSValUnchecked= undefined
fromJSValUncheckedListOf= undefined
#endif

#ifdef ghcjs_HOST_OS
foreign import javascript unsafe
  "$1.addEventListener($2, $3,false);"
  js_addEventListener :: Elem -> JSString -> Callback (JSVal -> IO ()) -> IO ()
#else
js_addEventListener= undefined
#endif


#ifdef ghcjs_HOST_OS
foreign import javascript unsafe "document.head" getHead :: IO Elem
#else
getHead= undefined
#endif

#ifdef ghcjs_HOST_OS
foreign import javascript unsafe "$1.childNodes" getChildren :: Elem -> IO JSVal
foreign import javascript unsafe "$1.firstChild" firstChild :: Elem -> IO JSVal
foreign import javascript unsafe "$2.insertBefore($1, $3)" addChildBefore :: Elem -> Elem -> Elem -> IO()

foreign import javascript unsafe
   "while ($1.nextSibling != null) {$1.parentNode.removeChild($1.nextSibling)};"
  deleteSiblings :: Elem -> IO ()

foreign import javascript unsafe
   "$1.nextSibling"
   js_nextSibling :: Elem  -> IO JSVal

nextSibling e= js_nextSibling e >>= fromJSVal

#else

type JSVal = ()
getChildren :: Elem -> IO JSVal
getChildren= undefined
firstChild :: Elem -> IO JSVal
firstChild= undefined
addChildBefore :: Elem -> Elem -> Elem -> IO()
addChildBefore= undefined
#endif


---------------------------- TEMPLATES & NAVIGATION ---------------

editW ::   Cloud String
#ifdef ghcjs_HOST_OS
editW = onBrowser $ loggedc $ do

      local $ do
         liftIO $ forElems_ "body"  $ this `child` do
                       div ! id  "panel" $ noHtml
                       div ! id "edit" $ div ! id "edited" $
                        center $ font ! atr "size" "2" ! atr "color" "red" $ p $ do
                           "Edit this template" <> br
                           "Add content, styles, layout" <> br
                           "Navigate the links and save the edition for each link" <> br
                           "Except this header, don't delete anything unless you know what you do" <> br
                           "since the template has been generated by your code" <> br
         installnicedit
         liftIO $threadDelay 1000000


--         edit <- liftIO $ elemById "edit" >>= return . fromJust
--         setState $ IdLine 0 "edit"



         react edit1  (return ()) :: TransIO ()

      return "editw"
      where
      font ch= nelem "font" `child` ch

      edit1 :: (() -> IO ()) -> IO ()
      edit1  f= do
         Callback cb <- syncCallback1 ContinueAsync $  \ _ -> f()
         js_edit  cb


      installnicedit= do
         liftIO   $ addHeader $ script ! id "nic"
                                       ! atr "type" "text/javascript"
                                       ! src "http://js.nicedit.com/nicEdit-latest.js"
                                       $ noHtml

--manageNavigation= do
--    Callback cb <- syncCallback1 ContinueAsync nav
--    onpopstate cb
--    where
--    nav e= do
--      location <- fromJSValUnchecked  e
--      alert location
----- pushstate

foreign import javascript unsafe
  "window.onpopstate = function(event) { $1(document.location);}"
  onpopstate :: JSVal -> IO ()

foreign import javascript unsafe  "window.history.pushState($1,$2,$3)"
    pushState :: JSString -> JSString  -> JSString -> IO ()



foreign import javascript unsafe  "window.history.replaceState($1,$2,$3)"
    replaceState :: JSString -> JSString  -> JSString -> IO ()

foreign import javascript unsafe "document.getElementById('edit').innerHTML"
    js_getPage :: IO JSVal
foreign import javascript safe  "window.location.pathname"                js_path    :: IO JSVal

foreign import javascript unsafe
          "var myNicEditor = new nicEditor({fullPanel : true, onSave : $1});myNicEditor.addInstance('edit');myNicEditor.setPanel('panel');"

          js_edit    ::  JSVal -> IO ()

--          "var myNicEditor = new nicEditor({fullPanel : true, onSave : function(content, id, instance) {myNicEditor.removeInstance('edit');myNicEditor.removePanel('panel');}});myNicEditor.addInstance('edit');myNicEditor.setPanel('panel');"

#else
--manageNavigation :: IO ()
--manageNavigation = undefined
pushState _ _ _= empty
replaceState _ _ _= empty
editW = onBrowser $ local empty                             -- !> "editW"
js_getPage=  empty
js_path=  empty
#endif

-- | edit and save the rendering of the widgets.
--
-- The edited content may be saved to a file with th current route by the save option of the editor.
-- `tlink`  will load this page. Also when this route is requested, the server will return this page.
edit w=  do
  b <- localIO $ elemById "edited" >>= return . isJust

  if  b then  do
              local $ do -- modify (\s -> s{mfSequence=2})  -- *******
                         -- liftIO $ writeIORef rprefix 2
--                         setData ExecTemplate    !> "SET EXECTEMPLATE 1"
                         liftIO $ writeIORef execTemplate True
--                         setData $ IdLine 0 "n0p0"
--              local addPrefix
              w
        else do
          edit' <|>  w
  where
  edit' = do

    editW

    page <-  localIO $   js_getPage >>= fromJSValUnchecked  :: Cloud String
    url  <- localIO $  js_path  >>=   fromJSValUnchecked    :: Cloud String

    atRemote $ localIO $  do
#ifdef ghcjs_HOST_OS
        return ()
#else
        let url' = if  url =="/" then "/index.html" else url :: String
        let page'= fullpage page
--        return ()                                       !>  ("----->",url')
        write  ("static/out.jsexe"++ url')  page'

--        return () !> "WRITTTEN"
    empty

   where
   write filename page=
     writeFile filename page
         `catch` (\e -> when ( isDoesNotExistError e) $  do
              let dir= take (1+(last $ elemIndices '/' filename)) filename
              return ()                                      -- !> ("create",dir)
              createDirectoryIfMissing True dir
              write filename page)

   fullpage page=
    "<!DOCTYPE html><html><head><script language=\"javascript\" src=\"rts.js\"></script><script language=\"javascript\" src=\"lib.js\"></script><script language=\"javascript\" src=\"out.js\"></script></head><body></body><script language=\"javascript\" src=\"runmain.js\" defer></script>"
      ++ page ++ "</body></html>"

#endif