summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlbertoCorona <>2017-03-20 15:30:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-03-20 15:30:00 (GMT)
commitcbe24d5a1214b5c1bdacd6dda7f0d4588c13bdc2 (patch)
tree4d761c9c570e6e8eaad3e3ac25346948f0302756
version 0.4.30.4.3
-rw-r--r--LICENSE19
-rw-r--r--README.md19
-rw-r--r--Setup.lhs6
-rw-r--r--axiom.cabal48
-rw-r--r--src/GHCJS/HPlay/Cell.hs280
-rw-r--r--src/GHCJS/HPlay/View.hs1899
6 files changed, 2271 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..4a8bfa9
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,19 @@
+Copyright © 2008-2016 Alberto G. Corona <https://github.com/agocorona>
+ 2016 Arthur S. Fayzrakhmanov <https://github.com/geraldus>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..31817a9
--- /dev/null
+++ b/README.md
@@ -0,0 +1,19 @@
+[![Hackage](https://img.shields.io/hackage/v/ghcjs-hplay.svg)](http://hackage.haskell.org/package/ghcjs-hplay)
+[![Stackage LTS](http://stackage.org/package/ghcjs-hplay/badge/lts)](http://stackage.org/lts/package/ghcjs-hplay)
+[![Stackage Nightly](http://stackage.org/package/ghcjs-hplay/badge/nightly)](http://stackage.org/nightly/package/ghcjs-hplay)
+[![Build Status](https://travis-ci.org/agocorona/ghcjs-hplay.png?branch=master)](https://travis-ci.org/agocorona/ghcjs-hplay)
+
+ghcjs-hplay
+==========
+
+![](https://raw.githubusercontent.com/agocorona/ghcjs-hplay/master/axiom.png)
+
+[![Gitter](https://badges.gitter.im/theam/haskell-do.svg)](https://gitter.im/Transient-Transient-Universe-HPlay/Lobby?utm_source=share-link&utm_medium=link&utm_campaign=share-link)
+
+This package [hplayground](https://github.com/agocorona/hplayground) is compilable with [GHCJS](https://github.com/ghcjs), the Haskell-to-JavaScript compiler. It is also the Web user interface of [Transient](https://github.com/agocorona/transient).
+
+Unlike hplayground, ghcjs-hplay has full integration with Transient and can run widgets that run code on the server, the client or both.
+
+To see how it integrates with Transient and how to create client-server applications, see the web paragraphs of the [transient tutorial](https://github.com/agocorona/transient/wiki/Transient-tutorial).
+
+To see how to create client side applications and widgets (not yet with full server code integration), look for the [hplayground](https://github.com/agocorona/hplayground) package.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
index 0000000..a630405
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,6 @@
+#!/usr/bin/runhaskell
+> module Main where
+> import Distribution.Simple
+> main :: IO ()
+> main = defaultMain
+
diff --git a/axiom.cabal b/axiom.cabal
new file mode 100644
index 0000000..559d0b6
--- /dev/null
+++ b/axiom.cabal
@@ -0,0 +1,48 @@
+name: axiom
+
+version: 0.4.3
+cabal-version: >=1.10
+build-type: Simple
+
+license: MIT
+license-file: LICENSE
+author: Alberto Gómez Corona
+maintainer: agocorona@gmail.com
+
+homepage: https://github.com/transient-haskell/axiom
+bug-reports: https://github.com/transient-haskell/axiom/issues
+synopsis: Web EDSL running over transient running in browsers and server nodes
+description: Client-and Server-side Haskell framework that compiles to javascript with the GHCJS compiler and run over Transient. See homepage
+category: Web
+cabal-version: >=1.10
+build-type: Simple
+stability: experimental
+
+data-dir: ""
+extra-source-files: README.md
+
+source-repository head
+ type: git
+ location: http://github.com/transient-haskell/axiom
+
+library
+ build-depends: base > 4.0 && <6.0
+ , transformers -any
+ , containers -any
+ , transient >= 0.5.1
+ , transient-universe >= 0.4.1
+
+ , mtl -any
+ , ghcjs-perch >= 0.3.3
+
+ if impl(ghcjs >=0.1)
+ build-depends: ghcjs-base -any
+ else
+ build-depends: bytestring, directory
+
+ exposed-modules: GHCJS.HPlay.View
+ GHCJS.HPlay.Cell
+ exposed: True
+ buildable: True
+ default-language: Haskell2010
+ hs-source-dirs: src .
diff --git a/src/GHCJS/HPlay/Cell.hs b/src/GHCJS/HPlay/Cell.hs
new file mode 100644
index 0000000..0a9068c
--- /dev/null
+++ b/src/GHCJS/HPlay/Cell.hs
@@ -0,0 +1,280 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Cell
+-- Copyright :
+-- License : MIT
+--
+-- Maintainer : agocorona@gmail.com
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, CPP, ScopedTypeVariables #-}
+module GHCJS.HPlay.Cell(Cell(..),boxCell,bcell,(.=),get,mkscell,scell, gcell, calc) where
+import Transient.Base
+import Transient.Move
+import Transient.Internals (runTransState)
+import Transient.Backtrack
+import GHCJS.HPlay.View
+import Data.Typeable
+import Unsafe.Coerce
+import qualified Data.Map as M hiding ((!))
+import System.IO.Unsafe
+
+import Control.Monad.IO.Class
+import Control.Monad
+import Data.Maybe
+import Control.Exception
+import Data.List
+import GHCJS.Perch
+import Control.Exception
+
+#ifdef ghcjs_HOST_OS
+
+import Data.JSString hiding (empty)
+
+#else
+
+type JSString = String
+
+#endif
+
+data Cell a = Cell { mk :: Maybe a -> Widget a
+ , setter :: a -> IO ()
+ , getter :: IO (Maybe a)}
+
+--instance Functor Cell where
+-- fmap f cell = cell{setter= \c x -> c .= f x, getter = \cell -> get cell >>= return . f}
+
+-- | creates (but not instantiates) an input box that has a setter and a getter. To instantiate it us his method `mk`
+bcell :: (Show a, Read a, Typeable a) =>TransIO (Cell a)
+bcell= genNewId >>= return . boxCell
+
+-- | creates (but not instantiates) a input box cell with polimorphic value, identified by a string.
+-- the cell has a getter and a setter. To instantiate it us his method `mk`
+boxCell :: (Show a, Read a, Typeable a) => ElemID -> Cell a
+boxCell id = Cell{ mk= \mv -> getParam (Just id) "text" mv
+ , setter= \x -> do
+ me <- elemById id
+ case me of
+ Just e -> setProp e "value" (toJSString $ show1 x)
+ Nothing -> return ()
+
+ , getter= getID id}
+
+getID id = withElem id $ \e -> do
+ ms <- getValue e
+ case ms of
+ Nothing -> return Nothing
+ Just s -> return $ read1 s
+ where
+ read1 s=
+ if typeOf(typeIO getID) /= typestring
+ then case readsPrec 0 s of
+ [(v,_)] -> v `seq` Just v
+ _ -> Nothing
+ else Just $ unsafeCoerce s
+
+typeIO :: (ElemID -> IO (Maybe a)) -> a
+typeIO = undefined
+
+typestring= typeOf (undefined :: String)
+
+show1 x= if typeOf x== typestring
+ then unsafeCoerce x
+ else show x
+
+instance Attributable (Cell a) where
+ (Cell mk setter getter) ! atr = Cell (\ma -> mk ma ! atr) setter getter
+
+
+
+-- | Cell assignment using the cell setter
+(.=) :: MonadIO m => Cell a -> a -> m ()
+(.=) cell x = liftIO $ (setter cell ) x
+
+get cell = Transient $ liftIO (getter cell)
+
+
+---- | a cell value assigned to other cell
+--(..=) :: Cell a -> Cell a -> Widget ()
+--(..=) cell cell'= get cell' >>= (cell .= )
+
+infixr 0 .= -- , ..=
+
+-- experimental: to permit cell arithmetic
+
+--instance Num a => Num (Cell a) where
+-- c + c'= Cell undefined undefined $
+-- do r1 <- getter c
+-- r2 <- getter c'
+-- return $ liftA2 (+) r1 r2
+--
+-- c * c'= Cell undefined undefined $
+-- do r1 <- getter c
+-- r2 <- getter c'
+-- return $ liftA2 (+) r1 r2
+--
+-- abs c= c{getter= getter c >>= return . fmap abs}
+--
+-- signum c= c{getter= getter c >>= return . fmap signum}
+--
+-- fromInteger i= Cell undefined undefined . return $ Just $ fromInteger i
+
+
+-- * Spradsheet type cells
+-- Implement a solver that allows circular dependencies . See
+-- > http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
+
+-- The recursive Cell calculation DSL BELOW ------
+
+
+-- | within a `mkscell` formula, `gcell` get the the value of another cell using his name.
+--
+-- see http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
+gcell :: JSString -> Widget Double
+gcell n= Widget $ do
+ Vars vars <- getSData <|> return(Vars M.empty ) -- liftIO $ readIORef rvars
+ case M.lookup n vars of
+ Just exp -> do inc n exp; exp
+ Nothing -> error $ "cell not found: " ++ show n
+ where
+ inc n exp= do
+ Tries tries maxtries<- getSData <|> do
+ Exprs exprs <- getSData
+ return . Tries 0 $ 3 * (M.size $ exprs)
+ if tries <= maxtries
+ then setData $ Tries (tries+1) maxtries
+ else back Loop
+
+data Loop= Loop deriving (Show,Typeable)
+
+instance Exception Loop
+
+-- a parameter is a function of all of the rest
+type Expr a = TransIO a
+
+data Tries= Tries Int Int deriving Typeable
+--rtries= unsafePerformIO $ newIORef $ (0::Int)
+--maxtries= 3 * (M.size $ unsafePerformIO $ readIORef rexprs)
+
+newtype Exprs= Exprs (M.Map JSString (Expr Double))
+--rexprs :: IORef (M.Map JSString (Expr Double))
+--rexprs= unsafePerformIO $ newIORef M.empty -- initial expressions
+
+newtype Vars= Vars (M.Map JSString (Expr Double))
+--rvars :: IORef (M.Map JSString (Expr Double))
+--rvars= unsafePerformIO $ newIORef M.empty -- expressions actually used for each cell.
+ -- initially, A mix of reexprs and rmodified
+ -- and also contains the result of calculation
+
+newtype Modified= Modified (M.Map JSString (Expr Double)) deriving Typeable
+--rmodified :: IORef (M.Map JSString (Expr Double))
+--rmodified= unsafePerformIO $ newIORef M.empty -- cells modified by the user or by the loop detection mechanism
+
+
+-- | make a spreadsheet cell. a spreadsheet cell is an input-output box that takes input values from
+-- the user, has an expression associated and display the result value after executing `calc`
+--
+-- see http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
+mkscell :: JSString -> Maybe Double -> Expr Double -> Widget Double
+mkscell name val expr= mk (scell name expr) val
+
+--both mx= local $ runCloud mx <** runCloud ( atRemote (clustered $ mx >> empty :: Cloud()))
+
+
+scell :: JSString -> Expr Double -> Cell Double
+scell id expr= Cell{ mk= \mv -> Widget $ do
+ Exprs exprs <- getSData <|> return (Exprs M.empty) -- readIORef rexprs
+ setData . Exprs $ M.insert id expr exprs
+
+ r <- norender $ getParam (Just id) "text" mv `fire` OnKeyUp
+
+ Modified mod <- getSData <|> return(Modified M.empty)
+ setData . Modified $ M.insert id (return r) mod
+ return r
+
+ , setter= \x -> withElem id $ \e -> setProp e "value" (toJSString $ show1 x)
+
+ , getter= getID id}
+
+
+
+
+
+-- | executes the spreadsheet adjusting the vaules of the cells created with `mkscell` and solving loops
+--
+-- see http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
+calc :: Widget ()
+calc= Widget $ do
+ st <- getCont
+ return() `onBack` (\(e::Loop) -> do removeVar st e; forward Loop )
+
+ Modified nvs <- getSData <|> error "no modified" -- liftIO $ readIORef rmodified
+
+ when (not $ M.null nvs) $ do
+ values <- calc1
+ mapM_ (\(n,v) -> boxCell n .= v) values
+
+-- liftIO $ writeIORef rmodified M.empty
+
+ where
+ run' st x= runTransState st x >> return ()
+
+
+ calc1 :: TransIO [(JSString,Double)]
+ calc1= do
+ setData $ Tries 0 -- liftIO $ writeIORef rtries 0
+ Exprs cells <- getSData <|> error "no exprs" -- liftIO $ readIORef rexprs
+ Modified nvs <- getSData <|> error "mo modified2" -- liftIO $ readIORef rmodified
+ setData . Vars $ M.union nvs cells
+ solve
+
+--solve :: M.Map JSString (Widget a) -> Widget (M.Map JSString a)
+solve :: TransIO [(JSString,Double)]
+solve = do
+ Vars vars <- getSData <|> error "no vars" -- liftIO $ readIORef rvars
+ mapM (solve1 vars) $ M.toList vars
+ where
+
+ solve1 vars (k,f)= do
+ x <- f
+ setData . Vars $ M.insert k (return x) vars
+ return (k,x) :: TransIO (JSString,Double)
+
+
+
+-- removeVar :: EventF -> SomeException -> IO () -- [(JSString,Double)]
+removeVar st = \(e:: Loop) -> do -- runCloud $ both $ localIO $ do
+ Modified nvs <- getSData <|> error "no modified 3"-- readIORef rmodified
+ Exprs exprs <- getSData <|> error " no Exprs2" --readIORef rexprs
+
+ case M.keys exprs \\ M.keys nvs of
+ [] -> error "non solvable circularity in cell dependencies"
+ (name:_) -> do
+ mv <- liftIO $ getID name
+
+ case mv of
+ Nothing -> return ()
+ Just v -> do
+ setData . Modified $ M.insert name ( return v) nvs
+ return () -- !> ("using",v)
+ norender calc -- runTransState st (norender calc)
+ return ()
+
+ -- http://blog.sigfpe.com/2006/11/from-l-theorem-to-spreadsheet.html
+ -- loeb :: Functor f => f (t -> a) -> f a
+ -- loeb x = fmap (\a -> a (loeb x)) x
+ -- loeb :: [([a]-> a)] -> [a]
+ -- loeb x= map (\f -> f (loeb x)) x
+
+--loeb :: [([a] -> IO a)] -> IO [a]
+--loeb x= mapM (\f -> loeb x >>= f) x -- fail does not terminate
+
+
+
+--loeb x= map (\f -> f (loeb x)) x
+
+
diff --git a/src/GHCJS/HPlay/View.hs b/src/GHCJS/HPlay/View.hs
new file mode 100644
index 0000000..24c621c
--- /dev/null
+++ b/src/GHCJS/HPlay/View.hs
@@ -0,0 +1,1899 @@
+{-# 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
+ , runWidget'
+ , addSData
+ -- * Widget Combinators and Modifiers
+ , (<<)
+ , (<<<)
+ , (<!)
+ , (<++)
+ , (++>)
+ , validate
+ , wcallback
+ -- * 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
+ , 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
+ , FormInput(..)
+ , 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
+
+) where
+
+
+import Transient.Internals hiding (input, option, parent, try)
+import Transient.Logged
+import Transient.Move.Utils
+import qualified Prelude(id,span,div)
+#ifndef ghcjs_HOST_OS
+import Transient.Move(ParseContext(..))
+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)
+import GHCJS.Types
+import Transient.Move hiding (pack)
+
+import Data.JSString as JS hiding (empty, center,span, strip,foldr,head,tail)
+#else
+import GHCJS.Perch hiding (JSVal, JsEvent (..), eventName,
+ option,head)
+import Transient.Move hiding (JSString, pack)
+#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
+ re <- elemBySeqDOM id1 $ JS.takeWhile (/='p') id
+ 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 Alternative Widget where
+-- empty= Widget empty
+-- (Widget x) <|> (Widget y)= Widget $ Transient $ do
+-- rx <- runTrans x
+-- ry <- runTrans y
+-- return $ rx <|> ry
+
+
+instance Applicative Widget where
+ pure= return
+
+ Widget (Transient x) <*> Widget (Transient y) = Widget .Transient $ do
+ mn <- getData
+ mrepeat <-getData
+
+ when (isJust mn && mrepeat == Just ExecEvent) $ do
+ let IDNUM n = fromJust mn in modify $ \s -> s{mfSequence= n}
+ -- !> ("SET IDMUN", n)
+ delData $ IDNUM 0
+ mx <- x
+ my <- y
+ return $ mx <*> my
+
+
+
+instance Monoid a => Monoid (Widget a) where
+ mempty= return mempty
+ mappend x y= (<>) <$> x <*> y
+
+instance AdditionalOperators Widget where
+
+ Widget (Transient x) <** Widget (Transient y)=
+ Widget . Transient $ do
+ mn <- getData
+ mrepeat <-getData
+ when (isJust mn && mrepeat == Just ExecEvent) $ do
+ let IDNUM n = fromJust mn in modify $ \s -> s{mfSequence= n}
+-- !> ("SET IDMUN", n)
+ delData $ IDNUM 0
+ 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
+
+
+
+
+
+
+{-
+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)
+ => JSString -> StateIO (ParamResult Perch a)
+getParam1 par = do
+ isTemplate <- liftIO $ readIORef execTemplate
+ if isTemplate then return NoParam else do
+ me <- 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 case reads $ str of -- -- !!> ("read " ++ str) of
+ [(x,"")] -> return $ Validated x -- !!> ("readsprec" ++ show x)
+ _ -> do
+ let err= inred . fromStr $ toJSString $ "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
+-- Prefix pre <- getData `onNothing` return (Prefix "")
+ 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 deriving Monoid
+
+
+
+-- | Implement a radio button
+-- the parameter is the name of the radio group
+setRadio :: (Typeable a, Eq a, Show a) =>
+ a -> Widget (Radio a)
+setRadio v = Widget $ Transient $ do
+ RadioId n <- getData `onNothing` error "setRadio out of getRadio"
+ id <- genNewId
+ st <- get
+-- setData HasElems -- only for MFlow
+ me <- elemBySeq id
+ checked <- case me of
+ Nothing -> return ""
+ Just e -> liftIO $ getProp e "checked"
+ let strs= if checked=="true" then Just v else Nothing
+-- let mn= if null strs then False else True
+ ret= fmap Radio strs
+ str = if typeOf v == typeOf(undefined :: String)
+ then unsafeCoerce v else show v
+
+ addSData
+ ( finput id "radio" (toJSString str) ( isJust strs ) Nothing `attrs` [("name",n)] :: Perch)
+
+ return ret
+
+setRadioActive :: (Typeable a, Eq a, Show a) =>
+ a -> Widget (Radio a)
+setRadioActive rs = setRadio rs `raiseEvent` OnClick
+
+data RadioId= RadioId JSString deriving Typeable
+
+-- | encloses a set of Radio boxes. Return the option selected
+getRadio
+ :: Monoid a => [Widget (Radio a)] -> Widget a
+getRadio ws = Widget $ Transient $ do
+ id <- genNewId
+ setData $ RadioId id
+ fs <- mapM runView ws
+ let mx = mconcat fs
+ delData $ RadioId id
+ return $ fmap (\(Radio r) -> r) mx
+
+
+data CheckBoxes a= CheckBoxes [a] deriving Show
+
+instance Monoid (CheckBoxes a) where
+ mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
+ mempty= CheckBoxes []
+
+
+-- | Display a text box and return the value entered if it is readable( Otherwise, fail the validation)
+setCheckBox :: (Typeable a , Show a) =>
+ Bool -> a -> Widget (CheckBoxes a)
+setCheckBox checked' v= Widget . Transient $ do
+ n <- genNewId
+ st <- get
+-- setData HasElems
+ 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 []
+
+
+getCheckBoxes :: Show a => Widget (CheckBoxes a) -> Widget [a]
+getCheckBoxes w = Widget $ Transient $ do
+ mrs <- runView w
+ case mrs of
+ Nothing -> return Nothing
+ Just(CheckBoxes rs ) -> return $ Just 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 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 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
+ r <- getParam1 tolook `asTypeOf` typef res
+ case r of
+ Validated x -> do addSData (ftextarea tolook $ toJSString x :: Perch); return $ Just x
+ NotValidated s err -> do addSData (ftextarea tolook (toJSString s) :: Perch); return Nothing
+ NoParam -> do setData WasParallel;addSData (ftextarea tolook nvalue :: Perch); return 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 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 ++ [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 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x
+ | otherwise= show x
+
+data Path= Path [JSString]
+--pathLength= unsafePerformIO $ newIORef 0
+-- | Present a link. Return the first parameter when clicked
+
+-- | template link. Besides the wlink behaviour, it loads the page from the server if there is any
+--
+-- the page many have been saved with `edit`
+tlink :: (Show a, Read 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
+ liftIO $ print (pathelem, segment)
+ 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
+
+try p= do
+ ParseContext readit str <- getSData :: TransIO (ParseContext BS.ByteString)
+ p <|> (setData ( ParseContext readit str) >> 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
+ 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
+
+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
+
+
+-------------------------
+instance FormInput Perch where
+ fromStr = toElem
+ fromStrNoEncode = toElem
+ ftag n v = nelem n `child` v
+
+ attrs tag [] = tag
+ attrs tag (nv:attribs) = attrs (attr tag nv) attribs
+
+ inred msg= ftag "b" msg `attrs` [("style","color:red")]
+
+ finput n t v f c=
+ let
+ tag= ftag "input" mempty `attrs` [("type", t), ("id", n), ("value", v)]
+ tag1= if f then tag `attrs` [("checked", "")] else tag
+ in case c of Just s -> tag1 `attrs` [("onclick", s)] ; _ -> tag1
+
+ ftextarea nam text=
+ ftag "textarea" mempty `attrs` [("id", nam)] `child` text
+
+
+ fselect nam list = ftag "select" mempty `attrs` [("id", nam)] `child` list
+ foption name v msel=
+ let tag= ftag "option" mempty `attrs` [("value", name)] `child` v
+ in if msel then tag `attrs` [("selected", "")] else tag
+
+
+ formAction action method1 form = ftag "form" mempty `attrs` [("acceptCharset", "UTF-8")
+ ,( "action", action)
+ ,("method", method1)]
+ `child` form
+
+
+ flink v str = ftag "a" mempty `attrs` [("href", v)] `child` str
+
+
+---------------------------
+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
+ cont <- get -- !> "raise"
+ 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
+
+ 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
+-- mn <- getData
+-- when (isJust mn) $ let IDNUM n = fromJust mn in modify $ \s -> s{mfSequence= n}
+ 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 ()
+addHeader format= do
+ head <- getHead
+ build format head
+ return ()
+
+
+-- | 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
+
+
+data AlternativeBranch= Alternative deriving (Typeable, Eq)
+
+-- | 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
+ 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
+ id1 <- if (ma == Just Alternative)
+ then do
+ id3 <- do
+ id3 <- genNewId
+ -- create id3 hanging from id1 parent
+ if (not isTemplate) then do
+ liftIO $ withElem id1' $ build $ this `goParent` (span ! 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 -- !> ("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 >> setData (IdLine (level +1) id2 ) -- !> ("setDataAl",id2)
+ else setData Alternative
+ return r
+
+
+#else
+render (Widget x)= x
+#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 id. The content can
+-- be appended, prepended to the previous content or it can be the only content depending on the
+-- update method.
+at :: JSString -> UpdateMethod -> Widget a -> Widget a
+at id method w= setAt id method <<< w
+
+
+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)" alert :: JSString -> IO ()
+
+
+
+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 = undefined
+setProp :: Elem -> JSString -> JSString -> IO ()
+setProp = undefined
+alert :: JSString -> IO ()
+alert= undefined
+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