module Haste.DOM (
Elem (..), PropID, ElemID,
newElem, newTextElem,
elemById, setProp, getProp, setAttr, getAttr, setProp',
getProp', getValue, withElem , withElems, addChild,
addChildBefore, removeChild, clearChildren , getChildBefore,
getFirstChild, getLastChild, getChildren, setChildren,
getStyle, setStyle, getStyle', setStyle',
getFileData, getFileName,
setClass, toggleClass, hasClass,
click, focus, blur,
documentBody
) where
import Haste.Prim
import Haste.JSType
import Data.Maybe (isNothing, fromJust)
import Control.Monad.IO.Class
import Haste.Foreign
import Haste.Binary.Types
import System.IO.Unsafe (unsafePerformIO)
newtype Elem = Elem JSAny
instance Pack Elem
instance Unpack Elem
type PropID = String
type ElemID = String
#ifdef __HASTE__
foreign import ccall jsGet :: Elem -> JSString -> IO JSString
foreign import ccall jsSet :: Elem -> JSString -> JSString -> IO ()
foreign import ccall jsGetAttr :: Elem -> JSString -> IO JSString
foreign import ccall jsSetAttr :: Elem -> JSString -> JSString -> IO ()
foreign import ccall jsGetStyle :: Elem -> JSString -> IO JSString
foreign import ccall jsSetStyle :: Elem -> JSString -> JSString -> IO ()
foreign import ccall jsFind :: JSString -> IO (Ptr (Maybe Elem))
foreign import ccall jsCreateElem :: JSString -> IO Elem
foreign import ccall jsCreateTextNode :: JSString -> IO Elem
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
jsGet = error "Tried to use jsGet on server side!"
jsSet = error "Tried to use jsSet on server side!"
jsGetAttr = error "Tried to use jsGetAttr on server side!"
jsSetAttr = error "Tried to use jsSetAttr on server side!"
jsGetStyle = error "Tried to use jsGetStyle on server side!"
jsSetStyle = error "Tried to use jsSetStyle on server side!"
jsFind = error "Tried to use jsFind on server side!"
jsCreateElem = error "Tried to use jsCreateElem on server side!"
jsCreateTextNode = error "Tried to use jsCreateTextNode on server side!"
jsAppendChild = error "Tried to use jsAppendChild on server side!"
jsGetFirstChild = error "Tried to use jsGetFirstChild on server side!"
jsGetLastChild = error "Tried to use jsGetLastChild on server side!"
jsGetChildren = error "Tried to use jsGetChildren on server side!"
jsSetChildren = error "Tried to use jsSetChildren on server side!"
jsAddChildBefore = error "Tried to use jsAddChildBefore on server side!"
jsGetChildBefore = error "Tried to use jsGetChildBefore on server side!"
jsKillChild = error "Tried to use jsKillChild on server side!"
jsClearChildren = error "Tried to use jsClearChildren on server side!"
#endif
addChild :: MonadIO m => Elem -> Elem -> m ()
addChild child parent = liftIO $ jsAppendChild child parent
addChildBefore :: MonadIO m => Elem -> Elem -> Elem -> m ()
addChildBefore child parent oldChild =
liftIO $ jsAddChildBefore child parent oldChild
getChildBefore :: MonadIO m => Elem -> m (Maybe Elem)
getChildBefore e = liftIO $ fromPtr `fmap` jsGetChildBefore e
getFirstChild :: MonadIO m => Elem -> m (Maybe Elem)
getFirstChild e = liftIO $ fromPtr `fmap` jsGetFirstChild e
getLastChild :: MonadIO m => Elem -> m (Maybe Elem)
getLastChild e = liftIO $ fromPtr `fmap` jsGetLastChild e
getChildren :: MonadIO m => Elem -> m [Elem]
getChildren e = liftIO $ fromPtr `fmap` jsGetChildren e
setChildren :: MonadIO m => Elem -> [Elem] -> m ()
setChildren e ch = liftIO $ jsSetChildren e (toPtr ch)
newElem :: MonadIO m => String -> m Elem
newElem = liftIO . jsCreateElem . toJSStr
newTextElem :: MonadIO m => String -> m Elem
newTextElem = liftIO . jsCreateTextNode . toJSStr
setProp :: MonadIO m => Elem -> PropID -> String -> m ()
setProp e prop val = liftIO $ jsSet e (toJSStr prop) (toJSStr val)
setProp' :: MonadIO m => Elem -> JSString -> JSString -> m ()
setProp' e prop val = liftIO $ jsSet e prop val
setAttr :: MonadIO m => Elem -> PropID -> String -> m ()
setAttr e prop val = liftIO $ jsSetAttr e (toJSStr prop) (toJSStr val)
getValue :: (MonadIO m, JSType a) => Elem -> m (Maybe a)
getValue e = liftIO $ fromJSString `fmap` jsGet e "value"
getProp :: MonadIO m => Elem -> PropID -> m String
getProp e prop = liftIO $ fromJSStr `fmap` jsGet e (toJSStr prop)
getProp' :: MonadIO m => Elem -> JSString -> m JSString
getProp' e prop = liftIO $ jsGet e prop
getAttr :: MonadIO m => Elem -> PropID -> m String
getAttr e prop = liftIO $ fromJSStr `fmap` jsGetAttr e (toJSStr prop)
getStyle :: MonadIO m => Elem -> PropID -> m String
getStyle e prop = liftIO $ fromJSStr `fmap` jsGetStyle e (toJSStr prop)
getStyle' :: MonadIO m => Elem -> JSString -> m JSString
getStyle' e prop = liftIO $ jsGetStyle e prop
setStyle :: MonadIO m => Elem -> PropID -> String -> m ()
setStyle e prop val = liftIO $ jsSetStyle e (toJSStr prop) (toJSStr val)
setStyle' :: MonadIO m => Elem -> JSString -> JSString -> m ()
setStyle' e prop val = liftIO $ jsSetStyle e prop val
elemById :: MonadIO m => ElemID -> m (Maybe Elem)
elemById eid = liftIO $ fromPtr `fmap` (jsFind $ toJSStr eid)
withElem :: MonadIO m => ElemID -> (Elem -> m a) -> m a
withElem e act = do
me' <- elemById e
case me' of
Just e' -> act e'
_ -> error $ "No element with ID " ++ e ++ " could be found!"
withElems :: MonadIO m => [ElemID] -> ([Elem] -> m a) -> m a
withElems es act = do
mes <- mapM elemById es
if any isNothing mes
then error $ "Elements with the following IDs could not be found: "
++ show (findElems es mes)
else act $ map fromJust mes
where
findElems (i:is) (Nothing:mes) = i : findElems is mes
findElems (_:is) (_:mes) = findElems is mes
findElems _ _ = []
clearChildren :: MonadIO m => Elem -> m ()
clearChildren = liftIO . jsClearChildren
removeChild :: MonadIO m => Elem -> Elem -> m ()
removeChild child parent = liftIO $ jsKillChild child parent
getFileData :: MonadIO m => Elem -> Int -> m (Maybe Blob)
getFileData e ix = liftIO $ do
num <- getFiles e
if ix < num
then Just `fmap` getFile e ix
else return Nothing
where
getFiles :: Elem -> IO Int
getFiles = ffi "(function(e){return e.files.length;})"
getFile :: Elem -> Int -> IO Blob
getFile = ffi "(function(e,ix){return e.files[ix];})"
getFileName :: MonadIO m => Elem -> m String
getFileName e = liftIO $ do
fn <- getProp e "value"
return $ reverse $ takeWhile (not . separator) $ reverse fn
where
separator '/' = True
separator '\\' = True
separator _ = False
setClass :: MonadIO m => Elem -> String -> Bool -> m ()
setClass e c x = liftIO $ setc e c x
where
setc :: Elem -> String -> Bool -> IO ()
setc = ffi "(function(e,c,x){x?e.classList.add(c):e.classList.remove(c);})"
toggleClass :: MonadIO m => Elem -> String -> m ()
toggleClass e c = liftIO $ toggc e c
where
toggc :: Elem -> String -> IO ()
toggc = ffi "(function(e,c) {e.classList.toggle(c);})"
hasClass :: MonadIO m => Elem -> String -> m Bool
hasClass e c = liftIO $ getc e c
where
getc :: Elem -> String -> IO Bool
getc = ffi "(function(e,c) {return e.classList.contains(c);})"
click :: MonadIO m => Elem -> m ()
click = liftIO . click'
where
click' :: Elem -> IO ()
click' = ffi "(function(e) {e.click();})"
focus :: MonadIO m => Elem -> m ()
focus = liftIO . focus'
where
focus' :: Elem -> IO ()
focus' = ffi "(function(e) {e.focus();})"
blur :: MonadIO m => Elem -> m ()
blur = liftIO . blur'
where
blur' :: Elem -> IO ()
blur' = ffi "(function(e) {e.blur();})"
documentBody :: Elem
documentBody = unsafePerformIO getBody
where
getBody :: IO Elem
getBody = ffi "document.body"