miso 0.21.1.0 → 0.21.2.0

raw patch · 71 files changed

+2897/−2396 lines, 71 filesdep +file-embeddep +jsaddledep +jsaddle-warpnew-component:exe:mathmlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: file-embed, jsaddle, jsaddle-warp, wai, wai-app-static, warp, websockets

API changes (from Hackage documentation)

Files

• examples/file-reader/Main.hs +0/−3
• examples/mario/Main.hs +28/−3
• examples/mario/index.html +0/−12
• examples/mathml/Main.hs +43/−0
• examples/router/Main.hs +7/−3
• examples/three/Main.hs +0/−3
• examples/todo-mvc/Main.hs +15/−7
• examples/todo-mvc/index.html +0/−10
• examples/websocket/Main.hs +7/−4
• examples/websocket/index.html +0/−10
• exe/Main.hs +6/−2
• frontend-src/Miso.hs +152/−0
• frontend-src/Miso/Delegate.hs +32/−0
• frontend-src/Miso/Dev.hs +14/−0
• frontend-src/Miso/Diff.hs +49/−0
• frontend-src/Miso/Effect.hs +94/−0
• frontend-src/Miso/Effect/DOM.hs +17/−0
• frontend-src/Miso/Effect/Storage.hs +108/−0
• frontend-src/Miso/Html/Internal.hs +292/−0
• frontend-src/Miso/String.hs +93/−0
• frontend-src/Miso/Subscription.hs +24/−0
• frontend-src/Miso/Subscription/History.hs +107/−0
• frontend-src/Miso/Subscription/Keyboard.hs +97/−0
• frontend-src/Miso/Subscription/Mouse.hs +30/−0
• frontend-src/Miso/Subscription/SSE.hs +49/−0
• frontend-src/Miso/Subscription/WebSocket.hs +148/−0
• frontend-src/Miso/Subscription/Window.hs +56/−0
• frontend-src/Miso/Types.hs +139/−0
• ghc-src/Miso.hs +2/−0
• ghc-src/Miso/Html/Internal.hs +1/−0
• ghcjs-ffi/Miso/FFI.hs +249/−0
• ghcjs-ffi/Miso/FFI/History.hs +37/−0
• ghcjs-ffi/Miso/FFI/SSE.hs +34/−0
• ghcjs-ffi/Miso/FFI/Storage.hs +45/−0
• ghcjs-ffi/Miso/FFI/WebSocket.hs +55/−0
• ghcjs-src/Miso.hs +0/−149
• ghcjs-src/Miso/Delegate.hs +0/−41
• ghcjs-src/Miso/Dev.hs +0/−14
• ghcjs-src/Miso/Diff.hs +0/−66
• ghcjs-src/Miso/Effect.hs +0/−92
• ghcjs-src/Miso/Effect/DOM.hs +0/−33
• ghcjs-src/Miso/Effect/Storage.hs +0/−116
• ghcjs-src/Miso/Effect/XHR.hs +0/−321
• ghcjs-src/Miso/FFI.hs +0/−156
• ghcjs-src/Miso/Html/Internal.hs +0/−298
• ghcjs-src/Miso/String.hs +0/−93
• ghcjs-src/Miso/Subscription.hs +0/−24
• ghcjs-src/Miso/Subscription/History.hs +0/−128
• ghcjs-src/Miso/Subscription/Keyboard.hs +0/−99
• ghcjs-src/Miso/Subscription/Mouse.hs +0/−30
• ghcjs-src/Miso/Subscription/SSE.hs +0/−68
• ghcjs-src/Miso/Subscription/WebSocket.hs +0/−253
• ghcjs-src/Miso/Subscription/Window.hs +0/−57
• ghcjs-src/Miso/Types.hs +0/−137
• jsaddle-ffi/Miso/Dev.hs +14/−0
• jsaddle-ffi/Miso/FFI.hs +239/−0
• jsaddle-ffi/Miso/FFI/History.hs +56/−0
• jsaddle-ffi/Miso/FFI/SSE.hs +38/−0
• jsaddle-ffi/Miso/FFI/Storage.hs +54/−0
• jsaddle-ffi/Miso/FFI/WebSocket.hs +61/−0
• jsbits/delegate.js +32/−24
• jsbits/diff.js +46/−42
• jsbits/isomorphic.js +4/−5
• jsbits/util.js +2/−2
• miso.cabal +74/−26
• src/Miso/Concurrent.hs +10/−0
• src/Miso/Mathml.hs +24/−0
• src/Miso/Mathml/Element.hs +23/−0
• src/Miso/Router.hs +83/−63
• src/Miso/WebSocket.hs +106/−0
• tests/Main.hs +1/−2

@@ -76,9 +76,6 @@ foreign import javascript unsafe "$r = new FileReader();"   newReader :: IO JSVal -foreign import javascript unsafe "$r = document.getElementById($1);"-  getElementById :: MisoString -> IO JSVal- foreign import javascript unsafe "$r = $1.files[0];"   getFile :: JSVal -> IO JSVal 

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE MultiWayIf        #-}@@ -6,12 +7,33 @@  import           Data.Bool import           Data.Function-import qualified Data.Map      as M+import qualified Data.Map as M import           Data.Monoid  import           Miso import           Miso.String +import qualified Language.Javascript.JSaddle.Warp as JSaddle++#ifdef ghcjs_HOST_OS+run :: Int -> JSM () -> IO ()+run = JSaddle.run+#else+import           Network.Wai.Application.Static+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import           Network.WebSockets++run :: Int -> JSM () -> IO ()+run port f =+    Warp.runSettings (Warp.setPort port (Warp.setTimeout 3600 Warp.defaultSettings)) =<<+        JSaddle.jsaddleOr defaultConnectionOptions (f >> syncPoint) app+    where app req sendResp =+            case Wai.pathInfo req of+              ("imgs" : _) -> staticApp (defaultWebAppSettings "examples/mario") req sendResp+              _ -> JSaddle.jsaddleApp req sendResp+#endif+ data Action   = GetArrows !Arrows   | Time !Double@@ -22,7 +44,7 @@ spriteFrames = ["0 0", "-74px 0","-111px 0","-148px 0","-185px 0","-222px 0","-259px 0","-296px 0"]  main :: IO ()-main = do+main = run 8080 $ do     time <- now     let m = mario { time = time }     startApp App { model = m@@ -122,7 +144,10 @@     marioImage =       div_ [ height_ $ ms h            , width_ $ ms w-           ] [ div_ [ style_ (marioStyle m groundY) ] [] ]+           ]+           [ nodeHtml "style" [] ["@keyframes play { 100% { background-position: -296px; } }"]+           , div_ [ style_ (marioStyle m groundY) ] []+           ]  marioStyle :: Model -> Double -> M.Map MisoString MisoString marioStyle Model {..} gy =

@@ -1,12 +0,0 @@-<!DOCTYPE html>-<html>-  <head>-    <meta charset="utf-8">-    <style>-      @keyframes play { 100% { background-position: -296px; } }-    </style>-  </head>-  <body>-    <script src='all.js'></script>-  </body>-</html>

@@ -0,0 +1,43 @@++-- | Haskell language pragma+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Haskell module declaration+module Main where++-- | Miso framework import+import Miso+import Miso.String+import Miso.Mathml++data Model = Empty deriving Eq++data Action+  =  NoOp+  deriving (Show, Eq)++-- | Entry point for a miso application+main :: IO ()+main = startApp App {..}+  where+    initialAction = NoOp -- initial action to be executed on application load+    model  = Empty                -- initial model+    update = updateModel          -- update function+    view   = viewModel            -- view function+    events = defaultEvents        -- default delegated events+    subs   = []                   -- empty subscription list+    mountPoint = Nothing          -- mount point for application (Nothing defaults to 'body')++-- | Updates model, optionally introduces side effects+updateModel :: Action -> Model -> Effect Action Model+updateModel NoOp = noEff++-- | Constructs a virtual DOM from a model+viewModel :: Model -> View Action+viewModel x = nodeMathml "math" [] [+    nodeMathml "msup" [] [+        nodeMathml "mi" [] [text "x"]+        , nodeMathml "mn" [] [text "2"]+    ]+ ]

@@ -9,9 +9,12 @@  import Data.Proxy import Servant.API-#if MIN_VERSION_servant(0,10,0)+#if MIN_VERSION_servant(0,14,1)+import Servant.Links+#elif MIN_VERSION_servant(0,10,0) import Servant.Utils.Links #endif+import Language.Javascript.JSaddle.Warp as JSaddle  import Miso @@ -32,8 +35,9 @@ -- | Main entry point main :: IO () main = do-  currentURI <- getCurrentURI-  startApp App { model = Model currentURI, initialAction = NoOp, ..}+  JSaddle.run 8080 $ do+    currentURI <- getCurrentURI+    startApp App { model = Model currentURI, initialAction = NoOp, ..}   where     update = updateModel     events = defaultEvents

@@ -129,9 +129,6 @@ foreign import javascript unsafe "$1.setSize( window.innerWidth, window.innerHeight );"   setSize :: JSVal -> IO () -foreign import javascript unsafe "$r = document.getElementById($1);"-  getElementById :: MisoString -> IO JSVal- foreign import javascript unsafe "$1.add($2);"   addToScene :: JSVal -> JSVal -> IO () 

@@ -12,15 +12,18 @@ {-# LANGUAGE ExtendedDefaultRules #-} module Main where -import           Data.Aeson   hiding (Object)+import           Data.Aeson hiding (Object) import           Data.Bool-import qualified Data.Map     as M+import qualified Data.Map as M import           Data.Monoid import           GHC.Generics import           Miso-import           Miso.String  (MisoString)-import qualified Miso.String  as S+import           Miso.String (MisoString)+import qualified Miso.String as S +import           Control.Monad.IO.Class+import           Language.Javascript.JSaddle.Warp as JSaddle+ default (MisoString)  data Model = Model@@ -78,7 +81,8 @@    deriving Show  main :: IO ()-main = startApp App { initialAction = NoOp, ..}+main =+  JSaddle.run 8080 $ startApp App { initialAction = NoOp, ..}   where     model      = emptyModel     update     = updateModel@@ -90,7 +94,7 @@ updateModel :: Msg -> Model -> Effect Msg Model updateModel NoOp m = noEff m updateModel (CurrentTime n) m =-  m <# do print n >> pure NoOp+  m <# do liftIO (print n) >> pure NoOp updateModel Add model@Model{..} =   noEff model {     uid = uid + 1@@ -123,7 +127,7 @@    model { entries = newEntries } <# eff     where       eff =-        putStrLn "clicked check" >>+        liftIO (putStrLn "clicked check") >>           pure NoOp        newEntries =@@ -161,6 +165,10 @@         , viewControls m visibility entries         ]     , infoFooter+    , link_+        [ rel_ "stylesheet"+        , href_ "https://d33wubrfki0l68.cloudfront.net/css/d0175a264698385259b5f1638f2a39134ee445a0/style.css"+        ]     ]  viewEntries :: MisoString -> [ Entry ] -> View Msg

@@ -1,10 +0,0 @@-<!DOCTYPE html>-<html>-  <head>-    <meta charset="utf-8">-    <link rel='stylesheet' href='https://d33wubrfki0l68.cloudfront.net/css/d0175a264698385259b5f1638f2a39134ee445a0/style.css'/>-  </head>-  <body>-    <script src='all.js'></script>-  </body>-</html>

@@ -20,10 +20,12 @@ import           Miso.String  (MisoString) import qualified Miso.String  as S +import qualified Language.Javascript.JSaddle.Warp as JSaddle+ main :: IO ()-main = startApp App { initialAction = Id, ..}+main = JSaddle.run 8080 $ startApp App { initialAction = Id, ..}   where-    model = Model mempty mempty+    model = Model (Message "") mempty     events = defaultEvents     subs = [ websocketSub uri protocols HandleWebSocket ]     update = updateModel@@ -43,7 +45,7 @@ instance FromJSON Message  newtype Message = Message MisoString-  deriving (Eq, Show, Generic, Monoid)+  deriving (Eq, Show, Generic)  data Action   = HandleWebSocket (WebSocket Message)@@ -58,7 +60,8 @@  appView :: Model -> View Action appView Model{..} = div_ [ style_ $ M.fromList [("text-align", "center")] ] [-   h1_ [style_ $ M.fromList [("font-weight", "bold")] ] [ a_ [ href_ "https://github.com/dmjio/miso" ] [ text $ S.pack "Miso Websocket Example" ] ]+   link_ [rel_ "stylesheet", href_ "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.4.3/css/bulma.min.css"]+ , h1_ [style_ $ M.fromList [("font-weight", "bold")] ] [ a_ [ href_ "https://github.com/dmjio/miso" ] [ text $ S.pack "Miso Websocket Example" ] ]  , h3_ [] [ text $ S.pack "wss://echo.websocket.org" ]  , input_  [ type_ "text"            , onInput UpdateMessage

@@ -1,10 +0,0 @@-<!DOCTYPE html>-<html>-  <head>-    <meta charset="utf-8">-    <link rel='stylesheet' href="https://cdnjs.cloudflare.com/ajax/libs/bulma/0.4.3/css/bulma.min.css"'/>-  </head>-  <body>-    <script src='all.js'></script>-  </body>-</html>

@@ -9,6 +9,9 @@ import Miso import Miso.String +import Control.Monad.IO.Class+import Language.Javascript.JSaddle.Warp as JSaddle+ -- | Type synonym for an application model type Model = Int @@ -22,7 +25,8 @@  -- | Entry point for a miso application main :: IO ()-main = startApp App {..}+main = JSaddle.run 8080 $ do+  startApp App {..}   where     initialAction = SayHelloWorld -- initial action to be executed on application load     model  = 0                    -- initial model@@ -38,7 +42,7 @@ updateModel SubtractOne m = noEff (m - 1) updateModel NoOp m = noEff m updateModel SayHelloWorld m = m <# do-  putStrLn "Hello World" >> pure NoOp+  liftIO (putStrLn "Hello World") >> pure NoOp  -- | Constructs a virtual DOM from a model viewModel :: Model -> View Action

@@ -0,0 +1,152 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- 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 qualified Data.Sequence as S+import qualified JavaScript.Object.Internal as OI++#ifdef JSADDLE+import           GHCJS.Types (JSString)+import           Language.Javascript.JSaddle (eval, waitForAnimationFrame)+import           Data.FileEmbed+#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+  _ <- 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+  -- 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+        when (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+    -- Initial diff can be bypassed, just copy DOM into VTree+    copyDOMIntoVTree 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 ())

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

@@ -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,49 @@+-----------------------------------------------------------------------------+-- |+-- 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

@@ -0,0 +1,94 @@+-----------------------------------------------------------------------------+-- |+-- 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+----------------------------------------------------------------------------+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 'update' function.+type Sub action = Sink action -> JSM ()++-- | Function to asynchronously dispatch actions to the '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]

@@ -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,108 @@+{-# 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 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 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

@@ -0,0 +1,292 @@+{-# 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+  -- * 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+  -- * 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++-- | `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.+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.+onDestroyed :: action -> Attribute action+onDestroyed action =+  Attribute $ \sink n -> do+    cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action))+    set "onDestroyed" 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)

@@ -0,0 +1,93 @@+{-# 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 (..)+  , 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.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           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+  fromMisoString :: MisoString -> str++-- | Convenience function, shorthand for `toMisoString`+ms :: ToMisoString str => str -> MisoString+ms = toMisoString++instance ToMisoString MisoString where+  toMisoString = id+  fromMisoString = id+instance ToMisoString String where+  toMisoString = pack+  fromMisoString = unpack+instance ToMisoString T.Text where+  toMisoString = textToJSString+  fromMisoString = textFromJSString+instance ToMisoString LT.Text where+  toMisoString = lazyTextToJSString+  fromMisoString = lazyTextFromJSString+instance ToMisoString B.ByteString where+  toMisoString = toMisoString . T.decodeUtf8+  fromMisoString = T.encodeUtf8 . fromMisoString+instance ToMisoString BL.ByteString where+  toMisoString = toMisoString . LT.decodeUtf8+  fromMisoString = LT.encodeUtf8 . fromMisoString+instance ToMisoString Float where+  toMisoString = realFloatToJSString+  fromMisoString = realToFrac . jsStringToDouble+instance ToMisoString Double where+  toMisoString = realFloatToJSString+  fromMisoString =  jsStringToDouble+instance ToMisoString Int where+  toMisoString = integralToJSString+  fromMisoString = round . jsStringToDouble+instance ToMisoString Word where+  toMisoString = integralToJSString+  fromMisoString = round . jsStringToDouble

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

@@ -0,0 +1,97 @@+{-# 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+    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))

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

@@ -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.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");

@@ -0,0 +1,148 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- 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+  , 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.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 <- parse =<< WS.data' v+    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++-- | 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

@@ -0,0 +1,56 @@+{-# 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))

@@ -0,0 +1,139 @@+-----------------------------------------------------------------------------+-- |+-- 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 (..)+  , 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 provide 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+  , initialAction :: action+  -- ^ Initial action that is run after the application has loaded+  , mountPoint :: Maybe MisoString+  -- ^ root element for DOM diff+  }++-- | 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 ]

@@ -18,6 +18,7 @@   , module Miso.Router   , module Miso.TypeLevel   , module Miso.Util+  , module Miso.WebSocket   ) where  import           Miso.Event@@ -25,3 +26,4 @@ import           Miso.Router import           Miso.TypeLevel import           Miso.Util+import           Miso.WebSocket

@@ -149,6 +149,7 @@ data NS   = HTML -- ^ HTML Namespace   | SVG  -- ^ SVG Namespace+  | MATHML  -- ^ MATHML Namespace   deriving (Show, Eq)  -- | `VNode` creation

@@ -0,0 +1,249 @@+{-# 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+   , 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++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++syncPoint :: JSM ()+syncPoint = pure ()++-- | Set property on object+set :: ToJSVal v => JSString -> v -> OI.Object -> IO ()+set k v obj = toJSVal v >>= \x -> OI.setProp k x obj++-- | Adds event listener to window+foreign import javascript unsafe "$1.addEventListener($2, $3);"+  addEventListener' :: JSVal -> JSString -> Callback (JSVal -> IO ()) -> IO ()++addEventListener :: JSVal -> JSString -> (JSVal -> IO ()) -> IO ()+addEventListener self name cb = addEventListener' self name =<< asyncCallback1 cb++windowAddEventListener :: JSString -> (JSVal -> IO ()) -> 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 inner height+foreign import javascript unsafe "$r = window.innerHeight;"+  windowInnerHeight :: IO Int++-- | Retrieves outer height+foreign import javascript unsafe "$r = window.innerWidth;"+  windowInnerWidth :: IO Int++-- | Retrieve high performance time stamp+foreign import javascript unsafe "$r = performance.now();"+  now :: IO Double++-- | Console-logging+foreign import javascript unsafe "console.log($1);"+  consoleLog :: 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 = objectToJSON($1,$2);"+  objectToJSON+    :: JSVal -- ^ decodeAt :: [JSString]+    -> JSVal -- ^ object with impure references to the DOM+    -> IO JSVal++foreign import javascript unsafe "$r = document.body;"+  getBody :: IO JSVal++foreign import javascript unsafe "$r = document;"+  getDoc :: IO JSVal++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 "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 "copyDOMIntoVTree($1);"+  copyDOMIntoVTree :: JSVal -> IO ()++-- | Pins down the current callbacks for clearing later+foreign import javascript unsafe "swapCallbacks();"+  swapCallbacks :: IO ()++-- | Releases callbacks registered by the virtual DOM.+foreign import javascript unsafe "releaseCallbacks();"+  releaseCallbacks :: IO ()++foreign import javascript unsafe "registerCallback($1);"+  registerCallback :: JSVal -> IO ()++-- | Fails silently if the element is not found.+--+-- Analogous to @document.getElementById(id).focus()@.+foreign import javascript unsafe "callFocus($1);"+  focus :: JSString -> JSM ()++-- | Fails silently if the element is not found.+--+-- Analogous to @document.getElementById(id).blur()@+foreign import javascript unsafe "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 ()

@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------+-- |+-- 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 ()

@@ -0,0 +1,34 @@+{-# 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

@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- 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 ()

@@ -0,0 +1,55 @@+{-# 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+  , 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 "$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

@@ -1,149 +0,0 @@-{-# LANGUAGE BangPatterns        #-}-{-# 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-  ( 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           Data.IORef-import           Data.List-import           Data.Sequence                 ((|>))-import qualified Data.Sequence                 as S-import           GHCJS.Types (JSVal)-import qualified JavaScript.Object.Internal    as OI-import           JavaScript.Web.AnimationFrame--import           Miso.Concurrent-import           Miso.Delegate-import           Miso.Diff-import           Miso.Effect-import           Miso.Event-import           Miso.Util-import           Miso.Html-import           Miso.Router-import           Miso.Subscription-import           Miso.Types-import           Miso.FFI---- | Helper function to abstract out common functionality between `startApp` and `miso`-common-  :: Eq model-  => App model action-  -> model-  -> (Sink action -> IO (IORef VTree))-  -> IO b-common App {..} m getView = do-  -- init Notifier-  Notify {..} <- newNotify-  -- init empty actions-  actionsRef <- newIORef S.empty-  let writeEvent a = void . 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 . 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 = wait >> do-        -- Apply actions to model-        actions <- atomicModifyIORef' actionsRef $ \actions -> (S.empty, actions)-        let (Acc newModel effects) = foldl' (foldEffects writeEvent update)-                                            (Acc oldModel (pure ())) actions-        effects-        when (oldModel /= newModel) $ do-          swapCallbacks-          newVTree <- runView (view newModel) writeEvent-          oldVTree <- readIORef viewRef-          void $ waitForAnimationFrame-          (diff mountPoint) (Just oldVTree) (Just newVTree)-          releaseCallbacks-          atomicWriteIORef viewRef newVTree-        loop newModel-  loop m---- | Runs an isomorphic miso application--- Assumes the pre-rendered DOM is already present-miso :: Eq model => (URI -> App model action) -> IO ()-miso f = do-  app@App {..} <- f <$> getCurrentURI-  common app model $ \writeEvent -> do-    let initialView = view model-    VTree (OI.Object iv) <- flip runView writeEvent initialView-    -- Initial diff can be bypassed, just copy DOM into VTree-    copyDOMIntoVTree iv-    let initialVTree = VTree (OI.Object iv)-    -- Create virtual dom, perform initial diff-    newIORef initialVTree---- | Runs a miso application-startApp :: Eq model => App model action -> IO ()-startApp app@App {..} =-  common app model $ \writeEvent -> do-    let initialView = view model-    initialVTree <- flip runView writeEvent initialView-    (diff mountPoint) Nothing (Just initialVTree)-    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 ->-            void $ forkIO (eff sink)--data Acc model = Acc !model !(IO ())---- | Copies DOM pointers into virtual dom--- entry point into isomorphic javascript-foreign import javascript unsafe "copyDOMIntoVTree($1);"-  copyDOMIntoVTree :: JSVal -> IO ()---- | Pins down the current callbacks for clearing later-foreign import javascript unsafe "swapCallbacks();"-  swapCallbacks :: IO ()---- | Releases callbacks registered by the virtual DOM.-foreign import javascript unsafe "releaseCallbacks();"-  releaseCallbacks :: IO ()

@@ -1,41 +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           Data.IORef-import qualified Data.Map                 as M-import           Miso.Html.Internal-import           Miso.String-import qualified JavaScript.Object.Internal as OI-import           GHCJS.Foreign.Callback-import           GHCJS.Marshal-import           GHCJS.Types (JSVal)---- | Entry point for event delegation-delegator-  :: JSVal-  -> IORef VTree-  -> M.Map MisoString Bool-  -> IO ()-delegator mountPointElement vtreeRef es = do-  evts <- toJSVal (M.toList es)-  getVTreeFromRef <- syncCallback' $ do-    VTree (OI.Object val) <- readIORef vtreeRef-    pure val-  delegateEvent mountPointElement evts getVTreeFromRef---- | Event delegation FFI, routes events received on body through the virtual dom--- Invokes event handler when found-foreign import javascript unsafe "delegate($1, $2, $3);"-  delegateEvent-     :: JSVal               -- ^ mountPoint element-     -> JSVal               -- ^ Events-     -> Callback (IO JSVal) -- ^ Virtual DOM callback-     -> IO ()

@@ -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,66 +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-import JavaScript.Object.Internal-import Miso.Html.Internal---- | Entry point for diffing / patching algorithm-diff :: Maybe JSString -> Maybe VTree -> Maybe VTree -> IO ()-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 -> IO ()-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 -> IO JSVal-mountElement mayMp =-  case mayMp of-    Nothing -> getBody-    Just eid -> getElementById eid--foreign import javascript unsafe "$r = document.body;"-  getBody :: IO JSVal--foreign import javascript unsafe "$r = document;"-  getDoc :: IO JSVal--foreign import javascript unsafe "$r = document.getElementById($1);"-  getElementById :: JSString -> IO JSVal--foreign import javascript unsafe "diff($1, $2, $3, $4);"-  diff'-    :: Object -- ^ current object-    -> Object -- ^ new object-    -> JSVal  -- ^ parent node-    -> JSVal  -- ^ document-    -> IO ()

@@ -1,92 +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------------------------------------------------------------------------------module Miso.Effect (-  module Miso.Effect.Storage-, module Miso.Effect.XHR-, module Miso.Effect.DOM-, Effect (..), Sub, Sink-, mapSub-, noEff-, (<#)-, (#>)-, batchEff-, effectSub-) where--import Data.Bifunctor--import Miso.Effect.Storage-import Miso.Effect.XHR-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 'update' function.-type Sub action = Sink action -> IO ()---- | Function to asynchronously dispatch actions to the '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 -> IO action -> Effect action model-(<#) m a = effectSub m $ \sink -> a >>= sink---- | `Effect` smart constructor, flipped-(#>) :: IO action -> model -> Effect action model-(#>) = flip (<#)---- | `Smart constructor for an 'Effect' with multiple actions.-batchEff :: model -> [IO action] -> Effect action model-batchEff model actions = Effect model $ (>>=) <$> 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,33 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--------------------------------------------------------------------------------- |--- 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-  , alert-  ) where--import Miso.String---- | Fails silently if the element is not found.------ Analogous to @document.getElementById(id).focus()@.-foreign import javascript unsafe "callFocus($1);"-  focus :: MisoString -> IO ()---- | Fails silently if the element is not found.------ Analogous to @document.getElementById(id).blur()@-foreign import javascript unsafe "callBlur($1);"-  blur :: MisoString -> IO ()---- | Calls the @alert()@ function.-foreign import javascript unsafe "alert($1);"-  alert :: MisoString -> IO ()

@@ -1,116 +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.Nullable-import GHCJS.Types--import Miso.FFI---- | Helper for retrieving either local or session storage-getStorageCommon-  :: FromJSON b => (t -> IO (Maybe JSVal)) -> t -> IO (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 session storage-getSessionStorage :: FromJSON model => JSString -> IO (Either String model)-getSessionStorage =-  getStorageCommon $ \t -> do-    r <- getItemSS t-    pure (nullableToMaybe r)---- | Retrieve local storage-getLocalStorage :: FromJSON model => JSString -> IO (Either String model)-getLocalStorage = getStorageCommon $ \t -> do-    r <- getItemLS t-    pure (nullableToMaybe 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 -> IO ()-setLocalStorage key model =-  setItemLS 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 -> IO ()-setSessionStorage key model =-  setItemSS key =<< stringify model--foreign import javascript unsafe "$r = window.localStorage.getItem($1);"-  getItemLS :: JSString -> IO (Nullable JSVal)--foreign import javascript unsafe "$r = window.sessionStorage.getItem($1);"-  getItemSS :: JSString -> IO (Nullable JSVal)---- | Removes item from local storage by key name.-foreign import javascript unsafe "window.localStorage.removeItem($1);"-  removeLocalStorage :: JSString -> IO ()---- | Removes item from session storage by key name.-foreign import javascript unsafe "window.sessionStorage.removeItem($1);"-  removeSessionStorage :: JSString -> IO ()--foreign import javascript unsafe "window.localStorage.setItem($1, $2);"-  setItemLS :: JSString -> JSString -> IO ()--foreign import javascript unsafe "window.sessionStorage.setItem($1, $2);"-  setItemSS :: JSString -> JSString -> IO ()---- | Retrieves the number of items in local storage.-foreign import javascript unsafe "$r = window.localStorage.length;"-  localStorageLength :: IO Int---- | Retrieves the number of items in session storage.-foreign import javascript unsafe "$r = window.sessionStorage.length;"-  sessionStorageLength :: IO Int---- | Clears local storage.-foreign import javascript unsafe "window.localStorage.clear();"-  clearLocalStorage :: IO ()---- | Clears session storage.-foreign import javascript unsafe "window.sessionStorage.clear();"-  clearSessionStorage :: IO ()

@@ -1,321 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE LambdaCase           #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE CPP                  #-}--------------------------------------------------------------------------------- |--- Module      :  Miso.Effect.XHR--- 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.XHR where--import Data.Proxy-import GHC.TypeLits-import JavaScript.Web.XMLHttpRequest-import Miso.String-import Servant.API---- | Still a WIP, use ghcjs-base XHR for now, or other---- | Intermediate type for accumulation-data RouteInfo-  = RouteInfo { riPath :: String-              , riMethod :: Method-              } deriving (Show, Eq)---- | Class for `XHR`-class HasXHR api where-  type XHR api :: *-  xhrWithRoute-    :: Proxy api-    -> RouteInfo-    -> XHR api---- | Result of using `XHR`-type Result a = IO (Either MisoString a)---- | Verb-instance {-# OVERLAPPABLE #-}-  ( MimeUnrender ct a-  , ReflectMethod method-  , cts' ~ (ct ': cts)-  ) => HasXHR (Verb method status cts' a) where-  type XHR (Verb method status cts' a) = Result a-  xhrWithRoute Proxy _ = undefined-    -- snd <$> performRequestCT (Proxy :: Proxy ct) method req-    --   where method = reflectMethod (Proxy :: Proxy method)---- | Verb NoContent-instance {-# OVERLAPPING #-}-  ReflectMethod method => HasXHR (Verb method status cts NoContent) where-  type XHR (Verb method status cts NoContent) = Result NoContent-  xhrWithRoute Proxy _ = undefined-    -- performRequestNoBody method req >> return NoContent-    --   where method = reflectMethod (Proxy :: Proxy method)---- | Verb, with HEADERS-instance {-# OVERLAPPING #-}-  ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)-  ) => HasXHR (Verb method status cts' (Headers ls a)) where-  type XHR (Verb method status cts' (Headers ls a)) = Result (Headers ls a)-  xhrWithRoute Proxy _ = undefined-    -- let method = reflectMethod (Proxy :: Proxy method)-    -- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req-    -- return $ Headers { getResponse = resp-    --                  , getHeadersHList = buildHeadersTo hdrs-    --                  }----- | `Headers`, with `NoContent`-instance {-# OVERLAPPING #-}-  ( BuildHeadersTo ls, ReflectMethod method-  ) => HasXHR (Verb method status cts (Headers ls NoContent)) where-  type XHR (Verb method status cts (Headers ls NoContent)) = Result (Headers ls NoContent)-  xhrWithRoute Proxy _ = undefined-    -- let method = reflectMethod (Proxy :: Proxy method)-    -- hdrs <- performRequestNoBody method req-    -- return $ Headers { getResponse = NoContent-    --                  , getHeadersHList = buildHeadersTo hdrs-    --                  }---- | Capture-instance (ToHttpApiData a, HasXHR api, KnownSymbol sym) => HasXHR (Capture sym a :> api) where-  type XHR (Capture sym a :> api) = a -> XHR api-  xhrWithRoute Proxy _ (_ :: a) = undefined--#if MIN_VERSION_servant(0,8,1)--- | CaptureAll-instance (KnownSymbol capture, ToHttpApiData a, HasXHR sublayout)-   => HasXHR (CaptureAll capture a :> sublayout) where-  type XHR (CaptureAll capture a :> sublayout) = [a] -> XHR sublayout-  xhrWithRoute Proxy _ _ = undefined-    -- xhrWithRoute (Proxy :: Proxy sublayout)-    --   (foldl' (flip appendToPath) req ps)-#endif---- | Path (done)-instance (HasXHR api, KnownSymbol sym) => HasXHR (sym :> api) where-  type XHR (sym :> api) = XHR api-  xhrWithRoute Proxy req = xhrWithRoute (Proxy :: Proxy api) newReq-    where-      newReq = req {-        riPath = riPath req ++ "/" ++ symbolVal (Proxy :: Proxy sym)-      }---- | Raw (not supported)--- instance HasXHR Raw where---   type XHR Raw = XHR (Response MisoString)---   xhrWithRoute Proxy _ = putStrLn "Raw is not supported"---- | Alternate-instance (HasXHR left, HasXHR right) => HasXHR (left :<|> right) where-  type XHR (left :<|> right) = XHR left :<|> XHR right-  xhrWithRoute Proxy s =-    xhrWithRoute (Proxy :: Proxy left) s :<|>-      xhrWithRoute (Proxy :: Proxy right) s---- | Header-instance (ToHttpApiData a, HasXHR api, KnownSymbol sym) => HasXHR (Header sym a :> api) where-  type XHR (Header sym a :> api) = Maybe a -> XHR api-  xhrWithRoute Proxy _ = undefined---- | HttpVersion-instance HasXHR api => HasXHR (HttpVersion :> api) where-  type XHR (HttpVersion :> api) = XHR api-  xhrWithRoute Proxy = xhrWithRoute (Proxy :: Proxy api)---- | Query param-instance (KnownSymbol sym, ToHttpApiData a, HasXHR api) => HasXHR (QueryParam sym a :> api) where-  type XHR (QueryParam sym a :> api) = Maybe a -> XHR api-  xhrWithRoute Proxy _ _ = undefined---- | Query param(s)-instance (KnownSymbol sym, ToHttpApiData a, HasXHR api) => HasXHR (QueryParams sym a :> api) where-  type XHR (QueryParams sym a :> api) = [a] -> XHR api-  xhrWithRoute Proxy _ _ = undefined---- | Query flag-instance (KnownSymbol sym, HasXHR api) => HasXHR (QueryFlag sym :> api) where-  type XHR (QueryFlag sym :> api) = Bool -> XHR api-  xhrWithRoute Proxy _ _ = undefined---- | Request Body-instance (MimeRender ct a, HasXHR api) => HasXHR (ReqBody (ct ': cts) a :> api) where-  type XHR (ReqBody (ct ': cts) a :> api) = a -> XHR api-  xhrWithRoute Proxy _ _ = undefined---- | Remote host (done)-instance HasXHR api => HasXHR (RemoteHost :> api) where-  type XHR (RemoteHost :> api) = XHR api-  xhrWithRoute Proxy req =  xhrWithRoute (Proxy :: Proxy api) req---- | IsSecure host (done)-instance HasXHR api => HasXHR (IsSecure :> api) where-  type XHR (IsSecure :> api) = XHR api-  xhrWithRoute Proxy req =  xhrWithRoute (Proxy :: Proxy api) req---- | WithNamedContext (done)-instance HasXHR api => HasXHR (WithNamedContext :> api) where-  type XHR (WithNamedContext :> api) = XHR api-  xhrWithRoute Proxy req =  xhrWithRoute (Proxy :: Proxy api) req---- | Vault (done)-instance HasXHR api => HasXHR (Vault :> api) where-  type XHR (Vault :> api) = XHR api-  xhrWithRoute Proxy req = xhrWithRoute (Proxy :: Proxy api) req---- | BasicAuth-instance HasXHR api => HasXHR (BasicAuth realm usr :> api) where-  type XHR (BasicAuth realm usr :> api) = BasicAuthData -> XHR api-  xhrWithRoute Proxy _ _ = undefined---- | Can't find AuthenticateReq--- instance HasXHR api => HasXHR (AuthProtect tag :> api) where---   type XHR (AuthProtect tag :> api) = AuthenticateReq (AuthProtect tag) -> XHR api---   xhrWithRoute Proxy req (AuthenticateReq (val,func)) =---     xhrWithRoute (Proxy :: Proxy api) (func val req)-------- xhrWithRoute (Proxy :: Proxy api)---                     (let ctProxy = Proxy :: Proxy ct---                      in setReqBodyLBS (mimeRender ctProxy body)---                                   -- We use first contentType from the Accept list---                                   (contentType ctProxy)---                                   req---                     )----- xhrJSON :: FromJSON json => Request -> IO (Response json)--- xhrJSON req = do---   r <- xhr' req---   case contents r of---     Nothing -> pure r { contents = Just Null }---     Just jsstring -> do---       x <- parse (unsafeCoerce jsstring)---       pure $ r { contents = Just x }----- import Data.JSString--- import GHCJS.Foreign.Callback--- import GHCJS.Nullable--- import GHCJS.Types--- import Prelude                hiding (lines)---- data ReadyState---   = UNSENT---   -- ^ XHR has been created. open() not called yet.---   | OPENED---   -- ^ open() has been called.---   | HEADERS_RECEIVED---   -- ^ send() has been called, and headers and status are available.---   | LOADING---   -- ^ Downloading; responseText holds partial data.---   | DONE---   -- ^ The operation is complete.---   deriving (Show, Eq, Enum)---- data ResponseType---   = DOMStringType---   | ArrayBufferType---   | BlobType---   | DocumentType---   | JSONType---   | UnknownXHRType---   deriving (Show, Eq)---- newtype Document = Document JSVal--- newtype XHR = XHR JSVal---- foreign import javascript unsafe "$r = new XMLHttpRequest();"---   newXHR :: IO XHR---- foreign import javascript unsafe "$1.abort();"---   abort :: XHR -> IO ()---- foreign import javascript unsafe "$r = $1.responseURL;"---   responseURL :: XHR -> IO JSString---- foreign import javascript unsafe "$r = $1.readyState;"---   readyState' :: XHR -> IO Int---- foreign import javascript unsafe "$r = $1.responseType;"---   responseType' :: XHR -> IO JSString---- responseType :: XHR -> IO ResponseType--- {-# INLINE responseType #-}--- responseType xhr =---   responseType' xhr >>= \case---     "" -> pure DOMStringType---     "blob" -> pure BlobType---     "document" -> pure DocumentType---     "json" -> pure JSONType---     "arraybuffer" -> pure ArrayBufferType---     "text" -> pure DOMStringType---     _ -> pure UnknownXHRType---- readyState :: XHR -> IO ReadyState--- {-# INLINE readyState #-}--- readyState xhr = toEnum <$> readyState' xhr---- -- request.open("GET", "foo.txt", true);--- foreign import javascript unsafe "$1.open($2, $3, $4);"---   open :: XHR -> JSString -> JSString -> Bool -> IO ()---- foreign import javascript unsafe "$1.send();"---   send :: XHR -> IO ()---- foreign import javascript unsafe "$1.setRequestHeader($2,$3);"---   setRequestHeader :: XHR -> JSString -> JSString -> IO ()---- foreign import javascript unsafe "$1.onreadystatechanged = $2;"---   onReadyStateChanged :: XHR -> Callback (JSVal -> IO ()) -> IO ()---- foreign import javascript unsafe "$r = $1.getAllResponseHeaders();"---   getAllResponseHeaders' :: XHR -> IO (Nullable JSString)---- foreign import javascript unsafe "$r = $1.getResponseHeader($2);"---   getResponseHeader' :: XHR -> JSString -> IO (Nullable JSString)---- getResponseHeader :: XHR -> JSString -> IO (Maybe JSString)--- {-# INLINE getResponseHeader #-}--- getResponseHeader xhr key =---   nullableToMaybe <$> getResponseHeader' xhr key---- foreign import javascript unsafe "$r = $1.response;"---   response' :: XHR -> IO (Nullable JSVal)---- foreign import javascript unsafe "$r = $1.status;"---   status' :: XHR -> IO (Nullable Int)---- foreign import javascript unsafe "$r = $1.statusText;"---   statusText' :: XHR -> IO (Nullable JSString)---- foreign import javascript unsafe "$1.overrideMimeType($2);"---   overrideMimeType :: XHR -> JSString -> IO ()---- foreign import javascript unsafe "$r = $1.timeout;"---   timeout :: XHR -> IO Int---- foreign import javascript unsafe "$1.withCredentials = true;"---   withCredentials :: XHR -> IO ()---- foreign import javascript unsafe "$1.response ? true : false"---   hasResponse :: XHR -> IO Bool---- getAllResponseHeaders :: XHR -> IO (Maybe [JSString])--- {-# INLINE getAllResponseHeaders #-}--- getAllResponseHeaders = \xhr -> do---   result <- getAllResponseHeaders' xhr---   pure $ lines <$> nullableToMaybe result

@@ -1,156 +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-   ( windowAddEventListener-   , windowRemoveEventListener-   , windowInnerHeight-   , windowInnerWidth-   , eventPreventDefault-   , eventStopPropagation-   , now-   , consoleLog-   , stringify-   , parse-   , item-   , jsvalToValue-   , clearBody-   , objectToJSON-   , getWindow-   , set-   ) where--import           Control.Monad-import           Control.Monad.Trans.Maybe-import qualified Data.Aeson                 as AE-import           Data.Aeson                 hiding (Object)-import qualified Data.HashMap.Strict        as H-import           Data.JSString-import qualified Data.JSString.Text         as JSS-import           Data.Maybe-import           Data.Scientific-import qualified Data.Vector                as V-import           GHCJS.Foreign.Callback-import           GHCJS.Foreign.Internal-import           GHCJS.Marshal-import           GHCJS.Types-import           JavaScript.Array.Internal-import qualified JavaScript.Object.Internal as OI-import           Unsafe.Coerce---- | Set property on object-set :: ToJSVal v => JSString -> v -> OI.Object -> IO ()-set k v obj = toJSVal v >>= \x -> OI.setProp k x obj---- | Convert JSVal to Maybe `Value`-jsvalToValue :: JSVal -> IO (Maybe Value)-jsvalToValue r = do-  case jsonTypeOf r of-    JSONNull -> return (Just Null)-    JSONInteger -> liftM (AE.Number . flip scientific 0 . (toInteger :: Int -> Integer))-         <$> fromJSVal r-    JSONFloat -> liftM (AE.Number . (fromFloatDigits :: Double -> Scientific))-         <$> fromJSVal r-    JSONBool -> liftM AE.Bool <$> fromJSVal r-    JSONString -> liftM AE.String <$> fromJSVal r-    JSONArray -> do-      xs :: [Value] <--        catMaybes <$>-          forM (toList (unsafeCoerce r)) jsvalToValue-      pure . pure $ Array . V.fromList $ xs-    JSONObject -> do-        Just (props :: [JSString]) <- fromJSVal =<< getKeys (OI.Object r)-        runMaybeT $ do-            propVals <- forM props $ \p -> do-              v <- MaybeT (jsvalToValue =<< OI.getProp p (OI.Object r))-              return (JSS.textFromJSString p, v)-            return (AE.Object (H.fromList propVals))---- | Retrieves keys-foreign import javascript unsafe "$r = Object.keys($1);"-  getKeys :: OI.Object -> IO JSVal---- | Adds event listener to window-foreign import javascript unsafe "window.addEventListener($1, $2);"-  windowAddEventListener :: JSString -> Callback (JSVal -> IO ()) -> IO ()---- | Removes event listener from window-foreign import javascript unsafe "window.removeEventListener($1, $2);"-  windowRemoveEventListener :: JSString -> Callback (JSVal -> IO ()) -> IO ()---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 inner height-foreign import javascript unsafe "$r = window.innerHeight;"-  windowInnerHeight :: IO Int---- | Retrieves outer height-foreign import javascript unsafe "$r = window.innerWidth;"-  windowInnerWidth :: IO Int---- | Retrieve high performance time stamp-foreign import javascript unsafe "$r = performance.now();"-  now :: IO Double---- | Console-logging-foreign import javascript unsafe "console.log($1);"-  consoleLog :: 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 <- jsvalToValue k-  case fromJSON val of-    Success x -> pure x-    Error y -> error y---- | Indexing into a JS object-foreign import javascript unsafe "$r = $1[$2];"-  item :: JSVal -> JSString -> IO JSVal---- | 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 = objectToJSON($1,$2);"-  objectToJSON-    :: JSVal -- ^ decodeAt :: [JSString]-    -> JSVal -- ^ object with impure references to the DOM-    -> IO JSVal

@@ -1,298 +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-  -- * 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-  -- * Events-  , defaultEvents-  -- * Subscription type-  , Sub-  ) where--import           Control.Monad-import           Data.Aeson.Types           (parseEither)-import           Data.JSString-import qualified Data.Map                   as M-import           Data.Monoid-import           Data.Proxy-import           Data.String                (IsString(..))-import qualified Data.Text                  as T-import           GHCJS.Foreign.Callback-import           GHCJS.Marshal-import           GHCJS.Types-import           JavaScript.Object-import           JavaScript.Object.Internal (Object (Object))-import qualified JavaScript.Array as JSArray-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 -> IO 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 <- jsval <$> create-  propsObj <- jsval <$> create-  eventObj <- jsval <$> 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 =<< setKids sink-  pure $ VTree vnode-    where-      setAttrs vnode sink =-        forM_ attrs $ \(Attribute attr) ->-          attr sink vnode--      setKids sink =-        jsval . JSArray.fromList <$>-          fmap (jsval . getTree) <$>-            traverse (flip runView sink) kids--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)---- | Namespace of DOM elements.-data NS-  = HTML -- ^ HTML Namespace-  | SVG  -- ^ SVG 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---- | `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 -> IO ())---- | @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 <- asyncCallback1 $ \e -> do-       Just v <- jsvalToValue =<< objectToJSON decodeAtVal e-       case parseEither decoder v of-         Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s-         Right r -> sink (toAction r)-   setProp "runEvent" (jsval cb) eventHandlerObject-   registerCallback cb-   setProp "options" jsOptions eventHandlerObject-   setProp eventName eo (Object eventObj)---- | @onCreated action@ is an event that gets called after the actual DOM--- element is created.-onCreated :: action -> Attribute action-onCreated action =-  Attribute $ \sink n -> do-    cb <- asyncCallback (sink action)-    setProp "onCreated" (jsval 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.-onDestroyed :: action -> Attribute action-onDestroyed action =-  Attribute $ \sink n -> do-    cb <- asyncCallback (sink action)-    setProp "onDestroyed" (jsval 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) ->-     setProp k (jsval v) (Object cssObj)--foreign import javascript unsafe "registerCallback($1);"-  registerCallback-    :: Callback a-    -> IO ()

@@ -1,93 +0,0 @@-{-# 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 (..)-  , 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.JSString-import           Data.JSString.Int-import           Data.JSString.RealFloat-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           GHCJS.Marshal.Pure-import           GHCJS.Types---- | String type swappable based on compiler-type MisoString = 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-  fromMisoString :: MisoString -> str---- | Convenience function, shorthand for `toMisoString`-ms :: ToMisoString str => str -> MisoString-ms = toMisoString--instance ToMisoString MisoString where-  toMisoString = id-  fromMisoString = id-instance ToMisoString String where-  toMisoString = pack-  fromMisoString = unpack-instance ToMisoString T.Text where-  toMisoString = textToJSString-  fromMisoString = textFromJSString-instance ToMisoString LT.Text where-  toMisoString = lazyTextToJSString-  fromMisoString = lazyTextFromJSString-instance ToMisoString B.ByteString where-  toMisoString = toMisoString . T.decodeUtf8-  fromMisoString = T.encodeUtf8 . fromMisoString-instance ToMisoString BL.ByteString where-  toMisoString = toMisoString . LT.decodeUtf8-  fromMisoString = LT.encodeUtf8 . fromMisoString-instance ToMisoString Float where-  toMisoString = realFloat-  fromMisoString = pFromJSVal . toJSNumber-instance ToMisoString Double where-  toMisoString = realFloat-  fromMisoString = pFromJSVal . toJSNumber-instance ToMisoString Int where-  toMisoString = decimal-  fromMisoString = pFromJSVal . toJSNumber-instance ToMisoString Word where-  toMisoString = decimal-  fromMisoString = pFromJSVal . toJSNumber--foreign import javascript unsafe "$r = Number($1);"-  toJSNumber :: JSString -> JSVal

@@ -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.WebSocket-  , module Miso.Subscription.Window-  , module Miso.Subscription.SSE-  ) where--import Miso.Subscription.Mouse-import Miso.Subscription.Keyboard-import Miso.Subscription.History-import Miso.Subscription.WebSocket-import Miso.Subscription.Window-import Miso.Subscription.SSE

@@ -1,128 +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.Concurrent-import           Control.Monad-import           GHCJS.Foreign.Callback-import           Miso.Concurrent-import           Miso.Html.Internal     (Sub)-import           Miso.String-import           Network.URI            hiding (path)-import           System.IO.Unsafe---- | Retrieves current URI of page-getCurrentURI :: IO URI-{-# INLINE getCurrentURI #-}-getCurrentURI = getURI---- | Retrieves current URI of page-getURI :: IO URI-{-# INLINE getURI #-}-getURI = do-  href <- fromMisoString <$> 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 -> IO ()-{-# 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 -> IO ()-{-# INLINE replaceURI #-}-replaceURI uri = replaceTo' uri { uriPath = toPath uri }---- | Navigates backwards-back :: IO ()-{-# INLINE back #-}-back = back'---- | Navigates forwards-forward :: IO ()-{-# INLINE forward #-}-forward = forward'---- | Jumps to a specific position in history-go :: Int -> IO ()-{-# INLINE go #-}-go n = go' n--chan :: Notify-{-# NOINLINE chan #-}-chan = unsafePerformIO newNotify---- | Subscription for `popState` events, from the History API-uriSub :: (URI -> action) -> Sub action-uriSub = \f sink -> do-  void.forkIO.forever $ do-    wait chan >> do-      sink =<< f <$> getURI-  onPopState =<< do-     asyncCallback $ do-      sink =<< f <$> getURI--foreign import javascript safe "$r = window.location.href || '';"-  getWindowLocationHref :: IO MisoString--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.addEventListener('popstate', $1);"-  onPopState :: Callback (IO ()) -> IO ()--foreign import javascript unsafe "window.history.pushState(null, null, $1);"-  pushStateNoModel' :: JSString -> IO ()--foreign import javascript unsafe "window.history.replaceState(null, null, $1);"-  replaceState' :: JSString -> IO ()--pushStateNoModel :: URI -> IO ()-{-# INLINE pushStateNoModel #-}-pushStateNoModel u = do-  pushStateNoModel' . pack . show $ u-  notify chan--replaceTo' :: URI -> IO ()-{-# INLINE replaceTo' #-}-replaceTo' u = do-  replaceState' . pack . show $ u-  notify chan

@@ -1,99 +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           Data.IORef-import           Data.Set-import qualified Data.Set as S-import           GHCJS.Foreign.Callback-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 <- newIORef mempty-  windowAddEventListener "keyup" =<< keyUpCallback keySetRef-  windowAddEventListener "keydown" =<< keyDownCallback keySetRef-    where-      keyDownCallback keySetRef = do-        asyncCallback1 $ \keyDownEvent -> do-          Just key <- fromJSVal =<< getProp "keyCode" (Object keyDownEvent)-          newKeys <- atomicModifyIORef' keySetRef $ \keys ->-             let !new = S.insert key keys-             in (new, new)-          sink (f newKeys)--      keyUpCallback keySetRef = do-        asyncCallback1 $ \keyUpEvent -> do-          Just key <- fromJSVal =<< getProp "keyCode" (Object keyUpEvent)-          newKeys <- atomicModifyIORef' keySetRef $ \keys ->-             let !new = S.delete key keys-             in (new, new)-          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 GHCJS.Foreign.Callback-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" =<< do-    asyncCallback1 $ \mouseEvent -> do-      Just x <- fromJSVal =<< getProp "clientX" (Object mouseEvent)-      Just y <- fromJSVal =<< getProp "clientY" (Object mouseEvent)-      sink $ f (x,y)

@@ -1,68 +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 Data.Aeson-import GHCJS.Foreign.Callback-import GHCJS.Types-import Miso.FFI-import Miso.Html.Internal     ( Sub )-import Miso.String---- | Server-sent events Subscription-sseSub :: FromJSON msg => MisoString -> (SSE msg -> action) -> Sub action-sseSub url f = \sink -> do-  es <- newEventSource url-  onMessage es =<< do-    asyncCallback1 $ \val -> do-      getData val >>= parse >>= \x -> do-        sink $ f (SSEMessage x)-  onError es =<< do-    asyncCallback $-      sink (f SSEError)-  onClose es =<< do-    asyncCallback $-      sink (f SSEClose)---- | Server-sent events data-data SSE message-  = SSEMessage message-  | SSEClose-  | SSEError-  deriving (Show, Eq)--foreign import javascript unsafe "$r = $1.data;"-  getData :: JSVal -> IO JSVal--newtype EventSource = EventSource JSVal--foreign import javascript unsafe "$r = new EventSource($1);"-  newEventSource :: JSString -> IO EventSource--foreign import javascript unsafe "$1.onmessage = $2;"-  onMessage :: EventSource -> Callback (JSVal -> IO ()) -> IO ()--foreign import javascript unsafe "$1.onerror = $2;"-  onError :: EventSource -> Callback (IO ()) -> IO ()--foreign import javascript unsafe "$1.onclose = $2;"-  onClose :: EventSource -> Callback (IO ()) -> IO ()---- | Test URL--- http://sapid.sourceforge.net/ssetest/webkit.events.php--- var source = new EventSource("demo_sse.php");

@@ -1,253 +0,0 @@-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--------------------------------------------------------------------------------- |--- 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-  , connect-  , getSocketState-  ) where--import Control.Concurrent-import Control.Monad-import Data.Aeson-import Data.IORef-import Data.Maybe-import GHC.Generics-import GHCJS.Foreign.Callback-import GHCJS.Marshal-import GHCJS.Types-import Prelude                hiding (map)-import System.IO.Unsafe--import Miso.FFI-import Miso.Html.Internal     ( Sub )-import Miso.String---- | WebSocket connection messages-data WebSocket action-  = WebSocketMessage action-  | WebSocketClose CloseCode WasClean Reason-  | WebSocketOpen-  | WebSocketError MisoString-    deriving (Show, Eq)--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-  writeIORef websocket (Just socket)-  void . forkIO $ handleReconnect-  onOpen socket =<< do-    writeIORef closedCode Nothing-    asyncCallback $ sink (f WebSocketOpen)-  onMessage socket =<< do-    asyncCallback1 $ \v -> do-      d <- parse =<< getData v-      sink $ f (WebSocketMessage d)-  onClose socket =<< do-    asyncCallback1 $ \e -> do-      code <- codeToCloseCode <$> getCode e-      writeIORef closedCode (Just code)-      reason <- getReason e-      clean <- wasClean e-      sink $ f (WebSocketClose code clean reason)-  onError socket =<< do-    asyncCallback1 $ \v -> do-      writeIORef closedCode Nothing-      d <- parse =<< getData v-      sink $ f (WebSocketError d)-  where-    handleReconnect = do-      threadDelay (secs 3)-      Just s <- readIORef websocket-      status <- getSocketState' s-      code <- 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 -> IO ()-{-# INLINE send #-}-send x = do-  Just socket <- readIORef websocket-  sendJson' socket x---- | Connects to a websocket server-connect :: URL -> Protocols -> IO ()-{-# INLINE connect #-}-connect (URL url') (Protocols ps) = do-  Just ws <- readIORef websocket-  s <- getSocketState' ws-  when (s == 3) $ do-    socket <- createWebSocket url' ps-    atomicWriteIORef websocket (Just socket)---- | URL of Websocket server-newtype URL = URL MisoString-  deriving (Show, Eq)---- | Protocols for Websocket connection-newtype Protocols = Protocols [MisoString]-  deriving (Show, Eq)---- | Wether or not the connection closed was done so cleanly-newtype WasClean = WasClean Bool deriving (Show, Eq)---- | Reason for closed connection-newtype Reason = Reason MisoString deriving (Show, Eq)--foreign import javascript unsafe "$r = new WebSocket($1, $2);"-  createWebSocket' :: JSString -> JSVal -> IO Socket--foreign import javascript unsafe "$r = $1.readyState;"-  getSocketState' :: Socket -> IO Int---- | `SocketState` corresponding to current WebSocket connection-data SocketState-  = CONNECTING -- ^ 0-  | OPEN       -- ^ 1-  | CLOSING    -- ^ 2-  | CLOSED     -- ^ 3-  deriving (Show, Eq, Ord, Enum)---- | Retrieves current status of `WebSocket`-getSocketState :: IO SocketState-getSocketState = do-  Just ws <- readIORef websocket-  toEnum <$> getSocketState' ws--foreign import javascript unsafe "$1.send($2);"-  send' :: Socket -> JSString -> IO ()--sendJson' :: ToJSON json => Socket -> json -> IO ()-sendJson' socket m = send' socket =<< stringify m--createWebSocket :: JSString -> [JSString] -> IO Socket-{-# INLINE createWebSocket #-}-createWebSocket url' protocols =-  createWebSocket' url' =<< toJSVal protocols--foreign import javascript unsafe "$1.onopen = $2"-  onOpen :: Socket -> Callback (IO ()) -> IO ()--foreign import javascript unsafe "$1.onclose = $2"-  onClose :: Socket -> Callback (JSVal -> IO ()) -> IO ()--foreign import javascript unsafe "$1.onmessage = $2"-  onMessage :: Socket -> Callback (JSVal -> IO ()) -> IO ()--foreign import javascript unsafe "$1.onerror = $2"-  onError :: Socket -> Callback (JSVal -> IO ()) -> IO ()--foreign import javascript unsafe "$r = $1.data"-  getData :: JSVal -> IO JSVal--foreign import javascript unsafe "$r = $1.wasClean"-  wasClean :: JSVal -> IO WasClean--foreign import javascript unsafe "$r = $1.code"-  getCode :: JSVal -> IO Int--foreign import javascript unsafe "$r = $1.reason"-  getReason :: JSVal -> IO Reason--newtype Socket = Socket JSVal---- | Code corresponding to a closed connection--- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent-data CloseCode-  = CLOSE_NORMAL-   -- ^ 1000, Normal closure; the connection successfully completed whatever purpose for which it was created.-  | CLOSE_GOING_AWAY-   -- ^ 1001, The endpoint is going away, either because of a server failure or because the browser is navigating away from the page that opened the connection.-  | CLOSE_PROTOCOL_ERROR-   -- ^ 1002, The endpoint is terminating the connection due to a protocol error.-  | CLOSE_UNSUPPORTED-   -- ^ 1003, The connection is being terminated because the endpoint received data of a type it cannot accept (for example, a textonly endpoint received binary data).-  | CLOSE_NO_STATUS-   -- ^ 1005, Reserved.  Indicates that no status code was provided even though one was expected.-  | CLOSE_ABNORMAL-   -- ^ 1006, Reserved. Used to indicate that a connection was closed abnormally (that is, with no close frame being sent) when a status code is expected.-  | Unsupported_Data-   -- ^ 1007, The endpoint is terminating the connection because a message was received that contained inconsistent data (e.g., nonUTF8 data within a text message).-  | Policy_Violation-   -- ^ 1008, The endpoint is terminating the connection because it received a message that violates its policy. This is a generic status code, used when codes 1003 and 1009 are not suitable.-  | CLOSE_TOO_LARGE-   -- ^ 1009, The endpoint is terminating the connection because a data frame was received that is too large.-  | Missing_Extension-   -- ^ 1010, The client is terminating the connection because it expected the server to negotiate one or more extension, but the server didn't.-  | Internal_Error-   -- ^ 1011, The server is terminating the connection because it encountered an unexpected condition that prevented it from fulfilling the request.-  | Service_Restart-   -- ^ 1012, The server is terminating the connection because it is restarting.-  | Try_Again_Later-   -- ^ 1013, The server is terminating the connection due to a temporary condition, e.g. it is overloaded and is casting off some of its clients.-  | TLS_Handshake-   -- ^ 1015, Reserved. Indicates that the connection was closed due to a failure to perform a TLS handshake (e.g., the server certificate can't be verified).-  | OtherCode Int-   -- ^ OtherCode that is reserved and not in the range 0999-  deriving (Show, Eq, Generic)--instance ToJSVal CloseCode-instance FromJSVal CloseCode--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,57 +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 Data.Monoid--import GHCJS.Foreign.Callback-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-  sink . f =<< (,) <$> windowInnerHeight <*> windowInnerWidth-  windowAddEventListener "resize" =<< do-    asyncCallback1 $ \windowEvent -> do-      target <- getProp "target" (Object windowEvent)-      Just w <- fromJSVal =<< getProp "innerWidth" (Object target)-      Just h <- fromJSVal =<< getProp "innerHeight" (Object target)-      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 =<< do-    decodeAtVal <- toJSVal decodeAt-    asyncCallback1 $ \e -> do-      Just v <- jsvalToValue =<< 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-          sink (toAction r)

@@ -1,137 +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 (..)-  , Effect-  , Sub--    -- * The Transition Monad-  , Transition-  , mapAction-  , fromTransition-  , toTransition-  , scheduleIO-  , scheduleIO_-  , scheduleIOFor_-  , scheduleSub-  ) where--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.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 provide 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-  , initialAction :: action-  -- ^ Initial action that is run after the application has loaded-  , mountPoint :: Maybe MisoString-  -- ^ root element for DOM diff-  }---- | 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 :: IO action -> Transition action model ()-scheduleIO ioAction = scheduleSub $ \sink -> ioAction >>= 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_ :: IO () -> 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 => IO (f action) -> Transition action model ()-scheduleIOFor_ io = scheduleSub $ \sink -> io >>= \m -> 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 ]

@@ -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,239 @@+{-# 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+   , 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)++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 k v obj = do+  v' <- toJSVal v+  setProp k v' obj++addEventListener :: JSVal -> JSString -> (JSVal -> JSM ()) -> JSM ()+addEventListener self name cb = do+  _ <- self # "addEventListener" $ (name, asyncFunction (\_ _ [a] -> cb a))+  pure ()++-- | Adds event listener to window+windowAddEventListener :: JSString -> (JSVal -> JSM ()) -> 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 inner height+windowInnerHeight :: JSM Int+windowInnerHeight =+  fromJSValUnchecked =<< jsg "window" ! "innerHeight"++-- | Retrieves outer height+windowInnerWidth :: JSM Int+windowInnerWidth =+  fromJSValUnchecked =<< jsg "window" ! "innerWidth"++-- | Retrieve high performance time stamp+now :: JSM Double+now = fromJSValUnchecked =<< (jsg "performance" # "now" $ ())++-- | Console-logging+consoleLog :: JSVal -> JSM ()+consoleLog 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"++getBody :: JSM JSVal+getBody = jsg "document" ! "body"++getDoc :: JSM JSVal+getDoc = jsg "document"++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' <- function $ \_ _ [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 :: JSVal -> JSM ()+copyDOMIntoVTree a = () <$ jsg1 "copyDOMIntoVTree" 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

@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+-- |+-- 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 ()

@@ -0,0 +1,38 @@+{-# 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

@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+-- |+-- 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 ()

@@ -0,0 +1,61 @@+{-# 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+  , 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 ()++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))

@@ -1,44 +1,46 @@-var oldCallbacks = [];-var currentCallbacks = [];+window.oldCallbacks = [];+window.currentCallbacks = [];  /* Callbacks in ghcjs need to be released. With this function one can register    callbacks that should be released right before diffing. */-function registerCallback(cb) {+window.registerCallback = function registerCallback(cb) {     currentCallbacks.push(cb);-}+};  /* Swaps out the new calbacks for old callbacks. The old callbacks should be cleared once the new callbacks have replaced them. */-function swapCallbacks() {+window.swapCallbacks = function swapCallbacks() {   oldCallbacks = currentCallbacks;   currentCallbacks = [];-}+};  /* This releases the old callbacks. */-function releaseCallbacks() {+window.releaseCallbacks = function releaseCallbacks() {     for (var i in oldCallbacks)       h$release(oldCallbacks[i]);      oldCallbacks = [];-}+};  /* event delegation algorithm */-function delegate(mountPointElement, events, getVTree) {+window.delegate = function delegate(mountPointElement, events, getVTree) {     for (var event in events) {-	mountPointElement.addEventListener(events[event][0], function(e) {-            delegateEvent ( e-                          , getVTree()+	  mountPointElement.addEventListener(events[event][0], function(e) {+        getVTree(function (obj) {+          delegateEvent ( e+                          , obj                           , buildTargetToElement(mountPointElement, e.target)                           , []-                          );+                        );+        }); 	     }, events[event][1]);     }-}+};  /* Accumulate parent stack as well for propagation */-function delegateEvent (event, obj, stack, parentStack) {+window.delegateEvent = function delegateEvent (event, obj, stack, parentStack) {      /* base case, not found */     if (!stack.length) return;@@ -73,18 +75,18 @@ 	      } 	}     }-}+}; -function buildTargetToElement (element, target) {+window.buildTargetToElement = function buildTargetToElement (element, target) {     var stack = [];     while (element !== target) {       stack.unshift (target);       target = target.parentNode;     }     return stack;-}+}; -function propogateWhileAble (parentStack, event) {+window.propogateWhileAble = function propogateWhileAble (parentStack, event) {   for (var i = 0; i < parentStack.length; i++) {     if (parentStack[i].events[event.type]) {       var eventObj = parentStack[i].events[event.type],@@ -94,11 +96,11 @@   	if (options.stopPropagation) break;     }   }-}+};  /* Walks down obj following the path described by `at`, then filters primitive  values (string, numbers and booleans)*/-function objectToJSON (at, obj) {+window.objectToJSON = function objectToJSON (at, obj) {   /* If at is of type [[MisoString]] */   if (typeof at[0] == "object") {     var ret = [];@@ -119,8 +121,14 @@    /* If obj is a non-list-like object */   var newObj = {};-  for (var i in obj)+    for (var i in obj){+    /* bug in safari, throws TypeError if the following fields are referenced on a checkbox */+    /* https://stackoverflow.com/a/25569117/453261 */+    /* https://html.spec.whatwg.org/multipage/input.html#do-not-apply */+    if (obj['type'] == "checkbox" && (i === "selectionDirection" || i === "selectionStart" || i === "selectionEnd"))+      continue;     if (typeof obj[i] == "string" || typeof obj[i] == "number" || typeof obj[i] == "boolean")       newObj[i] = obj[i];-  return (newObj);-}+    }+    return newObj;+};

@@ -1,5 +1,5 @@ /* virtual-dom diffing algorithm, applies patches as detected */-function diff(currentObj, newObj, parent, doc) {+window.diff = function diff(currentObj, newObj, parent, doc) {     if (!currentObj && !newObj) return;     else if (!currentObj && newObj) createNode(newObj, parent, doc);     else if (currentObj && !newObj) destroyNode(currentObj, parent);@@ -12,45 +12,45 @@ 	    else replaceElementWithText(currentObj, newObj, parent, doc); 	}     }-}+}; -function destroyNode(obj, parent) {+window.destroyNode = function destroyNode(obj, parent) {     parent.removeChild(obj.domRef);     callDestroyedRecursive(obj);-}+}; -function callDestroyedRecursive(obj) {+window.callDestroyedRecursive = function callDestroyedRecursive(obj) {     callDestroyed(obj);     for (var i in obj.children) 	callDestroyedRecursive(obj.children[i]);-}+}; -function callDestroyed(obj) {+window.callDestroyed = function callDestroyed(obj) {     if (obj.onDestroyed) obj.onDestroyed();-}+}; -function diffTextNodes(c, n) {+window.diffTextNodes = function diffTextNodes(c, n) {     if (c.text !== n.text) c.domRef.textContent = n.text;     n.domRef = c.domRef;-}+}; -function replaceElementWithText(c, n, parent, doc) {+window.replaceElementWithText = function replaceElementWithText(c, n, parent, doc) {     n.domRef = doc.createTextNode(n.text);     parent.replaceChild(n.domRef, c.domRef);     callDestroyedRecursive(c);-}+}; -function replaceTextWithElement(c, n, parent, doc) {+window.replaceTextWithElement = function replaceTextWithElement(c, n, parent, doc) {     createElement(n, doc);     parent.replaceChild(n.domRef, c.domRef);     callCreated(n);-}+}; -function callCreated(obj) {+window.callCreated = function callCreated(obj) {     if (obj.onCreated) obj.onCreated();-}+}; -function populate(c, n, doc) {+window.populate = function populate(c, n, doc) {     if (!c) c = { 	props: null, 	css: null,@@ -59,9 +59,9 @@     diffProps(c.props, n.props, n.domRef, n.ns === "svg");     diffCss(c.css, n.css, n.domRef);     diffChildren(c.children, n.children, n.domRef, doc);-}+}; -function diffVNodes(c, n, parent, doc) {+window.diffVNodes = function diffVNodes(c, n, parent, doc) {     if (c.tag === n.tag && n.key === c.key) { 	n.domRef = c.domRef; 	populate(c, n, doc);@@ -71,9 +71,9 @@ 	callDestroyedRecursive(c); 	callCreated(n);     }-}+}; -function diffProps(cProps, nProps, node, isSvg) {+window.diffProps = function diffProps(cProps, nProps, node, isSvg) {     var result, newProp, domProp;     /* Is current prop in new prop list? */     for (var c in cProps) {@@ -117,9 +117,9 @@ 	    node.setAttribute(n, newProp); 	}     }-}+}; -function diffCss(cCss, nCss, node) {+window.diffCss = function diffCss(cCss, nCss, node) {     var result;     /* is current attribute in new attribute list? */     for (var c in cCss) {@@ -136,13 +136,13 @@ 	if (cCss && cCss[n]) continue; 	node.style[n] = nCss[n];     }-}+}; -function hasKeys(ns, cs) {+window.hasKeys = function hasKeys(ns, cs) {     return ns.length > 0 && cs.length > 0 && ns[0].key != null && cs[0].key != null;-}+}; -function diffChildren(cs, ns, parent, doc) {+window.diffChildren = function diffChildren(cs, ns, parent, doc) {     var longest = ns.length > cs.length ? ns.length : cs.length;     if (hasKeys(ns, cs)) { 	syncChildren(cs, ns, parent, doc);@@ -150,24 +150,28 @@ 	for (var i = 0; i < longest; i++) 	    diff(cs[i], ns[i], parent, doc);     }-}+}; -function createElement(obj, doc) {-    obj.domRef = obj.ns === "svg" ?-	doc.createElementNS("http://www.w3.org/2000/svg", obj.tag) :-	doc.createElement(obj.tag);+window.createElement = function createElement(obj, doc) {+	if (obj.ns === "svg") {+		obj.domRef = doc.createElementNS("http://www.w3.org/2000/svg", obj.tag);+	} else if (obj.ns === "mathml") {+		obj.domRef = doc.createElementNS("http://www.w3.org/1998/Math/MathML", obj.tag);+	} else {+		obj.domRef = doc.createElement(obj.tag);+	}     populate(null, obj, doc);-}+}; -function createNode(obj, parent, doc) {+window.createNode = function createNode(obj, parent, doc) {     if (obj.type === "vnode") createElement(obj, doc);     else obj.domRef = doc.createTextNode(obj.text);     parent.appendChild(obj.domRef);     callCreated(obj);-}+};  /* Child reconciliation algorithm, inspired by kivi and Bobril */-function syncChildren(os, ns, parent, doc) {+window.syncChildren = function syncChildren(os, ns, parent, doc) {     var oldFirstIndex = 0, 	newFirstIndex = 0, 	oldLastIndex = os.length - 1,@@ -195,7 +199,7 @@ 	    diff(null, nFirst, parent, doc); 	    /* insertBefore's semantics will append a node if the second argument provided is `null` or `undefined`. 	       Otherwise, it will insert node.domRef before oLast.domRef. */-	    parent.insertBefore(nFirst.domRef, oLast.domRef);+	    parent.insertBefore(oLast.domRef, nFirst.domRef); 	    os.splice(newFirstIndex, 0, nFirst); 	    newFirstIndex++; 	}@@ -329,16 +333,16 @@ 	    } 	}     }-}+}; -function swapDomRefs(tmp,a,b,p) {+window.swapDomRefs = function swapDomRefs(tmp,a,b,p) {   tmp = a.nextSibling;   p.insertBefore(a,b);   p.insertBefore(b,tmp);-}+}; -function swap(os,l,r) {+window.swap= function swap(os,l,r) {   var k = os[l];   os[l] = os[r];   os[r] = k;-}+};

@@ -1,8 +1,8 @@-function copyDOMIntoVTree (vtree) {+window.copyDOMIntoVTree = function copyDOMIntoVTree (vtree) {     walk (vtree, document.body.firstChild);-}+}; -function walk (vtree, node) {+window.walk = function walk (vtree, node) {     var i = 0, vdomChild, domChild;     vtree.domRef = node; @@ -20,5 +20,4 @@       walk(vdomChild, domChild);       i++;    }-}-+};

@@ -1,11 +1,11 @@-function callFocus(id) {+window.callFocus = function callFocus(id) {   setTimeout(function(){     var ele = document.getElementById(id);     if (ele && ele.focus) ele.focus()   }, 50); } -function callBlur(id) {+window.callBlur = function callBlur(id) {   setTimeout(function(){     var ele = document.getElementById(id);     if (ele && ele.blur) ele.blur()

@@ -1,5 +1,5 @@ name:                miso-version:             0.21.1.0+version:             0.21.2.0 category:            Web, Miso, Data Structures license:             BSD3 license-file:        LICENSE@@ -17,9 +17,6 @@  extra-source-files:   README.md-  examples/todo-mvc/index.html-  examples/websocket/index.html-  examples/mario/index.html   examples/mario/imgs/mario.png  flag examples@@ -34,10 +31,17 @@   description:     Builds Miso's tests +flag jsaddle+  manual: True+  default:+    False+  description:+    Compile with JSaddle+ executable todo-mvc   main-is:     Main.hs-  if !impl(ghcjs) || !flag(examples)+  if (!impl(ghcjs) && !flag(jsaddle)) || !flag(examples)     buildable: False   else     hs-source-dirs:@@ -46,7 +50,9 @@       aeson,       base < 5,       containers,-      miso+      jsaddle-warp,+      miso,+      transformers     default-language:       Haskell2010 @@ -120,7 +126,7 @@ executable router   main-is:     Main.hs-  if !impl(ghcjs) || !flag(examples)+  if (!impl(ghcjs) && !flag(jsaddle)) || !flag(examples)     buildable: False   else     hs-source-dirs:@@ -129,15 +135,17 @@       aeson,       base < 5,       containers,+      jsaddle-warp,       miso,-      servant+      servant,+      transformers     default-language:       Haskell2010  executable websocket   main-is:     Main.hs-  if !impl(ghcjs) || !flag(examples)+  if (!impl(ghcjs) && !flag(jsaddle)) || !flag(examples)     buildable: False   else     hs-source-dirs:@@ -146,14 +154,16 @@       aeson,       base < 5,       containers,-      miso+      jsaddle-warp,+      miso,+      transformers     default-language:       Haskell2010  executable mario   main-is:     Main.hs-  if !impl(ghcjs) || !flag(examples)+  if (!impl(ghcjs) && !flag(jsaddle)) || !flag(examples)     buildable: False   else     hs-source-dirs:@@ -161,7 +171,14 @@     build-depends:       base < 5,       containers,-      miso+      miso,+      jsaddle-warp+    if flag(jsaddle) && !impl(ghcjs)+      build-depends:+        wai,+        wai-app-static,+        warp,+        websockets     default-language:       Haskell2010 @@ -197,19 +214,35 @@     default-language:       Haskell2010 -executable simple+executable mathml   main-is:     Main.hs   if !impl(ghcjs) || !flag(examples)     buildable: False   else     hs-source-dirs:+      examples/mathml+    build-depends:+      base < 5,+      miso+    default-language:+      Haskell2010++executable simple+  main-is:+    Main.hs+  if (!impl(ghcjs) && !flag(jsaddle)) || !flag(examples)+    buildable: False+  else+    hs-source-dirs:       exe     build-depends:       aeson,       base < 5,       containers,-      miso+      jsaddle-warp,+      miso,+      transformers     default-language:       Haskell2010 @@ -220,9 +253,7 @@     buildable: False   else     hs-source-dirs:-      tests, ghcjs-src, src-    other-modules:-      Miso.FFI+      tests     build-depends:       aeson,       base < 5,@@ -262,7 +293,10 @@     Miso.Svg.Attribute     Miso.Svg.Element     Miso.Svg.Event+    Miso.Mathml+    Miso.Mathml.Element     Miso.String+    Miso.WebSocket   other-modules:     Miso.Concurrent     Miso.Html.Internal@@ -281,26 +315,36 @@     servant,     text,     transformers-  if impl(ghcjs)+  if impl(ghcjs) || flag (jsaddle)+    if flag(jsaddle)+      build-depends:+        file-embed,+        jsaddle+      cpp-options: -DJSADDLE+      hs-source-dirs:+        jsaddle-ffi+    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:-      ghcjs-src+      frontend-src     build-depends:-      ghcjs-base,       containers,       scientific,       unordered-containers,       transformers,       vector-    js-sources:-      jsbits/diff.js-      jsbits/delegate.js-      jsbits/isomorphic.js-      jsbits/util.js     exposed-modules:       Miso.Dev       Miso.Effect       Miso.Effect.Storage-      Miso.Effect.XHR       Miso.Effect.DOM       Miso.Subscription       Miso.Subscription.History@@ -313,6 +357,10 @@     other-modules:       Miso.Diff       Miso.FFI+      Miso.FFI.History+      Miso.FFI.SSE+      Miso.FFI.Storage+      Miso.FFI.WebSocket       Miso.Delegate   else     exposed-modules:

@@ -11,6 +11,7 @@ module Miso.Concurrent (     Notify (..)   , newNotify+  , newEmptyNotify   ) where  import Control.Concurrent@@ -28,3 +29,12 @@   pure $ Notify    (takeMVar mvar)    (() <$ do tryPutMVar mvar $! ())++-- | Create a new `Notify`+newEmptyNotify :: IO Notify+newEmptyNotify = do+  mvar <- newEmptyMVar+  pure $ Notify+   (takeMVar mvar)+   (() <$ do tryPutMVar mvar $! ())+

@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Mathml+-- 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+--+-- Example usage:+--+-- @+-- @+--+-- More information on how to use `miso` is available on GitHub+--+-- <http://github.com/dmjio/miso>+--+----------------------------------------------------------------------------+module Miso.Mathml+   ( module Miso.Mathml.Element+   ) where++import Miso.Mathml.Element

@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.Mathml.Element+-- 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.Mathml.Element+  ( -- * Construct an Element+      nodeMathml+  ) where++import           Miso.Html.Internal+import           Miso.String (MisoString)+import qualified Prelude            as P++-- | Used to construct `VNode`'s in `View`+nodeMathml :: MisoString -> [Attribute action] -> [View action] -> View action+nodeMathml = P.flip (node MATHML) P.Nothing

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}@@ -23,6 +24,9 @@ ---------------------------------------------------------------------------- module Miso.Router   ( runRoute+  , route+  , HasRouter+  , RouteT   , RoutingError (..)   ) where @@ -73,119 +77,135 @@ -- It is the class responsible for making API combinators routable. -- 'RouteT' is used to build up the handler types. -- 'Router' is returned, to be interpretted by 'routeLoc'.-class HasRouter model layout where-  -- | A route handler.-  type RouteT model layout a :: *-  -- | Transform a route handler into a 'Router'.-  route :: Proxy layout -> Proxy a -> RouteT model layout a -> model -> Router a+class HasRouter layout where+  -- | A mkRouter handler.+  type RouteT layout a :: *+  -- | Transform a mkRouter handler into a 'Router'.+  mkRouter :: Proxy layout -> Proxy a -> RouteT layout a -> Router a  -- | Alternative-instance (HasRouter m x, HasRouter m y) => HasRouter m (x :<|> y) where-  type RouteT m (x :<|> y) a = RouteT m x a :<|> RouteT m y a-  route _ (a :: Proxy a) ((x :: RouteT m x a) :<|> (y :: RouteT m y a)) m-    = RChoice (route (Proxy :: Proxy x) a x m) (route (Proxy :: Proxy y) a y m)+instance (HasRouter x, HasRouter y) => HasRouter (x :<|> y) where+  type RouteT (x :<|> y) a = RouteT x a :<|> RouteT y a+  mkRouter _ (a :: Proxy a) ((x :: RouteT x a) :<|> (y :: RouteT y a))+    = RChoice (mkRouter (Proxy :: Proxy x) a x) (mkRouter (Proxy :: Proxy y) a y)  -- | Capture-instance (HasRouter m sublayout, FromHttpApiData x) =>-  HasRouter m (Capture sym x :> sublayout) where-  type RouteT m (Capture sym x :> sublayout) a = x -> RouteT m sublayout a-  route _ a f m = RCapture (\x -> route (Proxy :: Proxy sublayout) a (f x) m)+instance (HasRouter sublayout, FromHttpApiData x) =>+  HasRouter (Capture sym x :> sublayout) where+  type RouteT (Capture sym x :> sublayout) a = x -> RouteT sublayout a+  mkRouter _ a f = RCapture (\x -> mkRouter (Proxy :: Proxy sublayout) a (f x))  -- | QueryParam-instance (HasRouter m sublayout, FromHttpApiData x, KnownSymbol sym)-         => HasRouter m (QueryParam sym x :> sublayout) where-  type RouteT m (QueryParam sym x :> sublayout) a = Maybe x -> RouteT m sublayout a-  route _ a f m = RQueryParam (Proxy :: Proxy sym)-    (\x -> route (Proxy :: Proxy sublayout) a (f x) m)+instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym)+         => HasRouter (QueryParam sym x :> sublayout) where+  type RouteT (QueryParam sym x :> sublayout) a = Maybe x -> RouteT sublayout a+  mkRouter _ a f = RQueryParam (Proxy :: Proxy sym)+    (\x -> mkRouter (Proxy :: Proxy sublayout) a (f x))  -- | QueryParams-instance (HasRouter m sublayout, FromHttpApiData x, KnownSymbol sym)-         => HasRouter m (QueryParams sym x :> sublayout) where-  type RouteT m (QueryParams sym x :> sublayout) a = [x] -> RouteT m sublayout a-  route _ a f m = RQueryParams+instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym)+         => HasRouter (QueryParams sym x :> sublayout) where+  type RouteT (QueryParams sym x :> sublayout) a = [x] -> RouteT sublayout a+  mkRouter _ a f = RQueryParams     (Proxy :: Proxy sym)-    (\x -> route (Proxy :: Proxy sublayout) a (f x) m)+    (\x -> mkRouter (Proxy :: Proxy sublayout) a (f x))  -- | QueryFlag-instance (HasRouter m sublayout, KnownSymbol sym)-         => HasRouter m (QueryFlag sym :> sublayout) where-  type RouteT m (QueryFlag sym :> sublayout) a = Bool -> RouteT m sublayout a-  route _ a f m = RQueryFlag+instance (HasRouter sublayout, KnownSymbol sym)+         => HasRouter (QueryFlag sym :> sublayout) where+  type RouteT (QueryFlag sym :> sublayout) a = Bool -> RouteT sublayout a+  mkRouter _ a f = RQueryFlag     (Proxy :: Proxy sym)-    (\x -> route (Proxy :: Proxy sublayout) a (f x) m)+    (\x -> mkRouter (Proxy :: Proxy sublayout) a (f x))  -- | Path-instance (HasRouter m sublayout, KnownSymbol path)-         => HasRouter m (path :> sublayout) where-  type RouteT m (path :> sublayout) a = RouteT m sublayout a-  route _ a page m = RPath+instance (HasRouter sublayout, KnownSymbol path)+         => HasRouter (path :> sublayout) where+  type RouteT (path :> sublayout) a = RouteT sublayout a+  mkRouter _ a page = RPath     (Proxy :: Proxy path)-    (route (Proxy :: Proxy sublayout) a page m)+    (mkRouter (Proxy :: Proxy sublayout) a page)  -- | View-instance HasRouter m (View a) where-  type RouteT m (View a) x = m -> x-  route _ _ a m = RPage (a m)+instance HasRouter (View a) where+  type RouteT (View a) x = x+  mkRouter _ _ a = RPage a --- | Use a handler to route a 'Location'.--- Normally 'runRoute' should be used instead, unless you want custom+-- | Verb+instance HasRouter (Verb m s c a) where+  type RouteT (Verb m s c a) x = x+  mkRouter _ _ a = RPage a++-- | Raw+instance HasRouter Raw where+  type RouteT Raw x = x+  mkRouter _ _ a = RPage a++-- | Use a handler to mkRouter a 'Location'.+-- Normally 'route' should be used instead, unless you want custom -- handling of string failing to parse as 'URI'.-runRouteLoc :: forall m layout a. HasRouter m layout-            => Location -> Proxy layout -> RouteT m layout a -> m -> Either RoutingError a-runRouteLoc loc layout page m =-  let routing = route layout (Proxy :: Proxy a) page m-  in routeLoc loc routing m+runRouteLoc :: forall layout a. HasRouter layout+            => Location -> Proxy layout -> RouteT layout a ->  Either RoutingError a+runRouteLoc loc layout page =+  let routing = mkRouter layout (Proxy :: Proxy a) page+  in routeLoc loc routing --- | Use a handler to route a location, represented as a 'String'.+-- | Use a handler to mkRouter a location, represented as a 'String'. -- All handlers must, in the end, return @m a@.--- 'routeLoc' will choose a route and return its result.+-- 'routeLoc' will choose a mkRouter and return its result.+route+  :: HasRouter layout+  => Proxy layout+  -> RouteT layout a+  -> URI+  -> Either RoutingError a+route layout handler u = runRouteLoc (uriToLocation u) layout handler+ runRoute-  :: HasRouter m layout+  :: HasRouter layout   => Proxy layout-  -> RouteT m layout a+  -> RouteT layout (m -> a)   -> (m -> URI)   -> m   -> Either RoutingError a-runRoute layout page getURI m =-  runRouteLoc (uriToLocation uri) layout page m-    where-      uri = getURI m+runRoute layout pages getURI model = ($ model) <$> route layout pages (getURI model) --- | Use a computed 'Router' to route a 'Location'.-routeLoc :: Location -> Router a -> m -> Either RoutingError a-routeLoc loc r m = case r of+-- | Use a computed 'Router' to mkRouter a 'Location'.+routeLoc :: Location -> Router a -> Either RoutingError a+routeLoc loc r = case r of   RChoice a b -> do-    case routeLoc loc a m of-      Left Fail -> routeLoc loc b m+    case routeLoc loc a of+      Left Fail -> routeLoc loc b       Right x -> Right x   RCapture f -> case locPath loc of     [] -> Left Fail     capture:paths ->       case parseUrlPieceMaybe capture of         Nothing -> Left Fail-        Just x -> routeLoc loc { locPath = paths } (f x) m+        Just x -> routeLoc loc { locPath = paths } (f x)   RQueryParam sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of-    Nothing -> routeLoc loc (f Nothing) m+    Nothing -> routeLoc loc (f Nothing)     Just Nothing -> Left Fail     Just (Just text) -> case parseQueryParamMaybe (decodeUtf8 text) of       Nothing -> Left Fail-      Just x -> routeLoc loc (f (Just x)) m-  RQueryParams sym f -> maybe (Left Fail) (\x -> routeLoc loc (f x) m) $ do+      Just x -> routeLoc loc (f (Just x))+  RQueryParams sym f -> maybe (Left Fail) (\x -> routeLoc loc (f x)) $ do     ps <- sequence $ snd <$> Prelude.filter       (\(k, _) -> k == BS.pack (symbolVal sym)) (locQuery loc)     sequence $ (parseQueryParamMaybe . decodeUtf8) <$> ps   RQueryFlag sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of-    Nothing -> routeLoc loc (f False) m-    Just Nothing -> routeLoc loc (f True) m+    Nothing -> routeLoc loc (f False)+    Just Nothing -> routeLoc loc (f True)     Just (Just _) -> Left Fail   RPath sym a -> case locPath loc of     [] -> Left Fail     p:paths -> if p == T.pack (symbolVal sym)-      then routeLoc (loc { locPath = paths }) a m+      then routeLoc (loc { locPath = paths }) a       else Left Fail   RPage a ->     case locPath loc of       [] -> Right a+      [""] -> Right a       _ -> Left Fail  -- | Convert a 'URI' to a 'Location'.

@@ -0,0 +1,106 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Miso.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.WebSocket+  ( -- * Types+    WebSocket   (..)+  , URL         (..)+  , Protocols   (..)+  , SocketState (..)+  , CloseCode   (..)+  , WasClean    (..)+  , Reason      (..)+  ) where++import GHC.Generics+import Prelude                hiding (map)+#ifdef __GHCJS__+import GHCJS.Marshal+#endif++import Miso.String++-- | WebSocket connection messages+data WebSocket action+  = WebSocketMessage action+  | WebSocketClose CloseCode WasClean Reason+  | WebSocketOpen+  | WebSocketError MisoString+    deriving (Show, Eq)++-- | URL of Websocket server+newtype URL = URL MisoString+  deriving (Show, Eq)++-- | Protocols for Websocket connection+newtype Protocols = Protocols [MisoString]+  deriving (Show, Eq)++-- | Wether or not the connection closed was done so cleanly+newtype WasClean = WasClean Bool deriving (Show, Eq)++-- | Reason for closed connection+newtype Reason = Reason MisoString deriving (Show, Eq)++-- | `SocketState` corresponding to current WebSocket connection+data SocketState+  = CONNECTING -- ^ 0+  | OPEN       -- ^ 1+  | CLOSING    -- ^ 2+  | CLOSED     -- ^ 3+  deriving (Show, Eq, Ord, Enum)++-- | Code corresponding to a closed connection+-- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent+data CloseCode+  = CLOSE_NORMAL+   -- ^ 1000, Normal closure; the connection successfully completed whatever purpose for which it was created.+  | CLOSE_GOING_AWAY+   -- ^ 1001, The endpoint is going away, either because of a server failure or because the browser is navigating away from the page that opened the connection.+  | CLOSE_PROTOCOL_ERROR+   -- ^ 1002, The endpoint is terminating the connection due to a protocol error.+  | CLOSE_UNSUPPORTED+   -- ^ 1003, The connection is being terminated because the endpoint received data of a type it cannot accept (for example, a textonly endpoint received binary data).+  | CLOSE_NO_STATUS+   -- ^ 1005, Reserved.  Indicates that no status code was provided even though one was expected.+  | CLOSE_ABNORMAL+   -- ^ 1006, Reserved. Used to indicate that a connection was closed abnormally (that is, with no close frame being sent) when a status code is expected.+  | Unsupported_Data+   -- ^ 1007, The endpoint is terminating the connection because a message was received that contained inconsistent data (e.g., nonUTF8 data within a text message).+  | Policy_Violation+   -- ^ 1008, The endpoint is terminating the connection because it received a message that violates its policy. This is a generic status code, used when codes 1003 and 1009 are not suitable.+  | CLOSE_TOO_LARGE+   -- ^ 1009, The endpoint is terminating the connection because a data frame was received that is too large.+  | Missing_Extension+   -- ^ 1010, The client is terminating the connection because it expected the server to negotiate one or more extension, but the server didn't.+  | Internal_Error+   -- ^ 1011, The server is terminating the connection because it encountered an unexpected condition that prevented it from fulfilling the request.+  | Service_Restart+   -- ^ 1012, The server is terminating the connection because it is restarting.+  | Try_Again_Later+   -- ^ 1013, The server is terminating the connection due to a temporary condition, e.g. it is overloaded and is casting off some of its clients.+  | TLS_Handshake+   -- ^ 1015, Reserved. Indicates that the connection was closed due to a failure to perform a TLS handshake (e.g., the server certificate can't be verified).+  | OtherCode Int+   -- ^ OtherCode that is reserved and not in the range 0999+  deriving (Show, Eq, Generic)++#ifdef __GHCJS__+-- Defined here to avoid an orphan instance+instance ToJSVal CloseCode+instance FromJSVal CloseCode+#endif

@@ -24,7 +24,6 @@ import           Test.QuickCheck.Monadic  import           Miso-import           Miso.FFI  instance Arbitrary Value where   arbitrary = sized sizedArbitraryValue@@ -82,7 +81,7 @@   :: Value   -> IO Bool roundTrip x = do-  Just y <- jsvalToValue =<< toJSVal x+  Just y <- fromJSVal =<< toJSVal x   pure $ compareValue x y == True  iso_prop :: Value -> Property