module Haste.DOM.Core (
Elem (..), IsElem (..), Attribute, AttrName (..),
set, with, attribute, children,
click, focus, blur,
document, documentBody,
deleteChild, clearChildren,
setChildren, getChildren,
getLastChild, getFirstChild, getChildBefore,
insertChildBefore, appendChild,
jsSet, jsSetAttr, jsSetStyle,
removeChild, addChild, addChildBefore
) where
import Haste.Prim
import Control.Monad.IO.Class
import Haste.Foreign
import Data.String
jsSet :: Elem -> JSString -> JSString -> IO ()
jsSet = ffi "(function(e,p,v){e[p] = v;})"
jsSetAttr :: Elem -> JSString -> JSString -> IO ()
jsSetAttr = ffi "(function(e,p,v){e.setAttribute(p, v);})"
jsSetStyle :: Elem -> JSString -> JSString -> IO ()
jsSetStyle = ffi "(function(e,p,v){e.style[p] = v;})"
jsAppendChild :: Elem -> Elem -> IO ()
jsAppendChild = ffi "(function(c,p){p.appendChild(c);})"
jsGetFirstChild :: Elem -> IO (Maybe Elem)
jsGetFirstChild = ffi "(function(e){\
for(e = e.firstChild; e != null; e = e.nextSibling)\
{if(e instanceof HTMLElement) {return e;}}\
return null;})"
jsGetLastChild :: Elem -> IO (Maybe Elem)
jsGetLastChild = ffi "(function(e){\
for(e = e.lastChild; e != null; e = e.previousSibling)\
{if(e instanceof HTMLElement) {return e;}}\
return null;})"
jsGetChildren :: Elem -> IO [Elem]
jsGetChildren = ffi "(function(e){\
var ch = [];\
for(e = e.firstChild; e != null; e = e.nextSibling)\
{if(e instanceof HTMLElement) {ch.push(e);}}\
return ch;})"
jsSetChildren :: Elem -> [Elem] -> IO ()
jsSetChildren = ffi "(function(e,ch){\
while(e.firstChild) {e.removeChild(e.firstChild);}\
for(var i in ch) {e.appendChild(ch[i]);}})"
jsAddChildBefore :: Elem -> Elem -> Elem -> IO ()
jsAddChildBefore = ffi "(function(c,p,a){p.insertBefore(c,a);})"
jsGetChildBefore :: Elem -> IO (Maybe Elem)
jsGetChildBefore = ffi "(function(e){\
for(; e != null; e = e.previousSibling)\
{if(e instanceof HTMLElement) {return e;}\
return null;})"
jsKillChild :: Elem -> Elem -> IO ()
jsKillChild = ffi "(function(c,p){p.removeChild(c);})"
jsClearChildren :: Elem -> IO ()
jsClearChildren = ffi "(function(e){\
while(e.firstChild){e.removeChild(e.firstChild);}})"
-- | A DOM node.
newtype Elem = Elem JSAny
deriving (ToAny, FromAny)
-- | The class of types backed by DOM elements.
class IsElem a where
-- | Get the element representing the object.
elemOf :: a -> Elem
-- | Attempt to create an object from an 'Elem'.
fromElem :: Elem -> IO (Maybe a)
fromElem = const $ return Nothing
instance IsElem Elem where
elemOf = id
fromElem = return . Just
-- | The name of an attribute. May be either a common property, an HTML
-- attribute or a style attribute.
data AttrName
= PropName !JSString
| StyleName !JSString
| AttrName !JSString
instance IsString AttrName where
fromString = PropName . fromString
-- | A key/value pair representing the value of an attribute.
-- May represent a property, an HTML attribute, a style attribute or a list
-- of child elements.
data Attribute
= Attribute !AttrName !JSString
| Children ![Elem]
-- | Construct an 'Attribute'.
attribute :: AttrName -> JSString -> Attribute
attribute = Attribute
-- | Set a number of 'Attribute's on an element.
set :: (IsElem e, MonadIO m) => e -> [Attribute] -> m ()
set e as =
liftIO $ mapM_ set' as
where
e' = elemOf e
set' (Attribute (PropName k) v) = jsSet e' k v
set' (Attribute (StyleName k) v) = jsSetStyle e' k v
set' (Attribute (AttrName k) v) = jsSetAttr e' k v
set' (Children cs) = mapM_ (flip jsAppendChild e') cs
-- | Attribute adding a list of child nodes to an element.
children :: [Elem] -> Attribute
children = Children
-- | Set a number of 'Attribute's on the element produced by an IO action.
-- Gives more convenient syntax when creating elements:
--
-- > newElem "div" `with` [
-- > style "border" =: "1px solid black",
-- > ...
-- > ]
--
with :: (IsElem e, MonadIO m) => m e -> [Attribute] -> m e
with m attrs = do
x <- m
set x attrs
return x
-- | Generate a click event on an element.
click :: (IsElem e, MonadIO m) => e -> m ()
click = liftIO . click' . elemOf
click' :: Elem -> IO ()
click' = ffi "(function(e) {e.click();})"
-- | Generate a focus event on an element.
focus :: (IsElem e, MonadIO m) => e -> m ()
focus = liftIO . focus' . elemOf
focus' :: Elem -> IO ()
focus' = ffi "(function(e) {e.focus();})"
-- | Generate a blur event on an element.
blur :: (IsElem e, MonadIO m) => e -> m ()
blur = liftIO . blur' . elemOf
blur' :: Elem -> IO ()
blur' = ffi "(function(e) {e.blur();})"
-- | The DOM node corresponding to document.
document :: Elem
document = constant "document"
-- | The DOM node corresponding to document.body.
documentBody :: Elem
documentBody = constant "document.body"
-- | Append the first element as a child of the second element.
appendChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m ()
appendChild parent child = liftIO $ jsAppendChild (elemOf child) (elemOf parent)
{-# DEPRECATED addChild "Use appendChild instead. Note that appendChild == flip addChild." #-}
-- | DEPRECATED: use 'appendChild' instead!
-- Note that @appendChild == flip addChild@.
addChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m ()
addChild = flip appendChild
-- | Insert an element into a container, before another element.
-- For instance:
-- @
-- insertChildBefore theContainer olderChild childToAdd
-- @
insertChildBefore :: (IsElem parent, IsElem before, IsElem child, MonadIO m)
=> parent -> before -> child -> m ()
insertChildBefore parent oldChild child =
liftIO $ jsAddChildBefore (elemOf child) (elemOf parent) (elemOf oldChild)
{-# DEPRECATED addChildBefore "Use insertChildBefore instead. Note insertChildBefore == \\parent new old -> addChildBefore new parent old." #-}
addChildBefore :: (IsElem parent, IsElem child, MonadIO m)
=> child -> parent -> child -> m ()
addChildBefore child parent oldChild = insertChildBefore parent oldChild child
getChildBefore :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)
getChildBefore e = liftIO $ jsGetChildBefore (elemOf e)
getFirstChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)
getFirstChild e = liftIO $ jsGetFirstChild (elemOf e)
getLastChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)
getLastChild e = liftIO $ jsGetLastChild (elemOf e)
getChildren :: (IsElem e, MonadIO m) => e -> m [Elem]
getChildren e = liftIO $ jsGetChildren (elemOf e)
setChildren :: (IsElem parent, IsElem child, MonadIO m)
=> parent
-> [child]
-> m ()
setChildren e ch = liftIO $ jsSetChildren (elemOf e) (map elemOf ch)
clearChildren :: (IsElem e, MonadIO m) => e -> m ()
clearChildren = liftIO . jsClearChildren . elemOf
deleteChild :: (IsElem parent, IsElem child, MonadIO m)
=> parent
-> child
-> m ()
deleteChild parent child = liftIO $ jsKillChild (elemOf child) (elemOf parent)
removeChild :: (IsElem parent, IsElem child, MonadIO m)
=> child
-> parent
-> m ()
removeChild = flip deleteChild