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