Permalink
Browse files

Additional conversion from TP and MonadTP to IO. Concert Buttons exam…

…ple and test that it still works. #17
  • Loading branch information...
HeinrichApfelmus committed Apr 11, 2013
1 parent 8870c80 commit 3718a8b4cc2cade9cebc446805bd4953ddbec8fe
View
@@ -8,64 +8,64 @@ import Control.Monad.Extra
import Control.Monad.IO.Class
#ifdef CABAL
import "threepenny-gui" Graphics.UI.Threepenny
+import "threepenny-gui" Graphics.UI.Threepenny.Browser
#else
import Graphics.UI.Threepenny
+import Graphics.UI.Threepenny.Browser
#endif
-- | Main entry point. Starts a TP server.
main :: IO ()
main = serve Config
{ tpPort = 10001
- , tpRun = runTP
- , tpWorker = worker
- , tpInitHTML = Just "buttons.html"
+ , tpWorker = \window -> setup window >> handleEvents window
+ , tpInitHTML = Nothing
, tpStatic = "wwwroot"
}
-- | A per-user worker thread. Each user session has a thread.
-worker :: MonadTP m => m ()
-worker = do
- setTitle "Buttons"
- body <- getBody
- wrap <- newElement "div" >>= setAttr "class" "wrap" >>= appendTo body
- greet wrap
- makeButtons wrap
- linkage wrap
- handleEvents
+setup :: Window -> IO ()
+setup w = do
+ setTitle w "Buttons"
+ body <- getBody w
+ wrap <- newElement w "div" >>= setAttr "class" "wrap" >>= appendTo body
+ greet w wrap
+ makeButtons w wrap
+ linkage w wrap
-greet :: MonadTP m => Element -> m ()
-greet body = do
- header <- newElement "h1"
+greet :: Window -> Element -> IO ()
+greet w body = do
+ header <- newElement w "h1"
appendTo body header
setText "Hello, Haskell!" header
- greeting <- newElement "div"
+ greeting <- newElement w "div"
setText "Try the buttons below, they hover and click." greeting
appendTo body greeting
return ()
-linkage :: MonadTP m => Element -> m ()
-linkage body = do
- p <- newElementText body "p" ""
- vex <- link "https://github.com/chrisdone/ji/blob/master/examples/Buttons.hs"
+linkage :: Window -> Element -> IO ()
+linkage w body = do
+ p <- newElementText w body "p" ""
+ vex <- link w "https://github.com/chrisdone/ji/blob/master/examples/Buttons.hs"
"View source code" >>= setAttr "class" "view-source"
appendTo p vex
return ()
-makeButtons :: MonadTP m => Element -> m ()
-makeButtons body = do
- list <- newElement "ul"
+makeButtons :: Window -> Element -> IO ()
+makeButtons w body = do
+ list <- newElement w "ul"
setAttr "class" "buttons-list" list
- button1 <- appendToButton body button1Title
- button2 <- appendToButton body button2Title
+ button1 <- appendToButton w body button1Title
+ button2 <- appendToButton w body button2Title
appendTo body list
onHover button1 $ \_ -> do setText (button1Title ++ " [hover]") button1; return ()
onBlur button1 $ \_ -> do setText button1Title button1; return ()
onClick button1 $ \_ -> do
- li <- newElement "li"
- liftIO $ threadDelay $ 1000 * 1000 * 1
+ li <- newElement w "li"
+ threadDelay $ 1000 * 1000 * 1
setText (button1Title ++ " [pressed]") button1
setHtml "<b>Delayed</b> result!" li
appendTo list li
@@ -74,7 +74,7 @@ makeButtons body = do
onHover button2 $ \_ -> do setText (button2Title ++ " [hover]") button2; return ()
onBlur button2 $ \_ -> do setText button2Title button2; return ()
onClick button2 $ \_ -> do
- li <- newElement "li"
+ li <- newElement w "li"
setText (button2Title ++ " [pressed]") button2
setHtml "Zap! Quick result!" li
appendTo list li
@@ -83,26 +83,26 @@ makeButtons body = do
where button1Title = "Click me, I delay a bit"
button2Title = "Click me, I work immediately"
-appendToButton :: MonadTP m => Element -> String -> m Element
-appendToButton body caption = do
- p <- newElement "p"
- button <- newElement "a"
+appendToButton :: Window -> Element -> String -> IO Element
+appendToButton w body caption = do
+ p <- newElement w "p"
+ button <- newElement w "a"
appendTo body p
appendTo p button
setText caption button
setAttr "class" "button" button
return button
-link :: MonadTP m => String -> String -> m Element
-link url text = do
- el <- newElement "a"
+link :: Window -> String -> String -> IO Element
+link w url text = do
+ el <- newElement w "a"
setAttr "href" url el
setText text el
return el
-newElementText :: MonadTP m => Element -> String -> String -> m Element
-newElementText parent tagName text = do
- el <- newElement tagName
+newElementText :: Window -> Element -> String -> String -> IO Element
+newElementText w parent tagName text = do
+ el <- newElement w tagName
appendTo parent el
setText text el
return el
@@ -8,61 +8,61 @@ import Graphics.UI.Threepenny
infixl 1 #
-- | Append the element to a parent.
-(#+) :: (MonadTP m) => m Element -> Element -> m Element
+(#+) :: IO Element -> Element -> IO Element
m #+ parent = m # addTo parent
infixl 1 #+
-- | Set the class of an element.
-(#.) :: (MonadTP m) => m Element -> String -> m Element
+(#.) :: IO Element -> String -> IO Element
m #. cls = m # setClass cls
infixl 1 #.
-- | Set the id of an element.
-(##) :: (MonadTP m) => m Element -> String -> m Element
+(##) :: IO Element -> String -> IO Element
m ## id = m # setId id
infixl 1 ##
-- | Set the text of an element.
-(#=) :: (MonadTP m) => m Element -> String -> m Element
+(#=) :: IO Element -> String -> IO Element
m #= txt = m # setText txt
infixl 1 #=
-- | To this element, add this child.
-addTo :: MonadTP m => Element -> Element -> m Element
+addTo :: Element -> Element -> IO Element
addTo = appendTo
-- | Add this child, to that element.
-add :: MonadTP m => Element -> Element -> m Element
+add :: Element -> Element -> IO Element
add child parent = do
appendTo parent child # unit
return parent
-- | Set an attribute.
-set :: (MonadTP m) => String -> String -> Element -> m Element
+set :: String -> String -> Element -> IO Element
set = setAttr
-- | Discard the element chain.
unit :: Monad m => a -> m ()
unit = \_ -> return ()
-- | Set the class of an element.
-setClass :: (MonadTP m) => String -> Element -> m Element
+setClass :: String -> Element -> IO Element
setClass = set "class"
-- | Set the id of an element.
-setId :: (MonadTP m) => String -> Element -> m Element
+setId :: String -> Element -> IO Element
setId = set "id"
-- | Make a new div.
-new :: MonadTP m => m Element
-new = newElement "div"
+new :: Window -> IO Element
+new w = newElement w "div"
-- | Remove the element.
-remove :: MonadTP m => Element -> m ()
+remove :: Element -> IO ()
remove = delete
-- | Hide an element.
-hide :: MonadTP m => Element -> m ()
+hide :: Element -> IO ()
hide el = setClass "hidden" el # unit
@@ -7,53 +7,53 @@ import Graphics.UI.Threepenny
import Graphics.UI.Threepenny.DOM
-- | Make a new anchor.
-newAnchor :: MonadTP m => m Element
-newAnchor = newElement "a"
+newAnchor :: Window -> IO Element
+newAnchor w = newElement w "a"
-- | Make a new form.
-newForm :: MonadTP m => m Element
-newForm = newElement "form"
+newForm :: Window -> IO Element
+newForm w = newElement w "form"
-- | Make a new label.
-newLabel :: MonadTP m => m Element
-newLabel = newElement "label"
+newLabel :: Window -> IO Element
+newLabel w = newElement w "label"
-- | Make a new input.
-newInput :: MonadTP m => m Element
-newInput = newElement "input"
+newInput :: Window -> IO Element
+newInput w = newElement w "input"
-- | Make a new textarea.
-newTextarea :: MonadTP m => m Element
-newTextarea = newElement "textarea"
+newTextarea :: Window -> IO Element
+newTextarea w = newElement w "textarea"
-- | Make a new table.
-newTable :: MonadTP m => m Element
-newTable = newElement "table"
+newTable :: Window -> IO Element
+newTable w = newElement w "table"
-- | Make a new row.
-newRow :: MonadTP m => m Element
-newRow = newElement "tr"
+newRow :: Window -> IO Element
+newRow w = newElement w "tr"
-- | Make a new data.
-newData :: MonadTP m => m Element
-newData = newElement "td"
+newData :: Window -> IO Element
+newData w = newElement w "td"
-- | Make a new img.
-newImg :: MonadTP m => m Element
-newImg = newElement "img"
+newImg :: Window -> IO Element
+newImg w = newElement w "img"
-- | Add a stylesheet to the head.
-addStyleSheet :: MonadTP m => FilePath -> m ()
-addStyleSheet filename = do
- head <- getHead
- newElement "link"
+addStyleSheet :: Window -> FilePath -> IO ()
+addStyleSheet w filename = do
+ head <- getHead w
+ newElement w "link"
# setAttr "rel" "stylesheet"
# setAttr "type" "text/css"
# setAttr "href" ("/static/css/" ++ filename)
# appendTo head
# unit
-- | Add a clear.
-addClear :: MonadTP m => Element -> m ()
-addClear el = do
- new #. "clear" #+ el # unit
+addClear :: Window -> Element -> IO ()
+addClear w el = do
+ new w #. "clear" #+ el # unit
@@ -6,81 +6,72 @@ module Graphics.UI.Threepenny.Events where
import Graphics.UI.Threepenny
-- | Bind an event handler to the click event of the given element.
-onClick :: MonadTP m
- => Element -- ^ The element to bind to.
- -> (EventData -> m ()) -- ^ The event handler.
- -> m ()
+onClick :: Element -> (EventData -> IO ()) -> IO ()
onClick = bind "click"
-- | Bind an event handler to the hover event of the given element.
-onHover :: MonadTP m
- => Element -- ^ The element to bind to.
- -> (EventData -> m ()) -- ^ The event handler.
- -> m ()
+onHover :: Element -> (EventData -> IO ()) -> IO ()
onHover = bind "mouseenter"
-- | Bind an event handler to the blur event of the given element.
-onBlur :: MonadTP m
- => Element -- ^ The element to bind to.
- -> (EventData -> m ()) -- ^ The event handler.
- -> m ()
+onBlur :: Element -> (EventData -> IO ()) -> IO ()
onBlur = bind "mouseleave"
-- Drag events and support functions
-- | Enables drag on an element.
-allowDrag :: MonadTP m => Element -> m Element
+allowDrag :: Element -> IO Element
allowDrag = setDraggable True
-- | Disables drag on an element.
-blockDrag :: MonadTP m => Element -> m Element
+blockDrag :: Element -> IO Element
blockDrag = setDraggable False
-- | Enables or disables drag based on boolean argument.
-setDraggable :: MonadTP m => Bool -> Element -> m Element
+setDraggable :: Bool -> Element -> IO Element
setDraggable t = setAttr "draggable" (if t then "true" else "false")
-- | Set the drag data for an element. This data becomes the EventData for all drag-related events.
-setDragData :: MonadTP m => String -> Element -> m Element
+setDragData :: String -> Element -> IO Element
setDragData d = setAttr "ondragstart" $ "event.dataTransfer.setData('dragData', '" ++ d ++ "')"
-- | Enables an element to accept drops.
-allowDrop :: MonadTP m => Element -> m Element
+allowDrop :: Element -> IO Element
allowDrop e =
setAttr "ondragover" "event.preventDefault()" e >>= setAttr "ondrop" "event.preventDefault()"
-- | Disables an element from accepting drops.
-blockDrop :: MonadTP m => Element -> m Element
+blockDrop :: Element -> IO Element
blockDrop e = setAttr "ondragover" "" e >>= setAttr "ondrop" ""
-- | Enables or disables an element from accepting drops based on boolean argument.
-setDroppable :: MonadTP m => Bool -> Element -> m Element
+setDroppable :: Bool -> Element -> IO Element
setDroppable t = if t then allowDrop else blockDrop
-- | Bind an event handler to the drag start event.
-onDragStart :: MonadTP m => Element -> (EventData -> m ()) -> m ()
+onDragStart :: Element -> (EventData -> IO ()) -> IO ()
onDragStart = bind "dragstart"
-- | Bind an event handler to the drag enter event.
-onDragEnter :: MonadTP m => Element -> (EventData -> m ()) -> m ()
+onDragEnter :: Element -> (EventData -> IO ()) -> IO ()
onDragEnter = bind "dragenter"
-- | Bind an event handler to the drag over event.
-onDragOver :: MonadTP m => Element -> (EventData -> m ()) -> m ()
+onDragOver :: Element -> (EventData -> IO ()) -> IO ()
onDragOver = bind "dragover"
-- | Bind an event handler to the drag leave event.
-onDragLeave :: MonadTP m => Element -> (EventData -> m ()) -> m ()
+onDragLeave :: Element -> (EventData -> IO ()) -> IO ()
onDragLeave = bind "dragleave"
-- | Bind an event handler to the drag event.
-onDrag :: MonadTP m => Element -> (EventData -> m ()) -> m ()
+onDrag :: Element -> (EventData -> IO ()) -> IO ()
onDrag = bind "drag"
-- | Bind an event handler to the drop event.
-onDrop :: MonadTP m => Element -> (EventData -> m ()) -> m ()
+onDrop :: Element -> (EventData -> IO ()) -> IO ()
onDrop = bind "drop"
-- | Bind an event handler to the drag end event.
-onDragEnd :: MonadTP m => Element -> (EventData -> m ()) -> m ()
-onDragEnd = bind "dragend"
+onDragEnd :: Element -> (EventData -> IO ()) -> IO ()
+onDragEnd = bind "dragend"
Oops, something went wrong.

0 comments on commit 3718a8b

Please sign in to comment.