are defined by you. for example `./YourSource.hs -p start/localhost/8080`
124 |
125 | The program will be accessed from outside docker as a web application. Read the documentation of Docker for your platform about how to invoke it.
126 |
127 | If you want to run it in a host Linux machine, you can generate the browser code and the executable from docker in the way described above. Then in in the host you can execute it:
128 |
129 | ```
130 | > ./program - p start/localhost/8080
131 | ```
132 |
133 | If you want to install Axiom in your host machine:
134 | --------------------------------------------------
135 |
136 | You need to install [stack](https://docs.haskellstack.org/en/stable/README/) and [ghcjs](https://github.com/ghcjs/ghcjs). The latter is not an easy task.
137 |
138 | Then install Axiom in stack/ghc:
139 |
140 | ```
141 | > stack install axiom
142 | ```
143 |
144 | This should install ghc and compile everithing.
145 |
146 | Alternatively, you can install [Haskell platform](https://www.haskell.org/platform/) and:
147 |
148 | ```
149 | > cabal install axiom
150 | ```
151 |
152 | In any case you need to install Axiom in GHCJS too:
153 |
154 | ```
155 | > cabal install axiom --ghcjs
156 | ```
157 |
158 | How to compile and run a program
159 | ================================
160 | ```
161 | > mkdir static
162 | > ghcjs yourProgram.hs -o static/out
163 | > ghc yourProgram.hs
164 |
165 | > yourProgram -p start/yourhost/yourport
166 |
167 | ```
168 |
169 | How to run Distributed applications
170 | ========================
171 |
172 | If your program use `inputNodes` to connect N server nodes, you must use additional parameters in the command line:
173 |
174 | in a computer or docker instance:
175 | ```
176 | > yourProgram -p start/host1/port1
177 | ```
178 | In the same or another computer or docker instance:
179 | ```
180 | > yourProgram -p start/host2/port2/add/host1/port1/y
181 | ```
182 | in the same or another computer or docker instance:
183 | ```
184 | > yourProgram -p start/host3/port3/add/host1/port1/y
185 | ```
186 |
187 | Be sure that the `host:port` ip addresses are reachable from all the machines.
188 |
189 | This connect all the server nodes among them.
190 |
191 | The web browser can point to any host:port of them. You must have the static folder (wich contains the generated javascript files) as well as the executable in all the locations.
192 |
193 | See [distrbutedApps](https://github.com/transient-haskell/transient-examples/blob/master/distributedApps.hs) that contain examples of distributed web applications.
194 |
195 | Plans:
196 | ======
197 |
198 | Axiom web nodes are client side applications. So dHTML rendering happens on the browser. It is intended to implement server side rendering as well as multipage navigation. The last release support page navigation and page templates for the creation of server-side content.
199 |
200 |
201 |
--------------------------------------------------------------------------------
/src/GHCJS/HPlay/Cell.hs:
--------------------------------------------------------------------------------
1 | -----------------------------------------------------------------------------
2 | --
3 | -- Module : Cell
4 | -- Copyright :
5 | -- License : MIT
6 | --
7 | -- Maintainer : agocorona@gmail.com
8 | -- Stability : experimental
9 | -- Portability :
10 | --
11 | -- |
12 | --
13 | -----------------------------------------------------------------------------
14 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, CPP, ScopedTypeVariables #-}
15 | module GHCJS.HPlay.Cell(Cell(..),boxCell,bcell,(.=),get,mkscell,scell, gcell, calc) where
16 | import Transient.Internals
17 | import Transient.Move --hiding (JSString)
18 | import GHCJS.HPlay.View
19 | import Data.Typeable
20 | import Unsafe.Coerce
21 | import qualified Data.Map as M hiding ((!))
22 |
23 | import Control.Monad.State hiding (get)
24 | import Control.Monad
25 | import Data.Monoid
26 | import Data.List
27 | import Control.Exception
28 | import Data.IORef
29 | import System.IO.Unsafe
30 | #ifdef ghcjs_HOST_OS
31 |
32 | import Data.JSString hiding (empty)
33 |
34 | #else
35 |
36 | -- type JSString = String
37 |
38 | #endif
39 |
40 | data Cell a = Cell { mk :: Maybe a -> Widget a
41 | , setter :: a -> IO ()
42 | , getter :: IO (Maybe a)}
43 |
44 | --instance Functor Cell where
45 | -- fmap f cell = cell{setter= \c x -> c .= f x, getter = \cell -> get cell >>= return . f}
46 |
47 | -- | creates (but not instantiates) an input box that has a setter and a getter. To instantiate it us his method `mk`
48 | bcell :: (Show a, Read a, Typeable a) =>TransIO (Cell a)
49 | bcell= genNewId >>= return . boxCell
50 |
51 | -- | creates (but not instantiates) a input box cell with polimorphic value, identified by a string.
52 | -- the cell has a getter and a setter. To instantiate it us his method `mk`
53 | boxCell :: (Show a, Read a, Typeable a) => ElemID -> Cell a
54 | boxCell id = Cell{ mk= \mv -> getParam (Just id) "text" mv
55 | , setter= \x -> do
56 | me <- elemById id
57 | case me of
58 | Just e -> setProp e "value" (toJSString $ show1 x)
59 | Nothing -> return ()
60 |
61 | , getter= getID id}
62 |
63 | getID id = withElem id $ \e -> do
64 | ms <- getValue e
65 | case ms of
66 | Nothing -> return Nothing
67 | Just s -> return $ read1 s
68 | where
69 | read1 s=
70 | if typeOf(typeIO getID) /= typestring
71 | then case readsPrec 0 s of
72 | [(v,_)] -> v `seq` Just v
73 | _ -> Nothing
74 | else Just $ unsafeCoerce s
75 |
76 | typeIO :: (ElemID -> IO (Maybe a)) -> a
77 | typeIO = undefined
78 |
79 | typestring :: TypeRep
80 | typestring= typeOf (undefined :: String)
81 |
82 | show1 :: (Show a, Typeable a) => a -> String
83 | show1 x= if typeOf x== typestring
84 | then unsafeCoerce x
85 | else show x
86 |
87 | instance Attributable (Cell a) where
88 | (Cell mk setter getter) ! atr = Cell (\ma -> mk ma ! atr) setter getter
89 |
90 |
91 |
92 | -- | Cell assignment using the cell setter
93 | (.=) :: MonadIO m => Cell a -> a -> m ()
94 | (.=) cell x = liftIO $ (setter cell ) x
95 |
96 | get cell = Transient $ liftIO (getter cell)
97 |
98 |
99 | ---- | a cell value assigned to other cell
100 | --(..=) :: Cell a -> Cell a -> Widget ()
101 | --(..=) cell cell'= get cell' >>= (cell .= )
102 |
103 | infixr 0 .= -- , ..=
104 |
105 | -- experimental: to permit cell arithmetic
106 |
107 | --instance Num a => Num (Cell a) where
108 | -- c + c'= Cell undefined undefined $
109 | -- do r1 <- getter c
110 | -- r2 <- getter c'
111 | -- return $ liftA2 (+) r1 r2
112 | --
113 | -- c * c'= Cell undefined undefined $
114 | -- do r1 <- getter c
115 | -- r2 <- getter c'
116 | -- return $ liftA2 (+) r1 r2
117 | --
118 | -- abs c= c{getter= getter c >>= return . fmap abs}
119 | --
120 | -- signum c= c{getter= getter c >>= return . fmap signum}
121 | --
122 | -- fromInteger i= Cell undefined undefined . return $ Just $ fromInteger i
123 |
124 |
125 | -- * Spradsheet type cells
126 | -- Implement a solver that allows circular dependencies . See
127 | -- > http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
128 |
129 | -- The recursive Cell calculation DSL BELOW ------
130 |
131 |
132 | -- | within a `mkscell` formula, `gcell` get the the value of another cell using his name.
133 | --
134 | -- see http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
135 | gcell :: JSString -> Cloud Double
136 | gcell n= loggedc $ do
137 | -- onAll $ do
138 | -- cutExceptions
139 | -- reportBack
140 | vars <- getCloudState rvars <|> return M.empty -- liftIO $ readIORef rvars
141 | localIO $ print ("gcell", n)
142 | case M.lookup n vars of
143 | Just exp -> do inc ; exp !> "executing exp"
144 | Nothing -> error $ "cell not found: " ++ show n
145 | where
146 | inc = do
147 | Tries tries maxtries <- getCloudState rtries <|> error "no tries" --do
148 | -- Exprs exprs <- getCloudState
149 | -- return . Tries 0 $ 3 * (M.size $ exprs)
150 | localIO $ print tries
151 | if tries <= maxtries
152 | then localIO $ writeIORef rtries $ Tries (tries+1) maxtries
153 | else local $ do
154 | -- liftIO $ print "back"
155 | back Loop
156 |
157 | data Loop= Loop deriving (Show,Typeable)
158 |
159 | instance Exception Loop
160 |
161 | -- a parameter is a function of all of the rest
162 | type Expr a = Cloud a
163 |
164 | data Tries= Tries Int Int deriving Typeable
165 | rtries= unsafePerformIO $ newIORef $ Tries 0 0
166 | --maxtries= 3 * (M.size $ unsafePerformIO $ readIORef rexprs)
167 |
168 | -- newtype Exprs= Exprs (M.Map JSString (Expr Double))
169 | rexprs :: IORef (M.Map JSString (Expr Double))
170 | rexprs= unsafePerformIO $ newIORef M.empty -- initial expressions
171 |
172 | -- newtype Vars= Vars (M.Map JSString (Expr Double))
173 | rvars :: IORef (M.Map JSString (Expr Double))
174 | rvars= unsafePerformIO $ newIORef M.empty -- expressions actually used for each cell.
175 | -- initially, A mix of reexprs and rmodified
176 | -- and also contains the result of calculation
177 |
178 | -- newtype Modified= Modified (M.Map JSString (Expr Double)) deriving Typeable
179 | rmodified :: IORef (M.Map JSString ( Double))
180 | rmodified= unsafePerformIO $ newIORef M.empty -- cells modified by the user or by the loop detection mechanism
181 |
182 |
183 | -- | make a spreadsheet cell. a spreadsheet cell is an input-output box that takes input values from
184 | -- the user, has an expression associated and display the result value after executing `calc`
185 | --
186 | -- see http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
187 | mkscell :: JSString -> Expr Double -> Cloud (Cell Double)
188 | mkscell name expr= do
189 | exprs <- onAll $ liftIO (readIORef rexprs) <|> return ( M.empty) -- readIORef rexprs
190 | onAll $ liftIO $ writeIORef rexprs $ M.insert name expr exprs
191 | return $ scell name expr
192 |
193 |
194 |
195 | scell :: JSString -> Expr Double -> Cell Double
196 | scell id expr= Cell{ mk= \mv -> Widget $ do
197 | r <- norender $ getParam (Just id) "text" mv `fire` OnChange
198 | mod <- liftIO (readIORef rmodified) <|> return( M.empty)
199 | liftIO $ writeIORef rmodified $ M.insert id r mod
200 | return r
201 |
202 | , setter= \x -> withElem id $ \e -> setProp e "value" (toJSString $ show1 x)
203 |
204 | , getter= getID id}
205 |
206 |
207 |
208 |
209 |
210 |
211 | -- | executes the spreadsheet adjusting the vaules of the cells created with `mkscell` and solving loops
212 | --
213 | -- see http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
214 | calc :: Cloud ()
215 | calc= do
216 | mod <- localIO $ readIORef rmodified
217 | onAll $ liftIO $ print ("LENGTH MOD", M.size mod)
218 | onAll $ liftIO $ print "setCloudState modified"
219 | setCloudState rmodified mod
220 | exprs <- getCloudState rexprs
221 | onAll $ liftIO $ print "setCloudState exprs"
222 | setCloudState rexprs exprs
223 | onAll $ liftIO $ print "setCloudState rvars"
224 |
225 | setCloudState rvars M.empty
226 |
227 | onAll $ return() `onBack` (\(e::Loop) -> runCloud' $ do localIO $ print "REMOVEVAR"; removeVar e; local (forward Loop) )
228 | exprs <- getCloudState rexprs <|> error "no exprs"
229 | onAll $ liftIO $ print "setCloudState rtries"
230 |
231 | setCloudState rtries $ Tries 0 $ 3 * (M.size $ exprs)
232 | nvs <- getCloudState rmodified <|> error "no modified" -- liftIO $ readIORef rmodified
233 |
234 | onAll $ liftIO $ print ("LENGTH NVS", M.size nvs)
235 | when (not $ M.null nvs) $ calc1
236 | --values <- calc1
237 | --localIO $ print "NEW CALC"
238 | --local $ mapM_ (\(n,v) -> boxCell n .= v) values
239 | onAll $ liftIO $ print "setCloudState modified"
240 | setCloudState rmodified M.empty
241 |
242 | where
243 |
244 |
245 | --calc1 :: Expr [(JSString,Double)]
246 | calc1= do
247 | return () !> "CALC1"
248 | cells <- getCloudState rexprs <|> error "no exprs" -- liftIO $ readIORef rexprs
249 | nvs <- getCloudState rmodified <|> error "no modified2" -- liftIO $ readIORef rmodified
250 | onAll $ liftIO $ print "setCloudState vars"
251 |
252 | setCloudState rvars $ M.union (M.map return nvs) cells
253 |
254 | solve
255 |
256 | --solve :: Expr [(JSString,Double)]
257 | solve = do
258 | vars <- getCloudState rvars <|> error "no vars" -- liftIO $ readIORef rvars
259 | onAll $ liftIO $ print $ ("LENGHT VARS", M.size vars)
260 | mapM_ (solve1 vars) $ M.toList vars
261 | where
262 | solve1 vars (k,f)= do
263 | localIO $ print ("solve1",k)
264 | x <- f
265 | localIO $ print ("setcloudstate var",k,x)
266 | local $ boxCell k .= x
267 | setCloudState rvars $ M.insert k (return x) vars
268 | return () -- (k,x) :: Expr (JSString,Double)
269 |
270 |
271 | setCloudState r v= allNodes $ writeIORef r v
272 | getCloudState r= onAll . liftIO $ readIORef r
273 |
274 | -- removeVar ::SomeException -> IO () -- [(JSString,Double)]
275 | removeVar = \(e:: Loop) -> do
276 | nvs <- getCloudState rmodified <|> error "no modified 3"-- readIORef rmodified
277 | -- mapM (\n -> snd n >>= \v -> localIO $ print (fst n,v)) $ M.toList nvs
278 | exprs <- getCloudState rexprs <|> error " no Exprs2" --readIORef rexprs
279 |
280 | case M.keys exprs \\ M.keys nvs of
281 | [] -> error "non solvable circularity in cell dependencies"
282 | (name:_) -> do
283 | localIO $ print ("removeVar",name)
284 |
285 | mv <- localIO $ getID name
286 |
287 | case mv of
288 | Nothing -> return ()
289 | Just v -> do
290 | onAll $ liftIO $ print "setCloudState modified"
291 | setCloudState rmodified $ M.insert name v nvs
292 | return ()
293 |
294 | allNodes :: IO () -> Cloud ()
295 | allNodes mx= loggedc $ (localIO mx) <> (atRemote $ (localIO $ print "UPDATE" >> mx))
296 |
297 | --atBrowser mx= if isBrowserInstance then mx else atRemote mx
298 |
299 | --atServer mx= if not isBrowserInstance then mx else atRemote mx
300 |
301 | -- http://blog.sigfpe.com/2006/11/from-l-theorem-to-spreadsheet.html
302 | -- loeb :: Functor f => f (t -> a) -> f a
303 | -- loeb x = fmap (\a -> a (loeb x)) x
304 | -- loeb :: [([a]-> a)] -> [a]
305 | -- loeb x= map (\f -> f (loeb x)) x
306 |
307 | --loeb :: [([a] -> IO a)] -> IO [a]
308 | --loeb x= mapM (\f -> loeb x >>= f) x -- fail does not terminate
309 |
310 |
311 |
312 | --loeb x= map (\f -> f (loeb x)) x
313 |
314 |
315 |
--------------------------------------------------------------------------------
/src/GHCJS/HPlay/View.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP #-}
2 | {-# LANGUAGE DeriveDataTypeable #-}
3 | {-# LANGUAGE ExistentialQuantification #-}
4 | {-# LANGUAGE FlexibleContexts #-}
5 | {-# LANGUAGE FlexibleInstances #-}
6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
7 | {-# LANGUAGE MultiParamTypeClasses #-}
8 | {-# LANGUAGE OverloadedStrings #-}
9 | {-# LANGUAGE UndecidableInstances #-}
10 | {-# LANGUAGE ScopedTypeVariables #-}
11 | module GHCJS.HPlay.View(
12 | Widget(..)
13 | -- * Running it
14 | , module Transient.Move.Utils
15 | , runBody
16 | , addHeader
17 | , render
18 | -- * Widget Combinators and Modifiers
19 | , (<<)
20 | , (<<<)
21 | , ()
24 | , validate
25 | , wcallback
26 | , redraw
27 | -- * Basic Widgets
28 | , option
29 | , wprint
30 | , getString
31 | , inputString
32 | , getInteger
33 | , inputInteger
34 | , getInt
35 | , inputInt
36 | , inputFloat
37 | , inputDouble
38 | , getPassword
39 | , inputPassword
40 | , setRadio
41 | , setRadioActive
42 | , getRadio
43 | , setCheckBox
44 | , getCheckBoxes
45 | , getTextBox
46 | , getMultilineText
47 | , textArea
48 | , getBool
49 | , getSelect
50 | , setOption
51 | , setSelectedOption
52 | , wlabel
53 | , resetButton
54 | , inputReset
55 | , submitButton
56 | , inputSubmit
57 | , wbutton
58 | , wlink
59 | , tlink
60 | , staticNav
61 | , noWidget
62 | , wraw
63 | , rawHtml
64 | , isEmpty
65 | -- * Events
66 | , BrowserEvent(..)
67 | -- * Out of Flow Updates
68 | , UpdateMethod(..)
69 | , setRenderTag
70 | , at, at'
71 | -- * Reactive and Events
72 | , IsEvent(..)
73 | , EventData(..)
74 | , EvData(..)
75 | , resetEventData
76 | , getEventData
77 | , setEventData
78 | , raiseEvent
79 | , fire
80 | , wake
81 | , pass
82 | -- * utility
83 | , clearScreen
84 | -- * Low-level and Internals
85 | , ElemID
86 | , getNextId
87 | , genNewId
88 | , continuePerch
89 | , getParam
90 | , getCont
91 | , runCont
92 | , elemById
93 | , withElem
94 | , getProp
95 | , setProp
96 | , alert
97 | , fromJSString
98 | , toJSString
99 | , getValue
100 | -- * Re-exported
101 | , module Control.Applicative
102 | , module GHCJS.Perch
103 | -- remove
104 | ,CheckBoxes(..)
105 | ,edit
106 | ,JSString,pack, unpack
107 | ,RadioId(..), Radio(..)
108 |
109 |
110 | ) where
111 |
112 |
113 | import Transient.Internals hiding (input, option, parent)
114 | import Transient.Logged
115 | import Transient.Move.Utils
116 | import qualified Prelude(id,span,div)
117 | #ifndef ghcjs_HOST_OS
118 | import Transient.Parse hiding(parseString)
119 | import Data.Char(isSpace)
120 | import System.Directory
121 | import System.IO.Error
122 | import Data.List(elemIndices)
123 | import Control.Exception hiding (try)
124 | import qualified Data.ByteString.Lazy.Char8 as BS
125 | #endif
126 |
127 | import Control.Monad.State
128 | -- import qualified Data.Map as M
129 |
130 | import Control.Applicative
131 | import Control.Concurrent
132 | import Data.Dynamic
133 |
134 | import Data.Maybe
135 | import Data.Monoid
136 | import Data.Typeable
137 | import Prelude hiding (id,span,div)
138 | import System.IO.Unsafe
139 | import Unsafe.Coerce
140 |
141 | import Data.IORef
142 |
143 |
144 | #ifdef ghcjs_HOST_OS
145 |
146 | import GHCJS.Foreign
147 | import GHCJS.Foreign.Callback
148 | import GHCJS.Foreign.Callback.Internal (Callback(..))
149 | import GHCJS.Marshal
150 |
151 | import GHCJS.Perch hiding (JsEvent (..), eventName, option,head,map)
152 | import GHCJS.Types
153 | import Transient.Move hiding (pack)
154 |
155 | import qualified Data.JSString as JS hiding (empty, center,span, strip,foldr,head)
156 | import Data.JSString (pack,unpack,toLower)
157 | #else
158 | import Data.List as JS hiding (span)
159 | import GHCJS.Perch hiding (JSVal, JsEvent (..), eventName, option,head, map)
160 | import Transient.Move
161 | #endif
162 |
163 | #ifndef ghcjs_HOST_OS
164 | type JSString = String
165 | #else
166 | instance Loggable JSString
167 | #endif
168 |
169 | toJSString :: (Show a, Typeable a) => a -> JSString
170 | toJSString x =
171 | if typeOf x == typeOf (undefined :: String )
172 | then pack $ unsafeCoerce x
173 | else pack$ show x
174 |
175 | fromJSString :: (Typeable a,Read a) => JSString -> a
176 | fromJSString s = x
177 | where
178 | x | typeOf x == typeOf (undefined :: JSString) =
179 | unsafeCoerce x -- !> "unsafecoerce"
180 | | typeOf x == typeOf (undefined :: String) =
181 | unsafeCoerce $ pack$ unsafeCoerce x -- !!> "packcoerce"
182 | | otherwise = read $ unpack s -- !> "readunpack"
183 |
184 | getValue :: MonadIO m => Elem -> m (Maybe String)
185 |
186 | getName :: MonadIO m => Elem -> m (Maybe String)
187 | #ifdef ghcjs_HOST_OS
188 | getValue e = liftIO $ do
189 | s <- getValueDOM e
190 | fromJSVal s -- return $ JS.unpack s
191 |
192 | getName e = liftIO $ do
193 | s <- getNameDOM e
194 | fromJSVal s
195 | #else
196 | getValue = undefined
197 | getName = undefined
198 | #endif
199 |
200 | elemBySeq :: (MonadState EventF m, MonadIO m) => JSString -> m (Maybe Elem)
201 | #ifdef ghcjs_HOST_OS
202 | elemBySeq id = do
203 | IdLine _ id1 <- getData `onNothing` error ("not found: " ++ show id) -- return (IdLine "none")
204 | return () !> ("elemBySeq",id1, id)
205 | liftIO $ do
206 | let id2= JS.takeWhile (/='p') id
207 | re <- elemBySeqDOM id1 id2
208 | fromJSVal re
209 | #else
210 | elemBySeq _ = return Nothing
211 | #endif
212 |
213 | #ifdef ghcjs_HOST_OS
214 | attribute :: (MonadIO m) => Elem -> JSString -> m (Maybe JSString)
215 | attribute elem prop= liftIO $ do
216 | rv <- attributeDOM elem "id"
217 | fromJSVal rv
218 | #else
219 | attribute _ = return Nothing
220 | #endif
221 |
222 | elemById :: MonadIO m => JSString -> m (Maybe Elem)
223 | #ifdef ghcjs_HOST_OS
224 | elemById id= liftIO $ do
225 | re <- elemByIdDOM id
226 | fromJSVal re
227 | #else
228 | elemById _= return Nothing
229 | #endif
230 |
231 | withElem :: ElemID -> (Elem -> IO a) -> IO a
232 | withElem id f= do
233 | me <- elemById id
234 | case me of
235 | Nothing -> error ("withElem: not found"++ fromJSString id)
236 | Just e -> f e
237 |
238 | --data NeedForm= HasForm | HasElems | NoElems deriving Show
239 |
240 |
241 | type ElemID= JSString
242 | newtype Widget a= Widget{ norender :: TransIO a} deriving(Monad,MonadIO, Alternative, MonadState EventF,MonadPlus,Num)
243 |
244 | instance Functor Widget where
245 | fmap f mx= Widget. Transient $ fmap (fmap f) . runTrans $ norender mx
246 |
247 |
248 |
249 | instance Applicative Widget where
250 | pure= return
251 |
252 | Widget (Transient x) <*> Widget (Transient y) = Widget . Transient $ do
253 | getData `onNothing` do
254 | cont <- get
255 | let al= Alternative cont
256 | setData $ Alternative cont
257 | return al
258 | mx <- x
259 | my <- y
260 | return $ mx <*> my
261 |
262 |
263 |
264 | instance Monoid a => Monoid (Widget a) where
265 | mempty= return mempty
266 |
267 | #if MIN_VERSION_base(4,11,0)
268 | mappend= (<>)
269 |
270 | instance (Monoid a) => Semigroup (Widget a) where
271 | (<>)= mappendw
272 | #else
273 | mappend= mappendw
274 | #endif
275 |
276 | mappendw x y= (<>) <$> x <*> y
277 |
278 | instance AdditionalOperators Widget where
279 |
280 | Widget (Transient x) <** Widget (Transient y)= Widget . Transient $ do
281 | getData `onNothing` do
282 | cont <- get
283 | let al= Alternative cont
284 | setData $ Alternative cont
285 | return al
286 |
287 | mx <- x
288 | y
289 | return mx
290 |
291 | (<***) x y= Widget $ norender x <*** norender y
292 |
293 | (**>) x y= Widget $ norender x **> norender y
294 |
295 |
296 |
297 | runView :: Widget a -> StateIO (Maybe a)
298 | runView = runTrans . norender
299 |
300 | -- | It is a callback in the view monad. The rendering of the second parameter substitutes the rendering
301 | -- of the first paramenter when the latter validates without afecting the rendering of other widgets.
302 | wcallback
303 | :: Widget a -> (a ->Widget b) -> Widget b
304 |
305 | wcallback x f= Widget $ Transient $ do
306 | nid <- genNewId
307 | runView $ do
308 | r <- at nid Insert x
309 | at nid Insert $ f r
310 |
311 |
312 | -- | execute a widget but redraw itself too when some event happens.
313 | -- The first parameter is the path of the DOM element that hold the widget, used by `at`
314 |
315 | redraw :: JSString -> Widget a -> TransIO a
316 | redraw idelem w= do
317 | path <- getState <|> return ( Path [])
318 | r <- render $ at idelem Insert w
319 | setState path
320 | redraw idelem w <|> return r
321 |
322 |
323 |
324 | {-
325 | instance Monoid view => MonadTrans (View view) where
326 | lift f = Transient $ (lift f) >>= \x -> returnFormElm mempty $ Just x
327 | -}
328 |
329 | type Name= JSString
330 | type Type= JSString
331 | type Value= JSString
332 | type Checked= Bool
333 | type OnClick1= Maybe JSString
334 |
335 |
336 | -- | Minimal interface for defining the basic form and link elements. The core of MFlow is agnostic
337 | -- about the rendering package used. Every formatting (either HTML or not) used with MFlow must have an
338 | -- instance of this class.
339 | -- See "MFlow.Forms.Blaze.Html for the instance for blaze-html" "MFlow.Forms.XHtml" for the instance
340 | -- for @Text.XHtml@ and MFlow.Forms.HSP for the instance for Haskell Server Pages.
341 | -- class (Monoid view,Typeable view) => FormInput view where
342 | -- fromStr :: JSString -> view
343 | -- fromStrNoEncode :: String -> view
344 | -- ftag :: JSString -> view -> view
345 | -- inred :: view -> view
346 | -- flink :: JSString -> view -> view
347 | -- flink1:: JSString -> view
348 | -- flink1 verb = flink verb (fromStr verb)
349 | -- finput :: Name -> Type -> Value -> Checked -> OnClick1 -> view
350 | -- ftextarea :: JSString -> JSString -> view
351 | -- fselect :: JSString -> view -> view
352 | -- foption :: JSString -> view -> Bool -> view
353 | -- foption1 :: JSString -> Bool -> view
354 | -- foption1 val msel= foption val (fromStr val) msel
355 | -- formAction :: JSString -> JSString -> view -> view
356 | -- attrs :: view -> Attribs -> view
357 |
358 | type Attribs= [(JSString, JSString)]
359 |
360 |
361 | data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show)
362 |
363 | valToMaybe (Validated x)= Just x
364 | valToMaybe _= Nothing
365 |
366 | isValidated (Validated x)= True
367 | isValidated _= False
368 |
369 | fromValidated (Validated x)= x
370 | fromValidated NoParam= error "fromValidated : NoParam"
371 | fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s
372 |
373 | getParam1 :: ( Typeable a, Read a, Show a)
374 | => Bool -> JSString -> StateIO (ParamResult Perch a)
375 | getParam1 exact par = do
376 | isTemplate <- liftIO $ readIORef execTemplate
377 | if isTemplate then return NoParam else do
378 |
379 | me <- if exact then elemById par else elemBySeq par
380 | !> ("looking for " ++ show par)
381 | case me of
382 | Nothing -> return NoParam
383 | Just e -> do
384 | v <- getValue e -- !!> ("exist" ++ show par)
385 | readParam v -- !!> ("getParam for "++ show v)
386 |
387 |
388 | type Params= Attribs
389 |
390 |
391 |
392 | readParam :: (Typeable a, Read a)=> Maybe String -> StateIO (ParamResult Perch a)
393 | readParam Nothing = return NoParam
394 | readParam (Just x1) = r
395 | where
396 | r= maybeRead x1
397 |
398 | getType :: m (ParamResult v a) -> a
399 | getType= undefined
400 | x= getType r
401 |
402 | maybeRead str= do
403 | let typeofx = typeOf x
404 | if typeofx == typeOf ( undefined :: String) then
405 | return . Validated $ unsafeCoerce str -- !!> ("maybread string " ++ str)
406 | else if typeofx == typeOf(undefined :: JSString) then
407 | return . Validated $ unsafeCoerce $ pack str
408 | else case reads $ str of -- -- !!> ("read " ++ str) of
409 | [(x,"")] -> return $ Validated x -- !!> ("readsprec" ++ show x)
410 | _ -> do
411 | let err= inred $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
412 | return $ NotValidated str err
413 |
414 |
415 |
416 | -- | Validates a form or widget result against a validating procedure
417 | --
418 | -- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@
419 | validate
420 | :: Widget a
421 | -> (a -> StateIO (Maybe Perch))
422 | -> Widget a
423 | validate w val= do
424 | idn <- Widget $ Transient $ Just <$> genNewId
425 | rawHtml $ span ! id idn $ noHtml
426 | x <- w
427 | Widget $ Transient $ do
428 | me <- val x
429 | case me of
430 | Just str -> do
431 | liftIO $ withElem idn $ build $ clear >> (inred str)
432 | return Nothing
433 | Nothing -> do
434 | liftIO $ withElem idn $ build clear
435 | return $ Just x
436 |
437 |
438 |
439 |
440 | -- | Generate a new string. Useful for creating tag identifiers and other attributes.
441 | --
442 | -- if the page is refreshed, the identifiers generated are the same.
443 |
444 |
445 | {-#NOINLINE rprefix #-}
446 | rprefix= unsafePerformIO $ newIORef 0
447 | #ifdef ghcjs_HOST_OS
448 | genNewId :: (MonadState EventF m, MonadIO m) => m JSString
449 | genNewId= do
450 | r <- liftIO $ atomicModifyIORef rprefix (\n -> (n+1,n))
451 | n <- genId
452 | let nid= toJSString $ ('n':show n) ++ ('p':show r)
453 | nid `seq` return nid
454 |
455 |
456 |
457 | #else
458 | genNewId :: (MonadState EventF m, MonadIO m) => m JSString
459 | genNewId= return $ pack ""
460 |
461 | --getPrev :: StateIO JSString
462 | --getPrev= return $ pack ""
463 | #endif
464 |
465 |
466 |
467 | -- | get the next ideitifier that will be created by genNewId
468 | getNextId :: MonadState EventF m => m JSString
469 | getNextId= do
470 | n <- gets mfSequence
471 |
472 | return $ toJSString $ 'p':show n
473 |
474 |
475 | -- | Display a text box and return a non empty String
476 | getString :: Maybe String -> Widget String
477 | getString = getTextBox
478 | -- `validate`
479 | -- \s -> if Prelude.null s then return (Just $ fromStr "")
480 | -- else return Nothing
481 |
482 | inputString :: Maybe String -> Widget String
483 | inputString= getString
484 |
485 | -- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation)
486 | getInteger :: Maybe Integer -> Widget Integer
487 | getInteger = getTextBox
488 |
489 | inputInteger :: Maybe Integer -> Widget Integer
490 | inputInteger= getInteger
491 |
492 | -- | Display a text box and return a Int (if the value entered is not an Int, fails the validation)
493 | getInt :: Maybe Int -> Widget Int
494 | getInt = getTextBox
495 |
496 | inputInt :: Maybe Int -> Widget Int
497 | inputInt = getInt
498 |
499 | inputFloat :: Maybe Float -> Widget Float
500 | inputFloat = getTextBox
501 |
502 | inputDouble :: Maybe Double -> Widget Double
503 | inputDouble = getTextBox
504 |
505 | -- | Display a password box
506 | getPassword :: Widget String
507 | getPassword = getParam Nothing "password" Nothing
508 |
509 | inputPassword :: Widget String
510 | inputPassword= getPassword
511 |
512 | newtype Radio a= Radio a
513 |
514 | data RadioId= RadioId JSString deriving Typeable
515 |
516 | -- | Implement a radio button
517 | setRadio :: (Typeable a, Eq a, Show a,Read a) =>
518 | Bool -> a -> Widget (Radio a)
519 | setRadio ch v = Widget $ Transient $ do
520 | RadioId name <- getData `onNothing` error "setRadio out of getRadio"
521 | id <- genNewId
522 | me <- elemBySeq id
523 | checked <- case me of
524 | Nothing -> return ""
525 | Just e -> liftIO $ getProp e "checked"
526 |
527 | let str = if typeOf v == typeOf(undefined :: String)
528 | then unsafeCoerce v else show v
529 | addSData
530 | ( finput id "radio" (toJSString str) ch Nothing `attrs` [("name",name)] :: Perch)
531 |
532 | if checked == "true" !> ("val",v) then Just . Radio . read1 . unpack <$> liftIO (getProp (fromJust me) "value") else return Nothing
533 | where
534 | read1 x=r
535 | where
536 | r= if typeOf r== typeOf (undefined :: String) then unsafeCoerce x
537 | else read x
538 |
539 | setRadioActive :: (Typeable a, Eq a, Show a,Read a) =>
540 | Bool -> a -> Widget (Radio a)
541 | setRadioActive ch rs = setRadio ch rs `raiseEvent` OnClick
542 |
543 |
544 | -- | encloses a set of Radio boxes. Return the option selected
545 | getRadio
546 | :: [Widget (Radio a)] -> Widget a
547 | getRadio ws = do
548 | id <- genNewId
549 | setData $ RadioId id
550 | Radio x <- foldr (<|>) empty ws <*** delData (RadioId id)
551 | return x
552 |
553 |
554 | newtype CheckBoxes a= CheckBoxes [a]
555 |
556 | instance Monoid a => Monoid (CheckBoxes a) where
557 | mempty= CheckBoxes []
558 |
559 | #if MIN_VERSION_base(4,11,0)
560 | mappend= (<>)
561 |
562 | instance (Monoid a) => Semigroup (CheckBoxes a) where
563 | (<>)= mappendch
564 | #else
565 | mappend= mappendch
566 | #endif
567 |
568 | mappendch (CheckBoxes x) (CheckBoxes y)= CheckBoxes (x ++ y)
569 |
570 |
571 | -- | present a checkbox
572 | setCheckBox :: (Typeable a , Show a) =>
573 | Bool -> a -> Widget (CheckBoxes a)
574 | setCheckBox checked' v= Widget . Transient $ do
575 | n <- genNewId
576 | me <- elemBySeq n
577 | let showv= toJSString (if typeOf v == typeOf (undefined :: String)
578 | then unsafeCoerce v
579 | else show v)
580 |
581 | addSData $ ( finput n "checkbox" showv checked' Nothing :: Perch)
582 |
583 | case me of
584 | Nothing -> return Nothing
585 | Just e -> do
586 | checked <- liftIO $ getProp e "checked"
587 | return . Just . CheckBoxes $ if checked=="true" then [v] else []
588 |
589 | -- Read the checkboxes
590 | getCheckBoxes :: Show a => Widget (CheckBoxes a) -> Widget [a]
591 | getCheckBoxes w = do
592 | CheckBoxes rs <- w
593 | return rs
594 |
595 |
596 | whidden :: (Read a, Show a, Typeable a) => a -> Widget a
597 | whidden x= res where
598 | res= Widget . Transient $ do
599 | n <- genNewId
600 | let showx= case cast x of
601 | Just x' -> x'
602 | Nothing -> show x
603 | r <- getParam1 False n `asTypeOf` typef res
604 | addSData (finput n "hidden" (toJSString showx) False Nothing :: Perch)
605 | return (valToMaybe r)
606 | where
607 | typef :: Widget a -> StateIO (ParamResult Perch a)
608 | typef = undefined
609 |
610 |
611 |
612 |
613 | getTextBox
614 | :: (Typeable a,
615 | Show a,
616 | Read a) =>
617 | Maybe a -> Widget a
618 | getTextBox ms = getParam Nothing "text" ms
619 |
620 |
621 | getParam
622 | :: (Typeable a,
623 | Show a,
624 | Read a) =>
625 | Maybe JSString -> JSString -> Maybe a -> Widget a
626 | getParam look type1 mvalue= Widget . Transient $ getParamS look type1 mvalue
627 |
628 | getParamS look type1 mvalue= do
629 | tolook <- case look of
630 | Nothing -> genNewId
631 | Just n -> return n
632 | let nvalue x = case x of
633 | Nothing -> mempty
634 | Just v ->
635 | if (typeOf v== typeOf (undefined :: String)) then pack(unsafeCoerce v)
636 | else if typeOf v== typeOf (undefined :: JSString) then unsafeCoerce v
637 | else toJSString $ show v -- !!> "show"
638 |
639 | -- setData HasElems
640 | r <- getParam1 (isJust look) tolook
641 |
642 | case r of
643 | Validated x -> do addSData (finput tolook type1 (nvalue $ Just x) False Nothing :: Perch) ; return $ Just x -- !!> "validated"
644 | NotValidated s err -> do addSData (finput tolook type1 (toJSString s) False Nothing <> err :: Perch); return Nothing
645 | NoParam -> do modify $ \s -> s{execMode=Parallel};addSData (finput tolook type1 (nvalue mvalue) False Nothing :: Perch); return Nothing
646 |
647 |
648 |
649 |
650 | -- | Display a multiline text box and return its content
651 | getMultilineText :: JSString
652 | -> Widget String
653 | getMultilineText nvalue = res where
654 | res= Widget. Transient $ do
655 | tolook <- genNewId !> "GETMULTI"
656 | r <- getParam1 False tolook `asTypeOf` typef res
657 | case r of
658 | Validated x -> do addSData (ftextarea tolook $ toJSString x :: Perch); return $ Just x !> "VALIDATED"
659 | NotValidated s err -> do addSData (ftextarea tolook (toJSString s) :: Perch); return Nothing !> "NOTVALIDATED"
660 | NoParam -> do modify $ \s -> s{execMode=Parallel};addSData (ftextarea tolook nvalue :: Perch); return Nothing !> "NOTHING"
661 | where
662 | typef :: Widget String -> StateIO (ParamResult Perch String)
663 | typef = undefined
664 |
665 | -- | A synonim of getMultilineText
666 | textArea :: JSString ->Widget String
667 | textArea= getMultilineText
668 |
669 |
670 |
671 | getBool :: Bool -> String -> String -> Widget Bool
672 | getBool mv truestr falsestr= do
673 | r <- getSelect $ setOption truestr (fromStr $ toJSString truestr) setOption falsestr(fromStr $ toJSString falsestr)
682 | Widget (MFOption a) -> Widget a
683 | getSelect opts = res where
684 | res= Widget . Transient $ do
685 | tolook <- genNewId
686 | -- st <- get
687 | -- setData HasElems
688 | r <- getParam1 False tolook `asTypeOf` typef res
689 | -- setData $ fmap MFOption $ valToMaybe r
690 | runView $ fselect tolook <<< opts
691 | --
692 | return $ valToMaybe r
693 |
694 | where
695 | typef :: Widget a -> StateIO (ParamResult Perch a)
696 | typef = undefined
697 |
698 |
699 | newtype MFOption a = MFOption a deriving Typeable
700 |
701 | instance Monoid a => Monoid (MFOption a) where
702 | mempty= MFOption mempty
703 |
704 | #if MIN_VERSION_base(4,11,0)
705 | mappend= (<>)
706 |
707 | instance (Monoid a) => Semigroup (MFOption a) where
708 | (<>)= mappendop
709 | #else
710 | mappend= mappendop
711 | #endif
712 |
713 | mappendop (MFOption x) (MFOption y)= MFOption (x <> y)
714 |
715 | -- | Set the option for getSelect. Options are concatenated with `<|>`
716 | setOption
717 | :: (Show a, Eq a, Typeable a) =>
718 | a -> Perch -> Widget (MFOption a)
719 | setOption n v = setOption1 n v False
720 |
721 |
722 | -- | Set the selected option for getSelect. Options are concatenated with `<|>`
723 | setSelectedOption
724 | :: (Show a, Eq a, Typeable a) =>
725 | a -> Perch -> Widget (MFOption a)
726 | setSelectedOption n v= setOption1 n v True
727 |
728 |
729 | setOption1 :: (Typeable a, Eq a, Show a) =>
730 | a -> Perch -> Bool -> Widget (MFOption a)
731 | setOption1 nam val check= Widget . Transient $ do
732 | let n = if typeOf nam == typeOf(undefined :: String)
733 | then unsafeCoerce nam
734 | else show nam
735 |
736 | addSData (foption (toJSString n) val check)
737 |
738 | return Nothing -- (Just $ MFOption nam)
739 |
740 |
741 | wlabel:: Perch -> Widget a -> Widget a
742 | wlabel str w = Widget . Transient $ do
743 | id <- getNextId
744 | runView $ (ftag "label" str `attrs` [("for",id)] :: Perch) ++> w
745 |
746 |
747 |
748 | -- passive reset button.
749 | resetButton :: JSString -> Widget ()
750 | resetButton label= Widget . Transient $ do
751 | addSData (finput "reset" "reset" label False Nothing :: Perch)
752 | return $ Just ()
753 |
754 | inputReset :: JSString -> Widget ()
755 | inputReset= resetButton
756 |
757 | -- passive submit button. Submit a form, but it is not trigger any event.
758 | -- Unless you attach it with `raiseEvent`
759 | submitButton :: (Read a, Show a, Typeable a) => a -> Widget a
760 | submitButton label= getParam Nothing "submit" $ Just label
761 |
762 |
763 | inputSubmit :: (Read a, Show a, Typeable a) => a -> Widget a
764 | inputSubmit= submitButton
765 |
766 | -- | active button. When clicked, return the first parameter
767 | wbutton :: a -> JSString -> Widget a
768 | wbutton x label= Widget $ Transient $ do
769 | idn <- genNewId
770 | runView $ do
771 | input ! atr "type" "submit" ! id idn ! atr "value" label `pass` OnClick
772 | return x
773 | `continuePerch` idn
774 |
775 |
776 | clearScreen= local $ do
777 | render . wraw $ forElems "body" $ this >> clear `child` (div ! atr "id" "body1" $ noHtml)
778 | setRenderTag "body1"
779 |
780 |
781 | -- | when creating a complex widget with many tags, this call indentifies which tag will receive the attributes of the (!) operator.
782 | continuePerch :: Widget a -> ElemID -> Widget a
783 | continuePerch w eid= c <<< w
784 | where
785 | c f =Perch $ \e' -> do
786 | build f e'
787 | elemid eid
788 |
789 | elemid id= elemById id >>= return . fromJust
790 |
791 | -- child e = do
792 | -- jsval <- firstChild e
793 | -- fromJSValUnchecked jsval
794 |
795 | rReadIndexPath= unsafePerformIO $ newIORef 0
796 |
797 | -- | Present a link. It return the first parameter and execute the continuation when it is clicked.
798 | --
799 | -- It also update the path in the URL.
800 | wlink :: (Show a, Typeable a) => a -> Perch -> Widget a
801 | #ifdef ghcjs_HOST_OS
802 | wlink x v= do
803 | (a ! href "#" $ v) `pass` OnClick
804 | Path paths <- Widget $ getSData <|> return (Path [])
805 |
806 | let paths'= paths ++ [ toLower $ JS.pack $ show1 x ]
807 | setData $ Path paths'
808 | -- !> ("paths", paths')
809 | let fpath= ("/" <> (Prelude.foldl (\p p' -> p <> "/" <> p') (head paths') $ tail paths')<> ".html")
810 | liftIO $ replaceState "" "" fpath
811 | return x
812 | #else
813 | wlink _ _= empty
814 | #endif
815 |
816 | show1 :: (Typeable a,Show a) => a -> String
817 | show1 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x
818 | | otherwise= show x
819 |
820 | data Path= Path [JSString]
821 | --pathLength= unsafePerformIO $ newIORef 0
822 |
823 | -- | avoid that a recursive widget with links may produce long paths. It is equivalent to tail call elimination
824 | staticNav x= do
825 | Path paths <- getState <|> return (Path [])
826 | x <*** setState (Path paths)
827 |
828 |
829 | -- | template link. Besides the wlink behaviour, it loads the page from the server if there is any
830 | --
831 | -- the page may have been saved with `edit`
832 | tlink :: (Show a, Typeable a) => a -> Perch -> Widget a
833 | tlink x v= Widget $
834 |
835 | let showx= show1 x
836 | in do
837 | logged $ norender $ wlink showx v
838 | runCloud readPage
839 | return x
840 |
841 | <|> getPath showx
842 |
843 | where
844 |
845 |
846 | show1 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x
847 | | otherwise= show x
848 |
849 | readPage :: Cloud ()
850 | readPage = do
851 | url <- local $ do
852 | Path path <- getSData <|> return (Path [])
853 | return $ (Prelude.foldl (\p p' -> p <> "/" <> p') (head path) $ tail path)
854 | mr <- atRemote $ local $
855 | #ifndef ghcjs_HOST_OS
856 | do
857 | let url' = if url =="" then "/index" else url :: String
858 | let file= "static/out.jsexe/"++ url' ++ ".html"
859 | r <- liftIO $ doesFileExist file
860 | if r
861 | then do
862 | s <- liftIO $ BS.readFile file
863 | Just <$> do
864 | r <- filterBody s -- !> "exist"
865 | return r -- !> ("filtered",r)
866 | else return Nothing -- !> "do not exist"
867 | #else
868 | return Nothing
869 | #endif
870 |
871 |
872 | case mr of
873 | Nothing -> return () -- !> "readpage return"
874 | Just bodycontent -> do
875 |
876 |
877 | #ifdef ghcjs_HOST_OS
878 | local $ do
879 | liftIO $ forElems_ "body" $ this `setHtml` bodycontent -- !> bodycontent
880 |
881 |
882 | local $do
883 | installHandlers -- !> "installHanders"
884 | delData ExecEvent
885 | liftIO $ writeIORef execTemplate True
886 | return()
887 | #else
888 | localIO $ return()
889 | localIO $ return()
890 | return ()
891 | #endif
892 |
893 | #ifdef ghcjs_HOST_OS
894 | installHandlers= do
895 | setData $ IdLine 0 "n0p0"
896 | EventSet hs <- liftIO $ readIORef eventRef -- <- getSData <|> return (EventSet [])
897 | mapM_ f hs -- !> ("installhandlers, length=", Prelude.length hs)
898 | where
899 | f (id, _, Event event, iohandler)= do
900 | me <- elemBySeq id
901 | case me of
902 | Nothing -> return()
903 | -- !> ("installHandlers: not found", id) -- error $ "not found: "++ show id
904 | Just e ->
905 |
906 | liftIO $ buildHandler e event iohandler
907 | -- !> ("installHandlers adding event to ", id)
908 | #endif
909 |
910 | -- getPath :: Read a => TransIO a
911 | #ifdef ghcjs_HOST_OS
912 |
913 |
914 | getPath segment= do
915 | -- return () !> "GETPATH"
916 |
917 | Path paths <- getSData <|> initPath
918 | l <- liftIO $ readIORef rReadIndexPath
919 | let pathelem= paths !! l
920 | lpath= Prelude.length paths
921 | if l >= lpath
922 | then empty -- !> "getPath empty"
923 | else do
924 | -- setData ExecTemplate !> "SET EXECTEMPLATE 2"
925 | -- liftIO $ writeIORef execTemplate True
926 | if unpack pathelem /= segment then empty else do
927 | liftIO $ writeIORef rReadIndexPath $ l + 1
928 | asynchronous
929 | setData $ Path paths
930 | return x
931 | -- !> ("getPath return", x)
932 |
933 |
934 | -- liftIO $ writeIORef rReadIndexPath $ l +1
935 | -- r <- async . return . read $ unpack pathelem -- !> ("pathelem=",pathelem)
936 | -- setData $ Path paths
937 |
938 | -- return r
939 |
940 | where
941 | asynchronous= async $ return ()
942 | initPath= do
943 | path1 <- liftIO $ js_path >>= fromJSValUnchecked
944 | return $ Path $ split $ JS.drop 1 path1
945 |
946 | split x=
947 | if JS.null x then [] else
948 | let (f,s) = JS.break (=='/') x
949 | in if JS.null s
950 | then let l1= JS.length f in [JS.take (l1-5) f]
951 | else f:split (JS.drop 1 s)
952 | #else
953 | getPath _= empty
954 | #endif
955 |
956 | #ifndef ghcjs_HOST_OS
957 | filterBody :: BS.ByteString -> TransIO BS.ByteString
958 | filterBody page= do
959 | setData $ ParseContext (error "parsing page") page -- !> "filterBody"
960 | dropTill "" -- !> "token body"
961 | dropTill "" -- !> "tojen script"
962 | stringTill parseString (token "") -- !> "stringTill"
963 |
964 |
965 | stringTill p end = scan where
966 | scan= parseString <> ((try end >> return mempty) <|> scan)
967 |
968 | dropTill tok=do
969 | s <- parseString
970 | return ()
971 | if s == tok then return () -- !> ("FOUND", tok)
972 | else dropTill tok
973 |
974 | token tok= do
975 | s <- parseString
976 | return ()
977 | if s == tok then return () -- !> ("FOUND", tok)
978 | else empty
979 |
980 |
981 | parseString= do
982 | -- dropSpaces
983 | tTakeWhile (not . isSeparator)
984 |
985 |
986 | where
987 | isSeparator c= c == '>'
988 | --dropSpaces= parse $ \str ->((),BS.dropWhile isSpace str)
989 |
990 |
991 | -- tTakeWhile :: (Char -> Bool) -> TransIO BS.ByteString
992 | -- tTakeWhile cond= parse (span' cond)
993 | -- where
994 | -- span' cond s=
995 | -- let (h,t) = BS.span cond s
996 | -- c= BS.head t
997 | -- in (BS.snoc h c,BS.drop 1 t)
998 |
999 |
1000 | -- parse :: (BS.ByteString -> (b, BS.ByteString)) -> TransIO b
1001 | -- parse split= do
1002 | -- ParseContext readit str <- getSData
1003 | -- <|> error "parse: ParseContext not found"
1004 | -- :: TransIO (ParseContext BS.ByteString)
1005 |
1006 | -- if BS.null str then empty else do
1007 | -- let (ret,str3) = split str
1008 | -- setData $ ParseContext readit str3
1009 | -- return ret
1010 |
1011 |
1012 |
1013 | #endif
1014 |
1015 | -- | show something enclosed in the tag, so ASCII formatting chars are honored
1016 | wprint :: ToElem a => a -> Widget ()
1017 | wprint = wraw . pre
1018 |
1019 | -- | Enclose Widgets within some formating.
1020 | -- @view@ is intended to be instantiated to a particular format
1021 | --
1022 | -- NOTE: It has a infix priority : @infixr 5@ less than the one of @++>@ and @<++@ of the operators, so use parentheses when appropriate,
1023 | -- unless the we want to enclose all the widgets in the right side.
1024 | -- Most of the type errors in the DSL are due to the low priority of this operator.
1025 | --
1026 |
1027 | (<<<) :: (Perch -> Perch)
1028 | -> Widget a
1029 | -> Widget a
1030 | (<<<) v form= Widget . Transient $ do
1031 | rest <- getData `onNothing` return noHtml
1032 | delData rest
1033 | mx <- runView form
1034 | f <- getData `onNothing` return noHtml
1035 | setData $ rest <> v f
1036 | return mx
1037 |
1038 |
1039 | infixr 5 <<<
1040 |
1041 |
1042 |
1043 |
1044 |
1045 | -- | A parameter application with lower priority than ($) and direct function application
1046 | (<<) :: (Perch -> Perch) -> Perch -> Perch
1047 | (<<) tag content= tag $ toElem content
1048 |
1049 | infixr 7 <<
1050 |
1051 |
1052 | -- | Append formatting code to a widget
1053 | --
1054 | -- @ getString "hi" <++ H1 << "hi there"@
1055 | --
1056 | -- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators
1057 | (<++) :: Widget a
1058 | -> Perch
1059 | -> Widget a
1060 | (<++) form v= Widget . Transient $ do
1061 | mx <- runView form
1062 | addSData v
1063 | return mx
1064 |
1065 | infixr 6 ++>
1066 | infixr 6 <++
1067 | -- | Prepend formatting code to a widget
1068 | --
1069 | -- @bold << "enter name" ++> getString Nothing @
1070 | --
1071 | -- It has a infix prority: @infixr 6@ higher that '<<<' and most other operators
1072 | (++>) :: Perch -> Widget a -> Widget a
1073 | html ++> w =
1074 | Widget . Transient $ do
1075 | addSData html
1076 | runView w
1077 |
1078 |
1079 |
1080 |
1081 | -- | Add attributes to the topmost tag of a widget
1082 |
1083 | -- it has a fixity @infix 8@
1084 | infixl 8 (fs `attrs` attribs :: Perch)
1091 | return mx
1092 |
1093 |
1094 | instance Attributable (Widget a) where
1095 | (!) widget atrib = Widget $ Transient $ do -- widget do
1104 | e' <- build render e
1105 | jsval <- firstChild e'
1106 | fromJSValUnchecked jsval
1107 |
1108 | instance Attributable (Perch -> Widget a) where
1109 | w ! attr = \p -> w p ! attr
1110 |
1111 | mspan id cont= Perch $ \e -> do
1112 | n <- liftIO $ getName e
1113 | -- alert $ toJSString $ show n
1114 | if n == Just "EVENT"
1115 | then build cont e
1116 | else build (nelem' "event" ! atr "id" id $ cont) e
1117 | where
1118 | nelem' x cont= nelem x `child` cont
1119 | -- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets.
1120 | --
1121 | -- It returns a non valid value.
1122 | noWidget :: Widget a
1123 | noWidget= Control.Applicative.empty
1124 |
1125 | -- | Render raw view formatting. It is useful for displaying information.
1126 | wraw :: Perch -> Widget ()
1127 | wraw x= Widget $ addSData x >> return () -- x ++> return ()
1128 |
1129 | -- | wraw synonym
1130 | rawHtml= wraw
1131 |
1132 | -- | True if the widget has no valid input
1133 | isEmpty :: Widget a -> Widget Bool
1134 | isEmpty w= Widget $ Transient $ do
1135 | mv <- runView w
1136 | return $ Just $ isNothing mv
1137 |
1138 |
1139 | -------------------------
1140 | fromStr = toElem
1141 | -- fromStrNoEncode = toElem
1142 | ftag n v = nelem n `child` v
1143 |
1144 | attrs tag [] = tag
1145 | attrs tag (nv:attribs) = attrs (attr tag nv) attribs
1146 |
1147 | inred msg= ftag "b" msg `attrs` [("style","color:red")]
1148 |
1149 | finput n t v f c=
1150 | let
1151 | tag= input ! atr "type" t ! id n ! atr "value" v
1152 | tag1= if f then tag ! atr "checked" "" else tag
1153 | in case c of Just s -> tag1 ! atr "onclick" s; _ -> tag1
1154 |
1155 |
1156 | ftextarea nam text=
1157 | textarea ! id nam $ text
1158 |
1159 |
1160 | fselect nam list = select ! id nam $ list
1161 |
1162 | foption name v msel=
1163 | let tag= nelem "option" ! atr "value" name `child` v
1164 | in if msel then tag ! atr "selected" "" else tag
1165 |
1166 |
1167 | -- formAction action method1 form = ftag "form" mempty `attrs` [("acceptCharset", "UTF-8")
1168 | -- ,( "action", action)
1169 | -- ,("method", method1)]
1170 | -- `child` form
1171 |
1172 |
1173 | -- flink v str = ftag "a" mempty `attrs` [("href", v)] `child` str
1174 |
1175 |
1176 | ---------------------------
1177 | data EvData = NoData | Click Int (Int, Int) | Mouse (Int, Int) | MouseOut | Key Int deriving (Show,Eq,Typeable)
1178 |
1179 |
1180 |
1181 |
1182 | resetEventData :: Widget ()
1183 | resetEventData= Widget . Transient $ do
1184 | setData $ EventData "Onload" $ toDyn NoData
1185 | return $ Just () -- !!> "RESETEVENTDATA"
1186 |
1187 |
1188 | getEventData :: Widget EventData
1189 | getEventData = Widget getSData <|> return (EventData "Onload" $ toDyn NoData) -- (error "getEventData: event type not expected")
1190 |
1191 | setEventData :: EventData -> Widget ()
1192 | setEventData = Widget . setData
1193 |
1194 |
1195 | class Typeable a => IsEvent a where
1196 | eventName :: a -> JSString
1197 | buildHandler :: Elem -> a ->(EventData -> IO()) -> IO()
1198 |
1199 |
1200 |
1201 | data BrowserEvent= OnLoad | OnUnload | OnChange | OnFocus | OnMouseMove | OnMouseOver |
1202 | OnMouseOut | OnClick | OnDblClick | OnMouseDown | OnMouseUp | OnBlur |
1203 | OnKeyPress | OnKeyUp | OnKeyDown deriving (Show, Typeable)
1204 |
1205 | data EventData= EventData{ evName :: JSString, evData :: Dynamic} deriving (Show,Typeable)
1206 |
1207 | --data OnLoad= OnLoad
1208 | instance IsEvent BrowserEvent where
1209 | -- data EData _= EventData{ evName :: JSString, evData :: EvData} deriving (Show,Typeable)
1210 | eventName e =
1211 | #ifdef ghcjs_HOST_OS
1212 | JS.toLower $ JS.drop 2 (toJSString $ show e) -- const "load"
1213 | #else
1214 | ""
1215 | #endif
1216 | buildHandler elem e io =
1217 | case e of
1218 | OnLoad -> do
1219 | cb <- syncCallback1 ContinueAsync (const $ setDat elem (io
1220 | (EventData (eventName e) $ toDyn NoData)) )
1221 | js_addEventListener elem (eventName e) cb
1222 |
1223 | --data OnUnload = OnUnLoad
1224 | --instance IsEvent OnUnload where
1225 | -- eventName= const "unload"
1226 | -- buildHandler elem e io = do
1227 | OnUnload -> do
1228 | cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
1229 | (EventData (eventName e) $ toDyn NoData) )
1230 | js_addEventListener elem (eventName e) cb
1231 | --data OnChange= OnChange
1232 | --instance IsEvent OnChange where
1233 | -- eventName= const "onchange"
1234 | -- buildHandler elem e io = do
1235 | OnChange -> do
1236 | cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
1237 | (EventData (eventName e) $ toDyn NoData) )
1238 | js_addEventListener elem (eventName e) cb
1239 |
1240 | --data OnFocus= OnFocus
1241 | --instance IsEvent OnFocus where
1242 | -- eventName= const "focus"
1243 | -- buildHandler elem e io = do
1244 | OnFocus -> do
1245 | cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
1246 | (EventData (eventName e) $ toDyn NoData) )
1247 | js_addEventListener elem (eventName e) cb
1248 |
1249 | --data OnBlur= OnBlur
1250 | --instance IsEvent OnBlur where
1251 | -- eventName= const "blur"
1252 | -- buildHandler elem e io = do
1253 | OnBlur -> do
1254 | cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
1255 | (EventData (eventName e)$ toDyn NoData) )
1256 | js_addEventListener elem (eventName e) cb
1257 |
1258 | --data OnMouseMove= OnMouseMove Int Int
1259 | --instance IsEvent OnMouseMove where
1260 | -- eventName= const "mousemove"
1261 | -- buildHandler elem e io= do
1262 | OnMouseMove -> do
1263 | cb <- syncCallback1 ContinueAsync
1264 | (\r -> do
1265 | (x,y) <-fromJSValUnchecked r
1266 | stopPropagation r
1267 | setDat elem $ io $ EventData (eventName e) $ toDyn $ Mouse(x,y))
1268 | js_addEventListener elem (eventName e) cb
1269 |
1270 | --data OnMouseOver= OnMouseOver
1271 | --instance IsEvent OnMouseOver where
1272 | -- eventName= const "mouseover"
1273 | -- buildHandler elem e io= do
1274 | OnMouseOver -> do
1275 | cb <- syncCallback1 ContinueAsync
1276 | (\r -> do
1277 | (x,y) <-fromJSValUnchecked r
1278 | stopPropagation r
1279 | setDat elem $ io $ EventData (nevent e) $ toDyn $ Mouse(x,y))
1280 | js_addEventListener elem (eventName e) cb
1281 |
1282 | --data OnMouseOut= OnMouseOut
1283 | --instance IsEvent OnMouseOut where
1284 | -- eventName= const "mouseout"
1285 | -- buildHandler elem e io = do
1286 | OnMouseOut -> do
1287 | cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
1288 | (EventData (nevent e) $ toDyn $ NoData) )
1289 | js_addEventListener elem (eventName e) cb
1290 |
1291 | --data OnClick= OnClick
1292 | --
1293 | --instance IsEvent OnClick where
1294 | -- eventName= const "click"
1295 | -- buildHandler elem e io= do
1296 | OnClick -> do
1297 | cb <- syncCallback1 ContinueAsync $ \r -> do
1298 | (i,x,y)<- fromJSValUnchecked r
1299 | stopPropagation r
1300 | setDat elem $ io $ EventData (nevent e) $ toDyn $ Click i (x,y)
1301 | js_addEventListener elem (eventName e) cb
1302 |
1303 | --data OnDblClick= OnDblClick
1304 | --instance IsEvent OnDblClick where
1305 | -- eventName= const "dblclick"
1306 | -- buildHandler elem e io= do
1307 | OnDblClick -> do
1308 | cb <- syncCallback1 ContinueAsync $ \r -> do
1309 | (i,x,y)<- fromJSValUnchecked r
1310 | stopPropagation r
1311 | setDat elem $ io $ EventData (nevent e) $ toDyn $ Click i (x,y)
1312 | js_addEventListener elem (eventName e) cb
1313 |
1314 | --
1315 | --data OnMouseDown= OnMouseDown
1316 | --instance IsEvent OnMouseDown where
1317 | -- eventName= const "mousedowm"
1318 | -- buildHandler elem e io= do
1319 | OnMouseDown -> do
1320 | cb <- syncCallback1 ContinueAsync $ \r -> do
1321 | (i,x,y)<- fromJSValUnchecked r
1322 | stopPropagation r
1323 | setDat elem $ io $ EventData (nevent e) $ toDyn $ Click i (x,y)
1324 | js_addEventListener elem (eventName e) cb
1325 |
1326 |
1327 | --data OnMouseUp= OnMouseUp
1328 | --instance IsEvent OnMouseUp where
1329 | -- eventName= const "mouseup"
1330 | -- buildHandler elem e io= do
1331 | OnMouseUp -> do
1332 | cb <- syncCallback1 ContinueAsync $ \r -> do
1333 | (i,x,y)<- fromJSValUnchecked r
1334 | stopPropagation r
1335 | setDat elem $ io $ EventData (nevent e) $ toDyn $ Click i (x,y)
1336 | js_addEventListener elem (eventName e) cb
1337 |
1338 |
1339 | --data OnKeyPress= OnKeyPress
1340 | --instance IsEvent OnKeyPress where
1341 | -- eventName= const "keypress"
1342 | -- buildHandler elem e io = do
1343 | OnKeyPress -> do
1344 | cb <- syncCallback1 ContinueAsync $ \r -> do
1345 | i <- fromJSValUnchecked r
1346 | stopPropagation r
1347 | setDat elem $ io $ EventData (nevent e) $ toDyn $ Key i
1348 | js_addEventListener elem (eventName e) cb
1349 |
1350 | --data OnKeyUp= OnKeyUp
1351 | --instance IsEvent OnKeyUp where
1352 | -- eventName= const "keyup"
1353 | -- buildHandler elem e io = do
1354 | OnKeyUp -> do
1355 | cb <- syncCallback1 ContinueAsync $ \r -> do
1356 | i <- fromJSValUnchecked r
1357 | stopPropagation r
1358 | setDat elem $ io $ EventData (nevent e) $ toDyn $ Key i
1359 | js_addEventListener elem (eventName e) cb
1360 |
1361 | --data OnKeyDown= OnKeyDown
1362 | --instance IsEvent OnKeyDown where
1363 | -- eventName= const "keydown"
1364 | -- buildHandler elem e io = do
1365 | OnKeyDown -> do
1366 | cb <- syncCallback1 ContinueAsync $ \r -> do
1367 | i <- fromJSValUnchecked r
1368 | stopPropagation r
1369 | setDat elem $ io $ EventData (nevent e) $ toDyn $ Key i
1370 | js_addEventListener elem (eventName e) cb
1371 |
1372 | where
1373 |
1374 |
1375 | nevent = eventName
1376 |
1377 | setDat :: Elem -> IO() -> IO ()
1378 | setDat elem action = do
1379 | action -- !!> "begin action"
1380 | return () -- !!> "end action"
1381 |
1382 |
1383 | addSData :: (MonadState EventF m,Typeable a ,Monoid a) => a -> m ()
1384 | addSData y= do
1385 | x <- getData `onNothing` return mempty
1386 | setData (x <> y)
1387 |
1388 | -- stores the identifier of the element to append new rendering
1389 | -- must be an identifier instead of an DOM element since links may reload the whole page
1390 |
1391 | data IdLine= IdLine Int JSString -- deriving(Read,Show)
1392 | data ExecMode= ExecEvent deriving (Eq, Read, Show)
1393 |
1394 | execTemplate= unsafePerformIO $ newIORef False
1395 |
1396 | -- first identifier for an applicative widget expression
1397 | -- needed for applictives in the widget monad that are executed differently than in the TransIO monad
1398 | -- newtype IDNUM = IDNUM Int deriving Show
1399 |
1400 | data Event= forall ev.IsEvent ev => Event ev
1401 |
1402 | data EventSet= EventSet [(JSString, Int, Event, ( EventData -> IO ()))] deriving Typeable
1403 |
1404 | {-# NOINLINE eventRef #-}
1405 | eventRef= unsafePerformIO $ newIORef $ EventSet []
1406 |
1407 | -- | triggers the event that happens in a widget. The effects are the following:
1408 | --
1409 | -- 1)The event reexecutes the monadic sentence where the widget is, (with no re-rendering)
1410 | --
1411 | -- 2) with the result of this reevaluaution of 1), the rest of the monadic computation is executed
1412 | --
1413 | -- 3) update the DOM tree with the rendering generated by the reevaluation of 2).
1414 | --
1415 | -- As usual, If one step of the monadic computation return `empty` (`stop`), the reevaluation finish
1416 | -- So the effect of an event can be restricted as much as you may need.
1417 | --
1418 | -- The part of the monadic expression that is before the event is not evaluated and his rendering is untouched.
1419 | -- (but, at any moment, you can choose the element to be updated in the page using `at`)
1420 |
1421 | -- to store the identifier number of the form elements to be set for that event
1422 |
1423 |
1424 |
1425 | raiseEvent :: IsEvent event => Widget a -> event -> Widget a
1426 | #ifdef ghcjs_HOST_OS
1427 | raiseEvent w event = Widget . Transient $ do
1428 | Alternative cont <- getData `onNothing` (Alternative <$> get)
1429 | let iohandler :: EventData -> IO ()
1430 | iohandler eventdata =do
1431 | runStateT (setData eventdata >> runCont' cont) cont -- !> "runCont INIT"
1432 | return () -- !> "runCont finished"
1433 |
1434 | id <- genNewId
1435 | let id'= JS.takeWhile (/='p') id
1436 | addEventList id' event iohandler
1437 | template <-liftIO $ readIORef execTemplate
1438 | if not template then runView $ addEvent id event iohandler <<< w
1439 | else do
1440 | me <- elemBySeq id' -- !> ("adding event to", id')
1441 | case me of
1442 |
1443 | Nothing -> runView $ addEvent id event iohandler <<< w !> "do not exist, creating elem"
1444 | Just e -> do
1445 | mr <- getData !> "exist adding event to current element"
1446 | when (mr /= Just ExecEvent) $ liftIO (buildHandler e event iohandler)
1447 | r <- runView w
1448 | delData noHtml
1449 | return r
1450 |
1451 | where
1452 | -- to restore event handlers when a new template is loaded
1453 | addEventList a b c= do
1454 | IdLine level _ <- getData `onNothing` error "IdLine not set"
1455 | liftIO $ atomicModifyIORef eventRef $ \(EventSet mlist) ->
1456 | let (cut,rest)= Prelude.span (\(x,l,_,_) -> x < a) mlist
1457 | rest'= Prelude.takeWhile(\(_,l,_,_) -> l <= level) $ tail1 rest
1458 | in (EventSet $ cut ++ (a,level, Event b, c):rest' ,())
1459 | tail1 []= []
1460 | tail1 xs= tail xs
1461 |
1462 |
1463 | runCont' cont= do
1464 | setData ExecEvent -- !> "REPEAT: SET EXECEVENT"
1465 |
1466 | liftIO $ writeIORef execTemplate False
1467 | mr <- runClosure cont
1468 | return ()
1469 | case mr of
1470 | Nothing -> return Nothing
1471 | Just r -> runContinuation cont r -- !> "continue"
1472 |
1473 | -- create an element and add any event handler to it.
1474 | addEvent :: IsEvent a => JSString -> a -> (EventData -> IO()) -> Perch -> Perch
1475 | addEvent id event iohandler be= Perch $ \e -> do
1476 | e' <- build (mspan id be) e
1477 | buildHandler e' event iohandler
1478 | return e
1479 |
1480 |
1481 |
1482 |
1483 | #else
1484 | raiseEvent w _ = w
1485 | #endif
1486 |
1487 | #ifdef ghcjs_HOST_OS
1488 | foreign import javascript unsafe
1489 | "$1.stopPropagation()"
1490 | stopPropagation :: JSVal -> IO ()
1491 | #else
1492 | stopPropagation= undefined
1493 | #endif
1494 |
1495 |
1496 |
1497 | -- | A shorter synonym for `raiseEvent`
1498 | fire :: IsEvent event => Widget a -> event -> Widget a
1499 | fire = raiseEvent
1500 |
1501 | -- | A shorter and smoother synonym for `raiseEvent`
1502 | wake :: IsEvent event => Widget a -> event -> Widget a
1503 | wake = raiseEvent
1504 |
1505 |
1506 | -- | pass trough only if the event is fired in this DOM element.
1507 | -- Otherwise, if the code is executing from a previous event, the computation will stop
1508 | pass :: IsEvent event => Perch -> event -> Widget EventData
1509 | pass v event= do
1510 | resetEventData
1511 | wraw v `wake` event
1512 | e@(EventData typ _) <- getEventData
1513 | guard (eventName event== typ)
1514 |
1515 | return e
1516 |
1517 |
1518 | -- | run the widget as the content of a DOM element
1519 | -- the new rendering is added to the element
1520 | runWidget :: Widget b -> Elem -> IO (Maybe b)
1521 | runWidget action e = do
1522 | (mx, s) <- runTransient . norender $ runWidget' action e
1523 | return mx
1524 |
1525 |
1526 | runWidget' :: Widget b -> Elem -> Widget b
1527 | runWidget' action e = Widget $ Transient $ do
1528 |
1529 | mx <- runView action -- !> "runVidget'"
1530 | render <- getData `onNothing` (return noHtml)
1531 |
1532 | liftIO $ build render e
1533 |
1534 | delData render
1535 | return mx
1536 |
1537 |
1538 | -- | add a header in the tag
1539 | addHeader :: Perch -> IO ()
1540 | #ifdef ghcjs_HOST_OS
1541 | addHeader format= do
1542 | head <- getHead
1543 | build format head
1544 | return ()
1545 | #else
1546 | addHeader _ = return ()
1547 | #endif
1548 |
1549 |
1550 | -- | run the widget as the body of the HTML. It adds the rendering to the body of the document.
1551 | --
1552 | -- Use only for pure client-side applications, like the ones of
1553 | runBody :: Widget a -> IO (Maybe a)
1554 | runBody w= do
1555 | body <- getBody
1556 | runWidget w body
1557 |
1558 |
1559 | newtype AlternativeBranch= Alternative EventF deriving Typeable
1560 |
1561 | -- | executes the computation and add the effect of "hanging" the generated rendering from the one generated by the
1562 | -- previous `render` sentence, or from the body of the document, if there isn't any. If an event happens within
1563 | -- the `render` parameter, it deletes the rendering of all subsequent ones.
1564 | -- so that the sucessive sequence of `render` in the code will reconstruct them again.
1565 | -- However the rendering of elements combined with `<|>` or `<>` or `<*>` are independent.
1566 | -- This allows for full dynamic and composable client-side Web apps.
1567 | render :: Widget a -> TransIO a
1568 | #ifdef ghcjs_HOST_OS
1569 | render mx = Transient $ do
1570 | isTemplate <- liftIO $ readIORef execTemplate !> "RENDER"
1571 | idline1@(IdLine level id1')
1572 | <- getData `onNothing` do
1573 | id1 <- genNewId -- !> "ONNOTHING"
1574 | -- if is being edited or not
1575 | top <- liftIO $ (elemById "edited") `onNothing` getBody
1576 | when (not isTemplate) $ do
1577 | liftIO $ build (span ! id id1 $ noHtml) top
1578 | return ()
1579 | return $ IdLine 0 id1
1580 |
1581 |
1582 |
1583 | ma <- getData
1584 | mw <- gets execMode
1585 |
1586 | id1 <- if (isJust (ma :: Maybe AlternativeBranch) || mw == Parallel ) !> (mw)
1587 | then do
1588 | id3 <- do
1589 | id3 <- genNewId !> "ALTERNATIVE"
1590 | -- create id3 hanging from id1 parent
1591 | if (not isTemplate) then do
1592 | liftIO $ withElem id1' $ build $ this `goParent` (span ! atr "ALTERNATIVE" "" ! id id3 $ noHtml)
1593 | return id3
1594 | else do
1595 | -- template look for real id3
1596 | me <- liftIO $ elemById id1' >>= \x ->
1597 | case x of
1598 | Nothing -> return Nothing
1599 | Just x -> nextSibling x
1600 | case me of
1601 | Nothing -> return id3 -- should not happen
1602 | Just e -> attribute e "id" >>= return . fromJust
1603 |
1604 | setData (IdLine level id3) !> ("setDataAL1",id3)
1605 | delData $ Alternative undefined !> ("alternative, creating", id3)
1606 | return id3
1607 | else setData idline1 >> return id1'
1608 |
1609 | id2 <- genNewId
1610 | n <- gets mfSequence
1611 | -- setData $ IDNUM n
1612 |
1613 |
1614 |
1615 |
1616 | -- r <- runWidgetId' (mx' id1 id2 <++ (span ! id id2 $ noHtml)) id1
1617 | r <-runTrans $ norender mx <***
1618 |
1619 | (Transient $ do
1620 |
1621 | meid2 <- elemBySeq id2 !> ("checking",id1,id2)
1622 |
1623 | case meid2 of
1624 | Nothing -> return ()
1625 | Just eid2 -> do
1626 | -- we are in a template. Look for the true id2 in it
1627 | id2' <- attribute eid2 "id" >>= return . fromJust
1628 | -- let n= read (tail $ JS.unpack $ JS.dropWhile (/= 'p') id2') + 1
1629 | -- liftIO $ writeIORef rprefix n !> ("N",n)
1630 | (setData (IdLine (level +1) id2')) !> ("set IdLine",id2')
1631 |
1632 | execmode <- getData
1633 |
1634 | case execmode of
1635 | Just ExecEvent -> do
1636 | -- an event has happened. Clean previous rendering
1637 | when (isJust meid2) $ liftIO $ do
1638 | deleteSiblings $ fromJust meid2 !> "EVENT"
1639 | clearChildren $ fromJust meid2
1640 | delData ExecEvent
1641 |
1642 | delData noHtml
1643 | return ()
1644 |
1645 | _ -> do
1646 |
1647 | return () !> ("EXECTEMPLATE", isTemplate)
1648 | if isTemplate then delData noHtml else do
1649 | render <- getData `onNothing` (return noHtml) -- !> "TEMPLATE"
1650 |
1651 | eid1 <- liftIO $ elemById id1 `onNothing` error ("not found: " ++ show id1)
1652 |
1653 | liftIO $ build (render <> (span ! id id2 $ noHtml)) eid1
1654 | -- setData (IdLine (level +1) id2 ) !> ("set2 idLine", id2)
1655 | delData render
1656 | return $ Just ())
1657 | if(isJust r)
1658 | then delData (Alternative undefined) >> setData (IdLine (level +1) id2 ) -- !> ("setDataAl",id2)
1659 | else do
1660 | cont <- get
1661 | setData (Alternative cont) !> "SETDATA ALTERNATIVE"
1662 | return r
1663 |
1664 |
1665 | #else
1666 | render (Widget x)= empty
1667 | #endif
1668 |
1669 |
1670 | -- st@(EventF eff e x (fs) d n r applic ch rc bs) <- get
1671 |
1672 | -- let cont= EventF eff e x fs d n r applic ch rc bs
1673 | -- put cont
1674 | -- liftIO $ print ("length1",Prelude.length fs)
1675 |
1676 |
1677 | -- | use this instead of `Transient.Base.option` when runing in the browser
1678 | option :: (Typeable b, Show b) => b -> String -> Widget b
1679 | option x v= wlink x (toElem v) <++ " "
1680 |
1681 |
1682 | --foreign import javascript unsafe "document.body" getBody :: IO Elem
1683 |
1684 |
1685 |
1686 | data UpdateMethod= Append | Prepend | Insert deriving Show
1687 |
1688 | -- | set the tag where subsequent `render` calls will place HTML-DOM element
1689 | setRenderTag :: MonadState EventF m => JSString -> m ()
1690 | setRenderTag id= modifyData' (\(IdLine level _) -> IdLine level id) (IdLine 0 id) >> return ()
1691 |
1692 |
1693 | -- | Run the widget as the content of the element with the given path identifier. The content can
1694 | -- be appended, prepended to the previous content or it can erase the previous content depending on the
1695 | -- update method.
1696 | at :: JSString -> UpdateMethod -> Widget a -> Widget a
1697 | at id method w= setAt id method <<< do
1698 | original@(IdLine level i) <- Widget $ getState <|> error "IdLine not defined"
1699 | setState $ IdLine level $ JS.tail id -- "n0p0"
1700 | w `with` setState original
1701 | where
1702 | with (Widget (Transient x)) (Widget (Transient y))=
1703 | Widget . Transient $ do
1704 | mx <- x
1705 | y
1706 | return mx
1707 |
1708 | setAt :: JSString -> UpdateMethod -> Perch -> Perch
1709 | setAt id method render = liftIO $ case method of
1710 | Insert -> do
1711 |
1712 | forElems_ id $ clear >> render
1713 | return ()
1714 | Append -> do
1715 | forElems_ id render
1716 | return ()
1717 | Prepend -> do
1718 | forElems_ id $ Perch $ \e -> do
1719 | jsval <- getChildren e
1720 | es <- fromJSValUncheckedListOf jsval
1721 | case es of
1722 | [] -> build render e >> return e
1723 | e':es -> do
1724 | span <- newElem "span"
1725 | addChildBefore span e e'
1726 | build render span
1727 | return e
1728 |
1729 | -- | a version of `at` for the Cloud monad.
1730 | at' :: JSString -> UpdateMethod -> Cloud a -> Cloud a
1731 | at' id method w= setAt id method `insert` w
1732 | where
1733 | insert v comp= Cloud . Transient $ do
1734 | rest <- getData `onNothing` return noHtml
1735 | delData rest
1736 | mx <- runTrans $ runCloud comp
1737 | f <- getData `onNothing` return noHtml
1738 | setData $ rest <> v f
1739 | return mx
1740 |
1741 |
1742 |
1743 | #ifdef ghcjs_HOST_OS
1744 |
1745 | foreign import javascript unsafe "$1[$2].toString()" getProp :: Elem -> JSString -> IO JSString
1746 |
1747 |
1748 |
1749 | foreign import javascript unsafe "$1[$2] = $3" setProp :: Elem -> JSString -> JSString -> IO ()
1750 |
1751 | foreign import javascript unsafe "alert($1)" js_alert :: JSString -> IO ()
1752 |
1753 | alert :: (Show a,MonadIO m) => a -> m ()
1754 | alert= liftIO . js_alert . pack . show
1755 |
1756 | foreign import javascript unsafe "document.getElementById($1)" elemByIdDOM
1757 | :: JSString -> IO JSVal
1758 |
1759 | foreign import javascript unsafe "document.getElementById($1).querySelector(\"[id^='\"+$2+\"']\")"
1760 | elemBySeqDOM
1761 | :: JSString -> JSString -> IO JSVal
1762 |
1763 | foreign import javascript unsafe "$1.value" getValueDOM :: Elem -> IO JSVal
1764 | foreign import javascript unsafe "$1.tagName" getNameDOM :: Elem -> IO JSVal
1765 |
1766 | foreign import javascript unsafe "$1.getAttribute($2)"
1767 | attributeDOM
1768 | :: Elem -> JSString -> IO JSVal
1769 | #else
1770 | unpack= undefined
1771 | getProp :: Elem -> JSString -> IO JSString
1772 | getProp = error "getProp: undefined in server"
1773 | setProp :: Elem -> JSString -> JSString -> IO ()
1774 | setProp = error "setProp: undefined in server"
1775 | alert :: (Show a,MonadIO m) => a -> m ()
1776 | alert= liftIO . print
1777 | data Callback a= Callback a
1778 | data ContinueAsync=ContinueAsync
1779 | syncCallback1= undefined
1780 | fromJSValUnchecked= undefined
1781 | fromJSValUncheckedListOf= undefined
1782 | #endif
1783 |
1784 | #ifdef ghcjs_HOST_OS
1785 | foreign import javascript unsafe
1786 | "$1.addEventListener($2, $3,false);"
1787 | js_addEventListener :: Elem -> JSString -> Callback (JSVal -> IO ()) -> IO ()
1788 | #else
1789 | js_addEventListener= undefined
1790 | #endif
1791 |
1792 |
1793 | #ifdef ghcjs_HOST_OS
1794 | foreign import javascript unsafe "document.head" getHead :: IO Elem
1795 | #else
1796 | getHead= undefined
1797 | #endif
1798 |
1799 | #ifdef ghcjs_HOST_OS
1800 | foreign import javascript unsafe "$1.childNodes" getChildren :: Elem -> IO JSVal
1801 | foreign import javascript unsafe "$1.firstChild" firstChild :: Elem -> IO JSVal
1802 | foreign import javascript unsafe "$2.insertBefore($1, $3)" addChildBefore :: Elem -> Elem -> Elem -> IO()
1803 |
1804 | foreign import javascript unsafe
1805 | "while ($1.nextSibling != null) {$1.parentNode.removeChild($1.nextSibling)};"
1806 | deleteSiblings :: Elem -> IO ()
1807 |
1808 | foreign import javascript unsafe
1809 | "$1.nextSibling"
1810 | js_nextSibling :: Elem -> IO JSVal
1811 |
1812 | nextSibling e= js_nextSibling e >>= fromJSVal
1813 |
1814 | #else
1815 |
1816 | type JSVal = ()
1817 | getChildren :: Elem -> IO JSVal
1818 | getChildren= undefined
1819 | firstChild :: Elem -> IO JSVal
1820 | firstChild= undefined
1821 | addChildBefore :: Elem -> Elem -> Elem -> IO()
1822 | addChildBefore= undefined
1823 | #endif
1824 |
1825 |
1826 | ---------------------------- TEMPLATES & NAVIGATION ---------------
1827 |
1828 | editW :: Cloud String
1829 | #ifdef ghcjs_HOST_OS
1830 | editW = onBrowser $ loggedc $ do
1831 |
1832 | local $ do
1833 | liftIO $ forElems_ "body" $ this `child` do
1834 | div ! id "panel" $ noHtml
1835 | div ! id "edit" $ div ! id "edited" $
1836 | center $ font ! atr "size" "2" ! atr "color" "red" $ p $ do
1837 | "Edit this template" <> br
1838 | "Add content, styles, layout" <> br
1839 | "Navigate the links and save the edition for each link" <> br
1840 | "Except this header, don't delete anything unless you know what you do" <> br
1841 | "since the template has been generated by your code" <> br
1842 | installnicedit
1843 | liftIO $threadDelay 1000000
1844 |
1845 |
1846 | -- edit <- liftIO $ elemById "edit" >>= return . fromJust
1847 | -- setState $ IdLine 0 "edit"
1848 |
1849 |
1850 |
1851 | react edit1 (return ()) :: TransIO ()
1852 |
1853 | return "editw"
1854 | where
1855 | font ch= nelem "font" `child` ch
1856 |
1857 | edit1 :: (() -> IO ()) -> IO ()
1858 | edit1 f= do
1859 | Callback cb <- syncCallback1 ContinueAsync $ \ _ -> f()
1860 | js_edit cb
1861 |
1862 |
1863 | installnicedit= do
1864 | liftIO $ addHeader $ script ! id "nic"
1865 | ! atr "type" "text/javascript"
1866 | ! src "http://js.nicedit.com/nicEdit-latest.js"
1867 | $ noHtml
1868 |
1869 | --manageNavigation= do
1870 | -- Callback cb <- syncCallback1 ContinueAsync nav
1871 | -- onpopstate cb
1872 | -- where
1873 | -- nav e= do
1874 | -- location <- fromJSValUnchecked e
1875 | -- alert location
1876 | ----- pushstate
1877 |
1878 | foreign import javascript unsafe
1879 | "window.onpopstate = function(event) { $1(document.location);}"
1880 | onpopstate :: JSVal -> IO ()
1881 |
1882 | foreign import javascript unsafe "window.history.pushState($1,$2,$3)"
1883 | pushState :: JSString -> JSString -> JSString -> IO ()
1884 |
1885 |
1886 |
1887 | foreign import javascript unsafe "window.history.replaceState($1,$2,$3)"
1888 | replaceState :: JSString -> JSString -> JSString -> IO ()
1889 |
1890 | foreign import javascript unsafe "document.getElementById('edit').innerHTML"
1891 | js_getPage :: IO JSVal
1892 | foreign import javascript safe "window.location.pathname" js_path :: IO JSVal
1893 |
1894 | foreign import javascript unsafe
1895 | "var myNicEditor = new nicEditor({fullPanel : true, onSave : $1});myNicEditor.addInstance('edit');myNicEditor.setPanel('panel');"
1896 |
1897 | js_edit :: JSVal -> IO ()
1898 |
1899 | -- "var myNicEditor = new nicEditor({fullPanel : true, onSave : function(content, id, instance) {myNicEditor.removeInstance('edit');myNicEditor.removePanel('panel');}});myNicEditor.addInstance('edit');myNicEditor.setPanel('panel');"
1900 |
1901 | #else
1902 | --manageNavigation :: IO ()
1903 | --manageNavigation = undefined
1904 | pushState _ _ _= empty
1905 | replaceState _ _ _= empty
1906 | editW = onBrowser $ local empty -- !> "editW"
1907 | js_getPage= empty
1908 | js_path= empty
1909 | #endif
1910 |
1911 | -- | edit and save the rendering of the widgets.
1912 | --
1913 | -- The edited content may be saved to a file with th current route by the save option of the editor.
1914 | -- `tlink` will load this page. Also when this route is requested, the server will return this page.
1915 | edit w= do
1916 | b <- localIO $ elemById "edited" >>= return . isJust
1917 |
1918 | if b then do
1919 | local $ do -- modify (\s -> s{mfSequence=2}) -- *******
1920 | -- liftIO $ writeIORef rprefix 2
1921 | -- setData ExecTemplate !> "SET EXECTEMPLATE 1"
1922 | liftIO $ writeIORef execTemplate True
1923 | -- setData $ IdLine 0 "n0p0"
1924 | -- local addPrefix
1925 | w
1926 | else do
1927 | edit' <|> w
1928 | where
1929 | edit' = do
1930 |
1931 | editW
1932 |
1933 | page <- localIO $ js_getPage >>= fromJSValUnchecked :: Cloud String
1934 | url <- localIO $ js_path >>= fromJSValUnchecked :: Cloud String
1935 |
1936 | atRemote $ localIO $ do
1937 | #ifdef ghcjs_HOST_OS
1938 | return ()
1939 | #else
1940 | let url' = if url =="/" then "/index.html" else url :: String
1941 | let page'= fullpage page
1942 | -- return () !> ("----->",url')
1943 | write ("static/out.jsexe"++ url') page'
1944 |
1945 | -- return () !> "WRITTTEN"
1946 | empty
1947 |
1948 | where
1949 | write filename page=
1950 | writeFile filename page
1951 | `catch` (\e -> when ( isDoesNotExistError e) $ do
1952 | let dir= take (1+(last $ elemIndices '/' filename)) filename
1953 | return () -- !> ("create",dir)
1954 | createDirectoryIfMissing True dir
1955 | write filename page)
1956 |
1957 | fullpage page=
1958 | ""
1959 | ++ page ++ "