diff --git a/Shpadoinkle-html.cabal b/Shpadoinkle-html.cabal
--- a/Shpadoinkle-html.cabal
+++ b/Shpadoinkle-html.cabal
@@ -1,13 +1,13 @@
cabal-version: 1.12
--- This file has been generated from package.yaml by hpack version 0.32.0.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
--
-- see: https://github.com/sol/hpack
--
--- hash: 34deb8b30535a072cf6471b12f32a661dc2a4724c63dc1e22047302a2b7018a1
+-- hash: 507af092ca806a47783a31cc85707dba844dd89d06c3deba1589d0ea7678b193
name: Shpadoinkle-html
-version: 0.2.0.1
+version: 0.3.0.0
synopsis: A typed, template generated Html DSL, and helpers.
description: Shpadoinkle Html is a typed template-generated Html DSL building on types provided by Shpadoinkle Core. This exports a large namespace of terms covering most of the Html specifications. Some Elm-API-style helpers are present, but as outlaw type classes.
category: Web
@@ -36,8 +36,10 @@
Shpadoinkle.Html.LocalStorage
Shpadoinkle.Html.TH
Shpadoinkle.Html.TH.CSS
+ Shpadoinkle.WebWorker
Shpadoinkle.Keyboard
other-modules:
+ Shpadoinkle.Html.Event.Basic
Shpadoinkle.Html.Event.Debounce
Shpadoinkle.Html.Event.Throttle
Shpadoinkle.Html.TH.CSSTest
@@ -53,6 +55,8 @@
, containers >=0.6.0 && <0.7
, ghcjs-dom
, jsaddle >=0.9.7 && <0.20
+ , lens
+ , raw-strings-qq
, stm >=2.5.0 && <2.6
, template-haskell >=2.14.0 && <2.17
, text >=1.2.3 && <1.3
diff --git a/Shpadoinkle/Html.hs b/Shpadoinkle/Html.hs
--- a/Shpadoinkle/Html.hs
+++ b/Shpadoinkle/Html.hs
@@ -12,11 +12,11 @@
import Shpadoinkle (Html, Prop, baked, children,
- flagProp, injectProps, listen,
+ dataProp, injectProps, listen,
listenC, listenRaw, listener,
listenerProp, mapChildren,
mapProps, name, props, text,
- textContent, textProp)
+ textContent)
import Shpadoinkle.Html.Element
import Shpadoinkle.Html.Event
import Shpadoinkle.Html.Event.Debounce
diff --git a/Shpadoinkle/Html/Event.hs b/Shpadoinkle/Html/Event.hs
--- a/Shpadoinkle/Html/Event.hs
+++ b/Shpadoinkle/Html/Event.hs
@@ -1,9 +1,11 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
-- | This module provides a DSL of Events found on HTML elements.
@@ -13,12 +15,7 @@
-- functions as well without using this module. For those who like a typed
-- DSL with named functions and overloading, this is for you.
--
--- All listeners come in 2 flavors. Unctuous flavors. Plain (i.e. 'onInput') and monadic (i.e. 'onInputM').
--- The following should hold
---
--- @
--- onXM (pure x) = onX x
--- @
+-- All listeners come in 4 flavors. Unctuous flavors. Plain ('onInput'), continuous ('onInputC'), monadic ('onInputM'), and forgetful ('onInputM_').
--
-- A flavor providing access to the 'RawNode' and the 'RawEvent' are not provided
-- here. If you want access to these, try the 'listenRaw' constructor. The intent
@@ -26,213 +23,150 @@
--
-- Right now this module features limited specialization, but ideally we specialize
-- all of these listeners. For example, the 'onInput' listener takes a function
--- @(Text -> m a)@ where 'Text' is the current value of the input and 'onKeyup' takes
--- a function of type @(KeyCode -> m a)@ from 'Shpadoinkle.Keyboard'. Mouse move
--- listeners, for example, should take a function of @((Float, Float) -> m a)@, but
--- this work is not yet done. See https://gitlab.com/fresheyeball/Shpadoinkle/issues/5
+-- @(Text -> a -> a)@ where 'Text' is the current value of the input and 'onKeyup' takes
+-- a function of type @(KeyCode -> a -> a)@ from 'Shpadoinkle.Keyboard'. Mouse move
+-- listeners, for example, should take a function of @((Float, Float) -> a -> a)@, but
+-- this work is not yet done.
-module Shpadoinkle.Html.Event where
+module Shpadoinkle.Html.Event
+ ( module Shpadoinkle.Html.Event
+ , module Shpadoinkle.Html.Event.Basic
+ ) where
-import Control.Monad (msum, void)
+import Control.Concurrent.STM (retry)
+import Control.Lens ((^.))
+import Control.Monad (void)
+import Control.Monad.IO.Class (liftIO)
import Data.Text
-import GHCJS.DOM.Types hiding (Text)
-import Language.Javascript.JSaddle hiding (JSM, liftJSM, toJSString)
+import GHCJS.DOM.Types hiding (Text)
+import Language.Javascript.JSaddle hiding (JSM, liftJSM, toJSString)
+import UnliftIO.Concurrent (forkIO)
+import UnliftIO.STM
import Shpadoinkle
+import Shpadoinkle.Html.Event.Basic
import Shpadoinkle.Html.TH
import Shpadoinkle.Keyboard
mkWithFormVal :: (JSVal -> JSM v) -> Text -> JSString -> (v -> Continuation m a) -> (Text, Prop m a)
mkWithFormVal valTo evt from f = listenRaw evt $ \(RawNode n) _ ->
- return . f =<< liftJSM (valTo =<< unsafeGetProp from =<< valToObject n)
+ f <$> liftJSM (valTo =<< unsafeGetProp from =<< valToObject n)
onInputC :: (Text -> Continuation m a) -> (Text, Prop m a)
onInputC = mkWithFormVal valToText "input" "value"
-
-
-onInput :: (Text -> a) -> (Text, Prop m a)
-onInput f = onInputC (constUpdate . f)
-
-
-onInputM :: Monad m => (Text -> m (a -> a)) -> (Text, Prop m a)
-onInputM f = onInputC (impur . f)
-
-
-onInputM_ :: Monad m => (Text -> m ()) -> (Text, Prop m a)
-onInputM_ f = onInputC (causes . f)
+$(mkEventVariantsAfforded "input" ''Text)
onOptionC :: (Text -> Continuation m a) -> (Text, Prop m a)
onOptionC = mkWithFormVal valToText "change" "value"
-
-
-onOption :: (Text -> a) -> (Text, Prop m a)
-onOption f = onOptionC (constUpdate . f)
-
-
-onOptionM :: Monad m => (Text -> m (a -> a)) -> (Text, Prop m a)
-onOptionM f = onOptionC (impur . f)
-
-
-onOptionM_ :: Monad m => (Text -> m ()) -> (Text, Prop m a)
-onOptionM_ f = onOptionC (causes . f)
+$(mkEventVariantsAfforded "option" ''Text)
mkOnKey :: Text -> (KeyCode -> Continuation m a) -> (Text, Prop m a)
mkOnKey t f = listenRaw t $ \_ (RawEvent e) ->
- return . f =<< liftJSM (fmap round $ valToNumber =<< unsafeGetProp "keyCode" =<< valToObject e)
+ f <$> liftJSM (fmap round $ valToNumber =<< unsafeGetProp "keyCode" =<< valToObject e)
onKeyupC, onKeydownC, onKeypressC :: (KeyCode -> Continuation m a) -> (Text, Prop m a)
onKeyupC = mkOnKey "keyup"
onKeydownC = mkOnKey "keydown"
onKeypressC = mkOnKey "keypress"
-onKeyup, onKeydown, onKeypress :: (KeyCode -> a) -> (Text, Prop m a)
-onKeyup f = onKeyupC (constUpdate . f)
-onKeydown f = onKeydownC (constUpdate . f)
-onKeypress f = onKeypressC (constUpdate . f)
-onKeyupM, onKeydownM, onKeypressM :: Monad m => (KeyCode -> m (a -> a)) -> (Text, Prop m a)
-onKeyupM f = onKeyupC (impur . f)
-onKeydownM f = onKeydownC (impur . f)
-onKeypressM f = onKeypressC (impur . f)
-onKeyupM_, onKeydownM_, onKeypressM_ :: Monad m => (KeyCode -> m ()) -> (Text, Prop m a)
-onKeyupM_ f = onKeyupC (causes . f)
-onKeydownM_ f = onKeydownC (causes . f)
-onKeypressM_ f = onKeypressC (causes . f)
+$(mkEventVariantsAfforded "keyup" ''KeyCode)
+$(mkEventVariantsAfforded "keydown" ''KeyCode)
+$(mkEventVariantsAfforded "keypress" ''KeyCode)
onCheckC :: (Bool -> Continuation m a) -> (Text, Prop m a)
onCheckC = mkWithFormVal valToBool "change" "checked"
+$(mkEventVariantsAfforded "check" ''Bool)
-onCheck :: (Bool -> a) -> (Text, Prop m a)
-onCheck f = onCheckC (constUpdate . f)
+preventDefault :: RawEvent -> JSM ()
+preventDefault e = void $ valToObject e # ("preventDefault" :: String) $ ([] :: [()])
-onCheckM :: Monad m => (Bool -> m (a -> a)) -> (Text, Prop m a)
-onCheckM f = onCheckC (impur . f)
+onSubmitC :: Continuation m a -> (Text, Prop m a)
+onSubmitC m = listenRaw "submit" $ \_ e -> preventDefault e >> return m
+$(mkEventVariants "submit")
-onCheckM_ :: Monad m => (Bool -> m ()) -> (Text, Prop m a)
-onCheckM_ f = onCheckC (causes . f)
+mkGlobalMailbox :: Continuation m a -> JSM (JSM (), STM (Continuation m a))
+mkGlobalMailbox c = do
+ (notify, stream) <- mkGlobalMailboxAfforded (const c)
+ return (notify (), stream)
-preventDefault :: RawEvent -> JSM ()
-preventDefault e = void $ valToObject e # ("preventDefault" :: String) $ ([] :: [()])
+mkGlobalMailboxAfforded :: (b -> Continuation m a) -> JSM (b -> JSM (), STM (Continuation m a))
+mkGlobalMailboxAfforded bc = do
+ (notify, twas) <- liftIO $ (,) <$> newTVarIO (0, Nothing) <*> newTVarIO (0 :: Int)
+ return (\b -> atomically $ modifyTVar notify (\(i, _) -> (i + 1, Just b)), do
+ (new', b) <- readTVar notify
+ old <- readTVar twas
+ case b of
+ Just b' | new' /= old -> bc b' <$ writeTVar twas new'
+ _ -> retry)
-onSubmitC :: Continuation m a -> (Text, Prop m a)
-onSubmitC m = listenRaw "submit" $ \_ e -> preventDefault e >> return m
+onClickAwayC :: Continuation m a -> (Text, Prop m a)
+onClickAwayC c =
+ ( "onclickaway"
+ , PPotato $ \(RawNode elm) -> liftJSM $ do
+ (notify, stream) <- mkGlobalMailbox c
-onSubmit :: a -> (Text, Prop m a)
-onSubmit = onSubmitC . constUpdate
+ void $ jsg ("document" :: Text) ^. js2 ("addEventListener" :: Text) ("click" :: Text)
+ (fun $ \_ _ -> \case
+ evt:_ -> void . forkIO $ do
+ target <- evt ^. js ("target" :: Text)
+ onTarget <- fromJSVal =<< elm ^. js1 ("contains" :: Text) target
+ case onTarget of
+ Just False -> notify
+ _ -> return ()
-onSubmitM :: Monad m => m (a -> a) -> (Text, Prop m a)
-onSubmitM = onSubmitC . impur
+ [] -> pure ())
+ return stream
+ )
+$(mkEventVariants "clickAway")
-onSubmitM_ :: Monad m => m () -> (Text, Prop m a)
-onSubmitM_ = onSubmitC . causes
+mkGlobalKey :: Text -> (KeyCode -> Continuation m a) -> (Text, Prop m a)
+mkGlobalKey evtName c =
+ ( "global" <> evtName
+ , PPotato $ \_ -> liftJSM $ do
-mkGlobalKey :: Text -> (KeyCode -> JSM ()) -> JSM ()
-mkGlobalKey n t = do
- d <- makeObject =<< jsg ("window" :: Text)
- f <- toJSVal . fun $ \_ _ -> \case
- e:_ -> t =<<
- fmap round (valToNumber =<< unsafeGetProp "keyCode" =<< valToObject e)
- _ -> return ()
- unsafeSetProp (toJSString $ "on" <> n) f d
+ (notify, stream) <- mkGlobalMailboxAfforded c
+ void $ jsg ("window" :: Text) ^. js2 ("addEventListener" :: Text) evtName
+ (fun $ \_ _ -> \case
+ e:_ -> notify . round =<< valToNumber =<< unsafeGetProp "keyCode" =<< valToObject e
+ [] -> return ())
-globalKeyDown, globalKeyUp, globalKeyPress :: (KeyCode -> JSM ()) -> JSM ()
-globalKeyDown = mkGlobalKey "keydown"
-globalKeyUp = mkGlobalKey "keyup"
-globalKeyPress = mkGlobalKey "keypress"
+ return stream
+ )
-$(msum <$> mapM mkEventDSL
- [ "click"
- , "change"
- , "contextmenu"
- , "dblclick"
- , "mousedown"
- , "mouseenter"
- , "mouseleave"
- , "mousemove"
- , "mouseover"
- , "mouseout"
- , "mouseup"
- , "beforeunload"
- , "error"
- , "hashchange"
- , "load"
- , "pageshow"
- , "pagehide"
- , "resize"
- , "scroll"
- , "unload"
- , "blur"
- , "focus"
- , "focusin"
- , "focusout"
- , "invalid"
- , "reset"
- , "search"
- , "select"
- , "drag"
- , "dragend"
- , "dragenter"
- , "dragleave"
- , "dragover"
- , "dragstart"
- , "drop"
- , "copy"
- , "cut"
- , "paste"
- , "afterprint"
- , "beforeprint"
- , "abort"
- , "canplay"
- , "canplaythrough"
- , "durationchange"
- , "emptied"
- , "ended"
- , "loadeddata"
- , "loadedmetadata"
- , "loadstart"
- , "pause"
- , "play"
- , "playing"
- , "progress"
- , "ratechange"
- , "seeked"
- , "seeking"
- , "stalled"
- , "suspend"
- , "timeupdate"
- , "volumechange"
- , "waiting"
- , "animationend"
- , "animationiteration"
- , "animationstart"
- , "message"
- , "open"
- , "mousewheel"
- , "online"
- , "offline"
- , "popstate"
- , "show"
- , "storage"
- , "toggle"
- , "wheel"
- , "touchcancel"
- , "touchend"
- , "touchmove"
- , "touchstart" ])
+onGlobalKeyPressC, onGlobalKeyDownC, onGlobalKeyUpC :: (KeyCode -> Continuation m a) -> (Text, Prop m a)
+onGlobalKeyPressC = mkGlobalKey "keypress"
+onGlobalKeyDownC = mkGlobalKey "keydown"
+onGlobalKeyUpC = mkGlobalKey "keyup"
+$(mkEventVariantsAfforded "globalKeyPress" ''KeyCode)
+$(mkEventVariantsAfforded "globalKeyDown" ''KeyCode)
+$(mkEventVariantsAfforded "globalKeyUp" ''KeyCode)
+
+
+onEscapeC :: Continuation m a -> (Text, Prop m a)
+onEscapeC c = onKeyupC $ \case 27 -> c; _ -> done
+$(mkEventVariants "escape")
+
+onEnterC :: (Text -> Continuation m a) -> (Text, Prop m a)
+onEnterC f = listenRaw "keyup" $ \(RawNode n) _ -> liftJSM $
+ f <$> (valToText =<< unsafeGetProp "value"
+ =<< valToObject n)
+$(mkEventVariantsAfforded "enter" ''Text)
+
diff --git a/Shpadoinkle/Html/Event/Basic.hs b/Shpadoinkle/Html/Event/Basic.hs
new file mode 100644
--- /dev/null
+++ b/Shpadoinkle/Html/Event/Basic.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+
+
+-- | This module provides a DSL of Events found on HTML elements.
+-- This DSL is entirely optional. You may use the 'Prop's 'PListener' constructor
+-- provided by Shpadoinkle core and completely ignore this module.
+-- You can use the 'listener', 'listen', 'listenRaw', 'listenC', and 'listenM' convenience
+-- functions as well without using this module. For those who like a typed
+-- DSL with named functions and overloading, this is for you.
+--
+-- All listeners come in 4 flavors. Unctuous flavors. Plain ('onInput'), continuous ('onInputC'), monadic ('onInputM'), and forgetful ('onInputM_').
+--
+-- A flavor providing access to the 'RawNode' and the 'RawEvent' are not provided
+-- here. If you want access to these, try the 'listenRaw' constructor. The intent
+-- of this DSL is to provide simple named functions.
+--
+-- Right now this module features limited specialization, but ideally we specialize
+-- all of these listeners. For example, the 'onInput' listener takes a function
+-- @(Text -> a -> a)@ where 'Text' is the current value of the input and 'onKeyup' takes
+-- a function of type @(KeyCode -> a -> a)@ from 'Shpadoinkle.Keyboard'. Mouse move
+-- listeners, for example, should take a function of @((Float, Float) -> a -> a)@, but
+-- this work is not yet done. See https://gitlab.com/fresheyeball/Shpadoinkle/issues/5
+
+
+module Shpadoinkle.Html.Event.Basic where
+
+
+import Control.Monad (msum)
+
+import Shpadoinkle
+import Shpadoinkle.Html.TH
+
+
+$(msum <$> mapM mkEventDSL
+ [ "click"
+ , "change"
+ , "contextmenu"
+ , "dblclick"
+ , "mousedown"
+ , "mouseenter"
+ , "mouseleave"
+ , "mousemove"
+ , "mouseover"
+ , "mouseout"
+ , "mouseup"
+ , "beforeunload"
+ , "error"
+ , "hashchange"
+ , "load"
+ , "pageshow"
+ , "pagehide"
+ , "resize"
+ , "scroll"
+ , "unload"
+ , "blur"
+ , "focus"
+ , "focusin"
+ , "focusout"
+ , "invalid"
+ , "reset"
+ , "search"
+ , "select"
+ , "drag"
+ , "dragend"
+ , "dragenter"
+ , "dragleave"
+ , "dragover"
+ , "dragstart"
+ , "drop"
+ , "copy"
+ , "cut"
+ , "paste"
+ , "afterprint"
+ , "beforeprint"
+ , "abort"
+ , "canplay"
+ , "canplaythrough"
+ , "durationchange"
+ , "emptied"
+ , "ended"
+ , "loadeddata"
+ , "loadedmetadata"
+ , "loadstart"
+ , "pause"
+ , "play"
+ , "playing"
+ , "progress"
+ , "ratechange"
+ , "seeked"
+ , "seeking"
+ , "stalled"
+ , "suspend"
+ , "timeupdate"
+ , "volumechange"
+ , "waiting"
+ , "animationend"
+ , "animationiteration"
+ , "animationstart"
+ , "message"
+ , "open"
+ , "mousewheel"
+ , "online"
+ , "offline"
+ , "popstate"
+ , "show"
+ , "storage"
+ , "toggle"
+ , "wheel"
+ , "touchcancel"
+ , "touchend"
+ , "touchmove"
+ , "touchstart" ])
diff --git a/Shpadoinkle/Html/Event/Debounce.hs b/Shpadoinkle/Html/Event/Debounce.hs
--- a/Shpadoinkle/Html/Event/Debounce.hs
+++ b/Shpadoinkle/Html/Event/Debounce.hs
@@ -10,14 +10,17 @@
) where
-import Control.Monad.IO.Class
-import Data.Maybe
-import Data.Text
-import Data.Time.Clock
-import GHCJS.DOM.Types (JSM, MonadJSM, liftJSM)
-import Shpadoinkle
-import UnliftIO
-import UnliftIO.Concurrent
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (NominalDiffTime, getCurrentTime)
+import Shpadoinkle (Continuation, JSM, MonadJSM, Prop,
+ RawEvent, RawNode, atomically,
+ bakedProp, cataProp, dataProp, done,
+ flagProp, kleisli, liftJSM,
+ listenerProp, newTVarIO, readTVar,
+ textProp, writeTVar)
+import UnliftIO.Concurrent (threadDelay)
newtype Debounce m a b = Debounce { runDebounce
@@ -49,4 +52,5 @@
-> n (Debounce m a b)
debounce duration = do
db <- debounceRaw duration
- return . Debounce $ \g x -> let (attr, p) = g x in (attr, cataProp textProp (listenerProp . db) flagProp p)
+ return . Debounce $ \g x -> let (attr, p) = g x in (attr,
+ cataProp dataProp textProp flagProp (listenerProp . db) bakedProp p)
diff --git a/Shpadoinkle/Html/Event/Throttle.hs b/Shpadoinkle/Html/Event/Throttle.hs
--- a/Shpadoinkle/Html/Event/Throttle.hs
+++ b/Shpadoinkle/Html/Event/Throttle.hs
@@ -8,12 +8,16 @@
) where
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Text
-import Data.Time.Clock
-import GHC.Conc
-import Shpadoinkle hiding (newTVarIO)
+import Control.Monad (when)
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.Text (Text)
+import Data.Time.Clock (NominalDiffTime, diffUTCTime,
+ getCurrentTime)
+import Shpadoinkle (Continuation, JSM, Prop, RawEvent,
+ RawNode, atomically, bakedProp,
+ cataProp, dataProp, done, flagProp,
+ listenerProp, newTVarIO, readTVar,
+ textProp, writeTVar)
newtype Throttle m a b = Throttle { runThrottle
@@ -49,4 +53,4 @@
f <- throttleRaw duration
return . Throttle $ \g x ->
let (attr, p) = g x
- in (attr, cataProp textProp (listenerProp . f) flagProp p)
+ in (attr, cataProp dataProp textProp flagProp (listenerProp . f) bakedProp p)
diff --git a/Shpadoinkle/Html/LocalStorage.hs b/Shpadoinkle/Html/LocalStorage.hs
--- a/Shpadoinkle/Html/LocalStorage.hs
+++ b/Shpadoinkle/Html/LocalStorage.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -13,21 +12,22 @@
module Shpadoinkle.Html.LocalStorage where
-import Control.Monad
-import Control.Monad.Trans.Maybe
-import Data.Maybe
-import Data.String
-import Data.Text
-import GHC.Generics
-import GHCJS.DOM
-import GHCJS.DOM.Types hiding (Text)
-import GHCJS.DOM.Storage
-import GHCJS.DOM.Window
-import Text.Read
-import UnliftIO
-import UnliftIO.Concurrent (forkIO)
+import Control.Monad (void)
+import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
+import Data.Maybe (fromMaybe)
+import Data.String (IsString)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import GHCJS.DOM (currentWindow)
+import GHCJS.DOM.Storage (getItem, setItem)
+import GHCJS.DOM.Types (MonadJSM, liftJSM)
+import GHCJS.DOM.Window (getLocalStorage)
+import Text.Read (readMaybe)
+import UnliftIO (MonadIO (liftIO), MonadUnliftIO,
+ TVar, newTVarIO)
+import UnliftIO.Concurrent (forkIO)
-import Shpadoinkle (shouldUpdate)
+import Shpadoinkle (shouldUpdate)
-- | The key for a specific state kept in local storage
@@ -48,7 +48,7 @@
getStorage :: MonadJSM m => Read a => LocalStorageKey a -> m (Maybe a)
getStorage (LocalStorageKey k) = runMaybeT $ do
- w <- MaybeT $ currentWindow
+ w <- MaybeT currentWindow
s <- MaybeT $ Just <$> getLocalStorage w
MaybeT $ (>>= readMaybe) <$> getItem s k
diff --git a/Shpadoinkle/Html/Property.hs b/Shpadoinkle/Html/Property.hs
--- a/Shpadoinkle/Html/Property.hs
+++ b/Shpadoinkle/Html/Property.hs
@@ -89,7 +89,7 @@
, "max", "min", "step", "wrap", "target", "download", "hreflang", "media", "ping", "shape", "coords"
, "alt", "preload", "poster", "name'", "kind'", "srclang", "sandbox", "srcdoc", "align"
, "headers", "scope", "datetime", "pubdate", "manifest", "contextmenu", "draggable"
- , "dropzone", "itemprop", "charset", "content", "property"
+ , "dropzone", "itemprop", "charset", "content", "property", "innerHTML"
])
$(msum <$> mapM mkIntProp
diff --git a/Shpadoinkle/Html/TH.hs b/Shpadoinkle/Html/TH.hs
--- a/Shpadoinkle/Html/TH.hs
+++ b/Shpadoinkle/Html/TH.hs
@@ -1,23 +1,32 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
-
module Shpadoinkle.Html.TH where
import qualified Data.Char as Char
import qualified Data.Text
-import Language.Haskell.TH
+import Language.Haskell.TH (Body (NormalB), Clause (Clause),
+ Dec (FunD, SigD, ValD),
+ Exp (AppE, InfixE, ListE, LitE, UnboundVarE, VarE),
+ Lit (StringL), Name, Pat (VarP), Q,
+ Type (AppT, ArrowT, ConT, ForallT, ListT, TupleT, VarT),
+ mkName)
-import Shpadoinkle hiding (h, name)
+import Shpadoinkle (Continuation, Html, Prop, causes, impur,
+ pur)
+{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
+
+
capitalized :: String -> String
-capitalized (c:cs) = Char.toUpper c : fmap Char.toLower cs
+capitalized (c:cs) = Char.toUpper c : cs
capitalized [] = []
+
mkEventDSL :: String -> Q [Dec]
mkEventDSL evt = let
@@ -36,7 +45,7 @@
in return
[ SigD nameM (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]
- (AppT (AppT ArrowT (AppT m ((AppT (AppT ArrowT a) a))))
+ (AppT (AppT ArrowT (AppT m (AppT (AppT ArrowT a) a)))
(AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
(AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
@@ -62,7 +71,7 @@
, SigD name
(ForallT []
[]
- (AppT (AppT ArrowT a)
+ (AppT (AppT ArrowT (AppT (AppT ArrowT a) a))
(AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
(AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
@@ -70,6 +79,81 @@
]
+mkEventVariants :: String -> Q [Dec]
+mkEventVariants evt = let
+ onevt = "on" ++ capitalized evt
+ name = mkName onevt
+ nameC = mkName $ onevt ++ "C"
+ nameM = mkName $ onevt ++ "M"
+ nameM_ = mkName $ onevt ++ "M_"
+
+ m = VarT $ mkName "m"
+ a = VarT $ mkName "a"
+
+ in return
+ [ SigD nameM (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]
+ (AppT (AppT ArrowT (AppT m (AppT (AppT ArrowT a) a)))
+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
+
+ , FunD nameM [ Clause [] (NormalB $ AppE (AppE (VarE '(Prelude..)) (VarE nameC)) (VarE 'Shpadoinkle.impur)) []]
+
+ , SigD nameM_ (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]
+ (AppT (AppT ArrowT (AppT m (ConT ''())))
+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
+
+ , FunD nameM_ [ Clause [] (NormalB $ AppE (AppE (VarE '(Prelude..)) (VarE nameC)) (VarE 'Shpadoinkle.causes)) []]
+
+ , SigD name
+ (ForallT []
+ []
+ (AppT (AppT ArrowT (AppT (AppT ArrowT a) a))
+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
+
+ , FunD name [ Clause [] (NormalB $ AppE (AppE (VarE '(Prelude..)) (VarE nameC)) (VarE 'Shpadoinkle.pur)) []]
+
+ ]
+
+
+mkEventVariantsAfforded :: String -> Name -> Q [Dec]
+mkEventVariantsAfforded evt afford = let
+ onevt = "on" ++ capitalized evt
+ name = mkName onevt
+ nameC = mkName $ onevt ++ "C"
+ nameM = mkName $ onevt ++ "M"
+ nameM_ = mkName $ onevt ++ "M_"
+ f = mkName "f"
+
+ m = VarT $ mkName "m"
+ a = VarT $ mkName "a"
+
+ in return
+ [ SigD nameM (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]
+ (AppT (AppT ArrowT (AppT (AppT ArrowT (ConT afford)) (AppT m (AppT (AppT ArrowT a) a))))
+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
+
+ , FunD nameM [Clause [VarP f] (NormalB (AppE (UnboundVarE nameC) (InfixE (Just (UnboundVarE 'Shpadoinkle.impur)) (VarE '(Prelude..)) (Just (VarE f))))) []]
+
+ , SigD nameM_ (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]
+ (AppT (AppT ArrowT (AppT (AppT ArrowT (ConT afford)) (AppT m (ConT ''()))))
+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))
+
+ , FunD nameM_ [Clause [VarP f] (NormalB (AppE (UnboundVarE nameC) (InfixE (Just (UnboundVarE 'Shpadoinkle.causes)) (VarE '(Prelude..)) (Just (VarE f))))) []]
+
+ , SigD name
+ (AppT (AppT ArrowT (AppT (AppT ArrowT (ConT afford)) (AppT (AppT ArrowT a) a)))
+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))
+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a)))
+
+ , FunD name [Clause [VarP f] (NormalB (AppE (UnboundVarE nameC) (InfixE (Just (UnboundVarE 'Shpadoinkle.pur)) (VarE '(Prelude..)) (Just (VarE f))))) []]
+
+ ]
+
+
mkProp :: Name -> String -> String -> Q [Dec]
mkProp typ lStr name' = let
@@ -107,7 +191,7 @@
mkElement :: String -> Q [Dec]
mkElement name = let
- raw = filter (not . (== '\'')) name
+ raw = filter (/= '\'') name
n = mkName name
n' = mkName $ name ++ "'"
n_ = mkName $ name ++ "_"
diff --git a/Shpadoinkle/Html/TH/CSS.hs b/Shpadoinkle/Html/TH/CSS.hs
--- a/Shpadoinkle/Html/TH/CSS.hs
+++ b/Shpadoinkle/Html/TH/CSS.hs
@@ -64,7 +64,7 @@
#else
getAll :: ByteString -> [ByteString]
-getAll css = getAllTextMatches $ css =~ (selectors @ByteString)
+getAll css = getAllTextMatches $ css =~ selectors @ByteString
#endif
@@ -89,7 +89,7 @@
n = mkName $ "id'" <> sanitize name'
in
[ SigD n
- ((AppT (AppT (TupleT 2) (ConT ''Data.Text.Text)) (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a)))
+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text)) (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))
, ValD (VarP n) (NormalB (AppE (AppE (VarE l) (LitE (StringL "id"))) (LitE (StringL name')))) []
]
diff --git a/Shpadoinkle/Html/Utils.hs b/Shpadoinkle/Html/Utils.hs
--- a/Shpadoinkle/Html/Utils.hs
+++ b/Shpadoinkle/Html/Utils.hs
@@ -8,21 +8,30 @@
module Shpadoinkle.Html.Utils where
-import Control.Monad (forM_)
-import Data.Text hiding (empty)
-import GHCJS.DOM
-import GHCJS.DOM.Document as Doc
-import GHCJS.DOM.Element
-import GHCJS.DOM.Node
-import GHCJS.DOM.Types (ToJSString, liftJSM, toJSVal)
+import Control.Monad (forM_)
+import Data.Text (Text)
+import GHCJS.DOM (currentDocumentUnchecked)
+import GHCJS.DOM.Document as Doc (createElement,
+ createTextNode,
+ getBodyUnsafe,
+ getHeadUnsafe, setTitle)
+import GHCJS.DOM.Element (setAttribute, setInnerHTML)
+import GHCJS.DOM.Node (appendChild)
+import GHCJS.DOM.NonElementParentNode (getElementById)
+import GHCJS.DOM.Types (ToJSString, liftJSM, toJSVal)
-import Shpadoinkle
+import Shpadoinkle (MonadJSM, RawNode (RawNode))
default (Text)
-addStyle :: MonadJSM m => Text -> m ()
+-- | Add a stylesheet to the page via @link@ tag.
+addStyle
+ :: MonadJSM m
+ => Text
+ -- ^ The URI for the @href@ attribute
+ -> m ()
addStyle x = do
doc <- currentDocumentUnchecked
link <- createElement doc "link"
@@ -55,8 +64,8 @@
liftJSM $ RawNode <$> toJSVal body
-addMeta :: [(Text, Text)] -> JSM ()
-addMeta ps = do
+addMeta :: MonadJSM m => [(Text, Text)] -> m ()
+addMeta ps = liftJSM $ do
doc <- currentDocumentUnchecked
tag <- createElement doc ("meta" :: Text)
forM_ ps $ uncurry (setAttribute tag)
@@ -64,17 +73,26 @@
() <$ appendChild headRaw tag
-addScriptSrc :: Text -> JSM ()
-addScriptSrc src = do
+createDivWithId :: MonadJSM m => Text -> m ()
+createDivWithId did = liftJSM $ do
doc <- currentDocumentUnchecked
+ tag <- createElement doc ("div" :: Text)
+ setAttribute tag "id" did
+ body <- Doc.getHeadUnsafe doc
+ () <$ appendChild body tag
+
+
+addScriptSrc :: MonadJSM m => Text -> m ()
+addScriptSrc src = liftJSM $ do
+ doc <- currentDocumentUnchecked
tag <- createElement doc ("script" :: Text)
setAttribute tag ("src" :: Text) src
headRaw <- Doc.getHeadUnsafe doc
() <$ appendChild headRaw tag
-addScriptText :: Text -> JSM ()
-addScriptText js = do
+addScriptText :: MonadJSM m => Text -> m ()
+addScriptText js = liftJSM $ do
doc <- currentDocumentUnchecked
tag <- createElement doc ("script" :: Text)
setAttribute tag ("type" :: Text) ("text/javascript" :: Text)
@@ -82,6 +100,12 @@
jsn <- createTextNode doc js
_ <- appendChild tag jsn
() <$ appendChild headRaw tag
+
+
+getById :: MonadJSM m => Text -> m RawNode
+getById did = liftJSM $ do
+ doc <- currentDocumentUnchecked
+ fmap RawNode . toJSVal =<< getElementById doc did
treatEmpty :: Foldable f => Functor f => a -> (f a -> a) -> (b -> a) -> f b -> a
diff --git a/Shpadoinkle/WebWorker.hs b/Shpadoinkle/WebWorker.hs
new file mode 100644
--- /dev/null
+++ b/Shpadoinkle/WebWorker.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+
+module Shpadoinkle.WebWorker where
+
+
+import Control.Monad (void)
+import Data.Text
+import GHCJS.DOM
+import Language.Javascript.JSaddle
+import Text.RawString.QQ
+
+
+newtype Worker = Worker { unWorker :: JSVal }
+ deriving (ToJSVal)
+
+
+createWorkerJS :: Text
+createWorkerJS = [r|createWorker = function (workerUrl) {
+ var worker = null;
+ try {
+ worker = new Worker(workerUrl);
+ } catch (e) {
+ try {
+ var blob;
+ try {
+ blob = new Blob(["importScripts('" + workerUrl + "');"], { "type": 'application/javascript' });
+ } catch (e1) {
+ var blobBuilder = new (window.BlobBuilder || window.WebKitBlobBuilder || window.MozBlobBuilder)();
+ blobBuilder.append("importScripts('" + workerUrl + "');");
+ blob = blobBuilder.getBlob('application/javascript');
+ }
+ var url = window.URL || window.webkitURL;
+ var blobUrl = url.createObjectURL(blob);
+ worker = new Worker(blobUrl);
+ } catch (e2) {
+ //if it still fails, there is nothing much we can do
+ }
+ }
+ return worker;
+}|]
+
+
+createWorker :: MonadJSM m => Text -> m Worker
+createWorker url = liftJSM $ do
+ _ <- eval createWorkerJS
+ w <- toJSVal =<< currentWindowUnchecked
+ u <- toJSVal url
+ Worker <$> (w # ("createWorker" :: Text) $ [u])
+
+
+postMessage :: ToJSVal a => MonadJSM m => Worker -> a -> m ()
+postMessage (Worker worker) msg = liftJSM $ do
+ v <- toJSVal msg
+ () <$ (worker # ("postMessage" :: Text) $ [v])
+
+
+postMessage' :: ToJSVal a => MonadJSM m => a -> m ()
+postMessage' msg = liftJSM $ do
+ self <- jsg ("self" :: Text)
+ m <- toJSVal msg
+ () <$ (self # ("postMessage" :: Text) $ m)
+
+
+hackWindow :: MonadJSM m => m ()
+hackWindow = void . liftJSM $ eval ("window = self" :: Text)
+
+
+onMessage :: ToJSVal mailbox => FromJSVal message => MonadJSM m => mailbox -> (Maybe message -> JSM ()) -> m ()
+onMessage mailbox f = liftJSM $ do
+ box <- toJSVal mailbox
+ (box <# ("onmessage" :: Text)) =<< toJSVal (fun (\_ _ -> \case
+ [v] -> f =<< fromJSVal =<< (v ! ("data" :: Text))
+ _ -> return ()))
+