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,
removeChild, addChild, addChildBefore
) where
import Haste.Prim
import Control.Monad.IO.Class
import Haste.Foreign
import Data.String
#ifdef __HASTE__
foreign import ccall jsSet :: Elem -> JSString -> JSString -> IO ()
foreign import ccall jsSetAttr :: Elem -> JSString -> JSString -> IO ()
foreign import ccall jsSetStyle :: Elem -> JSString -> JSString -> IO ()
foreign import ccall jsAppendChild :: Elem -> Elem -> IO ()
foreign import ccall jsGetFirstChild :: Elem -> IO (Ptr (Maybe Elem))
foreign import ccall jsGetLastChild :: Elem -> IO (Ptr (Maybe Elem))
foreign import ccall jsGetChildren :: Elem -> IO (Ptr [Elem])
foreign import ccall jsSetChildren :: Elem -> Ptr [Elem] -> IO ()
foreign import ccall jsAddChildBefore :: Elem -> Elem -> Elem -> IO ()
foreign import ccall jsGetChildBefore :: Elem -> IO (Ptr (Maybe Elem))
foreign import ccall jsKillChild :: Elem -> Elem -> IO ()
foreign import ccall jsClearChildren :: Elem -> IO ()
#else
jsSet :: Elem -> JSString -> JSString -> IO ()
jsSet = error "Tried to use jsSet on server side!"
jsSetAttr :: Elem -> JSString -> JSString -> IO ()
jsSetAttr = error "Tried to use jsSetAttr on server side!"
jsSetStyle :: Elem -> JSString -> JSString -> IO ()
jsSetStyle = error "Tried to use jsSetStyle on server side!"
jsAppendChild :: Elem -> Elem -> IO ()
jsAppendChild = error "Tried to use jsAppendChild on server side!"
jsGetFirstChild :: Elem -> IO (Ptr (Maybe Elem))
jsGetFirstChild = error "Tried to use jsGetFirstChild on server side!"
jsGetLastChild :: Elem -> IO (Ptr (Maybe Elem))
jsGetLastChild = error "Tried to use jsGetLastChild on server side!"
jsGetChildren :: Elem -> IO (Ptr [Elem])
jsGetChildren = error "Tried to use jsGetChildren on server side!"
jsSetChildren :: Elem -> Ptr [Elem] -> IO ()
jsSetChildren = error "Tried to use jsSetChildren on server side!"
jsAddChildBefore :: Elem -> Elem -> Elem -> IO ()
jsAddChildBefore = error "Tried to use jsAddChildBefore on server side!"
jsGetChildBefore :: Elem -> IO (Ptr (Maybe Elem))
jsGetChildBefore = error "Tried to use jsGetChildBefore on server side!"
jsKillChild :: Elem -> Elem -> IO ()
jsKillChild = error "Tried to use jsKillChild on server side!"
jsClearChildren :: Elem -> IO ()
jsClearChildren = error "Tried to use jsClearChildren on server side!"
#endif
newtype Elem = Elem JSAny
deriving (ToAny, FromAny)
class IsElem a where
elemOf :: a -> Elem
fromElem :: Elem -> IO (Maybe a)
fromElem = const $ return Nothing
instance IsElem Elem where
elemOf = id
fromElem = return . Just
data AttrName
= PropName !JSString
| StyleName !JSString
| AttrName !JSString
instance IsString AttrName where
fromString = PropName . fromString
data Attribute
= Attribute !AttrName !JSString
| Children ![Elem]
attribute :: AttrName -> JSString -> Attribute
attribute = Attribute
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
children :: [Elem] -> Attribute
children = Children
with :: (IsElem e, MonadIO m) => m e -> [Attribute] -> m e
with m attrs = do
x <- m
set x attrs
return x
click :: (IsElem e, MonadIO m) => e -> m ()
click = liftIO . click' . elemOf
where
click' :: Elem -> IO ()
click' = ffi "(function(e) {e.click();})"
focus :: (IsElem e, MonadIO m) => e -> m ()
focus = liftIO . focus' . elemOf
where
focus' :: Elem -> IO ()
focus' = ffi "(function(e) {e.focus();})"
blur :: (IsElem e, MonadIO m) => e -> m ()
blur = liftIO . blur' . elemOf
where
blur' :: Elem -> IO ()
blur' = ffi "(function(e) {e.blur();})"
document :: Elem
document = constant "document"
documentBody :: Elem
documentBody = constant "document.body"
appendChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m ()
appendChild parent child = liftIO $ jsAppendChild (elemOf child) (elemOf parent)
addChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m ()
addChild = flip appendChild
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)
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 $ fromPtr `fmap` jsGetChildBefore (elemOf e)
getFirstChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)
getFirstChild e = liftIO $ fromPtr `fmap` jsGetFirstChild (elemOf e)
getLastChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)
getLastChild e = liftIO $ fromPtr `fmap` jsGetLastChild (elemOf e)
getChildren :: (IsElem e, MonadIO m) => e -> m [Elem]
getChildren e = liftIO $ fromPtr `fmap` jsGetChildren (elemOf e)
setChildren :: (IsElem parent, IsElem child, MonadIO m)
=> parent
-> [child]
-> m ()
setChildren e ch = liftIO $ jsSetChildren (elemOf e) (toPtr $ 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 child parent = liftIO $ jsKillChild (elemOf child) (elemOf parent)