diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -17,13 +17,13 @@ Cachix - - Travis CI + + GitHub Actions Hackage - + IRC #haskell-miso @@ -55,6 +55,7 @@ - [Simple](#simple) - [File Reader](#file-reader) - [WebVR](#webvr) + - [Pixel Card Wars](#pixel-card-wars) - [Haddocks](#haddocks) - [GHC](#ghc) - [GHCJS](#ghcjs) @@ -179,52 +180,55 @@ ## Examples ### TodoMVC - - [Link](http://todo-mvc.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/todo-mvc/Main.hs) + - [Link](https://todo-mvc.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/todo-mvc/Main.hs) ### Flatris - - [Link](http://flatris.haskell-miso.org/) / [Source](https://github.com/ptigwe/hs-flatris/) + - [Link](https://flatris.haskell-miso.org/) / [Source](https://github.com/ptigwe/hs-flatris/) ### 2048 - - [Link](http://2048.haskell-miso.org/) / [Source](https://github.com/ptigwe/hs2048/) + - [Link](https://2048.haskell-miso.org/) / [Source](https://github.com/ptigwe/hs2048/) ### Snake - - [Link](http://snake.haskell-miso.org/) / [Source](https://github.com/lbonn/miso-snake) + - [Link](https://snake.haskell-miso.org/) / [Source](https://github.com/lbonn/miso-snake) ### Mario - - [Link](http://mario.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/mario/Main.hs) + - [Link](https://mario.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/mario/Main.hs) ### Miso Plane (Flappy Birds) - - [Link](http://miso-plane.lermex.net/) / [Source](https://github.com/Lermex/miso-plane) + - [Link](http://miso-plane.haskell-miso.org) / [Source](https://github.com/Lermex/miso-plane) ### Websocket - - [Link](http://websocket.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/websocket/Main.hs) + - [Link](https://websocket.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/websocket/Main.hs) ### SSE - [Link](http://sse.haskell-miso.org/) / [Client](https://github.com/dmjio/miso/blob/master/examples/sse/client/Main.hs) / [Server](https://github.com/dmjio/miso/blob/master/examples/sse/server/Main.hs) ### XHR - - [Link](http://xhr.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/xhr/Main.hs) + - [Link](https://xhr.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/xhr/Main.hs) ### Router - - [Link](http://router.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/router/Main.hs) + - [Link](https://router.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/router/Main.hs) ### SVG - - [Link](http://svg.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/svg/Main.hs) + - [Link](https://svg.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/svg/Main.hs) ### Canvas 2D - - [Link](http://canvas.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/canvas2d/Main.hs) + - [Link](https://canvas.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/canvas2d/Main.hs) ### ThreeJS - - [Link](http://threejs.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/three/Main.hs) + - [Link](https://threejs.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/three/Main.hs) ### Simple - - [Link](http://simple.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/exe/Main.hs) + - [Link](https://simple.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/exe/Main.hs) ### File Reader - - [Link](http://file-reader.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/file-reader/Main.hs) + - [Link](https://file-reader.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/file-reader/Main.hs) ### WebVR - [Link](http://fizruk.github.io/fpconf-2017-talk/miso-aframe-demo/dist/demo.jsexe/index.html) / [Source](https://github.com/fizruk/miso-aframe) + +### Pixel Card Wars + - [Link](https://www.schplaf.org/hgames/darkcraw/) / [Source](https://github.com/smelc/miso-darkcraw) ## Haddocks diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -62,4 +62,5 @@ button_ [ onClick AddOne ] [ text "+" ] , text (ms x) , button_ [ onClick SubtractOne ] [ text "-" ] + , rawHtml "

hey expandable!

" ] diff --git a/frontend-src/Miso.hs b/frontend-src/Miso.hs deleted file mode 100644 --- a/frontend-src/Miso.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} - -#ifdef IOS -#else -{-# LANGUAGE TemplateHaskell #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Miso --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso - ( miso - , startApp - , module Miso.Effect - , module Miso.Event - , module Miso.Html - , module Miso.Subscription - , module Miso.Types - , module Miso.Router - , module Miso.Util - , module Miso.FFI - ) where - -import Control.Concurrent -import Control.Monad -import Control.Monad.IO.Class -import Data.IORef -import Data.List -import Data.Sequence ((|>)) -import System.Mem.StableName -import qualified Data.Sequence as S -import qualified JavaScript.Object.Internal as OI - -#ifdef JSADDLE -import Language.Javascript.JSaddle (eval, waitForAnimationFrame) -#ifdef IOS -import Miso.JSBits -#else -import GHCJS.Types (JSString) -import Data.FileEmbed -#endif -#else -import JavaScript.Web.AnimationFrame -#endif - -import Miso.Concurrent -import Miso.Delegate -import Miso.Diff -import Miso.Effect -import Miso.Event -import Miso.FFI -import Miso.Html -import Miso.Router -import Miso.Subscription -import Miso.Types -import Miso.Util - --- | Helper function to abstract out common functionality between `startApp` and `miso` -common - :: Eq model - => App model action - -> model - -> (Sink action -> JSM (IORef VTree)) - -> JSM () -common App {..} m getView = do -#ifdef JSADDLE -#ifdef IOS - mapM_ eval [delegateJs,diffJs,isomorphicJs,utilJs] -#else - _ <- eval ($(embedStringFile "jsbits/delegate.js") :: JSString) - _ <- eval ($(embedStringFile "jsbits/diff.js") :: JSString) - _ <- eval ($(embedStringFile "jsbits/isomorphic.js") :: JSString) - _ <- eval ($(embedStringFile "jsbits/util.js") :: JSString) -#endif -#endif - -- init Notifier - Notify {..} <- liftIO newNotify - -- init empty actions - actionsRef <- liftIO (newIORef S.empty) - let writeEvent a = void . liftIO . forkIO $ do - atomicModifyIORef' actionsRef $ \as -> (as |> a, ()) - notify - -- init Subs - forM_ subs $ \sub -> - sub writeEvent - -- Hack to get around `BlockedIndefinitelyOnMVar` exception - -- that occurs when no event handlers are present on a template - -- and `notify` is no longer in scope - void . liftIO . forkIO . forever $ threadDelay (1000000 * 86400) >> notify - -- Retrieves reference view - viewRef <- getView writeEvent - -- know thy mountElement - mountEl <- mountElement mountPoint - -- Begin listening for events in the virtual dom - delegator mountEl viewRef events - -- Process initial action of application - writeEvent initialAction - -- Program loop, blocking on SkipChan - - let - loop !oldModel = liftIO wait >> do - -- Apply actions to model - actions <- liftIO $ atomicModifyIORef' actionsRef $ \actions -> (S.empty, actions) - let (Acc newModel effects) = foldl' (foldEffects writeEvent update) - (Acc oldModel (pure ())) actions - effects - oldName <- liftIO $ oldModel `seq` makeStableName oldModel - newName <- liftIO $ newModel `seq` makeStableName newModel - when (oldName /= newName && oldModel /= newModel) $ do - swapCallbacks - newVTree <- runView (view newModel) writeEvent - oldVTree <- liftIO (readIORef viewRef) - void $ waitForAnimationFrame - (diff mountPoint) (Just oldVTree) (Just newVTree) - releaseCallbacks - liftIO (atomicWriteIORef viewRef newVTree) - syncPoint - loop newModel - loop m - --- | Runs an isomorphic miso application. --- Assumes the pre-rendered DOM is already present -miso :: Eq model => (URI -> App model action) -> JSM () -miso f = do - app@App {..} <- f <$> getCurrentURI - common app model $ \writeEvent -> do - let initialView = view model - VTree (OI.Object iv) <- flip runView writeEvent initialView - mountEl <- mountElement mountPoint - -- Initial diff can be bypassed, just copy DOM into VTree - copyDOMIntoVTree (logLevel == DebugPrerender) mountEl iv - let initialVTree = VTree (OI.Object iv) - -- Create virtual dom, perform initial diff - liftIO (newIORef initialVTree) - --- | Runs a miso application -startApp :: Eq model => App model action -> JSM () -startApp app@App {..} = - common app model $ \writeEvent -> do - let initialView = view model - initialVTree <- flip runView writeEvent initialView - (diff mountPoint) Nothing (Just initialVTree) - liftIO (newIORef initialVTree) - --- | Helper -foldEffects - :: Sink action - -> (action -> model -> Effect action model) - -> Acc model -> action -> Acc model -foldEffects sink update = \(Acc model as) action -> - case update action model of - Effect newModel effs -> Acc newModel newAs - where - newAs = as >> do - forM_ effs $ \eff -> forkJSM (eff sink) - -data Acc model = Acc !model !(JSM ()) diff --git a/frontend-src/Miso/Delegate.hs b/frontend-src/Miso/Delegate.hs deleted file mode 100644 --- a/frontend-src/Miso/Delegate.hs +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Miso.Delegate --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- 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 deleted file mode 100644 --- a/frontend-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/frontend-src/Miso/Diff.hs b/frontend-src/Miso/Diff.hs deleted file mode 100644 --- a/frontend-src/Miso/Diff.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Miso.Diff --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- 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 deleted file mode 100644 --- a/frontend-src/Miso/Effect.hs +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Miso.Effect --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable --- --- This module defines `Effect` and `Sub` types, which are used to define --- `Miso.Types.update` function and `Miso.Types.subs` field of the `Miso.Types.App`. ----------------------------------------------------------------------------- -module Miso.Effect ( - module Miso.Effect.Storage -, module Miso.Effect.DOM -, Effect (..), Sub, Sink -, mapSub -, noEff -, (<#) -, (#>) -, batchEff -, effectSub -) where - -import Data.Bifunctor - -import Control.Monad.IO.Class -import Miso.FFI (JSM) - -import Miso.Effect.Storage -import Miso.Effect.DOM - --- | An effect represents the results of an update action. --- --- It consists of the updated model and a list of subscriptions. Each 'Sub' is --- run in a new thread so there is no risk of accidentally blocking the --- application. -data Effect action model = Effect model [Sub action] - --- | Type synonym for constructing event subscriptions. --- --- The 'Sink' callback is used to dispatch actions which are then fed --- back to the 'Miso.Types.update' function. -type Sub action = Sink action -> JSM () - --- | Function to asynchronously dispatch actions to the 'Miso.Types.update' function. -type Sink action = action -> IO () - --- | Turn a subscription that consumes actions of type @a@ into a subscription --- that consumes actions of type @b@ using the supplied function of type @a -> b@. -mapSub :: (actionA -> actionB) -> Sub actionA -> Sub actionB -mapSub f sub = \sinkB -> let sinkA = sinkB . f - in sub sinkA - -instance Functor (Effect action) where - fmap f (Effect m acts) = Effect (f m) acts - -instance Applicative (Effect action) where - pure m = Effect m [] - Effect fModel fActs <*> Effect xModel xActs = Effect (fModel xModel) (fActs ++ xActs) - -instance Monad (Effect action) where - return = pure - Effect m acts >>= f = - case f m of - Effect m' acts' -> Effect m' (acts ++ acts') - -instance Bifunctor Effect where - bimap f g (Effect m acts) = Effect (g m) (map (\act -> \sink -> act (sink . f)) acts) - --- | Smart constructor for an 'Effect' with no actions. -noEff :: model -> Effect action model -noEff m = Effect m [] - --- | Smart constructor for an 'Effect' with exactly one action. -(<#) :: model -> JSM action -> Effect action model -(<#) m a = effectSub m $ \sink -> a >>= liftIO . sink - --- | `Effect` smart constructor, flipped -(#>) :: JSM action -> model -> Effect action model -(#>) = flip (<#) - --- | Smart constructor for an 'Effect' with multiple actions. -batchEff :: model -> [JSM action] -> Effect action model -batchEff model actions = Effect model $ - map (\a sink -> liftIO . sink =<< a) actions - --- | Like '<#' but schedules a subscription which is an IO computation which has --- access to a 'Sink' which can be used to asynchronously dispatch actions to --- the 'update' function. --- --- A use-case is scheduling an IO computation which creates a 3rd-party JS --- widget which has an associated callback. The callback can then call the sink --- to turn events into actions. To do this without accessing a sink requires --- going via a @'Sub'scription@ which introduces a leaky-abstraction. -effectSub :: model -> Sub action -> Effect action model -effectSub model sub = Effect model [sub] diff --git a/frontend-src/Miso/Effect/DOM.hs b/frontend-src/Miso/Effect/DOM.hs deleted file mode 100644 --- a/frontend-src/Miso/Effect/DOM.hs +++ /dev/null @@ -1,17 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Miso.Effect.DOM --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- 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 deleted file mode 100644 --- a/frontend-src/Miso/Effect/Storage.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE LambdaCase #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.Effect.Storage --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable --- --- This module provides an interface to the --- [Web Storage API](https://developer.mozilla.org/en-US/docs/Web/API/Web_Storage_API). ----------------------------------------------------------------------------- -module Miso.Effect.Storage - ( -- * Retrieve storage - getLocalStorage - , getSessionStorage - -- * Set items in storage - , setLocalStorage - , setSessionStorage - -- * Remove items from storage - , removeLocalStorage - , removeSessionStorage - -- * Clear storage - , clearLocalStorage - , clearSessionStorage - -- * Get number of items in storage - , localStorageLength - , sessionStorageLength - ) where - -import Data.Aeson hiding (Object, String) -import Data.JSString -import GHCJS.Marshal -import GHCJS.Types - -import Miso.FFI - -import qualified Miso.FFI.Storage as Storage - --- | Helper for retrieving either local or session storage -getStorageCommon - :: FromJSON b => (t -> JSM (Maybe JSVal)) -> t -> JSM (Either String b) -getStorageCommon f key = do - result :: Maybe JSVal <- f key - case result of - Nothing -> pure $ Left "Not Found" - Just v -> do - r <- parse v - pure $ case fromJSON r of - Success x -> Right x - Error y -> Left y - --- | Retrieve a value stored under given key in session storage -getSessionStorage :: FromJSON model => JSString -> JSM (Either String model) -getSessionStorage = - getStorageCommon $ \t -> do - s <- Storage.sessionStorage - r <- Storage.getItem s t - fromJSVal r - --- | Retrieve a value stored under given key in local storage -getLocalStorage :: FromJSON model => JSString -> JSM (Either String model) -getLocalStorage = getStorageCommon $ \t -> do - s <- Storage.localStorage - r <- Storage.getItem s t - fromJSVal r - --- | Set the value of a key in local storage. --- --- @setLocalStorage key value@ sets the value of @key@ to @value@. -setLocalStorage :: ToJSON model => JSString -> model -> JSM () -setLocalStorage key model = do - s <- Storage.localStorage - Storage.setItem s key =<< stringify model - --- | Set the value of a key in session storage. --- --- @setSessionStorage key value@ sets the value of @key@ to @value@. -setSessionStorage :: ToJSON model => JSString -> model -> JSM () -setSessionStorage key model = do - s <- Storage.sessionStorage - Storage.setItem s key =<< stringify model - -removeLocalStorage :: JSString -> JSM () -removeLocalStorage key = do - s <- Storage.localStorage - Storage.removeItem s key - -removeSessionStorage :: JSString -> JSM () -removeSessionStorage key = do - s <- Storage.sessionStorage - Storage.removeItem s key - -clearLocalStorage :: JSM () -clearLocalStorage = Storage.clear =<< Storage.localStorage - -clearSessionStorage :: JSM () -clearSessionStorage = Storage.clear =<< Storage.sessionStorage - -localStorageLength :: JSM Int -localStorageLength = Storage.length =<< Storage.localStorage - -sessionStorageLength :: JSM Int -sessionStorageLength = Storage.length =<< Storage.sessionStorage diff --git a/frontend-src/Miso/Html/Internal.hs b/frontend-src/Miso/Html/Internal.hs deleted file mode 100644 --- a/frontend-src/Miso/Html/Internal.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.Html.Internal --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso.Html.Internal ( - -- * Core types and interface - VTree (..) - , View (..) - , ToView (..) - , Attribute (..) - -- * Smart `View` constructors - , node - , text - , textRaw - -- * Key patch internals - , Key (..) - , ToKey (..) - -- * Namespace - , NS (..) - -- * Setting properties on virtual DOM nodes - , prop - -- * Setting css - , style_ - -- * Handling events - , on - , onWithOptions - -- * Life cycle events - , onCreated - , onDestroyed - , onBeforeDestroyed - -- * Events - , defaultEvents - -- * Subscription type - , Sub - ) where - -import Control.Monad -import Control.Monad.IO.Class -import Data.Aeson.Types (parseEither) -import Data.JSString -import qualified Data.Map as M -import Data.Proxy -import Data.String (IsString(..)) -import qualified Data.Text as T -import GHCJS.Marshal -import GHCJS.Types -import qualified JavaScript.Array as JSArray -import JavaScript.Object -import JavaScript.Object.Internal (Object (Object)) -import Servant.API - -import Miso.Effect (Sub) -import Miso.Event.Decoder -import Miso.Event.Types -import Miso.String -import Miso.Effect (Sink) -import Miso.FFI - --- | Virtual DOM implemented as a JavaScript `Object`. --- Used for diffing, patching and event delegation. --- Not meant to be constructed directly, see `View` instead. -newtype VTree = VTree { getTree :: Object } - --- | Core type for constructing a `VTree`, use this instead of `VTree` directly. -newtype View action = View { - runView :: Sink action -> JSM VTree -} deriving Functor - --- | For constructing type-safe links -instance HasLink (View a) where -#if MIN_VERSION_servant(0,14,0) - type MkLink (View a) b = MkLink (Get '[] ()) b - toLink toA Proxy = toLink toA (Proxy :: Proxy (Get '[] ())) -#else - type MkLink (View a) = MkLink (Get '[] ()) - toLink _ = toLink (Proxy :: Proxy (Get '[] ())) -#endif - --- | Convenience class for using View -class ToView v where toView :: v -> View m - --- | `ToJSVal` instance for `Decoder` -instance ToJSVal DecodeTarget where - toJSVal (DecodeTarget xs) = toJSVal xs - toJSVal (DecodeTargets xs) = toJSVal xs - --- | Create a new @VNode@. --- --- @node ns tag key attrs children@ creates a new node with tag @tag@ --- and 'Key' @key@ in the namespace @ns@. All @attrs@ are called when --- the node is created and its children are initialized to @children@. -node :: NS - -> MisoString - -> Maybe Key - -> [Attribute m] - -> [View m] - -> View m -node ns tag key attrs kids = View $ \sink -> do - vnode <- create - cssObj <- objectToJSVal =<< create - propsObj <- objectToJSVal =<< create - eventObj <- objectToJSVal =<< create - set "css" cssObj vnode - set "props" propsObj vnode - set "events" eventObj vnode - set "type" ("vnode" :: JSString) vnode - set "ns" ns vnode - set "tag" tag vnode - set "key" key vnode - setAttrs vnode sink - flip (set "children") vnode - =<< ghcjsPure . jsval - =<< setKids sink - pure $ VTree vnode - where - setAttrs vnode sink = - forM_ attrs $ \(Attribute attr) -> - attr sink vnode - setKids sink = do - kidsViews <- traverse (objectToJSVal . getTree <=< flip runView sink) kids - ghcjsPure (JSArray.fromList kidsViews) - -instance ToJSVal Options -instance ToJSVal Key where toJSVal (Key x) = toJSVal x - -instance ToJSVal NS where - toJSVal SVG = toJSVal ("svg" :: JSString) - toJSVal HTML = toJSVal ("html" :: JSString) - toJSVal MATHML = toJSVal ("mathml" :: JSString) - --- | Namespace of DOM elements. -data NS - = HTML -- ^ HTML Namespace - | SVG -- ^ SVG Namespace - | MATHML -- ^ MATHML Namespace - deriving (Show, Eq) - --- | Create a new @VText@ with the given content. -text :: MisoString -> View m -text t = View . const $ do - vtree <- create - set "type" ("vtext" :: JSString) vtree - set "text" t vtree - pure $ VTree vtree - --- | For parity with server-side rendering. Don't use directly. -textRaw :: MisoString -> View m -textRaw = text - --- | `IsString` instance -instance IsString (View a) where - fromString = text . fromString - --- | A unique key for a dom node. --- --- This key is only used to speed up diffing the children of a DOM --- node, the actual content is not important. The keys of the children --- of a given DOM node must be unique. Failure to satisfy this --- invariant gives undefined behavior at runtime. -newtype Key = Key MisoString - --- | Convert custom key types to `Key`. --- --- Instances of this class do not have to guarantee uniqueness of the --- generated keys, it is up to the user to do so. `toKey` must be an --- injective function. -class ToKey key where toKey :: key -> Key --- | Identity instance -instance ToKey Key where toKey = id --- | Convert `MisoString` to `Key` -instance ToKey MisoString where toKey = Key --- | Convert `Text` to `Key` -instance ToKey T.Text where toKey = Key . toMisoString --- | Convert `String` to `Key` -instance ToKey String where toKey = Key . toMisoString --- | Convert `Int` to `Key` -instance ToKey Int where toKey = Key . toMisoString --- | Convert `Double` to `Key` -instance ToKey Double where toKey = Key . toMisoString --- | Convert `Float` to `Key` -instance ToKey Float where toKey = Key . toMisoString --- | Convert `Word` to `Key` -instance ToKey Word where toKey = Key . toMisoString - --- | Attribute of a vnode in a `View`. --- --- The 'Sink' callback can be used to dispatch actions which are fed back to --- the @update@ function. This is especially useful for event handlers --- like the @onclick@ attribute. The second argument represents the --- vnode the attribute is attached to. -newtype Attribute action = Attribute (Sink action -> Object -> JSM ()) - --- | @prop k v@ is an attribute that will set the attribute @k@ of the DOM node associated with the vnode --- to @v@. -prop :: ToJSVal a => MisoString -> a -> Attribute action -prop k v = Attribute . const $ \n -> do - val <- toJSVal v - o <- getProp ("props" :: MisoString) n - set k val (Object o) - --- | Convenience wrapper for @onWithOptions defaultOptions@. --- --- > let clickHandler = on "click" emptyDecoder $ \() -> Action --- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ] --- -on :: MisoString - -> Decoder r - -> (r -> action) - -> Attribute action -on = onWithOptions defaultOptions - --- | @onWithOptions opts eventName decoder toAction@ is an attribute --- that will set the event handler of the associated DOM node to a function that --- decodes its argument using @decoder@, converts it to an action --- using @toAction@ and then feeds that action back to the @update@ function. --- --- @opts@ can be used to disable further event propagation. --- --- > let clickHandler = onWithOptions defaultOptions "click" emptyDecoder $ \() -> Action --- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ] --- -onWithOptions - :: Options - -> MisoString - -> Decoder r - -> (r -> action) - -> Attribute action -onWithOptions options eventName Decoder{..} toAction = - Attribute $ \sink n -> do - eventObj <- getProp "events" n - eventHandlerObject@(Object eo) <- create - jsOptions <- toJSVal options - decodeAtVal <- toJSVal decodeAt - cb <- callbackToJSVal <=< asyncCallback1 $ \e -> do - Just v <- fromJSVal =<< objectToJSON decodeAtVal e - case parseEither decoder v of - Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s - Right r -> liftIO (sink (toAction r)) - set "runEvent" cb eventHandlerObject - registerCallback cb - set "options" jsOptions eventHandlerObject - set eventName eo (Object eventObj) - --- | @onCreated action@ is an event that gets called after the actual DOM --- element is created. --- --- Important note: Any node that uses this event MUST have a unique @Key@, --- otherwise the event may not be reliably called! -onCreated :: action -> Attribute action -onCreated action = - Attribute $ \sink n -> do - cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action)) - set "onCreated" cb n - registerCallback cb - --- | @onDestroyed action@ is an event that gets called after the DOM element --- is removed from the DOM. The @action@ is given the DOM element that was --- removed from the DOM tree. --- --- Important note: Any node that uses this event MUST have a unique @Key@, --- otherwise the event may not be reliably called! -onDestroyed :: action -> Attribute action -onDestroyed action = - Attribute $ \sink n -> do - cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action)) - set "onDestroyed" cb n - registerCallback cb - --- | @onBeforeDestroyed action@ is an event that gets called before the DOM element --- is removed from the DOM. The @action@ is given the DOM element that was --- removed from the DOM tree. --- --- Important note: Any node that uses this event MUST have a unique @Key@, --- otherwise the event may not be reliably called! -onBeforeDestroyed :: action -> Attribute action -onBeforeDestroyed action = - Attribute $ \sink n -> do - cb <- callbackToJSVal =<< asyncCallback (liftIO (sink action)) - set "onBeforeDestroyed" cb n - registerCallback cb - --- | @style_ attrs@ is an attribute that will set the @style@ --- attribute of the associated DOM node to @attrs@. --- --- @style@ attributes not contained in @attrs@ will be deleted. --- --- > import qualified Data.Map as M --- > div_ [ style_ $ M.singleton "background" "red" ] [ ] --- --- --- -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/JSBits.hs b/frontend-src/Miso/JSBits.hs deleted file mode 100644 --- a/frontend-src/Miso/JSBits.hs +++ /dev/null @@ -1,1 +0,0 @@ -module Miso.JSBits where diff --git a/frontend-src/Miso/String.hs b/frontend-src/Miso/String.hs deleted file mode 100644 --- a/frontend-src/Miso/String.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.String --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso.String ( - ToMisoString (..) - , FromMisoString (..) - , fromMisoString - , MisoString - , module Data.JSString - , module Data.Monoid - , ms - ) where - -#ifndef JSADDLE -import Data.Aeson -#endif -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Char -import Data.JSString -import Data.JSString.Text -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Prelude hiding (foldr) -import Miso.FFI - --- | String type swappable based on compiler -type MisoString = JSString - -#ifndef JSADDLE - - --- | `ToJSON` for `MisoString` -instance ToJSON MisoString where - toJSON = String . textFromJSString - --- | `FromJSON` for `MisoString` -instance FromJSON MisoString where - parseJSON = - withText "Not a valid string" $ \x -> - pure (toMisoString x) -#endif - --- | Convenience class for creating `MisoString` from other string-like types -class ToMisoString str where - toMisoString :: str -> MisoString - -class FromMisoString t where - -- -- | Reads a `MisoString` into an 'a', throws an error when - fromMisoStringEither :: MisoString -> Either String t - --- | Reads a `MisoString` into an 'a', throws an error when decoding --- fails. Use `fromMisoStringEither` for as a safe alternative. -fromMisoString :: FromMisoString a => MisoString -> a -fromMisoString s = case fromMisoStringEither s of - Left err -> error err - Right x -> x - --- | Convenience function, shorthand for `toMisoString` -ms :: ToMisoString str => str -> MisoString -ms = toMisoString - -instance ToMisoString MisoString where - toMisoString = id -instance ToMisoString String where - toMisoString = pack -instance ToMisoString T.Text where - toMisoString = textToJSString -instance ToMisoString LT.Text where - toMisoString = lazyTextToJSString -instance ToMisoString B.ByteString where - toMisoString = toMisoString . T.decodeUtf8 -instance ToMisoString BL.ByteString where - toMisoString = toMisoString . LT.decodeUtf8 -instance ToMisoString Float where - toMisoString = realFloatToJSString -instance ToMisoString Double where - toMisoString = realFloatToJSString -instance ToMisoString Int where - toMisoString = integralToJSString -instance ToMisoString Word where - toMisoString = integralToJSString - -instance FromMisoString MisoString where - fromMisoStringEither = Right -instance FromMisoString String where - fromMisoStringEither = Right . unpack -instance FromMisoString T.Text where - fromMisoStringEither = Right . textFromJSString -instance FromMisoString LT.Text where - fromMisoStringEither = Right . lazyTextFromJSString -instance FromMisoString B.ByteString where - fromMisoStringEither = fmap T.encodeUtf8 . fromMisoStringEither -instance FromMisoString BL.ByteString where - fromMisoStringEither = fmap LT.encodeUtf8 . fromMisoStringEither -instance FromMisoString Float where - fromMisoStringEither = fmap realToFrac . jsStringToDoubleEither -instance FromMisoString Double where - fromMisoStringEither = jsStringToDoubleEither -instance FromMisoString Int where - fromMisoStringEither = parseInt -instance FromMisoString Word where - fromMisoStringEither = parseWord - -jsStringToDoubleEither :: JSString -> Either String Double -jsStringToDoubleEither s = let d = jsStringToDouble s - in if isNaN d then Left "jsStringToDoubleEither: parse failed" - else Right d - - -parseWord :: MisoString -> Either String Word -parseWord s = case uncons s of - Nothing -> Left "parseWord: parse error" - Just (c,s') -> foldl' k (pDigit c) s' - where - pDigit c | isDigit c = Right . fromIntegral . digitToInt $ c - | otherwise = Left "parseWord: parse error" - k ea c = (\a x -> 10*a + x) <$> ea <*> pDigit c - -parseInt :: MisoString -> Either String Int -parseInt s = case uncons s of - Just ('-',s') -> ((-1)*) . fromIntegral <$> parseWord s' - _ -> fromIntegral <$> parseWord s diff --git a/frontend-src/Miso/Subscription.hs b/frontend-src/Miso/Subscription.hs deleted file mode 100644 --- a/frontend-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.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 deleted file mode 100644 --- a/frontend-src/Miso/Subscription/History.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.Subscription.History --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- 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 deleted file mode 100644 --- a/frontend-src/Miso/Subscription/Keyboard.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.Subscription.Keyboard --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso.Subscription.Keyboard - ( -- * Types - Arrows (..) - -- * Subscriptions - , arrowsSub - , directionSub - , keyboardSub - , wasdSub - ) where - -import Control.Monad.IO.Class -import Data.IORef -import Data.Set -import qualified Data.Set as S -import GHCJS.Marshal -import JavaScript.Object -import JavaScript.Object.Internal - -import Miso.FFI -import Miso.Html.Internal ( Sub ) - --- | type for arrow keys currently pressed --- 37 left arrow ( x = -1 ) --- 38 up arrow ( y = 1 ) --- 39 right arrow ( x = 1 ) --- 40 down arrow ( y = -1 ) -data Arrows = Arrows { - arrowX :: !Int - , arrowY :: !Int - } deriving (Show, Eq) - --- | Helper function to convert keys currently pressed to `Arrow`, given a --- mapping for keys representing up, down, left and right respectively. -toArrows :: ([Int], [Int], [Int], [Int]) -> Set Int -> Arrows -toArrows (up, down, left, right) set' = - Arrows { - arrowX = - case (check left, check right) of - (True, False) -> -1 - (False, True) -> 1 - (_,_) -> 0 - , arrowY = - case (check down, check up) of - (True, False) -> -1 - (False, True) -> 1 - (_,_) -> 0 - } - where - check = any (`S.member` set') - --- | Maps `Arrows` onto a Keyboard subscription -arrowsSub :: (Arrows -> action) -> Sub action -arrowsSub = directionSub ([38], [40], [37], [39]) - --- | Maps `WASD` onto a Keyboard subscription for directions -wasdSub :: (Arrows -> action) -> Sub action -wasdSub = directionSub ([87], [83], [65], [68]) - --- | Maps a specified list of keys to directions (up, down, left, right) -directionSub :: ([Int], [Int], [Int], [Int]) - -> (Arrows -> action) - -> Sub action -directionSub dirs = keyboardSub . (. toArrows dirs) - --- | Returns subscription for Keyboard -keyboardSub :: (Set Int -> action) -> Sub action -keyboardSub f sink = do - keySetRef <- liftIO (newIORef mempty) - windowAddEventListener "keyup" $ keyUpCallback keySetRef - windowAddEventListener "keydown" $ keyDownCallback keySetRef - windowAddEventListener "blur" $ blurCallback keySetRef - where - keyDownCallback keySetRef = \keyDownEvent -> do - Just key <- fromJSVal =<< getProp "keyCode" (Object keyDownEvent) - newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \keys -> - let !new = S.insert key keys - in (new, new) - liftIO (sink (f newKeys)) - - keyUpCallback keySetRef = \keyUpEvent -> do - Just key <- fromJSVal =<< getProp "keyCode" (Object keyUpEvent) - newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \keys -> - let !new = S.delete key keys - in (new, new) - liftIO (sink (f newKeys)) - - -- Assume keys are released the moment focus is lost. Otherwise going - -- back and forth to the app can cause keys to get stuck. - blurCallback keySetRef = \_ -> do - newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \_ -> - let !new = S.empty - in (new, new) - liftIO (sink (f newKeys)) diff --git a/frontend-src/Miso/Subscription/Mouse.hs b/frontend-src/Miso/Subscription/Mouse.hs deleted file mode 100644 --- a/frontend-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 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 deleted file mode 100644 --- a/frontend-src/Miso/Subscription/SSE.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.Subscription.SSE --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- 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 deleted file mode 100644 --- a/frontend-src/Miso/Subscription/WebSocket.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.Subscription.WebSocket --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso.Subscription.WebSocket - ( -- * Types - WebSocket (..) - , URL (..) - , Protocols (..) - , SocketState (..) - , CloseCode (..) - , WasClean (..) - , Reason (..) - -- * Subscription - , websocketSub - , send - , close - , connect - , getSocketState - ) where - -import Control.Concurrent -import Control.Monad -import Control.Monad.IO.Class -import Data.Aeson -import Data.IORef -import Data.Maybe -import GHCJS.Marshal -import GHCJS.Foreign -import GHCJS.Types -import Prelude hiding (map) -import System.IO.Unsafe - -import Miso.FFI -import Miso.FFI.WebSocket (Socket) -import qualified Miso.FFI.WebSocket as WS -import Miso.Html.Internal ( Sub ) -import Miso.WebSocket - -websocket :: IORef (Maybe Socket) -{-# NOINLINE websocket #-} -websocket = unsafePerformIO (newIORef Nothing) - -closedCode :: IORef (Maybe CloseCode) -{-# NOINLINE closedCode #-} -closedCode = unsafePerformIO (newIORef Nothing) - -secs :: Int -> Int -secs = (*1000000) - --- | WebSocket subscription -websocketSub - :: FromJSON m - => URL - -> Protocols - -> (WebSocket m -> action) - -> Sub action -websocketSub (URL u) (Protocols ps) f sink = do - socket <- createWebSocket u ps - liftIO (writeIORef websocket (Just socket)) - void . forkJSM $ handleReconnect - WS.addEventListener socket "open" $ \_ -> liftIO $ do - writeIORef closedCode Nothing - sink (f WebSocketOpen) - WS.addEventListener socket "message" $ \v -> do - d <- parse =<< WS.data' v - liftIO . sink $ f (WebSocketMessage d) - WS.addEventListener socket "close" $ \e -> do - code <- codeToCloseCode <$> WS.code e - liftIO (writeIORef closedCode (Just code)) - reason <- WS.reason e - clean <- WS.wasClean e - liftIO . sink $ f (WebSocketClose code clean reason) - WS.addEventListener socket "error" $ \v -> do - liftIO (writeIORef closedCode Nothing) - d' <- WS.data' v -#ifndef __GHCJS__ - undef <- ghcjsPure (isUndefined d') -#else - let undef = isUndefined d' -#endif - if undef - then do - liftIO . sink $ f (WebSocketError mempty) - else do - Just d <- fromJSVal d' - liftIO . sink $ f (WebSocketError d) - where - handleReconnect = do - liftIO (threadDelay (secs 3)) - Just s <- liftIO (readIORef websocket) - status <- WS.socketState s - code <- liftIO (readIORef closedCode) - if status == 3 - then do - unless (code == Just CLOSE_NORMAL) $ - websocketSub (URL u) (Protocols ps) f sink - else handleReconnect - --- | Sends message to a websocket server -send :: ToJSON a => a -> JSM () -{-# INLINE send #-} -send x = do - Just socket <- liftIO (readIORef websocket) - sendJson' socket x - --- | Sends message to a websocket server -close :: JSM () -{-# INLINE close #-} -close = - mapM_ WS.close =<< - liftIO (readIORef websocket) - --- | Connects to a websocket server -connect :: URL -> Protocols -> JSM () -{-# INLINE connect #-} -connect (URL url') (Protocols ps) = do - Just ws <- liftIO (readIORef websocket) - s <- WS.socketState ws - when (s == 3) $ do - socket <- createWebSocket url' ps - liftIO (atomicWriteIORef websocket (Just socket)) - --- | Retrieves current status of `WebSocket` -getSocketState :: JSM SocketState -getSocketState = do - Just ws <- liftIO (readIORef websocket) - toEnum <$> WS.socketState ws - -sendJson' :: ToJSON json => Socket -> json -> JSM () -sendJson' socket m = WS.send socket =<< stringify m - -createWebSocket :: JSString -> [JSString] -> JSM Socket -{-# INLINE createWebSocket #-} -createWebSocket url' protocols = - WS.create url' =<< toJSVal protocols - -codeToCloseCode :: Int -> CloseCode -codeToCloseCode = go - where - go 1000 = CLOSE_NORMAL - go 1001 = CLOSE_GOING_AWAY - go 1002 = CLOSE_PROTOCOL_ERROR - go 1003 = CLOSE_UNSUPPORTED - go 1005 = CLOSE_NO_STATUS - go 1006 = CLOSE_ABNORMAL - go 1007 = Unsupported_Data - go 1008 = Policy_Violation - go 1009 = CLOSE_TOO_LARGE - go 1010 = Missing_Extension - go 1011 = Internal_Error - go 1012 = Service_Restart - go 1013 = Try_Again_Later - go 1015 = TLS_Handshake - go n = OtherCode n diff --git a/frontend-src/Miso/Subscription/Window.hs b/frontend-src/Miso/Subscription/Window.hs deleted file mode 100644 --- a/frontend-src/Miso/Subscription/Window.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.Subscription.Window --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- 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 deleted file mode 100644 --- a/frontend-src/Miso/Types.hs +++ /dev/null @@ -1,149 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Miso.Types --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso.Types - ( App (..) - , LogLevel (..) - , Effect - , Sub - - -- * The Transition Monad - , Transition - , mapAction - , fromTransition - , toTransition - , scheduleIO - , scheduleIO_ - , scheduleIOFor_ - , scheduleSub - ) where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Strict (StateT(StateT), execStateT, mapStateT) -import Control.Monad.Trans.Writer.Strict (WriterT(WriterT), Writer, runWriter, tell, mapWriter) -import Data.Bifunctor (second) -import Data.Foldable (Foldable, for_) -import qualified Data.Map as M -import Miso.Effect -import Miso.FFI (JSM) -import Miso.Html.Internal -import Miso.String - --- | Application entry point -data App model action = App - { model :: model - -- ^ initial model - , update :: action -> model -> Effect action model - -- ^ Function to update model, optionally providing effects. - -- See the 'Transition' monad for succinctly expressing model transitions. - , view :: model -> View action - -- ^ Function to draw `View` - , subs :: [ Sub action ] - -- ^ List of subscriptions to run during application lifetime - , events :: M.Map MisoString Bool - -- ^ List of delegated events that the body element will listen for. - -- You can start with 'Miso.Event.Types.defaultEvents' and modify as needed. - , initialAction :: action - -- ^ Initial action that is run after the application has loaded - , mountPoint :: Maybe MisoString - -- ^ Id of the root element for DOM diff. If 'Nothing' is provided, the entire document body is used as a mount point. - , logLevel :: LogLevel - -- ^ Display warning messages when prerendering if the DOM and VDOM are not in sync. - } - --- | Optional Logging for debugging miso internals (useful to see if prerendering is successful) -data LogLevel - = Off - | DebugPrerender - deriving (Show, Eq) - --- | A monad for succinctly expressing model transitions in the 'update' function. --- --- @Transition@ is a state monad so it abstracts over manually passing the model --- around. It's also a writer monad where the accumulator is a list of scheduled --- IO actions. Multiple actions can be scheduled using --- @Control.Monad.Writer.Class.tell@ from the @mtl@ library and a single action --- can be scheduled using 'scheduleIO'. --- --- Tip: use the @Transition@ monad in combination with the stateful --- --- 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 deleted file mode 100644 --- a/ghc-src/Miso.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} ------------------------------------------------------------------------------ --- | --- Module : Miso --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso - ( module Miso.Event - , module Miso.Html - , module Miso.Router - , module Miso.TypeLevel - , module Miso.Util - , module Miso.WebSocket - ) where - -import Miso.Event -import Miso.Html -import Miso.Router -import Miso.TypeLevel -import Miso.Util -import Miso.WebSocket diff --git a/ghc-src/Miso/Html/Internal.hs b/ghc-src/Miso/Html/Internal.hs deleted file mode 100644 --- a/ghc-src/Miso/Html/Internal.hs +++ /dev/null @@ -1,303 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.Html.Internal --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso.Html.Internal ( - -- * Core types and interface - VTree (..) - , View (..) - , ToView (..) - , Attribute (..) - -- * Smart `View` constructors - , node - , text - , textRaw - -- * Key patch internals - , Key (..) - , ToKey (..) - -- * Namespace - , NS (..) - -- * Setting properties on virtual DOM nodes - , prop - -- * Setting CSS - , style_ - -- * Handling events - , on - , onWithOptions - -- * Life cycle events - , onCreated - , onDestroyed - , onBeforeDestroyed - ) where - -import Data.Aeson (Value(..), ToJSON(..)) -import qualified Data.Map as M -import Data.Proxy -import Data.String (IsString(..)) -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Lucid as L -import qualified Lucid.Base as L -import Prelude hiding (null) -import Servant.API - -import Miso.Event -import Miso.String hiding (map) - --- | Virtual DOM implemented as a Rose `Vector`. --- Used for diffing, patching and event delegation. --- Not meant to be constructed directly, see `View` instead. -data VTree action where - VNode :: { vType :: Text -- ^ Element type (i.e. "div", "a", "p") - , vNs :: NS -- ^ HTML or SVG - , vProps :: Props -- ^ Fields present on DOM Node - , vKey :: Maybe Key -- ^ Key used for child swap patch - , vChildren :: V.Vector (VTree action) -- ^ Child nodes - } -> VTree action - VText :: { vText :: Text -- ^ TextNode content - } -> VTree action - -- Invariant: To avoid complexity with collapsing mixed VText and - -- VTextRaw nodes, VTextRaw node is always the only child. - -- That's not a big limitation, since the intended purpose is to be able - -- to use