diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2016-2018, David M. Johnson
+Copyright (c) 2016-2020, David M. Johnson
All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -11,24 +11,27 @@
-
- 
-
- 
+ 
-
- 
+
+ 
-
- 
+
+ 
+
+
+
+
+ 
+
-**Miso** is a small "[isomorphic](http://nerds.airbnb.com/isomorphic-javascript-future-web-apps/)" [Haskell](https://www.haskell.org/) front-end framework for quickly building highly interactive single-page web applications. It features 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. **Miso** can be considered a shallow [embedded domain-specific language](https://wiki.haskell.org/Embedded_domain_specific_language) for modern web programming.
+**Miso** is a small, production-ready, "[isomorphic](http://nerds.airbnb.com/isomorphic-javascript-future-web-apps/)" [Haskell](https://www.haskell.org/) front-end framework for quickly building highly interactive single-page web applications. It features a virtual-dom, recursive 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. **Miso** can be considered a shallow [embedded domain-specific language](https://wiki.haskell.org/Embedded_domain_specific_language) for modern web programming.
## Table of Contents
- [Quick Start](#quick-start)
@@ -73,8 +76,10 @@
To build the sample-app with `nix`, execute the commands below:
```bash
-(optional) nix-env -iA cachix -f https://cachix.org/api/v1/install
-(optional) cachix use haskell-miso
+# optional use of cache
+nix-env -iA cachix -f https://cachix.org/api/v1/install
+# optional use of cache
+cachix use haskell-miso
git clone https://github.com/dmjio/miso
cd miso/sample-app
nix-build
@@ -120,8 +125,8 @@
```nix
with (import (builtins.fetchTarball {
- url = "https://github.com/dmjio/miso/archive/b4c473f3ed6d6251ea7b8b489fc50076ac8d9b70.tar.gz";
- sha256 = "11rby2s0hxbl28a4fcwdm9lcbjfysv862xd6b9jy0rgl63dh51i3";
+ url = "https://github.com/dmjio/miso/archive/39b9e26ff41d6aab3b9d13a9d102ac56017f6a1f.tar.gz";
+ sha256 = "1lwr35p9074b7wgz0jh4f2pjc7ls8isgzmn9xl86vb6cvsm035kf";
}) {});
with pkgs.haskell.packages;
ghcjs.callCabal2nix "app" ./. {}
@@ -341,7 +346,7 @@
## Binary cache
-`nix` users on a Linux or OSX distro can take advantage of a [binary cache](https://hydra.dmj.io/nix-cache-info) for faster builds. To use the binary cache follow the instructions on `https://haskell-miso.cachix.org/`.
+`nix` users on a Linux or OSX distro can take advantage of a [binary cache](https://haskell-miso.cachix.org) for faster builds. To use the binary cache follow the instructions on [cachix](https://haskell-miso.cachix.org/).
```bash
cachix use haskell-miso
diff --git a/examples/canvas2d/Main.hs b/examples/canvas2d/Main.hs
deleted file mode 100644
--- a/examples/canvas2d/Main.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Main where
-
-import Control.Monad
-import GHCJS.Types
-import JavaScript.Web.Canvas
-
-import Miso
-import Miso.String
-
-type Model = (Double, Double)
-
-data Action
- = NoOp
- | GetTime
- | SetTime Model
-
-main :: IO ()
-main = do
- [sun, moon, earth] <- replicateM 3 newImage
- setSrc sun "https://mdn.mozillademos.org/files/1456/Canvas_sun.png"
- setSrc moon "https://mdn.mozillademos.org/files/1443/Canvas_moon.png"
- setSrc earth "https://mdn.mozillademos.org/files/1429/Canvas_earth.png"
- startApp App { initialAction = GetTime
- , update = updateModel (sun,moon,earth)
- , ..
- }
- where
- view _ = canvas_ [ id_ "canvas"
- , width_ "300"
- , height_ "300"
- ] []
- model = (0.0, 0.0)
- subs = []
- events = defaultEvents
- mountPoint = Nothing -- default to body
-
-updateModel
- :: (Image,Image,Image)
- -> Action
- -> Model
- -> Effect Action Model
-updateModel _ NoOp m = noEff m
-updateModel _ GetTime m = m <# do
- date <- newDate
- (s,m') <- (,) <$> getSecs date <*> getMillis date
- pure $ SetTime (s,m')
-updateModel (sun,moon,earth) (SetTime m@(secs,millis)) _ = m <# do
- ctx <- getCtx
- setGlobalCompositeOperation ctx
- clearRect 0 0 300 300 ctx
- fillStyle 0 0 0 0.6 ctx
- strokeStyle 0 153 255 0.4 ctx
- save ctx
- translate 150 150 ctx
- flip rotate ctx $ (((2 * pi) / 60) * secs) + (((2 * pi) / 60000) * millis)
- translate 105 0 ctx
- fillRect 0 (-12) 50 24 ctx
- drawImage' earth (-12) (-12) ctx
- save ctx
- flip rotate ctx $ (((2 * pi) / 6) * secs) + (((2 * pi) / 6000) * millis)
- translate 0 28.5 ctx
- drawImage' moon (-3.5) (-3.5) ctx
- replicateM_ 2 (restore ctx)
- beginPath ctx
- arc 150 150 105 0 (pi * 2) False ctx
- stroke ctx
- drawImage sun 0 0 300 300 ctx
- pure GetTime
-
-foreign import javascript unsafe "$1.globalCompositeOperation = 'destination-over';"
- setGlobalCompositeOperation :: Context -> IO ()
-
-foreign import javascript unsafe "$4.drawImage($1,$2,$3);"
- drawImage' :: Image -> Double -> Double -> Context -> IO ()
-
-foreign import javascript unsafe "$r = document.getElementById('canvas').getContext('2d');"
- getCtx :: IO Context
-
-foreign import javascript unsafe "$r = new Image();"
- newImage :: IO Image
-
-foreign import javascript unsafe "$1.src = $2;"
- setSrc :: Image -> MisoString -> IO ()
-
-foreign import javascript unsafe "$r = new Date();"
- newDate :: IO JSVal
-
-foreign import javascript unsafe "$r = $1.getSeconds();"
- getSecs :: JSVal -> IO Double
-
-foreign import javascript unsafe "$r = $1.getMilliseconds();"
- getMillis :: JSVal -> IO Double
-
diff --git a/examples/compose-update/Main.hs b/examples/compose-update/Main.hs
deleted file mode 100644
--- a/examples/compose-update/Main.hs
+++ /dev/null
@@ -1,108 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE OverloadedStrings #-}
-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.String
-
--- 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.
-type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
-
--- | 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 = []
- mountPoint = Nothing
-
-viewModel :: Model -> View Action
-viewModel (x, y) =
- div_
- []
- [ button_ [onClick Increment] [text "+"]
- , text (ms x <> " | " <> ms y)
- , button_ [onClick Decrement] [text "-"]
- ]
diff --git a/examples/file-reader/Main.hs b/examples/file-reader/Main.hs
deleted file mode 100644
--- a/examples/file-reader/Main.hs
+++ /dev/null
@@ -1,89 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-module Main where
-
-import Miso
-import Miso.String
-import Control.Concurrent.MVar
-
-import GHCJS.Types
-import GHCJS.Foreign.Callback
-
--- | Model
-data Model
- = Model
- { info :: MisoString
- } deriving (Eq, Show)
-
--- | Action
-data Action
- = ReadFile
- | NoOp
- | SetContent MisoString
- deriving (Show, Eq)
-
--- | Main entry point
-main :: IO ()
-main = do
- startApp App { model = Model ""
- , initialAction = NoOp
- , ..
- }
- where
- mountPoint = Nothing
- update = updateModel
- events = defaultEvents
- subs = []
- view = viewModel
-
--- | Update your model
-updateModel :: Action -> Model -> Effect Action Model
-updateModel ReadFile m = m <# do
- fileReaderInput <- getElementById "fileReader"
- file <- getFile fileReaderInput
- reader <- newReader
- mvar <- newEmptyMVar
- setOnLoad reader =<< do
- asyncCallback $ do
- r <- getResult reader
- putMVar mvar r
- readText reader file
- SetContent <$> readMVar mvar
-updateModel (SetContent c) m = noEff m { info = c }
-updateModel NoOp m = noEff m
-
--- | View function, with routing
-viewModel :: Model -> View Action
-viewModel Model {..} = view
- where
- view = div_ [] [
- "FileReader API example"
- , input_ [ id_ "fileReader"
- , type_ "file"
- , onChange (const ReadFile)
- ]
- , div_ [] [ text info ]
- ]
-
-foreign import javascript unsafe "console.log($1);"
- consoleLog :: JSVal -> IO ()
-
-foreign import javascript unsafe "$r = new FileReader();"
- newReader :: IO JSVal
-
-foreign import javascript unsafe "$r = $1.files[0];"
- getFile :: JSVal -> IO JSVal
-
-foreign import javascript unsafe "$1.onload = $2;"
- setOnLoad :: JSVal -> Callback (IO ()) -> IO ()
-
-foreign import javascript unsafe "$r = $1.result;"
- getResult :: JSVal -> IO MisoString
-
-foreign import javascript unsafe "$1.readAsText($2);"
- readText :: JSVal -> JSVal -> IO ()
diff --git a/examples/mario/Main.hs b/examples/mario/Main.hs
deleted file mode 100644
--- a/examples/mario/Main.hs
+++ /dev/null
@@ -1,176 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE BangPatterns #-}
-module Main where
-
-import Data.Bool
-import Data.Function
-import qualified Data.Map as M
-import Data.Monoid
-
-import Miso
-import Miso.String
-
-import qualified Language.Javascript.JSaddle.Warp as JSaddle
-
-#ifdef ghcjs_HOST_OS
-run :: Int -> JSM () -> IO ()
-run = JSaddle.run
-#else
-import Network.Wai.Application.Static
-import qualified Network.Wai as Wai
-import qualified Network.Wai.Handler.Warp as Warp
-import Network.WebSockets
-
-run :: Int -> JSM () -> IO ()
-run port f =
- Warp.runSettings (Warp.setPort port (Warp.setTimeout 3600 Warp.defaultSettings)) =<<
- JSaddle.jsaddleOr defaultConnectionOptions (f >> syncPoint) app
- where app req sendResp =
- case Wai.pathInfo req of
- ("imgs" : _) -> staticApp (defaultWebAppSettings "examples/mario") req sendResp
- _ -> JSaddle.jsaddleApp req sendResp
-#endif
-
-data Action
- = GetArrows !Arrows
- | Time !Double
- | WindowCoords !(Int,Int)
- | NoOp
-
-spriteFrames :: [MisoString]
-spriteFrames = ["0 0", "-74px 0","-111px 0","-148px 0","-185px 0","-222px 0","-259px 0","-296px 0"]
-
-main :: IO ()
-main = run 8080 $ do
- time <- now
- let m = mario { time = time }
- startApp App { model = m
- , initialAction = NoOp
- , ..
- }
- where
- update = updateMario
- view = display
- events = defaultEvents
- subs = [ arrowsSub GetArrows
- , windowCoordsSub WindowCoords
- ]
- mountPoint = Nothing
-
-data Model = Model
- { x :: !Double
- , y :: !Double
- , vx :: !Double
- , vy :: !Double
- , dir :: !Direction
- , time :: !Double
- , delta :: !Double
- , arrows :: !Arrows
- , window :: !(Int,Int)
- } deriving (Show, Eq)
-
-data Direction
- = L
- | R
- deriving (Show,Eq)
-
-mario :: Model
-mario = Model
- { x = 0
- , y = 0
- , vx = 0
- , vy = 0
- , dir = R
- , time = 0
- , delta = 0
- , arrows = Arrows 0 0
- , window = (0,0)
- }
-
-updateMario :: Action -> Model -> Effect Action Model
-updateMario NoOp m = step m
-updateMario (GetArrows arrs) m = noEff newModel
- where
- newModel = m { arrows = arrs }
-updateMario (Time newTime) m = step newModel
- where
- newModel = m { delta = (newTime - time m) / 20
- , time = newTime
- }
-updateMario (WindowCoords coords) m = noEff newModel
- where
- newModel = m { window = coords }
-
-step :: Model -> Effect Action Model
-step m@Model{..} = k <# do Time <$> now
- where
- k = m & gravity delta
- & jump arrows
- & walk arrows
- & physics delta
-
-jump :: Arrows -> Model -> Model
-jump Arrows{..} m@Model{..} =
- if arrowY > 0 && vy == 0
- then m { vy = 6 }
- else m
-
-gravity :: Double -> Model -> Model
-gravity dt m@Model{..} =
- m { vy = if y > 0 then vy - (dt / 4) else 0 }
-
-physics :: Double -> Model -> Model
-physics dt m@Model{..} =
- m { x = x + dt * vx
- , y = max 0 (y + dt * vy)
- }
-
-walk :: Arrows -> Model -> Model
-walk Arrows{..} m@Model{..} =
- m { vx = fromIntegral arrowX
- , dir = if | arrowX < 0 -> L
- | arrowX > 0 -> R
- | otherwise -> dir
- }
-
-display :: Model -> View action
-display m@Model{..} = marioImage
- where
- (h,w) = window
- groundY = 62 - (fromIntegral (fst window) / 2)
- marioImage =
- div_ [ height_ $ ms h
- , width_ $ ms w
- ]
- [ nodeHtml "style" [] ["@keyframes play { 100% { background-position: -296px; } }"]
- , div_ [ style_ (marioStyle m groundY) ] []
- ]
-
-marioStyle :: Model -> Double -> M.Map MisoString MisoString
-marioStyle Model {..} gy =
- M.fromList [ ("transform", matrix dir x $ abs (y + gy) )
- , ("display", "block")
- , ("width", "37px")
- , ("height", "37px")
- , ("background-color", "transparent")
- , ("background-image", "url(imgs/mario.png)")
- , ("background-repeat", "no-repeat")
- , ("background-position", spriteFrames !! frame)
- , bool mempty ("animation", "play 0.8s steps(8) infinite") (y == 0 && vx /= 0)
- ]
- where
- frame | y > 0 = 1
- | otherwise = 0
-
-matrix :: Direction -> Double -> Double -> MisoString
-matrix dir x y =
- "matrix("
- <> (if dir == L then "-1" else "1")
- <> ",0,0,1,"
- <> ms x
- <> ","
- <> ms y
- <> ")"
diff --git a/examples/mario/imgs/mario.png b/examples/mario/imgs/mario.png
deleted file mode 100644
Binary files a/examples/mario/imgs/mario.png and /dev/null differ
diff --git a/examples/mathml/Main.hs b/examples/mathml/Main.hs
deleted file mode 100644
--- a/examples/mathml/Main.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-
--- | Haskell language pragma
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-
--- | Haskell module declaration
-module Main where
-
--- | Miso framework import
-import Miso
-import Miso.String
-import Miso.Mathml
-
-data Model = Empty deriving Eq
-
-data Action
- = NoOp
- deriving (Show, Eq)
-
--- | Entry point for a miso application
-main :: IO ()
-main = startApp App {..}
- where
- initialAction = NoOp -- initial action to be executed on application load
- model = Empty -- initial model
- update = updateModel -- update function
- view = viewModel -- view function
- events = defaultEvents -- default delegated events
- subs = [] -- empty subscription list
- mountPoint = Nothing -- mount point for application (Nothing defaults to 'body')
-
--- | Updates model, optionally introduces side effects
-updateModel :: Action -> Model -> Effect Action Model
-updateModel NoOp = noEff
-
--- | Constructs a virtual DOM from a model
-viewModel :: Model -> View Action
-viewModel x = nodeMathml "math" [] [
- nodeMathml "msup" [] [
- nodeMathml "mi" [] [text "x"]
- , nodeMathml "mn" [] [text "2"]
- ]
- ]
diff --git a/examples/router/Main.hs b/examples/router/Main.hs
deleted file mode 100644
--- a/examples/router/Main.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE CPP #-}
-module Main where
-
-import Data.Proxy
-import Servant.API
-#if MIN_VERSION_servant(0,14,1)
-import Servant.Links
-#elif MIN_VERSION_servant(0,10,0)
-import Servant.Utils.Links
-#endif
-import Language.Javascript.JSaddle.Warp as JSaddle
-
-import Miso
-
--- | Model
-data Model
- = Model
- { uri :: URI
- -- ^ current URI of application
- } deriving (Eq, Show)
-
--- | Action
-data Action
- = HandleURI URI
- | ChangeURI URI
- | NoOp
- deriving (Show, Eq)
-
--- | Main entry point
-main :: IO ()
-main = do
- JSaddle.run 8080 $ do
- currentURI <- getCurrentURI
- startApp App { model = Model currentURI, initialAction = NoOp, ..}
- where
- update = updateModel
- events = defaultEvents
- subs = [ uriSub HandleURI ]
- view = viewModel
- mountPoint = Nothing
-
--- | Update your model
-updateModel :: Action -> Model -> Effect Action Model
-updateModel (HandleURI u) m = m { uri = u } <# do
- pure NoOp
-updateModel (ChangeURI u) m = m <# do
- pushURI u
- pure NoOp
-updateModel _ m = noEff m
-
--- | View function, with routing
-viewModel :: Model -> View Action
-viewModel model = view
- where
- view =
- either (const the404) id
- $ runRoute (Proxy :: Proxy API) handlers uri model
- handlers = about :<|> home
- home (_ :: Model) = div_ [] [
- div_ [] [ text "home" ]
- , button_ [ onClick goAbout ] [ text "go about" ]
- ]
- about (_ :: Model) = div_ [] [
- div_ [] [ text "about" ]
- , button_ [ onClick goHome ] [ text "go home" ]
- ]
- the404 = div_ [] [
- text "the 404 :("
- , button_ [ onClick goHome ] [ text "go home" ]
- ]
-
--- | Type-level routes
-type API = About :<|> Home
-type Home = View Action
-type About = "about" :> View Action
-
--- | Type-safe links used in `onClick` event handlers to route the application
-goAbout, goHome :: Action
-(goHome, goAbout) = (goto api home, goto api about)
- where
-#if MIN_VERSION_servant(0,10,0)
- goto a b = ChangeURI (linkURI (safeLink a b))
-#else
- goto a b = ChangeURI (safeLink a b)
-#endif
- home = Proxy :: Proxy Home
- about = Proxy :: Proxy About
- api = Proxy :: Proxy API
-
diff --git a/examples/svg/Main.hs b/examples/svg/Main.hs
deleted file mode 100644
--- a/examples/svg/Main.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-module Main where
-
-import qualified Data.Map as M
-
-import Control.Arrow
-import Miso
-import Miso.String (MisoString, pack, ms)
-import Miso.Svg hiding (height_, id_, style_, width_)
-import Touch
-
-trunc = truncate *** truncate
-
-main :: IO ()
-main = startApp App {..}
- where
- initialAction = Id
- model = emptyModel
- update = updateModel
- view = viewModel
- events = M.insert (pack "mousemove") False $
- M.insert (pack "touchstart") False $
- M.insert (pack "touchmove") False defaultEvents
- subs = [ mouseSub HandleMouse ]
- mountPoint = Nothing
-
-emptyModel :: Model
-emptyModel = Model (0,0)
-
-updateModel :: Action -> Model -> Effect Action Model
-updateModel (HandleTouch (TouchEvent touch)) model =
- model <# do
- putStrLn "Touch did move"
- print touch
- return $ HandleMouse $ trunc . page $ touch
-updateModel (HandleMouse newCoords) model =
- noEff model { mouseCoords = newCoords }
-updateModel Id model = noEff model
-
-data Action
- = HandleMouse (Int, Int)
- | HandleTouch TouchEvent
- | Id
-
-newtype Model
- = Model
- { mouseCoords :: (Int, Int)
- } deriving (Show, Eq)
-
-viewModel :: Model -> View Action
-viewModel (Model (x,y)) =
- div_ [ ] [
- svg_ [ style_ $ M.fromList [ ("border-style", "solid")
- , ("height", "700px")
- ]
- , width_ "auto"
- , onTouchMove HandleTouch
- ] [
- g_ [] [
- ellipse_ [ cx_ $ ms x
- , cy_ $ ms y
- , style_ svgStyle
- , rx_ "100"
- , ry_ "100"
- ] [ ]
- ]
- , text_ [ x_ $ ms x
- , y_ $ ms y
- ] [ text $ ms $ show (x,y) ]
- ]
- ]
-
-svgStyle :: M.Map MisoString MisoString
-svgStyle =
- M.fromList [
- ("fill", "yellow")
- , ("stroke", "purple")
- , ("stroke-width", "2")
- ]
diff --git a/examples/svg/Touch.hs b/examples/svg/Touch.hs
deleted file mode 100644
--- a/examples/svg/Touch.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-module Touch where
-
-import Control.Monad
-import Data.Aeson.Types
-import Debug.Trace
-import Miso
-
-data Touch = Touch
- { identifier :: Int
- , screen :: (Int, Int)
- , client :: (Double, Double)
- , page :: (Double, Double)
- } deriving (Eq, Show)
-
-instance FromJSON Touch where
- parseJSON =
- withObject "touch" $ \o -> do
- identifier <- o .: "identifier"
- screen <- (,) <$> o .: "screenX" <*> o .: "screenY"
- client <- (,) <$> o .: "clientX" <*> o .: "clientY"
- page <- (,) <$> o .: "pageX" <*> o .: "pageY"
- return Touch {..}
-
-data TouchEvent =
- TouchEvent Touch
- deriving (Eq, Show)
-
-instance FromJSON TouchEvent where
- parseJSON obj = do
- ((x:_):_) <- parseJSON obj
- return $ TouchEvent x
-
-touchDecoder :: Decoder TouchEvent
-touchDecoder = Decoder {..}
- where
- decodeAt = DecodeTargets [["changedTouches"], ["targetTouches"], ["touches"]]
- decoder = parseJSON
-
-onTouchMove :: (TouchEvent -> action) -> Attribute action
-onTouchMove = on "touchmove" touchDecoder
-
-onTouchStart = on "touchstart" touchDecoder
diff --git a/examples/three/Main.hs b/examples/three/Main.hs
deleted file mode 100644
--- a/examples/three/Main.hs
+++ /dev/null
@@ -1,151 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-module Main where
-
-import Control.Monad
-import Data.IORef
-import qualified Data.Map as M
-import GHCJS.Types
-
-import Miso
-import Miso.String
-
-data Action
- = GetTime
- | Init
- | SetTime !Double
-
-withStats :: JSVal -> IO () -> IO ()
-withStats stats m = do
- statsBegin stats >> m
- statsEnd stats
-
-data Context = Context
- { rotateCube :: IO ()
- , renderScene :: IO ()
- , stats :: JSVal
- }
-
-initContext :: IORef Context -> IO ()
-initContext ref = do
- canvas <- getElementById "canvas"
- scene <- newScene
- camera <- newCamera
- renderer <- newRenderer canvas
- setSize renderer
- cube <- join $ newMesh
- <$> newBoxGeometry 1 1 1
- <*> newMeshBasicMaterial
- addToScene scene cube
- positionCamera camera 5
- stats <- newStats
- statsContainer <- getElementById "stats"
- addStatsToDOM statsContainer stats
- writeIORef ref Context {
- stats = stats
- , rotateCube = do
- rotateX cube 0.1
- rotateY cube 0.1
- , renderScene =
- render renderer scene camera
- }
-
-main :: IO ()
-main = do
- stats <- newStats
- ref <- newIORef $ Context (pure ()) (pure ()) stats
- m <- now
- startApp App { model = m
- , initialAction = Init
- , update = updateModel ref
- , mountPoint = Nothing
- , ..
- }
- where
- events = defaultEvents
- view = viewModel
- subs = []
-
-viewModel :: Double -> View action
-viewModel _ = div_ [] [
- div_ [ id_ "stats"
- , style_ $ M.singleton "position" "absolute"
- ] []
- , canvas_ [ id_ "canvas"
- , width_ "400"
- , height_ "300"
- ] []
- ]
-
-updateModel
- :: IORef Context
- -> Action
- -> Double
- -> Effect Action Double
-updateModel ref Init m = m <# do
- initContext ref
- pure GetTime
-
-updateModel ref GetTime m = m <# do
- Context {..} <- readIORef ref
- withStats stats $ do
- rotateCube
- renderScene
- SetTime <$> now
-
-updateModel _ (SetTime m) _ =
- m <# pure GetTime
-
-foreign import javascript unsafe "$r = new Stats();"
- newStats :: IO JSVal
-
-foreign import javascript unsafe "$1.begin();"
- statsBegin :: JSVal -> IO ()
-
-foreign import javascript unsafe "$1.end();"
- statsEnd :: JSVal -> IO ()
-
-foreign import javascript unsafe "$1.showPanel(0);"
- showPanel :: JSVal -> IO ()
-
-foreign import javascript unsafe "$r = new THREE.Scene();"
- newScene :: IO JSVal
-
-foreign import javascript unsafe "$r = new THREE.BoxGeometry( $1, $2, $3 );"
- newBoxGeometry :: Int -> Int -> Int -> IO JSVal
-
-foreign import javascript unsafe "$r = new THREE.PerspectiveCamera( 75, window.innerWidth/window.innerHeight, 0.1, 1000 );"
- newCamera :: IO JSVal
-
-foreign import javascript unsafe "$r = new THREE.Mesh( $1, $2 );"
- newMesh :: JSVal -> JSVal -> IO JSVal
-
-foreign import javascript unsafe "$r = new THREE.MeshBasicMaterial( { color: 0x00ff00 } );"
- newMeshBasicMaterial :: IO JSVal
-
-foreign import javascript unsafe "$r = new THREE.WebGLRenderer({canvas:$1, antialias : true});"
- newRenderer :: JSVal -> IO JSVal
-
-foreign import javascript unsafe "$1.setSize( window.innerWidth, window.innerHeight );"
- setSize :: JSVal -> IO ()
-
-foreign import javascript unsafe "$1.add($2);"
- addToScene :: JSVal -> JSVal -> IO ()
-
-foreign import javascript unsafe "$1.position.z = $2;"
- cameraZ :: JSVal -> Int -> IO ()
-
-foreign import javascript unsafe "$1.rotation.x += $2;"
- rotateX :: JSVal -> Double -> IO ()
-
-foreign import javascript unsafe "$1.rotation.y += $2;"
- rotateY :: JSVal -> Double -> IO ()
-
-foreign import javascript unsafe "$1.render($2, $3);"
- render :: JSVal -> JSVal -> JSVal -> IO ()
-
-foreign import javascript unsafe "$1.position.z = $2;"
- positionCamera :: JSVal -> Double -> IO ()
-
-foreign import javascript unsafe "$1.appendChild( $2.domElement );"
- addStatsToDOM :: JSVal -> JSVal -> IO ()
diff --git a/examples/todo-mvc/Main.hs b/examples/todo-mvc/Main.hs
deleted file mode 100644
--- a/examples/todo-mvc/Main.hs
+++ /dev/null
@@ -1,320 +0,0 @@
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ExtendedDefaultRules #-}
-module Main where
-
-import Data.Aeson hiding (Object)
-import Data.Bool
-import qualified Data.Map as M
-import Data.Monoid
-import GHC.Generics
-import Miso
-import Miso.String (MisoString)
-import qualified Miso.String as S
-
-import Control.Monad.IO.Class
-import Language.Javascript.JSaddle.Warp as JSaddle
-
-default (MisoString)
-
-data Model = Model
- { entries :: [Entry]
- , field :: MisoString
- , uid :: Int
- , visibility :: MisoString
- , step :: Bool
- } deriving (Show, Generic, Eq)
-
-data Entry = Entry
- { description :: MisoString
- , completed :: Bool
- , editing :: Bool
- , eid :: Int
- , focussed :: Bool
- } deriving (Show, Generic, Eq)
-
-instance ToJSON Entry
-instance ToJSON Model
-
-instance FromJSON Entry
-instance FromJSON Model
-
-emptyModel :: Model
-emptyModel = Model
- { entries = []
- , visibility = "All"
- , field = mempty
- , uid = 0
- , step = False
- }
-
-newEntry :: MisoString -> Int -> Entry
-newEntry desc eid = Entry
- { description = desc
- , completed = False
- , editing = False
- , eid = eid
- , focussed = False
- }
-
-data Msg
- = NoOp
- | CurrentTime Int
- | UpdateField MisoString
- | EditingEntry Int Bool
- | UpdateEntry Int MisoString
- | Add
- | Delete Int
- | DeleteComplete
- | Check Int Bool
- | CheckAll Bool
- | ChangeVisibility MisoString
- deriving Show
-
-main :: IO ()
-main =
- JSaddle.run 8080 $ startApp App { initialAction = NoOp, ..}
- where
- model = emptyModel
- update = updateModel
- view = viewModel
- events = defaultEvents
- mountPoint = Nothing
- subs = []
-
-updateModel :: Msg -> Model -> Effect Msg Model
-updateModel NoOp m = noEff m
-updateModel (CurrentTime n) m =
- m <# do liftIO (print n) >> pure NoOp
-updateModel Add model@Model{..} =
- noEff model {
- uid = uid + 1
- , field = mempty
- , entries = entries <> [ newEntry field uid | not $ S.null field ]
- }
-updateModel (UpdateField str) model = noEff model { field = str }
-updateModel (EditingEntry id' isEditing) model@Model{..} =
- model { entries = newEntries } <# do
- focus $ S.pack $ "todo-" ++ show id'
- pure NoOp
- where
- newEntries = filterMap entries (\t -> eid t == id') $
- \t -> t { editing = isEditing, focussed = isEditing }
-
-updateModel (UpdateEntry id' task) model@Model{..} =
- noEff model { entries = newEntries }
- where
- newEntries =
- filterMap entries ((==id') . eid) $ \t ->
- t { description = task }
-
-updateModel (Delete id') model@Model{..} =
- noEff model { entries = filter (\t -> eid t /= id') entries }
-
-updateModel DeleteComplete model@Model{..} =
- noEff model { entries = filter (not . completed) entries }
-
-updateModel (Check id' isCompleted) model@Model{..} =
- model { entries = newEntries } <# eff
- where
- eff =
- liftIO (putStrLn "clicked check") >>
- pure NoOp
-
- newEntries =
- filterMap entries (\t -> eid t == id') $ \t ->
- t { completed = isCompleted }
-
-updateModel (CheckAll isCompleted) model@Model{..} =
- noEff model { entries = newEntries }
- where
- newEntries =
- filterMap entries (const True) $
- \t -> t { completed = isCompleted }
-
-updateModel (ChangeVisibility v) model =
- noEff model { visibility = v }
-
-filterMap :: [a] -> (a -> Bool) -> (a -> a) -> [a]
-filterMap xs predicate f = go' xs
- where
- go' [] = []
- go' (y:ys)
- | predicate y = f y : go' ys
- | otherwise = y : go' ys
-
-viewModel :: Model -> View Msg
-viewModel m@Model{..} =
- div_
- [ class_ "todomvc-wrapper"
- , style_ $ M.singleton "visibility" "hidden"
- ]
- [ section_
- [ class_ "todoapp" ]
- [ viewInput m field
- , viewEntries visibility entries
- , viewControls m visibility entries
- ]
- , infoFooter
- , link_
- [ rel_ "stylesheet"
- , href_ "https://d33wubrfki0l68.cloudfront.net/css/d0175a264698385259b5f1638f2a39134ee445a0/style.css"
- ]
- ]
-
-viewEntries :: MisoString -> [ Entry ] -> View Msg
-viewEntries visibility entries =
- section_
- [ class_ "main"
- , style_ $ M.singleton "visibility" cssVisibility
- ]
- [ input_
- [ class_ "toggle-all"
- , type_ "checkbox"
- , name_ "toggle"
- , checked_ allCompleted
- , onClick $ CheckAll (not allCompleted)
- ]
- , label_
- [ for_ "toggle-all" ]
- [ text $ S.pack "Mark all as complete" ]
- , ul_ [ class_ "todo-list" ] $
- flip map (filter isVisible entries) $ \t ->
- viewKeyedEntry t
- ]
- where
- cssVisibility = bool "visible" "hidden" (null entries)
- allCompleted = all (==True) $ completed <$> entries
- isVisible Entry {..} =
- case visibility of
- "Completed" -> completed
- "Active" -> not completed
- _ -> True
-
-viewKeyedEntry :: Entry -> View Msg
-viewKeyedEntry = viewEntry
-
-viewEntry :: Entry -> View Msg
-viewEntry Entry {..} = liKeyed_ (toKey eid)
- [ class_ $ S.intercalate " " $
- [ "completed" | completed ] <> [ "editing" | editing ]
- ]
- [ div_
- [ class_ "view" ]
- [ input_
- [ class_ "toggle"
- , type_ "checkbox"
- , checked_ completed
- , onClick $ Check eid (not completed)
- ]
- , label_
- [ onDoubleClick $ EditingEntry eid True ]
- [ text description ]
- , button_
- [ class_ "destroy"
- , onClick $ Delete eid
- ] []
- ]
- , input_
- [ class_ "edit"
- , value_ description
- , name_ "title"
- , id_ $ "todo-" <> S.ms eid
- , onInput $ UpdateEntry eid
- , onBlur $ EditingEntry eid False
- , onEnter $ EditingEntry eid False
- ]
- ]
-
-viewControls :: Model -> MisoString -> [ Entry ] -> View Msg
-viewControls model visibility entries =
- footer_ [ class_ "footer"
- , hidden_ (null entries)
- ]
- [ viewControlsCount entriesLeft
- , viewControlsFilters visibility
- , viewControlsClear model entriesCompleted
- ]
- where
- entriesCompleted = length . filter completed $ entries
- entriesLeft = length entries - entriesCompleted
-
-viewControlsCount :: Int -> View Msg
-viewControlsCount entriesLeft =
- span_ [ class_ "todo-count" ]
- [ strong_ [] [ text $ S.ms entriesLeft ]
- , text (item_ <> " left")
- ]
- where
- item_ = S.pack $ bool " items" " item" (entriesLeft == 1)
-
-viewControlsFilters :: MisoString -> View Msg
-viewControlsFilters visibility =
- ul_
- [ class_ "filters" ]
- [ visibilitySwap "#/" "All" visibility
- , text " "
- , visibilitySwap "#/active" "Active" visibility
- , text " "
- , visibilitySwap "#/completed" "Completed" visibility
- ]
-
-visibilitySwap :: MisoString -> MisoString -> MisoString -> View Msg
-visibilitySwap uri visibility actualVisibility =
- li_ [ ]
- [ a_ [ href_ uri
- , class_ $ S.concat [ "selected" | visibility == actualVisibility ]
- , onClick (ChangeVisibility visibility)
- ] [ text visibility ]
- ]
-
-viewControlsClear :: Model -> Int -> View Msg
-viewControlsClear _ entriesCompleted =
- button_
- [ class_ "clear-completed"
- , prop "hidden" (entriesCompleted == 0)
- , onClick DeleteComplete
- ]
- [ text $ "Clear completed (" <> S.ms entriesCompleted <> ")" ]
-
-viewInput :: Model -> MisoString -> View Msg
-viewInput _ task =
- header_ [ class_ "header" ]
- [ h1_ [] [ text "todos" ]
- , input_
- [ class_ "new-todo"
- , placeholder_ "What needs to be done?"
- , autofocus_ True
- , value_ task
- , name_ "newTodo"
- , onInput UpdateField
- , onEnter Add
- ]
- ]
-
-onEnter :: Msg -> Attribute Msg
-onEnter action =
- onKeyDown $ bool NoOp action . (== KeyCode 13)
-
-infoFooter :: View Msg
-infoFooter =
- footer_ [ class_ "info" ]
- [ p_ [] [ text "Double-click to edit a todo" ]
- , p_ []
- [ text "Written by "
- , a_ [ href_ "https://github.com/dmjio" ] [ text "David Johnson" ]
- ]
- , p_ []
- [ text "Part of "
- , a_ [ href_ "http://todomvc.com" ] [ text "TodoMVC" ]
- ]
- ]
diff --git a/examples/websocket/Main.hs b/examples/websocket/Main.hs
deleted file mode 100644
--- a/examples/websocket/Main.hs
+++ /dev/null
@@ -1,76 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ExtendedDefaultRules #-}
-module Main where
-
-import Data.Aeson
-import GHC.Generics
-import Data.Bool
-import qualified Data.Map as M
-
-import Miso
-import Miso.String (MisoString)
-import qualified Miso.String as S
-
-import qualified Language.Javascript.JSaddle.Warp as JSaddle
-
-main :: IO ()
-main = JSaddle.run 8080 $ startApp App { initialAction = Id, ..}
- where
- model = Model (Message "") mempty
- events = defaultEvents
- subs = [ websocketSub uri protocols HandleWebSocket ]
- update = updateModel
- view = appView
- uri = URL "wss://echo.websocket.org"
- protocols = Protocols [ ]
- mountPoint = Nothing
-
-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
-updateModel (UpdateMessage m) model = noEff model { msg = Message m }
-updateModel _ model = noEff model
-
-instance ToJSON Message
-instance FromJSON Message
-
-newtype Message = Message MisoString
- deriving (Eq, Show, Generic)
-
-data Action
- = HandleWebSocket (WebSocket Message)
- | SendMessage Message
- | UpdateMessage MisoString
- | Id
-
-data Model = Model {
- msg :: Message
- , received :: MisoString
- } deriving (Show, Eq)
-
-appView :: Model -> View Action
-appView Model{..} = div_ [ style_ $ M.fromList [("text-align", "center")] ] [
- link_ [rel_ "stylesheet", href_ "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.4.3/css/bulma.min.css"]
- , h1_ [style_ $ M.fromList [("font-weight", "bold")] ] [ a_ [ href_ "https://github.com/dmjio/miso" ] [ text $ S.pack "Miso Websocket Example" ] ]
- , h3_ [] [ text $ S.pack "wss://echo.websocket.org" ]
- , input_ [ type_ "text"
- , onInput UpdateMessage
- , onEnter (SendMessage msg)
- ]
- , button_ [ onClick (SendMessage msg)
- ] [ text (S.pack "Send to echo server") ]
- , div_ [ ] [ p_ [ ] [ text received | not . S.null $ received ] ]
- ]
-
-onEnter :: Action -> Attribute Action
-onEnter action = onKeyDown $ bool Id action . (== KeyCode 13)
diff --git a/examples/xhr/Main.hs b/examples/xhr/Main.hs
deleted file mode 100644
--- a/examples/xhr/Main.hs
+++ /dev/null
@@ -1,145 +0,0 @@
-{-# 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
- , mountPoint = Nothing
- , ..
- }
- 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_ True | 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
@@ -1,6 +1,7 @@
-- | Haskell language pragma
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
-- | Haskell module declaration
module Main where
@@ -10,8 +11,19 @@
import Miso.String
import Control.Monad.IO.Class
+
+#ifdef IOS
+import Language.Javascript.JSaddle.WKWebView as JSaddle
+
+runApp :: JSM () -> IO ()
+runApp = JSaddle.run
+#else
import Language.Javascript.JSaddle.Warp as JSaddle
+runApp :: JSM () -> IO ()
+runApp = JSaddle.run 8080
+#endif
+
-- | Type synonym for an application model
type Model = Int
@@ -25,8 +37,7 @@
-- | Entry point for a miso application
main :: IO ()
-main = JSaddle.run 8080 $ do
- startApp App {..}
+main = runApp $ startApp App {..}
where
initialAction = SayHelloWorld -- initial action to be executed on application load
model = 0 -- initial model
diff --git a/frontend-src/Miso.hs b/frontend-src/Miso.hs
--- a/frontend-src/Miso.hs
+++ b/frontend-src/Miso.hs
@@ -5,7 +5,11 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE TemplateHaskell #-}
+
+#ifdef IOS
+#else
+{-# LANGUAGE TemplateHaskell #-}
+#endif
-----------------------------------------------------------------------------
-- |
-- Module : Miso
@@ -39,9 +43,13 @@
import qualified JavaScript.Object.Internal as OI
#ifdef JSADDLE
-import GHCJS.Types (JSString)
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
@@ -67,10 +75,14 @@
-> 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
diff --git a/frontend-src/Miso/JSBits.hs b/frontend-src/Miso/JSBits.hs
new file mode 100644
--- /dev/null
+++ b/frontend-src/Miso/JSBits.hs
@@ -0,0 +1,1 @@
+module Miso.JSBits where
diff --git a/frontend-src/Miso/Subscription/WebSocket.hs b/frontend-src/Miso/Subscription/WebSocket.hs
--- a/frontend-src/Miso/Subscription/WebSocket.hs
+++ b/frontend-src/Miso/Subscription/WebSocket.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
diff --git a/jsaddle-ffi/Miso/FFI.hs b/jsaddle-ffi/Miso/FFI.hs
--- a/jsaddle-ffi/Miso/FFI.hs
+++ b/jsaddle-ffi/Miso/FFI.hs
@@ -200,7 +200,7 @@
-- | Copies DOM pointers into virtual dom
-- entry point into isomorphic javascript
copyDOMIntoVTree :: JSVal -> JSVal -> JSM ()
-copyDOMIntoVTree mountPoint a = () <$ jsg1 "copyDOMIntoVTree" mountPoint a
+copyDOMIntoVTree mountPoint a = () <$ jsg2 "copyDOMIntoVTree" mountPoint a
-- TODO For now, we do not free callbacks when compiling with JSaddle
diff --git a/jsbits/delegate.js b/jsbits/delegate.js
--- a/jsbits/delegate.js
+++ b/jsbits/delegate.js
@@ -1,3 +1,4 @@
+window = typeof window === 'undefined' ? {} : window;
window['oldCallbacks'] = [];
window['currentCallbacks'] = [];
@@ -29,7 +30,7 @@
for (var event in events) {
mountPointElement.addEventListener(events[event][0], function(e) {
getVTree(function (obj) {
- window['delegateEvent'](e, obj, window['buildTargetToElement'](mountPointElement, e.target), []);
+ window['delegateEvent'](e, obj, window['buildTargetToElement'](mountPointElement, e.target), []);
});
}, events[event][1]);
}
@@ -45,12 +46,12 @@
else if (stack.length > 1) {
if (obj['domRef'] === stack[0]) parentStack.unshift(obj);
for (var o = 0; o < obj.children.length; o++) {
- if (obj.children[o]['type'] === "vtext") continue;
+ if (obj.children[o]['type'] === 'vtext') continue;
delegateEvent ( event
- , obj.children[o]
- , stack.slice(1)
- , parentStack
- );
+ , obj.children[o]
+ , stack.slice(1)
+ , parentStack
+ );
}
}
@@ -59,15 +60,15 @@
if (obj['domRef'] === stack[0]) {
var eventObj = obj['events'][event.type];
if (eventObj) {
- var options = eventObj.options;
+ var options = eventObj.options;
if (options['preventDefault'])
- event.preventDefault();
+ event.preventDefault();
eventObj['runEvent'](event);
if (!options['stopPropagation'])
- window['propogateWhileAble'] (parentStack, event);
+ window['propogateWhileAble'] (parentStack, event);
} else {
- /* still propagate to parent handlers even if event not defined */
- window['propogateWhileAble'] (parentStack, event);
+ /* still propagate to parent handlers even if event not defined */
+ window['propogateWhileAble'] (parentStack, event);
}
}
}
@@ -86,7 +87,7 @@
for (var i = 0; i < parentStack.length; i++) {
if (parentStack[i]['events'][event.type]) {
var eventObj = parentStack[i]['events'][event.type],
- options = eventObj['options'];
+ options = eventObj['options'];
if (options['preventDefault']) event.preventDefault();
eventObj['runEvent'](event);
if (options['stopPropagation']) break;
@@ -98,11 +99,11 @@
values (string, numbers and booleans)*/
window['objectToJSON'] = function objectToJSON (at, obj) {
/* If at is of type [[MisoString]] */
- if (typeof at[0] == "object") {
+ if (typeof at[0] == 'object') {
var ret = [];
for (var i = 0; i < at.length; i++)
ret.push(window['objectToJSON'](at[i], obj));
- return (ret);
+ return ret;
}
for (var i in at) obj = obj[at[i]];
@@ -112,7 +113,7 @@
var newObj = [];
for (var i = 0; i < obj.length; i++)
newObj.push(window['objectToJSON']([], obj[i]));
- return (newObj);
+ return newObj;
}
/* If obj is a non-list-like object */
@@ -121,9 +122,9 @@
/* bug in safari, throws TypeError if the following fields are referenced on a checkbox */
/* https://stackoverflow.com/a/25569117/453261 */
/* https://html.spec.whatwg.org/multipage/input.html#do-not-apply */
- if (obj['type'] == "checkbox" && (i === "selectionDirection" || i === "selectionStart" || i === "selectionEnd"))
+ if (obj['type'] == 'checkbox' && (i === 'selectionDirection' || i === 'selectionStart' || i === 'selectionEnd'))
continue;
- if (typeof obj[i] == "string" || typeof obj[i] == "number" || typeof obj[i] == "boolean")
+ if (typeof obj[i] == 'string' || typeof obj[i] == 'number' || typeof obj[i] == 'boolean')
newObj[i] = obj[i];
}
return newObj;
diff --git a/jsbits/diff.js b/jsbits/diff.js
--- a/jsbits/diff.js
+++ b/jsbits/diff.js
@@ -1,14 +1,15 @@
/* virtual-dom diffing algorithm, applies patches as detected */
+window = typeof window === 'undefined' ? {} : window;
window['diff'] = function diff(currentObj, newObj, parent, doc) {
if (!currentObj && !newObj) return;
else if (!currentObj && newObj) window['createNode'](newObj, parent, doc);
else if (currentObj && !newObj) window['destroyNode'](currentObj, parent);
else {
- if (currentObj.type === "vtext") {
- if (newObj.type === "vnode") window['replaceTextWithElement'](currentObj, newObj, parent, doc);
+ if (currentObj.type === 'vtext') {
+ if (newObj.type === 'vnode') window['replaceTextWithElement'](currentObj, newObj, parent, doc);
else window['diffTextNodes'](currentObj, newObj);
} else {
- if (newObj.type === "vnode") window['diffVNodes'](currentObj, newObj, parent, doc);
+ if (newObj.type === 'vnode') window['diffVNodes'](currentObj, newObj, parent, doc);
else window['replaceElementWithText'](currentObj, newObj, parent, doc);
}
}
@@ -56,7 +57,7 @@
css: null,
children: []
}
- window['diffProps'](c['props'], n['props'], n['domRef'], n['ns'] === "svg");
+ window['diffProps'](c['props'], n['props'], n['domRef'], n['ns'] === 'svg');
window['diffCss'](c['css'], n['css'], n['domRef']);
window['diffChildren'](c['children'], n['children'], n['domRef'], doc);
};
@@ -89,11 +90,11 @@
/* Already on DOM from previous diff, continue */
if (newProp === cProps[c]) continue;
if (isSvg) {
- if (c === "href")
- node.setAttributeNS("http://www.w3.org/1999/xlink", "href", newProp);
+ if (c === 'href')
+ node.setAttributeNS('http://www.w3.org/1999/xlink', 'href', newProp);
else
node.setAttribute(c, newProp);
- } else if (c in node && !(c === "list" || c === "form")) {
+ } else if (c in node && !(c === 'list' || c === 'form')) {
node[c] = newProp;
} else {
node.setAttribute(c, newProp);
@@ -106,11 +107,11 @@
newProp = nProps[n];
/* Only add new properties, skip (continue) if they already exist in current property map */
if (isSvg) {
- if (n === "href")
- node.setAttributeNS("http://www.w3.org/1999/xlink", "href", newProp);
+ if (n === 'href')
+ node.setAttributeNS('http://www.w3.org/1999/xlink', 'href', newProp);
else
node.setAttribute(n, newProp);
- } else if (n in node && !(n === "list" || n === "form")) {
+ } else if (n in node && !(n === 'list' || n === 'form')) {
node[n] = nProps[n];
} else {
node.setAttribute(n, newProp);
@@ -152,10 +153,10 @@
};
window['createElement'] = function createElement(obj, doc) {
- if (obj['ns'] === "svg") {
- obj['domRef'] = doc.createElementNS("http://www.w3.org/2000/svg", obj['tag']);
- } else if (obj['ns'] === "mathml") {
- obj['domRef'] = doc.createElementNS("http://www.w3.org/1998/Math/MathML", obj['tag']);
+ if (obj['ns'] === 'svg') {
+ obj['domRef'] = doc.createElementNS('http://www.w3.org/2000/svg', obj['tag']);
+ } else if (obj['ns'] === 'mathml') {
+ obj['domRef'] = doc.createElementNS('http://www.w3.org/1998/Math/MathML', obj['tag']);
} else {
obj['domRef'] = doc.createElement(obj['tag']);
}
@@ -163,7 +164,7 @@
};
window['createNode'] = function createNode(obj, parent, doc) {
- if (obj.type === "vnode") window['createElement'](obj, doc);
+ if (obj.type === 'vnode') window['createElement'](obj, doc);
else obj['domRef'] = doc.createTextNode(obj['text']);
parent.appendChild(obj['domRef']);
window['callCreated'](obj);
@@ -272,7 +273,7 @@
newFirstIndex++;
}
- /* The "you're screwed" case, nothing aligns, pull the ripcord, do something more fancy
+ /* The 'you're screwed' case, nothing aligns, pull the ripcord, do something more fancy
This can happen when the list is sorted, for example.
-> [ a e c ] <- old children
-> [ b e d ] <- new children
diff --git a/jsbits/isomorphic.js b/jsbits/isomorphic.js
--- a/jsbits/isomorphic.js
+++ b/jsbits/isomorphic.js
@@ -1,4 +1,5 @@
-window['copyDOMIntoVTree'] = function copyDOMIntoVTree(mountPoint, vtree, doc = window.document) {
+window = typeof window === 'undefined' ? {} : window;
+window['copyDOMIntoVTree'] = function copyDOMIntoVTree(mountPoint, vtree, doc) {
var node = mountPoint ? mountPoint.firstChild : doc.body.firstChild;
if (!window['walk'](vtree, node, doc)) {
console.warn('Could not copy DOM into virtual DOM, falling back to diff');
@@ -26,7 +27,7 @@
for (var i = 0; i < vtree.children.length; i++) {
vdomChild = vtree['children'][i];
domChild = node.childNodes[i];
- if (vdomChild.type === "vtext") {
+ if (vdomChild.type === 'vtext') {
if (domChild.nodeType !== Node.TEXT_NODE) return false;
if (vdomChild['text'] === domChild.textContent) {
diff --git a/jsbits/util.js b/jsbits/util.js
--- a/jsbits/util.js
+++ b/jsbits/util.js
@@ -1,3 +1,4 @@
+window = typeof window === 'undefined' ? {} : window;
window['callFocus'] = function callFocus(id) {
setTimeout(function(){
var ele = document.getElementById(id);
diff --git a/miso.cabal b/miso.cabal
--- a/miso.cabal
+++ b/miso.cabal
@@ -1,30 +1,23 @@
name: miso
-version: 1.0.0.0
+version: 1.1.0.0
category: Web, Miso, Data Structures
license: BSD3
license-file: LICENSE
author: David M. Johnson
maintainer: David M. Johnson
homepage: http://github.com/dmjio/miso
-copyright: Copyright (c) 2017-2018 David M. Johnson
+copyright: Copyright (c) 2017-2020 David M. Johnson
bug-reports: https://github.com/dmjio/miso/issues
build-type: Simple
extra-source-files: README.md
cabal-version: >=1.22
synopsis: A tasty Haskell front-end framework
description:
- Miso is a small "isomorphic" Haskell front-end framework featuring a virtual-dom, diffing / patching algorithm, event delegation, event batching, SVG, Server-sent events, Websockets, type-safe servant-style routing and an extensible Subscription-based subsystem. Inspired by Elm, Redux and 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 FFI and therefore has minimal dependencies.
+ Miso is a small, production-ready, "isomorphic" Haskell front-end framework featuring a virtual-dom, recursive diffing / patching algorithm, event delegation, event batching, SVG, Server-sent events, Websockets, type-safe servant-style routing and an extensible Subscription-based subsystem. Inspired by Elm, Redux and 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 FFI and therefore has minimal dependencies.
extra-source-files:
README.md
- examples/mario/imgs/mario.png
-flag examples
- default:
- False
- description:
- Builds Miso's examples
-
flag tests
default:
False
@@ -38,244 +31,17 @@
description:
Compile with JSaddle
-executable todo-mvc
- main-is:
- Main.hs
- if (!impl(ghcjs) && !flag(jsaddle)) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/todo-mvc
- build-depends:
- aeson,
- base < 5,
- containers,
- jsaddle-warp,
- miso,
- transformers
- default-language:
- Haskell2010
-
-executable threejs
- main-is:
- Main.hs
- if !impl(ghcjs) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/three
- build-depends:
- aeson,
- base < 5,
- ghcjs-base,
- containers,
- miso
- default-language:
- Haskell2010
-
-executable file-reader
- main-is:
- Main.hs
- if !impl(ghcjs) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/file-reader
- build-depends:
- aeson,
- base < 5,
- containers,
- ghcjs-base,
- miso
- default-language:
- Haskell2010
-
-executable xhr
- main-is:
- Main.hs
- if !impl(ghcjs) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/xhr
- build-depends:
- aeson,
- base < 5,
- containers,
- ghcjs-base,
- miso
- default-language:
- Haskell2010
-
-executable canvas2d
- main-is:
- Main.hs
- if !impl(ghcjs) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/canvas2d
- build-depends:
- aeson,
- base < 5,
- ghcjs-base,
- miso
- default-language:
- Haskell2010
-
-executable router
- main-is:
- Main.hs
- if (!impl(ghcjs) && !flag(jsaddle)) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/router
- build-depends:
- aeson,
- base < 5,
- containers,
- jsaddle-warp,
- miso,
- servant,
- transformers
- default-language:
- Haskell2010
-
-executable websocket
- main-is:
- Main.hs
- if (!impl(ghcjs) && !flag(jsaddle)) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/websocket
- build-depends:
- aeson,
- base < 5,
- containers,
- jsaddle-warp,
- miso,
- transformers
- default-language:
- Haskell2010
-
-executable mario
- main-is:
- Main.hs
- if (!impl(ghcjs) && !flag(jsaddle)) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/mario
- build-depends:
- base < 5,
- containers,
- miso,
- jsaddle-warp
- if flag(jsaddle) && !impl(ghcjs)
- build-depends:
- wai,
- wai-app-static,
- warp,
- websockets
- default-language:
- Haskell2010
-
-executable svg
- main-is:
- Main.hs
- if !impl(ghcjs) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/svg
- other-modules:
- Touch
- build-depends:
- base < 5,
- containers,
- aeson,
- miso
- default-language:
- Haskell2010
-
-executable compose-update
- main-is:
- Main.hs
- if !impl(ghcjs) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/compose-update
- build-depends:
- base < 5,
- miso
- default-language:
- Haskell2010
-
-executable mathml
- main-is:
- Main.hs
- if !impl(ghcjs) || !flag(examples)
- buildable: False
- else
- ghcjs-options:
- -dedupe
- cpp-options:
- -DGHCJS_BROWSER
- hs-source-dirs:
- examples/mathml
- build-depends:
- base < 5,
- miso
- default-language:
- Haskell2010
+flag ios
+ manual: True
+ default:
+ False
+ description:
+ Cross compile to iOS
executable simple
main-is:
Main.hs
- if (!impl(ghcjs) && !flag(jsaddle)) || !flag(examples)
+ if !impl(ghcjs) && !flag(jsaddle)
buildable: False
else
ghcjs-options:
@@ -288,11 +54,20 @@
aeson,
base < 5,
containers,
- jsaddle-warp,
miso,
transformers
default-language:
Haskell2010
+ if flag(ios)
+ cpp-options:
+ -DIOS
+ ghc-options:
+ -threaded
+ build-depends:
+ jsaddle-wkwebview
+ else
+ build-depends:
+ jsaddle-warp
executable tests
main-is:
@@ -370,11 +145,19 @@
if impl(ghcjs) || flag (jsaddle)
if flag(jsaddle)
build-depends:
- file-embed,
jsaddle
- cpp-options: -DJSADDLE
+ cpp-options:
+ -DJSADDLE
hs-source-dirs:
jsaddle-ffi
+ if flag (ios)
+ cpp-options:
+ -DIOS
+ other-modules:
+ Miso.JSBits
+ else
+ build-depends:
+ file-embed
else
build-depends:
ghcjs-base
diff --git a/src/Miso/Html/Event.hs b/src/Miso/Html/Event.hs
--- a/src/Miso/Html/Event.hs
+++ b/src/Miso/Html/Event.hs
@@ -5,10 +5,9 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module : Miso.Html.Event
diff --git a/src/Miso/WebSocket.hs b/src/Miso/WebSocket.hs
--- a/src/Miso/WebSocket.hs
+++ b/src/Miso/WebSocket.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}