module Haste.DOM.JSString (
module Core,
IsElem (..), Elem, PropID, ElemID, QuerySelector, ElemClass,
AttrName, 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.JSType
import qualified Haste.DOM.Core as Core
hiding (Elem (..), AttrName (..))
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);})"