diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for plzwrk +## 0.0.0.3 + +- Adds bindings for `fetch` +- Simplifies `Browserful` API to only contain primitives and uses utility functions to build on top of the primitives. + ## 0.0.0.2 - Adds server side rendering via `toHTML` and `plzwrkSSR`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -85,9 +85,9 @@ > If you are using the Asterius backend, callback functions are still quite fragile and subject to breakage. The less third-party libraries you use in them, the better. For example, avoid using `Data.Text` and `aeson` if possible. -## Static site rendering +## Server side rendering -Plzwrk supports static site rendering. To do this, you have to compile your site twice: +Plzwrk supports server side rendering. To do this, you have to compile your site twice: - once using `ahc-cabal` using the procedure above to create any JavaScript you need (ie event handlers), and - once using plain old `cabal` to create the inital HTML. diff --git a/kitchen-sink/Main.hs b/kitchen-sink/Main.hs --- a/kitchen-sink/Main.hs +++ b/kitchen-sink/Main.hs @@ -66,11 +66,11 @@ (wId "incr" <.> wClass "dim" <.> wOnClick (\e s -> do (eventTargetBlur browser) e - (consoleLog browser) $ "Here is the current state " <> show s + (consoleLogS browser) $ "Here is the current state " <> show s concept <- randAbstract (mathRandom browser) comparedTo <- randConcrete (mathRandom browser) let newS = s { _abstractToConcrete = (concept, comparedTo) : a2c } - (consoleLog browser) $ "Here is the new state " <> show newS + (consoleLogS browser) $ "Here is the new state " <> show newS return $ newS ) ) diff --git a/plzwrk.cabal b/plzwrk.cabal --- a/plzwrk.cabal +++ b/plzwrk.cabal @@ -7,7 +7,7 @@ -- hash: 8099ceb0d406f862d89306de053aba4c75999a9e0d74ac6a502458d503e7dcc1 name: plzwrk -version: 0.0.0.2 +version: 0.0.0.3 category: Web synopsis: A front-end framework description: Please see the README on GitHub at diff --git a/src/Web/Framework/Plzwrk.hs b/src/Web/Framework/Plzwrk.hs --- a/src/Web/Framework/Plzwrk.hs +++ b/src/Web/Framework/Plzwrk.hs @@ -45,6 +45,21 @@ , eventPreventDefault , eventTargetBlur , eventTargetValue + , elementSetAttribute + , elementTagName + , eventTargetAddEventListener + , eventTargetRemoveEventListener + , getPropertyAsBool + , getPropertyAsDouble + , getPropertyAsInt + , getPropertyAsString + , htmlElemenetClick + , consoleLogS + , nodeAppendChild + , nodeChildNodes + , nodeInsertBefore + , nodeRemoveChild + , nodeTextContent ) where diff --git a/src/Web/Framework/Plzwrk/Asterius.hs b/src/Web/Framework/Plzwrk/Asterius.hs --- a/src/Web/Framework/Plzwrk/Asterius.hs +++ b/src/Web/Framework/Plzwrk/Asterius.hs @@ -23,59 +23,51 @@ import Asterius.Aeson import Asterius.ByteString import Asterius.Types +import Data.ByteString.Internal ( ByteString ) import qualified Data.ByteString as BS import Data.ByteString.Unsafe +import Data.HashMap.Strict as HM import Data.Coerce import Foreign.Ptr import Web.Framework.Plzwrk.Browserful asteriusBrowser :: IO (Browserful JSVal) asteriusBrowser = return Browserful - { eventTargetAddEventListener = _eventTargetAddEventListener - , nodeAppendChild = _nodeAppendChild - , htmlElemenetClick = _htmlElemenetClick + { + castToArray = _castToArray + , castToBool = _castToBool + , castToByteString = _castToByteString + , castToDouble = _castToDouble + , castToInt = _castToInt + , castToString = _castToString , consoleLog = _consoleLog - , consoleLog' = _consoleLog' + , defaultRequestInit = _defaultRequestInit , documentCreateElement = _documentCreateElement , documentCreateTextNode = _documentCreateTextNode , documentBody = _documentBody , documentGetElementById = _documentGetElementById , documentHead = _documentHead + , fetch = _fetch , _freeCallback = __freeCallback - , getPropertyAsBool = _getPropertyAsBool - , getPropertyAsDouble = _getPropertyAsDouble - , getPropertyAsInt = _getPropertyAsInt , getPropertyAsOpaque = _getPropertyAsOpaque - , getPropertyAsString = _getString - , elementTagName = _elementTagName - , nodeInsertBefore = _nodeInsertBefore + , jsValFromArray = _jsValFromArray + , jsValFromBool = _jsValFromBool + , jsValFromByteString = _jsValFromByteString + , jsValFromDouble = _jsValFromDouble + , jsValFromInt = _jsValFromInt + , jsValFromString = _jsValFromString , invokeOn0 = _invokeOn0 + , makeObject = _makeObject + , setValue = _setValue + , invokeOn1 = _invokeOn1 + , invokeOn2 = _invokeOn2 , _makeHaskellCallback = __makeHaskellCallback - , nodeChildNodes = _nodeChildNodes , mathRandom = _mathRandom - , nodeRemoveChild = _nodeRemoveChild - , eventTargetRemoveEventListener = _eventTargetRemoveEventListener - , elementSetAttribute = _elementSetAttribute - , nodeTextContent = _nodeTextContent } _documentCreateElement :: String -> IO JSVal _documentCreateElement = js_documentCreateElement . toJSString -_elementTagName :: JSVal -> IO String -_elementTagName x = do - v <- js_elementTagName x - return $ fromJSString v - -_nodeTextContent :: JSVal -> IO String -_nodeTextContent x = do - v <- js_nodeTextContent x - return $ fromJSString v - -_elementSetAttribute :: JSVal -> String -> String -> IO () -_elementSetAttribute e k v = - js_elementSetAttribute e (toJSString k) (toJSString v) - _getPropertyAsOpaque :: JSVal -> String -> IO (Maybe JSVal) _getPropertyAsOpaque n k = do isUndef <- js_null_or_undef n @@ -88,57 +80,106 @@ if isUndef' then pure Nothing else pure (Just v) ) -_getString :: JSVal -> String -> IO (Maybe String) -_getString n k = - _getGeneric (\v -> (jsonFromJSVal v) :: Either String String) n k +_castToString :: JSVal -> IO (Maybe String) +_castToString v = pure $ (Just . fromJSString . JSString) v -_getPropertyAsBool :: JSVal -> String -> IO (Maybe Bool) -_getPropertyAsBool n k = - _getGeneric (\v -> (jsonFromJSVal v) :: Either String Bool) n k +_castToByteString :: JSVal -> IO (Maybe ByteString) +_castToByteString v = pure $ (Just . byteStringFromJSUint8Array . JSUint8Array) v -_getPropertyAsInt :: JSVal -> String -> IO (Maybe Int) -_getPropertyAsInt n k = - _getGeneric (\v -> (jsonFromJSVal v) :: Either String Int) n k +_castToBool :: JSVal -> IO (Maybe Bool) +_castToBool n = + _castGeneric (\v -> (jsonFromJSVal v) :: Either String Bool) n -_getPropertyAsDouble :: JSVal -> String -> IO (Maybe Double) -_getPropertyAsDouble n k = - _getGeneric (\v -> (jsonFromJSVal v) :: Either String Double) n k +_castToInt :: JSVal -> IO (Maybe Int) +_castToInt n = + _castGeneric (\v -> (jsonFromJSVal v) :: Either String Int) n -_getGeneric :: (JSVal -> Either String a) -> JSVal -> String -> IO (Maybe a) -_getGeneric f n k = do - isUndef <- js_null_or_undef n - if isUndef +_castToDouble :: JSVal -> IO (Maybe Double) +_castToDouble n = + _castGeneric (\v -> (jsonFromJSVal v) :: Either String Double) n + +_castGeneric :: (JSVal -> Either String a) -> JSVal -> IO (Maybe a) +_castGeneric f v = do + isUndef' <- js_null_or_undef v + if isUndef' then pure Nothing - else - (do - v <- _js_getPropertyAsOpaque n (toJSString k) - isUndef' <- js_null_or_undef v - if isUndef' - then pure Nothing - else (let q = f v in either (\_ -> pure Nothing) (pure . Just) q) - ) + else (let q = f v in either (\_ -> pure Nothing) (pure . Just) q) -_consoleLog :: String -> IO () -_consoleLog t = _js_consoleLog (toJSString t) +_defaultRequestInit = RequestInit { + _ri_method = Nothing + , _ri_headers = Nothing + , _ri_body = Nothing + , _ri_mode = Nothing + , _ri_credentials = Nothing + , _ri_cache = Nothing + , _ri_redirect = Nothing + , _ri_referrer = Nothing + , _ri_integrity = Nothing +} -_consoleLog' :: JSVal -> IO () -_consoleLog' v = _js_consoleLog' v +_s2v :: JSString -> JSVal +_s2v (JSString v) = v +_b2v :: JSUint8Array -> JSVal +_b2v (JSUint8Array v) = v -_eventTargetAddEventListener :: JSVal -> String -> JSVal -> IO () -_eventTargetAddEventListener target event callback = - js_eventTargetAddEventListener target (toJSString event) callback -_eventTargetRemoveEventListener :: JSVal -> String -> JSVal -> IO () -_eventTargetRemoveEventListener target event callback = - js_eventTargetRemoveEventListener target (toJSString event) callback +makeBody :: FetchBody JSVal -> IO JSVal +makeBody (FormDataBody formData) = do + _fd <- _formData + mapM (\(x, y) -> _invokeOn2 _fd "append" (_s2v . toJSString $ x) y) (HM.toList formData) + return _fd +makeBody (StringBody str) = pure (_s2v . toJSString $ str) +makeBody (BlobBody blob) = pure blob +makeBody (URLSearchParamsBody searchParams) = do + _usp <- _urlSearchParams + mapM (\(x, y) -> _invokeOn2 _usp "append" (_s2v . toJSString $ x) (_s2v . toJSString $ y)) (HM.toList searchParams) + return _usp +makeBody (Uint8Array bs) = pure $ (_b2v . byteStringToJSUint8Array $ bs) +kvToJSVal :: (String, String) -> IO (JSVal, JSVal) +kvToJSVal (k, v) = do + _k <- _jsValFromString k + _v <- _jsValFromString v + return $ (_k, _v) + +requestInitToJSVal :: RequestInit JSVal -> IO JSVal +requestInitToJSVal ri = do + obj <- _makeObject + maybe (pure ()) (_setValue' obj "method") (_ri_method ri) + maybe (pure ()) (\hds -> do + __headers <- _headers + kvs <- mapM kvToJSVal (HM.toList hds) + mapM (\(x, y) -> _invokeOn2 __headers "append" x y) kvs + _setValue obj "headers" __headers) (_ri_headers ri) + maybe (pure ()) (\body -> do + _body <- makeBody body + _setValue obj "body" _body) (_ri_body ri) + maybe (pure ()) (_setValue' obj "mode") (_ri_mode ri) + maybe (pure ()) (_setValue' obj "credentials") (_ri_credentials ri) + maybe (pure ()) (_setValue' obj "cache") (_ri_cache ri) + maybe (pure ()) (_setValue' obj "redirect") (_ri_redirect ri) + maybe (pure ()) (_setValue' obj "referrer") (_ri_referrer ri) + maybe (pure ()) (_setValue' obj "integrity") (_ri_integrity ri) + return obj + +_fetch :: String -> RequestInit JSVal -> IO JSVal +_fetch url ri = do + _ri <- requestInitToJSVal ri + _js_fetch (toJSString url) _ri + _documentCreateTextNode :: String -> IO JSVal _documentCreateTextNode = js_documentCreateTextNode . toJSString _invokeOn0 :: JSVal -> String -> IO JSVal _invokeOn0 e s = _js_invokeOn0 e (toJSString s) +_invokeOn1 :: JSVal -> String -> JSVal -> IO JSVal +_invokeOn1 e s v0 = _js_invokeOn1 e (toJSString s) v0 + +_invokeOn2 :: JSVal -> String -> JSVal -> JSVal -> IO JSVal +_invokeOn2 e s v0 v1 = _js_invokeOn2 e (toJSString s) v0 v1 + _documentGetElementById :: String -> IO (Maybe JSVal) _documentGetElementById k = do v <- js_documentGetElementById (toJSString k) @@ -148,6 +189,27 @@ getJSVal :: JSFunction -> JSVal getJSVal (JSFunction x) = x +_castToArray :: JSVal -> IO (Maybe [JSVal]) +_castToArray v = pure $ (Just . fromJSArray . JSArray) v + +_jsValFromString :: String -> IO JSVal +_jsValFromString v = pure $ (x . toJSString) v + where x (JSString s) = s + +_jsValFromByteString :: ByteString -> IO JSVal +_jsValFromByteString v = pure $ (x . byteStringToJSUint8Array) v + where x (JSUint8Array bs) = bs + +_jsValFromArray :: [JSVal] -> IO JSVal +_jsValFromArray v = pure $ (x . toJSArray) v + where x (JSArray bs) = bs + +_setValue :: JSVal -> String -> JSVal -> IO () +_setValue a b c = _js_setValue a (toJSString b) c + +_setValue' :: JSVal -> String -> String -> IO () +_setValue' a b c = _js_setValue a (toJSString b) $ _s2v (toJSString c) + __makeHaskellCallback :: (JSVal -> IO ()) -> IO JSVal __makeHaskellCallback a = do x <- makeHaskellCallback1 a @@ -156,20 +218,46 @@ __freeCallback :: JSVal -> IO () __freeCallback v = freeHaskellCallback (JSFunction v) -_nodeChildNodes :: JSVal -> IO [JSVal] -_nodeChildNodes x = do - v <- _js_nodeChildNodes x - return $ fromJSArray v +foreign import javascript "{}" + _makeObject :: IO JSVal -foreign import javascript "console.log($1)" - _js_consoleLog :: JSString -> IO () +foreign import javascript "new Headers()" + _headers :: IO JSVal +foreign import javascript "new URLSearchParams()" + _urlSearchParams :: IO JSVal + +foreign import javascript "new FormData()" + _formData :: IO JSVal + + +foreign import javascript "$1[$2]=$3" + _js_setValue :: JSVal -> JSString -> JSVal -> IO () + +foreign import javascript "$1" + _jsValFromBool :: Bool -> IO JSVal + +foreign import javascript interruptible "fetch($1, $2)" + _js_fetch :: JSString -> JSVal -> IO JSVal + +foreign import javascript "$1" + _jsValFromInt :: Int -> IO JSVal + +foreign import javascript "$1" + _jsValFromDouble :: Double -> IO JSVal + foreign import javascript "console.log($1)" - _js_consoleLog' :: JSVal -> IO () + _consoleLog :: JSVal -> IO () foreign import javascript "$1[$2]()" _js_invokeOn0 :: JSVal -> JSString -> IO JSVal +foreign import javascript "$1[$2]($3)" + _js_invokeOn1 :: JSVal -> JSString -> JSVal -> IO JSVal + +foreign import javascript "$1[$2]($3,$4)" + _js_invokeOn2 :: JSVal -> JSString -> JSVal -> JSVal -> IO JSVal + foreign import javascript "$1[$2]" _js_getPropertyAsOpaque :: JSVal -> JSString -> IO JSVal @@ -185,38 +273,8 @@ foreign import javascript "document.head" _documentHead :: IO JSVal -foreign import javascript "$1.tagName" - js_elementTagName :: JSVal -> IO JSString - -foreign import javascript "$1.textContent" - js_nodeTextContent :: JSVal -> IO JSString - -foreign import javascript "$1.setAttribute($2,$3)" - js_elementSetAttribute :: JSVal -> JSString -> JSString -> IO () - -foreign import javascript "$1.appendChild($2)" - _nodeAppendChild :: JSVal -> JSVal -> IO () - foreign import javascript "($1 == null) || ($1 == undefined)" js_null_or_undef :: JSVal -> IO Bool - -foreign import javascript "$1.childNodes" - _js_nodeChildNodes :: JSVal -> IO JSArray - -foreign import javascript "$1.click()" - _htmlElemenetClick :: JSVal -> IO () - -foreign import javascript "$1.insertBefore($2,$3)" - _nodeInsertBefore :: JSVal -> JSVal -> JSVal -> IO () - -foreign import javascript "$1.removeChild($2)" - _nodeRemoveChild :: JSVal -> JSVal -> IO () - -foreign import javascript "$1.addEventListener($2,$3)" - js_eventTargetAddEventListener :: JSVal -> JSString -> JSVal -> IO () - -foreign import javascript "$1.removeEventListener($2,$3)" - js_eventTargetRemoveEventListener :: JSVal -> JSString -> JSVal -> IO () foreign import javascript "document.createTextNode($1)" js_documentCreateTextNode :: JSString -> IO JSVal diff --git a/src/Web/Framework/Plzwrk/Browserful.hs b/src/Web/Framework/Plzwrk/Browserful.hs --- a/src/Web/Framework/Plzwrk/Browserful.hs +++ b/src/Web/Framework/Plzwrk/Browserful.hs @@ -1,8 +1,13 @@ module Web.Framework.Plzwrk.Browserful ( Browserful(..) + , RequestInit(..) + , FetchBody(..) ) where +import Data.ByteString.Internal ( ByteString ) +import qualified Data.HashMap.Strict as HM + -- | A data class holding functions that operate on opaque -- JavaScript types, parameterized by @jsval@. When possible, -- the real names of browser functions like 'addEventListener' @@ -16,12 +21,30 @@ data Browserful jsval = Browserful { - -- | Logs a string. See [Console.log](https://developer.mozilla.org/en-US/docs/Web/API/Console/log) - consoleLog :: String -> IO () + -- | Casts a value to an array of jsvals + castToArray :: jsval -> IO (Maybe [jsval]) + -- | Casts a value to a bool + , castToBool :: jsval -> IO (Maybe Bool) + + -- | Casts a value to a bool + , castToByteString :: jsval -> IO (Maybe ByteString) + + -- | Casts a value to a double + , castToDouble :: jsval -> IO (Maybe Double) + + -- | Casts a value to an int + , castToInt :: jsval -> IO (Maybe Int) + + -- | Casts a value to a string + , castToString :: jsval -> IO (Maybe String) + -- | Logs an opaque JavaScript value. See [Console.log](https://developer.mozilla.org/en-US/docs/Web/API/Console/log) - , consoleLog' :: jsval -> IO () + , consoleLog :: jsval -> IO () + -- | A default request init + , defaultRequestInit :: RequestInit jsval + -- | The body of the document. See [Document.body](https://developer.mozilla.org/en-US/docs/Web/API/Document/body) , documentBody :: IO jsval @@ -37,56 +60,47 @@ -- | Gets the head of a document. See [Document.head](https://developer.mozilla.org/en-US/docs/Web/API/Document/head) , documentHead :: IO jsval - -- | Sets on an element an attribute. See [Element.setAttribute](https://developer.mozilla.org/en-US/docs/Web/API/Element/setAttribute) - , elementSetAttribute :: jsval -> String -> String -> IO () + -- | Calls the browser's fetch command + , fetch :: String -> (RequestInit jsval) -> IO jsval - -- | Gets the tag name of an element. See [Element.tagName](https://developer.mozilla.org/en-US/docs/Web/API/Element/tagName) - , elementTagName :: jsval -> IO String + -- | Gets a JavaScript property, returning @Nothing@ if the object being called is null or undefined. + , getPropertyAsOpaque :: jsval -> String -> IO (Maybe jsval) - -- | Takes a target and an event name and adds a listener. See [EventTarget.addEventListener](https://developer.mozilla.org/en-US/docs/Web/API/EventTarget/addEventListener) - , eventTargetAddEventListener :: jsval -> String -> jsval -> IO () + -- | Invokes on target a function with 0 arguments. + , invokeOn0 :: jsval -> String -> IO jsval - -- | Takes a target and an event name and removes a listener. See [EventTarget.removeEventListener](https://developer.mozilla.org/en-US/docs/Web/API/EventTarget/removeEventListener) - , eventTargetRemoveEventListener :: jsval -> String -> jsval -> IO () + -- | Invokes on target a function with 1 argument. + , invokeOn1 :: jsval -> String -> jsval -> IO jsval - -- | Gets a JavaScript property as a bool, returning @Nothing@ if the object being called is null or undefined or the property cannot be cast to a bool. - , getPropertyAsBool :: jsval -> String -> IO (Maybe Bool) + -- | Invokes on target a function with 2 arguments. + , invokeOn2 :: jsval -> String -> jsval -> jsval -> IO jsval - -- | Gets a JavaScript property as a double, returning @Nothing@ if the object being called is null or undefined or the property cannot be cast to a double. - , getPropertyAsDouble :: jsval -> String -> IO (Maybe Double) + -- | jsval from an array of jsvals + , jsValFromArray :: [jsval] -> IO jsval - -- | Gets a JavaScript property as an int, returning @Nothing@ if the object being called is null or undefined or the property cannot be cast to an int. - , getPropertyAsInt :: jsval -> String -> IO (Maybe Int) + -- | jsval from a bool + , jsValFromBool :: Bool -> IO jsval - -- | Gets a JavaScript property, returning @Nothing@ if the object being called is null or undefined. - , getPropertyAsOpaque :: jsval -> String -> IO (Maybe jsval) + -- | jsval from a byte string + , jsValFromByteString :: ByteString -> IO jsval - -- | Gets a JavaScript property as a string, returning @Nothing@ if the object being called is null or undefined or the property cannot be cast to a string. - , getPropertyAsString :: jsval -> String -> IO (Maybe String) + -- | jsval from a double + , jsValFromDouble :: Double -> IO jsval - -- | Takes an element and clicks it. Useful for testing. See [HTMLElement.click](https://developer.mozilla.org/en-US/docs/Web/API/HTMLElement/click) - , htmlElemenetClick :: jsval -> IO () + -- | jsval from an int + , jsValFromInt :: Int -> IO jsval - -- | Invokes on target a function with 0 arguments. - , invokeOn0 :: jsval -> String -> IO jsval + -- | jsval from a string + , jsValFromString :: String -> IO jsval + -- | Creates an object + , makeObject :: IO jsval + -- | Generate a random double between 0 and 1. See [Math.random](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/random) , mathRandom :: IO Double - -- | Takes a node and appends a child. See [Node.appendChild](https://developer.mozilla.org/en-US/docs/Web/API/Node/appendChild) - , nodeAppendChild :: jsval -> jsval -> IO () - - -- | Get the children of a node. See [Node.childNodes](https://developer.mozilla.org/en-US/docs/Web/API/Node/childNodes) - , nodeChildNodes :: jsval -> IO [jsval] - - -- | Insert into an element a new node before a reference node. See [Node.insertBefore](https://developer.mozilla.org/en-US/docs/Web/API/Node/insertBefore) - , nodeInsertBefore :: jsval -> jsval -> jsval -> IO () - - -- | From a node remove a child. See [Node.removeChild](https://developer.mozilla.org/en-US/docs/Web/API/Node/removeChild) - , nodeRemoveChild :: jsval -> jsval -> IO () - - -- | Gets the text content of a node. See [Node.textContent](https://developer.mozilla.org/en-US/docs/Web/API/Node/textContent) - , nodeTextContent :: jsval -> IO String + -- | Sets on an object a value + , setValue :: jsval -> String -> jsval -> IO () -- | Frees a callback. Should only be called in advanced cases. In most usage, callbacks are freed automatically by plzwrk. , _freeCallback :: jsval -> IO () @@ -94,3 +108,24 @@ -- | Makes a haskell callback. Should only be called in advanced cases. In most usage, callbacks are created automatically by plzwrk. , _makeHaskellCallback :: (jsval -> IO ()) -> IO jsval } + +-- |The body of a fetch request or response +data FetchBody jsval = + FormDataBody (HM.HashMap String jsval) -- ^ From form data, ie @multipart/form-data@ or @application/x-www-form-urlencoded@ + | StringBody String -- ^ A string, ie @text/plain@ or @application/json@ + | BlobBody jsval -- ^ A single file + | URLSearchParamsBody (HM.HashMap String String) -- ^ Useful for @application/x-www-form-urlencoded@ + | Uint8Array ByteString + +-- | Initialization parameters for a request made with fetch +data RequestInit jsval = RequestInit { + _ri_method :: Maybe String -- ^ The request method, e.g., GET, POST. The default is GET. + , _ri_headers :: Maybe (HM.HashMap String String) -- ^ Any headers you want to add to your request, contained within a Headers object or an object literal with ByteString values. + , _ri_body :: Maybe (FetchBody jsval) -- ^ Any body that you want to add to your request: this can be a Blob, BufferSource, FormData, URLSearchParams, USVString, or ReadableStream object. Note that a request using the GET or HEAD method cannot have a body. + , _ri_mode :: Maybe String -- ^ The mode you want to use for the request, e.g., cors, no-cors, same-origin, or navigate. The default is cors. + , _ri_credentials :: Maybe String -- ^ The request credentials you want to use for the request: omit, same-origin, or include. The default is same-origin. + , _ri_cache :: Maybe String -- ^ The cache mode you want to use for the request. + , _ri_redirect :: Maybe String -- ^ The redirect mode to use: follow, error, or manual. The default is follow. + , _ri_referrer :: Maybe String -- ^ A USVString specifying no-referrer, client, or a URL. The default is about:client. + , _ri_integrity :: Maybe String -- ^ Contains the subresource integrity value of the request (e.g., sha256-BpfBw7ivV8q2jLiT13fxDYAe2tJllusRSZ273h2nFSE=). +} diff --git a/src/Web/Framework/Plzwrk/Domify.hs b/src/Web/Framework/Plzwrk/Domify.hs --- a/src/Web/Framework/Plzwrk/Domify.hs +++ b/src/Web/Framework/Plzwrk/Domify.hs @@ -1,481 +1,483 @@ -module Web.Framework.Plzwrk.Domify - ( plzwrk - , plzwrk' - , plzwrk'_ - , plzwrkSSR - , plzwrkSSR' - , plzwrkSSR'_ - ) -where - -import Control.Applicative -import Control.Monad -import Control.Monad.Reader -import Control.Monad.Trans -import Control.Monad.Trans.Maybe -import qualified Data.HashMap.Strict as HM -import Data.IORef -import Data.Maybe ( catMaybes ) -import qualified Data.Set as S -import Web.Framework.Plzwrk.Base -import Web.Framework.Plzwrk.Browserful - -data DomifiedAttributes jsval = MkDomifiedAttributes - { _d_style :: HM.HashMap String String - , _d_class :: S.Set String - , _d_simple :: HM.HashMap String String - , _d_handlers :: HM.HashMap String jsval - } - -data DomifiedNode jsval = DomifiedElement - { _dom_tag :: String - , _dom_attr :: (DomifiedAttributes jsval) - , _dom_kids :: [DomifiedNode jsval] - , _dom_ptr :: jsval - } - | DomifiedTextNode String jsval - -data OldStuff state jsval = OldStuff { - _oldState :: state, - _oldDom :: Maybe (DomifiedNode jsval) -} - ----------- reader functions - - - - -freeAttrFunctions - :: DomifiedAttributes jsval -> ReaderT (Browserful jsval) IO () -freeAttrFunctions (MkDomifiedAttributes _ _ _ __d_handlers) = do - __freeCallback <- asks _freeCallback - liftIO $ void (mapM __freeCallback (HM.elems __d_handlers)) - -freeFunctions :: DomifiedNode jsval -> ReaderT (Browserful jsval) IO () -freeFunctions (DomifiedElement _ b c _) = do - freeAttrFunctions b - mapM_ freeFunctions c -freeFunctions _ = pure () - -nodesEq - :: String - -> String - -> DomifiedAttributes jsval - -> Attributes state jsval - -> Bool -nodesEq t0 t1 (MkDomifiedAttributes __d_style __d_class __d_simple _) (MkAttributes __style __class __simple _) - = (t0 == t1) - && (__d_style == __style) - && (__d_class == __class) - && (__d_simple == __simple) - -padr :: Int -> a -> [a] -> [a] -padr i v l = if (length l >= i) then l else padr i v (l ++ [v]) - -reconcile - :: Bool - -> IORef (OldStuff state jsval) - -> (state -> Node state jsval) - -> jsval - -> jsval - -> Maybe (DomifiedNode jsval) - -> Maybe (HydratedNode state jsval) - -> ReaderT - (Browserful jsval) - IO - (Maybe (DomifiedNode jsval)) -reconcile touchDOM refToOldStuff domCreationF parentNode topLevelNode (Just (DomifiedElement currentTag currentAttributes currentChildren currentNode)) (Just maybeNewNode@(HydratedElement maybeNewTag maybeNewAttributes maybeNewChildren)) - = if (nodesEq currentTag maybeNewTag currentAttributes maybeNewAttributes) - then - (do - let maxlen = max (length maybeNewChildren) (length currentChildren) - newChildren <- sequence $ getZipList - ( (reconcile touchDOM - refToOldStuff - domCreationF - currentNode - topLevelNode - ) - <$> (ZipList (padr maxlen Nothing (fmap Just currentChildren))) - <*> (ZipList (padr maxlen Nothing (fmap Just maybeNewChildren))) - ) - currentAttributes <- hydratedAttrsToDomifiedAttrs refToOldStuff - domCreationF - parentNode - maybeNewAttributes - if touchDOM - then - (do - removeEventHandlers currentNode currentAttributes - setEventHandlers currentNode currentAttributes - ) - else (pure ()) - return $ Just - (DomifiedElement currentTag - currentAttributes - (catMaybes newChildren) - currentNode - ) - ) - else - (do - res <- domify touchDOM - refToOldStuff - domCreationF - parentNode - topLevelNode - (Just currentNode) - maybeNewNode - return $ Just res - ) -reconcile touchDOM refToOldStuff domCreationF parentNode topLevelNode (Just currentDomifiedString@(DomifiedTextNode currentString currentNode)) (Just maybeNewNode@(HydratedTextNode maybeNewString)) - = if (currentString == maybeNewString) - then pure (Just currentDomifiedString) - else - (do - res <- domify touchDOM - refToOldStuff - domCreationF - parentNode - topLevelNode - (Just currentNode) - maybeNewNode - return $ Just res - ) -reconcile touchDOM refToOldStuff domCreationF parentNode topLevelNode (Just (DomifiedElement _ _ _ currentNode)) (Just maybeNewNode@(HydratedTextNode _)) - = do - res <- domify touchDOM - refToOldStuff - domCreationF - parentNode - topLevelNode - (Just currentNode) - maybeNewNode - return $ Just res -reconcile touchDOM refToOldStuff domCreationF parentNode topLevelNode (Just (DomifiedTextNode _ currentNode)) (Just maybeNewNode@(HydratedElement _ _ _)) - = do - res <- domify touchDOM - refToOldStuff - domCreationF - parentNode - topLevelNode - (Just currentNode) - maybeNewNode - return $ Just res -reconcile touchDOM refToOldStuff domCreationF parentNode topLevelNode Nothing (Just maybeNewNode) - = do - res <- domify touchDOM - refToOldStuff - domCreationF - parentNode - topLevelNode - Nothing - maybeNewNode - return $ Just res -reconcile touchDOM refToOldStuff domCreationF parentNode _ (Just (DomifiedElement _ _ _ currentNode)) Nothing - = if (touchDOM) - then - (do - _nodeRemoveChild <- asks nodeRemoveChild - liftIO $ _nodeRemoveChild parentNode currentNode - return Nothing - ) - else (pure Nothing) -reconcile touchDOM refToOldStuff domCreationF parentNode _ (Just (DomifiedTextNode _ currentNode)) Nothing - = if (touchDOM) - then - (do - _nodeRemoveChild <- asks nodeRemoveChild - liftIO $ _nodeRemoveChild parentNode currentNode - return Nothing - ) - else (pure Nothing) -reconcile _ _ _ _ _ _ _ = error "Inconsistent state" - -reconcileAndAdd = reconcile True - -cbMaker - :: IORef (OldStuff state jsval) - -> (state -> Node state jsval) - -> jsval - -> (jsval -> state -> IO state) - -> Browserful jsval - -> jsval - -> IO () -cbMaker refToOldStuff domCreationF topLevelNode eventToState env event = do - oldStuff <- readIORef refToOldStuff - let oldDom = _oldDom oldStuff - let oldState = _oldState oldStuff - newState <- eventToState event oldState - let newHydratedDom = hydrate newState domCreationF - newDom <- runReaderT - (reconcileAndAdd refToOldStuff - domCreationF - topLevelNode - topLevelNode - oldDom - (Just newHydratedDom) - ) - env - maybe (pure ()) (\x -> runReaderT (freeFunctions x) env) oldDom - writeIORef refToOldStuff (OldStuff newState newDom) - -eventable - :: IORef (OldStuff state jsval) - -> (state -> Node state jsval) - -> jsval - -> (jsval -> state -> IO state) - -> ReaderT (Browserful jsval) IO jsval -eventable refToOldStuff domCreationF topLevelNode eventToState = do - __makeHaskellCallback <- asks _makeHaskellCallback - env <- ask - liftIO $ __makeHaskellCallback - (cbMaker refToOldStuff domCreationF topLevelNode eventToState env) - -hydratedAttrsToDomifiedAttrs - :: IORef (OldStuff state jsval) - -> (state -> Node state jsval) - -> jsval - -> Attributes state jsval - -> ReaderT (Browserful jsval) IO (DomifiedAttributes jsval) -hydratedAttrsToDomifiedAttrs refToOldStuff domCreationF topLevelNode (MkAttributes __style __class __simple __handlers) - = do - handlers <- mapM - (\(k, v) -> do - func <- eventable refToOldStuff domCreationF topLevelNode v - return $ (k, func) - ) - (HM.toList __handlers) - return - $ MkDomifiedAttributes __style __class __simple (HM.fromList handlers) - -setAtts :: jsval -> DomifiedAttributes jsval -> ReaderT (Browserful jsval) IO () -setAtts currentNode domifiedAttributes@(MkDomifiedAttributes __style __class __simple _) - = do - _elementSetAttribute <- asks elementSetAttribute - liftIO $ if (HM.null __style) - then (pure ()) - else (_elementSetAttribute currentNode "style") . cssToStyle $ __style - liftIO $ if (S.null __class) - then (pure ()) - else - ((_elementSetAttribute currentNode "class") . unwords . S.toList) - $ __class - liftIO $ mapM_ (\x -> _elementSetAttribute currentNode (fst x) (snd x)) - (HM.toList __simple) - setEventHandlers currentNode domifiedAttributes - -handleOnlyEventListeners - :: (jsval -> String -> jsval -> IO ()) - -> jsval - -> DomifiedAttributes jsval - -> IO () -handleOnlyEventListeners eventListenerHandlerF currentNode domifiedAttributes = - void $ mapM (\(k, v) -> eventListenerHandlerF currentNode k v) - (HM.toList . _d_handlers $ domifiedAttributes) - -setEventHandlers - :: jsval -> DomifiedAttributes jsval -> ReaderT (Browserful jsval) IO () -setEventHandlers currentNode domifiedAttributes = do - _eventTargetAddEventListener <- asks eventTargetAddEventListener - liftIO $ handleOnlyEventListeners _eventTargetAddEventListener - currentNode - domifiedAttributes - -removeEventHandlers - :: jsval -> DomifiedAttributes jsval -> ReaderT (Browserful jsval) IO () -removeEventHandlers currentNode domifiedAttributes = do - _eventTargetRemoveEventListener <- asks eventTargetRemoveEventListener - liftIO $ handleOnlyEventListeners _eventTargetRemoveEventListener - currentNode - domifiedAttributes - -domify - :: Bool - -> IORef (OldStuff state jsval) - -> (state -> Node state jsval) - -> jsval - -> jsval - -> Maybe jsval - -> HydratedNode state jsval - -> ReaderT (Browserful jsval) IO (DomifiedNode jsval) -domify touchDOM refToOldStuff domCreationF parentNode topLevelNode replacing (HydratedElement tag attrs children) - = do - _documentCreateElement <- asks documentCreateElement - _nodeAppendChild <- asks nodeAppendChild - _nodeInsertBefore <- asks nodeInsertBefore - _nodeRemoveChild <- asks nodeRemoveChild - newNode <- liftIO $ _documentCreateElement tag - newAttributes <- hydratedAttrsToDomifiedAttrs refToOldStuff - domCreationF - topLevelNode - attrs - if touchDOM then (setAtts newNode newAttributes) else (pure ()) - newChildren <- mapM - (domify touchDOM refToOldStuff domCreationF newNode topLevelNode Nothing) - children - if touchDOM - then - (do - maybe - (liftIO $ _nodeAppendChild parentNode newNode) - (\x -> do - liftIO $ _nodeInsertBefore parentNode newNode x - liftIO $ _nodeRemoveChild parentNode x - ) - replacing - ) - else (pure ()) - liftIO $ return (DomifiedElement tag newAttributes newChildren newNode) -domify touchDOM _ _ parentNode topLevelNode replacing (HydratedTextNode text) = - do - _documentCreateElement <- asks documentCreateElement - _nodeAppendChild <- asks nodeAppendChild - _nodeInsertBefore <- asks nodeInsertBefore - _nodeRemoveChild <- asks nodeRemoveChild - _documentCreateTextNode <- asks documentCreateTextNode - newTextNode <- liftIO $ _documentCreateTextNode text - if touchDOM - then - (do - maybe - (liftIO $ _nodeAppendChild parentNode newTextNode) - (\x -> do - liftIO $ _nodeInsertBefore parentNode newTextNode x - liftIO $ _nodeRemoveChild parentNode x - ) - replacing - ) - else (pure ()) - liftIO $ return (DomifiedTextNode text newTextNode) - -getChildren :: DomifiedNode jsval -> [DomifiedNode jsval] -getChildren (DomifiedElement _ _ x _) = x -getChildren _ = [] - -setEventHandlers_ - :: jsval -> DomifiedNode jsval -> ReaderT (Browserful jsval) IO () -setEventHandlers_ v (DomifiedElement _ a _ _) = setEventHandlers v a -setEventHandlers_ _ _ = liftIO $ pure () - -transformFromCurrentDom - :: jsval - -> [DomifiedNode jsval] - -> ReaderT (Browserful jsval) IO [DomifiedNode jsval] -transformFromCurrentDom parentNode children = do - _nodeChildNodes <- asks nodeChildNodes - kids <- liftIO $ _nodeChildNodes parentNode - newChildren <- sequence $ getZipList - ( transformFromCurrentDom - <$> (ZipList kids) - <*> (ZipList $ fmap getChildren children) - ) - sequence - $ getZipList (setEventHandlers_ <$> (ZipList kids) <*> (ZipList children)) - return $ getZipList - ( (\cur chldrn ptr -> cur { _dom_kids = chldrn, _dom_ptr = ptr }) - <$> (ZipList children) - <*> (ZipList newChildren) - <*> (ZipList kids) - ) - -addHandlers - :: jsval - -> DomifiedNode jsval - -> ReaderT (Browserful jsval) IO (DomifiedNode jsval) -addHandlers parentNode curDom = do - transformed <- transformFromCurrentDom parentNode [curDom] - return $ (transformed !! 0) - -__plzwrk - :: Bool - -> (state -> Node state jsval) - -> state - -> jsval - -> Browserful jsval - -> IO (Maybe (DomifiedNode jsval)) -__plzwrk cleanDOM domF state parentNode env = do - refToOldStuff <- newIORef (OldStuff state Nothing) - newDom <- runReaderT - (reconcile cleanDOM - refToOldStuff - domF - parentNode - parentNode - Nothing - (Just $ hydrate state domF) - ) - env - writeIORef refToOldStuff (OldStuff state newDom) - if (not cleanDOM) - then - (maybe - (pure Nothing) - (\y -> do - withHandlers <- runReaderT (addHandlers parentNode y) env - writeIORef refToOldStuff (OldStuff state (Just y)) - return $ Just withHandlers - ) - newDom - ) - else pure newDom - -_plzwrk - :: Bool - -> (state -> Node state jsval) - -> state - -> Browserful jsval - -> String - -> IO (Maybe (DomifiedNode jsval)) -_plzwrk cleanDOM domF state env nodeId = do - parentNode <- (documentGetElementById env) nodeId - maybe (error ("Node with id not in DOM: " <> show nodeId)) - (\x -> __plzwrk cleanDOM domF state x env) - parentNode - - --- |The main function that makes a web app. -plzwrk - :: (state -> Node state jsval) -- ^ A function that takes a state and produces a DOM - -> state -- ^ An initial state - -> Browserful jsval -- ^ A browser implementation, ie Asterius or the mock browser - -> String -- ^ The id of the element into which the DOM is inserted. Note that plzwrk manages all children under this element. Touching the managed elements can break plzwrk. - -> IO () -- ^ Returns nothing -plzwrk domF state env nodeId = void $ _plzwrk True domF state env nodeId - --- |A variant of plzwrk that acts on a node already rendered to the DOM, --- ie by server-side rendering. It assumes the node has been rendered --- with the same state-to-node function as well as the same state. -plzwrkSSR - :: (state -> Node state jsval) -- ^ A function that takes a state and produces a DOM - -> state -- ^ An initial state - -> Browserful jsval -- ^ A browser implementation, ie Asterius or the mock browser - -> String -- ^ The id of the element into which the DOM is inserted. Note that plzwrk manages all children under this element. Touching the managed elements can break plzwrk. - -> IO () -- ^ Returns nothing -plzwrkSSR domF state env nodeId = void $ _plzwrk False domF state env nodeId - -_plzwrk' - :: Bool - -> (state -> Node state jsval) - -> state - -> Browserful jsval - -> IO (Maybe (DomifiedNode jsval)) -_plzwrk' cleanDOM domF state env = do - parentNode <- (documentBody env) - __plzwrk cleanDOM domF state parentNode env - --- |A variation of plzwrk that inserts the node as a child of the document's body. -plzwrk' :: (state -> Node state jsval) -> state -> Browserful jsval -> IO () -plzwrk' domF state env = void $ _plzwrk' True domF state env - --- |A variation of plzwrk that inserts the node as a child of the document's body. -plzwrkSSR' :: (state -> Node state jsval) -> state -> Browserful jsval -> IO () -plzwrkSSR' domF state env = void $ _plzwrk' False domF state env - --- |A variation of plzwrk that takes no state. -plzwrk'_ :: (() -> Node () jsval) -> Browserful jsval -> IO () -plzwrk'_ domF env = plzwrk' domF () env - --- |A variation of plzwrkSSR that takes no state. -plzwrkSSR'_ :: (() -> Node () jsval) -> Browserful jsval -> IO () -plzwrkSSR'_ domF env = plzwrkSSR' domF () env +module Web.Framework.Plzwrk.Domify + ( plzwrk + , plzwrk' + , plzwrk'_ + , plzwrkSSR + , plzwrkSSR' + , plzwrkSSR'_ + ) +where + +import Control.Applicative +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Trans +import Control.Monad.Trans.Maybe +import qualified Data.HashMap.Strict as HM +import Data.IORef +import Data.Maybe ( catMaybes ) +import qualified Data.Set as S +import Web.Framework.Plzwrk.Base +import Web.Framework.Plzwrk.Browserful +import Web.Framework.Plzwrk.Util + +data DomifiedAttributes jsval = MkDomifiedAttributes + { _d_style :: HM.HashMap String String + , _d_class :: S.Set String + , _d_simple :: HM.HashMap String String + , _d_handlers :: HM.HashMap String jsval + } + +data DomifiedNode jsval = DomifiedElement + { _dom_tag :: String + , _dom_attr :: (DomifiedAttributes jsval) + , _dom_kids :: [DomifiedNode jsval] + , _dom_ptr :: jsval + } + | DomifiedTextNode String jsval + +data OldStuff state jsval = OldStuff { + _oldState :: state, + _oldDom :: Maybe (DomifiedNode jsval) +} + +---------- reader functions + + + + +freeAttrFunctions + :: DomifiedAttributes jsval -> ReaderT (Browserful jsval) IO () +freeAttrFunctions (MkDomifiedAttributes _ _ _ __d_handlers) = do + __freeCallback <- asks _freeCallback + liftIO $ void (mapM __freeCallback (HM.elems __d_handlers)) + +freeFunctions :: DomifiedNode jsval -> ReaderT (Browserful jsval) IO () +freeFunctions (DomifiedElement _ b c _) = do + freeAttrFunctions b + mapM_ freeFunctions c +freeFunctions _ = pure () + +nodesEq + :: String + -> String + -> DomifiedAttributes jsval + -> Attributes state jsval + -> Bool +nodesEq t0 t1 (MkDomifiedAttributes __d_style __d_class __d_simple _) (MkAttributes __style __class __simple _) + = (t0 == t1) + && (__d_style == __style) + && (__d_class == __class) + && (__d_simple == __simple) + +padr :: Int -> a -> [a] -> [a] +padr i v l = if (length l >= i) then l else padr i v (l ++ [v]) + +reconcile + :: Bool + -> IORef (OldStuff state jsval) + -> (state -> Node state jsval) + -> jsval + -> jsval + -> Maybe (DomifiedNode jsval) + -> Maybe (HydratedNode state jsval) + -> ReaderT + (Browserful jsval) + IO + (Maybe (DomifiedNode jsval)) +reconcile touchDOM refToOldStuff domCreationF parentNode topLevelNode (Just (DomifiedElement currentTag currentAttributes currentChildren currentNode)) (Just maybeNewNode@(HydratedElement maybeNewTag maybeNewAttributes maybeNewChildren)) + = if (nodesEq currentTag maybeNewTag currentAttributes maybeNewAttributes) + then + (do + let maxlen = max (length maybeNewChildren) (length currentChildren) + newChildren <- sequence $ getZipList + ( (reconcile touchDOM + refToOldStuff + domCreationF + currentNode + topLevelNode + ) + <$> (ZipList (padr maxlen Nothing (fmap Just currentChildren))) + <*> (ZipList (padr maxlen Nothing (fmap Just maybeNewChildren))) + ) + currentAttributes <- hydratedAttrsToDomifiedAttrs refToOldStuff + domCreationF + parentNode + maybeNewAttributes + if touchDOM + then + (do + removeEventHandlers currentNode currentAttributes + setEventHandlers currentNode currentAttributes + ) + else (pure ()) + return $ Just + (DomifiedElement currentTag + currentAttributes + (catMaybes newChildren) + currentNode + ) + ) + else + (do + res <- domify touchDOM + refToOldStuff + domCreationF + parentNode + topLevelNode + (Just currentNode) + maybeNewNode + return $ Just res + ) +reconcile touchDOM refToOldStuff domCreationF parentNode topLevelNode (Just currentDomifiedString@(DomifiedTextNode currentString currentNode)) (Just maybeNewNode@(HydratedTextNode maybeNewString)) + = if (currentString == maybeNewString) + then pure (Just currentDomifiedString) + else + (do + res <- domify touchDOM + refToOldStuff + domCreationF + parentNode + topLevelNode + (Just currentNode) + maybeNewNode + return $ Just res + ) +reconcile touchDOM refToOldStuff domCreationF parentNode topLevelNode (Just (DomifiedElement _ _ _ currentNode)) (Just maybeNewNode@(HydratedTextNode _)) + = do + res <- domify touchDOM + refToOldStuff + domCreationF + parentNode + topLevelNode + (Just currentNode) + maybeNewNode + return $ Just res +reconcile touchDOM refToOldStuff domCreationF parentNode topLevelNode (Just (DomifiedTextNode _ currentNode)) (Just maybeNewNode@(HydratedElement _ _ _)) + = do + res <- domify touchDOM + refToOldStuff + domCreationF + parentNode + topLevelNode + (Just currentNode) + maybeNewNode + return $ Just res +reconcile touchDOM refToOldStuff domCreationF parentNode topLevelNode Nothing (Just maybeNewNode) + = do + res <- domify touchDOM + refToOldStuff + domCreationF + parentNode + topLevelNode + Nothing + maybeNewNode + return $ Just res +reconcile touchDOM refToOldStuff domCreationF parentNode _ (Just (DomifiedElement _ _ _ currentNode)) Nothing + = if (touchDOM) + then + (do + _nodeRemoveChild <- asks nodeRemoveChild + liftIO $ _nodeRemoveChild parentNode currentNode + return Nothing + ) + else (pure Nothing) +reconcile touchDOM refToOldStuff domCreationF parentNode _ (Just (DomifiedTextNode _ currentNode)) Nothing + = if (touchDOM) + then + (do + _nodeRemoveChild <- asks nodeRemoveChild + liftIO $ _nodeRemoveChild parentNode currentNode + return Nothing + ) + else (pure Nothing) +reconcile _ _ _ _ _ _ _ = error "Inconsistent state" + +reconcileAndAdd = reconcile True + +cbMaker + :: IORef (OldStuff state jsval) + -> (state -> Node state jsval) + -> jsval + -> (jsval -> state -> IO state) + -> Browserful jsval + -> jsval + -> IO () +cbMaker refToOldStuff domCreationF topLevelNode eventToState env event = do + oldStuff <- readIORef refToOldStuff + let oldDom = _oldDom oldStuff + let oldState = _oldState oldStuff + newState <- eventToState event oldState + let newHydratedDom = hydrate newState domCreationF + newDom <- runReaderT + (reconcileAndAdd refToOldStuff + domCreationF + topLevelNode + topLevelNode + oldDom + (Just newHydratedDom) + ) + env + maybe (pure ()) (\x -> runReaderT (freeFunctions x) env) oldDom + writeIORef refToOldStuff (OldStuff newState newDom) + +eventable + :: IORef (OldStuff state jsval) + -> (state -> Node state jsval) + -> jsval + -> (jsval -> state -> IO state) + -> ReaderT (Browserful jsval) IO jsval +eventable refToOldStuff domCreationF topLevelNode eventToState = do + __makeHaskellCallback <- asks _makeHaskellCallback + env <- ask + liftIO $ __makeHaskellCallback + (cbMaker refToOldStuff domCreationF topLevelNode eventToState env) + +hydratedAttrsToDomifiedAttrs + :: IORef (OldStuff state jsval) + -> (state -> Node state jsval) + -> jsval + -> Attributes state jsval + -> ReaderT (Browserful jsval) IO (DomifiedAttributes jsval) +hydratedAttrsToDomifiedAttrs refToOldStuff domCreationF topLevelNode (MkAttributes __style __class __simple __handlers) + = do + handlers <- mapM + (\(k, v) -> do + func <- eventable refToOldStuff domCreationF topLevelNode v + return $ (k, func) + ) + (HM.toList __handlers) + return + $ MkDomifiedAttributes __style __class __simple (HM.fromList handlers) + +setAtts :: jsval -> DomifiedAttributes jsval -> ReaderT (Browserful jsval) IO () +setAtts currentNode domifiedAttributes@(MkDomifiedAttributes __style __class __simple _) + = do + _elementSetAttribute <- asks elementSetAttribute + liftIO $ if (HM.null __style) + then (pure ()) + else (_elementSetAttribute currentNode "style") . cssToStyle $ __style + liftIO $ if (S.null __class) + then (pure ()) + else + ((_elementSetAttribute currentNode "class") . unwords . S.toList) + $ __class + liftIO $ mapM_ (\x -> _elementSetAttribute currentNode (fst x) (snd x)) + (HM.toList __simple) + setEventHandlers currentNode domifiedAttributes + +handleOnlyEventListeners + :: (jsval -> String -> jsval -> IO ()) + -> jsval + -> DomifiedAttributes jsval + -> IO () +handleOnlyEventListeners eventListenerHandlerF currentNode domifiedAttributes = + void $ mapM (\(k, v) -> eventListenerHandlerF currentNode k v) + (HM.toList . _d_handlers $ domifiedAttributes) + +setEventHandlers + :: jsval -> DomifiedAttributes jsval -> ReaderT (Browserful jsval) IO () +setEventHandlers currentNode domifiedAttributes = do + _eventTargetAddEventListener <- asks eventTargetAddEventListener + liftIO $ handleOnlyEventListeners _eventTargetAddEventListener + currentNode + domifiedAttributes + +removeEventHandlers + :: jsval -> DomifiedAttributes jsval -> ReaderT (Browserful jsval) IO () +removeEventHandlers currentNode domifiedAttributes = do + _eventTargetRemoveEventListener <- asks eventTargetRemoveEventListener + liftIO $ handleOnlyEventListeners _eventTargetRemoveEventListener + currentNode + domifiedAttributes + +domify + :: Bool + -> IORef (OldStuff state jsval) + -> (state -> Node state jsval) + -> jsval + -> jsval + -> Maybe jsval + -> HydratedNode state jsval + -> ReaderT (Browserful jsval) IO (DomifiedNode jsval) +domify touchDOM refToOldStuff domCreationF parentNode topLevelNode replacing (HydratedElement tag attrs children) + = do + _documentCreateElement <- asks documentCreateElement + _nodeAppendChild <- asks nodeAppendChild + _nodeInsertBefore <- asks nodeInsertBefore + _nodeRemoveChild <- asks nodeRemoveChild + newNode <- liftIO $ _documentCreateElement tag + newAttributes <- hydratedAttrsToDomifiedAttrs refToOldStuff + domCreationF + topLevelNode + attrs + if touchDOM then (setAtts newNode newAttributes) else (pure ()) + newChildren <- mapM + (domify touchDOM refToOldStuff domCreationF newNode topLevelNode Nothing) + children + if touchDOM + then + (do + maybe + (liftIO $ _nodeAppendChild parentNode newNode) + (\x -> do + liftIO $ _nodeInsertBefore parentNode newNode x + liftIO $ _nodeRemoveChild parentNode x + ) + replacing + ) + else (pure ()) + liftIO $ return (DomifiedElement tag newAttributes newChildren newNode) +domify touchDOM _ _ parentNode topLevelNode replacing (HydratedTextNode text) = + do + _documentCreateElement <- asks documentCreateElement + _nodeAppendChild <- asks nodeAppendChild + _nodeInsertBefore <- asks nodeInsertBefore + _nodeRemoveChild <- asks nodeRemoveChild + _documentCreateTextNode <- asks documentCreateTextNode + newTextNode <- liftIO $ _documentCreateTextNode text + if touchDOM + then + (do + maybe + (liftIO $ _nodeAppendChild parentNode newTextNode) + (\x -> do + liftIO $ _nodeInsertBefore parentNode newTextNode x + liftIO $ _nodeRemoveChild parentNode x + ) + replacing + ) + else (pure ()) + liftIO $ return (DomifiedTextNode text newTextNode) + +getChildren :: DomifiedNode jsval -> [DomifiedNode jsval] +getChildren (DomifiedElement _ _ x _) = x +getChildren _ = [] + +setEventHandlers_ + :: jsval -> DomifiedNode jsval -> ReaderT (Browserful jsval) IO () +setEventHandlers_ v (DomifiedElement _ a _ _) = setEventHandlers v a +setEventHandlers_ _ _ = liftIO $ pure () + +transformFromCurrentDom + :: jsval + -> [DomifiedNode jsval] + -> ReaderT (Browserful jsval) IO [DomifiedNode jsval] +transformFromCurrentDom parentNode children = do + _nodeChildNodes <- asks nodeChildNodes + _kids <- liftIO $ _nodeChildNodes parentNode + let kids = maybe [] id _kids + newChildren <- sequence $ getZipList + ( transformFromCurrentDom + <$> (ZipList kids) + <*> (ZipList $ fmap getChildren children) + ) + sequence + $ getZipList (setEventHandlers_ <$> (ZipList kids) <*> (ZipList children)) + return $ getZipList + ( (\cur chldrn ptr -> cur { _dom_kids = chldrn, _dom_ptr = ptr }) + <$> (ZipList children) + <*> (ZipList newChildren) + <*> (ZipList kids) + ) + +addHandlers + :: jsval + -> DomifiedNode jsval + -> ReaderT (Browserful jsval) IO (DomifiedNode jsval) +addHandlers parentNode curDom = do + transformed <- transformFromCurrentDom parentNode [curDom] + return $ (transformed !! 0) + +__plzwrk + :: Bool + -> (state -> Node state jsval) + -> state + -> jsval + -> Browserful jsval + -> IO (Maybe (DomifiedNode jsval)) +__plzwrk cleanDOM domF state parentNode env = do + refToOldStuff <- newIORef (OldStuff state Nothing) + newDom <- runReaderT + (reconcile cleanDOM + refToOldStuff + domF + parentNode + parentNode + Nothing + (Just $ hydrate state domF) + ) + env + writeIORef refToOldStuff (OldStuff state newDom) + if (not cleanDOM) + then + (maybe + (pure Nothing) + (\y -> do + withHandlers <- runReaderT (addHandlers parentNode y) env + writeIORef refToOldStuff (OldStuff state (Just y)) + return $ Just withHandlers + ) + newDom + ) + else pure newDom + +_plzwrk + :: Bool + -> (state -> Node state jsval) + -> state + -> Browserful jsval + -> String + -> IO (Maybe (DomifiedNode jsval)) +_plzwrk cleanDOM domF state env nodeId = do + parentNode <- (documentGetElementById env) nodeId + maybe (error ("Node with id not in DOM: " <> show nodeId)) + (\x -> __plzwrk cleanDOM domF state x env) + parentNode + + +-- |The main function that makes a web app. +plzwrk + :: (state -> Node state jsval) -- ^ A function that takes a state and produces a DOM + -> state -- ^ An initial state + -> Browserful jsval -- ^ A browser implementation, ie Asterius or the mock browser + -> String -- ^ The id of the element into which the DOM is inserted. Note that plzwrk manages all children under this element. Touching the managed elements can break plzwrk. + -> IO () -- ^ Returns nothing +plzwrk domF state env nodeId = void $ _plzwrk True domF state env nodeId + +-- |A variant of plzwrk that acts on a node already rendered to the DOM, +-- ie by server-side rendering. It assumes the node has been rendered +-- with the same state-to-node function as well as the same state. +plzwrkSSR + :: (state -> Node state jsval) -- ^ A function that takes a state and produces a DOM + -> state -- ^ An initial state + -> Browserful jsval -- ^ A browser implementation, ie Asterius or the mock browser + -> String -- ^ The id of the element into which the DOM is inserted. Note that plzwrk manages all children under this element. Touching the managed elements can break plzwrk. + -> IO () -- ^ Returns nothing +plzwrkSSR domF state env nodeId = void $ _plzwrk False domF state env nodeId + +_plzwrk' + :: Bool + -> (state -> Node state jsval) + -> state + -> Browserful jsval + -> IO (Maybe (DomifiedNode jsval)) +_plzwrk' cleanDOM domF state env = do + parentNode <- (documentBody env) + __plzwrk cleanDOM domF state parentNode env + +-- |A variation of plzwrk that inserts the node as a child of the document's body. +plzwrk' :: (state -> Node state jsval) -> state -> Browserful jsval -> IO () +plzwrk' domF state env = void $ _plzwrk' True domF state env + +-- |A variation of plzwrk that inserts the node as a child of the document's body. +plzwrkSSR' :: (state -> Node state jsval) -> state -> Browserful jsval -> IO () +plzwrkSSR' domF state env = void $ _plzwrk' False domF state env + +-- |A variation of plzwrk that takes no state. +plzwrk'_ :: (() -> Node () jsval) -> Browserful jsval -> IO () +plzwrk'_ domF env = plzwrk' domF () env + +-- |A variation of plzwrkSSR that takes no state. +plzwrkSSR'_ :: (() -> Node () jsval) -> Browserful jsval -> IO () +plzwrkSSR'_ domF env = plzwrkSSR' domF () env diff --git a/src/Web/Framework/Plzwrk/MockJSVal.hs b/src/Web/Framework/Plzwrk/MockJSVal.hs --- a/src/Web/Framework/Plzwrk/MockJSVal.hs +++ b/src/Web/Framework/Plzwrk/MockJSVal.hs @@ -1,519 +1,693 @@ -{-| -Module : Web.Framework.Plzwrk.MockJSVal -Description : Mock browser for testing -Copyright : (c) Mike Solomon 2020 -License : GPL-3 -Maintainer : mike@meeshkan.com -Stability : experimental -Portability : POSIX, Windows - -This module exports a mock browser called -@defaultInternalBrowser@ used in plzwrk's tests -and that can be used in your unit tests as well. --} -module Web.Framework.Plzwrk.MockJSVal - ( MockJSVal(..) - , makeMockBrowser - , defaultInternalBrowser - , makeMockBrowserWithContext - ) -where - -import Data.Aeson ( FromJSON ) -import Data.HashMap.Strict hiding ( foldr - , null - ) -import Data.IORef -import Data.List ( elemIndex ) -import Prelude hiding ( lookup ) -import System.Random -import Web.Framework.Plzwrk.Base -import Web.Framework.Plzwrk.Browserful - -data LogEvent = ListenerReceived String Int - | AddedAsListenerTo Int - | AttributeReceived String String - | ChildReceived Int - | AddedAsChildTo Int - | RemovedNode Int - | RemovedAsNodeFrom Int - | RemovedListener String Int - | RemovedAsListenerFrom Int - | CreatedElement Int - | CreatedTextNode Int - | InsertedChildBefore Int Int - | InsertedAsChildBefore Int Int - | ElementAddedBefore Int - | GotElementById - | MadeCallback Int - | FreeCallback Int - deriving (Show, Eq) - - -data MockAttributes = MockAttributes - { _d_attrs :: HashMap String String - , _d_events :: HashMap String MockJSVal - } - deriving Show - -data MockJSVal = MockJSElement Int String MockAttributes [MockJSVal] [LogEvent] - | MockJSTextNode Int String [LogEvent] - | MockJSFunction Int (MockJSVal -> IO ()) [LogEvent] - | MockJSObject Int (HashMap String MockJSVal) [LogEvent] - | MockJSString Int String [LogEvent] - | MockJSNumber Int Double [LogEvent] - | MockJSArray Int [MockJSVal] [LogEvent] - | MockMouseEvent Int - -instance Show MockJSVal where - show (MockJSElement a b c d e) = - show a - <> " " - <> " " - <> show b - <> " " - <> show c - <> " " - <> show d - <> " " - <> show e - show (MockJSTextNode a b c) = show a <> " " <> show b <> " " <> show c - show (MockJSFunction a _ c) = show a <> " " <> show c - show (MockJSObject a b c) = show a <> " " <> show b <> " " <> show c - show (MockJSString a b c) = show a <> " " <> show b <> " " <> show c - show (MockJSNumber a b c) = show a <> " " <> show b <> " " <> show c - show (MockJSArray a b c) = show a <> " " <> show b <> " " <> show c - show (MockMouseEvent a ) = show a - -_withNewLog :: MockJSVal -> [LogEvent] -> MockJSVal -_withNewLog (MockJSElement a b c d _) log = MockJSElement a b c d log -_withNewLog (MockJSTextNode a b _ ) log = MockJSTextNode a b log -_withNewLog (MockJSFunction a b _ ) log = MockJSFunction a b log -_withNewLog (MockJSObject a b _ ) log = MockJSObject a b log -_withNewLog (MockJSString a b _ ) log = MockJSString a b log -_withNewLog (MockJSNumber a b _ ) log = MockJSNumber a b log -_withNewLog (MockJSArray a b _ ) log = MockJSArray a b log - -_withNewAttrs :: MockJSVal -> MockAttributes -> MockJSVal -_withNewAttrs (MockJSElement n tg _ chlds log) newat = - MockJSElement n tg newat chlds log -_withNewAttrs a _ = a - -_withNewKids :: MockJSVal -> [MockJSVal] -> MockJSVal -_withNewKids (MockJSElement n tg attrs _ log) newKids = - MockJSElement n tg attrs newKids log -_withNewKids a _ = a - -_ptr :: MockJSVal -> Int -_ptr (MockJSElement a _ _ _ _) = a -_ptr (MockJSTextNode a _ _ ) = a -_ptr (MockJSFunction a _ _ ) = a -_ptr (MockJSObject a _ _ ) = a -_ptr (MockJSString a _ _ ) = a -_ptr (MockJSNumber a _ _ ) = a -_ptr (MockJSArray a _ _ ) = a - -_eventTargetAddEventListener - :: MockJSVal - -> String - -> MockJSVal - -> IO (MockAttributes, [LogEvent], [LogEvent]) -_eventTargetAddEventListener (MockJSElement n _ (MockAttributes atts lstns) _ logn) evt fn@(MockJSFunction m _ logm) - = pure - $ ( MockAttributes atts $ insert evt fn lstns - , logn <> [ListenerReceived evt m] - , logm <> [AddedAsListenerTo n] - ) -_eventTargetAddEventListener _ _ _ = - error "Can only add event listener to element" - -_elementSetAttribute - :: MockJSVal -> String -> String -> IO (MockAttributes, [LogEvent]) -_elementSetAttribute (MockJSElement n _ (MockAttributes atts lstns) _ logn) nm attr - = pure - $ ( MockAttributes (insert nm attr atts) lstns - , logn <> [AttributeReceived nm attr] - ) -_elementSetAttribute _ _ _ = error "Can only add event listener to element" - -_nodeAppendChild - :: MockJSVal -> MockJSVal -> IO ([MockJSVal], [LogEvent], [LogEvent]) -_nodeAppendChild (MockJSElement n _ _ kids logn) kid@(MockJSElement m _ _ _ logm) - = pure - $ (kids <> [kid], logn <> [ChildReceived m], logm <> [AddedAsChildTo n]) -_nodeAppendChild (MockJSElement n _ _ kids logn) kid@(MockJSTextNode m _ logm) - = pure - $ (kids <> [kid], logn <> [ChildReceived m], logm <> [AddedAsChildTo n]) -_nodeAppendChild _ _ = error "Can only append element to element" - -__nodeRemoveChild - :: Int - -> [MockJSVal] - -> [LogEvent] - -> MockJSVal - -> Int - -> [LogEvent] - -> IO ([MockJSVal], [LogEvent], [LogEvent]) -__nodeRemoveChild n kids logn kid m logm = maybe - (error ("Existing item " <> show m <> " not child of " <> show n)) - (\x -> - pure - $ ( take x kids <> drop (x + 1) kids - , logn <> [RemovedNode m] - , logm <> [RemovedAsNodeFrom n] - ) - ) - (elemIndex (_ptr kid) (fmap _ptr kids)) - -_nodeRemoveChild - :: MockJSVal -> MockJSVal -> IO ([MockJSVal], [LogEvent], [LogEvent]) -_nodeRemoveChild (MockJSElement n _ _ kids logn) kid@(MockJSElement m _ _ _ logm) - = __nodeRemoveChild n kids logn kid m logm -_nodeRemoveChild (MockJSElement n _ _ kids logn) kid@(MockJSTextNode m _ logm) - = __nodeRemoveChild n kids logn kid m logm -_nodeRemoveChild _ _ = error "Can only remove element from element" - -_eventTargetRemoveEventListener - :: MockJSVal - -> String - -> MockJSVal - -> IO (MockAttributes, [LogEvent], [LogEvent]) -_eventTargetRemoveEventListener (MockJSElement n _ (MockAttributes atts lstns) _ logn) evt fn@(MockJSFunction m _ logm) - = maybe - (error ("Listener " <> show m <> " not child of " <> show n)) - (\x -> - pure - $ ( MockAttributes atts $ delete evt lstns - , logn <> [RemovedListener evt m] - , logm <> [RemovedAsListenerFrom n] - ) - ) - (lookup evt lstns) -_eventTargetRemoveEventListener _ _ _ = - error "Can only add event listener to element" - -_nodeInsertBeforeInternal - :: Int - -> [MockJSVal] - -> [LogEvent] - -> MockJSVal - -> Int - -> [LogEvent] - -> MockJSVal - -> Int - -> [LogEvent] - -> IO - ( [MockJSVal] - , [LogEvent] - , [LogEvent] - , [LogEvent] - ) -_nodeInsertBeforeInternal n kids logn newI m logm existingI l logl = maybe - (error ("Existing item " <> show l <> " not child of " <> show n)) - (\x -> - pure - $ ( take x kids <> [newI] <> drop x kids - , logn <> [InsertedChildBefore m l] - , logm <> [InsertedAsChildBefore n l] - , logl <> [ElementAddedBefore m] - ) - ) - (elemIndex (_ptr existingI) (fmap _ptr kids)) - - -_nodeInsertBefore - :: MockJSVal - -> MockJSVal - -> MockJSVal - -> IO ([MockJSVal], [LogEvent], [LogEvent], [LogEvent]) -_nodeInsertBefore (MockJSElement n _ _ kids logn) newI@(MockJSElement m _ _ _ logm) existingI@(MockJSElement l _ _ _ logl) - = _nodeInsertBeforeInternal n kids logn newI m logm existingI l logl -_nodeInsertBefore (MockJSElement n _ _ kids logn) newI@(MockJSTextNode m _ logm) existingI@(MockJSElement l _ _ _ logl) - = _nodeInsertBeforeInternal n kids logn newI m logm existingI l logl -_nodeInsertBefore (MockJSElement n _ _ kids logn) newI@(MockJSElement m _ _ _ logm) existingI@(MockJSTextNode l _ logl) - = _nodeInsertBeforeInternal n kids logn newI m logm existingI l logl -_nodeInsertBefore (MockJSElement n _ _ kids logn) newI@(MockJSTextNode m _ logm) existingI@(MockJSTextNode l _ logl) - = _nodeInsertBeforeInternal n kids logn newI m logm existingI l logl -_nodeInsertBefore _ _ _ = error "Can only append element to element" - -_elementTagName :: MockJSVal -> IO String -_elementTagName (MockJSElement _ tag _ _ _) = return tag -_elementTagName _ = error "Can only get tag of element" - -_nodeTextContent :: MockJSVal -> IO String -_nodeTextContent (MockJSTextNode _ txt _) = return txt -_nodeTextContent _ = error "Can only get text content of text node" - - -_nodeChildNodes :: MockJSVal -> IO [Int] -_nodeChildNodes (MockJSElement _ _ _ kids _) = return $ fmap _ptr kids -_nodeChildNodes _ = error "Can only get children of element" - -__freeCallback :: MockJSVal -> IO [LogEvent] -__freeCallback (MockJSFunction n _ log) = pure (log <> [FreeCallback n]) -__freeCallback _ = error "Can only free function" - -dummyClick :: MockJSVal -> IO () --- todo give real number - - -dummyClick (MockJSFunction _ f _) = f $ MockMouseEvent (-1) - - -_htmlElemenetClick :: MockJSVal -> IO () -_htmlElemenetClick (MockJSElement _ _ (MockAttributes _ evts) _ _) = do - let oc = lookup "click" evts - maybe (pure ()) (\x -> dummyClick x) oc - -_htmlElemenetClick _ = error "Can only free function" - - --------------- - - - -data MockBrowserInternal = MockBrowserInternal - { unBrowser :: HashMap Int MockJSVal - , unCtr :: Int - } - deriving Show - -look :: IORef MockBrowserInternal -> Int -> IO MockJSVal -look env elt = do - r <- readIORef env - let bz = unBrowser r - maybe (error $ "Cannot find object pointer in env: " <> (show elt)) - (\x -> return x) - (lookup elt bz) - -incr :: IORef MockBrowserInternal -> IO Int -incr env = do - r <- readIORef env - let ctr = unCtr r - writeIORef env $ r { unCtr = ctr + 1 } - return ctr - - -wrt :: IORef MockBrowserInternal -> Int -> MockJSVal -> IO () -wrt env elt v = do - r <- readIORef env - let bz = unBrowser r - writeIORef env $ r { unBrowser = insert elt v bz } - -_'eventTargetAddEventListener - :: IORef MockBrowserInternal -> Int -> String -> Int -> IO () -_'eventTargetAddEventListener env elt evt fn = do - _elt <- look env elt - _fn <- look env fn - (newAttrs, newLogElt, newLogFn) <- _eventTargetAddEventListener _elt evt _fn - wrt env elt $ _withNewLog (_withNewAttrs _elt newAttrs) newLogElt - wrt env fn $ _withNewLog _fn newLogFn - -_'nodeAppendChild :: IORef MockBrowserInternal -> Int -> Int -> IO () -_'nodeAppendChild env parent kid = do - _parent <- look env parent - _kid <- look env kid - (newKids, newLogParent, newLogKid) <- _nodeAppendChild _parent _kid - wrt env parent $ _withNewLog (_withNewKids _parent newKids) newLogParent - wrt env kid $ _withNewLog _kid newLogKid - -_'documentCreateElement :: IORef MockBrowserInternal -> String -> IO Int -_'documentCreateElement env tg = do - i <- incr env - let elt = - MockJSElement i tg (MockAttributes empty empty) [] [CreatedElement i] - wrt env i elt - return i - -_'mathRandom :: IORef MockBrowserInternal -> IO Double -_'mathRandom _ = pure 0.5 - -_'consoleLog :: IORef MockBrowserInternal -> String -> IO () -_'consoleLog _ txt = print txt - -_'consoleLog' :: IORef MockBrowserInternal -> Int -> IO () -_'consoleLog' _ v = print (show v) - - -_'documentCreateTextNode :: IORef MockBrowserInternal -> String -> IO Int -_'documentCreateTextNode env txt = do - i <- incr env - let elt = MockJSTextNode i txt [CreatedTextNode i] - wrt env i elt - return i - -_'getPropertyAsString - :: IORef MockBrowserInternal -> Int -> String -> IO (Maybe String) -_'getPropertyAsString env _ _ = pure Nothing -- not implemented yet - - -_'getPropertyAsBool - :: IORef MockBrowserInternal -> Int -> String -> IO (Maybe Bool) -_'getPropertyAsBool env _ _ = pure Nothing -- not implemented yet - - -_'getPropertyAsInt - :: IORef MockBrowserInternal -> Int -> String -> IO (Maybe Int) -_'getPropertyAsInt env _ _ = pure Nothing -- not implemented yet - - -_'getPropertyAsDouble - :: IORef MockBrowserInternal -> Int -> String -> IO (Maybe Double) -_'getPropertyAsDouble env _ _ = pure Nothing -- not implemented yet - - -_'getPropertyAsOpaque - :: IORef MockBrowserInternal -> Int -> String -> IO (Maybe Int) -_'getPropertyAsOpaque env _ _ = pure Nothing -- not implemented yet - - - -_'invokeOn0 :: IORef MockBrowserInternal -> Int -> String -> IO Int -_'invokeOn0 env _ _ = pure 0 -- not implemented yet - - - -_'elementTagName :: IORef MockBrowserInternal -> Int -> IO String -_'elementTagName env elt = do - _elt <- look env elt - _elementTagName _elt - -_'nodeChildNodes :: IORef MockBrowserInternal -> Int -> IO [Int] -_'nodeChildNodes env elt = do - _elt <- look env elt - _nodeChildNodes _elt - -_'nodeTextContent :: IORef MockBrowserInternal -> Int -> IO String -_'nodeTextContent env elt = do - _elt <- look env elt - _nodeTextContent _elt - -_'freeCallback :: IORef MockBrowserInternal -> Int -> IO () -_'freeCallback env fn = do - _fn <- look env fn - newLog <- __freeCallback _fn - wrt env fn $ _withNewLog _fn newLog - -_'htmlElemenetClick :: IORef MockBrowserInternal -> Int -> IO () -_'htmlElemenetClick env elt = do - _elt <- look env elt - _htmlElemenetClick _elt - -idEq :: String -> MockJSVal -> Bool -idEq txt (MockJSElement _ _ (MockAttributes atts _) _ _) = - Just txt == (lookup "id" atts) -idEq _ _ = False - -_'documentBody :: IORef MockBrowserInternal -> IO Int -_'documentBody ref = do - mb <- readIORef ref - let browser = unBrowser mb - pt <- maybe (error "No body.") (\x -> pure $ _ptr x) $ lookup 0 browser - return pt - -_'documentHead :: IORef MockBrowserInternal -> IO Int -_'documentHead ref = pure (-1) -- need to implement in mock? - - -_documentGetElementByIdInternal :: MockJSVal -> String -> [Int] -_documentGetElementByIdInternal jsv@(MockJSElement _ _ _ ch _) txt = - if (idEq txt jsv) - then [_ptr jsv] - else (foldr (++) [] $ fmap (\x -> _documentGetElementByIdInternal x txt) ch) -_documentGetElementByIdInternal _ _ = [] - -_'documentGetElementById - :: IORef MockBrowserInternal -> String -> IO (Maybe Int) -_'documentGetElementById env txt = do - body <- _'documentBody env - _body <- look env body - let elts = _documentGetElementByIdInternal _body txt - return $ if (null elts) then (Nothing) else (Just $ head elts) - -_'nodeInsertBefore :: IORef MockBrowserInternal -> Int -> Int -> Int -> IO () -_'nodeInsertBefore env parent newItem existingItem = do - _parent <- look env parent - _newItem <- look env newItem - _existingItem <- look env existingItem - (newKids, newLogParent, newLogNewItem, newLogExistingItem) <- - _nodeInsertBefore _parent _newItem _existingItem - wrt env parent $ _withNewLog (_withNewKids _parent newKids) newLogParent - wrt env newItem $ _withNewLog _newItem newLogNewItem - wrt env existingItem $ _withNewLog _existingItem newLogExistingItem - -_'makeHaskellCallback :: IORef MockBrowserInternal -> (Int -> IO ()) -> IO Int -_'makeHaskellCallback env cb = do - i <- incr env - let elt = MockJSFunction i (\x -> cb $ _ptr x) [MadeCallback i] - wrt env i elt - return i - -_'nodeRemoveChild :: IORef MockBrowserInternal -> Int -> Int -> IO () -_'nodeRemoveChild env parent kid = do - _parent <- look env parent - _kid <- look env kid - (newKids, newLogParent, newLogKid) <- _nodeRemoveChild _parent _kid - wrt env parent $ _withNewLog (_withNewKids _parent newKids) newLogParent - wrt env kid $ _withNewLog _kid newLogKid - -_'eventTargetRemoveEventListener - :: IORef MockBrowserInternal -> Int -> String -> Int -> IO () -_'eventTargetRemoveEventListener env elt evt fn = do - _elt <- look env elt - _fn <- look env fn - (newAttrs, newLogElt, newLogFn) <- _eventTargetRemoveEventListener _elt - evt - _fn - wrt env elt $ _withNewLog (_withNewAttrs _elt newAttrs) newLogElt - wrt env fn $ _withNewLog _fn newLogFn - -_'elementSetAttribute - :: IORef MockBrowserInternal -> Int -> String -> String -> IO () -_'elementSetAttribute env elt nm attr = do - _elt <- look env elt - (newAttrs, newLog) <- _elementSetAttribute _elt nm attr - wrt env elt $ _withNewLog (_withNewAttrs _elt newAttrs) newLog - -makeMockBrowserWithContext :: IORef MockBrowserInternal -> IO (Browserful Int) -makeMockBrowserWithContext r = return Browserful - { eventTargetAddEventListener = _'eventTargetAddEventListener r - , nodeAppendChild = _'nodeAppendChild r - , consoleLog = _'consoleLog r - , consoleLog' = _'consoleLog' r - , htmlElemenetClick = _'htmlElemenetClick r - , documentCreateElement = _'documentCreateElement r - , documentCreateTextNode = _'documentCreateTextNode r - , documentBody = _'documentBody r - , documentGetElementById = _'documentGetElementById r - , documentHead = _'documentHead r - , _freeCallback = _'freeCallback r - , getPropertyAsBool = _'getPropertyAsBool r - , getPropertyAsDouble = _'getPropertyAsDouble r - , getPropertyAsInt = _'getPropertyAsInt r - , getPropertyAsOpaque = _'getPropertyAsOpaque r - , getPropertyAsString = _'getPropertyAsString r - , elementTagName = _'elementTagName r - , nodeInsertBefore = _'nodeInsertBefore r - , invokeOn0 = _'invokeOn0 r - , _makeHaskellCallback = _'makeHaskellCallback r - , nodeChildNodes = _'nodeChildNodes r - , mathRandom = _'mathRandom r - , nodeRemoveChild = _'nodeRemoveChild r - , eventTargetRemoveEventListener = _'eventTargetRemoveEventListener r - , elementSetAttribute = _'elementSetAttribute r - , nodeTextContent = _'nodeTextContent r - } - -defaultInternalBrowser :: IO (IORef MockBrowserInternal) -defaultInternalBrowser = do - let body = MockJSElement 0 - "body" - (MockAttributes empty empty) - [] - [CreatedElement 0] - newIORef MockBrowserInternal { unBrowser = singleton 0 body, unCtr = 1 } - -makeMockBrowser :: IO (Browserful Int) -makeMockBrowser = do - rf <- defaultInternalBrowser - makeMockBrowserWithContext rf +{-| +Module : Web.Framework.Plzwrk.MockJSVal +Description : Mock browser for testing +Copyright : (c) Mike Solomon 2020 +License : GPL-3 +Maintainer : mike@meeshkan.com +Stability : experimental +Portability : POSIX, Windows + +This module exports a mock browser called +@defaultInternalBrowser@ used in plzwrk's tests +and that can be used in your unit tests as well. +-} +module Web.Framework.Plzwrk.MockJSVal + ( MockJSVal(..) + , makeMockBrowser + , defaultInternalBrowser + , makeMockBrowserWithContext + ) +where + +import Data.Aeson ( FromJSON ) +import Data.ByteString.Internal ( ByteString ) +import Data.HashMap.Strict hiding ( foldr + , null + ) +import Data.IORef +import Data.List ( elemIndex ) +import Prelude hiding ( lookup ) +import System.Random +import Web.Framework.Plzwrk.Base +import Web.Framework.Plzwrk.Browserful + +data LogEvent = ListenerReceived String Int + | AddedAsListenerTo Int + | AttributeReceived String String + | ChildReceived Int + | AddedAsChildTo Int + | RemovedNode Int + | RemovedAsNodeFrom Int + | RemovedListener String Int + | RemovedAsListenerFrom Int + | CreatedElement Int + | CreatedTextNode Int + | InsertedChildBefore Int Int + | InsertedAsChildBefore Int Int + | ElementAddedBefore Int + | GotElementById + | MadeCallback Int + | FreeCallback Int + deriving (Show, Eq) + + +data MockAttributes = MockAttributes + { _d_attrs :: HashMap String String + , _d_events :: HashMap String MockJSVal + } + deriving Show + +data MockJSVal = MockJSElement Int String MockAttributes [MockJSVal] [LogEvent] + | MockJSTextNode Int String [LogEvent] + | MockJSFunction Int (MockJSVal -> IO ()) [LogEvent] + | MockJSObject Int (HashMap String Int) [LogEvent] + | MockJSString Int String [LogEvent] + | MockJSDouble Int Double [LogEvent] + | MockJSInt Int Int [LogEvent] + | MockJSBool Int Bool [LogEvent] + | MockJSByteString Int ByteString [LogEvent] + | MockJSArray Int [Int] [LogEvent] + | MockMouseEvent Int + +instance Show MockJSVal where + show (MockJSElement a b c d e) = + show a + <> " " + <> " " + <> show b + <> " " + <> show c + <> " " + <> show d + <> " " + <> show e + show (MockJSTextNode a b c) = show a <> " " <> show b <> " " <> show c + show (MockJSFunction a _ c) = show a <> " " <> show c + show (MockJSObject a b c) = show a <> " " <> show b <> " " <> show c + show (MockJSString a b c) = show a <> " " <> show b <> " " <> show c + show (MockJSDouble a b c) = show a <> " " <> show b <> " " <> show c + show (MockJSInt a b c) = show a <> " " <> show b <> " " <> show c + show (MockJSBool a b c) = show a <> " " <> show b <> " " <> show c + show (MockJSByteString a b c) = show a <> " " <> show b <> " " <> show c + show (MockJSArray a b c) = show a <> " " <> show b <> " " <> show c + show (MockMouseEvent a ) = show a + +_withNewLog :: MockJSVal -> [LogEvent] -> MockJSVal +_withNewLog (MockJSElement a b c d _) log = MockJSElement a b c d log +_withNewLog (MockJSTextNode a b _ ) log = MockJSTextNode a b log +_withNewLog (MockJSFunction a b _ ) log = MockJSFunction a b log +_withNewLog (MockJSObject a b _ ) log = MockJSObject a b log +_withNewLog (MockJSString a b _ ) log = MockJSString a b log +_withNewLog (MockJSDouble a b _ ) log = MockJSDouble a b log +_withNewLog (MockJSBool a b _ ) log = MockJSBool a b log +_withNewLog (MockJSInt a b _ ) log = MockJSInt a b log +_withNewLog (MockJSByteString a b _ ) log = MockJSByteString a b log +_withNewLog (MockJSArray a b _ ) log = MockJSArray a b log + +_withNewAttrs :: MockJSVal -> MockAttributes -> MockJSVal +_withNewAttrs (MockJSElement n tg _ chlds log) newat = + MockJSElement n tg newat chlds log +_withNewAttrs a _ = a + +_withNewKids :: MockJSVal -> [MockJSVal] -> MockJSVal +_withNewKids (MockJSElement n tg attrs _ log) newKids = + MockJSElement n tg attrs newKids log +_withNewKids a _ = a + +_ptr :: MockJSVal -> Int +_ptr (MockJSElement a _ _ _ _) = a +_ptr (MockJSTextNode a _ _ ) = a +_ptr (MockJSFunction a _ _ ) = a +_ptr (MockJSObject a _ _ ) = a +_ptr (MockJSString a _ _ ) = a +_ptr (MockJSDouble a _ _ ) = a +_ptr (MockJSBool a _ _ ) = a +_ptr (MockJSInt a _ _ ) = a +_ptr (MockJSByteString a _ _ ) = a +_ptr (MockJSArray a _ _ ) = a + +_eventTargetAddEventListener + :: MockJSVal + -> String + -> MockJSVal + -> IO (MockAttributes, [LogEvent], [LogEvent]) +_eventTargetAddEventListener (MockJSElement n _ (MockAttributes atts lstns) _ logn) evt fn@(MockJSFunction m _ logm) + = pure + $ ( MockAttributes atts $ insert evt fn lstns + , logn <> [ListenerReceived evt m] + , logm <> [AddedAsListenerTo n] + ) +_eventTargetAddEventListener _ _ _ = + error "Can only add event listener to element" + +_elementSetAttribute + :: MockJSVal -> String -> String -> IO (MockAttributes, [LogEvent]) +_elementSetAttribute (MockJSElement n _ (MockAttributes atts lstns) _ logn) nm attr + = pure + $ ( MockAttributes (insert nm attr atts) lstns + , logn <> [AttributeReceived nm attr] + ) +_elementSetAttribute _ _ _ = error "Can only add event listener to element" + +_nodeAppendChild + :: MockJSVal -> MockJSVal -> IO ([MockJSVal], [LogEvent], [LogEvent]) +_nodeAppendChild (MockJSElement n _ _ kids logn) kid@(MockJSElement m _ _ _ logm) + = pure + $ (kids <> [kid], logn <> [ChildReceived m], logm <> [AddedAsChildTo n]) +_nodeAppendChild (MockJSElement n _ _ kids logn) kid@(MockJSTextNode m _ logm) + = pure + $ (kids <> [kid], logn <> [ChildReceived m], logm <> [AddedAsChildTo n]) +_nodeAppendChild _ _ = error "Can only append element to element" + +__nodeRemoveChild + :: Int + -> [MockJSVal] + -> [LogEvent] + -> MockJSVal + -> Int + -> [LogEvent] + -> IO ([MockJSVal], [LogEvent], [LogEvent]) +__nodeRemoveChild n kids logn kid m logm = maybe + (error ("Existing item " <> show m <> " not child of " <> show n)) + (\x -> + pure + $ ( take x kids <> drop (x + 1) kids + , logn <> [RemovedNode m] + , logm <> [RemovedAsNodeFrom n] + ) + ) + (elemIndex (_ptr kid) (fmap _ptr kids)) + +_nodeRemoveChild + :: MockJSVal -> MockJSVal -> IO ([MockJSVal], [LogEvent], [LogEvent]) +_nodeRemoveChild (MockJSElement n _ _ kids logn) kid@(MockJSElement m _ _ _ logm) + = __nodeRemoveChild n kids logn kid m logm +_nodeRemoveChild (MockJSElement n _ _ kids logn) kid@(MockJSTextNode m _ logm) + = __nodeRemoveChild n kids logn kid m logm +_nodeRemoveChild _ _ = error "Can only remove element from element" + +_eventTargetRemoveEventListener + :: MockJSVal + -> String + -> MockJSVal + -> IO (MockAttributes, [LogEvent], [LogEvent]) +_eventTargetRemoveEventListener (MockJSElement n _ (MockAttributes atts lstns) _ logn) evt fn@(MockJSFunction m _ logm) + = maybe + (error ("Listener " <> show m <> " not child of " <> show n)) + (\x -> + pure + $ ( MockAttributes atts $ delete evt lstns + , logn <> [RemovedListener evt m] + , logm <> [RemovedAsListenerFrom n] + ) + ) + (lookup evt lstns) +_eventTargetRemoveEventListener _ _ _ = + error "Can only add event listener to element" + +_nodeInsertBeforeInternal + :: Int + -> [MockJSVal] + -> [LogEvent] + -> MockJSVal + -> Int + -> [LogEvent] + -> MockJSVal + -> Int + -> [LogEvent] + -> IO + ( [MockJSVal] + , [LogEvent] + , [LogEvent] + , [LogEvent] + ) +_nodeInsertBeforeInternal n kids logn newI m logm existingI l logl = maybe + (error ("Existing item " <> show l <> " not child of " <> show n)) + (\x -> + pure + $ ( take x kids <> [newI] <> drop x kids + , logn <> [InsertedChildBefore m l] + , logm <> [InsertedAsChildBefore n l] + , logl <> [ElementAddedBefore m] + ) + ) + (elemIndex (_ptr existingI) (fmap _ptr kids)) + + +_nodeInsertBefore + :: MockJSVal + -> MockJSVal + -> MockJSVal + -> IO ([MockJSVal], [LogEvent], [LogEvent], [LogEvent]) +_nodeInsertBefore (MockJSElement n _ _ kids logn) newI@(MockJSElement m _ _ _ logm) existingI@(MockJSElement l _ _ _ logl) + = _nodeInsertBeforeInternal n kids logn newI m logm existingI l logl +_nodeInsertBefore (MockJSElement n _ _ kids logn) newI@(MockJSTextNode m _ logm) existingI@(MockJSElement l _ _ _ logl) + = _nodeInsertBeforeInternal n kids logn newI m logm existingI l logl +_nodeInsertBefore (MockJSElement n _ _ kids logn) newI@(MockJSElement m _ _ _ logm) existingI@(MockJSTextNode l _ logl) + = _nodeInsertBeforeInternal n kids logn newI m logm existingI l logl +_nodeInsertBefore (MockJSElement n _ _ kids logn) newI@(MockJSTextNode m _ logm) existingI@(MockJSTextNode l _ logl) + = _nodeInsertBeforeInternal n kids logn newI m logm existingI l logl +_nodeInsertBefore _ _ _ = error "Can only append element to element" + +_elementTagName :: MockJSVal -> IO String +_elementTagName (MockJSElement _ tag _ _ _) = return tag +_elementTagName _ = error "Can only get tag of element" + +_nodeTextContent :: MockJSVal -> IO String +_nodeTextContent (MockJSTextNode _ txt _) = return txt +_nodeTextContent _ = error "Can only get text content of text node" + + +_nodeChildNodes :: MockJSVal -> IO [Int] +_nodeChildNodes (MockJSElement _ _ _ kids _) = return $ fmap _ptr kids +_nodeChildNodes _ = error "Can only get children of element" + +__freeCallback :: MockJSVal -> IO [LogEvent] +__freeCallback (MockJSFunction n _ log) = pure (log <> [FreeCallback n]) +__freeCallback _ = error "Can only free function" + +dummyClick :: MockJSVal -> IO () +-- todo give real number + + +dummyClick (MockJSFunction _ f _) = f $ MockMouseEvent (-1) + + +_htmlElemenetClick :: MockJSVal -> IO () +_htmlElemenetClick (MockJSElement _ _ (MockAttributes _ evts) _ _) = do + let oc = lookup "click" evts + maybe (pure ()) (\x -> dummyClick x) oc + +_htmlElemenetClick _ = error "Can only free function" + + +-------------- + + + +data MockBrowserInternal = MockBrowserInternal + { unBrowser :: HashMap Int MockJSVal + , unCtr :: Int + } + deriving Show + +look :: IORef MockBrowserInternal -> Int -> IO MockJSVal +look env elt = do + r <- readIORef env + let bz = unBrowser r + maybe (error $ "Cannot find object pointer in env: " <> (show elt)) + (\x -> return x) + (lookup elt bz) + +incr :: IORef MockBrowserInternal -> IO Int +incr env = do + r <- readIORef env + let ctr = unCtr r + writeIORef env $ r { unCtr = ctr + 1 } + return ctr + + +wrt :: IORef MockBrowserInternal -> Int -> MockJSVal -> IO () +wrt env elt v = do + r <- readIORef env + let bz = unBrowser r + writeIORef env $ r { unBrowser = insert elt v bz } + +_'eventTargetAddEventListener + :: IORef MockBrowserInternal -> Int -> String -> Int -> IO () +_'eventTargetAddEventListener env elt evt fn = do + _elt <- look env elt + _fn <- look env fn + (newAttrs, newLogElt, newLogFn) <- _eventTargetAddEventListener _elt evt _fn + wrt env elt $ _withNewLog (_withNewAttrs _elt newAttrs) newLogElt + wrt env fn $ _withNewLog _fn newLogFn + +_'nodeAppendChild :: IORef MockBrowserInternal -> Int -> Int -> IO () +_'nodeAppendChild env parent kid = do + _parent <- look env parent + _kid <- look env kid + (newKids, newLogParent, newLogKid) <- _nodeAppendChild _parent _kid + wrt env parent $ _withNewLog (_withNewKids _parent newKids) newLogParent + wrt env kid $ _withNewLog _kid newLogKid + +_'documentCreateElement :: IORef MockBrowserInternal -> String -> IO Int +_'documentCreateElement env tg = do + i <- incr env + let elt = + MockJSElement i tg (MockAttributes empty empty) [] [CreatedElement i] + wrt env i elt + return i + +---------------------- +_jsValFrom + :: (Int -> s -> [LogEvent] -> MockJSVal) + -> IORef MockBrowserInternal + -> s + -> IO Int +_jsValFrom trans env toConv = do + i <- incr env + let elt = trans i toConv [] + wrt env i elt + return i + +_'jsValFromArray = _jsValFrom MockJSArray +_'jsValFromBool = _jsValFrom MockJSBool +_'jsValFromByteString = _jsValFrom MockJSByteString +_'jsValFromDouble = _jsValFrom MockJSDouble +_'jsValFromInt = _jsValFrom MockJSInt +_'jsValFromString = _jsValFrom MockJSString + +---------------------- + +_'mathRandom :: IORef MockBrowserInternal -> IO Double +_'mathRandom _ = pure 0.5 + +_'consoleLog :: IORef MockBrowserInternal -> Int -> IO () +_'consoleLog env v = do + _v <- look env v + print v + + +_'documentCreateTextNode :: IORef MockBrowserInternal -> String -> IO Int +_'documentCreateTextNode env txt = do + i <- incr env + let elt = MockJSTextNode i txt [CreatedTextNode i] + wrt env i elt + return i + +_'getPropertyAsOpaque + :: IORef MockBrowserInternal -> Int -> String -> IO (Maybe Int) +_'getPropertyAsOpaque env i s + | s == "tagName" = do + tn <- _'elementTagName env i + _v <- _'jsValFromString env tn + (return . Just) $ _v + | s == "textContent" = do + tc <- _'nodeTextContent env i + _v <- _'jsValFromString env tc + (return . Just) $ _v + | s == "childNodes" = do + cn <- _'nodeChildNodes env i + _v <-_'jsValFromArray env cn + (return . Just) $ _v + | otherwise = error + $ "This property is not implemented yet in MockJSVal: " + <> s + +_'invokeOn0 :: IORef MockBrowserInternal -> Int -> String -> IO Int +_'invokeOn0 env i s + | s == "click" = do + _'htmlElementClick env i + return (negate 1) + | otherwise = error + $ "This function is not implemented yet in MockJSVal: " + <> s + +_'invokeOn1 :: IORef MockBrowserInternal -> Int -> String -> Int -> IO Int +_'invokeOn1 env i s v + | s == "appendChild" = do + _'nodeAppendChild env i v + return (negate 1) + | s == "removeChild" = do + _'nodeRemoveChild env i v + return (negate 1) + | otherwise = error + $ "This function is not implemented yet in MockJSVal: " + <> s + +_'invokeOn2 + :: IORef MockBrowserInternal -> Int -> String -> Int -> Int -> IO Int +_'invokeOn2 env i s k v + | s == "setAttribute" = do + _k <- _'castToString env k + _v <- _'castToString env v + maybe + (error "key not a string") + (\__k -> maybe + (error "value not a string") + (\__v -> do + _'elementSetAttribute env i __k __v + return (negate 1) + ) + _v + ) + _k + | s == "addEventListener" = do + _k <- _'castToString env k + maybe + (error "key not a string") + (\__k -> do + _'eventTargetAddEventListener env i __k v + return (negate 1) + ) + _k + | s == "removeEventListener" = do + _k <- _'castToString env k + maybe + (error "key not a string") + (\__k -> do + _'eventTargetRemoveEventListener env i __k v + return (negate 1) + ) + _k + | s == "insertBefore" = do + _'nodeInsertBefore env i k v + return (negate 1) + | otherwise = error + $ "This function is not implemented yet in MockJSVal: " + <> s + +_'setValue :: IORef MockBrowserInternal -> Int -> String -> Int -> IO () +_'setValue env o k v = do + _o <- _'castToObject env o + maybe + (error "Not an object") + (\x -> do + __o <- look env o + let (MockJSObject _ _ lg) = __o + wrt env o $ MockJSObject o (insert k v x) lg + ) + _o + + +_'fetch :: IORef MockBrowserInternal -> String -> RequestInit Int -> IO Int +_'fetch env _ _ = do + _o <- _'makeObject env + return _o -- return an empty object for now + +_'elementTagName :: IORef MockBrowserInternal -> Int -> IO String +_'elementTagName env elt = do + _elt <- look env elt + _elementTagName _elt + +_'nodeChildNodes :: IORef MockBrowserInternal -> Int -> IO [Int] +_'nodeChildNodes env elt = do + _elt <- look env elt + _nodeChildNodes _elt + +_'nodeTextContent :: IORef MockBrowserInternal -> Int -> IO String +_'nodeTextContent env elt = do + _elt <- look env elt + _nodeTextContent _elt + +_'_freeCallback :: IORef MockBrowserInternal -> Int -> IO () +_'_freeCallback env fn = do + _fn <- look env fn + newLog <- __freeCallback _fn + wrt env fn $ _withNewLog _fn newLog + +_'htmlElementClick :: IORef MockBrowserInternal -> Int -> IO () +_'htmlElementClick env elt = do + _elt <- look env elt + _htmlElemenetClick _elt + +idEq :: String -> MockJSVal -> Bool +idEq txt (MockJSElement _ _ (MockAttributes atts _) _ _) = + Just txt == (lookup "id" atts) +idEq _ _ = False + +_'documentBody :: IORef MockBrowserInternal -> IO Int +_'documentBody ref = do + mb <- readIORef ref + let browser = unBrowser mb + pt <- maybe (error "No body.") (\x -> pure $ _ptr x) $ lookup 0 browser + return pt + +_'documentHead :: IORef MockBrowserInternal -> IO Int +_'documentHead ref = pure (-1) -- need to implement in mock? + + +_documentGetElementByIdInternal :: MockJSVal -> String -> [Int] +_documentGetElementByIdInternal jsv@(MockJSElement _ _ _ ch _) txt = + if (idEq txt jsv) + then [_ptr jsv] + else (foldr (++) [] $ fmap (\x -> _documentGetElementByIdInternal x txt) ch) +_documentGetElementByIdInternal _ _ = [] + +_'documentGetElementById + :: IORef MockBrowserInternal -> String -> IO (Maybe Int) +_'documentGetElementById env txt = do + body <- _'documentBody env + _body <- look env body + let elts = _documentGetElementByIdInternal _body txt + return $ if (null elts) then (Nothing) else (Just $ head elts) + +_'nodeInsertBefore :: IORef MockBrowserInternal -> Int -> Int -> Int -> IO () +_'nodeInsertBefore env parent newItem existingItem = do + _parent <- look env parent + _newItem <- look env newItem + _existingItem <- look env existingItem + (newKids, newLogParent, newLogNewItem, newLogExistingItem) <- + _nodeInsertBefore _parent _newItem _existingItem + wrt env parent $ _withNewLog (_withNewKids _parent newKids) newLogParent + wrt env newItem $ _withNewLog _newItem newLogNewItem + wrt env existingItem $ _withNewLog _existingItem newLogExistingItem + +_'_makeHaskellCallback :: IORef MockBrowserInternal -> (Int -> IO ()) -> IO Int +_'_makeHaskellCallback env cb = do + i <- incr env + let elt = MockJSFunction i (\x -> cb $ _ptr x) [MadeCallback i] + wrt env i elt + return i + +_'makeObject :: IORef MockBrowserInternal -> IO Int +_'makeObject env = do + i <- incr env + let elt = MockJSObject i empty [] + wrt env i elt + return i + + +_'nodeRemoveChild :: IORef MockBrowserInternal -> Int -> Int -> IO () +_'nodeRemoveChild env parent kid = do + _parent <- look env parent + _kid <- look env kid + (newKids, newLogParent, newLogKid) <- _nodeRemoveChild _parent _kid + wrt env parent $ _withNewLog (_withNewKids _parent newKids) newLogParent + wrt env kid $ _withNewLog _kid newLogKid + +_'eventTargetRemoveEventListener + :: IORef MockBrowserInternal -> Int -> String -> Int -> IO () +_'eventTargetRemoveEventListener env elt evt fn = do + _elt <- look env elt + _fn <- look env fn + (newAttrs, newLogElt, newLogFn) <- _eventTargetRemoveEventListener _elt + evt + _fn + wrt env elt $ _withNewLog (_withNewAttrs _elt newAttrs) newLogElt + wrt env fn $ _withNewLog _fn newLogFn + +_'elementSetAttribute + :: IORef MockBrowserInternal -> Int -> String -> String -> IO () +_'elementSetAttribute env elt nm attr = do + _elt <- look env elt + (newAttrs, newLog) <- _elementSetAttribute _elt nm attr + wrt env elt $ _withNewLog (_withNewAttrs _elt newAttrs) newLog + +_castable + :: (MockJSVal -> IO v) -> IORef MockBrowserInternal -> Int -> IO (Maybe v) +_castable cst env elt = do + _elt <- look env elt + v <- cst _elt + pure $ Just v + +_assertByteString :: MockJSVal -> IO ByteString +_assertByteString (MockJSByteString _ v _) = pure v +_assertByteString _ = error "Not a ByteString" + +_'castToByteString = _castable _assertByteString + +_assertBool :: MockJSVal -> IO Bool +_assertBool (MockJSBool _ v _) = pure v +_assertBool _ = error "Not a bool" + +_'castToBool = _castable _assertBool + +_assertDouble :: MockJSVal -> IO Double +_assertDouble (MockJSDouble _ v _) = pure v +_assertDouble _ = error "Not a double" + +_'castToDouble = _castable _assertDouble + +_assertInt :: MockJSVal -> IO Int +_assertInt (MockJSInt _ v _) = pure v +_assertInt _ = error "Not an int" + +_'castToInt = _castable _assertInt + +_assertArray :: MockJSVal -> IO [Int] +_assertArray (MockJSArray _ v _) = pure v +_assertArray _ = error "Not an array" + +_'castToArray = _castable _assertArray + +_assertString :: MockJSVal -> IO String +_assertString (MockJSString _ v _) = pure v +_assertString _ = error "Not an array" + +_'castToString = _castable _assertString + +_assertObject :: MockJSVal -> IO (HashMap String Int) +_assertObject (MockJSObject _ v _) = pure v +_assertObject _ = error "Not an array" + +_'castToObject = _castable _assertObject + + +_'defaultRequestInit = RequestInit { _ri_method = Nothing + , _ri_headers = Nothing + , _ri_body = Nothing + , _ri_mode = Nothing + , _ri_credentials = Nothing + , _ri_cache = Nothing + , _ri_redirect = Nothing + , _ri_referrer = Nothing + , _ri_integrity = Nothing + } + +makeMockBrowserWithContext :: IORef MockBrowserInternal -> IO (Browserful Int) +makeMockBrowserWithContext r = return Browserful + { castToArray = _'castToArray r + , castToBool = _'castToBool r + , castToByteString = _'castToByteString r + , castToDouble = _'castToDouble r + , castToInt = _'castToInt r + , castToString = _'castToString r + , consoleLog = _'consoleLog r + , defaultRequestInit = _'defaultRequestInit + , documentCreateElement = _'documentCreateElement r + , documentCreateTextNode = _'documentCreateTextNode r + , documentBody = _'documentBody r + , documentGetElementById = _'documentGetElementById r + , documentHead = _'documentHead r + , fetch = _'fetch r + , _freeCallback = _'_freeCallback r + , getPropertyAsOpaque = _'getPropertyAsOpaque r + , jsValFromArray = _'jsValFromArray r + , jsValFromBool = _'jsValFromBool r + , jsValFromByteString = _'jsValFromByteString r + , jsValFromDouble = _'jsValFromDouble r + , jsValFromInt = _'jsValFromInt r + , jsValFromString = _'jsValFromString r + , invokeOn0 = _'invokeOn0 r + , makeObject = _'makeObject r + , setValue = _'setValue r + , invokeOn1 = _'invokeOn1 r + , invokeOn2 = _'invokeOn2 r + , _makeHaskellCallback = _'_makeHaskellCallback r + , mathRandom = _'mathRandom r + } + +defaultInternalBrowser :: IO (IORef MockBrowserInternal) +defaultInternalBrowser = do + let body = MockJSElement 0 + "body" + (MockAttributes empty empty) + [] + [CreatedElement 0] + newIORef MockBrowserInternal { unBrowser = singleton 0 body, unCtr = 1 } + +makeMockBrowser :: IO (Browserful Int) +makeMockBrowser = do + rf <- defaultInternalBrowser + makeMockBrowserWithContext rf diff --git a/src/Web/Framework/Plzwrk/Util.hs b/src/Web/Framework/Plzwrk/Util.hs --- a/src/Web/Framework/Plzwrk/Util.hs +++ b/src/Web/Framework/Plzwrk/Util.hs @@ -1,140 +1,303 @@ -module Web.Framework.Plzwrk.Util - ( (<.>) - , wStyle - , wStyle' - , wStyles - , wStyles' - , wClass - , wClass' - , wClasses - , wClasses' - , wOnClick - , wOnClick' - , wId - , wId' - , wOnInput - , wOnInput' - , wAttr - , wAttr' - , wAttrs - , wAttrs' - , eventTargetValue - , eventPreventDefault - , eventTargetBlur - ) -where - -import Control.Monad -import Data.HashMap.Strict as HM -import Data.Set as S -import Web.Framework.Plzwrk.Base ( dats - , dats' - , Attributes(..) - ) -import Web.Framework.Plzwrk.Browserful - -merge :: Attributes s opq -> Attributes s opq -> Attributes s opq -merge a b = MkAttributes { _style = HM.union (_style a) (_style b) - , _class = S.union (_class a) (_class b) - , _simple = HM.union (_simple a) (_simple b) - , _handlers = HM.union (_handlers a) (_handlers b) - } - --- |Merges two 'Attributes' -(<.>) - :: (s -> Attributes s opq) - -> (s -> Attributes s opq) - -> (s -> Attributes s opq) -a <.> b = (\s -> merge (a s) (b s)) - --- |Constrcts a stateful 'Attributes' applicative functor from a single style. -wStyle :: String -> String -> (s -> Attributes s opq) -wStyle k v = (\s -> dats' { _style = HM.singleton k v }) - --- |Constrcts an 'Attributes' from a single style. -wStyle' :: String -> String -> Attributes s opq -wStyle' k v = dats' { _style = HM.singleton k v } - --- |Constrcts a stateful 'Attributes' applicative functor from a list of styles. -wStyles :: [(String, String)] -> (s -> Attributes s opq) -wStyles kvs = (\s -> dats' { _style = HM.fromList kvs }) - --- |Constrcts an 'Attributes' from a list of styles. -wStyles' :: [(String, String)] -> Attributes s opq -wStyles' kvs = dats' { _style = HM.fromList kvs } - --- |Constrcts a stateful 'Attributes' applicative functor from a single class. -wClass :: String -> (s -> Attributes s opq) -wClass k = (\s -> dats' { _class = S.singleton k }) - --- |Constrcts an 'Attributes' from a single class. -wClass' :: String -> Attributes s opq -wClass' k = dats' { _class = S.singleton k } - --- |Constrcts a stateful 'Attributes' applicative functor from a list of clases. -wClasses :: [String] -> (s -> Attributes s opq) -wClasses ks = (\s -> dats' { _class = S.fromList ks }) - --- |Constrcts an 'Attributes' from a list of classes. -wClasses' :: [String] -> Attributes s opq -wClasses' ks = dats' { _class = S.fromList ks } - --- |Constrcts a stateful 'Attributes' applicative functor with a given id. -wId :: String -> (s -> Attributes s opq) -wId v = (\s -> dats' { _simple = HM.singleton "id" v }) - --- |Constrcts an 'Attributes' with a given id. -wId' :: String -> Attributes s opq -wId' v = dats' { _simple = HM.singleton "id" v } - --- |Constrcts a stateful 'Attributes' applicative functor from an @onClick@ callback. -wOnClick :: (opq -> s -> IO s) -> (s -> Attributes s opq) -wOnClick v = (\s -> dats' { _handlers = HM.singleton "click" v }) - --- |Constrcts an 'Attributes' from an @onClick@ callback. -wOnClick' :: (opq -> s -> IO s) -> Attributes s opq -wOnClick' v = dats' { _handlers = HM.singleton "click" v } - --- |Constrcts a stateful 'Attributes' applicative functor from an @onInput@ callback. -wOnInput :: (opq -> s -> IO s) -> (s -> Attributes s opq) -wOnInput v = (\s -> dats' { _handlers = HM.singleton "input" v }) - --- |Constrcts an 'Attributes' from an @onInput@ callback. -wOnInput' :: (opq -> s -> IO s) -> Attributes s opq -wOnInput' v = dats' { _handlers = HM.singleton "input" v } - --- |Constrcts a stateful 'Attributes' applicative functor from a single attribute. -wAttr :: String -> String -> (s -> Attributes s opq) -wAttr k v = (\s -> dats' { _simple = HM.singleton k v }) - --- |Constrcts an 'Attributes' from a single attribute. -wAttr' :: String -> String -> Attributes s opq -wAttr' k v = dats' { _simple = HM.singleton k v } - --- |Constrcts a stateful 'Attributes' applicative functor from a list of attributes. -wAttrs :: [(String, String)] -> (s -> Attributes s opq) -wAttrs kvs = (\s -> dats' { _simple = HM.fromList kvs }) - --- |Constrcts an 'Attributes' from a list of attributes. -wAttrs' :: [(String, String)] -> Attributes s opq -wAttrs' kvs = dats' { _simple = HM.fromList kvs } - ------------------------------ ----- events - --- |From an event, gets the target's value. -eventTargetValue :: Browserful jsval -> jsval -> IO (Maybe String) -eventTargetValue browser e = do - opq <- (getPropertyAsOpaque browser) e "target" - maybe (pure Nothing) (\y -> (getPropertyAsString browser) y "value") opq - --- |From an event, takes the target and blurs it. -eventTargetBlur :: Browserful jsval -> jsval -> IO () -eventTargetBlur browser e = do - opq <- (getPropertyAsOpaque browser) e "target" - maybe (pure ()) (\y -> void $ (invokeOn0 browser) y "blur") opq - --- |Take an event and prevent the default. -eventPreventDefault :: Browserful jsval -> jsval -> IO () -eventPreventDefault browser e = do - void $ (invokeOn0 browser) e "preventDefault" +module Web.Framework.Plzwrk.Util + ( (<.>) + , wStyle + , wStyle' + , wStyles + , wStyles' + , wClass + , wClass' + , wClasses + , wClasses' + , wOnClick + , wOnClick' + , wId + , wId' + , wOnInput + , wOnInput' + , wAttr + , wAttr' + , wAttrs + , wAttrs' + , eventTargetValue + , eventPreventDefault + , eventTargetBlur + , elementSetAttribute + , elementTagName + , eventTargetAddEventListener + , eventTargetRemoveEventListener + , getPropertyAsBool + , getPropertyAsDouble + , getPropertyAsInt + , getPropertyAsString + , htmlElemenetClick + , consoleLogS + , nodeAppendChild + , nodeChildNodes + , nodeInsertBefore + , nodeRemoveChild + , nodeTextContent + ) +where + +import Control.Monad +import Data.HashMap.Strict as HM +import Data.Set as S +import Web.Framework.Plzwrk.Base ( dats + , dats' + , Attributes(..) + ) +import Web.Framework.Plzwrk.Browserful + +merge :: Attributes s opq -> Attributes s opq -> Attributes s opq +merge a b = MkAttributes { _style = HM.union (_style a) (_style b) + , _class = S.union (_class a) (_class b) + , _simple = HM.union (_simple a) (_simple b) + , _handlers = HM.union (_handlers a) (_handlers b) + } + +-- |Merges two 'Attributes' +(<.>) + :: (s -> Attributes s opq) + -> (s -> Attributes s opq) + -> (s -> Attributes s opq) +a <.> b = (\s -> merge (a s) (b s)) + +-- |Constrcts a stateful 'Attributes' applicative functor from a single style. +wStyle :: String -> String -> (s -> Attributes s opq) +wStyle k v = (\s -> dats' { _style = HM.singleton k v }) + +-- |Constrcts an 'Attributes' from a single style. +wStyle' :: String -> String -> Attributes s opq +wStyle' k v = dats' { _style = HM.singleton k v } + +-- |Constrcts a stateful 'Attributes' applicative functor from a list of styles. +wStyles :: [(String, String)] -> (s -> Attributes s opq) +wStyles kvs = (\s -> dats' { _style = HM.fromList kvs }) + +-- |Constrcts an 'Attributes' from a list of styles. +wStyles' :: [(String, String)] -> Attributes s opq +wStyles' kvs = dats' { _style = HM.fromList kvs } + +-- |Constrcts a stateful 'Attributes' applicative functor from a single class. +wClass :: String -> (s -> Attributes s opq) +wClass k = (\s -> dats' { _class = S.singleton k }) + +-- |Constrcts an 'Attributes' from a single class. +wClass' :: String -> Attributes s opq +wClass' k = dats' { _class = S.singleton k } + +-- |Constrcts a stateful 'Attributes' applicative functor from a list of clases. +wClasses :: [String] -> (s -> Attributes s opq) +wClasses ks = (\s -> dats' { _class = S.fromList ks }) + +-- |Constrcts an 'Attributes' from a list of classes. +wClasses' :: [String] -> Attributes s opq +wClasses' ks = dats' { _class = S.fromList ks } + +-- |Constrcts a stateful 'Attributes' applicative functor with a given id. +wId :: String -> (s -> Attributes s opq) +wId v = (\s -> dats' { _simple = HM.singleton "id" v }) + +-- |Constrcts an 'Attributes' with a given id. +wId' :: String -> Attributes s opq +wId' v = dats' { _simple = HM.singleton "id" v } + +-- |Constrcts a stateful 'Attributes' applicative functor from an @onClick@ callback. +wOnClick :: (opq -> s -> IO s) -> (s -> Attributes s opq) +wOnClick v = (\s -> dats' { _handlers = HM.singleton "click" v }) + +-- |Constrcts an 'Attributes' from an @onClick@ callback. +wOnClick' :: (opq -> s -> IO s) -> Attributes s opq +wOnClick' v = dats' { _handlers = HM.singleton "click" v } + +-- |Constrcts a stateful 'Attributes' applicative functor from an @onInput@ callback. +wOnInput :: (opq -> s -> IO s) -> (s -> Attributes s opq) +wOnInput v = (\s -> dats' { _handlers = HM.singleton "input" v }) + +-- |Constrcts an 'Attributes' from an @onInput@ callback. +wOnInput' :: (opq -> s -> IO s) -> Attributes s opq +wOnInput' v = dats' { _handlers = HM.singleton "input" v } + +-- |Constrcts a stateful 'Attributes' applicative functor from a single attribute. +wAttr :: String -> String -> (s -> Attributes s opq) +wAttr k v = (\s -> dats' { _simple = HM.singleton k v }) + +-- |Constrcts an 'Attributes' from a single attribute. +wAttr' :: String -> String -> Attributes s opq +wAttr' k v = dats' { _simple = HM.singleton k v } + +-- |Constrcts a stateful 'Attributes' applicative functor from a list of attributes. +wAttrs :: [(String, String)] -> (s -> Attributes s opq) +wAttrs kvs = (\s -> dats' { _simple = HM.fromList kvs }) + +-- |Constrcts an 'Attributes' from a list of attributes. +wAttrs' :: [(String, String)] -> Attributes s opq +wAttrs' kvs = dats' { _simple = HM.fromList kvs } + +----------------------------- +---- events + +-- |From an event, gets the target's value. +eventTargetValue + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the event + -> IO (Maybe String) -- ^ the target value, or nothing if it doesn't exist +eventTargetValue browser e = do + opq <- (getPropertyAsOpaque browser) e "target" + maybe (pure Nothing) (\y -> (getPropertyAsString browser) y "value") opq + +-- |From an event, takes the target and blurs it. +eventTargetBlur + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the event + -> IO () -- ^ returns nothing +eventTargetBlur browser e = do + opq <- (getPropertyAsOpaque browser) e "target" + maybe (pure ()) (\y -> void $ (invokeOn0 browser) y "blur") opq + +-- |Take an event and prevent the default. +eventPreventDefault + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the event + -> IO () -- ^ returns nothing +eventPreventDefault browser e = do + void $ (invokeOn0 browser) e "preventDefault" + +----------- + +-- | Sets on an element an attribute. See [Element.setAttribute](https://developer.mozilla.org/en-US/docs/Web/API/Element/setAttribute) +elementSetAttribute + :: Browserful jsval -- ^ The browser + -> jsval -- ^ the node + -> String -- ^ the attribute name + -> String -- ^ the attribute + -> IO () -- ^ returns nothing +elementSetAttribute b e k v = do + _k <- (jsValFromString b) k + _v <- (jsValFromString b) v + void $ (invokeOn2 b) e "setAttribute" _k _v + +-- | Gets the tag name of an element. See [Element.tagName](https://developer.mozilla.org/en-US/docs/Web/API/Element/tagName) +elementTagName + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the element + -> IO (Maybe String) -- ^ Returns the tag name +elementTagName b v = do + _o <- (getPropertyAsOpaque b) v "tagName" + maybe (pure Nothing) (\x -> (castToString b) x) _o + +-- | Takes a target and an event name and adds a listener. See [EventTarget.addEventListener](https://developer.mozilla.org/en-US/docs/Web/API/EventTarget/addEventListener) +eventTargetAddEventListener + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the element + -> String -- ^ the listener name. note that this should be "click" or "input", not "onclick" nor "oninput" + -> jsval -- ^ the listener + -> IO () -- ^ returns nothing +eventTargetAddEventListener b e k v = do + _k <- (jsValFromString b) k + void $ (invokeOn2 b) e "addEventListener" _k v + +-- | Takes a target and an event name and removes a listener. See [EventTarget.removeEventListener](https://developer.mozilla.org/en-US/docs/Web/API/EventTarget/removeEventListener) +eventTargetRemoveEventListener + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the element + -> String -- ^ the listener name. note that this should be "click" or "input", not "onclick" nor "oninput" + -> jsval -- ^ the listener + -> IO () -- ^ returns nothing +eventTargetRemoveEventListener b e k v = do + _k <- (jsValFromString b) k + void $ (invokeOn2 b) e "removeEventListener" _k v + +-- | Gets a JavaScript property as a bool, returning @Nothing@ if the object being called is null or undefined or the property cannot be cast to a bool. +getPropertyAsBool + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the object containing the property + -> String -- ^ the property name + -> IO (Maybe Bool) -- ^ the response if the property is a bool, else Nothing +getPropertyAsBool b o k = do + _v <- (getPropertyAsOpaque b) o k + maybe (pure Nothing) (\x -> (castToBool b) x) _v + +-- | Gets a JavaScript property as a double, returning @Nothing@ if the object being called is null or undefined or the property cannot be cast to a double. +getPropertyAsDouble + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the object containing the property + -> String -- ^ the property name + -> IO (Maybe Double) -- ^ the response if the property is a double, else Nothing +getPropertyAsDouble b o k = do + _v <- (getPropertyAsOpaque b) o k + maybe (pure Nothing) (\x -> (castToDouble b) x) _v + +-- | Gets a JavaScript property as an int, returning @Nothing@ if the object being called is null or undefined or the property cannot be cast to an int. +getPropertyAsInt + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the object containing the property + -> String -- ^ the property name + -> IO (Maybe Int) -- ^ the response if the property is an int, else Nothing +getPropertyAsInt b o k = do + _v <- (getPropertyAsOpaque b) o k + maybe (pure Nothing) (\x -> (castToInt b) x) _v + +-- | Gets a JavaScript property as an string, returning @Nothing@ if the object being called is null or undefined. +getPropertyAsString + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the object containing the property + -> String -- ^ the property name + -> IO (Maybe String) -- ^ the response +getPropertyAsString b o k = do + _v <- (getPropertyAsOpaque b) o k + maybe (pure Nothing) (\x -> (castToString b) x) _v + +-- | Takes an element and clicks it. Useful for testing. See [HTMLElement.click](https://developer.mozilla.org/en-US/docs/Web/API/HTMLElement/click) +htmlElemenetClick :: Browserful jsval -> jsval -> IO () +htmlElemenetClick b e = void $ (invokeOn0 b) e "click" + +-- | Logs a string. See [Console.log](https://developer.mozilla.org/en-US/docs/Web/API/Console/log) +consoleLogS :: Browserful jsval -> String -> IO () +consoleLogS b s = do + _s <- (jsValFromString b) s + (consoleLog b) _s + +-- | Takes a node and appends a child. See [Node.appendChild](https://developer.mozilla.org/en-US/docs/Web/API/Node/appendChild) +nodeAppendChild + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the node + -> jsval -- ^ the child to append + -> IO () -- ^ returns nothing +nodeAppendChild b e v = void $ (invokeOn1 b) e "appendChild" v + +-- | Get the children of a node. See [Node.childNodes](https://developer.mozilla.org/en-US/docs/Web/API/Node/childNodes) +nodeChildNodes + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the node + -> IO (Maybe [jsval]) +nodeChildNodes b v = do + _cn <- (getPropertyAsOpaque b) v "childNodes" + maybe (pure Nothing) (\x -> (castToArray b) x) _cn + +-- | Inserts a node into an element before another node. See [Node.insertBefore](https://developer.mozilla.org/en-US/docs/Web/API/Node/insertBefore) +nodeInsertBefore + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the parent element + -> jsval -- ^ the new node + -> jsval -- ^ the pre-existing node + -> IO () -- ^ returns nothing +nodeInsertBefore b e k v = void $ (invokeOn2 b) e "insertBefore" k v + +-- | Removes a child from a parent node. See [Node.removeChild](https://developer.mozilla.org/en-US/docs/Web/API/Node/removeChild) +nodeRemoveChild + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the parent element + -> jsval -- ^ the child to remove + -> IO () -- ^ returns nothing +nodeRemoveChild b e v = void $ (invokeOn1 b) e "removeChild" v + +-- | Gets the text content of a node. See [Node.textContent](https://developer.mozilla.org/en-US/docs/Web/API/Node/textContent) +nodeTextContent + :: Browserful jsval -- ^ the browser + -> jsval -- ^ the node + -> IO (Maybe String) -- ^ the text content as a string +nodeTextContent b e = do + _tc <- (getPropertyAsOpaque b) e "textContent" + maybe (pure Nothing) (\x -> (castToString b) x) _tc + diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,97 +1,112 @@ -import Control.Monad -import Control.Monad.Reader -import Data.IORef -import Prelude hiding ( div ) -import Test.Hspec -import Web.Framework.Plzwrk -import Web.Framework.Plzwrk.MockJSVal -import Data.HashMap.Strict -import Web.Framework.Plzwrk.Tag ( p - , br - , txt - , button - , div'_ - ) - -data MyState = MyState - { _name :: String - , _ctr :: Int - } - -main :: IO () -main = hspec $ do - describe "Element with basic state" $ do - let domF = - (\x y -> div'_ - [ p (wStyle "position" "absolute") - (take y $ repeat (txt (concat [x, show y]))) - , button - (wId "incr" <.> wClasses ["a b ccc"] <.> wOnClick - (\_ s -> pure $ s { _ctr = y + 1 }) - ) - [txt "Increase counter"] - , br - ,button - ( wId "decr" - <.> wStyles [("position", "absolute"), ("margin", "10px")] - <.> wOnClick (\_ s -> pure $ s { _ctr = y - 1 }) - ) - [txt "Decrease counter"] - ] - ) - <$> _name - <*> _ctr - let state = MyState "Mike" 1 - it "Creates the correct DOM from the state" $ do - rf <- defaultInternalBrowser - mock <- makeMockBrowserWithContext rf - plzwrk' domF state mock - parentNode <- documentBody mock - childrenLevel0 <- (nodeChildNodes mock) parentNode - length childrenLevel0 `shouldBe` 1 - divtag <- (elementTagName mock) (head childrenLevel0) - divtag `shouldBe` "div" - childrenLevel1 <- (nodeChildNodes mock) (head childrenLevel0) - length childrenLevel1 `shouldBe` 4 - ptag <- (elementTagName mock) (head childrenLevel1) - ptag `shouldBe` "p" - childrenLevel2 <- (nodeChildNodes mock) (head childrenLevel1) - length childrenLevel2 `shouldBe` 1 - - -- increment 4 times - - (documentGetElementById mock) "incr" - >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) - (documentGetElementById mock) "incr" - >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) - (documentGetElementById mock) "incr" - >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) - (documentGetElementById mock) "incr" - >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) - parentNode' <- documentBody mock - childrenLevel0' <- (nodeChildNodes mock) parentNode' - length childrenLevel0' `shouldBe` 1 - divtag' <- (elementTagName mock) (head childrenLevel0') - divtag' `shouldBe` "div" - childrenLevel1' <- (nodeChildNodes mock) (head childrenLevel0') - length childrenLevel1' `shouldBe` 4 - childrenLevel2' <- (nodeChildNodes mock) (head childrenLevel1') - length childrenLevel2' `shouldBe` 5 - content' <- mapM (nodeTextContent mock) childrenLevel2' - content' `shouldBe` (take 5 $ repeat "Mike5") - (documentGetElementById mock) "decr" - >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) - (documentGetElementById mock) "decr" - >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) - parentNode'' <- documentBody mock - childrenLevel0'' <- (nodeChildNodes mock) parentNode'' - length childrenLevel0'' `shouldBe` 1 - divtag'' <- (elementTagName mock) (head childrenLevel0'') - divtag'' `shouldBe` "div" - childrenLevel1'' <- (nodeChildNodes mock) (head childrenLevel0'') - length childrenLevel1'' `shouldBe` 4 - childrenLevel2'' <- (nodeChildNodes mock) (head childrenLevel1'') - length childrenLevel2'' `shouldBe` 3 - content'' <- mapM (nodeTextContent mock) childrenLevel2'' - content'' `shouldBe` (take 3 $ repeat "Mike3") - toHTML domF state `shouldBe` "

Mike1


" +import Control.Monad +import Control.Monad.Reader +import Data.IORef +import Prelude hiding ( div ) +import Test.Hspec +import Web.Framework.Plzwrk +import Web.Framework.Plzwrk.MockJSVal +import Data.HashMap.Strict +import Web.Framework.Plzwrk.Tag ( p + , br + , txt + , button + , div'_ + ) + +nodeChildNodesOrThrow :: Browserful jsval -> jsval -> IO [jsval] +nodeChildNodesOrThrow b v = do + _v <- (nodeChildNodes b v) + maybe (error "Could not find child nodes") pure _v + +nodeTextContentOrThrow :: Browserful jsval -> jsval -> IO String +nodeTextContentOrThrow b v = do + _v <- (nodeTextContent b v) + maybe (error "Could not find text content") pure _v + +elementTagNameOrThrow :: Browserful jsval -> jsval -> IO String +elementTagNameOrThrow b v = do + _v <- (elementTagName b v) + maybe (error "Could not find tag name") pure _v + +data MyState = MyState + { _name :: String + , _ctr :: Int + } + +main :: IO () +main = hspec $ do + describe "Element with basic state" $ do + let domF = + (\x y -> div'_ + [ p (wStyle "position" "absolute") + (take y $ repeat (txt (concat [x, show y]))) + , button + (wId "incr" <.> wClasses ["a b ccc"] <.> wOnClick + (\_ s -> pure $ s { _ctr = y + 1 }) + ) + [txt "Increase counter"] + , br + ,button + ( wId "decr" + <.> wStyles [("position", "absolute"), ("margin", "10px")] + <.> wOnClick (\_ s -> pure $ s { _ctr = y - 1 }) + ) + [txt "Decrease counter"] + ] + ) + <$> _name + <*> _ctr + let state = MyState "Mike" 1 + it "Creates the correct DOM from the state" $ do + rf <- defaultInternalBrowser + mock <- makeMockBrowserWithContext rf + plzwrk' domF state mock + parentNode <- documentBody mock + childrenLevel0 <- (nodeChildNodesOrThrow mock) parentNode + length childrenLevel0 `shouldBe` 1 + divtag <- (elementTagNameOrThrow mock) (head childrenLevel0) + divtag `shouldBe` "div" + childrenLevel1 <- (nodeChildNodesOrThrow mock) (head childrenLevel0) + length childrenLevel1 `shouldBe` 4 + ptag <- (elementTagNameOrThrow mock) (head childrenLevel1) + ptag `shouldBe` "p" + childrenLevel2 <- (nodeChildNodesOrThrow mock) (head childrenLevel1) + length childrenLevel2 `shouldBe` 1 + + -- increment 4 times + + (documentGetElementById mock) "incr" + >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) + (documentGetElementById mock) "incr" + >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) + (documentGetElementById mock) "incr" + >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) + (documentGetElementById mock) "incr" + >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) + parentNode' <- documentBody mock + childrenLevel0' <- (nodeChildNodesOrThrow mock) parentNode' + length childrenLevel0' `shouldBe` 1 + divtag' <- (elementTagNameOrThrow mock) (head childrenLevel0') + divtag' `shouldBe` "div" + childrenLevel1' <- (nodeChildNodesOrThrow mock) (head childrenLevel0') + length childrenLevel1' `shouldBe` 4 + childrenLevel2' <- (nodeChildNodesOrThrow mock) (head childrenLevel1') + length childrenLevel2' `shouldBe` 5 + content' <- mapM (nodeTextContentOrThrow mock) childrenLevel2' + content' `shouldBe` (take 5 $ repeat "Mike5") + (documentGetElementById mock) "decr" + >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) + (documentGetElementById mock) "decr" + >>= maybe (error "Incr node does not exist") (htmlElemenetClick mock) + parentNode'' <- documentBody mock + childrenLevel0'' <- (nodeChildNodesOrThrow mock) parentNode'' + length childrenLevel0'' `shouldBe` 1 + divtag'' <- (elementTagNameOrThrow mock) (head childrenLevel0'') + divtag'' `shouldBe` "div" + childrenLevel1'' <- (nodeChildNodesOrThrow mock) (head childrenLevel0'') + length childrenLevel1'' `shouldBe` 4 + childrenLevel2'' <- (nodeChildNodesOrThrow mock) (head childrenLevel1'') + length childrenLevel2'' `shouldBe` 3 + content'' <- mapM (nodeTextContentOrThrow mock) childrenLevel2'' + content'' `shouldBe` (take 3 $ repeat "Mike3") + toHTML domF state `shouldBe` "

Mike1


"