diff --git a/examples/file-reader/Main.hs b/examples/file-reader/Main.hs --- a/examples/file-reader/Main.hs +++ b/examples/file-reader/Main.hs @@ -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 diff --git a/examples/mario/Main.hs b/examples/mario/Main.hs --- a/examples/mario/Main.hs +++ b/examples/mario/Main.hs @@ -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 = diff --git a/examples/mario/index.html b/examples/mario/index.html deleted file mode 100644 --- a/examples/mario/index.html +++ /dev/null @@ -1,12 +0,0 @@ - - - - - - - - - - diff --git a/examples/mathml/Main.hs b/examples/mathml/Main.hs new file mode 100644 --- /dev/null +++ b/examples/mathml/Main.hs @@ -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"] + ] + ] diff --git a/examples/router/Main.hs b/examples/router/Main.hs --- a/examples/router/Main.hs +++ b/examples/router/Main.hs @@ -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 diff --git a/examples/three/Main.hs b/examples/three/Main.hs --- a/examples/three/Main.hs +++ b/examples/three/Main.hs @@ -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 () diff --git a/examples/todo-mvc/Main.hs b/examples/todo-mvc/Main.hs --- a/examples/todo-mvc/Main.hs +++ b/examples/todo-mvc/Main.hs @@ -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 diff --git a/examples/todo-mvc/index.html b/examples/todo-mvc/index.html deleted file mode 100644 --- a/examples/todo-mvc/index.html +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - - - - - diff --git a/examples/websocket/Main.hs b/examples/websocket/Main.hs --- a/examples/websocket/Main.hs +++ b/examples/websocket/Main.hs @@ -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 diff --git a/examples/websocket/index.html b/examples/websocket/index.html deleted file mode 100644 --- a/examples/websocket/index.html +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - - - - - diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -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 diff --git a/frontend-src/Miso.hs b/frontend-src/Miso.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso.hs @@ -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 +-- 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 ()) diff --git a/frontend-src/Miso/Delegate.hs b/frontend-src/Miso/Delegate.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Delegate.hs @@ -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 +-- 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 diff --git a/frontend-src/Miso/Dev.hs b/frontend-src/Miso/Dev.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Dev.hs @@ -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 +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Dev + ( clearBody + ) where + +import Miso.FFI (clearBody) diff --git a/frontend-src/Miso/Diff.hs b/frontend-src/Miso/Diff.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Diff.hs @@ -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 +-- 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 diff --git a/frontend-src/Miso/Effect.hs b/frontend-src/Miso/Effect.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Effect.hs @@ -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 +-- 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] diff --git a/frontend-src/Miso/Effect/DOM.hs b/frontend-src/Miso/Effect/DOM.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Effect/DOM.hs @@ -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 +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Effect.DOM + ( focus + , blur + , scrollIntoView + , alert + ) where + +import Miso.FFI diff --git a/frontend-src/Miso/Effect/Storage.hs b/frontend-src/Miso/Effect/Storage.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Effect/Storage.hs @@ -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 +-- 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 diff --git a/frontend-src/Miso/Html/Internal.hs b/frontend-src/Miso/Html/Internal.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Html/Internal.hs @@ -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 +-- 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" ] [ ] +-- +-- +-- +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) diff --git a/frontend-src/Miso/String.hs b/frontend-src/Miso/String.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/String.hs @@ -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 +-- 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 diff --git a/frontend-src/Miso/Subscription.hs b/frontend-src/Miso/Subscription.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Subscription.hs @@ -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 +-- 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 diff --git a/frontend-src/Miso/Subscription/History.hs b/frontend-src/Miso/Subscription/History.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Subscription/History.hs @@ -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 +-- 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) diff --git a/frontend-src/Miso/Subscription/Keyboard.hs b/frontend-src/Miso/Subscription/Keyboard.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Subscription/Keyboard.hs @@ -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 +-- 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)) diff --git a/frontend-src/Miso/Subscription/Mouse.hs b/frontend-src/Miso/Subscription/Mouse.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Subscription/Mouse.hs @@ -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 +-- 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)) diff --git a/frontend-src/Miso/Subscription/SSE.hs b/frontend-src/Miso/Subscription/SSE.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Subscription/SSE.hs @@ -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 +-- 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"); diff --git a/frontend-src/Miso/Subscription/WebSocket.hs b/frontend-src/Miso/Subscription/WebSocket.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Subscription/WebSocket.hs @@ -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 +-- 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 diff --git a/frontend-src/Miso/Subscription/Window.hs b/frontend-src/Miso/Subscription/Window.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Subscription/Window.hs @@ -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 +-- 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)) diff --git a/frontend-src/Miso/Types.hs b/frontend-src/Miso/Types.hs new file mode 100644 --- /dev/null +++ b/frontend-src/Miso/Types.hs @@ -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 +-- 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 +-- +-- 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 ] diff --git a/ghc-src/Miso.hs b/ghc-src/Miso.hs --- a/ghc-src/Miso.hs +++ b/ghc-src/Miso.hs @@ -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 diff --git a/ghc-src/Miso/Html/Internal.hs b/ghc-src/Miso/Html/Internal.hs --- a/ghc-src/Miso/Html/Internal.hs +++ b/ghc-src/Miso/Html/Internal.hs @@ -149,6 +149,7 @@ data NS = HTML -- ^ HTML Namespace | SVG -- ^ SVG Namespace + | MATHML -- ^ MATHML Namespace deriving (Show, Eq) -- | `VNode` creation diff --git a/ghcjs-ffi/Miso/FFI.hs b/ghcjs-ffi/Miso/FFI.hs new file mode 100644 --- /dev/null +++ b/ghcjs-ffi/Miso/FFI.hs @@ -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 +-- 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 () diff --git a/ghcjs-ffi/Miso/FFI/History.hs b/ghcjs-ffi/Miso/FFI/History.hs new file mode 100644 --- /dev/null +++ b/ghcjs-ffi/Miso/FFI/History.hs @@ -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 +-- 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 () diff --git a/ghcjs-ffi/Miso/FFI/SSE.hs b/ghcjs-ffi/Miso/FFI/SSE.hs new file mode 100644 --- /dev/null +++ b/ghcjs-ffi/Miso/FFI/SSE.hs @@ -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 +-- 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 diff --git a/ghcjs-ffi/Miso/FFI/Storage.hs b/ghcjs-ffi/Miso/FFI/Storage.hs new file mode 100644 --- /dev/null +++ b/ghcjs-ffi/Miso/FFI/Storage.hs @@ -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 +-- 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 () diff --git a/ghcjs-ffi/Miso/FFI/WebSocket.hs b/ghcjs-ffi/Miso/FFI/WebSocket.hs new file mode 100644 --- /dev/null +++ b/ghcjs-ffi/Miso/FFI/WebSocket.hs @@ -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 +-- 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 diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs deleted file mode 100644 --- a/ghcjs-src/Miso.hs +++ /dev/null @@ -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 --- 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 () diff --git a/ghcjs-src/Miso/Delegate.hs b/ghcjs-src/Miso/Delegate.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Delegate.hs +++ /dev/null @@ -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 --- 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 () diff --git a/ghcjs-src/Miso/Dev.hs b/ghcjs-src/Miso/Dev.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Dev.hs +++ /dev/null @@ -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 --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso.Dev - ( clearBody - ) where - -import Miso.FFI (clearBody) diff --git a/ghcjs-src/Miso/Diff.hs b/ghcjs-src/Miso/Diff.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Diff.hs +++ /dev/null @@ -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 --- 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 () diff --git a/ghcjs-src/Miso/Effect.hs b/ghcjs-src/Miso/Effect.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Effect.hs +++ /dev/null @@ -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 --- 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] diff --git a/ghcjs-src/Miso/Effect/DOM.hs b/ghcjs-src/Miso/Effect/DOM.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Effect/DOM.hs +++ /dev/null @@ -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 --- 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 () diff --git a/ghcjs-src/Miso/Effect/Storage.hs b/ghcjs-src/Miso/Effect/Storage.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Effect/Storage.hs +++ /dev/null @@ -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 --- 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 () diff --git a/ghcjs-src/Miso/Effect/XHR.hs b/ghcjs-src/Miso/Effect/XHR.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Effect/XHR.hs +++ /dev/null @@ -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 --- 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 diff --git a/ghcjs-src/Miso/FFI.hs b/ghcjs-src/Miso/FFI.hs deleted file mode 100644 --- a/ghcjs-src/Miso/FFI.hs +++ /dev/null @@ -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 --- 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 diff --git a/ghcjs-src/Miso/Html/Internal.hs b/ghcjs-src/Miso/Html/Internal.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Html/Internal.hs +++ /dev/null @@ -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 --- 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" ] [ ] --- --- --- -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 () diff --git a/ghcjs-src/Miso/String.hs b/ghcjs-src/Miso/String.hs deleted file mode 100644 --- a/ghcjs-src/Miso/String.hs +++ /dev/null @@ -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 --- 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 diff --git a/ghcjs-src/Miso/Subscription.hs b/ghcjs-src/Miso/Subscription.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Subscription.hs +++ /dev/null @@ -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 --- 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 diff --git a/ghcjs-src/Miso/Subscription/History.hs b/ghcjs-src/Miso/Subscription/History.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Subscription/History.hs +++ /dev/null @@ -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 --- 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 diff --git a/ghcjs-src/Miso/Subscription/Keyboard.hs b/ghcjs-src/Miso/Subscription/Keyboard.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Subscription/Keyboard.hs +++ /dev/null @@ -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 --- 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) diff --git a/ghcjs-src/Miso/Subscription/Mouse.hs b/ghcjs-src/Miso/Subscription/Mouse.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Subscription/Mouse.hs +++ /dev/null @@ -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 --- 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) diff --git a/ghcjs-src/Miso/Subscription/SSE.hs b/ghcjs-src/Miso/Subscription/SSE.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Subscription/SSE.hs +++ /dev/null @@ -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 --- 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"); diff --git a/ghcjs-src/Miso/Subscription/WebSocket.hs b/ghcjs-src/Miso/Subscription/WebSocket.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Subscription/WebSocket.hs +++ /dev/null @@ -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 --- 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 diff --git a/ghcjs-src/Miso/Subscription/Window.hs b/ghcjs-src/Miso/Subscription/Window.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Subscription/Window.hs +++ /dev/null @@ -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 --- 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) diff --git a/ghcjs-src/Miso/Types.hs b/ghcjs-src/Miso/Types.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Types.hs +++ /dev/null @@ -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 --- 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 --- --- 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 ] diff --git a/jsaddle-ffi/Miso/Dev.hs b/jsaddle-ffi/Miso/Dev.hs new file mode 100644 --- /dev/null +++ b/jsaddle-ffi/Miso/Dev.hs @@ -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 +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Dev + ( clearBody + ) where + +import Miso.FFI (clearBody) diff --git a/jsaddle-ffi/Miso/FFI.hs b/jsaddle-ffi/Miso/FFI.hs new file mode 100644 --- /dev/null +++ b/jsaddle-ffi/Miso/FFI.hs @@ -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 +-- 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 diff --git a/jsaddle-ffi/Miso/FFI/History.hs b/jsaddle-ffi/Miso/FFI/History.hs new file mode 100644 --- /dev/null +++ b/jsaddle-ffi/Miso/FFI/History.hs @@ -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 +-- 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 () diff --git a/jsaddle-ffi/Miso/FFI/SSE.hs b/jsaddle-ffi/Miso/FFI/SSE.hs new file mode 100644 --- /dev/null +++ b/jsaddle-ffi/Miso/FFI/SSE.hs @@ -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 +-- 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 diff --git a/jsaddle-ffi/Miso/FFI/Storage.hs b/jsaddle-ffi/Miso/FFI/Storage.hs new file mode 100644 --- /dev/null +++ b/jsaddle-ffi/Miso/FFI/Storage.hs @@ -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 +-- 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 () diff --git a/jsaddle-ffi/Miso/FFI/WebSocket.hs b/jsaddle-ffi/Miso/FFI/WebSocket.hs new file mode 100644 --- /dev/null +++ b/jsaddle-ffi/Miso/FFI/WebSocket.hs @@ -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 +-- 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)) diff --git a/jsbits/delegate.js b/jsbits/delegate.js --- a/jsbits/delegate.js +++ b/jsbits/delegate.js @@ -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; +}; diff --git a/jsbits/diff.js b/jsbits/diff.js --- a/jsbits/diff.js +++ b/jsbits/diff.js @@ -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; -} +}; diff --git a/jsbits/isomorphic.js b/jsbits/isomorphic.js --- a/jsbits/isomorphic.js +++ b/jsbits/isomorphic.js @@ -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++; } -} - +}; diff --git a/jsbits/util.js b/jsbits/util.js --- a/jsbits/util.js +++ b/jsbits/util.js @@ -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() diff --git a/miso.cabal b/miso.cabal --- a/miso.cabal +++ b/miso.cabal @@ -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: diff --git a/src/Miso/Concurrent.hs b/src/Miso/Concurrent.hs --- a/src/Miso/Concurrent.hs +++ b/src/Miso/Concurrent.hs @@ -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 $! ()) + diff --git a/src/Miso/Mathml.hs b/src/Miso/Mathml.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Mathml.hs @@ -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 +-- Stability : experimental +-- Portability : non-portable +-- +-- Example usage: +-- +-- @ +-- @ +-- +-- More information on how to use `miso` is available on GitHub +-- +-- +-- +---------------------------------------------------------------------------- +module Miso.Mathml + ( module Miso.Mathml.Element + ) where + +import Miso.Mathml.Element diff --git a/src/Miso/Mathml/Element.hs b/src/Miso/Mathml/Element.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Mathml/Element.hs @@ -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 +-- 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 diff --git a/src/Miso/Router.hs b/src/Miso/Router.hs --- a/src/Miso/Router.hs +++ b/src/Miso/Router.hs @@ -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'. diff --git a/src/Miso/WebSocket.hs b/src/Miso/WebSocket.hs new file mode 100644 --- /dev/null +++ b/src/Miso/WebSocket.hs @@ -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 +-- 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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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