module Haste.DOM.JSString (
AttrName (..), Attribute, IsElem (..), Elem,
attribute, set, with, children,
click, focus, blur, document, documentBody, appendChild, addChild,
addChildBefore, insertChildBefore, getFirstChild, getLastChild, getChildren,
setChildren, clearChildren, deleteChild, removeChild,
PropID, ElemID, QuerySelector, ElemClass, AttrValue,
style, attr, (=:),
newElem, newTextElem,
elemById, elemsByQS, elemsByClass,
setProp, getProp, setAttr, getAttr, getValue,
withElem , withElems, withElemsQS, mapQS, mapQS_,
getStyle, setStyle,
getFileData, getFileName,
setClass, toggleClass, hasClass
) where
import Haste.Prim
import Haste.Prim.JSType
import Haste.DOM.Core
import Data.Maybe (isNothing, fromJust)
import Control.Monad.IO.Class
import Haste.Foreign
import Haste.Binary.Types
type PropID = JSString
type ElemID = JSString
type QuerySelector = JSString
type ElemClass = JSString
type AttrValue = JSString
#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 jsQuerySelectorAll :: Elem -> JSString -> IO (Ptr [Elem])
foreign import ccall jsElemsByClassName :: JSString -> IO (Ptr [Elem])
foreign import ccall jsCreateElem :: JSString -> IO Elem
foreign import ccall jsCreateTextNode :: JSString -> IO Elem
#else
jsGet :: Elem -> JSString -> IO JSString
jsGet = error "Tried to use jsGet on server side!"
jsSet :: Elem -> JSString -> JSString -> IO ()
jsSet = error "Tried to use jsSet on server side!"
jsGetAttr :: Elem -> JSString -> IO JSString
jsGetAttr = error "Tried to use jsGetAttr on server side!"
jsSetAttr :: Elem -> JSString -> JSString -> IO ()
jsSetAttr = error "Tried to use jsSetAttr on server side!"
jsGetStyle :: Elem -> JSString -> IO JSString
jsGetStyle = error "Tried to use jsGetStyle on server side!"
jsSetStyle :: Elem -> JSString -> JSString -> IO ()
jsSetStyle = error "Tried to use jsSetStyle on server side!"
jsFind :: JSString -> IO (Ptr (Maybe Elem))
jsFind = error "Tried to use jsFind on server side!"
jsQuerySelectorAll :: Elem -> JSString -> IO (Ptr [Elem])
jsQuerySelectorAll = error "Tried to use jsQuerySelectorAll on server side!"
jsElemsByClassName :: JSString -> IO (Ptr [Elem])
jsElemsByClassName = error "Tried to use jsElemsByClassName on server side!"
jsCreateElem :: JSString -> IO Elem
jsCreateElem = error "Tried to use jsCreateElem on server side!"
jsCreateTextNode :: JSString -> IO Elem
jsCreateTextNode = error "Tried to use jsCreateTextNode on server side!"
#endif
style :: JSString -> AttrName
style = StyleName
attr :: JSString -> AttrName
attr = AttrName
(=:) :: AttrName -> AttrValue -> Attribute
(=:) = attribute
newElem :: MonadIO m => JSString -> m Elem
newElem = liftIO . jsCreateElem
newTextElem :: MonadIO m => JSString -> m Elem
newTextElem = liftIO . jsCreateTextNode
setProp :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m ()
setProp e prop val = liftIO $ jsSet (elemOf e) prop val
setAttr :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m ()
setAttr e prop val = liftIO $ jsSetAttr (elemOf e) prop val
getValue :: (IsElem e, MonadIO m, JSType a) => e -> m (Maybe a)
getValue e = liftIO $ fromJSString `fmap` jsGet (elemOf e) "value"
getProp :: (IsElem e, MonadIO m) => e -> PropID -> m JSString
getProp e prop = liftIO $ jsGet (elemOf e) prop
getAttr :: (IsElem e, MonadIO m) => e -> PropID -> m JSString
getAttr e prop = liftIO $ jsGetAttr (elemOf e) prop
getStyle :: (IsElem e, MonadIO m) => e -> PropID -> m JSString
getStyle e prop = liftIO $ jsGetStyle (elemOf e) prop
setStyle :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m ()
setStyle e prop val = liftIO $ jsSetStyle (elemOf e) prop val
elemById :: MonadIO m => ElemID -> m (Maybe Elem)
elemById eid = liftIO $ fromPtr `fmap` (jsFind eid)
elemsByClass :: MonadIO m => ElemClass -> m [Elem]
elemsByClass cls = liftIO $ fromPtr `fmap` (jsElemsByClassName cls)
elemsByQS :: (IsElem e, MonadIO m) => e -> QuerySelector -> m [Elem]
elemsByQS el sel = liftIO $ fromPtr `fmap` (jsQuerySelectorAll (elemOf el) sel)
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 " ++ fromJSStr e ++ " 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 _ _ = []
withElemsQS :: (IsElem e, MonadIO m)
=> e
-> QuerySelector
-> ([Elem] -> m a)
-> m a
withElemsQS el sel act = elemsByQS el sel >>= act
mapQS :: (IsElem e, MonadIO m) => e -> QuerySelector -> (Elem -> m a) -> m [a]
mapQS el sel act = elemsByQS el sel >>= mapM act
mapQS_ :: (IsElem e, MonadIO m) => e -> QuerySelector -> (Elem -> m a) -> m ()
mapQS_ el sel act = elemsByQS el sel >>= mapM_ act
getFileData :: (IsElem e, MonadIO m) => e -> Int -> m (Maybe Blob)
getFileData e ix = liftIO $ do
num <- getFiles (elemOf e)
if ix < num
then Just `fmap` getFile (elemOf e) ix
else return Nothing
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 :: (IsElem e, MonadIO m) => e -> m JSString
getFileName e = liftIO $ do
fn <- fromJSStr `fmap` getProp e "value"
return $ toJSStr $ reverse $ takeWhile (not . separator) $ reverse fn
where
separator '/' = True
separator '\\' = True
separator _ = False
setClass :: (IsElem e, MonadIO m) => e -> JSString -> Bool -> m ()
setClass e c x = liftIO $ setc (elemOf e) c x
setc :: Elem -> JSString -> Bool -> IO ()
setc = ffi "(function(e,c,x){x?e.classList.add(c):e.classList.remove(c);})"
toggleClass :: (IsElem e, MonadIO m) => e -> JSString -> m ()
toggleClass e c = liftIO $ toggc (elemOf e) c
toggc :: Elem -> JSString -> IO ()
toggc = ffi "(function(e,c) {e.classList.toggle(c);})"
hasClass :: (IsElem e, MonadIO m) => e -> JSString -> m Bool
hasClass e c = liftIO $ getc (elemOf e) c
getc :: Elem -> JSString -> IO Bool
getc = ffi "(function(e,c) {return e.classList.contains(c);})"