miso 1.7.1.0 → 1.8.0.0

raw patch · 73 files changed

+2400/−3023 lines, 73 filesdep +tagsoupPVP ok

version bump matches the API change (PVP)

Dependencies added: tagsoup

API changes (from Hackage documentation)

Files

• README.md +21/−17
• exe/Main.hs +1/−0
• frontend-src/Miso.hs +0/−168
• frontend-src/Miso/Delegate.hs +0/−32
• frontend-src/Miso/Dev.hs +0/−14
• frontend-src/Miso/Diff.hs +0/−49
• frontend-src/Miso/Effect.hs +0/−97
• frontend-src/Miso/Effect/DOM.hs +0/−17
• frontend-src/Miso/Effect/Storage.hs +0/−108
• frontend-src/Miso/Html/Internal.hs +0/−319
• frontend-src/Miso/JSBits.hs +0/−1
• frontend-src/Miso/String.hs +0/−139
• frontend-src/Miso/Subscription.hs +0/−24
• frontend-src/Miso/Subscription/History.hs +0/−107
• frontend-src/Miso/Subscription/Keyboard.hs +0/−106
• frontend-src/Miso/Subscription/Mouse.hs +0/−30
• frontend-src/Miso/Subscription/SSE.hs +0/−49
• frontend-src/Miso/Subscription/WebSocket.hs +0/−167
• frontend-src/Miso/Subscription/Window.hs +0/−56
• frontend-src/Miso/Types.hs +0/−149
• ghc-src/Miso.hs +0/−29
• ghc-src/Miso/Html/Internal.hs +0/−303
• ghc-src/Miso/String.hs +10/−2
• ghc-src/Miso/TypeLevel.hs +0/−19
• ghcjs-ffi/Miso/FFI.hs +0/−286
• ghcjs-ffi/Miso/FFI/History.hs +0/−37
• ghcjs-ffi/Miso/FFI/SSE.hs +0/−34
• ghcjs-ffi/Miso/FFI/Storage.hs +0/−45
• ghcjs-ffi/Miso/FFI/WebSocket.hs +0/−59
• ghcjs-src/Miso/String.hs +147/−0
• jsaddle-ffi/Miso/Dev.hs +0/−14
• jsaddle-ffi/Miso/FFI.hs +0/−274
• jsaddle-ffi/Miso/FFI/History.hs +0/−56
• jsaddle-ffi/Miso/FFI/SSE.hs +0/−38
• jsaddle-ffi/Miso/FFI/Storage.hs +0/−54
• jsaddle-ffi/Miso/FFI/WebSocket.hs +0/−67
• jsbits/diff.js +1/−1
• miso.cabal +35/−44
• src/Miso.hs +172/−0
• src/Miso/Concurrent.hs +3/−3
• src/Miso/Delegate.hs +32/−0
• src/Miso/Dev.hs +14/−0
• src/Miso/Diff.hs +50/−0
• src/Miso/Effect.hs +97/−0
• src/Miso/Effect/DOM.hs +17/−0
• src/Miso/Effect/Storage.hs +125/−0
• src/Miso/Event/Decoder.hs +6/−0
• src/Miso/Event/Types.hs +3/−0
• src/Miso/FFI.hs +293/−0
• src/Miso/FFI/History.hs +57/−0
• src/Miso/FFI/SSE.hs +39/−0
• src/Miso/FFI/Storage.hs +55/−0
• src/Miso/FFI/WebSocket.hs +68/−0
• src/Miso/Html.hs +2/−2
• src/Miso/Html/Element.hs +1/−1
• src/Miso/Html/Event.hs +1/−1
• src/Miso/Html/Property.hs +13/−1
• src/Miso/Html/Types.hs +421/−0
• src/Miso/JSBits.hs +1/−0
• src/Miso/Mathml/Element.hs +1/−1
• src/Miso/Router.hs +1/−0
• src/Miso/Subscription.hs +24/−0
• src/Miso/Subscription/History.hs +107/−0
• src/Miso/Subscription/Keyboard.hs +106/−0
• src/Miso/Subscription/Mouse.hs +30/−0
• src/Miso/Subscription/SSE.hs +49/−0
• src/Miso/Subscription/WebSocket.hs +168/−0
• src/Miso/Subscription/Window.hs +58/−0
• src/Miso/Svg/Attribute.hs +1/−1
• src/Miso/Svg/Element.hs +1/−1
• src/Miso/Svg/Event.hs +1/−1
• src/Miso/TypeLevel.hs +19/−0
• src/Miso/Types.hs +149/−0

@@ -17,13 +17,13 @@   <a href="https://miso-haskell.cachix.org"> 	<img src="https://img.shields.io/badge/build-cachix-yellow.svg?style=flat-square" alt="Cachix">   </a>-  <a href="https://travis-ci.org/dmjio/miso">-    <img src="https://img.shields.io/travis/dmjio/miso.svg?style=flat-square" alt="Travis CI">+  <a href="https://github.com/dmjio/miso/actions">+    <img src="https://github.com/dmjio/miso/workflows/test%20matrix/badge.svg" alt="GitHub Actions">   </a>   <a href="http://hackage.haskell.org/package/miso"> 	<img src="https://img.shields.io/hackage/v/miso.svg?style=flat-square" alt="Hackage">   </a>-  <a href="https://www.irccloud.com/invite?channel=%23haskell-miso&amp;hostname=irc.freenode.net&amp;port=6697&amp;ssl=1">+  <a href="https://www.irccloud.com/invite?channel=%23haskell-miso&amp;hostname=irc.libera.chat&amp;port=6697&amp;ssl=1"> 	<img src="https://img.shields.io/badge/irc-%23haskell--miso-1e72ff.svg?style=flat-square" alt="IRC #haskell-miso">   </a>   <a href="https://github.com/dmjio/miso/blob/master/LICENSE">@@ -55,6 +55,7 @@   - [Simple](#simple)   - [File Reader](#file-reader)   - [WebVR](#webvr)+  - [Pixel Card Wars](#pixel-card-wars) - [Haddocks](#haddocks)   - [GHC](#ghc)   - [GHCJS](#ghcjs)@@ -179,52 +180,55 @@ ## Examples  ### TodoMVC-  - [Link](http://todo-mvc.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/todo-mvc/Main.hs)+  - [Link](https://todo-mvc.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/todo-mvc/Main.hs)  ### Flatris-  - [Link](http://flatris.haskell-miso.org/) / [Source](https://github.com/ptigwe/hs-flatris/)+  - [Link](https://flatris.haskell-miso.org/) / [Source](https://github.com/ptigwe/hs-flatris/)  ### 2048-  - [Link](http://2048.haskell-miso.org/) / [Source](https://github.com/ptigwe/hs2048/)+  - [Link](https://2048.haskell-miso.org/) / [Source](https://github.com/ptigwe/hs2048/)  ### Snake-  - [Link](http://snake.haskell-miso.org/) / [Source](https://github.com/lbonn/miso-snake)+  - [Link](https://snake.haskell-miso.org/) / [Source](https://github.com/lbonn/miso-snake)  ### Mario-  - [Link](http://mario.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/mario/Main.hs)+  - [Link](https://mario.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/mario/Main.hs)  ### Miso Plane (Flappy Birds)-  - [Link](http://miso-plane.lermex.net/) / [Source](https://github.com/Lermex/miso-plane)+  - [Link](http://miso-plane.haskell-miso.org) / [Source](https://github.com/Lermex/miso-plane)  ### Websocket-  - [Link](http://websocket.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/websocket/Main.hs)+  - [Link](https://websocket.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/websocket/Main.hs)  ### SSE   - [Link](http://sse.haskell-miso.org/) / [Client](https://github.com/dmjio/miso/blob/master/examples/sse/client/Main.hs) / [Server](https://github.com/dmjio/miso/blob/master/examples/sse/server/Main.hs)  ### XHR-  - [Link](http://xhr.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/xhr/Main.hs)+  - [Link](https://xhr.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/xhr/Main.hs)  ### Router-  - [Link](http://router.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/router/Main.hs)+  - [Link](https://router.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/router/Main.hs)  ### SVG-  - [Link](http://svg.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/svg/Main.hs)+  - [Link](https://svg.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/svg/Main.hs)  ### Canvas 2D-  - [Link](http://canvas.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/canvas2d/Main.hs)+  - [Link](https://canvas.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/canvas2d/Main.hs)  ### ThreeJS-  - [Link](http://threejs.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/three/Main.hs)+  - [Link](https://threejs.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/three/Main.hs)  ### Simple-  - [Link](http://simple.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/exe/Main.hs)+  - [Link](https://simple.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/exe/Main.hs)  ### File Reader-  - [Link](http://file-reader.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/file-reader/Main.hs)+  - [Link](https://file-reader.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/file-reader/Main.hs)  ### WebVR   - [Link](http://fizruk.github.io/fpconf-2017-talk/miso-aframe-demo/dist/demo.jsexe/index.html) / [Source](https://github.com/fizruk/miso-aframe)++### Pixel Card Wars+  - [Link](https://www.schplaf.org/hgames/darkcraw/) / [Source](https://github.com/smelc/miso-darkcraw)  ## Haddocks 

@@ -62,4 +62,5 @@    button_ [ onClick AddOne ] [ text "+" ]  , text (ms x)  , button_ [ onClick SubtractOne ] [ text "-" ]+ , rawHtml "<div><p>hey expandable!</div></p>"  ]

@@ -1,168 +0,0 @@-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE KindSignatures      #-}--#ifdef IOS-#else-{-# LANGUAGE TemplateHaskell     #-}-#endif--------------------------------------------------------------------------------- |--- Module      :  Miso--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso-  ( miso-  , startApp-  , module Miso.Effect-  , module Miso.Event-  , module Miso.Html-  , module Miso.Subscription-  , module Miso.Types-  , module Miso.Router-  , module Miso.Util-  , module Miso.FFI-  ) where--import           Control.Concurrent-import           Control.Monad-import           Control.Monad.IO.Class-import           Data.IORef-import           Data.List-import           Data.Sequence ((|>))-import           System.Mem.StableName-import qualified Data.Sequence as S-import qualified JavaScript.Object.Internal as OI--#ifdef JSADDLE-import           Language.Javascript.JSaddle (eval, waitForAnimationFrame)-#ifdef IOS-import           Miso.JSBits-#else-import           GHCJS.Types (JSString)-import           Data.FileEmbed-#endif-#else-import           JavaScript.Web.AnimationFrame-#endif--import           Miso.Concurrent-import           Miso.Delegate-import           Miso.Diff-import           Miso.Effect-import           Miso.Event-import           Miso.FFI-import           Miso.Html-import           Miso.Router-import           Miso.Subscription-import           Miso.Types-import           Miso.Util---- | Helper function to abstract out common functionality between `startApp` and `miso`-common-  :: Eq model-  => App model action-  -> model-  -> (Sink action -> JSM (IORef VTree))-  -> JSM ()-common App {..} m getView = do-#ifdef JSADDLE-#ifdef IOS-  mapM_ eval [delegateJs,diffJs,isomorphicJs,utilJs]-#else-  _ <- eval ($(embedStringFile "jsbits/delegate.js") :: JSString)-  _ <- eval ($(embedStringFile "jsbits/diff.js") :: JSString)-  _ <- eval ($(embedStringFile "jsbits/isomorphic.js") :: JSString)-  _ <- eval ($(embedStringFile "jsbits/util.js") :: JSString)-#endif-#endif-  -- init Notifier-  Notify {..} <- liftIO newNotify-  -- init empty actions-  actionsRef <- liftIO (newIORef S.empty)-  let writeEvent a = void . liftIO . forkIO $ do-        atomicModifyIORef' actionsRef $ \as -> (as |> a, ())-        notify-  -- init Subs-  forM_ subs $ \sub ->-    sub writeEvent-  -- Hack to get around `BlockedIndefinitelyOnMVar` exception-  -- that occurs when no event handlers are present on a template-  -- and `notify` is no longer in scope-  void . liftIO . forkIO . forever $ threadDelay (1000000 * 86400) >> notify-  -- Retrieves reference view-  viewRef <- getView writeEvent-  -- know thy mountElement-  mountEl <- mountElement mountPoint-  -- Begin listening for events in the virtual dom-  delegator mountEl viewRef events-  -- Process initial action of application-  writeEvent initialAction-  -- Program loop, blocking on SkipChan--  let-    loop !oldModel = liftIO wait >> do-        -- Apply actions to model-        actions <- liftIO $ atomicModifyIORef' actionsRef $ \actions -> (S.empty, actions)-        let (Acc newModel effects) = foldl' (foldEffects writeEvent update)-                                            (Acc oldModel (pure ())) actions-        effects-        oldName <- liftIO $ oldModel `seq` makeStableName oldModel-        newName <- liftIO $ newModel `seq` makeStableName newModel-        when (oldName /= newName && oldModel /= newModel) $ do-          swapCallbacks-          newVTree <- runView (view newModel) writeEvent-          oldVTree <- liftIO (readIORef viewRef)-          void $ waitForAnimationFrame-          (diff mountPoint) (Just oldVTree) (Just newVTree)-          releaseCallbacks-          liftIO (atomicWriteIORef viewRef newVTree)-        syncPoint-        loop newModel-  loop m---- | Runs an isomorphic miso application.--- Assumes the pre-rendered DOM is already present-miso :: Eq model => (URI -> App model action) -> JSM ()-miso f = do-  app@App {..} <- f <$> getCurrentURI-  common app model $ \writeEvent -> do-    let initialView = view model-    VTree (OI.Object iv) <- flip runView writeEvent initialView-    mountEl <- mountElement mountPoint-    -- Initial diff can be bypassed, just copy DOM into VTree-    copyDOMIntoVTree (logLevel == DebugPrerender) mountEl iv-    let initialVTree = VTree (OI.Object iv)-    -- Create virtual dom, perform initial diff-    liftIO (newIORef initialVTree)---- | Runs a miso application-startApp :: Eq model => App model action -> JSM ()-startApp app@App {..} =-  common app model $ \writeEvent -> do-    let initialView = view model-    initialVTree <- flip runView writeEvent initialView-    (diff mountPoint) Nothing (Just initialVTree)-    liftIO (newIORef initialVTree)---- | Helper-foldEffects-  :: Sink action-  -> (action -> model -> Effect action model)-  -> Acc model -> action -> Acc model-foldEffects sink update = \(Acc model as) action ->-  case update action model of-    Effect newModel effs -> Acc newModel newAs-      where-        newAs = as >> do-          forM_ effs $ \eff -> forkJSM (eff sink)--data Acc model = Acc !model !(JSM ())

@@ -1,32 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.Delegate--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Delegate where--import           Control.Monad.IO.Class-import           Data.IORef-import qualified Data.Map as M-import           GHCJS.Marshal-import           GHCJS.Types (JSVal)-import qualified JavaScript.Object.Internal as OI-import           Miso.FFI-import           Miso.Html.Internal-import           Miso.String---- | Entry point for event delegation-delegator-  :: JSVal-  -> IORef VTree-  -> M.Map MisoString Bool-  -> JSM ()-delegator mountPointElement vtreeRef es = do-  evts <- toJSVal (M.toList es)-  delegateEvent mountPointElement evts $ do-    VTree (OI.Object val) <- liftIO (readIORef vtreeRef)-    pure val

@@ -1,14 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.Dev--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Dev-  ( clearBody-  ) where--import Miso.FFI (clearBody)

@@ -1,49 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.Diff--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Diff ( diff-                 , mountElement-                 ) where--import GHCJS.Foreign.Internal     hiding (Object)-import GHCJS.Types-import JavaScript.Object.Internal-import Miso.Html.Internal-import Miso.FFI---- | Entry point for diffing / patching algorithm-diff :: Maybe JSString -> Maybe VTree -> Maybe VTree -> JSM ()-diff mayElem current new =-  case mayElem of-    Nothing -> do-      body <- getBody-      diffElement body current new-    Just elemId -> do-      e <- getElementById elemId-      diffElement e current new---- | diffing / patching a given element-diffElement :: JSVal -> Maybe VTree -> Maybe VTree -> JSM ()-diffElement mountEl current new = do-  doc <- getDoc-  case (current, new) of-    (Nothing, Nothing) -> pure ()-    (Just (VTree current'), Just (VTree new')) -> do-      diff' current' new' mountEl doc-    (Nothing, Just (VTree new')) -> do-      diff' (Object jsNull) new' mountEl doc-    (Just (VTree current'), Nothing) -> do-      diff' current' (Object jsNull) mountEl doc---- | return the configured mountPoint element or the body-mountElement :: Maybe JSString -> JSM JSVal-mountElement mayMp =-  case mayMp of-    Nothing -> getBody-    Just eid -> getElementById eid

@@ -1,97 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.Effect--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ This module defines `Effect` and `Sub` types, which are used to define--- `Miso.Types.update` function and `Miso.Types.subs` field of the `Miso.Types.App`.------------------------------------------------------------------------------module Miso.Effect (-  module Miso.Effect.Storage-, module Miso.Effect.DOM-, Effect (..), Sub, Sink-, mapSub-, noEff-, (<#)-, (#>)-, batchEff-, effectSub-) where--import Data.Bifunctor--import Control.Monad.IO.Class-import Miso.FFI (JSM)--import Miso.Effect.Storage-import Miso.Effect.DOM---- | An effect represents the results of an update action.------ It consists of the updated model and a list of subscriptions. Each 'Sub' is--- run in a new thread so there is no risk of accidentally blocking the--- application.-data Effect action model = Effect model [Sub action]---- | Type synonym for constructing event subscriptions.------ The 'Sink' callback is used to dispatch actions which are then fed--- back to the 'Miso.Types.update' function.-type Sub action = Sink action -> JSM ()---- | Function to asynchronously dispatch actions to the 'Miso.Types.update' function.-type Sink action = action -> IO ()---- | Turn a subscription that consumes actions of type @a@ into a subscription--- that consumes actions of type @b@ using the supplied function of type @a -> b@.-mapSub :: (actionA -> actionB) -> Sub actionA -> Sub actionB-mapSub f sub = \sinkB -> let sinkA = sinkB . f-                         in sub sinkA--instance Functor (Effect action) where-  fmap f (Effect m acts) = Effect (f m) acts--instance Applicative (Effect action) where-  pure m = Effect m []-  Effect fModel fActs <*> Effect xModel xActs = Effect (fModel xModel) (fActs ++ xActs)--instance Monad (Effect action) where-  return = pure-  Effect m acts >>= f =-    case f m of-      Effect m' acts' -> Effect m' (acts ++ acts')--instance Bifunctor Effect where-  bimap f g (Effect m acts) = Effect (g m) (map (\act -> \sink -> act (sink . f)) acts)---- | Smart constructor for an 'Effect' with no actions.-noEff :: model -> Effect action model-noEff m = Effect m []---- | Smart constructor for an 'Effect' with exactly one action.-(<#) :: model -> JSM action -> Effect action model-(<#) m a = effectSub m $ \sink -> a >>= liftIO . sink---- | `Effect` smart constructor, flipped-(#>) :: JSM action -> model -> Effect action model-(#>) = flip (<#)---- | Smart constructor for an 'Effect' with multiple actions.-batchEff :: model -> [JSM action] -> Effect action model-batchEff model actions = Effect model $-  map (\a sink -> liftIO . sink =<< a) actions---- | Like '<#' but schedules a subscription which is an IO computation which has--- access to a 'Sink' which can be used to asynchronously dispatch actions to--- the 'update' function.------ A use-case is scheduling an IO computation which creates a 3rd-party JS--- widget which has an associated callback. The callback can then call the sink--- to turn events into actions. To do this without accessing a sink requires--- going via a @'Sub'scription@ which introduces a leaky-abstraction.-effectSub :: model -> Sub action -> Effect action model-effectSub model sub = Effect model [sub]

@@ -1,17 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.Effect.DOM--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Effect.DOM-  ( focus-  , blur-  , scrollIntoView-  , alert-  ) where--import Miso.FFI

@@ -1,108 +0,0 @@-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE ForeignFunctionInterface  #-}-{-# LANGUAGE LambdaCase                #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.Effect.Storage--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ This module provides an interface to the--- [Web Storage API](https://developer.mozilla.org/en-US/docs/Web/API/Web_Storage_API).------------------------------------------------------------------------------module Miso.Effect.Storage-  ( -- * Retrieve storage-    getLocalStorage-  , getSessionStorage-    -- * Set items in storage-  , setLocalStorage-  , setSessionStorage-    -- * Remove items from storage-  , removeLocalStorage-  , removeSessionStorage-    -- * Clear storage-  , clearLocalStorage-  , clearSessionStorage-    -- * Get number of items in storage-  , localStorageLength-  , sessionStorageLength-  ) where--import           Data.Aeson hiding (Object, String)-import           Data.JSString-import           GHCJS.Marshal-import           GHCJS.Types--import           Miso.FFI--import qualified Miso.FFI.Storage as Storage---- | Helper for retrieving either local or session storage-getStorageCommon-  :: FromJSON b => (t -> JSM (Maybe JSVal)) -> t -> JSM (Either String b)-getStorageCommon f key = do-  result :: Maybe JSVal <- f key-  case result of-    Nothing -> pure $ Left "Not Found"-    Just v -> do-      r <- parse v-      pure $ case fromJSON r of-        Success x -> Right x-        Error y -> Left y---- | Retrieve a value stored under given key in session storage-getSessionStorage :: FromJSON model => JSString -> JSM (Either String model)-getSessionStorage =-  getStorageCommon $ \t -> do-    s <- Storage.sessionStorage-    r <- Storage.getItem s t-    fromJSVal r---- | Retrieve a value stored under given key in local storage-getLocalStorage :: FromJSON model => JSString -> JSM (Either String model)-getLocalStorage = getStorageCommon $ \t -> do-    s <- Storage.localStorage-    r <- Storage.getItem s t-    fromJSVal r---- | Set the value of a key in local storage.------ @setLocalStorage key value@ sets the value of @key@ to @value@.-setLocalStorage :: ToJSON model => JSString -> model -> JSM ()-setLocalStorage key model = do-  s <- Storage.localStorage-  Storage.setItem s key =<< stringify model---- | Set the value of a key in session storage.------ @setSessionStorage key value@ sets the value of @key@ to @value@.-setSessionStorage :: ToJSON model => JSString -> model -> JSM ()-setSessionStorage key model = do-  s <- Storage.sessionStorage-  Storage.setItem s key =<< stringify model--removeLocalStorage :: JSString -> JSM ()-removeLocalStorage key = do-  s <- Storage.localStorage-  Storage.removeItem s key--removeSessionStorage :: JSString -> JSM ()-removeSessionStorage key = do-  s <- Storage.sessionStorage-  Storage.removeItem s key--clearLocalStorage :: JSM ()-clearLocalStorage = Storage.clear =<< Storage.localStorage--clearSessionStorage :: JSM ()-clearSessionStorage = Storage.clear =<< Storage.sessionStorage--localStorageLength :: JSM Int-localStorageLength = Storage.length =<< Storage.localStorage--sessionStorageLength :: JSM Int-sessionStorageLength = Storage.length =<< Storage.sessionStorage

@@ -1,319 +0,0 @@-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE RecordWildCards            #-}-{-# OPTIONS_GHC -fno-warn-orphans       #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.Html.Internal--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Html.Internal (-  -- * Core types and interface-    VTree  (..)-  , View   (..)-  , ToView (..)-  , Attribute (..)-  -- * Smart `View` constructors-  , node-  , text-  , textRaw-  -- * Key patch internals-  , Key    (..)-  , ToKey  (..)-  -- * Namespace-  , NS     (..)-  -- * Setting properties on virtual DOM nodes-  , prop-  -- * Setting css-  , style_-  -- * Handling events-  , on-  , onWithOptions-  -- * Life cycle events-  , onCreated-  , onDestroyed-  , onBeforeDestroyed-  -- * Events-  , defaultEvents-  -- * Subscription type-  , Sub-  ) where--import           Control.Monad-import           Control.Monad.IO.Class-import           Data.Aeson.Types (parseEither)-import           Data.JSString-import qualified Data.Map as M-import           Data.Proxy-import           Data.String (IsString(..))-import qualified Data.Text as T-import           GHCJS.Marshal-import           GHCJS.Types-import qualified JavaScript.Array as JSArray-import           JavaScript.Object-import           JavaScript.Object.Internal (Object (Object))-import           Servant.API--import           Miso.Effect (Sub)-import           Miso.Event.Decoder-import           Miso.Event.Types-import           Miso.String-import           Miso.Effect (Sink)-import           Miso.FFI---- | Virtual DOM implemented as a JavaScript `Object`.---   Used for diffing, patching and event delegation.---   Not meant to be constructed directly, see `View` instead.-newtype VTree = VTree { getTree :: Object }---- | Core type for constructing a `VTree`, use this instead of `VTree` directly.-newtype View action = View {-  runView :: Sink action -> JSM VTree-} deriving Functor---- | For constructing type-safe links-instance HasLink (View a) where-#if MIN_VERSION_servant(0,14,0)-  type MkLink (View a) b = MkLink (Get '[] ()) b-  toLink toA Proxy = toLink toA (Proxy :: Proxy (Get '[] ()))-#else-  type MkLink (View a) = MkLink (Get '[] ())-  toLink _ = toLink (Proxy :: Proxy (Get '[] ()))-#endif---- | Convenience class for using View-class ToView v where toView :: v -> View m---- | `ToJSVal` instance for `Decoder`-instance ToJSVal DecodeTarget where-  toJSVal (DecodeTarget xs) = toJSVal xs-  toJSVal (DecodeTargets xs) = toJSVal xs---- | Create a new @VNode@.------ @node ns tag key attrs children@ creates a new node with tag @tag@--- and 'Key' @key@ in the namespace @ns@. All @attrs@ are called when--- the node is created and its children are initialized to @children@.-node :: NS-     -> MisoString-     -> Maybe Key-     -> [Attribute m]-     -> [View m]-     -> View m-node ns tag key attrs kids = View $ \sink -> do-  vnode <- create-  cssObj <- objectToJSVal =<< create-  propsObj <- objectToJSVal =<< create-  eventObj <- objectToJSVal =<< create-  set "css" cssObj vnode-  set "props" propsObj vnode-  set "events" eventObj vnode-  set "type" ("vnode" :: JSString) vnode-  set "ns" ns vnode-  set "tag" tag vnode-  set "key" key vnode-  setAttrs vnode sink-  flip (set "children") vnode-    =<< ghcjsPure . jsval-    =<< setKids sink-  pure $ VTree vnode-    where-      setAttrs vnode sink =-        forM_ attrs $ \(Attribute attr) ->-          attr sink vnode-      setKids sink = do-        kidsViews <- traverse (objectToJSVal . getTree <=< flip runView sink) kids-        ghcjsPure (JSArray.fromList kidsViews)--instance ToJSVal Options-instance ToJSVal Key where toJSVal (Key x) = toJSVal x--instance ToJSVal NS where-  toJSVal SVG  = toJSVal ("svg" :: JSString)-  toJSVal HTML = toJSVal ("html" :: JSString)-  toJSVal MATHML = toJSVal ("mathml" :: JSString)---- | Namespace of DOM elements.-data NS-  = HTML -- ^ HTML Namespace-  | SVG  -- ^ SVG Namespace-  | MATHML  -- ^ MATHML Namespace-  deriving (Show, Eq)---- | Create a new @VText@ with the given content.-text :: MisoString -> View m-text t = View . const $ do-  vtree <- create-  set "type" ("vtext" :: JSString) vtree-  set "text" t vtree-  pure $ VTree vtree---- | For parity with server-side rendering. Don't use directly.-textRaw :: MisoString -> View m-textRaw = text---- | `IsString` instance-instance IsString (View a) where-  fromString = text . fromString---- | A unique key for a dom node.------ This key is only used to speed up diffing the children of a DOM--- node, the actual content is not important. The keys of the children--- of a given DOM node must be unique. Failure to satisfy this--- invariant gives undefined behavior at runtime.-newtype Key = Key MisoString---- | Convert custom key types to `Key`.------ Instances of this class do not have to guarantee uniqueness of the--- generated keys, it is up to the user to do so. `toKey` must be an--- injective function.-class ToKey key where toKey :: key -> Key--- | Identity instance-instance ToKey Key where toKey = id--- | Convert `MisoString` to `Key`-instance ToKey MisoString where toKey = Key--- | Convert `Text` to `Key`-instance ToKey T.Text where toKey = Key . toMisoString--- | Convert `String` to `Key`-instance ToKey String where toKey = Key . toMisoString--- | Convert `Int` to `Key`-instance ToKey Int where toKey = Key . toMisoString--- | Convert `Double` to `Key`-instance ToKey Double where toKey = Key . toMisoString--- | Convert `Float` to `Key`-instance ToKey Float where toKey = Key . toMisoString--- | Convert `Word` to `Key`-instance ToKey Word where toKey = Key . toMisoString---- | Attribute of a vnode in a `View`.------ The 'Sink' callback can be used to dispatch actions which are fed back to--- the @update@ function. This is especially useful for event handlers--- like the @onclick@ attribute. The second argument represents the--- vnode the attribute is attached to.-newtype Attribute action = Attribute (Sink action -> Object -> JSM ())---- | @prop k v@ is an attribute that will set the attribute @k@ of the DOM node associated with the vnode--- to @v@.-prop :: ToJSVal a => MisoString -> a -> Attribute action-prop k v = Attribute . const $ \n -> do-  val <- toJSVal v-  o <- getProp ("props" :: MisoString) n-  set k val (Object o)---- | Convenience wrapper for @onWithOptions defaultOptions@.------ > let clickHandler = on "click" emptyDecoder $ \() -> Action--- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ]----on :: MisoString-   -> Decoder r-   -> (r -> action)-   -> Attribute action-on = onWithOptions defaultOptions---- | @onWithOptions opts eventName decoder toAction@ is an attribute--- that will set the event handler of the associated DOM node to a function that--- decodes its argument using @decoder@, converts it to an action--- using @toAction@ and then feeds that action back to the @update@ function.------ @opts@ can be used to disable further event propagation.------ > let clickHandler = onWithOptions defaultOptions "click" emptyDecoder $ \() -> Action--- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ]----onWithOptions-  :: Options-  -> MisoString-  -> Decoder r-  -> (r -> action)-  -> Attribute action-onWithOptions options eventName Decoder{..} toAction =-  Attribute $ \sink n -> do-   eventObj <- getProp "events" n-   eventHandlerObject@(Object eo) <- create-   jsOptions <- toJSVal options-   decodeAtVal <- toJSVal decodeAt-   cb <- callbackToJSVal <=< asyncCallback1 $ \e -> do-       Just v <- fromJSVal =<< objectToJSON decodeAtVal e-       case parseEither decoder v of-         Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s-         Right r -> liftIO (sink (toAction r))-   set "runEvent" cb eventHandlerObject-   registerCallback cb-   set "options" jsOptions eventHandlerObject-   set eventName eo (Object eventObj)---- | @onCreated action@ is an event that gets called after the actual DOM--- element is created.------ Important note: Any node that uses this event MUST have a unique @Key@,--- otherwise the event may not be reliably called!-onCreated :: action -> Attribute action-onCreated action =-  Attribute $ \sink n -> do-    cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action))-    set "onCreated" cb n-    registerCallback cb---- | @onDestroyed action@ is an event that gets called after the DOM element--- is removed from the DOM. The @action@ is given the DOM element that was--- removed from the DOM tree.------ Important note: Any node that uses this event MUST have a unique @Key@,--- otherwise the event may not be reliably called!-onDestroyed :: action -> Attribute action-onDestroyed action =-  Attribute $ \sink n -> do-    cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action))-    set "onDestroyed" cb n-    registerCallback cb---- | @onBeforeDestroyed action@ is an event that gets called before the DOM element--- is removed from the DOM. The @action@ is given the DOM element that was--- removed from the DOM tree.------ Important note: Any node that uses this event MUST have a unique @Key@,--- otherwise the event may not be reliably called!-onBeforeDestroyed :: action -> Attribute action-onBeforeDestroyed action =-  Attribute $ \sink n -> do-    cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action))-    set "onBeforeDestroyed" cb n-    registerCallback cb---- | @style_ attrs@ is an attribute that will set the @style@--- attribute of the associated DOM node to @attrs@.------ @style@ attributes not contained in @attrs@ will be deleted.------ > import qualified Data.Map as M--- > div_ [ style_  $ M.singleton "background" "red" ] [ ]------ <https://developer.mozilla.org/en-US/docs/Web/CSS>----style_ :: M.Map MisoString MisoString -> Attribute action-style_ m = Attribute . const $ \n -> do-   cssObj <- getProp "css" n-   forM_ (M.toList m) $ \(k,v) ->-     set k v (Object cssObj)

@@ -1,1 +0,0 @@-module Miso.JSBits where

@@ -1,139 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans       #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.String--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.String (-    ToMisoString (..)-  , FromMisoString (..)-  , fromMisoString-  , MisoString-  , module Data.JSString-  , module Data.Monoid-  , ms-  ) where--#ifndef JSADDLE-import           Data.Aeson-#endif-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import           Data.Char-import           Data.JSString-import           Data.JSString.Text-import           Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.Encoding as LT-import           Prelude hiding (foldr)-import           Miso.FFI---- | String type swappable based on compiler-type MisoString = JSString--#ifndef JSADDLE----- | `ToJSON` for `MisoString`-instance ToJSON MisoString where-  toJSON = String . textFromJSString---- | `FromJSON` for `MisoString`-instance FromJSON MisoString where-  parseJSON =-    withText "Not a valid string" $ \x ->-      pure (toMisoString x)-#endif---- | Convenience class for creating `MisoString` from other string-like types-class ToMisoString str where-  toMisoString :: str -> MisoString--class FromMisoString t where-  -- -- | Reads a `MisoString` into an 'a', throws an error when-  fromMisoStringEither :: MisoString -> Either String t---- | Reads a `MisoString` into an 'a', throws an error when decoding--- fails. Use `fromMisoStringEither` for as a safe alternative.-fromMisoString :: FromMisoString a => MisoString -> a-fromMisoString s = case fromMisoStringEither s of-                     Left err -> error err-                     Right x  -> x---- | Convenience function, shorthand for `toMisoString`-ms :: ToMisoString str => str -> MisoString-ms = toMisoString--instance ToMisoString MisoString where-  toMisoString = id-instance ToMisoString String where-  toMisoString = pack-instance ToMisoString T.Text where-  toMisoString = textToJSString-instance ToMisoString LT.Text where-  toMisoString = lazyTextToJSString-instance ToMisoString B.ByteString where-  toMisoString = toMisoString . T.decodeUtf8-instance ToMisoString BL.ByteString where-  toMisoString = toMisoString . LT.decodeUtf8-instance ToMisoString Float where-  toMisoString = realFloatToJSString-instance ToMisoString Double where-  toMisoString = realFloatToJSString-instance ToMisoString Int where-  toMisoString = integralToJSString-instance ToMisoString Word where-  toMisoString = integralToJSString--instance FromMisoString MisoString where-  fromMisoStringEither = Right-instance FromMisoString String where-  fromMisoStringEither = Right . unpack-instance FromMisoString T.Text where-  fromMisoStringEither = Right . textFromJSString-instance FromMisoString LT.Text where-  fromMisoStringEither = Right . lazyTextFromJSString-instance FromMisoString B.ByteString where-  fromMisoStringEither = fmap T.encodeUtf8 . fromMisoStringEither-instance FromMisoString BL.ByteString where-  fromMisoStringEither = fmap LT.encodeUtf8 . fromMisoStringEither-instance FromMisoString Float where-  fromMisoStringEither = fmap realToFrac . jsStringToDoubleEither-instance FromMisoString Double where-  fromMisoStringEither = jsStringToDoubleEither-instance FromMisoString Int where-  fromMisoStringEither = parseInt-instance FromMisoString Word where-  fromMisoStringEither = parseWord--jsStringToDoubleEither :: JSString -> Either String Double-jsStringToDoubleEither s = let d = jsStringToDouble s-                           in if isNaN d then Left "jsStringToDoubleEither: parse failed"-                                         else Right d---parseWord   :: MisoString -> Either String Word-parseWord s = case uncons s of-                Nothing     -> Left "parseWord: parse error"-                Just (c,s') -> foldl' k (pDigit c) s'-  where-    pDigit c | isDigit c = Right . fromIntegral . digitToInt $ c-             | otherwise = Left "parseWord: parse error"-    k ea c = (\a x -> 10*a + x) <$> ea <*> pDigit c--parseInt   :: MisoString -> Either String Int-parseInt s = case uncons s of-               Just ('-',s') -> ((-1)*) . fromIntegral <$> parseWord s'-               _             ->           fromIntegral <$> parseWord s

@@ -1,24 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.Subscription--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Subscription-  ( module Miso.Subscription.Mouse-  , module Miso.Subscription.Keyboard-  , module Miso.Subscription.History-  , module Miso.Subscription.Window-  , module Miso.Subscription.WebSocket-  , module Miso.Subscription.SSE-  ) where--import Miso.Subscription.Mouse-import Miso.Subscription.Keyboard-import Miso.Subscription.History-import Miso.Subscription.Window-import Miso.Subscription.WebSocket-import Miso.Subscription.SSE

@@ -1,107 +0,0 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE TypeOperators     #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.Subscription.History--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Subscription.History-  ( getCurrentURI-  , pushURI-  , replaceURI-  , back-  , forward-  , go-  , uriSub-  , URI (..)-  ) where--import Control.Monad-import Control.Monad.IO.Class-import Miso.Concurrent-import Miso.FFI-import qualified Miso.FFI.History as FFI-import Miso.Html.Internal (Sub)-import Miso.String-import Network.URI hiding (path)-import System.IO.Unsafe---- | Retrieves current URI of page-getCurrentURI :: JSM URI-{-# INLINE getCurrentURI #-}-getCurrentURI = getURI---- | Retrieves current URI of page-getURI :: JSM URI-{-# INLINE getURI #-}-getURI = do-  href <- fromMisoString <$> FFI.getWindowLocationHref-  case parseURI href of-    Nothing  -> fail $ "Could not parse URI from window.location: " ++ href-    Just uri -> return uri---- | Pushes a new URI onto the History stack-pushURI :: URI -> JSM ()-{-# INLINE pushURI #-}-pushURI uri = pushStateNoModel uri { uriPath = toPath uri }---- | Prepend '/' if necessary-toPath :: URI -> String-toPath uri =-  case uriPath uri of-    "" -> "/"-    "/" -> "/"-    xs@('/' : _) -> xs-    xs -> '/' : xs---- | Replaces current URI on stack-replaceURI :: URI -> JSM ()-{-# INLINE replaceURI #-}-replaceURI uri = replaceTo' uri { uriPath = toPath uri }---- | Navigates backwards-back :: JSM ()-{-# INLINE back #-}-back = FFI.back---- | Navigates forwards-forward :: JSM ()-{-# INLINE forward #-}-forward = FFI.forward---- | Jumps to a specific position in history-go :: Int -> JSM ()-{-# INLINE go #-}-go n = FFI.go n--chan :: Notify-{-# NOINLINE chan #-}-chan = unsafePerformIO newEmptyNotify---- | Subscription for `popState` events, from the History API-uriSub :: (URI -> action) -> Sub action-uriSub = \f sink -> do-  void.forkJSM.forever $ do-    liftIO (wait chan)-    liftIO . sink . f =<< getURI-  windowAddEventListener "popstate" $ \_ ->-      liftIO . sink . f =<< getURI--pushStateNoModel :: URI -> JSM ()-{-# INLINE pushStateNoModel #-}-pushStateNoModel u = do-  FFI.pushState . pack . show $ u-  liftIO (notify chan)--replaceTo' :: URI -> JSM ()-{-# INLINE replaceTo' #-}-replaceTo' u = do-  FFI.replaceState . pack . show $ u-  liftIO (notify chan)

@@ -1,106 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE OverloadedStrings   #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.Subscription.Keyboard--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Subscription.Keyboard-  ( -- * Types-    Arrows (..)-    -- * Subscriptions-  , arrowsSub-  , directionSub-  , keyboardSub-  , wasdSub-  ) where--import           Control.Monad.IO.Class-import           Data.IORef-import           Data.Set-import qualified Data.Set as S-import           GHCJS.Marshal-import           JavaScript.Object-import           JavaScript.Object.Internal--import           Miso.FFI-import           Miso.Html.Internal ( Sub )---- | type for arrow keys currently pressed---  37 left arrow  ( x = -1 )---  38 up arrow    ( y =  1 )---  39 right arrow ( x =  1 )---  40 down arrow  ( y = -1 )-data Arrows = Arrows {-   arrowX :: !Int- , arrowY :: !Int- } deriving (Show, Eq)---- | Helper function to convert keys currently pressed to `Arrow`, given a--- mapping for keys representing up, down, left and right respectively.-toArrows :: ([Int], [Int], [Int], [Int]) -> Set Int -> Arrows-toArrows (up, down, left, right) set' =-  Arrows {-    arrowX =-      case (check left, check right) of-        (True, False) -> -1-        (False, True) -> 1-        (_,_) -> 0-  , arrowY =-      case (check down, check up) of-        (True, False) -> -1-        (False, True) -> 1-        (_,_) -> 0-  }-  where-    check = any (`S.member` set')---- | Maps `Arrows` onto a Keyboard subscription-arrowsSub :: (Arrows -> action) -> Sub action-arrowsSub = directionSub ([38], [40], [37], [39])---- | Maps `WASD` onto a Keyboard subscription for directions-wasdSub :: (Arrows -> action) -> Sub action-wasdSub = directionSub ([87], [83], [65], [68])---- | Maps a specified list of keys to directions (up, down, left, right)-directionSub :: ([Int], [Int], [Int], [Int])-             -> (Arrows -> action)-             -> Sub action-directionSub dirs = keyboardSub . (. toArrows dirs)---- | Returns subscription for Keyboard-keyboardSub :: (Set Int -> action) -> Sub action-keyboardSub f sink = do-  keySetRef <- liftIO (newIORef mempty)-  windowAddEventListener "keyup" $ keyUpCallback keySetRef-  windowAddEventListener "keydown" $ keyDownCallback keySetRef-  windowAddEventListener "blur" $ blurCallback keySetRef-    where-      keyDownCallback keySetRef = \keyDownEvent -> do-          Just key <- fromJSVal =<< getProp "keyCode" (Object keyDownEvent)-          newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \keys ->-             let !new = S.insert key keys-             in (new, new)-          liftIO (sink (f newKeys))--      keyUpCallback keySetRef = \keyUpEvent -> do-          Just key <- fromJSVal =<< getProp "keyCode" (Object keyUpEvent)-          newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \keys ->-             let !new = S.delete key keys-             in (new, new)-          liftIO (sink (f newKeys))--      -- Assume keys are released the moment focus is lost. Otherwise going-      -- back and forth to the app can cause keys to get stuck.-      blurCallback keySetRef = \_ -> do-          newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \_ ->-            let !new = S.empty-            in (new, new)-          liftIO (sink (f newKeys))

@@ -1,30 +0,0 @@-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.Subscription.Mouse--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Subscription.Mouse (mouseSub) where--import Control.Monad.IO.Class-import GHCJS.Marshal-import JavaScript.Object-import JavaScript.Object.Internal--import Miso.FFI-import Miso.Html.Internal ( Sub )---- | Captures mouse coordinates as they occur and writes them to--- an event sink-mouseSub :: ((Int,Int) -> action) -> Sub action-mouseSub f = \sink -> do-  windowAddEventListener "mousemove" $-    \mouseEvent -> do-      Just x <- fromJSVal =<< getProp "clientX" (Object mouseEvent)-      Just y <- fromJSVal =<< getProp "clientY" (Object mouseEvent)-      liftIO (sink $ f (x,y))

@@ -1,49 +0,0 @@-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.Subscription.SSE--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Subscription.SSE- ( -- * Subscription-   sseSub-   -- * Types- , SSE (..)- ) where--import           Control.Monad.IO.Class-import           Data.Aeson-import           Miso.FFI-import           Miso.Html.Internal ( Sub )-import           Miso.String--import qualified Miso.FFI.SSE as SSE---- | Server-sent events Subscription-sseSub :: FromJSON msg => MisoString -> (SSE msg -> action) -> Sub action-sseSub url f = \sink -> do-  es <- SSE.new url-  SSE.addEventListener es "message" $ \val -> do-    dat <- parse =<< SSE.data' val-    (liftIO . sink) (f (SSEMessage dat))-  SSE.addEventListener es "error" $ \_ ->-    (liftIO . sink) (f SSEError)-  SSE.addEventListener es "close" $ \_ ->-    (liftIO . sink) (f SSEClose)---- | Server-sent events data-data SSE message-  = SSEMessage message-  | SSEClose-  | SSEError-  deriving (Show, Eq)---- | Test URL--- http://sapid.sourceforge.net/ssetest/webkit.events.php--- var source = new EventSource("demo_sse.php");

@@ -1,167 +0,0 @@-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP                        #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.Subscription.WebSocket--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Subscription.WebSocket-  ( -- * Types-    WebSocket   (..)-  , URL         (..)-  , Protocols   (..)-  , SocketState (..)-  , CloseCode   (..)-  , WasClean    (..)-  , Reason      (..)-    -- * Subscription-  , websocketSub-  , send-  , close-  , connect-  , getSocketState-  ) where--import           Control.Concurrent-import           Control.Monad-import           Control.Monad.IO.Class-import           Data.Aeson-import           Data.IORef-import           Data.Maybe-import           GHCJS.Marshal-import           GHCJS.Foreign-import           GHCJS.Types-import           Prelude hiding (map)-import           System.IO.Unsafe--import           Miso.FFI-import           Miso.FFI.WebSocket (Socket)-import qualified Miso.FFI.WebSocket as WS-import           Miso.Html.Internal ( Sub )-import           Miso.WebSocket--websocket :: IORef (Maybe Socket)-{-# NOINLINE websocket #-}-websocket = unsafePerformIO (newIORef Nothing)--closedCode :: IORef (Maybe CloseCode)-{-# NOINLINE closedCode #-}-closedCode = unsafePerformIO (newIORef Nothing)--secs :: Int -> Int-secs = (*1000000)---- | WebSocket subscription-websocketSub-  :: FromJSON m-  => URL-  -> Protocols-  -> (WebSocket m -> action)-  -> Sub action-websocketSub (URL u) (Protocols ps) f sink = do-  socket <- createWebSocket u ps-  liftIO (writeIORef websocket (Just socket))-  void . forkJSM $ handleReconnect-  WS.addEventListener socket "open" $ \_ -> liftIO $ do-    writeIORef closedCode Nothing-    sink (f WebSocketOpen)-  WS.addEventListener socket "message" $ \v -> do-    d <- parse =<< WS.data' v-    liftIO . sink $ f (WebSocketMessage d)-  WS.addEventListener socket "close" $ \e -> do-    code <- codeToCloseCode <$> WS.code e-    liftIO (writeIORef closedCode (Just code))-    reason <- WS.reason e-    clean <- WS.wasClean e-    liftIO . sink $ f (WebSocketClose code clean reason)-  WS.addEventListener socket "error" $ \v -> do-    liftIO (writeIORef closedCode Nothing)-    d' <- WS.data' v-#ifndef __GHCJS__        -    undef <- ghcjsPure (isUndefined d')-#else-    let undef = isUndefined d'-#endif-    if undef-      then do-         liftIO . sink $ f (WebSocketError mempty)-      else do-         Just d <- fromJSVal d'-         liftIO . sink $ f (WebSocketError d)-  where-    handleReconnect = do-      liftIO (threadDelay (secs 3))-      Just s <- liftIO (readIORef websocket)-      status <- WS.socketState s-      code <- liftIO (readIORef closedCode)-      if status == 3-        then do-          unless (code == Just CLOSE_NORMAL) $-            websocketSub (URL u) (Protocols ps) f sink-        else handleReconnect---- | Sends message to a websocket server-send :: ToJSON a => a -> JSM ()-{-# INLINE send #-}-send x = do-  Just socket <- liftIO (readIORef websocket)-  sendJson' socket x---- | Sends message to a websocket server-close :: JSM ()-{-# INLINE close #-}-close =-  mapM_ WS.close =<<-    liftIO (readIORef websocket)---- | Connects to a websocket server-connect :: URL -> Protocols -> JSM ()-{-# INLINE connect #-}-connect (URL url') (Protocols ps) = do-  Just ws <- liftIO (readIORef websocket)-  s <- WS.socketState ws-  when (s == 3) $ do-    socket <- createWebSocket url' ps-    liftIO (atomicWriteIORef websocket (Just socket))---- | Retrieves current status of `WebSocket`-getSocketState :: JSM SocketState-getSocketState = do-  Just ws <- liftIO (readIORef websocket)-  toEnum <$> WS.socketState ws--sendJson' :: ToJSON json => Socket -> json -> JSM ()-sendJson' socket m = WS.send socket =<< stringify m--createWebSocket :: JSString -> [JSString] -> JSM Socket-{-# INLINE createWebSocket #-}-createWebSocket url' protocols =-  WS.create url' =<< toJSVal protocols--codeToCloseCode :: Int -> CloseCode-codeToCloseCode = go-  where-    go 1000 = CLOSE_NORMAL-    go 1001 = CLOSE_GOING_AWAY-    go 1002 = CLOSE_PROTOCOL_ERROR-    go 1003 = CLOSE_UNSUPPORTED-    go 1005 = CLOSE_NO_STATUS-    go 1006 = CLOSE_ABNORMAL-    go 1007 = Unsupported_Data-    go 1008 = Policy_Violation-    go 1009 = CLOSE_TOO_LARGE-    go 1010 = Missing_Extension-    go 1011 = Internal_Error-    go 1012 = Service_Restart-    go 1013 = Try_Again_Later-    go 1015 = TLS_Handshake-    go n    = OtherCode n

@@ -1,56 +0,0 @@-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.Subscription.Window--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Subscription.Window where--import Control.Monad-import Control.Monad.IO.Class--import GHCJS.Marshal-import JavaScript.Object-import JavaScript.Object.Internal--import Miso.Event-import Miso.FFI-import Miso.Html.Internal         ( Sub )-import Miso.String--import Data.Aeson.Types (parseEither)---- | Captures window coordinates changes as they occur and writes them to--- an event sink-windowCoordsSub :: ((Int, Int) -> action) -> Sub action-windowCoordsSub f = \sink -> do-  liftIO . sink . f =<< (,) <$> windowInnerHeight <*> windowInnerWidth-  windowAddEventListener "resize" $-    \windowEvent -> do-      target <- getProp "target" (Object windowEvent)-      Just w <- fromJSVal =<< getProp "innerWidth" (Object target)-      Just h <- fromJSVal =<< getProp "innerHeight" (Object target)-      liftIO . sink $ f (h, w)---- | @windowOn eventName decoder toAction@ is a subscription which parallels the--- attribute handler `on`, providing a subscription to listen to window level events.-windowSub :: MisoString -> Decoder r -> (r -> action) -> Sub action-windowSub  = windowSubWithOptions defaultOptions--windowSubWithOptions :: Options -> MisoString -> Decoder r -> (r -> action) -> Sub action-windowSubWithOptions Options{..} eventName Decoder{..} toAction = \sink -> do-  windowAddEventListener eventName $-    \e -> do-      decodeAtVal <- toJSVal decodeAt-      Just v <- fromJSVal =<< objectToJSON decodeAtVal e-      case parseEither decoder v of-        Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s-        Right r -> do-          when stopPropagation $ eventStopPropagation e-          when preventDefault $ eventPreventDefault e-          liftIO (sink (toAction r))

@@ -1,149 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.Types--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Types-  ( App (..)-  , LogLevel (..)-  , Effect-  , Sub--    -- * The Transition Monad-  , Transition-  , mapAction-  , fromTransition-  , toTransition-  , scheduleIO-  , scheduleIO_-  , scheduleIOFor_-  , scheduleSub-  ) where--import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class (lift)-import           Control.Monad.Trans.State.Strict (StateT(StateT), execStateT, mapStateT)-import           Control.Monad.Trans.Writer.Strict (WriterT(WriterT), Writer, runWriter, tell, mapWriter)-import           Data.Bifunctor (second)-import           Data.Foldable (Foldable, for_)-import qualified Data.Map as M-import           Miso.Effect-import           Miso.FFI (JSM)-import           Miso.Html.Internal-import           Miso.String---- | Application entry point-data App model action = App-  { model :: model-  -- ^ initial model-  , update :: action -> model -> Effect action model-  -- ^ Function to update model, optionally providing effects.-  --   See the 'Transition' monad for succinctly expressing model transitions.-  , view :: model -> View action-  -- ^ Function to draw `View`-  , subs :: [ Sub action ]-  -- ^ List of subscriptions to run during application lifetime-  , events :: M.Map MisoString Bool-  -- ^ List of delegated events that the body element will listen for.-  --   You can start with 'Miso.Event.Types.defaultEvents' and modify as needed.-  , initialAction :: action-  -- ^ Initial action that is run after the application has loaded-  , mountPoint :: Maybe MisoString-  -- ^ Id of the root element for DOM diff. If 'Nothing' is provided, the entire document body is used as a mount point.-  , logLevel :: LogLevel-  -- ^ Display warning messages when prerendering if the DOM and VDOM are not in sync.-  }---- | Optional Logging for debugging miso internals (useful to see if prerendering is successful)-data LogLevel-  = Off-  | DebugPrerender-  deriving (Show, Eq)---- | A monad for succinctly expressing model transitions in the 'update' function.------ @Transition@ is a state monad so it abstracts over manually passing the model--- around. It's also a writer monad where the accumulator is a list of scheduled--- IO actions. Multiple actions can be scheduled using--- @Control.Monad.Writer.Class.tell@ from the @mtl@ library and a single action--- can be scheduled using 'scheduleIO'.------ Tip: use the @Transition@ monad in combination with the stateful--- <http://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Operators.html lens>--- operators (all operators ending in "@=@"). The following example assumes--- the lenses @field1@, @counter@ and @field2@ are in scope and that the--- @LambdaCase@ language extension is enabled:------ @--- myApp = App---   { update = 'fromTransition' . \\case---       MyAction1 -> do---         field1 .= value1---         counter += 1---       MyAction2 -> do---         field2 %= f---         scheduleIO $ do---           putStrLn \"Hello\"---           putStrLn \"World!\"---   , ...---   }--- @-type Transition action model = StateT model (Writer [Sub action])---- | Turn a transition that schedules subscriptions that consume--- actions of type @a@ into a transition that schedules subscriptions--- that consume actions of type @b@ using the supplied function of--- type @a -> b@.-mapAction :: (actionA -> actionB) -> Transition actionA model r -> Transition actionB model r-mapAction = mapStateT . mapWriter . second . fmap . mapSub---- | Convert a @Transition@ computation to a function that can be given to 'update'.-fromTransition-    :: Transition action model ()-    -> (model -> Effect action model) -- ^ model 'update' function.-fromTransition act = uncurry Effect . runWriter . execStateT act---- | Convert an 'update' function to a @Transition@ computation.-toTransition-    :: (model -> Effect action model) -- ^ model 'update' function-    -> Transition action model ()-toTransition f = StateT $ \s ->-                   let Effect s' ios = f s-                   in WriterT $ pure (((), s'), ios)---- | Schedule a single IO action for later execution.------ Note that multiple IO action can be scheduled using--- @Control.Monad.Writer.Class.tell@ from the @mtl@ library.-scheduleIO :: JSM action -> Transition action model ()-scheduleIO ioAction = scheduleSub $ \sink -> ioAction >>= liftIO . sink---- | Like 'scheduleIO' but doesn't cause an action to be dispatched to--- the 'update' function.------ This is handy for scheduling IO computations where you don't care--- about their results or when they complete.-scheduleIO_ :: JSM () -> Transition action model ()-scheduleIO_ ioAction = scheduleSub $ \_sink -> ioAction---- | Like `scheduleIO_` but generalized to any instance of `Foldable`------ This is handy for scheduling IO computations that return a `Maybe` value-scheduleIOFor_ :: Foldable f => JSM (f action) -> Transition action model ()-scheduleIOFor_ io = scheduleSub $ \sink -> io >>= \m -> liftIO (for_ m sink)---- | Like 'scheduleIO' but schedules a subscription which is an IO--- computation that has access to a 'Sink' which can be used to--- asynchronously dispatch actions to the 'update' function.------ A use-case is scheduling an IO computation which creates a--- 3rd-party JS widget which has an associated callback. The callback--- can then call the sink to turn events into actions. To do this--- without accessing a sink requires going via a @'Sub'scription@--- which introduces a leaky-abstraction.-scheduleSub :: Sub action -> Transition action model ()-scheduleSub sub = lift $ tell [ sub ]

@@ -1,29 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE KindSignatures      #-}--------------------------------------------------------------------------------- |--- Module      :  Miso--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso-  ( module Miso.Event-  , module Miso.Html-  , module Miso.Router-  , module Miso.TypeLevel-  , module Miso.Util-  , module Miso.WebSocket-  ) where--import           Miso.Event-import           Miso.Html-import           Miso.Router-import           Miso.TypeLevel-import           Miso.Util-import           Miso.WebSocket

@@ -1,303 +0,0 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE DeriveFunctor        #-}-{-# LANGUAGE KindSignatures       #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE RankNTypes           #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.Html.Internal--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Html.Internal (-  -- * Core types and interface-    VTree  (..)-  , View   (..)-  , ToView (..)-  , Attribute (..)-  -- * Smart `View` constructors-  , node-  , text-  , textRaw-  -- * Key patch internals-  , Key    (..)-  , ToKey  (..)-  -- * Namespace-  , NS     (..)-  -- * Setting properties on virtual DOM nodes-  , prop-  -- * Setting CSS-  , style_-  -- * Handling events-  , on-  , onWithOptions-  -- * Life cycle events-  , onCreated-  , onDestroyed-  , onBeforeDestroyed-  ) where--import           Data.Aeson  (Value(..), ToJSON(..))-import qualified Data.Map    as M-import           Data.Proxy-import           Data.String (IsString(..))-import qualified Data.Text   as T-import qualified Data.Vector as V-import qualified Lucid       as L-import qualified Lucid.Base  as L-import           Prelude     hiding (null)-import           Servant.API--import           Miso.Event-import           Miso.String hiding (map)---- | Virtual DOM implemented as a Rose `Vector`.---   Used for diffing, patching and event delegation.---   Not meant to be constructed directly, see `View` instead.-data VTree action where-  VNode :: { vType :: Text -- ^ Element type (i.e. "div", "a", "p")-           , vNs :: NS -- ^ HTML or SVG-           , vProps :: Props -- ^ Fields present on DOM Node-           , vKey :: Maybe Key -- ^ Key used for child swap patch-           , vChildren :: V.Vector (VTree action) -- ^ Child nodes-           } -> VTree action-  VText :: { vText :: Text -- ^ TextNode content-           } -> VTree action-  -- Invariant: To avoid complexity with collapsing mixed VText and-  -- VTextRaw nodes, VTextRaw node is always the only child.-  -- That's not a big limitation, since the intended purpose is to be able-  -- to use <style> and <script> tags. That means we can't support HTML-  -- entities like &nbsp; with VTextRaw, but the same can be achieved with-  -- Unicode.-  VTextRaw :: { vText :: Text -- ^ Raw TextNode content-              } -> VTree action-  deriving Functor--instance Show (VTree action) where-  show = show . L.toHtml---- | Converting `VTree` to Lucid's `L.Html`-instance L.ToHtml (VTree action) where-  toHtmlRaw = L.toHtml-  toHtml (VText x) | T.null x = L.toHtml (" " :: MisoString)-                   | otherwise = L.toHtml x-  toHtml (VTextRaw x) | T.null x = L.toHtml (" " :: MisoString)-                      | otherwise = L.toHtmlRaw x-  toHtml VNode{..} =-    let-      noEnd = ["img", "input", "br", "hr", "meta"]-      tag = toTag vType-      ele =-          if tag `elem` noEnd-            then L.makeElementNoEnd tag-            else L.makeElement tag kids-    in L.with ele as-      where-        Props xs = vProps-        as = [ L.makeAttribute k (if k `elem` exceptions && v == Bool True then k else v')-             | (k,v) <- M.toList xs-             , let v' = toHtmlFromJSON v-             , not (k `elem` exceptions && v == Bool False)-             ]-        exceptions = [ "checked"-                     , "disabled"-                     , "selected"-                     , "hidden"-                     , "readOnly"-                     , "autoplay"-                     , "required"-                     , "default"-                     , "autofocus"-                     , "multiple"-                     , "noValidate"-                     , "autocomplete"-                     ]-        toTag = T.toLower-        kids-          = foldMap L.toHtml-          . V.fromList-          . collapseSiblingTextNodes-          . V.toList-          $ vChildren--collapseSiblingTextNodes :: [VTree a] -> [VTree a]-collapseSiblingTextNodes [] = []-collapseSiblingTextNodes (VText x : VText y : xs) =-  collapseSiblingTextNodes (VText (x <> y) : xs)--- VTextRaw is the only child, so no need to collapse.-collapseSiblingTextNodes (x:xs) =-  x : collapseSiblingTextNodes xs---- | Helper for turning JSON into Text--- Object, Array and Null are kind of non-sensical here-toHtmlFromJSON :: Value -> Text-toHtmlFromJSON (String t) = t-toHtmlFromJSON (Number t) = pack (show t)-toHtmlFromJSON (Bool b) = if b then "true" else "false"-toHtmlFromJSON Null = "null"-toHtmlFromJSON (Object o) = pack (show o)-toHtmlFromJSON (Array a) = pack (show a)---- | Core type for constructing a `VTree`, use this instead of `VTree` directly.-newtype View action = View { runView :: VTree action }-  deriving Functor---- | For constructing type-safe links-instance HasLink (View a) where-#if MIN_VERSION_servant(0,14,0)-  type MkLink (View a) b = MkLink (Get '[] ()) b-  toLink toA Proxy = toLink toA (Proxy :: Proxy (Get '[] ()))-#else-  type MkLink (View a) = MkLink (Get '[] ())-  toLink Proxy = toLink (Proxy :: Proxy (Get '[] ()))-#endif----- | Convenience class for using View-class ToView v where toView :: v -> View action---- | Show `View`-instance Show (View action) where-  show (View xs) = show xs---- | Converting `View` to Lucid's `L.Html`-instance L.ToHtml (View action) where-  toHtmlRaw = L.toHtml-  toHtml (View xs) = L.toHtml xs---- | Namespace for element creation-data NS-  = HTML -- ^ HTML Namespace-  | SVG  -- ^ SVG Namespace-  | MATHML  -- ^ MATHML Namespace-  deriving (Show, Eq)---- | `VNode` creation-node :: NS -> MisoString -> Maybe Key -> [Attribute action] -> [View action] -> View action-node vNs vType vKey as xs =-  let classes = intercalate " " [ v | P "class" (String v) <- as ]-      vProps  = Props $ do-        let propClass = M.fromList [ (k,v) | P k v <- as ]-        if not (null classes)-          then M.insert "class" (String classes) propClass-          else propClass-      vChildren = V.fromList $ map runView xs-  in View VNode {..}---- | `VText` creation-text :: MisoString -> View action-text = View . VText---- | `VTextRaw` creation. Don't use directly-textRaw :: MisoString -> View action-textRaw = View . VTextRaw---- | `IsString` instance-instance IsString (View a) where-  fromString = text . fromString---- | Key for specific children patch-newtype Key = Key MisoString-  deriving (Show, Eq, Ord, IsString)---- | Convert type into Key, ensure `Key` is unique-class ToKey key where toKey :: key -> Key--- | Identity instance-instance ToKey Key    where toKey = id--- | Convert `Text` to `Key`-instance ToKey MisoString where toKey = Key--- | Convert `String` to `Key`-instance ToKey String where toKey = Key . T.pack--- | Convert `Int` to `Key`-instance ToKey Int    where toKey = Key . T.pack . show--- | Convert `Double` to `Key`-instance ToKey Double where toKey = Key . T.pack . show--- | Convert `Float` to `Key`-instance ToKey Float  where toKey = Key . T.pack . show--- | Convert `Word` to `Key`-instance ToKey Word   where toKey = Key . T.pack . show---- | Properties-newtype Props = Props (M.Map MisoString Value)-  deriving (Show, Eq)---- | `View` Attributes to annotate DOM, converted into Events, Props, Attrs and CSS-data Attribute action-  = P MisoString Value-  | E ()-  deriving (Show, Eq)---- | DMJ: this used to get set on preventDefault on Options... if options are dynamic now what--- | Useful for `drop` events-newtype AllowDrop = AllowDrop Bool-  deriving (Show, Eq)---- | Constructs a property on a `VNode`, used to set fields on a DOM Node-prop :: ToJSON a => MisoString -> a -> Attribute action-prop k v = P k (toJSON v)---- | For defining delegated events------ > let clickHandler = on "click" emptyDecoder $ \() -> Action--- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ]----on :: MisoString-   -> Decoder r-   -> (r -> action)-   -> Attribute action-on _ _ _ = E ()---- | For defining delegated events with options------ > let clickHandler = onWithOptions defaultOptions "click" emptyDecoder $ \() -> Action--- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ]----onWithOptions-   :: Options-   -> MisoString-   -> Decoder r-   -> (r -> action)-   -> Attribute action-onWithOptions _ _ _ _ = E ()---- | @onCreated action@ is an event that gets called after the actual DOM--- element is created.-onCreated :: action -> Attribute action-onCreated _ = E ()---- | @onDestroyed action@ is an event that gets called after the DOM element--- is removed from the DOM. The @action@ is given the DOM element that was--- removed from the DOM tree.-onDestroyed :: action -> Attribute action-onDestroyed _ = E ()---- | @onBeforeDestroyed action@ is an event that gets called before the DOM element--- is removed from the DOM. The @action@ is given the DOM element that was--- removed from the DOM tree.-onBeforeDestroyed :: action -> Attribute action-onBeforeDestroyed _ = E ()---- | Constructs CSS for a DOM Element------ > import qualified Data.Map as M--- > div_ [ style_  $ M.singleton "background" "red" ] [ ]------ <https://developer.mozilla.org/en-US/docs/Web/CSS>----style_ :: M.Map MisoString MisoString -> Attribute action-style_ map' = P "style" $ String (M.foldrWithKey go mempty map')-  where-    go :: MisoString -> MisoString -> MisoString -> MisoString-    go k v xs = mconcat [ k, ":", v, ";" ] <> xs

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -23,6 +24,8 @@ import qualified Data.ByteString         as B import qualified Data.ByteString.Lazy    as BL import           Data.Monoid+import           Data.JSString+import           Data.JSString.Text import           Data.Text import qualified Data.Text               as T import qualified Data.Text.Encoding      as T@@ -38,11 +41,12 @@ class ToMisoString str where   toMisoString :: str -> MisoString +-- | Class from safely parsing 'MisoString' class FromMisoString t where-  -- -- | Reads a `MisoString` into an 'a', throws an error when+  -- -- | Parses a `MisoString`   fromMisoStringEither :: MisoString -> Either String t --- | Reads a `MisoString` into an 'a', throws an error when decoding+-- | Parses a `MisoString`, throws an error when decoding -- fails. Use `fromMisoStringEither` for as a safe alternative. fromMisoString :: FromMisoString a => MisoString -> a fromMisoString s = case fromMisoStringEither s of@@ -59,6 +63,8 @@   toMisoString = T.pack instance ToMisoString LT.Text where   toMisoString = LT.toStrict+instance ToMisoString JSString where+  toMisoString = textFromJSString instance ToMisoString B.ByteString where   toMisoString = toMisoString . T.decodeUtf8 instance ToMisoString BL.ByteString where@@ -78,6 +84,8 @@   fromMisoStringEither = Right . T.unpack instance FromMisoString LT.Text where   fromMisoStringEither = Right . LT.fromStrict+instance FromMisoString JSString where+  fromMisoStringEither = Right . textToJSString instance FromMisoString B.ByteString where   fromMisoStringEither = fmap T.encodeUtf8 . fromMisoStringEither instance FromMisoString BL.ByteString where

@@ -1,19 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-module Miso.TypeLevel ( ToServerRoutes ) where--import Miso.Html-import Servant.API-import Servant.HTML.Lucid---- | Convert client route type to a server web handler type-type family ToServerRoutes (layout :: k) (wrapper :: * -> *) (action :: *) :: k where-  ToServerRoutes (a :<|> b) wrapper action =-    ToServerRoutes a wrapper action :<|>-      ToServerRoutes b wrapper action-  ToServerRoutes (a :> b) wrapper action =-    a :> ToServerRoutes b wrapper action-  ToServerRoutes (View a) wrapper action =-    Get '[HTML] (wrapper (View action))

@@ -1,286 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.FFI--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.FFI-   ( JSM-   , forkJSM-   , asyncCallback-   , asyncCallback1-   , callbackToJSVal-   , objectToJSVal-   , ghcjsPure-   , syncPoint--   , addEventListener-   , windowAddEventListener--   , windowInnerHeight-   , windowInnerWidth--   , eventPreventDefault-   , eventStopPropagation--   , now-   , consoleLog-   , consoleLogJSVal-   , stringify-   , parse-   , clearBody-   , objectToJSON-   , set-   , getBody-   , getDoc-   , getElementById-   , diff'--   , integralToJSString-   , realFloatToJSString-   , jsStringToDouble--   , delegateEvent--   , copyDOMIntoVTree--   , swapCallbacks-   , releaseCallbacks-   , registerCallback--   , focus-   , blur-   , scrollIntoView-   , alert-   ) where--import           Control.Concurrent-import           Data.Aeson                 hiding (Object)-import           Data.JSString-import           Data.JSString.Int-import           Data.JSString.RealFloat-import           GHCJS.Foreign.Callback-import           GHCJS.Marshal-import           GHCJS.Types-import qualified JavaScript.Object.Internal as OI---- | When compiled without the `jsaddle` Cabal flag, this is just a--- type synonym for `IO`. When the `jsaddle` flag is enabled, this--- resolves to the `JSM` type defined in `jsaddle`.-type JSM = IO---- | Run given `JSM` action asynchronously, in a separate thread.-forkJSM :: JSM () -> JSM ()-forkJSM a = () <$ forkIO a--callbackToJSVal :: Callback a -> JSM JSVal-callbackToJSVal = pure . jsval--objectToJSVal :: OI.Object -> JSM JSVal-objectToJSVal = pure . jsval--ghcjsPure :: a -> JSM a-ghcjsPure = pure---- | Forces execution of pending asyncronous code-syncPoint :: JSM ()-syncPoint = pure ()---- | Set property on object-set :: ToJSVal v => JSString -> v -> OI.Object -> IO ()-set "class" v obj = toJSVal v >>= appendClass obj-set k v obj = toJSVal v >>= \x -> OI.setProp k x obj---- | Only used for 'class', guaranteed to be a MisoString-foreign import javascript unsafe "if ('class' in $1) { $1['class'] += ' ' + $2; } else { $1['class'] = $2; }"-  appendClass :: OI.Object -> JSVal -> IO ()--foreign import javascript unsafe "$1.addEventListener($2, $3);"-  addEventListener' :: JSVal -> JSString -> Callback (JSVal -> IO ()) -> IO ()---- | Register an event listener on given target.-addEventListener :: JSVal            -- ^ Event target on which we want to register event listener-                 -> JSString         -- ^ Type of event to listen to (e.g. "click")-                 -> (JSVal -> IO ()) -- ^ Callback which will be called when the event occurs. The event is passed as a parameter to it.-                 -> IO ()-addEventListener self name cb = addEventListener' self name =<< asyncCallback1 cb---- | Registers an event listener on window-windowAddEventListener :: JSString           -- ^ Type of event to listen to (e.g. "click")-                       -> (JSVal -> IO ())  -- ^ Callback which will be called when the event occurs, the event will be passed to it as a parameter.-                       -> IO ()-windowAddEventListener name cb = do-  win <- getWindow-  addEventListener win name cb--foreign import javascript unsafe "$1.stopPropagation();"-    eventStopPropagation :: JSVal -> IO ()--foreign import javascript unsafe "$1.preventDefault();"-    eventPreventDefault :: JSVal -> IO ()---- | Window object-foreign import javascript unsafe "$r = window;"-  getWindow :: IO JSVal----- | Retrieves the height (in pixels) of the browser window viewport including, if rendered, the horizontal scrollbar.------ See <https://developer.mozilla.org/en-US/docs/Web/API/Window/innerHeight>-foreign import javascript unsafe "$r = window['innerHeight'];"-  windowInnerHeight :: IO Int---- | Retrieves the width (in pixels) of the browser window viewport including, if rendered, the vertical scrollbar.------ See <https://developer.mozilla.org/en-US/docs/Web/API/Window/innerWidth>-foreign import javascript unsafe "$r = window['innerWidth'];"-  windowInnerWidth :: IO Int---- | Retrieve high resolution time stamp------ See <https://developer.mozilla.org/en-US/docs/Web/API/Performance/now>-foreign import javascript unsafe "$r = performance.now();"-  now :: IO Double---- | Outputs a message to the web console------ See <https://developer.mozilla.org/en-US/docs/Web/API/Console/log>-foreign import javascript unsafe "console.log($1);"-  consoleLog :: JSString -> IO ()--foreign import javascript unsafe "console.log($1);"-  consoleLogJSVal :: JSVal -> IO ()---- | Converts a JS object into a JSON string-foreign import javascript unsafe "$r = JSON.stringify($1);"-  stringify' :: JSVal -> IO JSString--foreign import javascript unsafe "$r = JSON.parse($1);"-  parse' :: JSVal -> IO JSVal---- | Converts a JS object into a JSON string-stringify :: ToJSON json => json -> IO JSString-{-# INLINE stringify #-}-stringify j = stringify' =<< toJSVal (toJSON j)---- | Parses a JSString-parse :: FromJSON json => JSVal -> IO json-{-# INLINE parse #-}-parse jval = do-  k <- parse' jval-  Just val <- fromJSVal k-  case fromJSON val of-    Success x -> pure x-    Error y -> error y---- | Clear the document body. This is particularly useful to avoid--- creating multiple copies of your app when running in GHCJSi.-foreign import javascript unsafe "document.body.innerHTML = '';"-  clearBody :: IO ()---foreign import javascript unsafe "$r = window['objectToJSON']($1,$2);"-  objectToJSON-    :: JSVal -- ^ decodeAt :: [JSString]-    -> JSVal -- ^ object with impure references to the DOM-    -> IO JSVal---- | Retrieves a reference to the document body.------ See <https://developer.mozilla.org/en-US/docs/Web/API/Document/body>-foreign import javascript unsafe "$r = document.body;"-  getBody :: IO JSVal---- | Retrieves a reference to the document.------ See <https://developer.mozilla.org/en-US/docs/Web/API/Document>-foreign import javascript unsafe "$r = document;"-  getDoc :: IO JSVal---- | Returns an Element object representing the element whose id property matches the specified string.------ See <https://developer.mozilla.org/en-US/docs/Web/API/Document/getElementById>-foreign import javascript unsafe "$r = document.getElementById($1);"-  getElementById :: JSString -> IO JSVal--foreign import javascript unsafe "diff($1, $2, $3, $4);"-  diff'-    :: OI.Object -- ^ current object-    -> OI.Object -- ^ new object-    -> JSVal  -- ^ parent node-    -> JSVal  -- ^ document-    -> IO ()--integralToJSString :: Integral a => a -> JSString-integralToJSString = decimal--realFloatToJSString :: RealFloat a => a -> JSString-realFloatToJSString = realFloat--foreign import javascript unsafe "$r = Number($1);"-  jsStringToDouble :: JSString -> Double--delegateEvent :: JSVal -> JSVal -> IO JSVal -> IO ()-delegateEvent mountPoint events getVTree = do-  cb' <- syncCallback1 ThrowWouldBlock $ \continuation -> do-    res <- getVTree-    callFunction continuation res-  delegateEvent' mountPoint events cb'--foreign import javascript unsafe "window['delegate']($1, $2, $3);"-  delegateEvent'-     :: JSVal               -- ^ mountPoint element-     -> JSVal               -- ^ Events-     -> Callback (JSVal -> IO ()) -- ^ Virtual DOM callback-     -> IO ()--foreign import javascript unsafe "$1($2);"-  callFunction :: JSVal -> JSVal -> IO ()---- | Copies DOM pointers into virtual dom--- entry point into isomorphic javascript-foreign import javascript unsafe "window['copyDOMIntoVTree']($1, $2, $3);"-  copyDOMIntoVTree-    :: Bool  -- ^ Display debugging information when pre-rendering-    -> JSVal -- ^ mountPoint element of the isomorphic app-    -> JSVal -- ^ VDom object-    -> IO ()---- | Pins down the current callbacks for clearing later-foreign import javascript unsafe "window['swapCallbacks']();"-  swapCallbacks :: IO ()---- | Releases callbacks registered by the virtual DOM.-foreign import javascript unsafe "window['releaseCallbacks']();"-  releaseCallbacks :: IO ()--foreign import javascript unsafe "window['registerCallback']($1);"-  registerCallback :: JSVal -> IO ()---- | Fails silently if the element is not found.------ Analogous to @document.getElementById(id).focus()@.-foreign import javascript unsafe "window['callFocus']($1);"-  focus :: JSString -> JSM ()---- | Fails silently if the element is not found.------ Analogous to @document.getElementById(id).blur()@-foreign import javascript unsafe "window['callBlur']($1);"-  blur :: JSString -> JSM ()---- | Calls @document.getElementById(id).scrollIntoView()@-foreign import javascript unsafe-  "document.getElementById($1)['scrollIntoView']();"-  scrollIntoView :: JSString -> IO ()---- | Calls the @alert()@ function.-foreign import javascript unsafe "alert($1);"-  alert :: JSString -> JSM ()

@@ -1,37 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.FFI.History--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.FFI.History-  ( getWindowLocationHref-  , go-  , back-  , forward-  , pushState-  , replaceState-  ) where--import GHCJS.Types--foreign import javascript safe "$r = window.location.href || '';"-  getWindowLocationHref :: IO JSString--foreign import javascript unsafe "window.history.go($1);"-  go :: Int -> IO ()--foreign import javascript unsafe "window.history.back();"-  back :: IO ()--foreign import javascript unsafe "window.history.forward();"-  forward :: IO ()--foreign import javascript unsafe "window.history.pushState(null, null, $1);"-  pushState :: JSString -> IO ()--foreign import javascript unsafe "window.history.replaceState(null, null, $1);"-  replaceState :: JSString -> IO ()

@@ -1,34 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.FFI.SSE--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.FFI.SSE-  ( EventSource(..)-  , data'-  , new-  , addEventListener-  ) where--import           GHCJS.Types--import qualified Miso.FFI as FFI--newtype EventSource = EventSource JSVal--foreign import javascript unsafe "$r = $1.data;"-  data' :: JSVal -> IO JSVal--foreign import javascript unsafe "$r = new EventSource($1);"-  new :: JSString -> IO EventSource--addEventListener :: EventSource -> JSString -> (JSVal -> IO ()) -> IO ()-addEventListener (EventSource s) = FFI.addEventListener s

@@ -1,45 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.FFI.Storage--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.FFI.Storage-  ( Storage-  , localStorage-  , sessionStorage-  , getItem-  , removeItem-  , setItem-  , length-  , clear-  ) where--import GHCJS.Types-import Prelude hiding (length)--newtype Storage = Storage JSVal--foreign import javascript unsafe "$r = window.localStorage"-  localStorage :: IO Storage--foreign import javascript unsafe "$r = window.sessionStorage"-  sessionStorage :: IO Storage--foreign import javascript unsafe "$r = $1.getItem($2);"-  getItem :: Storage -> JSString -> IO JSVal--foreign import javascript unsafe "$1.removeItem($2);"-  removeItem :: Storage -> JSString -> IO ()--foreign import javascript unsafe "$1.setItem($2, $3);"-  setItem :: Storage -> JSString -> JSString -> IO ()--foreign import javascript unsafe "$r = $1.length;"-  length :: Storage -> IO Int--foreign import javascript unsafe "$1.clear();"-  clear :: Storage -> IO ()

@@ -1,59 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.FFI.WebSocket--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.FFI.WebSocket-  ( Socket(..)-  , create-  , socketState-  , send-  , close-  , addEventListener-  , data'-  , wasClean-  , code-  , reason-  ) where--import           GHCJS.Types--import qualified Miso.FFI as FFI-import           Miso.WebSocket--newtype Socket = Socket JSVal--foreign import javascript unsafe "$r = new WebSocket($1, $2);"-  create :: JSString -> JSVal -> IO Socket--foreign import javascript unsafe "$1.close()"-  close :: Socket -> IO ()--foreign import javascript unsafe "$r = $1.readyState;"-  socketState :: Socket -> IO Int--foreign import javascript unsafe "$1.send($2);"-  send :: Socket -> JSString -> IO ()--addEventListener :: Socket -> JSString -> (JSVal -> IO ()) -> IO ()-addEventListener (Socket s) = FFI.addEventListener s--foreign import javascript unsafe "$r = $1.data"-  data' :: JSVal -> IO JSVal--foreign import javascript unsafe "$r = $1.wasClean"-  wasClean :: JSVal -> IO WasClean--foreign import javascript unsafe "$r = $1.code"-  code :: JSVal -> IO Int--foreign import javascript unsafe "$r = $1.reason"-  reason :: JSVal -> IO Reason

@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans       #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.String+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.String (+    ToMisoString (..)+  , FromMisoString (..)+  , fromMisoString+  , MisoString+  , module Data.JSString+  , module Data.Monoid+  , ms+  ) where++import           Data.Aeson+import qualified Data.ByteString         as B+import qualified Data.ByteString.Lazy    as BL+import           Data.Char+import           Data.JSString+import qualified Data.JSString as JS+import           Data.JSString.Text+import           Data.Monoid+import qualified Data.Text               as T+import qualified Data.Text.Encoding      as T+import qualified Data.Text.Lazy          as LT+import qualified Data.Text.Lazy.Encoding as LT+import           Prelude                 hiding (foldr)+import           Text.StringLike         (StringLike(..))++-- | String type swappable based on compiler+type MisoString = JS.JSString++-- | `ToJSON` for `MisoString`+instance ToJSON MisoString where+  toJSON = String . textFromJSString++-- | `FromJSON` for `MisoString`+instance FromJSON MisoString where+  parseJSON =+    withText "Not a valid string" $ \x ->+      pure (toMisoString x)++-- | Convenience class for creating `MisoString` from other string-like types+class ToMisoString str where+  toMisoString :: str -> MisoString++-- | Class used to parse a 'MisoString'. Like a safe 'Read' for 'MisoString'+class FromMisoString t where+  -- -- | Reads a `MisoString`+  fromMisoStringEither :: MisoString -> Either String t++-- | Reads a 'MisoString', throws an error when decoding+-- fails. Use `fromMisoStringEither` for as a safe alternative.+fromMisoString :: FromMisoString a => MisoString -> a+fromMisoString s =+  case fromMisoStringEither s of+    Left err -> error err+    Right x  -> x++-- | Convenience function, shorthand for `toMisoString`+ms :: ToMisoString str => str -> MisoString+ms = toMisoString++instance ToMisoString MisoString where+  toMisoString = id+instance ToMisoString String where+  toMisoString = JS.pack+instance ToMisoString T.Text where+  toMisoString = textToJSString+instance ToMisoString LT.Text where+  toMisoString = lazyTextToJSString+instance ToMisoString B.ByteString where+  toMisoString = toMisoString . T.decodeUtf8+instance ToMisoString BL.ByteString where+  toMisoString = toMisoString . LT.decodeUtf8+instance ToMisoString Float where+  toMisoString = JS.pack . show+instance ToMisoString Double where+  toMisoString = JS.pack . show+instance ToMisoString Int where+  toMisoString = JS.pack . show+instance ToMisoString Word where+  toMisoString = JS.pack . show++instance FromMisoString MisoString where+  fromMisoStringEither = Right+instance FromMisoString String where+  fromMisoStringEither = Right . JS.unpack+instance FromMisoString T.Text where+  fromMisoStringEither = Right . textFromJSString+instance FromMisoString LT.Text where+  fromMisoStringEither = Right . lazyTextFromJSString+instance FromMisoString B.ByteString where+  fromMisoStringEither = fmap T.encodeUtf8 . fromMisoStringEither+instance FromMisoString BL.ByteString where+  fromMisoStringEither = fmap LT.encodeUtf8 . fromMisoStringEither+instance FromMisoString Float where+  fromMisoStringEither = fmap realToFrac . jsStringToDoubleEither+instance FromMisoString Double where+  fromMisoStringEither = jsStringToDoubleEither+instance FromMisoString Int where+  fromMisoStringEither = parseInt+instance FromMisoString Word where+  fromMisoStringEither = parseWord++jsStringToDoubleEither :: JS.JSString -> Either String Double+jsStringToDoubleEither s = let d = read $ JS.unpack s+                           in if isNaN d then Left "jsStringToDoubleEither: parse failed"+                                         else Right d+++parseWord   :: MisoString -> Either String Word+parseWord s = case JS.uncons s of+                Nothing     -> Left "parseWord: parse error"+                Just (c,s') -> JS.foldl' k (pDigit c) s'+  where+    pDigit c | isDigit c = Right . fromIntegral . digitToInt $ c+             | otherwise = Left "parseWord: parse error"+    k ea c = (\a x -> 10*a + x) <$> ea <*> pDigit c++parseInt   :: MisoString -> Either String Int+parseInt s = case JS.uncons s of+               Just ('-',s') -> ((-1)*) . fromIntegral <$> parseWord s'+               _             ->           fromIntegral <$> parseWord s++instance StringLike MisoString where+  uncons = JS.uncons+  toString = JS.unpack+  fromChar = JS.singleton+  strConcat = JS.concat+  empty = JS.empty+  strNull = JS.null+  cons = JS.cons+  append = JS.append+  strMap = JS.map

@@ -1,14 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.Dev--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.Dev-  ( clearBody-  ) where--import Miso.FFI (clearBody)

@@ -1,274 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE LambdaCase #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.FFI--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.FFI-   ( JSM-   , forkJSM-   , asyncCallback-   , asyncCallback1-   , callbackToJSVal-   , objectToJSVal-   , ghcjsPure-   , syncPoint-   , addEventListener-   , windowAddEventListener-   , windowInnerHeight-   , windowInnerWidth-   , eventPreventDefault-   , eventStopPropagation-   , now-   , consoleLog-   , consoleLogJSVal-   , stringify-   , parse-   , clearBody-   , objectToJSON-   , set-   , getBody-   , getDoc-   , getElementById-   , diff'-   , integralToJSString-   , realFloatToJSString-   , jsStringToDouble-   , delegateEvent-   , copyDOMIntoVTree-   , swapCallbacks-   , releaseCallbacks-   , registerCallback-   , focus-   , blur-   , scrollIntoView-   , alert-   ) where--import           Control.Concurrent-import           Control.Monad.IO.Class-import           Data.Aeson hiding (Object)-import           Data.JSString-import           GHCJS.Marshal-import           GHCJS.Types-import qualified JavaScript.Object.Internal as OI-import           Language.Javascript.JSaddle hiding (Success, obj, val)---- | Run given `JSM` action asynchronously, in a separate thread.-forkJSM :: JSM () -> JSM ()-forkJSM a = do-  ctx <- askJSM-  _ <- liftIO (forkIO (runJSM a ctx))-  pure ()--asyncCallback :: JSM () -> JSM Function-asyncCallback a = asyncFunction (\_ _ _ -> a)--asyncCallback1 :: (JSVal -> JSM ()) -> JSM Function-asyncCallback1 f = asyncFunction (\_ _ [x] -> f x)--callbackToJSVal :: Function -> JSM JSVal-callbackToJSVal = toJSVal--objectToJSVal :: Object -> JSM JSVal-objectToJSVal = toJSVal---- | Set property on object-set :: ToJSVal v => JSString -> v -> OI.Object -> JSM ()-set (unpack -> "class") v obj = do-  classSet <- ((pack "class") `elem`) <$> listProps obj-  if classSet-    then do-      classStr <- fromJSValUnchecked =<< getProp (pack "class") obj-      vStr <- fromJSValUnchecked =<< toJSVal v-      v' <- toJSVal (classStr <> pack " " <> vStr)-      setProp (pack "class") v' obj-    else do-      v' <- toJSVal v-      setProp (pack "class") v' obj-set k v obj = do-  v' <- toJSVal v-  setProp k v' obj---- | Register an event listener on given target.-addEventListener :: JSVal             -- ^ Event target on which we want to register event listener-                 -> JSString          -- ^ Type of event to listen to (e.g. "click")-                 -> (JSVal -> JSM ()) -- ^ Callback which will be called when the event occurs, the event will be passed to it as a parameter.-                 -> JSM ()-addEventListener self name cb = do-  _ <- self # "addEventListener" $ (name, asyncFunction (\_ _ [a] -> cb a))-  pure ()---- | Registers an event listener on window-windowAddEventListener :: JSString           -- ^ Type of event to listen to (e.g. "click")-                       -> (JSVal -> JSM ())  -- ^ Callback which will be called when the event occurs, the event will be passed to it as a parameter.-                       -> JSM ()-windowAddEventListener name cb = do-  win <- jsg "window"-  addEventListener win name cb--eventStopPropagation :: JSVal -> JSM ()-eventStopPropagation e = do-  _ <- e # "stopPropagation" $ ()-  pure ()--eventPreventDefault :: JSVal -> JSM ()-eventPreventDefault e = do-  _ <- e # "preventDefault" $ ()-  pure ()---- | Retrieves the height (in pixels) of the browser window viewport including, if rendered, the horizontal scrollbar.------ See <https://developer.mozilla.org/en-US/docs/Web/API/Window/innerHeight>-windowInnerHeight :: JSM Int-windowInnerHeight =-  fromJSValUnchecked =<< jsg "window" ! "innerHeight"---- | Retrieves the width (in pixels) of the browser window viewport including, if rendered, the vertical scrollbar.------ See <https://developer.mozilla.org/en-US/docs/Web/API/Window/innerWidth>-windowInnerWidth :: JSM Int-windowInnerWidth =-  fromJSValUnchecked =<< jsg "window" ! "innerWidth"---- | Retrieve high resolution time stamp------ See <https://developer.mozilla.org/en-US/docs/Web/API/Performance/now>-now :: JSM Double-now = fromJSValUnchecked =<< (jsg "performance" # "now" $ ())---- | Outputs a message to the web console------ See <https://developer.mozilla.org/en-US/docs/Web/API/Console/log>-consoleLog :: JSString -> JSM ()-consoleLog v = do-  _ <- jsg "console" # "log" $ [toJSString v]-  pure ()---- | Console-logging-consoleLogJSVal :: JSVal -> JSM ()-consoleLogJSVal v = do-  _ <- jsg "console" # "log" $ [v]-  pure ()---- | Converts a JS object into a JSON string-stringify :: ToJSON json => json -> JSM JSString-{-# INLINE stringify #-}-stringify j = do-  v <- toJSVal (toJSON j)-  fromJSValUnchecked =<< (jsg "JSON" # "stringify" $ [v])---- | Parses a JSString-parse :: FromJSON json => JSVal -> JSM json-{-# INLINE parse #-}-parse jval = do-  val <- fromJSValUnchecked =<< (jsg "JSON" # "parse" $ [jval])-  case fromJSON val of-    Success x -> pure x-    Error y -> error y---- | Clear the document body. This is particularly useful to avoid--- creating multiple copies of your app when running in GHCJSi.-clearBody :: JSM ()-clearBody =-  (jsg "document" ! "body"  <# "innerHtml") [""]--objectToJSON-    :: JSVal -- ^ decodeAt :: [JSString]-    -> JSVal -- ^ object with impure references to the DOM-    -> JSM JSVal-objectToJSON = jsg2 "objectToJSON"---- | Retrieves a reference to document body.------ See <https://developer.mozilla.org/en-US/docs/Web/API/Document/body>-getBody :: JSM JSVal-getBody = jsg "document" ! "body"----- | Retrieves a reference to the document.------ See <https://developer.mozilla.org/en-US/docs/Web/API/Document>-getDoc :: JSM JSVal-getDoc = jsg "document"---- | Returns an Element object representing the element whose id property matches the specified string.------ See <https://developer.mozilla.org/en-US/docs/Web/API/Document/getElementById>-getElementById :: JSString -> JSM JSVal-getElementById e = getDoc # "getElementById" $ [e]--diff'-    :: OI.Object -- ^ current object-    -> OI.Object -- ^ new object-    -> JSVal  -- ^ parent node-    -> JSVal -- ^ document-    -> JSM ()-diff' a b c d = () <$ jsg4 "diff" a b c d--integralToJSString :: Integral a => a -> JSString-integralToJSString = pack . show . toInteger--realFloatToJSString :: RealFloat a => a -> JSString-realFloatToJSString x = (pack . show) (realToFrac x :: Double)--jsStringToDouble :: JSString -> Double-jsStringToDouble = read . unpack--delegateEvent :: JSVal -> JSVal -> JSM JSVal -> JSM ()-delegateEvent mountPoint events getVTree = do-  cb' <- asyncFunction $ \_ _ [continuation] -> do-    res <- getVTree-    _ <- call continuation global res-    pure ()-  delegateEvent' mountPoint events cb'--delegateEvent' :: JSVal -> JSVal -> Function -> JSM ()-delegateEvent' mountPoint events cb = () <$ jsg3 "delegate" mountPoint events cb---- | Copies DOM pointers into virtual dom--- entry point into isomorphic javascript-copyDOMIntoVTree :: Bool -> JSVal -> JSVal -> JSM ()-copyDOMIntoVTree logLevel mountPoint a = () <$ jsg3 "copyDOMIntoVTree" logLevel mountPoint a---- TODO For now, we do not free callbacks when compiling with JSaddle---- | Pins down the current callbacks for clearing later-swapCallbacks :: JSM ()-swapCallbacks = pure ()---- | Releases callbacks registered by the virtual DOM.-releaseCallbacks :: JSM ()-releaseCallbacks = pure ()--registerCallback :: JSVal -> JSM ()-registerCallback _ = pure ()---- | Fails silently if the element is not found.------ Analogous to @document.getElementById(id).focus()@.-focus :: JSString -> JSM ()-focus a = () <$ jsg1 "callFocus" a---- | Fails silently if the element is not found.------ Analogous to @document.getElementById(id).blur()@-blur :: JSString -> JSM ()-blur a = () <$ jsg1 "callBlur" a---- | Calls @document.getElementById(id).scrollIntoView()@-scrollIntoView :: JSString -> JSM ()-scrollIntoView elId = do-  el <- jsg "document" # "getElementById" $ [elId]-  _ <- el # "scollIntoView" $ ()-  pure ()---- | Calls the @alert()@ function.-alert :: JSString -> JSM ()-alert a = () <$ jsg1 "alert" a

@@ -1,56 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.FFI.History--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.FFI.History-  ( getWindowLocationHref-  , go-  , back-  , forward-  , pushState-  , replaceState-  ) where--import Control.Monad-import GHCJS.Types-import Language.Javascript.JSaddle--getWindowLocationHref :: JSM JSString-getWindowLocationHref = do-  href <- fromJSVal =<< jsg "window" ! "location" ! "href"-  case join href of-    Nothing -> pure mempty-    Just uri -> pure uri--getHistory :: JSM JSVal-getHistory = jsg "window" ! "history"--go :: Int -> JSM ()-go i = do-  _ <- getHistory # "go" $ [i]-  pure ()--back :: JSM ()-back = do-  _ <- getHistory # "back" $ ()-  pure ()--forward :: JSM ()-forward = do-  _ <- getHistory # "forward" $ ()-  pure ()--pushState :: JSString -> JSM ()-pushState url = do-  _ <- getHistory # "pushState" $ (jsNull, jsNull, url)-  pure ()--replaceState :: JSString -> JSM ()-replaceState url = do-  _ <- getHistory # "replaceState" $ (jsNull, jsNull, url)-  pure ()

@@ -1,38 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.FFI.SSE--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.FFI.SSE-  ( EventSource(..)-  , data'-  , new-  , addEventListener-  ) where--import           GHCJS.Types--import           Miso.FFI (JSM)-import qualified Miso.FFI as FFI--import qualified Language.Javascript.JSaddle as JSaddle-import           Language.Javascript.JSaddle hiding (new)--newtype EventSource = EventSource JSVal--data' :: JSVal -> JSM JSVal-data' v = v ! ("data" :: JSString)--new :: JSString -> JSM EventSource-new url = EventSource <$> JSaddle.new (jsg ("EventSource" :: JSString)) [url]--addEventListener :: EventSource -> JSString -> (JSVal -> JSM ()) -> JSM ()-addEventListener (EventSource s) = FFI.addEventListener s

@@ -1,54 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Miso.FFI.Storage--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.FFI.Storage-  ( Storage-  , localStorage-  , sessionStorage-  , getItem-  , removeItem-  , setItem-  , length-  , clear-  ) where--import GHCJS.Types-import Prelude hiding (length)--import Language.Javascript.JSaddle ((!), (#), JSM, fromJSValUnchecked, jsg)--newtype Storage = Storage JSVal--localStorage :: JSM Storage-localStorage = Storage <$> (jsg "window" ! "localStorage")--sessionStorage :: JSM Storage-sessionStorage = Storage <$> (jsg "window" ! "sessionStorage")--getItem :: Storage -> JSString -> JSM JSVal-getItem (Storage s) key =-  s # "getItem" $ [key]--removeItem :: Storage -> JSString -> JSM ()-removeItem (Storage s) key = do-  _ <- s # "removeItem" $ [key]-  pure ()--setItem :: Storage -> JSString -> JSString -> JSM ()-setItem (Storage s) key val = do-  _ <- s # "setItem" $ (key, val)-  pure ()--length :: Storage -> JSM Int-length (Storage s) = fromJSValUnchecked =<< s ! "length"--clear :: Storage -> JSM ()-clear (Storage s) = do-  _ <- s # "clear" $ ()-  pure ()

@@ -1,67 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.FFI.WebSocket--- Copyright   :  (C) 2016-2018 David M. Johnson--- License     :  BSD3-style (see the file LICENSE)--- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------------------------------------------------------------------------------module Miso.FFI.WebSocket-  ( Socket(..)-  , create-  , socketState-  , send-  , close-  , addEventListener-  , data'-  , wasClean-  , code-  , reason-  ) where--import           GHCJS.Types--import           Language.Javascript.JSaddle hiding (create)--import           Miso.FFI (JSM)-import qualified Miso.FFI as FFI-import           Miso.WebSocket--newtype Socket = Socket JSVal--create :: JSString -> JSVal -> JSM Socket-create url protocols = Socket <$> new (jsg ("WebSocket" :: JSString)) (url, protocols)--socketState :: Socket -> JSM Int-socketState (Socket s) = fromJSValUnchecked =<< s ! ("readyState" :: JSString)--send :: Socket -> JSString -> JSM ()-send (Socket s) msg = do-  _ <- s # ("send" :: JSString) $ [msg]-  pure ()--close :: Socket -> JSM ()-close (Socket s) = do-  _ <- s # ("close" :: JSString) $ ([] :: [JSString])-  pure ()--addEventListener :: Socket -> JSString -> (JSVal -> JSM ()) -> JSM ()-addEventListener (Socket s) name cb = do-  FFI.addEventListener s name cb--data' :: JSVal -> JSM JSVal-data' v = v ! ("data" :: JSString)--wasClean :: JSVal -> JSM WasClean-wasClean v = WasClean <$> (fromJSValUnchecked =<< v ! ("wasClean" :: JSString))--code :: JSVal -> JSM Int-code v = fromJSValUnchecked =<< v ! ("code" :: JSString)--reason :: JSVal -> JSM Reason-reason v = Reason <$> (fromJSValUnchecked =<< v ! ("reason" :: JSString))

@@ -93,7 +93,7 @@   for (var c in cProps) {     newProp = nProps[c];     /* If current property no longer exists, remove it */-    if (!newProp) {+    if (newProp === undefined) {       /* current key is not in node, remove it from DOM, if SVG, remove attribute */       if (isSvg || !(c in node))         node.removeAttribute(c, cProps[c]);

@@ -1,5 +1,5 @@ name:                miso-version:             1.7.1.0+version:             1.8.0.0 category:            Web, Miso, Data Structures license:             BSD3 license-file:        LICENSE@@ -108,25 +108,46 @@   exposed-modules:     Miso     Miso.Util+    Miso.Dev     Miso.Html     Miso.Html.Element     Miso.Html.Event     Miso.Html.Property+    Miso.Html.Types+    Miso.Delegate+    Miso.Diff     Miso.Event     Miso.Event.Decoder     Miso.Event.Types     Miso.Router+    Miso.Effect+    Miso.Effect.Storage+    Miso.Effect.DOM+    Miso.FFI+    Miso.FFI.History+    Miso.FFI.SSE+    Miso.FFI.Storage+    Miso.FFI.WebSocket+    Miso.JSBits+    Miso.Subscription+    Miso.Subscription.History+    Miso.Subscription.Keyboard+    Miso.Subscription.Mouse+    Miso.Subscription.WebSocket+    Miso.Subscription.Window+    Miso.Subscription.SSE     Miso.Svg     Miso.Svg.Attribute     Miso.Svg.Element     Miso.Svg.Event+    Miso.TypeLevel+    Miso.Types     Miso.Mathml     Miso.Mathml.Element     Miso.String     Miso.WebSocket   other-modules:     Miso.Concurrent-    Miso.Html.Internal   ghc-options:     -Wall   hs-source-dirs:@@ -136,74 +157,44 @@     base < 5,     bytestring,     containers,+    file-embed,     http-api-data,     http-types,+    jsaddle,+    lucid,     network-uri,     servant,+    servant-lucid,+    tagsoup,     text,     transformers   if impl(ghcjs) || flag (jsaddle)-    if flag(jsaddle)+    if impl(ghcjs)       build-depends:-        jsaddle-      cpp-options:-        -DJSADDLE-      hs-source-dirs:-        jsaddle-ffi+        ghcjs-base+    if flag(jsaddle)       if flag (ios)         cpp-options:           -DIOS-        other-modules:-          Miso.JSBits-      else-        build-depends:-          file-embed     else-      build-depends:-        ghcjs-base-      hs-source-dirs:-        ghcjs-ffi       js-sources:         jsbits/diff.js         jsbits/delegate.js         jsbits/isomorphic.js         jsbits/util.js-    hs-source-dirs:-      frontend-src     build-depends:       containers,       scientific,       unordered-containers,       transformers,       vector-    exposed-modules:-      Miso.Dev-      Miso.Effect-      Miso.Effect.Storage-      Miso.Effect.DOM-      Miso.Subscription-      Miso.Subscription.History-      Miso.Subscription.Keyboard-      Miso.Subscription.Mouse-      Miso.Subscription.WebSocket-      Miso.Subscription.Window-      Miso.Subscription.SSE-      Miso.Types-    other-modules:-      Miso.Diff-      Miso.FFI-      Miso.FFI.History-      Miso.FFI.SSE-      Miso.FFI.Storage-      Miso.FFI.WebSocket-      Miso.Delegate   else-    exposed-modules:-      Miso.TypeLevel     build-depends:-      lucid,-      servant-lucid,       vector+  if impl(ghcjs)+    hs-source-dirs:+      ghcjs-src+  else     hs-source-dirs:       ghc-src 

@@ -0,0 +1,172 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE KindSignatures      #-}++#ifdef IOS+#else+{-# LANGUAGE TemplateHaskell     #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso+  ( miso+  , startApp+  , module Miso.Effect+  , module Miso.Event+  , module Miso.Html+  , module Miso.Subscription+  , module Miso.TypeLevel+  , module Miso.Types+  , module Miso.Router+  , module Miso.Util+  , module Miso.FFI+  , module Miso.WebSocket+  ) where++import           Control.Concurrent+import           Control.Monad+import           Control.Monad.IO.Class+import           Data.IORef+import           Data.List+import           Data.Sequence ((|>))+import           System.Mem.StableName+import qualified Data.Sequence as S+import qualified JavaScript.Object.Internal as OI++#ifndef __GHCJS__+import           Language.Javascript.JSaddle (eval, waitForAnimationFrame)+#ifdef IOS+import           Miso.JSBits+#else+import           GHCJS.Types (JSString)+import           Data.FileEmbed+#endif+#else+import           JavaScript.Web.AnimationFrame+#endif++import           Miso.Concurrent+import           Miso.Delegate+import           Miso.Diff+import           Miso.Effect+import           Miso.Event+import           Miso.FFI+import           Miso.Html+import           Miso.Router+import           Miso.Subscription+import           Miso.TypeLevel+import           Miso.Types+import           Miso.Util+import           Miso.WebSocket++-- | Helper function to abstract out common functionality between `startApp` and `miso`+common+  :: Eq model+  => App model action+  -> model+  -> (Sink action -> JSM (IORef VTree))+  -> JSM ()+common App {..} m getView = do+#ifndef __GHCJS__+#ifdef IOS+  mapM_ eval [delegateJs,diffJs,isomorphicJs,utilJs]+#else+  _ <- eval ($(embedStringFile "jsbits/delegate.js") :: JSString)+  _ <- eval ($(embedStringFile "jsbits/diff.js") :: JSString)+  _ <- eval ($(embedStringFile "jsbits/isomorphic.js") :: JSString)+  _ <- eval ($(embedStringFile "jsbits/util.js") :: JSString)+#endif+#endif+  -- init Notifier+  Notify {..} <- liftIO newNotify+  -- init empty actions+  actionsRef <- liftIO (newIORef S.empty)+  let writeEvent a = void . liftIO . forkIO $ do+        atomicModifyIORef' actionsRef $ \as -> (as |> a, ())+        notify+  -- init Subs+  forM_ subs $ \sub ->+    sub writeEvent+  -- Hack to get around `BlockedIndefinitelyOnMVar` exception+  -- that occurs when no event handlers are present on a template+  -- and `notify` is no longer in scope+  void . liftIO . forkIO . forever $ threadDelay (1000000 * 86400) >> notify+  -- Retrieves reference view+  viewRef <- getView writeEvent+  -- know thy mountElement+  mountEl <- mountElement mountPoint+  -- Begin listening for events in the virtual dom+  delegator mountEl viewRef events+  -- Process initial action of application+  writeEvent initialAction+  -- Program loop, blocking on SkipChan++  let+    loop !oldModel = liftIO wait >> do+        -- Apply actions to model+        actions <- liftIO $ atomicModifyIORef' actionsRef $ \actions -> (S.empty, actions)+        let (Acc newModel effects) = foldl' (foldEffects writeEvent update)+                                            (Acc oldModel (pure ())) actions+        effects+        oldName <- liftIO $ oldModel `seq` makeStableName oldModel+        newName <- liftIO $ newModel `seq` makeStableName newModel+        when (oldName /= newName && oldModel /= newModel) $ do+          swapCallbacks+          newVTree <- runView (view newModel) writeEvent+          oldVTree <- liftIO (readIORef viewRef)+          void $ waitForAnimationFrame+          (diff mountPoint) (Just oldVTree) (Just newVTree)+          releaseCallbacks+          liftIO (atomicWriteIORef viewRef newVTree)+        syncPoint+        loop newModel+  loop m++-- | Runs an isomorphic miso application.+-- Assumes the pre-rendered DOM is already present+miso :: Eq model => (URI -> App model action) -> JSM ()+miso f = do+  app@App {..} <- f <$> getCurrentURI+  common app model $ \writeEvent -> do+    let initialView = view model+    VTree (OI.Object iv) <- flip runView writeEvent initialView+    mountEl <- mountElement mountPoint+    -- Initial diff can be bypassed, just copy DOM into VTree+    copyDOMIntoVTree (logLevel == DebugPrerender) mountEl iv+    let initialVTree = VTree (OI.Object iv)+    -- Create virtual dom, perform initial diff+    liftIO (newIORef initialVTree)++-- | Runs a miso application+startApp :: Eq model => App model action -> JSM ()+startApp app@App {..} =+  common app model $ \writeEvent -> do+    let initialView = view model+    initialVTree <- flip runView writeEvent initialView+    (diff mountPoint) Nothing (Just initialVTree)+    liftIO (newIORef initialVTree)++-- | Helper+foldEffects+  :: Sink action+  -> (action -> model -> Effect action model)+  -> Acc model -> action -> Acc model+foldEffects sink update = \(Acc model as) action ->+  case update action model of+    Effect newModel effs -> Acc newModel newAs+      where+        newAs = as >> do+          forM_ effs $ \eff -> forkJSM (eff sink)++data Acc model = Acc !model !(JSM ())

@@ -16,13 +16,13 @@  import Control.Concurrent --- | Concurrent API for `SkipChan` implementation+-- | Concurrent API for SkipChan implementation data Notify = Notify {     wait :: IO ()   , notify :: IO ()   } --- | Create a new `Notify`+-- | Create a new 'Notify' newNotify :: IO Notify newNotify = do   mvar <- newMVar ()@@ -30,7 +30,7 @@    (takeMVar mvar)    (() <$ do tryPutMVar mvar $! ()) --- | Create a new `Notify`+-- | Create a new 'Notify' newEmptyNotify :: IO Notify newEmptyNotify = do   mvar <- newEmptyMVar

@@ -0,0 +1,32 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Delegate+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Delegate where++import           Control.Monad.IO.Class+import           Data.IORef+import qualified Data.Map as M+import           GHCJS.Marshal+import           GHCJS.Types (JSVal)+import qualified JavaScript.Object.Internal as OI+import           Miso.FFI+import           Miso.Html.Types+import           Miso.String++-- | Entry point for event delegation+delegator+  :: JSVal+  -> IORef VTree+  -> M.Map MisoString Bool+  -> JSM ()+delegator mountPointElement vtreeRef es = do+  evts <- toJSVal (M.toList es)+  delegateEvent mountPointElement evts $ do+    VTree (OI.Object val) <- liftIO (readIORef vtreeRef)+    pure val

@@ -0,0 +1,14 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Dev+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Dev+  ( clearBody+  ) where++import Miso.FFI (clearBody)

@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Diff+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Diff ( diff+                 , mountElement+                 ) where++import GHCJS.Foreign.Internal     hiding (Object)+import GHCJS.Types+import JavaScript.Object.Internal+import Miso.Html.Types+import Miso.FFI+import Miso.String++-- | Entry point for diffing / patching algorithm+diff :: Maybe MisoString -> Maybe VTree -> Maybe VTree -> JSM ()+diff mayElem current new =+  case mayElem of+    Nothing -> do+      body <- getBody+      diffElement body current new+    Just elemId -> do+      e <- getElementById elemId+      diffElement e current new++-- | diffing / patching a given element+diffElement :: JSVal -> Maybe VTree -> Maybe VTree -> JSM ()+diffElement mountEl current new = do+  doc <- getDoc+  case (current, new) of+    (Nothing, Nothing) -> pure ()+    (Just (VTree current'), Just (VTree new')) -> do+      diff' current' new' mountEl doc+    (Nothing, Just (VTree new')) -> do+      diff' (Object jsNull) new' mountEl doc+    (Just (VTree current'), Nothing) -> do+      diff' current' (Object jsNull) mountEl doc++-- | return the configured mountPoint element or the body+mountElement :: Maybe MisoString -> JSM JSVal+mountElement mayMp =+  case mayMp of+    Nothing -> getBody+    Just eid -> getElementById eid

@@ -0,0 +1,97 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Effect+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- This module defines `Effect` and `Sub` types, which are used to define+-- `Miso.Types.update` function and `Miso.Types.subs` field of the `Miso.Types.App`.+----------------------------------------------------------------------------+module Miso.Effect (+  module Miso.Effect.Storage+, module Miso.Effect.DOM+, Effect (..), Sub, Sink+, mapSub+, noEff+, (<#)+, (#>)+, batchEff+, effectSub+) where++import Data.Bifunctor++import Control.Monad.IO.Class+import Miso.FFI (JSM)++import Miso.Effect.Storage+import Miso.Effect.DOM++-- | An effect represents the results of an update action.+--+-- It consists of the updated model and a list of subscriptions. Each 'Sub' is+-- run in a new thread so there is no risk of accidentally blocking the+-- application.+data Effect action model = Effect model [Sub action]++-- | Type synonym for constructing event subscriptions.+--+-- The 'Sink' callback is used to dispatch actions which are then fed+-- back to the 'Miso.Types.update' function.+type Sub action = Sink action -> JSM ()++-- | Function to asynchronously dispatch actions to the 'Miso.Types.update' function.+type Sink action = action -> IO ()++-- | Turn a subscription that consumes actions of type @a@ into a subscription+-- that consumes actions of type @b@ using the supplied function of type @a -> b@.+mapSub :: (actionA -> actionB) -> Sub actionA -> Sub actionB+mapSub f sub = \sinkB -> let sinkA = sinkB . f+                         in sub sinkA++instance Functor (Effect action) where+  fmap f (Effect m acts) = Effect (f m) acts++instance Applicative (Effect action) where+  pure m = Effect m []+  Effect fModel fActs <*> Effect xModel xActs = Effect (fModel xModel) (fActs ++ xActs)++instance Monad (Effect action) where+  return = pure+  Effect m acts >>= f =+    case f m of+      Effect m' acts' -> Effect m' (acts ++ acts')++instance Bifunctor Effect where+  bimap f g (Effect m acts) = Effect (g m) (map (\act -> \sink -> act (sink . f)) acts)++-- | Smart constructor for an 'Effect' with no actions.+noEff :: model -> Effect action model+noEff m = Effect m []++-- | Smart constructor for an 'Effect' with exactly one action.+(<#) :: model -> JSM action -> Effect action model+(<#) m a = effectSub m $ \sink -> a >>= liftIO . sink++-- | `Effect` smart constructor, flipped+(#>) :: JSM action -> model -> Effect action model+(#>) = flip (<#)++-- | Smart constructor for an 'Effect' with multiple actions.+batchEff :: model -> [JSM action] -> Effect action model+batchEff model actions = Effect model $+  map (\a sink -> liftIO . sink =<< a) actions++-- | Like '<#' but schedules a subscription which is an IO computation which has+-- access to a 'Sink' which can be used to asynchronously dispatch actions to+-- the 'Miso.Types.update' function.+--+-- A use-case is scheduling an IO computation which creates a 3rd-party JS+-- widget which has an associated callback. The callback can then call the sink+-- to turn events into actions. To do this without accessing a sink requires+-- going via a @'Sub'scription@ which introduces a leaky-abstraction.+effectSub :: model -> Sub action -> Effect action model+effectSub model sub = Effect model [sub]

@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Effect.DOM+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Effect.DOM+  ( focus+  , blur+  , scrollIntoView+  , alert+  ) where++import Miso.FFI

@@ -0,0 +1,125 @@+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE ForeignFunctionInterface  #-}+{-# LANGUAGE LambdaCase                #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Effect.Storage+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- This module provides an interface to the+-- [Web Storage API](https://developer.mozilla.org/en-US/docs/Web/API/Web_Storage_API).+----------------------------------------------------------------------------+module Miso.Effect.Storage+  ( -- * Retrieve storage+    getLocalStorage+  , getSessionStorage+    -- * Set items in storage+  , setLocalStorage+  , setSessionStorage+    -- * Remove items from storage+  , removeLocalStorage+  , removeSessionStorage+    -- * Clear storage+  , clearLocalStorage+  , clearSessionStorage+    -- * Get number of items in storage+  , localStorageLength+  , sessionStorageLength+  ) where++import           Data.Aeson hiding (Object, String)+import           GHCJS.Marshal+import           GHCJS.Types++import           Miso.FFI+import qualified Miso.FFI.Storage as Storage+import           Miso.String++-- | Helper for retrieving either local or session storage+getStorageCommon+  :: FromJSON b => (t -> JSM (Maybe JSVal)) -> t -> JSM (Either String b)+getStorageCommon f key = do+  result :: Maybe JSVal <- f key+  case result of+    Nothing -> pure $ Left "Not Found"+    Just v -> do+      r <- parse v+      pure $ case fromJSON r of+        Success x -> Right x+        Error y -> Left y++-- | Retrieve a value stored under given key in session storage+getSessionStorage :: FromJSON model => MisoString -> JSM (Either String model)+getSessionStorage =+  getStorageCommon $ \t -> do+    s <- Storage.sessionStorage+    r <- Storage.getItem s t+    fromJSVal r++-- | Retrieve a value stored under given key in local storage+getLocalStorage :: FromJSON model => MisoString -> JSM (Either String model)+getLocalStorage = getStorageCommon $ \t -> do+    s <- Storage.localStorage+    r <- Storage.getItem s t+    fromJSVal r++-- | Set the value of a key in local storage.+--+-- @setLocalStorage key value@ sets the value of @key@ to @value@.+setLocalStorage :: ToJSON model => MisoString -> model -> JSM ()+setLocalStorage key model = do+  s <- Storage.localStorage+  Storage.setItem s key =<< stringify model++-- | Set the value of a key in session storage.+--+-- @setSessionStorage key value@ sets the value of @key@ to @value@.+setSessionStorage :: ToJSON model => MisoString -> model -> JSM ()+setSessionStorage key model = do+  s <- Storage.sessionStorage+  Storage.setItem s key =<< stringify model++-- | Removes an item from local storage+--+-- @removeLocalStorage key@ removes the value of @key@.+removeLocalStorage :: MisoString -> JSM ()+removeLocalStorage key = do+  s <- Storage.localStorage+  Storage.removeItem s key++-- | Removes an item from session storage.+--+-- @removeSessionStorage key@ removes the value of @key@.+removeSessionStorage :: MisoString -> JSM ()+removeSessionStorage key = do+  s <- Storage.sessionStorage+  Storage.removeItem s key++-- | Clear local storage+--+-- @clearLocalStorage@ removes all values from local storage.+clearLocalStorage :: JSM ()+clearLocalStorage = Storage.clear =<< Storage.localStorage++-- | Clear session storage+--+-- @clearSessionStorage@ removes all values from session storage.+clearSessionStorage :: JSM ()+clearSessionStorage = Storage.clear =<< Storage.sessionStorage++-- | Local storage length+--+-- @localStorageLength@ returns the count of items in local storage+localStorageLength :: JSM Int+localStorageLength = Storage.length =<< Storage.localStorage++-- | Session storage length+--+-- @sessionStorageLength@ returns the count of items in session storage+sessionStorageLength :: JSM Int+sessionStorageLength = Storage.length =<< Storage.sessionStorage

@@ -25,6 +25,7 @@  import Data.Aeson.Types import Control.Applicative+import GHCJS.Marshal (ToJSVal, toJSVal)  import Miso.Event.Types import Miso.String@@ -33,6 +34,11 @@ data DecodeTarget   = DecodeTarget [MisoString] -- ^ Specify single path within Event object, where a decoder should be applied.   | DecodeTargets [[MisoString]] -- ^ Specify multiple paths withing Event object, where decoding should be attempted. The first path where decoding suceeds is the one taken.++-- | `ToJSVal` instance for `Decoder`+instance ToJSVal DecodeTarget where+  toJSVal (DecodeTarget xs) = toJSVal xs+  toJSVal (DecodeTargets xs) = toJSVal xs  -- | Decoder data type for parsing events data Decoder a = Decoder {

@@ -14,6 +14,7 @@  import qualified Data.Map as M import           GHC.Generics+import           GHCJS.Marshal (ToJSVal) import           Miso.String import           Data.Aeson (FromJSON) @@ -39,6 +40,8 @@     preventDefault :: Bool   , stopPropagation :: Bool   } deriving (Show, Eq, Generic)++instance ToJSVal Options  -- | Default value for 'Options'. --

@@ -0,0 +1,293 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.FFI+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.FFI+   ( JSM+   , forkJSM+   , asyncCallback+   , asyncCallback1+   , callbackToJSVal+   , objectToJSVal+   , ghcjsPure+   , syncPoint+   , addEventListener+   , windowAddEventListener+   , windowInnerHeight+   , windowInnerWidth+   , eventPreventDefault+   , eventStopPropagation+   , now+   , consoleLog+   , consoleLogJSVal+   , stringify+   , parse+   , clearBody+   , objectToJSON+   , set+   , getBody+   , getDoc+   , getElementById+   , diff'+   , integralToJSString+   , realFloatToJSString+   , jsStringToDouble+   , delegateEvent+   , copyDOMIntoVTree+   , swapCallbacks+   , releaseCallbacks+   , registerCallback+   , focus+   , blur+   , scrollIntoView+   , alert+   ) where++import           Control.Concurrent+import           Control.Monad.IO.Class+import           Data.Aeson hiding (Object)+import qualified Data.JSString as JSS+import           GHCJS.Marshal+import           GHCJS.Types+import qualified JavaScript.Object.Internal as OI+#ifdef __GHCJS__+import           Language.Javascript.JSaddle hiding (obj, val)+#else+import           Language.Javascript.JSaddle hiding (Success, obj, val)+#endif+import           Miso.String++-- | Run given `JSM` action asynchronously, in a separate thread.+forkJSM :: JSM () -> JSM ()+forkJSM a = do+  ctx <- askJSM+  _ <- liftIO (forkIO (runJSM a ctx))+  pure ()++-- | Creates an asynchronous callback function+asyncCallback :: JSM () -> JSM Function+asyncCallback a = asyncFunction (\_ _ _ -> a)++-- | Creates an asynchronous callback function with a single argument+asyncCallback1 :: (JSVal -> JSM ()) -> JSM Function+asyncCallback1 f = asyncFunction (\_ _ [x] -> f x)++-- | Convert a Callback into a JSVal+callbackToJSVal :: Function -> JSM JSVal+callbackToJSVal = toJSVal++-- | Convert an Object into a JSVal+objectToJSVal :: Object -> JSM JSVal+objectToJSVal = toJSVal++-- | Set property on object+set :: ToJSVal v => MisoString -> v -> OI.Object -> JSM ()+set (unpack -> "class") v obj = do+  classSet <- ((JSS.pack "class") `elem`) <$> listProps obj+  if classSet+    then do+      classStr <- fromJSValUnchecked =<< getProp (JSS.pack "class") obj+      vStr <- fromJSValUnchecked =<< toJSVal v+      v' <- toJSVal (classStr <> JSS.pack " " <> vStr)+      setProp (JSS.pack "class") v' obj+    else do+      v' <- toJSVal v+      setProp (JSS.pack "class") v' obj+set k v obj = do+  v' <- toJSVal v+  setProp (fromMisoString k) v' obj++-- | Register an event listener on given target.+addEventListener :: JSVal             -- ^ Event target on which we want to register event listener+                 -> MisoString        -- ^ Type of event to listen to (e.g. "click")+                 -> (JSVal -> JSM ()) -- ^ Callback which will be called when the event occurs, the event will be passed to it as a parameter.+                 -> JSM ()+addEventListener self name cb = do+  _ <- self # "addEventListener" $ (name, asyncFunction (\_ _ [a] -> cb a))+  pure ()++-- | Registers an event listener on window+windowAddEventListener :: MisoString         -- ^ Type of event to listen to (e.g. "click")+                       -> (JSVal -> JSM ())  -- ^ Callback which will be called when the event occurs, the event will be passed to it as a parameter.+                       -> JSM ()+windowAddEventListener name cb = do+  win <- jsg "window"+  addEventListener win name cb++-- | Stop propagation of events+eventStopPropagation :: JSVal -> JSM ()+eventStopPropagation e = do+  _ <- e # "stopPropagation" $ ()+  pure ()++-- | Prevent default event behavior+eventPreventDefault :: JSVal -> JSM ()+eventPreventDefault e = do+  _ <- e # "preventDefault" $ ()+  pure ()++-- | Retrieves the height (in pixels) of the browser window viewport including, if rendered, the horizontal scrollbar.+--+-- See <https://developer.mozilla.org/en-US/docs/Web/API/Window/innerHeight>+windowInnerHeight :: JSM Int+windowInnerHeight =+  fromJSValUnchecked =<< jsg "window" ! "innerHeight"++-- | Retrieves the width (in pixels) of the browser window viewport including, if rendered, the vertical scrollbar.+--+-- See <https://developer.mozilla.org/en-US/docs/Web/API/Window/innerWidth>+windowInnerWidth :: JSM Int+windowInnerWidth =+  fromJSValUnchecked =<< jsg "window" ! "innerWidth"++-- | Retrieve high resolution time stamp+--+-- See <https://developer.mozilla.org/en-US/docs/Web/API/Performance/now>+now :: JSM Double+now = fromJSValUnchecked =<< (jsg "performance" # "now" $ ())++-- | Outputs a message to the web console+--+-- See <https://developer.mozilla.org/en-US/docs/Web/API/Console/log>+consoleLog :: MisoString -> JSM ()+consoleLog v = do+  _ <- jsg "console" # "log" $ [toJSString v]+  pure ()++-- | Console-logging+consoleLogJSVal :: JSVal -> JSM ()+consoleLogJSVal v = do+  _ <- jsg "console" # "log" $ [v]+  pure ()++-- | Converts a JS object into a JSON string+stringify :: ToJSON json => json -> JSM MisoString+{-# INLINE stringify #-}+stringify j = do+  v <- toJSVal (toJSON j)+  fromJSValUnchecked =<< (jsg "JSON" # "stringify" $ [v])++-- | Parses a MisoString+parse :: FromJSON json => JSVal -> JSM json+{-# INLINE parse #-}+parse jval = do+  val <- fromJSValUnchecked =<< (jsg "JSON" # "parse" $ [jval])+  case fromJSON val of+    Success x -> pure x+    Error y -> error y++-- | Clear the document body. This is particularly useful to avoid+-- creating multiple copies of your app when running in GHCJSi.+clearBody :: JSM ()+clearBody =+  (jsg "document" ! "body"  <# "innerHtml") [""]++-- | Convert a JavaScript object to JSON+objectToJSON+    :: JSVal -- ^ decodeAt :: [JSString]+    -> JSVal -- ^ object with impure references to the DOM+    -> JSM JSVal+objectToJSON = jsg2 "objectToJSON"++-- | Retrieves a reference to document body.+--+-- See <https://developer.mozilla.org/en-US/docs/Web/API/Document/body>+getBody :: JSM JSVal+getBody = jsg "document" ! "body"++-- | Retrieves a reference to the document.+--+-- See <https://developer.mozilla.org/en-US/docs/Web/API/Document>+getDoc :: JSM JSVal+getDoc = jsg "document"++-- | Returns an Element object representing the element whose id property matches the specified string.+--+-- See <https://developer.mozilla.org/en-US/docs/Web/API/Document/getElementById>+getElementById :: MisoString -> JSM JSVal+getElementById e = getDoc # "getElementById" $ [e]++-- | Diff two virtual DOMs+diff'+    :: OI.Object -- ^ current object+    -> OI.Object -- ^ new object+    -> JSVal  -- ^ parent node+    -> JSVal -- ^ document+    -> JSM ()+diff' a b c d = () <$ jsg4 "diff" a b c d++-- | Helper function for converting Integral types to JavaScript strings+integralToJSString :: Integral a => a -> MisoString+integralToJSString = pack . show . toInteger++-- | Helper function for converting RealFloat types to JavaScript strings+realFloatToJSString :: RealFloat a => a -> MisoString+realFloatToJSString x = (pack . show) (realToFrac x :: Double)++-- | Helper function for converting RealFloat types to JavaScript strings+jsStringToDouble :: MisoString -> Double+jsStringToDouble = read . unpack++-- | Initialize event delegation from a mount point.+delegateEvent :: JSVal -> JSVal -> JSM JSVal -> JSM ()+delegateEvent mountPoint events getVTree = do+  cb' <- function $ \_ _ [continuation] -> do+    res <- getVTree+    _ <- call continuation global res+    pure ()+  delegateEvent' mountPoint events cb'++-- | Call 'delegateEvent' JavaScript function+delegateEvent' :: JSVal -> JSVal -> Function -> JSM ()+delegateEvent' mountPoint events cb = () <$ jsg3 "delegate" mountPoint events cb++-- | Copies DOM pointers into virtual dom+-- entry point into isomorphic javascript+copyDOMIntoVTree :: Bool -> JSVal -> JSVal -> JSM ()+copyDOMIntoVTree logLevel mountPoint a = () <$ jsg3 "copyDOMIntoVTree" logLevel mountPoint a++-- TODO For now, we do not free callbacks when compiling with JSaddle++-- | Pins down the current callbacks for clearing later+swapCallbacks :: JSM ()+swapCallbacks = pure ()++-- | Releases callbacks registered by the virtual DOM.+releaseCallbacks :: JSM ()+releaseCallbacks = pure ()++-- | Mock for callback registration+registerCallback :: JSVal -> JSM ()+registerCallback _ = pure ()++-- | Fails silently if the element is not found.+--+-- Analogous to @document.getElementById(id).focus()@.+focus :: MisoString -> JSM ()+focus a = () <$ jsg1 "callFocus" a++-- | Fails silently if the element is not found.+--+-- Analogous to @document.getElementById(id).blur()@+blur :: MisoString -> JSM ()+blur a = () <$ jsg1 "callBlur" a++-- | Calls @document.getElementById(id).scrollIntoView()@+scrollIntoView :: MisoString -> JSM ()+scrollIntoView elId = do+  el <- jsg "document" # "getElementById" $ [elId]+  _ <- el # "scrollIntoView" $ ()+  pure ()++-- | Calls the @alert()@ function.+alert :: MisoString -> JSM ()+alert a = () <$ jsg1 "alert" a

@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.FFI.History+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.FFI.History+  ( getWindowLocationHref+  , go+  , back+  , forward+  , pushState+  , replaceState+  ) where++import Control.Monad+import GHCJS.Types+import Language.Javascript.JSaddle+import Miso.String++getWindowLocationHref :: JSM MisoString+getWindowLocationHref = do+  href <- fromJSVal =<< jsg "window" ! "location" ! "href"+  case join href of+    Nothing -> pure mempty+    Just uri -> pure uri++getHistory :: JSM JSVal+getHistory = jsg "window" ! "history"++go :: Int -> JSM ()+go i = do+  _ <- getHistory # "go" $ [i]+  pure ()++back :: JSM ()+back = do+  _ <- getHistory # "back" $ ()+  pure ()++forward :: JSM ()+forward = do+  _ <- getHistory # "forward" $ ()+  pure ()++pushState :: MisoString -> JSM ()+pushState url = do+  _ <- getHistory # "pushState" $ (jsNull, jsNull, url)+  pure ()++replaceState :: MisoString -> JSM ()+replaceState url = do+  _ <- getHistory # "replaceState" $ (jsNull, jsNull, url)+  pure ()

@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.FFI.SSE+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.FFI.SSE+  ( EventSource(..)+  , data'+  , new+  , addEventListener+  ) where++import           GHCJS.Types++import           Miso.FFI (JSM)+import qualified Miso.FFI as FFI+import           Miso.String++import qualified Language.Javascript.JSaddle as JSaddle+import           Language.Javascript.JSaddle hiding (new)++newtype EventSource = EventSource JSVal++data' :: JSVal -> JSM JSVal+data' v = v ! ("data" :: JSString)++new :: MisoString -> JSM EventSource+new url = EventSource <$> JSaddle.new (jsg ("EventSource" :: JSString)) [url]++addEventListener :: EventSource -> MisoString -> (JSVal -> JSM ()) -> JSM ()+addEventListener (EventSource s) = FFI.addEventListener s

@@ -0,0 +1,55 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.FFI.Storage+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.FFI.Storage+  ( Storage+  , localStorage+  , sessionStorage+  , getItem+  , removeItem+  , setItem+  , length+  , clear+  ) where++import GHCJS.Types+import Prelude hiding (length)++import Language.Javascript.JSaddle ((!), (#), JSM, fromJSValUnchecked, jsg)+import Miso.String hiding (length)++newtype Storage = Storage JSVal++localStorage :: JSM Storage+localStorage = Storage <$> (jsg "window" ! "localStorage")++sessionStorage :: JSM Storage+sessionStorage = Storage <$> (jsg "window" ! "sessionStorage")++getItem :: Storage -> MisoString -> JSM JSVal+getItem (Storage s) key =+  s # "getItem" $ [key]++removeItem :: Storage -> MisoString -> JSM ()+removeItem (Storage s) key = do+  _ <- s # "removeItem" $ [key]+  pure ()++setItem :: Storage -> MisoString -> MisoString -> JSM ()+setItem (Storage s) key val = do+  _ <- s # "setItem" $ (key, val)+  pure ()++length :: Storage -> JSM Int+length (Storage s) = fromJSValUnchecked =<< s ! "length"++clear :: Storage -> JSM ()+clear (Storage s) = do+  _ <- s # "clear" $ ()+  pure ()

@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.FFI.WebSocket+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.FFI.WebSocket+  ( Socket(..)+  , create+  , socketState+  , send+  , close+  , addEventListener+  , data'+  , wasClean+  , code+  , reason+  ) where++import           GHCJS.Types++import           Language.Javascript.JSaddle hiding (create)++import           Miso.FFI (JSM)+import qualified Miso.FFI as FFI+import           Miso.String+import           Miso.WebSocket++newtype Socket = Socket JSVal++create :: MisoString -> JSVal -> JSM Socket+create url protocols = Socket <$> new (jsg ("WebSocket" :: JSString)) (url, protocols)++socketState :: Socket -> JSM Int+socketState (Socket s) = fromJSValUnchecked =<< s ! ("readyState" :: JSString)++send :: Socket -> MisoString -> JSM ()+send (Socket s) msg = do+  _ <- s # ("send" :: JSString) $ [msg]+  pure ()++close :: Socket -> JSM ()+close (Socket s) = do+  _ <- s # ("close" :: JSString) $ ([] :: [JSString])+  pure ()++addEventListener :: Socket -> MisoString -> (JSVal -> JSM ()) -> JSM ()+addEventListener (Socket s) name cb = do+  FFI.addEventListener s name cb++data' :: JSVal -> JSM JSVal+data' v = v ! ("data" :: JSString)++wasClean :: JSVal -> JSM WasClean+wasClean v = WasClean <$> (fromJSValUnchecked =<< v ! ("wasClean" :: JSString))++code :: JSVal -> JSM Int+code v = fromJSValUnchecked =<< v ! ("code" :: JSString)++reason :: JSVal -> JSM Reason+reason v = Reason <$> (fromJSValUnchecked =<< v ! ("reason" :: JSString))

@@ -30,11 +30,11 @@ module Miso.Html    ( module Miso.Html.Element    , module Miso.Html.Event-   , module Miso.Html.Internal+   , module Miso.Html.Types    , module Miso.Html.Property    ) where  import Miso.Html.Element hiding (style_) import Miso.Html.Event-import Miso.Html.Internal hiding (textRaw)+import Miso.Html.Types hiding (textRaw) import Miso.Html.Property hiding (form_)

@@ -134,7 +134,7 @@     , menu_     ) where -import           Miso.Html.Internal+import           Miso.Html.Types import           Miso.String (MisoString)  -- | Used to construct `VNode`'s in `View`

@@ -57,7 +57,7 @@   , onDrop   ) where -import Miso.Html.Internal ( Attribute, on, onWithOptions )+import Miso.Html.Types ( Attribute, on, onWithOptions ) import Miso.Event import Miso.String (MisoString) 

@@ -86,6 +86,7 @@    , height_    , width_    , alt_+   , loading_    -- * Audio and Video    , autoplay_    , controls_@@ -118,9 +119,10 @@    , scoped_    -- * Data    , data_+   , styleInline_    ) where -import           Miso.Html.Internal+import           Miso.Html.Types import           Miso.String (MisoString, intercalate)  #if __GLASGOW_HASKELL__ < 841@@ -293,6 +295,9 @@ -- | <https://developer.mozilla.org/en-US/docs/Mozilla/Tech/XUL/Attribute/alt> alt_ ::  MisoString -> Attribute action alt_               = textProp "alt"+-- | <https://developer.mozilla.org/en-US/docs/Mozilla/Tech/XUL/Attribute/loading>+loading_ ::  MisoString -> Attribute action+loading_           = textProp "loading" -- | <https://developer.mozilla.org/en-US/docs/Mozilla/Tech/XUL/Attribute/autoplay> autoplay_ ::  Bool -> Attribute action autoplay_          = boolProp "autoplay"@@ -398,3 +403,10 @@ -- https://developer.mozilla.org/en-US/docs/Web/HTML/Global_attributes/data-* data_ ::  MisoString -> MisoString -> Attribute action data_ k v = textProp ("data-" <> k) v+-- | Set "style" property+--+-- > view m = div_ [ styleInline_ "background-color:red;color:blue;" ] [ "foo" ]+--+-- https://developer.mozilla.org/en-US/docs/Web/CSS+styleInline_ ::  MisoString -> Attribute action+styleInline_ = textProp "style"

@@ -0,0 +1,421 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}++module Miso.Html.Types (+    -- * Core types and interface+      VTree  (..)+    , View   (..)+    , ToView (..)+    -- * `View` runner+    , runView+    -- * Smart `View` constructors+    , node+    , text+    , textRaw+    , rawHtml+    -- * Core types and interface+    , Attribute (..)+    -- * Key patch internals+    , Key    (..)+    , ToKey  (..)+    -- * Namespace+    , NS(..)+    -- * Setting properties on virtual DOM nodes+    , prop+    -- * Setting css+    , style_+    -- * Handling events+    , on+    , onWithOptions+    -- * Life cycle events+    , onCreated+    , onDestroyed+    , onBeforeDestroyed+    ) where++import           Control.Monad              (forM_, (<=<), guard)+import           Control.Monad.IO.Class     (liftIO)+import           Data.Aeson                 (ToJSON, Value, toJSON)+import qualified Data.Aeson                 as A+import           Data.Aeson.Types           (parseEither)+import           Data.JSString              (JSString)+import qualified Data.Map                   as M+import           Data.Proxy                 (Proxy(Proxy))+import           Data.String                (IsString, fromString)+import qualified Data.Text                  as T+import           GHCJS.Marshal              (ToJSVal, fromJSVal, toJSVal)+import           GHCJS.Types                (jsval)+import qualified JavaScript.Array           as JSArray+import           JavaScript.Object          (create, getProp)+import           JavaScript.Object.Internal (Object(Object))+import qualified Lucid                      as L+import qualified Lucid.Base                 as L+import           Prelude                    hiding (null)+import           Servant.API                (Get, HasLink, MkLink, toLink)+import           Text.HTML.TagSoup.Tree     (parseTree, TagTree(..))+import           Text.HTML.TagSoup          (Tag(..))++import           Miso.Effect+import           Miso.Event+import           Miso.FFI+import           Miso.String hiding (reverse)++-- | Core type for constructing a `VTree`, use this instead of `VTree` directly.+data View action+    = Node NS MisoString (Maybe Key) [Attribute action] [View action]+    | Text MisoString+    | TextRaw MisoString+    deriving Functor++-- | For constructing type-safe links+instance HasLink (View a) where+#if MIN_VERSION_servant(0,14,0)+  type MkLink (View a) b = MkLink (Get '[] ()) b+  toLink toA Proxy = toLink toA (Proxy :: Proxy (Get '[] ()))+#else+  type MkLink (View a) = MkLink (Get '[] ())+  toLink _ = toLink (Proxy :: Proxy (Get '[] ()))+#endif++-- | Convenience class for using View+class ToView v where toView :: v -> View action++-- | Create a new @Miso.Html.Types.TextRaw@.+--+-- @expandable@+-- a 'rawHtml' node takes raw HTML and attempts to convert it to a 'VTree'+-- at runtime. This is a way to dynamically populate the virtual DOM from+-- HTML received at runtime. If rawHtml cannot parse the HTML it will not render.+rawHtml+  :: MisoString+  -> View action+rawHtml = TextRaw+++-- | Create a new @Miso.Html.Types.Node@.+--+-- @node ns tag key attrs children@ creates a new node with tag @tag@+-- and 'Key' @key@ in the namespace @ns@. All @attrs@ are called when+-- the node is created and its children are initialized to @children@.+node :: NS+     -> MisoString+     -> Maybe Key+     -> [Attribute action]+     -> [View action]+     -> View action+node = Node++-- | Create a new @Text@ with the given content.+text :: MisoString -> View action+text = Text++-- | `TextRaw` creation. Don't use directly+textRaw :: MisoString -> View action+textRaw = TextRaw++-- | `IsString` instance+instance IsString (View a) where+  fromString = text . fromString++-- | Converting `View` to Lucid's `L.Html`+instance L.ToHtml (View action) where+  toHtmlRaw = L.toHtml+  toHtml (Node _ vType _ attrs vChildren) = L.with ele lattrs+    where+      noEnd = ["img", "input", "br", "hr", "meta"]+      tag = toTag $ fromMisoString vType+      ele = if tag `elem` noEnd+          then L.makeElementNoEnd tag+          else L.makeElement tag kids+      classes = T.intercalate " " [ v | P "class" (A.String v) <- attrs ]+      propClass = M.fromList $ attrs >>= \case+          P k v -> [(k, v)]+          E _ -> []+          S m -> [("style", A.String . fromMisoString $ M.foldrWithKey go mempty m)]+            where+              go :: MisoString -> MisoString -> MisoString -> MisoString+              go k v ys = mconcat [ k, ":", v, ";" ] <> ys+      xs = if not (T.null classes)+          then M.insert "class" (A.String classes) propClass+          else propClass+      lattrs = [ L.makeAttribute k' (if k `elem` exceptions && v == A.Bool True then k' else v')+               | (k,v) <- M.toList xs+               , let k' = fromMisoString k+               , let v' = toHtmlFromJSON v+               , not (k `elem` exceptions && v == A.Bool False)+               ]+      exceptions = [ "checked"+                   , "disabled"+                   , "selected"+                   , "hidden"+                   , "readOnly"+                   , "autoplay"+                   , "required"+                   , "default"+                   , "autofocus"+                   , "multiple"+                   , "noValidate"+                   , "autocomplete"+                   ]+      toTag = T.toLower+      kids = foldMap L.toHtml $ collapseSiblingTextNodes vChildren+  toHtml (Text x) | null x = L.toHtml (" " :: T.Text)+                  | otherwise = L.toHtml (fromMisoString x :: T.Text)+  toHtml (TextRaw x)+    | null x = L.toHtml (" " :: T.Text)+    | otherwise = L.toHtmlRaw (fromMisoString x :: T.Text)++collapseSiblingTextNodes :: [View a] -> [View a]+collapseSiblingTextNodes [] = []+collapseSiblingTextNodes (Text x : Text y : xs) =+  collapseSiblingTextNodes (Text (x <> y) : xs)+-- TextRaw is the only child, so no need to collapse.+collapseSiblingTextNodes (x:xs) =+  x : collapseSiblingTextNodes xs++-- | Helper for turning JSON into Text+-- Object, Array and Null are kind of non-sensical here+toHtmlFromJSON :: Value -> T.Text+toHtmlFromJSON (A.String t) = t+toHtmlFromJSON (A.Number t) = T.pack (show t)+toHtmlFromJSON (A.Bool b) = if b then "true" else "false"+toHtmlFromJSON A.Null = "null"+toHtmlFromJSON (A.Object o) = T.pack (show o)+toHtmlFromJSON (A.Array a) = T.pack (show a)++-- | Virtual DOM implemented as a JavaScript `Object`.+--   Used for diffing, patching and event delegation.+--   Not meant to be constructed directly, see `View` instead.+newtype VTree = VTree { getTree :: Object }++runView :: View action -> Sink action -> JSM VTree+runView (Node ns tag key attrs kids) sink = do+  vnode <- create+  cssObj <- objectToJSVal =<< create+  propsObj <- objectToJSVal =<< create+  eventObj <- objectToJSVal =<< create+  set "css" cssObj vnode+  set "props" propsObj vnode+  set "events" eventObj vnode+  set "type" ("vnode" :: JSString) vnode+  set "ns" ns vnode+  set "tag" tag vnode+  set "key" key vnode+  setAttrs vnode+  flip (set "children") vnode+    =<< ghcjsPure . jsval+    =<< setKids+  pure $ VTree vnode+    where+      setAttrs vnode =+        forM_ attrs $ \case+          P k v -> do+            val <- toJSVal v+            o <- getProp "props" vnode+            set k val (Object o)+          E attr -> attr sink vnode+          S m -> do+            cssObj <- getProp "css" vnode+            forM_ (M.toList m) $ \(k,v) -> do+              set k v (Object cssObj)+      setKids = do+        kidsViews <- traverse (objectToJSVal . getTree <=< flip runView sink) kids+        ghcjsPure (JSArray.fromList kidsViews)+runView (Text t) _ = do+  vtree <- create+  set "type" ("vtext" :: JSString) vtree+  set "text" t vtree+  pure $ VTree vtree+runView (TextRaw str) sink =+  case parseView str of+    [] ->+      runView (Text (" " :: MisoString)) sink+    [parent] ->+      runView parent sink+    kids -> do+      runView (Node HTML "div" Nothing mempty kids) sink++-- Filters tree to only branches and leaves w/ Text tags.+-- converts to View a. Note: if HTML is malformed,+-- (e.g. closing tags and opening tags are present) they will+-- be removed.+parseView :: MisoString -> [View a]+parseView html = reverse (go (parseTree html) [])+  where+    go [] xs = xs+    go (TagLeaf (TagText s) : next) views =+      go next (Text s : views)+    go (TagBranch name attrs kids : next) views =+      let+        attrs' = [ P key $ A.String (fromMisoString val)+                 | (key, val) <- attrs+                 ]+        newNode =+          Node HTML name Nothing attrs' (reverse (go kids []))+      in+        go next (newNode:views)+    go (TagLeaf _ : next) views =+      go next views++-- | Namespace of DOM elements.+data NS+  = HTML -- ^ HTML Namespace+  | SVG  -- ^ SVG Namespace+  | MATHML  -- ^ MATHML Namespace+  deriving (Show, Eq)++instance ToJSVal NS where+  toJSVal SVG  = toJSVal ("svg" :: JSString)+  toJSVal HTML = toJSVal ("html" :: JSString)+  toJSVal MATHML = toJSVal ("mathml" :: JSString)++-- | A unique key for a dom node.+--+-- This key is only used to speed up diffing the children of a DOM+-- node, the actual content is not important. The keys of the children+-- of a given DOM node must be unique. Failure to satisfy this+-- invariant gives undefined behavior at runtime.+newtype Key = Key MisoString++instance ToJSVal Key where toJSVal (Key x) = toJSVal x++-- | Convert custom key types to `Key`.+--+-- Instances of this class do not have to guarantee uniqueness of the+-- generated keys, it is up to the user to do so. `toKey` must be an+-- injective function.+class ToKey key where toKey :: key -> Key+-- | Identity instance+instance ToKey Key where toKey = id+-- | Convert `MisoString` to `Key`+instance ToKey JSString where toKey = Key . toMisoString+-- | Convert `T.Text` to `Key`+instance ToKey T.Text where toKey = Key . toMisoString+-- | Convert `String` to `Key`+instance ToKey String where toKey = Key . toMisoString+-- | Convert `Int` to `Key`+instance ToKey Int where toKey = Key . toMisoString+-- | Convert `Double` to `Key`+instance ToKey Double where toKey = Key . toMisoString+-- | Convert `Float` to `Key`+instance ToKey Float where toKey = Key . toMisoString+-- | Convert `Word` to `Key`+instance ToKey Word where toKey = Key . toMisoString++-- | Attribute of a vnode in a `View`.+--+-- The 'Sink' callback can be used to dispatch actions which are fed back to+-- the @update@ function. This is especially useful for event handlers+-- like the @onclick@ attribute. The second argument represents the+-- vnode the attribute is attached to.+data Attribute action+    = P MisoString Value+    | E (Sink action -> Object -> JSM ())+    | S (M.Map MisoString MisoString)+    deriving Functor++-- | @prop k v@ is an attribute that will set the attribute @k@ of the DOM node associated with the vnode+-- to @v@.+prop :: ToJSON a => MisoString -> a -> Attribute action+prop k v = P k (toJSON v)++-- | Convenience wrapper for @onWithOptions defaultOptions@.+--+-- > let clickHandler = on "click" emptyDecoder $ \() -> Action+-- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ]+--+on :: MisoString+   -> Decoder r+   -> (r -> action)+   -> Attribute action+on = onWithOptions defaultOptions++-- | @onWithOptions opts eventName decoder toAction@ is an attribute+-- that will set the event handler of the associated DOM node to a function that+-- decodes its argument using @decoder@, converts it to an action+-- using @toAction@ and then feeds that action back to the @update@ function.+--+-- @opts@ can be used to disable further event propagation.+--+-- > let clickHandler = onWithOptions defaultOptions "click" emptyDecoder $ \() -> Action+-- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ]+--+onWithOptions+  :: Options+  -> MisoString+  -> Decoder r+  -> (r -> action)+  -> Attribute action+onWithOptions options eventName Decoder{..} toAction =+  E $ \sink n -> do+   eventObj <- getProp "events" n+   eventHandlerObject@(Object eo) <- create+   jsOptions <- toJSVal options+   decodeAtVal <- toJSVal decodeAt+   cb <- callbackToJSVal <=< asyncCallback1 $ \e -> do+       Just v <- fromJSVal =<< objectToJSON decodeAtVal e+       case parseEither decoder v of+         Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s+         Right r -> liftIO (sink (toAction r))+   set "runEvent" cb eventHandlerObject+   registerCallback cb+   set "options" jsOptions eventHandlerObject+   set eventName eo (Object eventObj)++-- | @onCreated action@ is an event that gets called after the actual DOM+-- element is created.+--+-- Important note: Any node that uses this event MUST have a unique @Key@,+-- otherwise the event may not be reliably called!+onCreated :: action -> Attribute action+onCreated action =+  E $ \sink n -> do+    cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action))+    set "onCreated" cb n+    registerCallback cb++-- | @onDestroyed action@ is an event that gets called after the DOM element+-- is removed from the DOM. The @action@ is given the DOM element that was+-- removed from the DOM tree.+--+-- Important note: Any node that uses this event MUST have a unique @Key@,+-- otherwise the event may not be reliably called!+onDestroyed :: action -> Attribute action+onDestroyed action =+  E $ \sink n -> do+    cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action))+    set "onDestroyed" cb n+    registerCallback cb++-- | @onBeforeDestroyed action@ is an event that gets called before the DOM element+-- is removed from the DOM. The @action@ is given the DOM element that was+-- removed from the DOM tree.+--+-- Important note: Any node that uses this event MUST have a unique @Key@,+-- otherwise the event may not be reliably called!+onBeforeDestroyed :: action -> Attribute action+onBeforeDestroyed action =+  E $ \sink n -> do+    cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action))+    set "onBeforeDestroyed" cb n+    registerCallback cb++-- | @style_ attrs@ is an attribute that will set the @style@+-- attribute of the associated DOM node to @attrs@.+--+-- @style@ attributes not contained in @attrs@ will be deleted.+--+-- > import qualified Data.Map as M+-- > div_ [ style_  $ M.singleton "background" "red" ] [ ]+--+-- <https://developer.mozilla.org/en-US/docs/Web/CSS>+--+style_ :: M.Map MisoString MisoString -> Attribute action+style_ = S

@@ -0,0 +1,1 @@+module Miso.JSBits where

@@ -14,7 +14,7 @@       nodeMathml   ) where -import           Miso.Html.Internal+import           Miso.Html.Types import           Miso.String (MisoString) import qualified Prelude            as P 

@@ -166,6 +166,7 @@   -> Either RoutingError a route layout handler u = runRouteLoc (uriToLocation u) layout handler +-- | Executes router runRoute   :: HasRouter layout   => Proxy layout

@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Subscription+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Subscription+  ( module Miso.Subscription.Mouse+  , module Miso.Subscription.Keyboard+  , module Miso.Subscription.History+  , module Miso.Subscription.Window+  , module Miso.Subscription.WebSocket+  , module Miso.Subscription.SSE+  ) where++import Miso.Subscription.Mouse+import Miso.Subscription.Keyboard+import Miso.Subscription.History+import Miso.Subscription.Window+import Miso.Subscription.WebSocket+import Miso.Subscription.SSE

@@ -0,0 +1,107 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeOperators     #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Subscription.History+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Subscription.History+  ( getCurrentURI+  , pushURI+  , replaceURI+  , back+  , forward+  , go+  , uriSub+  , URI (..)+  ) where++import Control.Monad+import Control.Monad.IO.Class+import Miso.Concurrent+import Miso.Effect (Sub)+import Miso.FFI+import qualified Miso.FFI.History as FFI+import Miso.String+import Network.URI hiding (path)+import System.IO.Unsafe++-- | Retrieves current URI of page+getCurrentURI :: JSM URI+{-# INLINE getCurrentURI #-}+getCurrentURI = getURI++-- | Retrieves current URI of page+getURI :: JSM URI+{-# INLINE getURI #-}+getURI = do+  href <- fromMisoString <$> FFI.getWindowLocationHref+  case parseURI href of+    Nothing  -> fail $ "Could not parse URI from window.location: " ++ href+    Just uri -> return uri++-- | Pushes a new URI onto the History stack+pushURI :: URI -> JSM ()+{-# INLINE pushURI #-}+pushURI uri = pushStateNoModel uri { uriPath = toPath uri }++-- | Prepend '/' if necessary+toPath :: URI -> String+toPath uri =+  case uriPath uri of+    "" -> "/"+    "/" -> "/"+    xs@('/' : _) -> xs+    xs -> '/' : xs++-- | Replaces current URI on stack+replaceURI :: URI -> JSM ()+{-# INLINE replaceURI #-}+replaceURI uri = replaceTo' uri { uriPath = toPath uri }++-- | Navigates backwards+back :: JSM ()+{-# INLINE back #-}+back = FFI.back++-- | Navigates forwards+forward :: JSM ()+{-# INLINE forward #-}+forward = FFI.forward++-- | Jumps to a specific position in history+go :: Int -> JSM ()+{-# INLINE go #-}+go n = FFI.go n++chan :: Notify+{-# NOINLINE chan #-}+chan = unsafePerformIO newEmptyNotify++-- | Subscription for @popstate@ events, from the History API+uriSub :: (URI -> action) -> Sub action+uriSub = \f sink -> do+  void.forkJSM.forever $ do+    liftIO (wait chan)+    liftIO . sink . f =<< getURI+  windowAddEventListener "popstate" $ \_ ->+      liftIO . sink . f =<< getURI++pushStateNoModel :: URI -> JSM ()+{-# INLINE pushStateNoModel #-}+pushStateNoModel u = do+  FFI.pushState . pack . show $ u+  liftIO (notify chan)++replaceTo' :: URI -> JSM ()+{-# INLINE replaceTo' #-}+replaceTo' u = do+  FFI.replaceState . pack . show $ u+  liftIO (notify chan)

@@ -0,0 +1,106 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE OverloadedStrings   #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Subscription.Keyboard+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Subscription.Keyboard+  ( -- * Types+    Arrows (..)+    -- * Subscriptions+  , arrowsSub+  , directionSub+  , keyboardSub+  , wasdSub+  ) where++import           Control.Monad.IO.Class+import           Data.IORef+import           Data.Set+import qualified Data.Set as S+import           GHCJS.Marshal+import           JavaScript.Object+import           JavaScript.Object.Internal++import           Miso.Effect (Sub)+import           Miso.FFI++-- | type for arrow keys currently pressed+--  37 left arrow  ( x = -1 )+--  38 up arrow    ( y =  1 )+--  39 right arrow ( x =  1 )+--  40 down arrow  ( y = -1 )+data Arrows = Arrows {+   arrowX :: !Int+ , arrowY :: !Int+ } deriving (Show, Eq)++-- | Helper function to convert keys currently pressed to `Arrow`, given a+-- mapping for keys representing up, down, left and right respectively.+toArrows :: ([Int], [Int], [Int], [Int]) -> Set Int -> Arrows+toArrows (up, down, left, right) set' =+  Arrows {+    arrowX =+      case (check left, check right) of+        (True, False) -> -1+        (False, True) -> 1+        (_,_) -> 0+  , arrowY =+      case (check down, check up) of+        (True, False) -> -1+        (False, True) -> 1+        (_,_) -> 0+  }+  where+    check = any (`S.member` set')++-- | Maps `Arrows` onto a Keyboard subscription+arrowsSub :: (Arrows -> action) -> Sub action+arrowsSub = directionSub ([38], [40], [37], [39])++-- | Maps `WASD` onto a Keyboard subscription for directions+wasdSub :: (Arrows -> action) -> Sub action+wasdSub = directionSub ([87], [83], [65], [68])++-- | Maps a specified list of keys to directions (up, down, left, right)+directionSub :: ([Int], [Int], [Int], [Int])+             -> (Arrows -> action)+             -> Sub action+directionSub dirs = keyboardSub . (. toArrows dirs)++-- | Returns subscription for Keyboard+keyboardSub :: (Set Int -> action) -> Sub action+keyboardSub f sink = do+  keySetRef <- liftIO (newIORef mempty)+  windowAddEventListener "keyup" $ keyUpCallback keySetRef+  windowAddEventListener "keydown" $ keyDownCallback keySetRef+  windowAddEventListener "blur" $ blurCallback keySetRef+    where+      keyDownCallback keySetRef = \keyDownEvent -> do+          Just key <- fromJSVal =<< getProp "keyCode" (Object keyDownEvent)+          newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \keys ->+             let !new = S.insert key keys+             in (new, new)+          liftIO (sink (f newKeys))++      keyUpCallback keySetRef = \keyUpEvent -> do+          Just key <- fromJSVal =<< getProp "keyCode" (Object keyUpEvent)+          newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \keys ->+             let !new = S.delete key keys+             in (new, new)+          liftIO (sink (f newKeys))++      -- Assume keys are released the moment focus is lost. Otherwise going+      -- back and forth to the app can cause keys to get stuck.+      blurCallback keySetRef = \_ -> do+          newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \_ ->+            let !new = S.empty+            in (new, new)+          liftIO (sink (f newKeys))

@@ -0,0 +1,30 @@+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Subscription.Mouse+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Subscription.Mouse (mouseSub) where++import Control.Monad.IO.Class+import GHCJS.Marshal+import JavaScript.Object+import JavaScript.Object.Internal++import Miso.Effect (Sub)+import Miso.FFI++-- | Captures mouse coordinates as they occur and writes them to+-- an event sink+mouseSub :: ((Int,Int) -> action) -> Sub action+mouseSub f = \sink -> do+  windowAddEventListener "mousemove" $+    \mouseEvent -> do+      Just x <- fromJSVal =<< getProp "clientX" (Object mouseEvent)+      Just y <- fromJSVal =<< getProp "clientY" (Object mouseEvent)+      liftIO (sink $ f (x,y))

@@ -0,0 +1,49 @@+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Subscription.SSE+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Subscription.SSE+ ( -- * Subscription+   sseSub+   -- * Types+ , SSE (..)+ ) where++import           Control.Monad.IO.Class+import           Data.Aeson+import           Miso.Effect (Sub)+import           Miso.FFI+import           Miso.String++import qualified Miso.FFI.SSE as SSE++-- | Server-sent events Subscription+sseSub :: FromJSON msg => MisoString -> (SSE msg -> action) -> Sub action+sseSub url f = \sink -> do+  es <- SSE.new url+  SSE.addEventListener es "message" $ \val -> do+    dat <- parse =<< SSE.data' val+    (liftIO . sink) (f (SSEMessage dat))+  SSE.addEventListener es "error" $ \_ ->+    (liftIO . sink) (f SSEError)+  SSE.addEventListener es "close" $ \_ ->+    (liftIO . sink) (f SSEClose)++-- | Server-sent events data+data SSE message+  = SSEMessage message+  | SSEClose+  | SSEError+  deriving (Show, Eq)++-- | Test URL+-- http://sapid.sourceforge.net/ssetest/webkit.events.php+-- var source = new EventSource("demo_sse.php");

@@ -0,0 +1,168 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP                        #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Subscription.WebSocket+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Subscription.WebSocket+  ( -- * Types+    WebSocket   (..)+  , URL         (..)+  , Protocols   (..)+  , SocketState (..)+  , CloseCode   (..)+  , WasClean    (..)+  , Reason      (..)+    -- * Subscription+  , websocketSub+  , send+  , close+  , connect+  , getSocketState+  ) where++import           Control.Concurrent+import           Control.Monad+import           Control.Monad.IO.Class+import           Data.Aeson+import           Data.IORef+import           Data.Maybe+import           GHCJS.Marshal+import           GHCJS.Foreign+import           GHCJS.Types ()+import           Prelude hiding (map)+import           System.IO.Unsafe++import           Miso.Effect (Sub)+import           Miso.FFI+import           Miso.FFI.WebSocket (Socket)+import qualified Miso.FFI.WebSocket as WS+import           Miso.String+import           Miso.WebSocket++websocket :: IORef (Maybe Socket)+{-# NOINLINE websocket #-}+websocket = unsafePerformIO (newIORef Nothing)++closedCode :: IORef (Maybe CloseCode)+{-# NOINLINE closedCode #-}+closedCode = unsafePerformIO (newIORef Nothing)++secs :: Int -> Int+secs = (*1000000)++-- | WebSocket subscription+websocketSub+  :: FromJSON m+  => URL+  -> Protocols+  -> (WebSocket m -> action)+  -> Sub action+websocketSub (URL u) (Protocols ps) f sink = do+  socket <- createWebSocket u ps+  liftIO (writeIORef websocket (Just socket))+  void . forkJSM $ handleReconnect+  WS.addEventListener socket "open" $ \_ -> liftIO $ do+    writeIORef closedCode Nothing+    sink (f WebSocketOpen)+  WS.addEventListener socket "message" $ \v -> do+    d <- parse =<< WS.data' v+    liftIO . sink $ f (WebSocketMessage d)+  WS.addEventListener socket "close" $ \e -> do+    code <- codeToCloseCode <$> WS.code e+    liftIO (writeIORef closedCode (Just code))+    reason <- WS.reason e+    clean <- WS.wasClean e+    liftIO . sink $ f (WebSocketClose code clean reason)+  WS.addEventListener socket "error" $ \v -> do+    liftIO (writeIORef closedCode Nothing)+    d' <- WS.data' v+#ifndef __GHCJS__        +    undef <- ghcjsPure (isUndefined d')+#else+    let undef = isUndefined d'+#endif+    if undef+      then do+         liftIO . sink $ f (WebSocketError mempty)+      else do+         Just d <- fromJSVal d'+         liftIO . sink $ f (WebSocketError d)+  where+    handleReconnect = do+      liftIO (threadDelay (secs 3))+      Just s <- liftIO (readIORef websocket)+      status <- WS.socketState s+      code <- liftIO (readIORef closedCode)+      if status == 3+        then do+          unless (code == Just CLOSE_NORMAL) $+            websocketSub (URL u) (Protocols ps) f sink+        else handleReconnect++-- | Sends message to a websocket server+send :: ToJSON a => a -> JSM ()+{-# INLINE send #-}+send x = do+  Just socket <- liftIO (readIORef websocket)+  sendJson' socket x++-- | Sends message to a websocket server+close :: JSM ()+{-# INLINE close #-}+close =+  mapM_ WS.close =<<+    liftIO (readIORef websocket)++-- | Connects to a websocket server+connect :: URL -> Protocols -> JSM ()+{-# INLINE connect #-}+connect (URL url') (Protocols ps) = do+  Just ws <- liftIO (readIORef websocket)+  s <- WS.socketState ws+  when (s == 3) $ do+    socket <- createWebSocket url' ps+    liftIO (atomicWriteIORef websocket (Just socket))++-- | Retrieves current status of `WebSocket`+getSocketState :: JSM SocketState+getSocketState = do+  Just ws <- liftIO (readIORef websocket)+  toEnum <$> WS.socketState ws++sendJson' :: ToJSON json => Socket -> json -> JSM ()+sendJson' socket m = WS.send socket =<< stringify m++createWebSocket :: MisoString -> [MisoString] -> JSM Socket+{-# INLINE createWebSocket #-}+createWebSocket url' protocols =+  WS.create url' =<< toJSVal protocols++codeToCloseCode :: Int -> CloseCode+codeToCloseCode = go+  where+    go 1000 = CLOSE_NORMAL+    go 1001 = CLOSE_GOING_AWAY+    go 1002 = CLOSE_PROTOCOL_ERROR+    go 1003 = CLOSE_UNSUPPORTED+    go 1005 = CLOSE_NO_STATUS+    go 1006 = CLOSE_ABNORMAL+    go 1007 = Unsupported_Data+    go 1008 = Policy_Violation+    go 1009 = CLOSE_TOO_LARGE+    go 1010 = Missing_Extension+    go 1011 = Internal_Error+    go 1012 = Service_Restart+    go 1013 = Try_Again_Later+    go 1015 = TLS_Handshake+    go n    = OtherCode n

@@ -0,0 +1,58 @@+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Subscription.Window+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Subscription.Window where++import Control.Monad+import Control.Monad.IO.Class++import GHCJS.Marshal+import JavaScript.Object+import JavaScript.Object.Internal++import Miso.Effect (Sub)+import Miso.Event+import Miso.FFI+import Miso.String++import Data.Aeson.Types (parseEither)++-- | Captures window coordinates changes as they occur and writes them to+-- an event sink+windowCoordsSub :: ((Int, Int) -> action) -> Sub action+windowCoordsSub f = \sink -> do+  liftIO . sink . f =<< (,) <$> windowInnerHeight <*> windowInnerWidth+  windowAddEventListener "resize" $+    \windowEvent -> do+      target <- getProp "target" (Object windowEvent)+      Just w <- fromJSVal =<< getProp "innerWidth" (Object target)+      Just h <- fromJSVal =<< getProp "innerHeight" (Object target)+      liftIO . sink $ f (h, w)++-- | @windowSub eventName decoder toAction@ is a subscription which parallels the+-- attribute handler `on`, providing a subscription to listen to window level events.+windowSub :: MisoString -> Decoder r -> (r -> action) -> Sub action+windowSub  = windowSubWithOptions defaultOptions++-- | @windowSubWithOptions options eventName decoder toAction@ is a subscription which parallels the+-- attribute handler `on`, providing a subscription to listen to window level events.+windowSubWithOptions :: Options -> MisoString -> Decoder r -> (r -> action) -> Sub action+windowSubWithOptions Options{..} eventName Decoder{..} toAction = \sink -> do+  windowAddEventListener eventName $+    \e -> do+      decodeAtVal <- toJSVal decodeAt+      Just v <- fromJSVal =<< objectToJSON decodeAtVal e+      case parseEither decoder v of+        Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s+        Right r -> do+          when stopPropagation $ eventStopPropagation e+          when preventDefault $ eventPreventDefault e+          liftIO (sink (toAction r))

@@ -270,7 +270,7 @@   , writingMode_   ) where -import Miso.Html.Internal ( Attribute )+import Miso.Html.Types ( Attribute ) import Miso.Html.Property ( textProp ) import Miso.String        ( MisoString ) 

@@ -103,7 +103,7 @@   , view_   ) where -import           Miso.Html.Internal hiding (style_)+import           Miso.Html.Types hiding (style_) import           Miso.String        (MisoString) import qualified Prelude            as P 

@@ -39,7 +39,7 @@  import Miso.Event  import Miso.Html.Event (onClick)-import Miso.Html.Internal+import Miso.Html.Types  -- | onBegin event onBegin :: action -> Attribute action

@@ -0,0 +1,19 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+module Miso.TypeLevel ( ToServerRoutes ) where++import Miso.Html+import Servant.API+import Servant.HTML.Lucid++-- | Convert client route type to a server web handler type+type family ToServerRoutes (layout :: k) (wrapper :: * -> *) (action :: *) :: k where+  ToServerRoutes (a :<|> b) wrapper action =+    ToServerRoutes a wrapper action :<|>+      ToServerRoutes b wrapper action+  ToServerRoutes (a :> b) wrapper action =+    a :> ToServerRoutes b wrapper action+  ToServerRoutes (View a) wrapper action =+    Get '[HTML] (wrapper (View action))

@@ -0,0 +1,149 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Types+-- Copyright   :  (C) 2016-2018 David M. Johnson+-- License     :  BSD3-style (see the file LICENSE)+-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+----------------------------------------------------------------------------+module Miso.Types+  ( App (..)+  , LogLevel (..)+  , Effect+  , Sub++    -- * The Transition Monad+  , Transition+  , mapAction+  , fromTransition+  , toTransition+  , scheduleIO+  , scheduleIO_+  , scheduleIOFor_+  , scheduleSub+  ) where++import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class (lift)+import           Control.Monad.Trans.State.Strict (StateT(StateT), execStateT, mapStateT)+import           Control.Monad.Trans.Writer.Strict (WriterT(WriterT), Writer, runWriter, tell, mapWriter)+import           Data.Bifunctor (second)+import           Data.Foldable (Foldable, for_)+import qualified Data.Map as M+import           Miso.Effect+import           Miso.FFI (JSM)+import           Miso.Html.Types (View)+import           Miso.String++-- | Application entry point+data App model action = App+  { model :: model+  -- ^ initial model+  , update :: action -> model -> Effect action model+  -- ^ Function to update model, optionally providing effects.+  --   See the 'Transition' monad for succinctly expressing model transitions.+  , view :: model -> View action+  -- ^ Function to draw `View`+  , subs :: [ Sub action ]+  -- ^ List of subscriptions to run during application lifetime+  , events :: M.Map MisoString Bool+  -- ^ List of delegated events that the body element will listen for.+  --   You can start with 'Miso.Event.Types.defaultEvents' and modify as needed.+  , initialAction :: action+  -- ^ Initial action that is run after the application has loaded+  , mountPoint :: Maybe MisoString+  -- ^ Id of the root element for DOM diff. If 'Nothing' is provided, the entire document body is used as a mount point.+  , logLevel :: LogLevel+  -- ^ Display warning messages when prerendering if the DOM and VDOM are not in sync.+  }++-- | Optional Logging for debugging miso internals (useful to see if prerendering is successful)+data LogLevel+  = Off+  | DebugPrerender+  deriving (Show, Eq)++-- | A monad for succinctly expressing model transitions in the 'update' function.+--+-- @Transition@ is a state monad so it abstracts over manually passing the model+-- around. It's also a writer monad where the accumulator is a list of scheduled+-- IO actions. Multiple actions can be scheduled using+-- @Control.Monad.Writer.Class.tell@ from the @mtl@ library and a single action+-- can be scheduled using 'scheduleIO'.+--+-- Tip: use the @Transition@ monad in combination with the stateful+-- <http://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Operators.html lens>+-- operators (all operators ending in "@=@"). The following example assumes+-- the lenses @field1@, @counter@ and @field2@ are in scope and that the+-- @LambdaCase@ language extension is enabled:+--+-- @+-- myApp = App+--   { update = 'fromTransition' . \\case+--       MyAction1 -> do+--         field1 .= value1+--         counter += 1+--       MyAction2 -> do+--         field2 %= f+--         scheduleIO $ do+--           putStrLn \"Hello\"+--           putStrLn \"World!\"+--   , ...+--   }+-- @+type Transition action model = StateT model (Writer [Sub action])++-- | Turn a transition that schedules subscriptions that consume+-- actions of type @a@ into a transition that schedules subscriptions+-- that consume actions of type @b@ using the supplied function of+-- type @a -> b@.+mapAction :: (actionA -> actionB) -> Transition actionA model r -> Transition actionB model r+mapAction = mapStateT . mapWriter . second . fmap . mapSub++-- | Convert a @Transition@ computation to a function that can be given to 'update'.+fromTransition+    :: Transition action model ()+    -> (model -> Effect action model) -- ^ model 'update' function.+fromTransition act = uncurry Effect . runWriter . execStateT act++-- | Convert an 'update' function to a @Transition@ computation.+toTransition+    :: (model -> Effect action model) -- ^ model 'update' function+    -> Transition action model ()+toTransition f = StateT $ \s ->+                   let Effect s' ios = f s+                   in WriterT $ pure (((), s'), ios)++-- | Schedule a single IO action for later execution.+--+-- Note that multiple IO action can be scheduled using+-- @Control.Monad.Writer.Class.tell@ from the @mtl@ library.+scheduleIO :: JSM action -> Transition action model ()+scheduleIO ioAction = scheduleSub $ \sink -> ioAction >>= liftIO . sink++-- | Like 'scheduleIO' but doesn't cause an action to be dispatched to+-- the 'update' function.+--+-- This is handy for scheduling IO computations where you don't care+-- about their results or when they complete.+scheduleIO_ :: JSM () -> Transition action model ()+scheduleIO_ ioAction = scheduleSub $ \_sink -> ioAction++-- | Like `scheduleIO_` but generalized to any instance of `Foldable`+--+-- This is handy for scheduling IO computations that return a `Maybe` value+scheduleIOFor_ :: Foldable f => JSM (f action) -> Transition action model ()+scheduleIOFor_ io = scheduleSub $ \sink -> io >>= \m -> liftIO (for_ m sink)++-- | Like 'scheduleIO' but schedules a subscription which is an IO+-- computation that has access to a 'Sink' which can be used to+-- asynchronously dispatch actions to the 'update' function.+--+-- A use-case is scheduling an IO computation which creates a+-- 3rd-party JS widget which has an associated callback. The callback+-- can then call the sink to turn events into actions. To do this+-- without accessing a sink requires going via a @'Sub'scription@+-- which introduces a leaky-abstraction.+scheduleSub :: Sub action -> Transition action model ()+scheduleSub sub = lift $ tell [ sub ]