diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,27 +1,27 @@ -Copyright (c) Alberto Gómez Corona 2008 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. +Copyright (c) Alberto Gómez Corona 2008 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,6 +1,6 @@ -#!/usr/bin/runhaskell -> module Main where -> import Distribution.Simple -> main :: IO () -> main = defaultMain - +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/hplayground.cabal b/hplayground.cabal --- a/hplayground.cabal +++ b/hplayground.cabal @@ -1,5 +1,5 @@ name: hplayground -version: 0.1.2.8 +version: 0.1.2.9 cabal-version: >=1.8 build-type: Simple license: BSD3 @@ -27,7 +27,7 @@ if flag(haste-inst) build-depends: base >4.0 && <5, transformers -any, containers -any, - data-default -any, monads-tf -any, haste-lib -any, + data-default -any, monads-tf -any, haste-lib -any, haste-perch >= 0.1.0.5 exposed: True buildable: True diff --git a/src/Haste/HPlay/View.hs b/src/Haste/HPlay/View.hs --- a/src/Haste/HPlay/View.hs +++ b/src/Haste/HPlay/View.hs @@ -218,7 +218,7 @@ modify $ \st -> st{fixed= was} return r --- override static locally to permit dynamic effects inside a static widget. It is useful +-- | override static locally to permit dynamic effects inside a static widget. It is useful -- when a monadic Widget computation which perform no rendering changes has a to do some update: -- -- > launchMissiles= static $ do @@ -1028,9 +1028,13 @@ resetEventData= modify $ \st -> st{ lastEvent= toDyn $ EventData "Onload" NoData} -getEventData :: (Typeable a, StateType m ~ MFlowState, MonadState m) => m a -getEventData = gets lastEvent >>= return . (flip fromDyn) (error "getEventData: event type not expected") +getEventData :: Typeable a => Widget a +getEventData = View $ do + mr <- getMEventData + return $ FormElm noHtml mr +-- gets lastEvent >>= return . (flip fromDyn) (error "getEventData: event type not expected") + setEventData :: (Typeable a, StateType m ~ MFlowState, MonadState m) => a-> m () setEventData dat= modify $ \st -> st{ lastEvent= toDyn dat} @@ -1262,11 +1266,11 @@ -- | 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 :: String -> UpdateMethod -> Widget a -> Widget a -at ident= at' ('#':ident) - --- A generalized version of `at` that include the widget rendering at the elements that meet the selector criteria +-- update method. +at :: String -> UpdateMethod -> Widget a -> Widget a +at ident= at' ('#':ident) + +-- | A generalized version of `at` that include the widget rendering at the elements that meet the selector criteria -- (the first parameter) in the style of jQuery. the selector can match classes etc not only identifiers. at' :: String -> UpdateMethod -> Widget a -> Widget a at' id method w= View $ do @@ -1295,8 +1299,8 @@ responseAjax :: IORef [(String,Maybe JSString)] responseAjax = unsafePerformIO $ newIORef [] - + -- | Invoke AJAX. `ToJSString` is a class coverter to-from JavaScript strings -- `(a,b)` are the lists of parameters, a is normally `String` or `JSString`. -- JSON is also supported for `b` and `c`. If you want to handle your data types, make a instance of @@ -1364,12 +1368,12 @@ -> JSString -- POST data -> JSFun (Maybe JSString -> IO ()) -> IO () -foreign import ccall jsSetCB :: Elem -> JSString -> JSFun a -> IO Bool +foreign import ccall jsSetCB :: Elem -> JSString -> JSFun a -> IO Bool #else -ajaxReq= undefined +ajaxReq= undefined jsSetCB= undefined #endif - + listen :: JSType event => Elem -> event -> a -> IO Bool listen e event f= jsSetCB e (toJSString event) (mkCallback $! f) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,361 +1,361 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Main where -import Haste -import Haste.Foreign -import Haste.Graphics.Canvas -import Haste.HPlay.View -import Haste.HPlay.Cell as Cell -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class -import Data.Monoid -import Data.Typeable -import Prelude hiding (div,all,id,print,getChar, putStr, putStrLn,getLine) -import qualified Data.Map as V -import Data.Maybe -import Data.List(isInfixOf) - - -main= runBody $ do -- PerchM monad - h1 ! style "text-align:center" $ "hplayground examples" - h3 $ center $ do - a ! href "https://github.com/agocorona/hplayground" $ "Git repository" - toElem " " - a ! href "https://github.com/agocorona/hplayground/blob/master/src/Main.hs" $ "Examples code" - toElem " " - a ! href "haskell-web.blogspot.com.es/2014/07/hplayground-translate-your-console.html" $ "Article" - ++> do -- Widget monad - (table ! style "border-collapse:collapse" - <<<(tr ! style "vertical-align:top" - <<< ( tds <<< sumTwo - <|> tds <<< sumfold 3 - <|> tds <<< sumRecursive) - <|> tr ! style "vertical-align:top" - <<< (tds <<< (counter 3 <|> buttons <|> linksample) - <|> tds <<< sumCell - <|> tds <<< showpascal 4) - <|> tr ! style "vertical-align:top" - <<< (tds <<< formWidget - <|> tds <<< palindrome - <|> tds <<< naiveTodo) - <|> tr ! style "vertical-align:top" - <<< (tds <<< drawcanvas - <|> tds <<< gallery - <|> tds <<< mouse ) - - )) - - <++ b << "bottom of the page" - where - tds= td ! style "padding:15px;border-style:dotted" - --- Don't be scared by the operators: --- <|> is the Alternantive combinator, to combine Widget() entries --- and the <<< combinator simply encloses a widget within a HTML tag. --- ++> prepend HTML to a widget --- <++ postpend it - - - -sumTwo :: Widget () -sumTwo = p "This widget sum two numbers and append the result. Using applicative and monadic expressions" ++> - (p <<< do - r <- (+) <$> fromStr "first number" ++> br - ++> inputInt Nothing `fire` OnKeyUp <++ br - <*> fromStr "second number " ++> br - ++> inputInt Nothing `fire` OnKeyUp <++ br - p <<< fromStr "result: " ++> b (show r) ++> return()) - - where - less3 x= if x < 3 then return Nothing else return . Just $ b " no more than 2 please" - -sumRecursive :: Widget () -sumRecursive = p "This widget sum recursively n numbers. When enters 0, present the result" ++> sumr 0 - where - sumr r=do - r' <- inputInt Nothing `fire` OnKeyUp - if r'== 0 - then br ++> fromStr "result: " ++> b (show r) ++> noWidget - else do - b (show $ r+r') ++> br ++> return () - sumr (r+r') - -sumfold :: Int -> Widget () -sumfold n = p ("This widget sum "++ show n ++" numbers and append the result using a fold") ++> - (p <<< do - r <- foldl (<>) (return 0) . take n $ repeat $ inputInt Nothing `fire` OnKeyUp <++ br - br ++> fromStr "result: " ++> b (show r) ++> return ()) - -instance Monoid Int where - mappend= (+) - mempty= 0 - - - -newtype Counter= Counter Int deriving Typeable - -counter n = p "Two counters. One is pure and recursive, the other is stateful" - ++> br ++> (center <<< (counter1 n <|> counter2 n)) - - where - -- a "pure" counter - counter1 :: Int -> Widget () - counter1 n= (b (show n) ++> onemore) `wcallback` (const $ counter1 $ n +1) - - onemore= submitButton "+" `fire` OnClick - - - -- a stateful counter - counter2 n = do - onemore -- isEmpty (getSData :: Widget Counter ) <|> (onemore >> return True) - Counter n <- getSData <|> return (Counter n) - wraw $ b (show n) - setSessionData . Counter $ n +1 - - - -sumCell :: Widget () - -sumCell = p "This widget sum recursively n numbers, but remember the\ - \ previos entries when one entry is edited" ++> sumr 0 0 - - where - sumr i r=do - r' <- cell i - b (show $ r+r') ++> br ++> return () - sumr (i +1) (r+r') - - cell i= do - stored <- Just <$> getNumber i <|> return Nothing - r' <- inputInt stored `fire` OnKeyUp <|> fromM stored - addNumber i r' - return r' - where - addNumber i x= do - xs <- getSData <|> return V.empty - setSData $ V.insert i x xs - - getNumber :: Int -> Widget Int - getNumber i= do - xs <- getSData - case V.lookup i xs of - Nothing -> empty - Just x -> return x - - fromM Nothing = empty - fromM (Just x) = return x - - - --- pascal triangle http://www.haskell.org/haskellwiki/Blow_your_mind - -pascal = iterate (\row -> zipWith (+) ([0] ++ row) (row ++ [0])) [1] :: [[Int]] - -showpascal n= p << ("Show " ++ show n ++ " rows of the Pascal triangle ") - ++> mconcat[p ! style "text-align:center" $ row | row <- take n pascal] - ++> empty -- the applicative empty === noWidget - - - - -drawcanvas :: Widget () -drawcanvas= - p << "This example draw a function of x between 10 and -10. You can define the function\ - \ using javascript expressions" ++> - - (center <<< do - let initial= "x*x+x+10;" - sanitize str= if isInfixOf "alert" str then initial else str - expr <- inputString (Just initial) `fire` OnKeyUp <++ br <|> return initial - wraw $ canvas ! id "canvas" $ noHtml - wraw $ draw $sanitize expr) - - - where - - evalFormula :: String -> IO Double - evalFormula= ffi $ toJSString "(function(exp){ return eval(exp);})" - - draw expr= liftIO $ do - Just can <- getCanvasById "canvas" - let range= [-10..10] - exprs = Prelude.map (\v -> subst 'x' (show v) expr) range - ps <- mapM evalFormula exprs - render can $ scale (3,1) $ translate (50,130) $ rotate pi $ stroke $do - line (-10,0) (10,0) - line (0,30) (0,-30) - path $ zip range ps - - subst _ _ []= [] - subst c v (c':cs) - | c==c' = v++ subst c v cs - | otherwise= c':subst c v cs - - - -newtype GalleryIndex= G Int deriving Typeable - -gallery :: Widget () -gallery = p "this example show a image gallery. It advances each 20 seconds and by\ - \ pressing the button" ++> - (wtimeout 20000 $ do - G i <- getSData <|> return (G 0) - let i' = if i == length gall-1 then 0 else i+1 - setSData $ G i' - wraw $ do - img ! src (gall !! i) ! width "100%" ! height "100%" -- raw Perch code - br - submitButton ">" `fire` OnClick - `wcallback` \_ -> gallery) - - where - gall=["http://almaer.com/blog/uploads/interview-haskell.png" - ,"https://encrypted-tbn3.gstatic.com/images?q=tbn:ANd9GcQmmC4kV3NPFIpGL_x4H_iHG_p-c93DGjWfkxVtjxEFVng7A8o-nw" - ,"https://encrypted-tbn3.gstatic.com/images?q=tbn:ANd9GcQ_ywj-zxDq3h_B4l48XHsjTywrdbK5egxvhxkYJ1HOkDFXd_-H" - ,"https://encrypted-tbn3.gstatic.com/images?q=tbn:ANd9GcS53axpzkDyzEUAdaIP3YsaHuR-_YqN9qFK3W4bp_D2OBZfW5BU_Q" - ,"https://encrypted-tbn1.gstatic.com/images?q=tbn:ANd9GcSfP70npv4FOrkBjScP0tVu2t3veSNoFQ6MMxX6LDO8kldNeu-DxQ" - ,"https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcRAgKkpDyzk8kdIqk5ECsZ14XgbpBzyWFvrCrHombkSBAUn6jFo" - ] - - -mouse :: Widget () -mouse= do - wraw (div ! style "height:100px;background-color:lightgreen;position:relative" - $ h1 "Mouse events here") - `fire` OnMouseOut - `fire` OnMouseOver - `fire` OnMouseDown - `fire` OnMouseMove - `fire` OnMouseUp - `fire` OnClick - `fire` OnDblClick - `fire` OnKeyPress - `fire` OnKeyDown - `fire` OnKeyUp - evdata <- getEventData - wraw $ p << ( (evName evdata) ++" "++ show (evData evdata)) - -linksample= br ++> wlink "Hi!" (toElem "This link say Hi!")`fire` OnClick >>= \r -> wraw( b (" returns "++ r)) - -buttons= p "Different input elements:" ++> checkButton - **> br ++> br - ++> radio - **> br ++> br - ++> select - <++ br - where - checkButton=do - rs <- getCheckBoxes( - ((setCheckBox False "Red" <++ b "red") `fire` OnClick) - <> ((setCheckBox False "Green" <++ b "green") `fire` OnClick) - <> ((setCheckBox False "blue" <++ b "blue") `fire` OnClick)) - wraw $ fromStr " returns: " <> b (show rs) - - radio= do - r <- getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]] - - wraw $ fromStr " returns: " <> b ( show r ) - - select= do +{-# LANGUAGE DeriveDataTypeable #-} +module Main where +import Haste +import Haste.Foreign +import Haste.Graphics.Canvas +import Haste.HPlay.View +import Haste.HPlay.Cell as Cell +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Data.Monoid +import Data.Typeable +import Prelude hiding (div,all,id,print,getChar, putStr, putStrLn,getLine) +import qualified Data.Map as V +import Data.Maybe +import Data.List(isInfixOf) + + +main= runBody $ do -- PerchM monad + h1 ! style "text-align:center" $ "hplayground examples" + h3 $ center $ do + a ! href "https://github.com/agocorona/hplayground" $ "Git repository" + toElem " " + a ! href "https://github.com/agocorona/hplayground/blob/master/src/Main.hs" $ "Examples code" + toElem " " + a ! href "haskell-web.blogspot.com.es/2014/07/hplayground-translate-your-console.html" $ "Article" + ++> do -- Widget monad + (table ! style "border-collapse:collapse" + <<<(tr ! style "vertical-align:top" + <<< ( tds <<< sumTwo + <|> tds <<< sumfold 3 + <|> tds <<< sumRecursive) + <|> tr ! style "vertical-align:top" + <<< (tds <<< (counter 3 <|> buttons <|> linksample) + <|> tds <<< sumCell + <|> tds <<< showpascal 4) + <|> tr ! style "vertical-align:top" + <<< (tds <<< formWidget + <|> tds <<< palindrome + <|> tds <<< naiveTodo) + <|> tr ! style "vertical-align:top" + <<< (tds <<< drawcanvas + <|> tds <<< gallery + <|> tds <<< mouse ) + + )) + + <++ b << "bottom of the page" + where + tds= td ! style "padding:15px;border-style:dotted" + +-- Don't be scared by the operators: +-- <|> is the Alternantive combinator, to combine Widget() entries +-- and the <<< combinator simply encloses a widget within a HTML tag. +-- ++> prepend HTML to a widget +-- <++ postpend it + + + +sumTwo :: Widget () +sumTwo = p "This widget sum two numbers and append the result. Using applicative and monadic expressions" ++> + (p <<< do + r <- (+) <$> fromStr "first number" ++> br + ++> inputInt Nothing `fire` OnKeyUp <++ br + <*> fromStr "second number " ++> br + ++> inputInt Nothing `fire` OnKeyUp <++ br + p <<< fromStr "result: " ++> b (show r) ++> return()) + + where + less3 x= if x < 3 then return Nothing else return . Just $ b " no more than 2 please" + +sumRecursive :: Widget () +sumRecursive = p "This widget sum recursively n numbers. When enters 0, present the result" ++> sumr 0 + where + sumr r=do + r' <- inputInt Nothing `fire` OnKeyUp + if r'== 0 + then br ++> fromStr "result: " ++> b (show r) ++> noWidget + else do + b (show $ r+r') ++> br ++> return () + sumr (r+r') + +sumfold :: Int -> Widget () +sumfold n = p ("This widget sum "++ show n ++" numbers and append the result using a fold") ++> + (p <<< do + r <- foldl (<>) (return 0) . take n $ repeat $ inputInt Nothing `fire` OnKeyUp <++ br + br ++> fromStr "result: " ++> b (show r) ++> return ()) + +instance Monoid Int where + mappend= (+) + mempty= 0 + + + +newtype Counter= Counter Int deriving Typeable + +counter n = p "Two counters. One is pure and recursive, the other is stateful" + ++> br ++> (center <<< (counter1 n <|> counter2 n)) + + where + -- a "pure" counter + counter1 :: Int -> Widget () + counter1 n= (b (show n) ++> onemore) `wcallback` (const $ counter1 $ n +1) + + onemore= submitButton "+" `fire` OnClick + + + -- a stateful counter + counter2 n = do + onemore -- isEmpty (getSData :: Widget Counter ) <|> (onemore >> return True) + Counter n <- getSData <|> return (Counter n) + wraw $ b (show n) + setSessionData . Counter $ n +1 + + + +sumCell :: Widget () + +sumCell = p "This widget sum recursively n numbers, but remember the\ + \ previos entries when one entry is edited" ++> sumr 0 0 + + where + sumr i r=do + r' <- cell i + b (show $ r+r') ++> br ++> return () + sumr (i +1) (r+r') + + cell i= do + stored <- Just <$> getNumber i <|> return Nothing + r' <- inputInt stored `fire` OnKeyUp <|> fromM stored + addNumber i r' + return r' + where + addNumber i x= do + xs <- getSData <|> return V.empty + setSData $ V.insert i x xs + + getNumber :: Int -> Widget Int + getNumber i= do + xs <- getSData + case V.lookup i xs of + Nothing -> empty + Just x -> return x + + fromM Nothing = empty + fromM (Just x) = return x + + + +-- pascal triangle http://www.haskell.org/haskellwiki/Blow_your_mind + +pascal = iterate (\row -> zipWith (+) ([0] ++ row) (row ++ [0])) [1] :: [[Int]] + +showpascal n= p << ("Show " ++ show n ++ " rows of the Pascal triangle ") + ++> mconcat[p ! style "text-align:center" $ row | row <- take n pascal] + ++> empty -- the applicative empty === noWidget + + + + +drawcanvas :: Widget () +drawcanvas= + p << "This example draw a function of x between 10 and -10. You can define the function\ + \ using javascript expressions" ++> + + (center <<< do + let initial= "x*x+x+10;" + sanitize str= if isInfixOf "alert" str then initial else str + expr <- inputString (Just initial) `fire` OnKeyUp <++ br <|> return initial + wraw $ canvas ! id "canvas" $ noHtml + wraw $ draw $sanitize expr) + + + where + + evalFormula :: String -> IO Double + evalFormula= ffi $ toJSString "(function(exp){ return eval(exp);})" + + draw expr= liftIO $ do + Just can <- getCanvasById "canvas" + let range= [-10..10] + exprs = Prelude.map (\v -> subst 'x' (show v) expr) range + ps <- mapM evalFormula exprs + render can $ scale (3,1) $ translate (50,130) $ rotate pi $ stroke $do + line (-10,0) (10,0) + line (0,30) (0,-30) + path $ zip range ps + + subst _ _ []= [] + subst c v (c':cs) + | c==c' = v++ subst c v cs + | otherwise= c':subst c v cs + + + +newtype GalleryIndex= G Int deriving Typeable + +gallery :: Widget () +gallery = p "this example show a image gallery. It advances each 20 seconds and by\ + \ pressing the button" ++> + (wtimeout 20000 $ do + G i <- getSData <|> return (G 0) + let i' = if i == length gall-1 then 0 else i+1 + setSData $ G i' + wraw $ do + img ! src (gall !! i) ! width "100%" ! height "100%" -- raw Perch code + br + submitButton ">" `fire` OnClick + `wcallback` \_ -> gallery) + + where + gall=["http://almaer.com/blog/uploads/interview-haskell.png" + ,"https://encrypted-tbn3.gstatic.com/images?q=tbn:ANd9GcQmmC4kV3NPFIpGL_x4H_iHG_p-c93DGjWfkxVtjxEFVng7A8o-nw" + ,"https://encrypted-tbn3.gstatic.com/images?q=tbn:ANd9GcQ_ywj-zxDq3h_B4l48XHsjTywrdbK5egxvhxkYJ1HOkDFXd_-H" + ,"https://encrypted-tbn3.gstatic.com/images?q=tbn:ANd9GcS53axpzkDyzEUAdaIP3YsaHuR-_YqN9qFK3W4bp_D2OBZfW5BU_Q" + ,"https://encrypted-tbn1.gstatic.com/images?q=tbn:ANd9GcSfP70npv4FOrkBjScP0tVu2t3veSNoFQ6MMxX6LDO8kldNeu-DxQ" + ,"https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcRAgKkpDyzk8kdIqk5ECsZ14XgbpBzyWFvrCrHombkSBAUn6jFo" + ] + + +mouse :: Widget () +mouse= do + wraw (div ! style "height:100px;background-color:lightgreen;position:relative" + $ h1 "Mouse events here") + `fire` OnMouseOut + `fire` OnMouseOver + `fire` OnMouseDown + `fire` OnMouseMove + `fire` OnMouseUp + `fire` OnClick + `fire` OnDblClick + `fire` OnKeyPress + `fire` OnKeyDown + `fire` OnKeyUp + evdata <- getEventData + wraw $ p << ( (evName evdata) ++" "++ show (evData evdata)) + +linksample= br ++> wlink "Hi!" (toElem "This link say Hi!")`fire` OnClick >>= \r -> wraw( b (" returns "++ r)) + +buttons= p "Different input elements:" ++> checkButton + **> br ++> br + ++> radio + **> br ++> br + ++> select + <++ br + where + checkButton=do + rs <- getCheckBoxes( + ((setCheckBox False "Red" <++ b "red") `fire` OnClick) + <> ((setCheckBox False "Green" <++ b "green") `fire` OnClick) + <> ((setCheckBox False "blue" <++ b "blue") `fire` OnClick)) + wraw $ fromStr " returns: " <> b (show rs) + + radio= do + r <- getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]] + + wraw $ fromStr " returns: " <> b ( show r ) + + select= do r <- getSelect ( setOption "red" (fromStr "red") - <|> setOption "green" (fromStr "green") - <|> setOption "blue" (fromStr "blue")) - `fire` OnClick - - wraw $ fromStr " returns: " <> b ( show r ) - -formWidget= center <<< do -- PerchM monad - p "Fields of a form appear in sequence. \ - \Some of the fields trigger events instantly. Some others use a button to trigger them. \ - \It also contains option buttons, radio buttons etc" - p $ do - toElem "This formulary is the same than the one " - a ! href "http://mflowdemo.herokuapp.com/noscript/monadicwidgets/combination" - $ "run in the server by MFlow" - ++> - do - (n,s) <- (,) <$> p << "Who are you? " - ++> getString Nothing getString Nothing getRadio[radiob "work?",radiob "study?"] <++ br - - r<- case flag of - "work?" -> Left <$> b << "do you enjoy your work? " - ++> getBool True "yes" "no" - <** submitButton "ok" `fire` OnClick <++ br - - "study?"-> Right <$> b << "do you study in " - ++> getRadio[radiob "University" - ,radiob "High School"] - - p << ("You are "++n++" "++s) - - ++> case r of - Left fl -> p << ("You work and it is " ++ show fl ++ " that you enjoy your work") - ++> noWidget - - Right stu -> p << ("You study at the " ++ stu) - ++> noWidget - - where - hint s= [("placeholder",s)] - radiob s n= wlabel (fromStr s) $ setRadioActive s n - - -palindrome= p << "To search palindromes: one box present the other's reversed. It is also\ - \ an example of cell usage" ++> do - let entry= boxCell "entry" :: Cell String - revEntry= boxCell "revEntry" - - r <- center <<< ((mk entry Nothing `fire` OnKeyUp >>= return . Left) <++ br <|> - (mk revEntry Nothing `fire` OnKeyUp >>= return . Right)) - - case r of - Left s -> do - r <- Cell.get entry >>= return . reverse - revEntry .= r - Right s -> do - r' <- Cell.get revEntry >>= return . reverse - entry .= r' - - -newtype Tasks = Tasks [String] deriving Typeable - -data TaskAction = Done | Destroy - -naiveTodo= do - p $ do -- PerchM monad - toElem "Work in progress for a todo application to be added to " - a ! href "http://todomvc.com" $ "todomvc.com" - ++> todos - - where - - todos= center <<< h1 "todos" ++> - do - let entry = boxCell "todo" - task <- mk entry Nothing `fire` OnKeyUp - EventData _ (Key k) <- getEventData - when( k == 13) $ do - entry .= "" - Tasks tasks <- getSData <|> return (Tasks []) - setSData . Tasks $ task:tasks - - at "list" Insert $ foldl (<|>) mempty [ display t | t <- (task:tasks)] - return () - <|> - wraw (div ! id "list" $ noHtml) - - - - display task= li <<< (do - ch <- getCheckBoxes $ setCheckBox False "check" `fire` OnClick - case ch of - ["check"] -> wraw $ b ! style "text-decoration:line-through;" $ task - _ -> wraw $ b task - - ) - - + <|> setOption "green" (fromStr "green") + <|> setOption "blue" (fromStr "blue")) + `fire` OnClick + + wraw $ fromStr " returns: " <> b ( show r ) + +formWidget= center <<< do -- PerchM monad + p "Fields of a form appear in sequence. \ + \Some of the fields trigger events instantly. Some others use a button to trigger them. \ + \It also contains option buttons, radio buttons etc" + p $ do + toElem "This formulary is the same than the one " + a ! href "http://mflowdemo.herokuapp.com/noscript/monadicwidgets/combination" + $ "run in the server by MFlow" + ++> + do + (n,s) <- (,) <$> p << "Who are you? " + ++> getString Nothing getString Nothing getRadio[radiob "work?",radiob "study?"] <++ br + + r<- case flag of + "work?" -> Left <$> b << "do you enjoy your work? " + ++> getBool True "yes" "no" + <** submitButton "ok" `fire` OnClick <++ br + + "study?"-> Right <$> b << "do you study in " + ++> getRadio[radiob "University" + ,radiob "High School"] + + p << ("You are "++n++" "++s) + + ++> case r of + Left fl -> p << ("You work and it is " ++ show fl ++ " that you enjoy your work") + ++> noWidget + + Right stu -> p << ("You study at the " ++ stu) + ++> noWidget + + where + hint s= [("placeholder",s)] + radiob s n= wlabel (fromStr s) $ setRadioActive s n + + +palindrome= p << "To search palindromes: one box present the other's reversed. It is also\ + \ an example of cell usage" ++> do + let entry= boxCell "entry" :: Cell String + revEntry= boxCell "revEntry" + + r <- center <<< ((mk entry Nothing `fire` OnKeyUp >>= return . Left) <++ br <|> + (mk revEntry Nothing `fire` OnKeyUp >>= return . Right)) + + case r of + Left s -> do + r <- Cell.get entry >>= return . reverse + revEntry .= r + Right s -> do + r' <- Cell.get revEntry >>= return . reverse + entry .= r' + + +newtype Tasks = Tasks [String] deriving Typeable + +data TaskAction = Done | Destroy + +naiveTodo= do + p $ do -- PerchM monad + toElem "Work in progress for a todo application to be added to " + a ! href "http://todomvc.com" $ "todomvc.com" + ++> todos + + where + + todos= center <<< h1 "todos" ++> + do + let entry = boxCell "todo" + task <- mk entry Nothing `fire` OnKeyUp + EventData _ (Key k) <- getEventData + when( k == 13) $ do + entry .= "" + Tasks tasks <- getSData <|> return (Tasks []) + setSData . Tasks $ task:tasks + + at "list" Insert $ foldl (<|>) mempty [ display t | t <- (task:tasks)] + return () + <|> + wraw (div ! id "list" $ noHtml) + + + + display task= li <<< (do + ch <- getCheckBoxes $ setCheckBox False "check" `fire` OnClick + case ch of + ["check"] -> wraw $ b ! style "text-decoration:line-through;" $ task + _ -> wraw $ b task + + ) + +