miso-examples (empty) → 1.2.0.0
raw patch · 16 files changed
+1789/−0 lines, 16 filesdep +aesondep +basedep +containerssetup-changedbinary-added
Dependencies added: aeson, base, containers, ghcjs-base, jsaddle, jsaddle-warp, jsaddle-wkwebview, miso, servant, transformers, wai, wai-app-static, warp, websockets
Files
- LICENSE +10/−0
- Setup.hs +2/−0
- canvas2d/Main.hs +95/−0
- compose-update/Main.hs +108/−0
- file-reader/Main.hs +89/−0
- mario/Main.hs +183/−0
- mario/imgs/mario.png binary
- mathml/Main.hs +43/−0
- miso-examples.cabal +313/−0
- router/Main.hs +106/−0
- svg/Main.hs +82/−0
- svg/Touch.hs +44/−0
- three/Main.hs +151/−0
- todo-mvc/Main.hs +331/−0
- websocket/Main.hs +87/−0
- xhr/Main.hs +145/−0
+ LICENSE view
@@ -0,0 +1,10 @@+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:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ canvas2d/Main.hs view
@@ -0,0 +1,95 @@+{-# 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+
+ compose-update/Main.hs view
@@ -0,0 +1,108 @@+{-# 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 "-"]+ ]
+ file-reader/Main.hs view
@@ -0,0 +1,89 @@+{-# 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 ()
+ mario/Main.hs view
@@ -0,0 +1,183 @@+{-# 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++#ifdef IOS+import Language.Javascript.JSaddle.WKWebView as JSaddle++runApp :: JSM () -> IO ()+runApp = JSaddle.run+#else+import qualified Language.Javascript.JSaddle.Warp as JSaddle+#ifdef ghcjs_HOST_OS+runApp :: JSM () -> IO ()+runApp = JSaddle.run 8080++#else+import Network.Wai.Application.Static+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import Network.WebSockets++runApp :: JSM () -> IO ()+runApp f =+ Warp.runSettings (Warp.setPort 8080 (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+#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 = runApp $ 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+ <> ")"
+ mario/imgs/mario.png view
binary file changed (absent → 4869 bytes)
+ mathml/Main.hs view
@@ -0,0 +1,43 @@++-- | Haskell language pragma+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Haskell module declaration+module Main where++-- | Miso framework import+import Miso+import Miso.String+import Miso.Mathml++data Model = Empty deriving Eq++data Action+ = NoOp+ deriving (Show, Eq)++-- | Entry point for a miso application+main :: IO ()+main = startApp App {..}+ where+ initialAction = NoOp -- initial action to be executed on application load+ model = Empty -- initial model+ update = updateModel -- update function+ view = viewModel -- view function+ events = defaultEvents -- default delegated events+ subs = [] -- empty subscription list+ mountPoint = Nothing -- mount point for application (Nothing defaults to 'body')++-- | Updates model, optionally introduces side effects+updateModel :: Action -> Model -> Effect Action Model+updateModel NoOp = noEff++-- | Constructs a virtual DOM from a model+viewModel :: Model -> View Action+viewModel x = nodeMathml "math" [] [+ nodeMathml "msup" [] [+ nodeMathml "mi" [] [text "x"]+ , nodeMathml "mn" [] [text "2"]+ ]+ ]
+ miso-examples.cabal view
@@ -0,0 +1,313 @@+name: miso-examples+version: 1.2.0.0+category: Web, Miso, Data Structures+author: David M. Johnson <djohnson.m@gmail.com>+maintainer: David M. Johnson <djohnson.m@gmail.com>+homepage: http://github.com/dmjio/miso+copyright: Copyright (c) 2017-2020 David M. Johnson+bug-reports: https://github.com/dmjio/miso/issues+build-type: Simple+cabal-version: >=1.22+synopsis: A tasty Haskell front-end framework+description: Examples for miso+license: BSD3+license-file: LICENSE++extra-source-files:+ mario/imgs/mario.png++flag jsaddle+ manual: True+ default:+ False+ description:+ Compile with JSaddle++flag ios+ manual: True+ default:+ False+ description:+ Cross compile to iOS++executable todo-mvc+ main-is:+ Main.hs+ if !impl(ghcjs) && !flag(jsaddle)+ buildable: False+ else+ if flag(jsaddle)+ build-depends:+ jsaddle+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ todo-mvc+ build-depends:+ aeson,+ base < 5,+ containers,+ miso,+ transformers+ default-language:+ Haskell2010+ if flag(ios)+ cpp-options:+ -DIOS+ ghc-options:+ -threaded+ build-depends:+ jsaddle-wkwebview+ else+ build-depends:+ jsaddle-warp++executable threejs+ main-is:+ Main.hs+ if !impl(ghcjs)+ buildable: False+ else+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ three+ build-depends:+ aeson,+ base < 5,+ ghcjs-base,+ containers,+ miso+ default-language:+ Haskell2010++executable file-reader+ main-is:+ Main.hs+ if !impl(ghcjs)+ buildable: False+ else+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ file-reader+ build-depends:+ aeson,+ base < 5,+ containers,+ ghcjs-base,+ miso+ default-language:+ Haskell2010++executable xhr+ main-is:+ Main.hs+ if !impl(ghcjs)+ buildable: False+ else+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ xhr+ build-depends:+ aeson,+ base < 5,+ containers,+ ghcjs-base,+ miso+ default-language:+ Haskell2010++executable canvas2d+ main-is:+ Main.hs+ if !impl(ghcjs)+ buildable: False+ else+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ canvas2d+ build-depends:+ aeson,+ base < 5,+ ghcjs-base,+ miso+ default-language:+ Haskell2010++executable router+ main-is:+ Main.hs+ if !impl(ghcjs) && !flag(jsaddle)+ buildable: False+ else+ if flag(jsaddle)+ build-depends:+ jsaddle+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ router+ build-depends:+ aeson,+ base < 5,+ containers,+ miso,+ servant,+ transformers+ default-language:+ Haskell2010+ if flag(ios)+ cpp-options:+ -DIOS+ ghc-options:+ -threaded+ build-depends:+ jsaddle-wkwebview+ else+ build-depends:+ jsaddle-warp++executable websocket+ main-is:+ Main.hs+ if !impl(ghcjs) && !flag(jsaddle)+ buildable: False+ else+ if flag(jsaddle)+ build-depends:+ jsaddle+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ websocket+ build-depends:+ aeson,+ base < 5,+ containers,+ miso,+ transformers+ default-language:+ Haskell2010+ if flag(ios)+ cpp-options:+ -DIOS+ ghc-options:+ -threaded+ build-depends:+ jsaddle-wkwebview+ else+ build-depends:+ jsaddle-warp++executable mario+ main-is:+ Main.hs+ if !impl(ghcjs) && !flag(jsaddle)+ buildable: False+ else+ if flag(jsaddle)+ build-depends:+ jsaddle+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ mario+ build-depends:+ base < 5,+ containers,+ miso+ if flag(jsaddle) && !impl(ghcjs) && !flag(ios)+ build-depends:+ wai,+ wai-app-static,+ warp,+ websockets+ if flag(ios) && !impl(ghcjs)+ cpp-options:+ -DIOS+ ghc-options:+ -threaded+ build-depends:+ jsaddle-wkwebview+ if !flag(ios)+ build-depends:+ jsaddle-warp+ default-language:+ Haskell2010++executable svg+ main-is:+ Main.hs+ if !impl(ghcjs)+ buildable: False+ else+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ svg+ other-modules:+ Touch+ build-depends:+ base < 5,+ containers,+ aeson,+ miso+ default-language:+ Haskell2010++executable compose-update+ main-is:+ Main.hs+ if !impl(ghcjs)+ buildable: False+ else+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ compose-update+ build-depends:+ base < 5,+ miso+ default-language:+ Haskell2010++executable mathml+ main-is:+ Main.hs+ if !impl(ghcjs)+ buildable: False+ else+ ghcjs-options:+ -dedupe+ cpp-options:+ -DGHCJS_BROWSER+ hs-source-dirs:+ mathml+ build-depends:+ base < 5,+ miso+ default-language:+ Haskell2010
+ router/Main.hs view
@@ -0,0 +1,106 @@+{-# 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 Miso++#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++-- | 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 =+ runApp $ 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+
+ svg/Main.hs view
@@ -0,0 +1,82 @@+{-# 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")+ ]
+ svg/Touch.hs view
@@ -0,0 +1,44 @@+{-# 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
+ three/Main.hs view
@@ -0,0 +1,151 @@+{-# 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 ()
+ todo-mvc/Main.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE CPP #-}+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++#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++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 = runApp $ 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" ]+ ]+ ]
+ websocket/Main.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE CPP #-}+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++#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++main :: IO ()+main = runApp $ 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)
+ xhr/Main.hs view
@@ -0,0 +1,145 @@+{-# 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+ }+