Shpadoinkle-html 0.2.0.1 → 0.3.0.0

raw patch · 12 files changed

+472/−221 lines, 12 filesdep +lensdep +raw-strings-qqPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, raw-strings-qq

API changes (from Hackage documentation)

Files

• Shpadoinkle-html.cabal +7/−3
• Shpadoinkle/Html.hs +2/−2
• Shpadoinkle/Html/Event.hs +93/−159
• Shpadoinkle/Html/Event/Basic.hs +119/−0
• Shpadoinkle/Html/Event/Debounce.hs +13/−9
• Shpadoinkle/Html/Event/Throttle.hs +11/−7
• Shpadoinkle/Html/LocalStorage.hs +16/−16
• Shpadoinkle/Html/Property.hs +1/−1
• Shpadoinkle/Html/TH.hs +91/−7
• Shpadoinkle/Html/TH/CSS.hs +2/−2
• Shpadoinkle/Html/Utils.hs +39/−15
• Shpadoinkle/WebWorker.hs +78/−0

@@ -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

@@ -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

@@ -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)+

@@ -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" ])

@@ -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)

@@ -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)

@@ -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 

@@ -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

@@ -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 ++  "_"

@@ -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')))) []     ] 

@@ -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

@@ -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 ()))+