+
+
+
+
+
+
A tasty Haskell front-end framework
+ + + **Miso** is a small "[isomorphic](http://nerds.airbnb.com/isomorphic-javascript-future-web-apps/)" [Haskell](https://www.haskell.org/) front-end framework featuring a virtual-dom, diffing / patching algorithm, event delegation, event batching, SVG, Server-sent events, Websockets, and an extensible Subscription-based subsystem. Inspired by [Elm](http://elm-lang.org/), [Redux](http://redux.js.org/) and [Bobril](http://github.com/bobris/bobril). `IO` and other effects (like `XHR`) can be introduced into the system via the `Effect` data type. Miso makes heavy use of the [GHCJS](https://github.com/ghcjs/ghcjs) FFI and therefore has minimal dependencies. ## Examples @@ -29,6 +52,7 @@ ## Getting Started ```haskell {-# LANGUAGE RecordWildCards #-} + module Main where import Miso diff --git a/examples/mario/Main.hs b/examples/mario/Main.hs --- a/examples/mario/Main.hs +++ b/examples/mario/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BangPatterns #-} module Main where import Data.Function @@ -11,9 +12,9 @@ import Miso.String data Action - = GetArrows Arrows - | Time Double - | WindowCoords (Int,Int) + = GetArrows !Arrows + | Time !Double + | WindowCoords !(Int,Int) foreign import javascript unsafe "$r = performance.now();" now :: IO Double @@ -32,15 +33,15 @@ ] data Model = Model - { x :: Double - , y :: Double - , vx :: Double - , vy :: Double - , dir :: Direction - , time :: Double - , delta :: Double - , arrows :: Arrows - , window :: (Int,Int) + { x :: !Double + , y :: !Double + , vx :: !Double + , vy :: !Double + , dir :: !Direction + , time :: !Double + , delta :: !Double + , arrows :: !Arrows + , window :: !(Int,Int) } deriving (Show, Eq) data Direction diff --git a/ghcjs-src/Miso/Subscription/Keyboard.hs b/ghcjs-src/Miso/Subscription/Keyboard.hs --- a/ghcjs-src/Miso/Subscription/Keyboard.hs +++ b/ghcjs-src/Miso/Subscription/Keyboard.hs @@ -36,8 +36,8 @@ -- 39 right arrow ( x = 1 ) -- 40 down arrow ( y = -1 ) data Arrows = Arrows { - arrowX :: Int - , arrowY :: Int + arrowX :: !Int + , arrowY :: !Int } deriving (Show, Eq) -- | Helper function to convert keys currently pressed to `Arrow` diff --git a/miso.cabal b/miso.cabal --- a/miso.cabal +++ b/miso.cabal @@ -1,5 +1,5 @@ name: miso -version: 0.1.2.0 +version: 0.1.3.0 category: Web, Miso, Data Structures license: BSD3 license-file: LICENSE @@ -128,6 +128,7 @@ aeson, base < 5, bytestring, + BoundedChan, containers, text if impl(ghcjs) diff --git a/src/Miso/Concurrent.hs b/src/Miso/Concurrent.hs --- a/src/Miso/Concurrent.hs +++ b/src/Miso/Concurrent.hs @@ -15,8 +15,8 @@ , newEventWriter ) where -import Control.Concurrent.MVar -import Control.Concurrent +import Control.Concurrent hiding (readChan) +import Control.Concurrent.BoundedChan import Control.Monad -- | Concurrent API for receiving events and writing to an event sink @@ -28,12 +28,12 @@ -- | Creates a new `EventWriter` newEventWriter :: IO () -> IO (EventWriter m) newEventWriter notify' = do - chan <- newChan + chan <- newBoundedChan 50 pure $ EventWriter (write chan) (readChan chan) where write chan event = void . forkIO $ do - writeChan chan event + void $ tryWriteChan chan $! event notify' -- | Concurrent API for `SkipChan` implementation @@ -45,30 +45,8 @@ -- | Create a new `Notify` newNotify :: IO Notify newNotify = do - skipChan <- newSkipChan + mvar <- newMVar () pure $ Notify - (getSkipChan skipChan) - (putSkipChan skipChan ()) - -data SkipChan a = - SkipChan (MVar (a, [MVar ()])) (MVar ()) - -newSkipChan :: IO (SkipChan a) -newSkipChan = do - sem <- newEmptyMVar - main <- newMVar (undefined, [sem]) - return (SkipChan main sem) - -putSkipChan :: SkipChan a -> a -> IO () -putSkipChan (SkipChan main _) v = do - (_, sems) <- takeMVar main - putMVar main (v, []) - mapM_ (\sem -> putMVar sem ()) sems - -getSkipChan :: SkipChan a -> IO a -getSkipChan (SkipChan main sem) = do - takeMVar sem - (v, sems) <- takeMVar main - putMVar main (v, sem:sems) - return v + (takeMVar mvar) + (() <$ do tryPutMVar mvar $! ())
+ 
+ 
+ 
+ 
+ 
+ 
+