diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -33,37 +33,289 @@

-**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, type-safe [servant](https://haskell-servant.github.io/)-style routing 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). **Miso** is pure by default, but side 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. +**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, attribute and property normalization, event delegation, event batching, SVG, Server-sent events, Websockets, type-safe [servant](https://haskell-servant.github.io/)-style routing 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). **Miso** is pure by default, but side 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. ## Table of Contents +- [Quick Start](#quick-start) + - [Stack](#stack) + - [Nix](#nix) + - [Cabal](#cabal) + - [GHCJSi Caveats](#ghcjsi-caveats) + - [Architecture](#architecture) - [Examples](#examples) + - [TodoMVC](#todomvc) + - [Mario](#mario) + - [Websocket](#websocket) + - [SSE](#sse) + - [XHR](#xhr) + - [Router](#router) + - [SVG](#svg) + - [Simple](#simple) - [Haddocks](#haddocks) + - [GHC](#ghc) + - [GHCJS](#ghcjs) - [Sample Application](#sample-application) - [Building examples](#building-examples) +- [Maintainers](#maintainers) +- [Contributing](#contributing) +- [License](#license) +## Quick start +To get started quickly building applications, we recommend using the [`stack`](https://docs.haskellstack.org/en/stable/README/) or [`nix`](https://nixos.org/nix) package managers. Obtaining [`GHCJS`](https://github.com/ghcjs/ghcjs) is required as a prerequisite. `stack` and `nix` make this process easy, if you're using `cabal` we assume you have [obtained `GHCJS`](https://github.com/ghcjs/ghcjs#installation) by other means. + +All source code depicted below for the quick start app is available [here](https://github.com/dmjio/miso/tree/master/sample-app). + +### Stack +In the `miso` repository there is a [folder named `stack`](https://github.com/dmjio/miso/tree/master/stack) with "known to work" configurations for `GHCJS`. One stack file exists for both the `7.10.3` and `8.0.1` versions of `GHCJS`. In general, we recommend developing with the `7.10.3` version since it currently supports `GHCJSi` (a REPL that connects to the browser by way of a [`nodejs`](https://nodejs.org/en/) web server using [`socket.io`](https://socket.io/)) and building with the `8.0.1` version (if possible). For more information on using `stack` with `GHCJS`, please consult the [GHCJS section of the `stack` docs](https://docs.haskellstack.org/en/stable/ghcjs/). + +To begin, create the following directory layout +```bash +➜ mkdir app && touch app/{Main.hs,app.cabal,stack.yaml} && tree app +app +|-- Main.hs +|-- app.cabal +`-- stack.yaml +``` + +Add a `stack.yaml` file that uses a recent version of `miso`. +```bash +➜ cat app/stack.yaml +resolver: lts-6.20 +compiler: ghcjs-0.2.0.9006020_ghc-7.10.3 +compiler-check: match-exact + +packages: + - '.' +extra-deps: + - miso-0.4.0.0 + +setup-info: + ghcjs: + source: + ghcjs-0.2.0.9006020_ghc-7.10.3: + url: http://ghcjs.tolysz.org/lts-6.20-9006020.tar.gz + sha1: a6cea90cd8121eee3afb201183c6e9bd6bacd94a +``` + +Add a `cabal` file +```bash +➜ cat app/*.cabal +name: app +version: 0.1.0.0 +synopsis: First miso app +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable app + main-is: Main.hs + build-depends: base, miso + default-language: Haskell2010 +``` + +Add the source from [Sample Application](#sample-application) to `app/Main.hs` + +Run `stack setup`. This might take a long time, since it will have to build `GHCJS`. +``` +stack setup +``` + +Run `stack build` to get the static assets +``` +stack build +``` + +See the result +``` +open $(stack path --local-install-root)/bin/app.jsexe/index.html +``` + +Using GHCJSi +``` +stack ghci +``` + +If that warns with `socket.io not found, browser session not available`, you'll need to install `socket.io` +``` +npm install socket.io +``` + +and update your `NODE_PATH` +``` +export NODE_PATH=$(pwd)/node_modules +``` + +Now you should be connected, and the app viewable in `GHCJSi` (open http://localhost:6400). +```bash +➜ stack ghci +app-0.1.0.0: initial-build-steps (exe) +Configuring GHCi with the following packages: app +GHCJSi, version 0.2.0.9006020-7.10.3: http://www.github.com/ghcjs/ghcjs/ :? for help +[1 of 1] Compiling Main ( /Users/david/Desktop/miso/sample-app/Main.hs, interpreted ) +socket.io found, browser session available at http://localhost:6400 +Ok, modules loaded: Main. +*Main> main +browser connected, code runs in browser from now on +``` + +### Nix +`Nix` is a more powerful option for building web applications with `miso` since it encompasses development workflow, configuration management, and deployment. The source code for [`haskell-miso.org`](https://github.com/dmjio/miso/tree/master/examples/haskell-miso.org) is an example of this. + +If unfamiliar with `nix`, we recommend [@Gabriel439](https://github.com/Gabriel439)'s ["Nix and Haskell in production"](https://github.com/Gabriel439/haskell-nix) guide. + +To get started, we will use the [`cabal2nix`](https://github.com/NixOS/cabal2nix) tool to convert our `Cabal` file into a `nix` derivation (named `app.nix`). We'll then write a file named `default.nix`, which is used for building our project (via `nix-build`) and development (via `nix-shell`). + +To begin, make the following directory layout: +```bash +➜ mkdir app && touch app/{Main.hs,app.cabal,default.nix,app.nix} && tree app +app +|-- Main.hs +|-- app.cabal +|-- default.nix +`-- app.nix +``` + +Add a `cabal` file +```bash +➜ cat app/*.cabal +name: app +version: 0.1.0.0 +synopsis: First miso app +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable app + main-is: Main.hs + build-depends: base, miso + default-language: Haskell2010 +``` + +Use [`cabal2nix`](https://github.com/NixOS/cabal2nix) to generate a file named `app.nix` +that looks like below. +```bash +➜ cabal2nix . --compiler ghcjs > app.nix +➜ cat app.nix +``` + +```nix +{ mkDerivation, base, miso, stdenv }: +mkDerivation { + pname = "app"; + version = "0.1.0.0"; + src = ./.; + isLibrary = false; + isExecutable = true; + executableHaskellDepends = [ base miso ]; + description = "First miso app"; + license = stdenv.lib.licenses.unfree; +} +``` + +Write a `default.nix` (which calls `app.nix`), this fetches a recent version of `miso`. +```nix +{ pkgs ? import {} }: +let + result = import (pkgs.fetchFromGitHub { + owner = "dmjio"; + repo = "miso"; + sha256 = "13ckz11gbfs047hl3phj7h6fm59wsg9zw2fiqjaqkxmxv17zj5yj"; + rev = "0834d5c0b309de24d836cbdcc25fd257de10be17"; + }) {}; +in pkgs.haskell.packages.ghcjs.callPackage ./app.nix { + miso = result.miso-ghcjs; +} +``` + +Build the project +``` +nix-build +``` + +Open the result +``` +open ./result/bin/app.jsexe/index.html +``` + +For development with `nix`, it's important to have `cabal` present for building. This command will make it available in your `PATH`. +``` +nix-env -iA cabal-install -f '' +``` + +To be put into a shell w/ `GHCJS` and all the dependencies for this project present, use `nix-shell`. +``` +nix-shell -A env +``` + +To open `GHCJSi` (`NODE_PATH` should already be set properly) +``` +$ cabal configure --ghcjs +$ cabal repl +Package has never been configured. Configuring with default flags. If this +fails, please run configure manually. +Resolving dependencies... +Configuring app-0.1.0.0... +Preprocessing executable 'app' for app-0.1.0.0... +GHCJSi, version 0.2.0-7.10.3: http://www.github.com/ghcjs/ghcjs/ :? for help +[1 of 1] Compiling Main ( Main.hs, interpreted ) +Ok, modules loaded: Main. +*Main> +browser connected, code runs in browser from now on +``` + +### Cabal +The latest stable version of `miso` will be available on Hackage. +To build with cabal, we assume `ghcjs` is in your `PATH` and `ghcjs-base` is present in your `ghcjs-pkg` list. +```bash +cabal sandbox init +cabal install --ghcjs +cabal build +open dist/build/app/app.jsexe/index.html +``` + +### GHCJSi Caveats +If you run `main` in `GHCJSi`, interrupt it and then run it again, you +will end up with two copies of your app displayed above each other. As +a workaround, you can use `clearBody >> main` which will completely +clear the document body before rendering your application. + +### Architecture +For constructing client and server applications, we recommend using one `cabal` file with two executable sections, where the `buildable` attribute set is contingent on the compiler. An example of this layout is [here](https://github.com/dmjio/miso/blob/master/examples/haskell-miso.org/haskell-miso.cabal#L16-L60). For more info on how to use `stack` with a `client`/`server` setup, see this [link](https://docs.haskellstack.org/en/stable/ghcjs/#project-with-both-client-and-server). For more information on how to use `nix` with a `client`/`server` setup, see the [nix scripts](https://github.com/dmjio/miso/blob/master/examples/haskell-miso.org/default.nix) for [https://haskell-miso.org](https://haskell-miso.org). + ## Examples - - TodoMVC - - [Link](https://todo-mvc.haskell-miso.org/) - - [Source](https://github.com/dmjio/miso/blob/master/examples/todo-mvc/Main.hs) - - Mario - - [Link](https://mario.haskell-miso.org/) - - [Source](https://github.com/dmjio/miso/blob/master/examples/mario/Main.hs) - - Websocket - - [Link](https://websocket.haskell-miso.org/) - - [Source](https://github.com/dmjio/miso/blob/master/examples/websocket/Main.hs) - - Router - - [Link](https://router.haskell-miso.org/) - - [Source](https://github.com/dmjio/miso/blob/master/examples/router/Main.hs) - - SVG - - [Link](https://svg.haskell-miso.org/) - - Simple - - [Link](https://simple.haskell-miso.org/) - - [Source](https://github.com/dmjio/miso/blob/master/exe/Main.hs) +### TodoMVC + - [Link](https://todo-mvc.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/todo-mvc/Main.hs) + +### Mario + - [Link](https://mario.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/mario/Main.hs) + +### Websocket + - [Link](https://websocket.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/websocket/Main.hs) + +### SSE + - [Link](https://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](https://xhr.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/xhr/Main.hs) + +### Router + - [Link](https://router.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/router/Main.hs) + +### SVG + - [Link](https://svg.haskell-miso.org/) + +### Simple + - [Link](https://simple.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/exe/Main.hs) + ## Haddocks - - [GHCJS](https://haddocks.haskell-miso.org/) - - [GHC](http://hackage.haskell.org/package/miso) +### GHCJS + - [Link](https://haddocks.haskell-miso.org/) + +### GHC + - [Link](http://hackage.haskell.org/package/miso) + ## Sample application ```haskell -- | Haskell language pragma @@ -91,14 +343,14 @@ main = startApp App {..} where initialAction = SayHelloWorld -- initial action to be executed on application load - model = 0 -- initial model + model = 0 -- initial model update = updateModel -- update function view = viewModel -- view function events = defaultEvents -- default delegated events subs = [] -- empty subscription list -- | Updates model, optionally introduces side effects -updateModel :: Action -> Model -> Effect Model Action +updateModel :: Action -> Model -> Effect Action Model updateModel AddOne m = noEff (m + 1) updateModel SubtractOne m = noEff (m - 1) updateModel NoOp m = noEff m @@ -153,3 +405,17 @@ cd result/examples/todo-mvc.jsexe && python -m SimpleHTTPServer Serving HTTP on 0.0.0.0 port 8000 ... ``` + +## Maintainers + +[@dmjio](https://github.com/dmjio) + +## Contributing + +Feel free to dive in! [Open an issue](https://github.com/dmjio/miso/issues/new) or submit [PRs](https://github.com/dmjio/miso/pulls). + +See [CONTRIBUTING](https://github.com/dmjio/miso/blob/master/CONTRIBUTING.md) for more info. + +## License + +[BSD3](LICENSE) © David Johnson diff --git a/examples/compose-update/Main.hs b/examples/compose-update/Main.hs new file mode 100644 --- /dev/null +++ b/examples/compose-update/Main.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +module Main where + +-- This example demonstrates how you can split your update function +-- into separate update functions for parts of your model and then +-- combine them into a single update function operating on the whole +-- model which combines their effects. + +import Control.Monad +import Data.Monoid + +import Miso +import Miso.Lens + +-- In this slightly contrived example, our model consists of two +-- counters. When one of those counters is incremented, the other is +-- decremented and the other way around. +type Model = (Int, Int) + +data Action + = Increment + | Decrement + | NoOp + deriving (Show, Eq) + +-- We are going to use 'Lens'es in this example. Since @miso@ does not +-- depend on a lens library we are going to define a couple of +-- utilities ourselves. We recommend that in your own applications, +-- you depend on a lens library such as @lens@ or @microlens@ to get +-- these definitions. + +-- | You can find this under the same name in @lens@ and +-- @microlens@. @lens@ also provides the infix operator '%%~' as a +-- synonym for 'traverseOf'. +-- +-- In this example we are only going to use this when applied to +-- 'Lens' m a' and using 'Effect Action' for the @f@ type variable. In +-- that case the specialized type signature is: +-- +-- @traverseOf :: Functor f => Lens' m a -> (a -> Effect Action a) -> s -> Effect action s +traverseOf :: Functor f => Lens s t a b -> (a -> f b) -> s -> f t +traverseOf = id + +-- | A lens into the first element of a tuple. Both @lens@ and +-- @microlens@ provide this under the same name. +_1 :: Lens (a,c) (b,c) a b +_1 f (a,c) = (,c) <$> f a + +-- | A lens into the second element of a tuple. Both @lens@ and +-- @microlens@ provide this under the same name. +_2 :: Lens (c,a) (c,b) a b +_2 f (c,a) = (c,) <$> f a + +-- | Update function for the first counter in our 'Model'. +updateFirstCounter :: Action -> Int -> Effect Action Int +updateFirstCounter Increment m = noEff (m + 1) +updateFirstCounter Decrement m = noEff (m - 1) +updateFirstCounter NoOp m = noEff m + +-- | Update function for the second counter in our 'Model'. As we’ve +-- mentioned before, this counter is decremented when the first +-- counter is incremented and the other way around. +updateSecondCounter :: Action -> Int -> Effect Action Int +updateSecondCounter Increment m = noEff (m - 1) +updateSecondCounter Decrement m = noEff (m + 1) +updateSecondCounter NoOp m = noEff m + +-- | This is the combined update function for both counters. +updateModel :: Action -> Model -> Effect Action Model +updateModel act = + let -- We use 'traverseOf' to lift an update function for one + -- counter to an update function that operates on both + -- counters. The lifted function leaves the other counter + -- untouched. + liftedUpdateFirst :: Model -> Effect Action Model + liftedUpdateFirst = traverseOf _1 (updateFirstCounter act) + liftedUpdateSecond :: Model -> Effect Action Model + liftedUpdateSecond = traverseOf _2 (updateSecondCounter act) + in -- Since 'Effect Action' is an instance of 'Monad', we can just + -- use '<=<' to compose these lifted update functions. It might + -- be helpful to look at the type signature of '<=<' specialized + -- for 'Effect Action': + -- + -- @(<=<) :: (b -> Effect Action c) -> (a -> Effect Action b) -> a -> Effect Action c + liftedUpdateFirst <=< liftedUpdateSecond + +main :: IO () +main = startApp App { initialAction = NoOp, ..} + where + model = (0, 0) + update = updateModel + view = viewModel + events = defaultEvents + subs = [] + +viewModel :: Model -> View Action +viewModel (x, y) = + div_ + [] + [ button_ [onClick Increment] [text "+"] + , text (show x <> " | " <> show y) + , button_ [onClick Decrement] [text "-"] + ] diff --git a/examples/mario/Main.hs b/examples/mario/Main.hs --- a/examples/mario/Main.hs +++ b/examples/mario/Main.hs @@ -63,7 +63,7 @@ , window = (0,0) } -updateMario :: Action -> Model -> Effect Model Action +updateMario :: Action -> Model -> Effect Action Model updateMario NoOp m = noEff m updateMario (GetArrows arrs) m = step newModel where @@ -77,7 +77,7 @@ where newModel = m { window = coords } -step :: Model -> Effect Model Action +step :: Model -> Effect Action Model step m@Model{..} = k <# do Time <$> now where k = m & gravity delta diff --git a/examples/router/Main.hs b/examples/router/Main.hs --- a/examples/router/Main.hs +++ b/examples/router/Main.hs @@ -43,7 +43,7 @@ view = viewModel -- | Update your model -updateModel :: Action -> Model -> Effect Model Action +updateModel :: Action -> Model -> Effect Action Model updateModel (HandleURI u) m = m { uri = u } <# do pure NoOp updateModel (ChangeURI u) m = m <# do 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 @@ -86,7 +86,7 @@ events = defaultEvents subs = [] -updateModel :: Msg -> Model -> Effect Model Msg +updateModel :: Msg -> Model -> Effect Msg Model updateModel NoOp m = noEff m updateModel (CurrentTime n) m = m <# do print n >> pure NoOp diff --git a/examples/websocket/Main.hs b/examples/websocket/Main.hs --- a/examples/websocket/Main.hs +++ b/examples/websocket/Main.hs @@ -31,7 +31,7 @@ uri = URL "wss://echo.websocket.org" protocols = Protocols [ ] -updateModel :: Action -> Model -> Effect Model Action +updateModel :: Action -> Model -> Effect Action Model updateModel (HandleWebSocket (WebSocketMessage (Message m))) model = noEff model { received = m } updateModel (SendMessage msg) model = model <# do send msg >> pure Id diff --git a/examples/xhr/Main.hs b/examples/xhr/Main.hs new file mode 100644 --- /dev/null +++ b/examples/xhr/Main.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Main where + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Map as M +import Data.Maybe +import GHC.Generics +import JavaScript.Web.XMLHttpRequest + +import Miso hiding (defaultOptions) +import Miso.String + +-- | Model +data Model + = Model + { info :: Maybe APIInfo + } deriving (Eq, Show) + +-- | Action +data Action + = FetchGitHub + | SetGitHub APIInfo + | NoOp + deriving (Show, Eq) + +-- | Main entry point +main :: IO () +main = do + startApp App { model = Model Nothing + , initialAction = NoOp + , .. + } + where + update = updateModel + events = defaultEvents + subs = [] + view = viewModel + +-- | Update your model +updateModel :: Action -> Model -> Effect Action Model +updateModel FetchGitHub m = m <# do + SetGitHub <$> getGitHubAPIInfo +updateModel (SetGitHub apiInfo) m = + noEff m { info = Just apiInfo } +updateModel NoOp m = noEff m + +-- | View function, with routing +viewModel :: Model -> View Action +viewModel Model {..} = view + where + view = div_ [ style_ $ M.fromList [ + (pack "text-align", pack "center") + , (pack "margin", pack "200px") + ] + ] [ + h1_ [class_ $ pack "title" ] [ text $ pack "Miso XHR Example" ] + , button_ attrs [ + text $ pack "Fetch JSON from https://api.github.com via XHR" + ] + , case info of + Nothing -> div_ [] [ text $ pack "No data" ] + Just APIInfo{..} -> + table_ [ class_ $ pack "table is-striped" ] [ + thead_ [] [ + tr_ [] [ + th_ [] [ text $ pack "URLs"] + ] + ] + , tbody_ [] [ + tr_ [] [ td_ [] [ text current_user_url ] ] + , tr_ [] [ td_ [] [ text emojis_url ] ] + , tr_ [] [ td_ [] [ text emails_url ] ] + , tr_ [] [ td_ [] [ text events_url ] ] + , tr_ [] [ td_ [] [ text gists_url ] ] + , tr_ [] [ td_ [] [ text feeds_url ] ] + , tr_ [] [ td_ [] [ text followers_url ] ] + , tr_ [] [ td_ [] [ text following_url ] ] + ] + ] + ] + where + attrs = [ onClick FetchGitHub + , class_ $ pack "button is-large is-outlined" + ] ++ + [ disabled_ $ pack "disabled" + | isJust info + ] + +data APIInfo + = APIInfo + { current_user_url :: MisoString + , current_user_authorizations_html_url :: MisoString + , authorizations_url :: MisoString + , code_search_url :: MisoString + , commit_search_url :: MisoString + , emails_url :: MisoString + , emojis_url :: MisoString + , events_url :: MisoString + , feeds_url :: MisoString + , followers_url :: MisoString + , following_url :: MisoString + , gists_url :: MisoString + , hub_url :: MisoString + , issue_search_url :: MisoString + , issues_url :: MisoString + , keys_url :: MisoString + , notifications_url :: MisoString + , organization_repositories_url :: MisoString + , organization_url :: MisoString + , public_gists_url :: MisoString + , rate_limit_url :: MisoString + , repository_url :: MisoString + , repository_search_url :: MisoString + , current_user_repositories_url :: MisoString + , starred_url :: MisoString + , starred_gists_url :: MisoString + , team_url :: MisoString + , user_url :: MisoString + , user_organizations_url :: MisoString + , user_repositories_url :: MisoString + , user_search_url :: MisoString + } deriving (Show, Eq, Generic) + +instance FromJSON APIInfo where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo '_' } + +getGitHubAPIInfo :: IO APIInfo +getGitHubAPIInfo = do + Just resp <- contents <$> xhrByteString req + case eitherDecodeStrict resp :: Either String APIInfo of + Left s -> error s + Right j -> pure j + where + req = Request { reqMethod = GET + , reqURI = pack "https://api.github.com" + , reqLogin = Nothing + , reqHeaders = [] + , reqWithCredentials = False + , reqData = NoData + } + diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -14,7 +14,7 @@ events = defaultEvents subs = [] -updateModel :: Action -> Model -> Effect Model Action +updateModel :: Action -> Model -> Effect Action Model updateModel AddOne m = noEff (m + 1) updateModel SubtractOne m = noEff (m - 1) updateModel NoOp m = noEff m diff --git a/ghc-src/Miso/TypeLevel.hs b/ghc-src/Miso/TypeLevel.hs --- a/ghc-src/Miso/TypeLevel.hs +++ b/ghc-src/Miso/TypeLevel.hs @@ -15,5 +15,5 @@ ToServerRoutes b wrapper action ToServerRoutes (a :> b) wrapper action = a :> ToServerRoutes b wrapper action - ToServerRoutes (View _) wrapper action = + ToServerRoutes (View a) wrapper action = Get '[HTML] (wrapper (View action)) diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs --- a/ghcjs-src/Miso.hs +++ b/ghcjs-src/Miso.hs @@ -123,11 +123,10 @@ -- | Helper foldEffects :: (action -> IO ()) - -> (action -> model -> Effect model action) + -> (action -> model -> Effect action model) -> (model, IO ()) -> action -> (model, IO ()) foldEffects sink update = \(model, as) action -> case update action model of - NoEffect newModel -> (newModel, as) - Effect newModel eff -> (newModel, newAs) + Effect newModel effs -> (newModel, newAs) where - newAs = as >> do void . forkIO . sink =<< eff + newAs = as >> (mapM_ (forkIO . sink =<<) effs) diff --git a/ghcjs-src/Miso/Dev.hs b/ghcjs-src/Miso/Dev.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Dev.hs @@ -0,0 +1,14 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Dev +-- Copyright : (C) 2016-2017 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/Effect.hs b/ghcjs-src/Miso/Effect.hs --- a/ghcjs-src/Miso/Effect.hs +++ b/ghcjs-src/Miso/Effect.hs @@ -21,19 +21,35 @@ import Miso.Effect.XHR import Miso.Effect.DOM --- | Capturing effects in update actions -data Effect model action - = NoEffect model - | Effect model (IO action) +-- | An effect represents the results of an update action. +-- +-- It consists of the updated model and a list of actions. Each action +-- is run in a new thread so there is no risk of accidentally +-- blocking the application. +data Effect action model + = Effect model [IO action] --- | `NoEffect` smart constructor -noEff :: model -> Effect model action -noEff = NoEffect +instance Functor (Effect action) where + fmap f (Effect m acts) = Effect (f m) acts --- | `Effect` smart constructor -(<#) :: model -> IO action -> Effect model action -(<#) = Effect +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') + +-- | 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 = Effect m [a] + -- | `Effect` smart constructor, flipped -(#>) :: IO action -> model -> Effect model action +(#>) :: IO action -> model -> Effect action model (#>) = flip (<#) diff --git a/ghcjs-src/Miso/FFI.hs b/ghcjs-src/Miso/FFI.hs --- a/ghcjs-src/Miso/FFI.hs +++ b/ghcjs-src/Miso/FFI.hs @@ -23,6 +23,7 @@ , item , jsvalToValue , delegateEvent + , clearBody ) where import Control.Monad @@ -127,3 +128,7 @@ -> Callback (IO JSVal) -- ^ Virtual DOM callback -> IO () +-- | 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 () diff --git a/ghcjs-src/Miso/Router.hs b/ghcjs-src/Miso/Router.hs --- a/ghcjs-src/Miso/Router.hs +++ b/ghcjs-src/Miso/Router.hs @@ -43,6 +43,7 @@ import Web.HttpApiData import Miso.Html hiding (text) +import Miso.Lens -- | Router terminator. -- The 'HasRouter' instance for 'View' finalizes the router. @@ -203,29 +204,6 @@ } class HasURI m where lensURI :: Lens' m URI - -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t -type Lens' s a = Lens s s a a -type Getting r s a = (a -> Const r a) -> (s -> Const r s) - -newtype Const r a = Const { runConst :: r } - deriving Functor - -newtype Id a = Id { runId :: a } - deriving (Functor) - -instance Applicative Id where - pure = Id - Id f <*> Id x = Id (f x) - -get :: Getting a s a -> s -> a -get l = \ s -> runConst (l Const s) - -set :: Lens s t a b -> b -> s -> t -set l b = \ s -> runId (l (\ _ -> A.pure b) s) - -makeLens :: (s -> a) -> (s -> b -> t) -> Lens s t a b -makeLens get' upd = \ f s -> upd s `fmap` f (get' s) getURI :: HasURI m => m -> URI getURI = get lensURI diff --git a/ghcjs-src/Miso/Types.hs b/ghcjs-src/Miso/Types.hs --- a/ghcjs-src/Miso/Types.hs +++ b/ghcjs-src/Miso/Types.hs @@ -20,7 +20,7 @@ data App model action = App { model :: model -- ^ initial model - , update :: action -> model -> Effect model action + , update :: action -> model -> Effect action model -- ^ Function to update model, optionally provide effects , view :: model -> View action -- ^ Function to draw `View` diff --git a/jsbits/diff.js b/jsbits/diff.js --- a/jsbits/diff.js +++ b/jsbits/diff.js @@ -15,7 +15,7 @@ } function diffTextNodes (c, n) { - if (c.text !== n.text) c.domRef.replaceData (0, c.domRef.length, n.text); + if (c.text !== n.text) c.domRef.textContent = n.text; n.domRef = c.domRef; } diff --git a/miso.cabal b/miso.cabal --- a/miso.cabal +++ b/miso.cabal @@ -1,5 +1,5 @@ name: miso -version: 0.4.0.0 +version: 0.5.0.0 category: Web, Miso, Data Structures license: BSD3 license-file: LICENSE @@ -53,6 +53,23 @@ default-language: Haskell2010 +executable xhr + main-is: + Main.hs + if !impl(ghcjs) || !flag(examples) + buildable: False + else + hs-source-dirs: + examples/xhr + build-depends: + aeson, + base < 5, + containers, + ghcjs-base, + miso + default-language: + Haskell2010 + executable router main-is: Main.hs @@ -101,6 +118,20 @@ default-language: Haskell2010 +executable compose-update + main-is: + Main.hs + if !impl(ghcjs) || !flag(examples) + buildable: False + else + hs-source-dirs: + examples/compose-update + build-depends: + base < 5, + miso + default-language: + Haskell2010 + executable simple main-is: Main.hs @@ -144,6 +175,7 @@ Miso.Html.Element Miso.Html.Event Miso.Html.Property + Miso.Lens Miso.Event Miso.Event.Decoder Miso.Event.Types @@ -186,6 +218,7 @@ jsbits/isomorphic.js jsbits/util.js exposed-modules: + Miso.Dev Miso.Effect Miso.Effect.Storage Miso.Effect.XHR diff --git a/src/Miso/Lens.hs b/src/Miso/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Lens.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Lens +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Lens + ( Lens + , Lens' + , Getting + , get + , set + , makeLens + ) where + +import Data.Functor.Identity +import Control.Applicative + +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t +type Lens' s a = Lens s s a a +type Getting r s a = (a -> Const r a) -> (s -> Const r s) + +get :: Getting a s a -> s -> a +get l = \ s -> getConst (l Const s) + +set :: Lens s t a b -> b -> s -> t +set l b = \s -> runIdentity (l (\ _ -> pure b) s) + +makeLens :: (s -> a) -> (s -> b -> t) -> Lens s t a b +makeLens get' upd = \ f s -> upd s `fmap` f (get' s)