diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,10 @@ +Copyright (c) 2016-2017, 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +:ramen:
miso
+====================== +![Hackage](https://img.shields.io/hackage/v/miso.svg) +![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-green.svg) +![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg) + +[![Slack Status](https://haskell-miso-slack.herokuapp.com/badge.svg)](https://haskell-miso-slack.herokuapp.com) +![Build Status](https://api.travis-ci.org/dmjio/miso.svg?branch=master) + +**Miso** is a small [isomorphic](http://nerds.airbnb.com/isomorphic-javascript-future-web-apps/) [Haskell](https://www.haskell.org/) front-end framework featuring a virtual-dom, diffing / patching algorithm, event delegation, event batching, SVG, Server-sent events, Websockets, and an extensible Subscription-based subsystem. Inspired by [Elm](http://elm-lang.org/), [Redux](http://redux.js.org/) and [Bobril](http://github.com/bobris/bobril). `IO` and other effects (like `XHR`) can be introduced into the system via the `Effect` data type. *Miso* makes heavy use of the [GHCJS](https://github.com/ghcjs/ghcjs) FFI and therefore has minimal dependencies. + +## Examples + - TodoMVC + - [Link](http://miso-todomvc.bitballoon.com/) + - [Source](https://github.com/dmjio/miso/blob/master/examples/todo-mvc/Main.hs) + - Mario + - [Link](https://s3.amazonaws.com/aws-website-mario-5u38b/index.html) + - [Source](https://github.com/dmjio/miso/blob/master/examples/mario/Main.hs) + +## Documentation + - [GHCJS](https://d10z4r8eai3cm9.cloudfront.net/) + - [GHC](https://d1f745wtmyhj66.cloudfront.net/) + +## Getting Started +```haskell +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Miso + +type Model = Int + +main :: IO () +main = startApp App {..} + where + model = 0 + update = updateModel + view = viewModel + events = defaultEvents + subs = [] + +updateModel :: Action -> Model -> Effect Model Action +updateModel AddOne m = noEff (m + 1) +updateModel SubtractOne m = noEff (m - 1) + +data Action + = AddOne + | SubtractOne + deriving (Show, Eq) + +viewModel :: Int -> View Action +viewModel x = div_ [] [ + button_ [ onClick AddOne ] [ text "+" ] + , text (show x) + , button_ [ onClick SubtractOne ] [ text "-" ] + ] + ``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/mario/Main.hs b/examples/mario/Main.hs new file mode 100644 --- /dev/null +++ b/examples/mario/Main.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +module Main where + +import Data.Function +import qualified Data.Map as M +import Data.Monoid + +import Miso +import Miso.String + +data Action + = GetArrows Arrows + | Time Double + | WindowCoords (Int,Int) + +foreign import javascript unsafe "$r = performance.now();" + now :: IO Double + +main :: IO () +main = do + time <- now + let m = mario { time = time } + startApp App { model = m, ..} + where + update = updateMario + view = display + events = defaultEvents + subs = [ arrowsSub GetArrows + , windowSub WindowCoords + ] + +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 Model Action +updateMario (GetArrows arrs) m = step 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 = step newModel + where + newModel = m { window = coords } + +step :: Model -> Effect Model Action +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 + verb = if | y > 0 -> "jump" + | vx /= 0 -> "walk" + | otherwise -> "stand" + d = case dir of + L -> "left" + R -> "right" + src = "imgs/"<> verb <> "/" <> d <> ".gif" + groundY = 62 - (fromIntegral (fst window) / 2) + marioImage = + div_ [ height_ $ pack (show h) + , height_ $ pack (show w) + ] [ img_ [ height_ "37" + , width_ "37" + , src_ src + , style_ (marioStyle m groundY) + ] [] ] + +marioStyle :: Model -> Double -> M.Map MisoString MisoString +marioStyle Model {..} gy = + M.fromList [ ("transform", matrix x $ abs (y + gy) ) + , ("display", "block") + ] + +matrix :: Double -> Double -> MisoString +matrix x y = + "matrix(1,0,0,1," + <> pack (show x) + <> "," + <> pack (show y) + <> ")" diff --git a/examples/mario/imgs/jump/left.gif b/examples/mario/imgs/jump/left.gif new file mode 100644 Binary files /dev/null and b/examples/mario/imgs/jump/left.gif differ diff --git a/examples/mario/imgs/jump/right.gif b/examples/mario/imgs/jump/right.gif new file mode 100644 Binary files /dev/null and b/examples/mario/imgs/jump/right.gif differ diff --git a/examples/mario/imgs/stand/left.gif b/examples/mario/imgs/stand/left.gif new file mode 100644 Binary files /dev/null and b/examples/mario/imgs/stand/left.gif differ diff --git a/examples/mario/imgs/stand/right.gif b/examples/mario/imgs/stand/right.gif new file mode 100644 Binary files /dev/null and b/examples/mario/imgs/stand/right.gif differ diff --git a/examples/mario/imgs/walk/left.gif b/examples/mario/imgs/walk/left.gif new file mode 100644 Binary files /dev/null and b/examples/mario/imgs/walk/left.gif differ diff --git a/examples/mario/imgs/walk/right.gif b/examples/mario/imgs/walk/right.gif new file mode 100644 Binary files /dev/null and b/examples/mario/imgs/walk/right.gif differ diff --git a/examples/todo-mvc/Main.hs b/examples/todo-mvc/Main.hs new file mode 100644 --- /dev/null +++ b/examples/todo-mvc/Main.hs @@ -0,0 +1,312 @@ +{-# 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 + +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 = startApp App{..} + where + model = emptyModel + update = updateModel + view = viewModel + events = defaultEvents + subs = [] + +updateModel :: Msg -> Model -> Effect Model Msg +updateModel NoOp m = noEff m +updateModel (CurrentTime n) m = + m <# do 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 = + 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 + ] + +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.pack (show 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_ (bool "" "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.pack (show 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.pack (show 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/todo-mvc/index.html b/examples/todo-mvc/index.html new file mode 100644 --- /dev/null +++ b/examples/todo-mvc/index.html @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE RecordWildCards #-} +module Main where + +import Miso + +type Model = Int + +main :: IO () +main = startApp App {..} + where + model = 0 + update = updateModel + view = viewModel + events = defaultEvents + subs = [] + +updateModel :: Action -> Model -> Effect Model Action +updateModel AddOne m = noEff (m + 1) +updateModel SubtractOne m = noEff (m - 1) + +data Action + = AddOne + | SubtractOne + deriving (Show, Eq) + +viewModel :: Int -> View Action +viewModel x = div_ [] [ + button_ [ onClick AddOne ] [ text "+" ] + , text (show x) + , button_ [ onClick SubtractOne ] [ text "-" ] + ] diff --git a/ghc-src/Miso/Html/Internal.hs b/ghc-src/Miso/Html/Internal.hs new file mode 100644 --- /dev/null +++ b/ghc-src/Miso/Html/Internal.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Html.Internal +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Html.Internal ( + -- * Core types and interface + VTree (..) + , View (..) + , ToView (..) + , Attribute (..) + -- * Smart `View` constructors + , node + , text + -- * Key patch internals + , Key (..) + , ToKey (..) + -- * Namespace + , NS (..) + -- * Setting properties on virtual DOM nodes + , prop + -- * Setting CSS + , style_ + -- * Handling events + , on + , onWithOptions + -- * String + , module Miso.String + ) where + +import Data.Aeson +import qualified Data.Map as M +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Lucid as L +import qualified Lucid.Base as L +import Miso.String hiding (map) +import Miso.Event + +-- | Virtual DOM implemented as a Rose `Vector`. +-- Used for diffing, patching and event delegation. +-- Not meant to be constructed directly, see `View` instead. +data VTree model where + VNode :: { vType :: Text -- ^ Element type (i.e. "div", "a", "p") + , vNs :: NS -- ^ HTML or SVG + , vProps :: Props -- ^ Fields present on DOM Node + , vCss :: CSS -- ^ Styles + , vKey :: Maybe Key -- ^ Key used for child swap patch + , vChildren :: V.Vector (VTree model) -- ^ Child nodes + } -> VTree model + VText :: { vText :: Text -- ^ TextNode content + } -> VTree model + +instance Show (VTree model) where + show = show . L.toHtml + +-- | Converting `VTree` to Lucid's `L.Html` +instance L.ToHtml (VTree model) where + toHtmlRaw = L.toHtml + toHtml (VText x) = L.toHtml x + toHtml VNode{..} = + let ele = L.makeElement (toTag vType) kids + in L.with ele as + where + Props xs = vProps + as = [ L.makeAttribute k v' + | (k,v) <- M.toList xs + , let v' = toHtmlFromJSON v + ] + toTag = T.toLower + kids = foldMap L.toHtml vChildren + +-- | Helper for turning JSON into Text +-- Object, Array and Null are kind of non-sensical here +toHtmlFromJSON :: Value -> Text +toHtmlFromJSON (String t) = t +toHtmlFromJSON (Number t) = pack (show t) +toHtmlFromJSON (Bool b) = if b then "true" else "false" +toHtmlFromJSON Null = "null" +toHtmlFromJSON (Object o) = pack (show o) +toHtmlFromJSON (Array a) = pack (show a) + +-- | Core type for constructing a `VTree`, use this instead of `VTree` directly. +newtype View model = View { runView :: VTree model } + +-- | Convenience class for using View +class ToView v where toView :: v -> View model + +-- | Show `View` +instance Show (View model) where + show (View xs) = show xs + +-- | Converting `View` to Lucid's `L.Html` +instance L.ToHtml (View model) where + toHtmlRaw = L.toHtml + toHtml (View xs) = L.toHtml xs + +-- | Namespace for element creation +data NS + = HTML -- ^ HTML Namespace + | SVG -- ^ SVG Namespace + deriving (Show, Eq) + +-- | `VNode` creation +node :: NS -> MisoString -> Maybe Key -> [Attribute model] -> [View model] -> View model +node vNs vType vKey as xs = + let vProps = Props $ M.fromList [ (k,v) | P k v <- as ] + vCss = CSS $ M.fromList [ (k,v) | C k v <- as ] + vChildren = V.fromList $ map runView xs + in View VNode {..} + +-- | `VText` creation +text :: ToMisoString str => str -> View model +text x = View $ VText (toMisoString x) + +-- | Key for specific children patch +newtype Key = Key MisoString + deriving (Show, Eq, Ord) + +-- | Convert type into Key, ensure `Key` is unique +class ToKey key where toKey :: key -> Key +-- | Identity instance +instance ToKey Key where toKey = id +-- | Convert `Text` to `Key` +instance ToKey MisoString where toKey = Key +-- | Convert `String` to `Key` +instance ToKey String where toKey = Key . T.pack +-- | Convert `Int` to `Key` +instance ToKey Int where toKey = Key . T.pack . show +-- | Convert `Double` to `Key` +instance ToKey Double where toKey = Key . T.pack . show +-- | Convert `Float` to `Key` +instance ToKey Float where toKey = Key . T.pack . show +-- | Convert `Word` to `Key` +instance ToKey Word where toKey = Key . T.pack . show + +-- | Fields that a DOM node contains +newtype Props = Props (M.Map MisoString Value) + +-- | Individual CSS property diffing +newtype CSS = CSS (M.Map MisoString MisoString) + +-- | `View` Attributes to annotate DOM, converted into `Events`, `Props`, `Attrs` and `CSS` +data Attribute model + = C MisoString MisoString + | P MisoString Value + | E () + +-- | DMJ: this used to get set on preventDefault on Options... if options are dynamic now what +-- | Useful for `drop` events +newtype AllowDrop = AllowDrop Bool + deriving (Show, Eq) + +-- | Constructs a property on a `VNode`, used to set fields on a DOM Node +prop :: ToJSON a => MisoString -> a -> Attribute model +prop k v = P k (toJSON v) + +-- | For defining delegated events +-- +-- > let clickHandler = on "click" emptyDecoder $ \() -> Action +-- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ] +-- +on :: MisoString + -> Decoder r + -> (r -> action) + -> Attribute action +on _ _ _ = E () + +-- | For defining delegated events with options +-- +-- > let clickHandler = on defaultOptions "click" emptyDecoder $ \() -> Action +-- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ] +-- +onWithOptions + :: Options + -> MisoString + -> Decoder r + -> (r -> action) + -> Attribute action +onWithOptions _ _ _ _ = E () + +-- | Constructs `CSS` for a DOM Element +-- +-- > import qualified Data.Map as M +-- > div_ [ style_ $ M.singleton "background" "red" ] [ ] +-- +-- +-- +style_ :: M.Map MisoString MisoString -> Attribute action +style_ = C "style" . M.foldrWithKey go mempty + where + go :: MisoString -> MisoString -> MisoString -> MisoString + go k v xs = mconcat [ k, ":", v, ";" ] <> xs diff --git a/ghc-src/Miso/String.hs b/ghc-src/Miso/String.hs new file mode 100644 --- /dev/null +++ b/ghc-src/Miso/String.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.String +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.String + ( ToMisoString (..) + , MisoString + , module Data.Text + ) where + +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Text +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT + +-- | String type swappable based on compiler +type MisoString = Text + +-- | Convenience class for creating `MisoString` from other string-like types +class ToMisoString str where toMisoString :: str -> MisoString +instance ToMisoString MisoString where toMisoString = id +instance ToMisoString String where toMisoString = T.pack +instance ToMisoString LT.Text where toMisoString = LT.toStrict +instance ToMisoString B.ByteString where toMisoString = toMisoString . T.decodeUtf8 +instance ToMisoString BL.ByteString where toMisoString = toMisoString . LT.decodeUtf8 +instance ToMisoString Value where toMisoString = toMisoString . encode diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso + ( startApp + , App (..) + , module Miso.Effect + , module Miso.Event + , module Miso.Html + , module Miso.Subscription + , module Miso.Types + ) where + +import Control.Concurrent +import Control.Monad +import Data.IORef +import Data.List +import Data.Sequence ((|>)) +import qualified Data.Sequence as S +import JavaScript.Web.AnimationFrame + +import Miso.Concurrent +import Miso.Diff +import Miso.Effect +import Miso.Event +import Miso.Html +import Miso.Subscription +import Miso.Types +import Miso.Delegate + +-- | Runs a miso application +startApp :: Eq model => App model action -> IO () +startApp App {..} = do + let initialView = view model + -- init empty Model + modelRef <- newIORef model + -- init empty actions + actionsMVar <- newMVar S.empty + -- init Notifier + Notify {..} <- newNotify + -- init EventWriter + EventWriter {..} <- newEventWriter notify + -- init Subs + forM_ subs $ \sub -> + sub (readIORef modelRef) writeEvent + -- init event application thread + void . forkIO . forever $ do + action <- getEvent + modifyMVar_ actionsMVar $! \actions -> + pure (actions |> action) + -- Hack to get around `BlockedIndefinitelyOnMVar` exception + -- that occurs when no event handlers are present on a template + -- and `notify` is no longer in scope + void . forkIO . forever $ threadDelay (1000000 * 86400) >> notify + -- Create virtual dom, perform initial diff + initialVTree <- flip runView writeEvent initialView + Nothing `diff` (Just initialVTree) + viewRef <- newIORef initialVTree + -- Begin listening for events in the virtual dom + delegator viewRef events + -- Program loop, blocking on SkipChan + forever $ wait >> do + -- Apply actions to model + shouldDraw <- + modifyMVar actionsMVar $! \actions -> do + (shouldDraw, effects) <- atomicModifyIORef' modelRef $! \oldModel -> + let (newModel, effects) = + foldl' (foldEffects writeEvent update) + (oldModel, pure ()) actions + in (newModel, (oldModel /= newModel, effects)) + effects + pure (S.empty, shouldDraw) + when shouldDraw $ do + newVTree <- + flip runView writeEvent + =<< view <$> readIORef modelRef + oldVTree <- readIORef viewRef + void $ waitForAnimationFrame + Just oldVTree `diff` Just newVTree + atomicWriteIORef viewRef newVTree + +foldEffects + :: (action -> IO ()) + -> (action -> model -> Effect model action) + -> (model, IO ()) -> action -> (model, IO ()) +foldEffects sink update = \(model, as) action -> + case update action model of + NoEffect newModel -> (newModel, as) + Effect newModel eff -> (newModel, newAs) + where + newAs = as >> do void . forkIO . sink =<< eff diff --git a/ghcjs-src/Miso/Delegate.hs b/ghcjs-src/Miso/Delegate.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Delegate.hs @@ -0,0 +1,23 @@ +module Miso.Delegate where + +import Data.IORef +import qualified Data.Map as M +import Miso.Html.Internal +import Miso.String +import Miso.FFI +import qualified JavaScript.Object.Internal as OI +import GHCJS.Foreign.Callback +import GHCJS.Marshal + +-- | Entry point for event delegation +delegator + :: IORef VTree + -> M.Map MisoString Bool + -> IO () +delegator vtreeRef es = do + evts <- toJSVal (M.toList es) + getVTreeFromRef <- syncCallback' $ do + VTree (OI.Object val) <- readIORef vtreeRef + pure val + delegateEvent evts getVTreeFromRef + diff --git a/ghcjs-src/Miso/Diff.hs b/ghcjs-src/Miso/Diff.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Diff.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Diff +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Diff ( diff ) where + +import GHCJS.Foreign.Internal hiding (Object) +import GHCJS.Types +import JavaScript.Object +import JavaScript.Object.Internal +import Miso.Html.Internal + +-- | Entry point for diffing / patching algorithm +diff :: Maybe VTree -> Maybe VTree -> IO () +diff current new = do + body <- getBody + case (current, new) of + (Nothing, Nothing) -> pure () + (Just (VTree current'), Just (VTree new')) -> do + diff' current' new' body + (Nothing, Just (VTree new')) -> do + diff' (Object jsNull) new' body + (Just (VTree current'), Nothing) -> do + diff' current' (Object jsNull) body + +foreign import javascript unsafe "$r = document.body;" + getBody :: IO JSVal + +foreign import javascript unsafe "diff($1, $2, $3);" + diff' + :: Object -- ^ current object + -> Object -- ^ new object + -> JSVal -- ^ parent node + -> IO () diff --git a/ghcjs-src/Miso/Effect.hs b/ghcjs-src/Miso/Effect.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Effect.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Effect +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Effect ( + module Miso.Effect.Storage +, module Miso.Effect.XHR +, module Miso.Effect.DOM +, Effect (..) +, noEff +, (<#) +) where + +import Miso.Effect.Storage +import Miso.Effect.XHR +import Miso.Effect.DOM + +-- | Capturing effects in update actions +data Effect model action + = NoEffect model + | Effect model (IO action) + +-- | `NoEffect` smart constructor +noEff :: model -> Effect model action +noEff = NoEffect + +-- | `Effect` smart constructor +(<#) :: model -> IO action -> Effect model action +(<#) = Effect diff --git a/ghcjs-src/Miso/Effect/DOM.hs b/ghcjs-src/Miso/Effect/DOM.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Effect/DOM.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Effect.DOM +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Effect.DOM + ( focus + , blur + , alert + ) where + +import Miso.String + +-- | Fails silently if no element found +-- Analgous to `document.getElementById(id).focus()` +foreign import javascript unsafe "callFocus($1);" + focus :: MisoString -> IO () + +-- | Fails silently if no element found +-- Analgous to `document.getElementById(id).blur()` +foreign import javascript unsafe "callBlur($1);" + blur :: MisoString -> IO () + +-- | Calls alert() function +foreign import javascript unsafe "alert($1);" + alert :: MisoString -> IO () diff --git a/ghcjs-src/Miso/Effect/Storage.hs b/ghcjs-src/Miso/Effect/Storage.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Effect/Storage.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Effect.Storage +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Effect.Storage + ( -- * Local and Session Storage APIs + --- * Get storage + getLocalStorage + , getSessionStorage + --- * Set storage + , setLocalStorage + , setSessionStorage + --- * Remove storage + , removeLocalStorage + , removeSessionStorage + --- * Clear storage + , clearLocalStorage + , clearSessionStorage + --- * Get storage length + , localStorageLength + , sessionStorageLength + ) where + +import Data.Aeson hiding (Object, String) +import Data.JSString +import GHCJS.Nullable +import GHCJS.Types + +import Miso.FFI + +-- | Retrieve local storage +getLocalStorage, getSessionStorage :: + FromJSON model => JSString -> IO (Either String model) + +-- | Helper for retrieving either local or session storage +getStorageCommon + :: FromJSON b => (t -> IO (Maybe JSVal)) -> t -> IO (Either String b) +getStorageCommon f key = do + result :: Maybe JSVal <- f key + case result of + Nothing -> pure $ Left "Not Found" + Just v -> do + r <- parse v + pure $ case fromJSON r of + Success x -> Right x + Error y -> Left y + +-- | Retrieve session storage +getSessionStorage = + getStorageCommon $ \t -> do + r <- getItemSS t + pure (nullableToMaybe r) +-- | Retrieve local storage +getLocalStorage = getStorageCommon $ \t -> do + r <- getItemLS t + pure (nullableToMaybe r) + +setLocalStorage, setSessionStorage :: + ToJSON model => JSString -> model -> IO () +-- | Set local storage +setLocalStorage key model = + setItemLS key =<< stringify model +-- | Set session storage +setSessionStorage key model = + setItemSS key =<< stringify model + +foreign import javascript unsafe "$r = window.localStorage.getItem($1);" + getItemLS :: JSString -> IO (Nullable JSVal) + +foreign import javascript unsafe "$r = window.sessionStorage.getItem($1);" + getItemSS :: JSString -> IO (Nullable JSVal) + +-- | Removes item from local storage by key name +foreign import javascript unsafe "window.localStorage.removeItem($1);" + removeLocalStorage :: JSString -> IO () + +-- | Removes item from session storage by key name +foreign import javascript unsafe "window.sessionStorage.removeItem($1);" + removeSessionStorage :: JSString -> IO () + +foreign import javascript unsafe "window.localStorage.setItem($1, $2);" + setItemLS :: JSString -> JSString -> IO () + +foreign import javascript unsafe "window.sessionStorage.setItem($1, $2);" + setItemSS :: JSString -> JSString -> IO () + +-- | Retrieves the number of items in local storage +foreign import javascript unsafe "$r = window.localStorage.length;" + localStorageLength :: IO Int + +-- | Retrieves the number of items in session storage +foreign import javascript unsafe "$r = window.sessionStorage.length;" + sessionStorageLength :: IO Int + +-- | Clears local storage +foreign import javascript unsafe "window.localStorage.clear();" + clearLocalStorage :: IO () + +-- | Clears session storage +foreign import javascript unsafe "window.sessionStorage.clear();" + clearSessionStorage :: IO () diff --git a/ghcjs-src/Miso/Effect/XHR.hs b/ghcjs-src/Miso/Effect/XHR.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Effect/XHR.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Effect.XHR +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Effect.XHR where + +import Data.Proxy +import GHC.TypeLits +import JavaScript.Web.XMLHttpRequest +import Miso.String +import Servant.API + +type Path = String + +-- | Still a WIP, use ghcjs-base XHR for now, or other + +-- | Intermediate type for accumulation +data RouteInfo + = RouteInfo { riPath :: String + , riMethod :: Method + } deriving (Show, Eq) + +-- | Class for `XHR` +class HasXHR api where + type XHR api :: * + xhrWithRoute + :: Proxy api + -> RouteInfo + -> XHR api + +type Result a = Either MisoString a + +-- | Verb +instance {-# OVERLAPPABLE #-} + ( MimeUnrender ct a + , ReflectMethod method + , cts' ~ (ct ': cts) + ) => HasXHR (Verb method status cts' a) where + type XHR (Verb method status cts' a) = Result a + xhrWithRoute Proxy _ = undefined + -- snd <$> performRequestCT (Proxy :: Proxy ct) method req + -- where method = reflectMethod (Proxy :: Proxy method) + +-- | Verb NoContent +instance {-# OVERLAPPING #-} + ReflectMethod method => HasXHR (Verb method status cts NoContent) where + type XHR (Verb method status cts NoContent) = Result NoContent + xhrWithRoute Proxy _ = undefined + -- performRequestNoBody method req >> return NoContent + -- where method = reflectMethod (Proxy :: Proxy method) + +-- | Verb, with HEADERS +instance {-# OVERLAPPING #-} + ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasXHR (Verb method status cts' (Headers ls a)) where + type XHR (Verb method status cts' (Headers ls a)) = Result (Headers ls a) + xhrWithRoute Proxy _ = undefined + -- let method = reflectMethod (Proxy :: Proxy method) + -- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req + -- return $ Headers { getResponse = resp + -- , getHeadersHList = buildHeadersTo hdrs + -- } + + +instance {-# OVERLAPPING #-} + ( BuildHeadersTo ls, ReflectMethod method + ) => HasXHR (Verb method status cts (Headers ls NoContent)) where + type XHR (Verb method status cts (Headers ls NoContent)) = Result (Headers ls NoContent) + xhrWithRoute Proxy _ = undefined + -- let method = reflectMethod (Proxy :: Proxy method) + -- hdrs <- performRequestNoBody method req + -- return $ Headers { getResponse = NoContent + -- , getHeadersHList = buildHeadersTo hdrs + -- } + +-- | Capture +instance (ToHttpApiData a, HasXHR api, KnownSymbol sym) => HasXHR (Capture sym a :> api) where + type XHR (Capture sym a :> api) = a -> XHR api + xhrWithRoute Proxy _ (_ :: a) = undefined + +-- | CaptureAll +instance (KnownSymbol capture, ToHttpApiData a, HasXHR sublayout) + => HasXHR (CaptureAll capture a :> sublayout) where + type XHR (CaptureAll capture a :> sublayout) = [a] -> XHR sublayout + xhrWithRoute Proxy _ _ = undefined + -- xhrWithRoute (Proxy :: Proxy sublayout) + -- (foldl' (flip appendToPath) req ps) + +-- | Path (done) +instance (HasXHR api, KnownSymbol sym) => HasXHR (sym :> api) where + type XHR (sym :> api) = XHR api + xhrWithRoute Proxy req = xhrWithRoute (Proxy :: Proxy api) newReq + where + newReq = req { + riPath = riPath req ++ "/" ++ symbolVal (Proxy :: Proxy sym) + } + +-- | Raw (not supported) +-- instance HasXHR Raw where +-- type XHR Raw = XHR (Response MisoString) +-- xhrWithRoute Proxy _ = putStrLn "Raw is not supported" + +-- | Alternate +instance (HasXHR left, HasXHR right) => HasXHR (left :<|> right) where + type XHR (left :<|> right) = XHR left :<|> XHR right + xhrWithRoute Proxy s = + xhrWithRoute (Proxy :: Proxy left) s :<|> + xhrWithRoute (Proxy :: Proxy right) s + +-- | Header +instance (ToHttpApiData a, HasXHR api, KnownSymbol sym) => HasXHR (Header sym a :> api) where + type XHR (Header sym a :> api) = Maybe a -> XHR api + xhrWithRoute Proxy _ = undefined + +-- | HttpVersion +instance HasXHR api => HasXHR (HttpVersion :> api) where + type XHR (HttpVersion :> api) = XHR api + xhrWithRoute Proxy = xhrWithRoute (Proxy :: Proxy api) + +-- | Query param +instance (KnownSymbol sym, ToHttpApiData a, HasXHR api) => HasXHR (QueryParam sym a :> api) where + type XHR (QueryParam sym a :> api) = Maybe a -> XHR api + xhrWithRoute Proxy _ _ = undefined + +-- | Query param(s) +instance (KnownSymbol sym, ToHttpApiData a, HasXHR api) => HasXHR (QueryParams sym a :> api) where + type XHR (QueryParams sym a :> api) = [a] -> XHR api + xhrWithRoute Proxy _ _ = undefined + +-- | Query flag +instance (KnownSymbol sym, HasXHR api) => HasXHR (QueryFlag sym :> api) where + type XHR (QueryFlag sym :> api) = Bool -> XHR api + xhrWithRoute Proxy _ _ = undefined + +-- | Request Body +instance (MimeRender ct a, HasXHR api) => HasXHR (ReqBody (ct ': cts) a :> api) where + type XHR (ReqBody (ct ': cts) a :> api) = a -> XHR api + xhrWithRoute Proxy _ _ = undefined + +-- | Remote host (done) +instance HasXHR api => HasXHR (RemoteHost :> api) where + type XHR (RemoteHost :> api) = XHR api + xhrWithRoute Proxy req = xhrWithRoute (Proxy :: Proxy api) req + +-- | IsSecure host (done) +instance HasXHR api => HasXHR (IsSecure :> api) where + type XHR (IsSecure :> api) = XHR api + xhrWithRoute Proxy req = xhrWithRoute (Proxy :: Proxy api) req + +-- | WithNamedContext (done) +instance HasXHR api => HasXHR (WithNamedContext :> api) where + type XHR (WithNamedContext :> api) = XHR api + xhrWithRoute Proxy req = xhrWithRoute (Proxy :: Proxy api) req + +-- | Vault (done) +instance HasXHR api => HasXHR (Vault :> api) where + type XHR (Vault :> api) = XHR api + xhrWithRoute Proxy req = xhrWithRoute (Proxy :: Proxy api) req + +-- | BasicAuth +instance HasXHR api => HasXHR (BasicAuth realm usr :> api) where + type XHR (BasicAuth realm usr :> api) = BasicAuthData -> XHR api + xhrWithRoute Proxy _ _ = undefined + +-- | Can't find AuthenticateReq +-- instance HasXHR api => HasXHR (AuthProtect tag :> api) where +-- type XHR (AuthProtect tag :> api) = AuthenticateReq (AuthProtect tag) -> XHR api +-- xhrWithRoute Proxy req (AuthenticateReq (val,func)) = +-- xhrWithRoute (Proxy :: Proxy api) (func val req) + + + + + +-- xhrWithRoute (Proxy :: Proxy api) +-- (let ctProxy = Proxy :: Proxy ct +-- in setReqBodyLBS (mimeRender ctProxy body) +-- -- We use first contentType from the Accept list +-- (contentType ctProxy) +-- req +-- ) + + +-- xhrJSON :: FromJSON json => Request -> IO (Response json) +-- xhrJSON req = do +-- r <- xhr' req +-- case contents r of +-- Nothing -> pure r { contents = Just Null } +-- Just jsstring -> do +-- x <- parse (unsafeCoerce jsstring) +-- pure $ r { contents = Just x } + + +-- import Data.JSString +-- import GHCJS.Foreign.Callback +-- import GHCJS.Nullable +-- import GHCJS.Types +-- import Prelude hiding (lines) + +-- data ReadyState +-- = UNSENT +-- -- ^ XHR has been created. open() not called yet. +-- | OPENED +-- -- ^ open() has been called. +-- | HEADERS_RECEIVED +-- -- ^ send() has been called, and headers and status are available. +-- | LOADING +-- -- ^ Downloading; responseText holds partial data. +-- | DONE +-- -- ^ The operation is complete. +-- deriving (Show, Eq, Enum) + +-- data ResponseType +-- = DOMStringType +-- | ArrayBufferType +-- | BlobType +-- | DocumentType +-- | JSONType +-- | UnknownXHRType +-- deriving (Show, Eq) + +-- newtype Document = Document JSVal +-- newtype XHR = XHR JSVal + +-- foreign import javascript unsafe "$r = new XMLHttpRequest();" +-- newXHR :: IO XHR + +-- foreign import javascript unsafe "$1.abort();" +-- abort :: XHR -> IO () + +-- foreign import javascript unsafe "$r = $1.responseURL;" +-- responseURL :: XHR -> IO JSString + +-- foreign import javascript unsafe "$r = $1.readyState;" +-- readyState' :: XHR -> IO Int + +-- foreign import javascript unsafe "$r = $1.responseType;" +-- responseType' :: XHR -> IO JSString + +-- responseType :: XHR -> IO ResponseType +-- {-# INLINE responseType #-} +-- responseType xhr = +-- responseType' xhr >>= \case +-- "" -> pure DOMStringType +-- "blob" -> pure BlobType +-- "document" -> pure DocumentType +-- "json" -> pure JSONType +-- "arraybuffer" -> pure ArrayBufferType +-- "text" -> pure DOMStringType +-- _ -> pure UnknownXHRType + +-- readyState :: XHR -> IO ReadyState +-- {-# INLINE readyState #-} +-- readyState xhr = toEnum <$> readyState' xhr + +-- -- request.open("GET", "foo.txt", true); +-- foreign import javascript unsafe "$1.open($2, $3, $4);" +-- open :: XHR -> JSString -> JSString -> Bool -> IO () + +-- foreign import javascript unsafe "$1.send();" +-- send :: XHR -> IO () + +-- foreign import javascript unsafe "$1.setRequestHeader($2,$3);" +-- setRequestHeader :: XHR -> JSString -> JSString -> IO () + +-- foreign import javascript unsafe "$1.onreadystatechanged = $2;" +-- onReadyStateChanged :: XHR -> Callback (JSVal -> IO ()) -> IO () + +-- foreign import javascript unsafe "$r = $1.getAllResponseHeaders();" +-- getAllResponseHeaders' :: XHR -> IO (Nullable JSString) + +-- foreign import javascript unsafe "$r = $1.getResponseHeader($2);" +-- getResponseHeader' :: XHR -> JSString -> IO (Nullable JSString) + +-- getResponseHeader :: XHR -> JSString -> IO (Maybe JSString) +-- {-# INLINE getResponseHeader #-} +-- getResponseHeader xhr key = +-- nullableToMaybe <$> getResponseHeader' xhr key + +-- foreign import javascript unsafe "$r = $1.response;" +-- response' :: XHR -> IO (Nullable JSVal) + +-- foreign import javascript unsafe "$r = $1.status;" +-- status' :: XHR -> IO (Nullable Int) + +-- foreign import javascript unsafe "$r = $1.statusText;" +-- statusText' :: XHR -> IO (Nullable JSString) + +-- foreign import javascript unsafe "$1.overrideMimeType($2);" +-- overrideMimeType :: XHR -> JSString -> IO () + +-- foreign import javascript unsafe "$r = $1.timeout;" +-- timeout :: XHR -> IO Int + +-- foreign import javascript unsafe "$1.withCredentials = true;" +-- withCredentials :: XHR -> IO () + +-- foreign import javascript unsafe "$1.response ? true : false" +-- hasResponse :: XHR -> IO Bool + +-- getAllResponseHeaders :: XHR -> IO (Maybe [JSString]) +-- {-# INLINE getAllResponseHeaders #-} +-- getAllResponseHeaders = \xhr -> do +-- result <- getAllResponseHeaders' xhr +-- pure $ lines <$> nullableToMaybe result diff --git a/ghcjs-src/Miso/FFI.hs b/ghcjs-src/Miso/FFI.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/FFI.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.FFI +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.FFI + ( windowAddEventListener + , windowRemoveEventListener + , windowInnerHeight + , windowInnerWidth + , now + , consoleLog + , stringify + , parse + , copyDOMIntoVTree + , item + , jsvalToValue + , delegateEvent + ) where + +import Control.Monad +import Control.Monad.Trans.Maybe +import qualified Data.Aeson as AE +import Data.Aeson hiding (Object) +import qualified Data.HashMap.Strict as H +import Data.JSString +import qualified Data.JSString.Text as JSS +import Data.Scientific +import qualified Data.Vector as V +import GHCJS.Foreign.Callback +import GHCJS.Foreign.Internal +import GHCJS.Marshal +import GHCJS.Types +import qualified JavaScript.Object.Internal as OI + +-- | Convert JSVal to Maybe `Value` +jsvalToValue :: JSVal -> IO (Maybe Value) +jsvalToValue r = do + case jsonTypeOf r of + JSONNull -> return (Just Null) + JSONInteger -> liftM (AE.Number . flip scientific 0 . (toInteger :: Int -> Integer)) + <$> fromJSVal r + JSONFloat -> liftM (AE.Number . (fromFloatDigits :: Double -> Scientific)) + <$> fromJSVal r + JSONBool -> liftM AE.Bool <$> fromJSVal r + JSONString -> liftM AE.String <$> fromJSVal r + JSONArray -> liftM (Array . V.fromList) <$> fromJSVal r + JSONObject -> do + Just props<- fromJSVal =<< getKeys (OI.Object r) + runMaybeT $ do + propVals <- forM props $ \p -> do + v <- MaybeT (fromJSVal =<< OI.getProp p (OI.Object r)) + return (JSS.textFromJSString p, v) + return (AE.Object (H.fromList propVals)) + +-- | Retrieves keys +foreign import javascript unsafe "$r = Object.keys($1);" + getKeys :: OI.Object -> IO JSVal + +-- | Adds event listener to window +foreign import javascript unsafe "window.addEventListener($1, $2);" + windowAddEventListener :: JSString -> Callback (JSVal -> IO ()) -> IO () + +-- | Removes event listener from window +foreign import javascript unsafe "window.removeEventListener($1, $2);" + windowRemoveEventListener :: JSString -> Callback (JSVal -> IO ()) -> IO () + +-- | Retrieves inner height +foreign import javascript unsafe "$r = window.innerHeight;" + windowInnerHeight :: IO Int + +-- | Retrieves outer height +foreign import javascript unsafe "$r = window.innerWidth;" + windowInnerWidth :: IO Int + +-- | Retrieve high performance time stamp +foreign import javascript unsafe "$r = performance.now();" + now :: IO Double + +-- | Console-logging +foreign import javascript unsafe "console.log($1);" + consoleLog :: JSVal -> IO () + +-- | Converts a JS object into a JSON string +foreign import javascript unsafe "$r = JSON.stringify($1);" + stringify' :: JSVal -> IO JSString + +foreign import javascript unsafe "$r = JSON.parse($1);" + parse' :: JSVal -> IO JSVal + +-- | Converts a JS object into a JSON string +stringify :: ToJSON json => json -> IO JSString +{-# INLINE stringify #-} +stringify j = stringify' =<< toJSVal (toJSON j) + +-- | Parses a JSString +parse :: FromJSON json => JSVal -> IO json +{-# INLINE parse #-} +parse jval = do + k <- parse' jval + Just val <- jsvalToValue k + case fromJSON val of + Success x -> pure x + Error y -> error y + +-- | Indexing into a JS object +foreign import javascript unsafe "$r = $1[$2];" + item :: JSVal -> JSString -> IO JSVal + +-- | Copies DOM pointers into virtual dom +-- entry point into isomorphic javascript +foreign import javascript unsafe "copyDOMIntoVTree($1);" + copyDOMIntoVTree :: JSVal -> IO () + +foreign import javascript unsafe "delegate($1, $2);" + delegateEvent + :: JSVal -- ^ Events + -> Callback (IO JSVal) -- ^ Virtual DOM callback + -> IO () + diff --git a/ghcjs-src/Miso/Html/Internal.hs b/ghcjs-src/Miso/Html/Internal.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Html/Internal.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Html.Internal +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Html.Internal ( + -- * Core types and interface + VTree (..) + , View (..) + , ToView (..) + , Attribute (..) + -- * Smart `View` constructors + , node + , text + -- * Key patch internals + , Key (..) + , ToKey (..) + -- * Namespace + , NS (..) + -- * Setting properties on virtual DOM nodes + , prop + -- * Setting css + , style_ + -- * Handling events + , on + , onWithOptions + -- * Events + , defaultEvents + -- * Subscription type + , Sub + ) where + +import Control.Monad +-- import Data.Aeson hiding (Object) +import Data.Aeson.Types (parseEither) +import Data.Monoid +import Data.JSString +import Data.JSString.Text +import qualified Data.Map as M +import qualified Data.Text as T +import GHCJS.Foreign.Callback +import GHCJS.Marshal +import GHCJS.Types +import JavaScript.Array.Internal (fromList) +import JavaScript.Object +import JavaScript.Object.Internal (Object (Object)) + +import Miso.Event.Decoder +import Miso.Event.Types +import Miso.String +import Miso.FFI + +-- | Type def for constructing event subscriptions +type Sub a m = IO m -> (a -> IO ()) -> IO () + +-- | Virtual DOM implemented as a JavaScript `Object` +-- Used for diffing, patching and event delegation. +-- Not meant to be constructed directly, see `View` instead. +newtype VTree = VTree { getTree :: Object } + +-- | Core type for constructing a `VTree`, use this instead of `VTree` directly. +newtype View action = View { + runView :: (action -> IO ()) -> IO VTree +} + +-- | Convenience class for using View +class ToView v where toView :: v -> View m + +set :: ToJSVal v => JSString -> v -> Object -> IO () +set k v obj = toJSVal v >>= \x -> setProp k x obj + +-- | `VNode` creation +node :: NS + -> MisoString + -> Maybe Key + -> [Attribute m] + -> [View m] + -> View m +node ns tag key attrs kids = View $ \sink -> do + vnode <- create + cssObj <- jsval <$> create + propsObj <- jsval <$> create + eventObj <- jsval <$> create + set "css" cssObj vnode + set "props" propsObj vnode + set "events" eventObj vnode + set "type" ("vnode" :: JSString) vnode + set "ns" ns vnode + set "tag" tag vnode + set "key" key vnode + setAttrs vnode sink + flip (set "children") vnode =<< setKids sink + pure $ VTree vnode + where + setAttrs vnode sink = + forM_ attrs $ \(Attribute attr) -> + attr sink vnode + + setKids sink = + jsval . fromList <$> + fmap (jsval . getTree) <$> + traverse (flip runView sink) kids + +instance ToJSVal Options +instance ToJSVal Key where toJSVal (Key x) = toJSVal x + +instance ToJSVal NS where + toJSVal SVG = toJSVal ("svg" :: JSString) + toJSVal HTML = toJSVal ("html" :: JSString) + +-- | Namespace for element creation +data NS + = HTML -- ^ HTML Namespace + | SVG -- ^ SVG Namespace + deriving (Show, Eq) + +-- | `VText` creation +text :: ToMisoString str => str -> View m +text t = View . const $ do + vtree <- create + set "type" ("vtext" :: JSString) vtree + set "text" (toMisoString t) vtree + pure $ VTree vtree + +-- | For use with child reconciliaton algorithm +-- Keys must be unique. Failure to satisfy this invariant +-- gives undefined behavior at runtime. +newtype Key = Key MisoString + +-- | Convert type into Key, ensure `Key` is unique +class ToKey key where toKey :: key -> Key +-- | Identity instance +instance ToKey Key where toKey = id +-- | Convert `MisoString` to `Key` +instance ToKey MisoString where toKey = Key +-- | Convert `Text` to `Key` +instance ToKey T.Text where toKey = Key . textToJSString +-- | Convert `String` to `Key` +instance ToKey String where toKey = Key . pack +-- | Convert `Int` to `Key` +instance ToKey Int where toKey = Key . pack . show +-- | Convert `Double` to `Key` +instance ToKey Double where toKey = Key . pack . show +-- | Convert `Float` to `Key` +instance ToKey Float where toKey = Key . pack . show +-- | Convert `Word` to `Key` +instance ToKey Word where toKey = Key . pack . show + +-- | `View` Attributes to annotate DOM, converted into `Events`, `Props`, `Attrs` and `CSS` +newtype Attribute action = Attribute ((action -> IO ()) -> Object -> IO ()) + +-- | Constructs a property on a `VNode`, used to set fields on a DOM Node +prop :: ToJSVal a => MisoString -> a -> Attribute action +prop k v = Attribute . const $ \n -> do + val <- toJSVal v + o <- getProp ("props" :: MisoString) n + set k val (Object o) + +-- | For defining delegated events +-- +-- > let clickHandler = on "click" emptyDecoder $ \() -> Action +-- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ] +-- +on :: MisoString + -> Decoder r + -> (r -> action) + -> Attribute action +on = onWithOptions defaultOptions + +foreign import javascript unsafe "$r = objectToJSON($1,$2);" + objectToJSON + :: JSVal -- ^ decodeAt :: [JSString] + -> JSVal -- ^ object with impure references to the DOM + -> IO JSVal + +-- | For defining delegated events with options +-- +-- > let clickHandler = on defaultOptions "click" emptyDecoder $ \() -> Action +-- > in button_ [ clickHandler, class_ "add" ] [ text_ "+" ] +-- +onWithOptions + :: Options + -> MisoString + -> Decoder r + -> (r -> action) + -> Attribute action +onWithOptions options eventName Decoder{..} toAction = + Attribute $ \sink n -> do + eventObj <- getProp "events" n + eventHandlerObject@(Object eo) <- create + jsOptions <- toJSVal options + decodeAtVal <- toJSVal decodeAt + cb <- jsval <$> (asyncCallback1 $ \e -> do + Just v <- jsvalToValue =<< objectToJSON decodeAtVal e + case parseEither decoder v of + Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s + Right r -> sink (toAction r)) + setProp "runEvent" cb eventHandlerObject + setProp "options" jsOptions eventHandlerObject + setProp eventName eo (Object eventObj) + +-- | Constructs `CSS` for a DOM Element +-- +-- > import qualified Data.Map as M +-- > div_ [ style_ $ M.singleton "background" "red" ] [ ] +-- +-- +-- +style_ :: M.Map MisoString MisoString -> Attribute action +style_ m = Attribute . const $ \n -> do + cssObj <- getProp "css" n + forM_ (M.toList m) $ \(k,v) -> + setProp k (jsval v) (Object cssObj) diff --git a/ghcjs-src/Miso/String.hs b/ghcjs-src/Miso/String.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/String.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.String +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.String ( + MisoString + , module Data.JSString + , ToMisoString (..) + ) where + +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.JSString +import Data.JSString.Text +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT + +-- | String type swappable based on compiler +type MisoString = JSString + +-- | `ToJSON` for `MisoString` +instance ToJSON MisoString where + toJSON = String . textFromJSString + +-- | `FromJSON` for `MisoString` +instance FromJSON MisoString where + parseJSON = + withText "Not a valid string" $ \x -> + pure (toMisoString x) + +-- | Convenience class for creating `MisoString` from other string-like types +class ToMisoString str where + toMisoString :: str -> MisoString + +instance ToMisoString MisoString where toMisoString = id +instance ToMisoString String where toMisoString = pack +instance ToMisoString T.Text where toMisoString = textToJSString +instance ToMisoString LT.Text where toMisoString = lazyTextToJSString +instance ToMisoString B.ByteString where toMisoString = toMisoString . T.decodeUtf8 +instance ToMisoString BL.ByteString where toMisoString = toMisoString . LT.decodeUtf8 +instance ToMisoString Value where toMisoString = toMisoString . encode diff --git a/ghcjs-src/Miso/Subscription.hs b/ghcjs-src/Miso/Subscription.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Subscription.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Subscription +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Subscription + ( module Miso.Subscription.Mouse + , module Miso.Subscription.Keyboard + , module Miso.Subscription.History + , module Miso.Subscription.WebSocket + , module Miso.Subscription.Window + , module Miso.Subscription.SSE + ) where + +import Miso.Subscription.Mouse +import Miso.Subscription.Keyboard +import Miso.Subscription.History +import Miso.Subscription.WebSocket +import Miso.Subscription.Window +import Miso.Subscription.SSE diff --git a/ghcjs-src/Miso/Subscription/History.hs b/ghcjs-src/Miso/Subscription/History.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Subscription/History.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Subscription.History +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Subscription.History + ( getURI + , pushURI + , replaceURI + , back + , forward + , go + , uriSub + ) where + +import Miso.String +import GHCJS.Foreign.Callback +import Network.URI hiding (path) +import Miso.Html.Internal ( Sub ) + +-- | Retrieves current URI of page +getURI :: IO URI +{-# INLINE getURI #-} +getURI = do + URI <$> pure mempty + <*> pure Nothing + <*> do unpack <$> getPathName + <*> do unpack <$> getSearch + <*> pure mempty + +-- | Pushes a new URI onto the History stack +pushURI :: URI -> IO () +{-# INLINE pushURI #-} +pushURI uri = pushStateNoModel uri { uriPath = path } + where + path | uriPath uri == mempty = "/" + | otherwise = uriPath uri + +-- | Replaces current URI on stack +replaceURI :: URI -> IO () +{-# INLINE replaceURI #-} +replaceURI uri = replaceTo' uri { uriPath = path } + where + path | uriPath uri == mempty = "/" + | otherwise = uriPath uri + +-- | Navigates backwards +back :: IO () +{-# INLINE back #-} +back = back' + +-- | Navigates forwards +forward :: IO () +{-# INLINE forward #-} +forward = forward' + +-- | Jumps to a specific position in history +go :: Int -> IO () +{-# INLINE go #-} +go = go' + +-- | Subscription for `popState` events, from the History API +uriSub :: (URI -> action) -> Sub action model +uriSub = \f _ sink -> + onPopState =<< do + ps <- f <$> getURI + asyncCallback $ sink ps + +foreign import javascript unsafe "window.history.go($1);" + go' :: Int -> IO () + +foreign import javascript unsafe "window.history.back();" + back' :: IO () + +foreign import javascript unsafe "window.history.forward();" + forward' :: IO () + +foreign import javascript unsafe "$r = window.location.pathname;" + getPathName :: IO JSString + +foreign import javascript unsafe "$r = window.location.search;" + getSearch :: IO JSString + +foreign import javascript unsafe "window.addEventListener('popstate', $1);" + onPopState :: Callback (IO ()) -> IO () + +foreign import javascript unsafe "window.history.pushState(null, null, $1);" + pushStateNoModel' :: JSString -> IO () + +foreign import javascript unsafe "window.history.replaceState(null, null, $1);" + replaceState' :: JSString -> IO () + +pushStateNoModel :: URI -> IO () +{-# INLINE pushStateNoModel #-} +pushStateNoModel = pushStateNoModel' . pack . show + +replaceTo' :: URI -> IO () +{-# INLINE replaceTo' #-} +replaceTo' = replaceState' . pack . show diff --git a/ghcjs-src/Miso/Subscription/Keyboard.hs b/ghcjs-src/Miso/Subscription/Keyboard.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Subscription/Keyboard.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Subscription.Keyboard +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Subscription.Keyboard + ( -- * Types + Arrows (..) + -- * Subscriptions + , arrowsSub + , keyboardSub + ) where + +import Data.IORef +import Data.Set +import qualified Data.Set as S +import GHCJS.Foreign.Callback +import GHCJS.Marshal +import JavaScript.Object +import JavaScript.Object.Internal + +import Miso.FFI +import Miso.Html.Internal ( Sub ) + +-- | type for arrow keys currently pressed +-- 37 left arrow ( x = -1 ) +-- 38 up arrow ( y = 1 ) +-- 39 right arrow ( x = 1 ) +-- 40 down arrow ( y = -1 ) +data Arrows = Arrows { + arrowX :: Int + , arrowY :: Int + } deriving (Show, Eq) + +-- | Helper function to convert keys currently pressed to `Arrow` +toArrows :: Set Int -> Arrows +toArrows set = + Arrows { + arrowX = + case (S.member 37 set, S.member 39 set) of + (True, False) -> -1 + (False, True) -> 1 + (_,_) -> 0 + , arrowY = + case (S.member 40 set, S.member 38 set) of + (True, False) -> -1 + (False, True) -> 1 + (_,_) -> 0 + } + +arrowsSub :: (Arrows -> action) -> Sub action model +arrowsSub = keyboardSub . (. toArrows) + +-- | Returns subscription for Keyboard +keyboardSub :: (Set Int -> action) -> Sub action model +keyboardSub f _ sink = do + keySetRef <- newIORef mempty + windowAddEventListener "keyup" =<< keyUpCallback keySetRef + windowAddEventListener "keydown" =<< keyDownCallback keySetRef + where + keyDownCallback keySetRef = do + asyncCallback1 $ \keyDownEvent -> do + Just key <- fromJSVal =<< getProp "keyCode" (Object keyDownEvent) + newKeys <- atomicModifyIORef' keySetRef $ \keys -> + let !new = S.insert key keys + in (new, new) + sink (f newKeys) + + keyUpCallback keySetRef = do + asyncCallback1 $ \keyUpEvent -> do + Just key <- fromJSVal =<< getProp "keyCode" (Object keyUpEvent) + newKeys <- atomicModifyIORef' keySetRef $ \keys -> + let !new = S.delete key keys + in (new, new) + sink (f newKeys) + diff --git a/ghcjs-src/Miso/Subscription/Mouse.hs b/ghcjs-src/Miso/Subscription/Mouse.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Subscription/Mouse.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Subscription.Mouse +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Subscription.Mouse (mouseSub) where + +import GHCJS.Foreign.Callback +import GHCJS.Marshal +import JavaScript.Object +import JavaScript.Object.Internal + +import Miso.FFI +import Miso.Html.Internal ( Sub ) + +-- | Captures mouse coordinates as they occur and writes them to +-- an event sink +mouseSub :: ((Int,Int) -> action) -> Sub action model +mouseSub f _ = \sink -> do + windowAddEventListener "mousemove" =<< do + asyncCallback1 $ \mouseEvent -> do + Just x <- fromJSVal =<< getProp "clientX" (Object mouseEvent) + Just y <- fromJSVal =<< getProp "clientY" (Object mouseEvent) + sink $ f (x,y) + diff --git a/ghcjs-src/Miso/Subscription/SSE.hs b/ghcjs-src/Miso/Subscription/SSE.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Subscription/SSE.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Subscription.SSE +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Subscription.SSE + ( -- * Subscription + sseSub + -- * Types + , SSE (..) + ) where + +import Data.Aeson +import GHCJS.Foreign.Callback +import GHCJS.Types +import Miso.FFI +import Miso.Html.Internal ( Sub ) +import Miso.String + +-- | Server-sent events Subscription +sseSub :: FromJSON msg => MisoString -> (SSE msg -> action) -> Sub action model +sseSub url f _ = \sink -> do + es <- newEventSource url + onMessage es =<< do + asyncCallback1 $ \val -> do + getData val >>= parse >>= \x -> do + sink $ f (SSEMessage x) + onError es =<< do + asyncCallback $ + sink (f SSEError) + onClose es =<< do + asyncCallback $ + sink (f SSEClose) + +-- | Server-sent events data +data SSE message + = SSEMessage message + | SSEClose + | SSEError + deriving (Show, Eq) + +foreign import javascript unsafe "$r = $1.data;" + getData :: JSVal -> IO JSVal + +newtype EventSource = EventSource JSVal + +foreign import javascript unsafe "$r = new EventSource($1);" + newEventSource :: JSString -> IO EventSource + +foreign import javascript unsafe "$1.onmessage = $2;" + onMessage :: EventSource -> Callback (JSVal -> IO ()) -> IO () + +foreign import javascript unsafe "$1.onerror = $2;" + onError :: EventSource -> Callback (IO ()) -> IO () + +foreign import javascript unsafe "$1.onclose = $2;" + onClose :: EventSource -> Callback (IO ()) -> IO () + +-- | Test URL +-- http://sapid.sourceforge.net/ssetest/webkit.events.php +-- var source = new EventSource("demo_sse.php"); + diff --git a/ghcjs-src/Miso/Subscription/WebSocket.hs b/ghcjs-src/Miso/Subscription/WebSocket.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Subscription/WebSocket.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Subscription.WebSocket +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Subscription.WebSocket + ( -- * Types + WebSocket (..) + , URL (..) + , Protocols (..) + , SocketState (..) + -- * Subscription + , websocketSub + , send + , connect + , getSocketState + ) where + +import Control.Concurrent +import Control.Monad +import Data.Aeson +import Data.IORef +import Data.Maybe +import GHC.Generics +import GHCJS.Foreign.Callback +import GHCJS.Marshal +import GHCJS.Types +import Prelude hiding (map) +import System.IO.Unsafe + +import Miso.FFI +import Miso.Html.Internal ( Sub ) +import Miso.String + +-- | WebSocket connection messages +data WebSocket action + = WebSocketMessage action + | WebSocketClose CloseCode WasClean Reason + | WebSocketOpen + | WebSocketError MisoString + +websocket :: IORef (Maybe Socket) +{-# NOINLINE websocket #-} +websocket = unsafePerformIO (newIORef Nothing) + +secs :: Int -> Int +secs = (*1000000) + +-- | WebSocket subscription +websocketSub + :: FromJSON m + => URL + -> Protocols + -> (WebSocket m -> action) + -> Sub action model +websocketSub (URL u) (Protocols ps) f _ sink = do + socket <- createWebSocket u ps + writeIORef websocket (Just socket) + -- Handle Reconnects + void . forkIO . forever $ do + threadDelay (secs 3) + Just s <- readIORef websocket + status <- getSocketState' s + when (status == 3) $ do + atomicWriteIORef websocket + =<< Just <$> createWebSocket u ps + onOpen socket =<< do + asyncCallback $ do + sink (f WebSocketOpen) + onMessage socket =<< do + asyncCallback1 $ \v -> do + d <- parse =<< getData v + sink $ f (WebSocketMessage d) + onClose socket =<< do + asyncCallback1 $ \e -> do + code <- codeToCloseCode <$> getCode e + reason <- getReason e + clean <- wasClean e + sink $ f (WebSocketClose code clean reason) + onError socket =<< do + asyncCallback1 $ \v -> do + d <- parse =<< getData v + sink $ f (WebSocketError d) + +-- | Sends message to a websocket server +send :: ToJSON a => a -> IO () +{-# INLINE send #-} +send x = do + Just socket <- readIORef websocket + sendJson' socket x + +-- | Connects to a websocket server +connect :: URL -> Protocols -> IO () +{-# INLINE connect #-} +connect (URL url') (Protocols ps) = do + Just ws <- readIORef websocket + s <- getSocketState' ws + when (s == 3) $ do + socket <- createWebSocket url' ps + atomicWriteIORef websocket (Just socket) + +newtype URL = URL MisoString + deriving (Show, Eq) + +newtype Protocols = Protocols [MisoString] + deriving (Show, Eq) + +newtype WasClean = WasClean Bool deriving (Show, Eq) + +newtype Reason = Reason MisoString deriving (Show, Eq) + +foreign import javascript unsafe "$r = new WebSocket($1, $2);" + createWebSocket' :: JSString -> JSVal -> IO Socket + +foreign import javascript unsafe "$r = $1.readyState;" + getSocketState' :: Socket -> IO Int + +data SocketState + = CONNECTING -- ^ 0 + | OPEN -- ^ 1 + | CLOSING -- ^ 2 + | CLOSED -- ^ 3 + deriving (Show, Eq, Ord, Enum) + +-- | Retrieves current status of `WebSocket` +getSocketState :: IO SocketState +getSocketState = do + Just ws <- readIORef websocket + toEnum <$> getSocketState' ws + +foreign import javascript unsafe "$1.send($2);" + send' :: Socket -> JSString -> IO () + +sendJson' :: ToJSON json => Socket -> json -> IO () +sendJson' socket m = send' socket =<< stringify m + +createWebSocket :: JSString -> [JSString] -> IO Socket +{-# INLINE createWebSocket #-} +createWebSocket url' protocols = + createWebSocket' url' =<< toJSVal protocols + +foreign import javascript unsafe "$1.onopen = $2" + onOpen :: Socket -> Callback (IO ()) -> IO () + +foreign import javascript unsafe "$1.onclose = $2" + onClose :: Socket -> Callback (JSVal -> IO ()) -> IO () + +foreign import javascript unsafe "$1.onmessage = $2" + onMessage :: Socket -> Callback (JSVal -> IO ()) -> IO () + +foreign import javascript unsafe "$1.onerror = $2" + onError :: Socket -> Callback (JSVal -> IO ()) -> IO () + +foreign import javascript unsafe "$r = $1.data" + getData :: JSVal -> IO JSVal + +foreign import javascript unsafe "$r = $1.wasClean" + wasClean :: JSVal -> IO WasClean + +foreign import javascript unsafe "$r = $1.code" + getCode :: JSVal -> IO Int + +foreign import javascript unsafe "$r = $1.reason" + getReason :: JSVal -> IO Reason + +newtype Socket = Socket JSVal + +--- | https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent +data CloseCode + = CLOSE_NORMAL + -- ^ 1000, Normal closure; the connection successfully completed whatever purpose for which it was created. + | CLOSE_GOING_AWAY + -- ^ 1001, The endpoint is going away, either because of a server failure or because the browser is navigating away from the page that opened the connection. + | CLOSE_PROTOCOL_ERROR + -- ^ 1002, The endpoint is terminating the connection due to a protocol error. + | CLOSE_UNSUPPORTED + -- ^ 1003, The connection is being terminated because the endpoint received data of a type it cannot accept (for example, a textonly endpoint received binary data). + | CLOSE_NO_STATUS + -- ^ 1005, Reserved. Indicates that no status code was provided even though one was expected. + | CLOSE_ABNORMAL + -- ^ 1006, Reserved. Used to indicate that a connection was closed abnormally (that is, with no close frame being sent) when a status code is expected. + | Unsupported_Data + -- ^ 1007, The endpoint is terminating the connection because a message was received that contained inconsistent data (e.g., nonUTF8 data within a text message). + | Policy_Violation + -- ^ 1008, The endpoint is terminating the connection because it received a message that violates its policy. This is a generic status code, used when codes 1003 and 1009 are not suitable. + | CLOSE_TOO_LARGE + -- ^ 1009, The endpoint is terminating the connection because a data frame was received that is too large. + | Missing_Extension + -- ^ 1010, The client is terminating the connection because it expected the server to negotiate one or more extension, but the server didn't. + | Internal_Error + -- ^ 1011, The server is terminating the connection because it encountered an unexpected condition that prevented it from fulfilling the request. + | Service_Restart + -- ^ 1012, The server is terminating the connection because it is restarting. + | Try_Again_Later + -- ^ 1013, The server is terminating the connection due to a temporary condition, e.g. it is overloaded and is casting off some of its clients. + | TLS_Handshake + -- ^ 1015, Reserved. Indicates that the connection was closed due to a failure to perform a TLS handshake (e.g., the server certificate can't be verified). + | OtherCode Int + -- ^ OtherCode that is reserved and not in the range 0999 + deriving (Show, Eq, Generic) + +instance ToJSVal CloseCode +instance FromJSVal CloseCode + +codeToCloseCode :: Int -> CloseCode +codeToCloseCode = go + where + go 1000 = CLOSE_NORMAL + go 1001 = CLOSE_GOING_AWAY + go 1002 = CLOSE_PROTOCOL_ERROR + go 1003 = CLOSE_UNSUPPORTED + go 1005 = CLOSE_NO_STATUS + go 1006 = CLOSE_ABNORMAL + go 1007 = Unsupported_Data + go 1008 = Policy_Violation + go 1009 = CLOSE_TOO_LARGE + go 1010 = Missing_Extension + go 1011 = Internal_Error + go 1012 = Service_Restart + go 1013 = Try_Again_Later + go 1015 = TLS_Handshake + go n = OtherCode n diff --git a/ghcjs-src/Miso/Subscription/Window.hs b/ghcjs-src/Miso/Subscription/Window.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Subscription/Window.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Subscription.Window +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Subscription.Window where + +import GHCJS.Foreign.Callback +import GHCJS.Marshal + +import JavaScript.Object +import JavaScript.Object.Internal +import Miso.FFI +import Miso.Html.Internal ( Sub ) + +-- | Captures window coordinates changes as they occur and writes them to +-- an event sink +windowSub :: ((Int, Int) -> action) -> Sub action model +windowSub f _ = \sink -> do + sink . f =<< (,) <$> windowInnerHeight <*> windowInnerWidth + windowAddEventListener "resize" =<< do + asyncCallback1 $ \windowEvent -> do + target <- getProp "target" (Object windowEvent) + Just w <- fromJSVal =<< getProp "innerWidth" (Object target) + Just h <- fromJSVal =<< getProp "innerHeight" (Object target) + sink $ f (h, w) + diff --git a/ghcjs-src/Miso/Types.hs b/ghcjs-src/Miso/Types.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Miso/Types.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Types +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Types + ( App (..) + ) where + +import qualified Data.Map as M +import Miso.Effect +import Miso.Html.Internal +import Miso.String + +-- | Application entry point +data App model action = App + { model :: model + -- ^ initial model + , update :: action -> model -> Effect model action + -- ^ Function to update model, optionally provide effects + , view :: model -> View action + -- ^ Function to draw `View` + , subs :: [ Sub action model ] + -- ^ List of subscriptions to run during application lifetime + , events :: M.Map MisoString Bool + -- ^ List of delegated events that the body element will listen for + } + diff --git a/jsbits/delegate.js b/jsbits/delegate.js new file mode 100644 --- /dev/null +++ b/jsbits/delegate.js @@ -0,0 +1,77 @@ +/* event delegation algorithm */ +function delegate(events, getVTree) { + for (var event in events) { + document.body.addEventListener(events[event][0], function(e) { + delegateEvent ( e + , getVTree() + , buildTargetToBody(document.body, e.target) + , [] + ); + }, events[event][1]); + } +} + +/* Accumulate parent stack as well for propagation */ +function delegateEvent (event, obj, stack, parentStack) { + + /* base case, not found */ + if (!stack.length) return; + + /* stack not length 1, recurse */ + 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; + delegateEvent ( event + , obj.children[o] + , stack.slice(1) + , parentStack + ); + } + } + + /* stack.length == 1 */ + else { + if (obj.domRef === stack[0]) { + if (obj.events[event.type]) { + var eventObj = obj.events[event.type], + options = eventObj.options; + if (options.preventDefault) event.preventDefault(); + eventObj.runEvent(event); + if (!options.stopPropagation) + propogateWhileAble (parentStack, event); + } + } + } +} + +function buildTargetToBody (body, target) { + var stack = []; + while (body !== target) { + stack.unshift (target); + target = target.parentNode; + } + return stack; +} + +function propogateWhileAble (parentStack, event) { + for (var i = 0; i < parentStack.length; i++) { + if (parentStack[i].events[event.type]) { + var eventObj = parentStack[i].events[event.type], + options = eventObj.options; + if (options.preventDefault) event.preventDefault(); + eventObj.runEvent(event); + if (options.stopPropagation) break; + } + } +} + +/* Convert event to JSON at a specific location in the DOM tree*/ +function objectToJSON (at, obj) { + for (var i in at) obj = obj[at[i]]; + var newObj = {}; + for (var i in obj) + 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 new file mode 100644 --- /dev/null +++ b/jsbits/diff.js @@ -0,0 +1,365 @@ +/* virtual-dom diffing algorithm, applies patches as detected */ +function diff (currentObj, newObj, parent) { + if (!currentObj && !newObj) return; + else if (!currentObj && newObj) createNode (newObj, parent); + else if (currentObj && !newObj) parent.removeChild (currentObj.domRef); + else { + if (currentObj.type === "vtext") { + if (newObj.type === "vnode") replaceElementWithText (currentObj, newObj, parent); + else diffTextNodes (currentObj, newObj); + } else { + if (newObj.type === "vnode") diffVNodes (currentObj, newObj, parent); + else replaceTextWithElement (currentObj, newObj, parent); + } + } +} + +function diffTextNodes (c, n) { + if (c.text !== n.text) c.domRef.replaceData (0, c.domRef.length, n.text); + n.domRef = c.domRef; +} + +function replaceElementWithText (c, n, parent) { + n.domRef = document.createTextNode (n.text); + parent.replaceChild (n.domRef, c.domRef); +} + +function replaceTextWithElement (c, n, parent) { + createElement (n); + parent.replaceChild (n.domRef, c.domRef); +} + +function populate (c, n) { + if (!c) c = { + props : null + , css : null + , children : [] + } + if (!n) n = { + props : null + , css : null + , children : [] + } + diffProps (c.props, n.props, n.domRef, n.ns === "svg"); + diffCss (c.css, n.css, n.domRef); + diffChildren (c.children, n.children, n.domRef); +} + +function diffVNodes (c, n, parent) { + if (c.tag === n.tag) { + n.domRef = c.domRef; + populate (c, n); + } else { + createElement(n); + parent.replaceChild (n.domRef, c.domRef); + } +} + +function diffProps (cProps, nProps, node, isSvg) { + var result, newProp, domProp; + /* Is current prop in new prop list? */ + for (var c in cProps) { + newProp = nProps[c]; + /* If current property no longer exists, remove it */ + if (!newProp) { + /* current key is not in node, remove it from DOM, if SVG, remove attribute */ + if (isSvg || !(c in node)) + node.removeAttribute(c, cProps[c]); + else + node[c] = ""; + } else { + /* Already on DOM from previous diff, continue */ + if (newProp === cProps[c]) continue; + domProp = node[c]; + /* Value in new prop map, not in old, but already pre-populated on DOM, potentially from server-prerendering, continue */ + if (newProp === domProp) continue; + if (isSvg) { + if (c === "href") + node.setAttributeNS("http://www.w3.org/1999/xlink", "href", newProp); + else if (c === "className" || c === "class") + node.setAttributeNS("http://www.w3.org/1999/xlink", "class", newProp); + else + node.setAttribute(c, newProp); + } else if (n in node) { + node[c] = newProp; + } else { + node.setAttribute(c, newProp); + } + } + } + /* add remaining */ + for (var n in nProps) { + if (cProps && cProps[n]) continue; + 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); + else if (n === "className" || n === "class") + node.setAttributeNS("http://www.w3.org/1999/xlink", "class", newProp); + else + node.setAttribute(n, newProp); + } else if (n in node) { + node[n] = nProps[n]; + } else { + node.setAttribute(n, newProp); + } + } +} + +function diffCss (cCss, nCss, node) { + var result; + /* is current attribute in new attribute list? */ + for (var c in cCss) { + result = nCss[c]; + if (!result) { + /* current key is not in node */ + node.style[c] = null; + } else if (result !== cCss[c]) { + node.style[c] = result; + } + } + /* add remaining */ + for (var n in nCss) { + if (cCss && cCss[n]) continue; + node.style[n] = nCss[n]; + } +} + +function hasKey (cs) { + return cs && cs[0] && cs[0].key; +} + +function diffChildren (cs, ns, parent) { + var longest = ns.length > cs.length ? ns.length : cs.length; +// if (hasKey(cs)) syncChildren (cs, ns, parent); + for (var i = 0; i < longest; i++) diff (cs[i], ns[i], parent); +} + +function createElement (obj) { + obj.domRef = obj.ns === "svg" + ? document.createElementNS("http://www.w3.org/2000/svg", obj.tag) + : document.createElement(obj.tag); + populate (null, obj); +} + +function createNode (obj, parent) { + if (obj.type === "vnode") createElement(obj); + else obj.domRef = document.createTextNode(obj.text); + parent.appendChild(obj.domRef); +} + +function createNodeDontAppend (obj) { + if (obj.type === "vnode") createElement(obj); + else obj.domRef = document.createTextNode(obj.text); + return obj; +} + +/* Child reconciliation algorithm, inspired by kivi and Bobril */ +function syncChildren (os, ns, parent) { + var oldFirstIndex = 0 + , newFirstIndex = 0 + , oldLastIndex = os.length - 1 + , newLastIndex = ns.length - 1 + , nFirst + , nLast + , oFirst + , oLast + , LIS + , temp; + for (;;) { + /* check base case, first > last for both new and old + [ ] -- old children empty (fully-swapped) + [ ] -- new children empty (fully-swapped) + */ + if (newFirstIndex > newLastIndex && oldFirstIndex > oldLastIndex) break; + nFirst = ns[newFirstIndex]; + nLast = ns[newLastIndex]; + oFirst = os[oldFirstIndex]; + oLast = os[oldLastIndex]; + /* No more old nodes, create and insert all remaining nodes + -> [ ] <- old children + -> [ a b c ] <- new children + */ + if (oldFirstIndex > oldLastIndex) { + var node = createNodeDontAppend(nFirst); + /* insertBefore's semantics will append a node if the second argument provided is `null` or `undefined`. + Otherwise, it will insert node.domRef before oLast.domRef. */ + parent.insertBefore(node.domRef, oLast ? oLast.domRef : null); + os.splice(newFirstIndex, 0, nFirst); + newFirstIndex++; + continue; + } + /* No more new nodes, delete all remaining nodes in old list + -> [ a b c ] <- old children + -> [ ] <- new children + */ + else if (newFirstIndex > newLastIndex) { + tmp = oldLastIndex - oldFirstIndex; + while (tmp >= 0) { + parent.removeChild(os[oldFirstIndex].domRef); + os.splice(oldFirstIndex, 1); + tmp--; + } + break; + } + /* happy path, everything aligns, we continue + -> oldFirstIndex -> [ a b c ] <- oldLastIndex + -> newFirstIndex -> [ a b c ] <- newLastIndex + check if nFirst and oFirst align, if so, check nLast and oLast + */ + else if (oFirst.key === nFirst.key) { + newFirstIndex++; + oldFirstIndex++; + continue; + } else if (oLast.key === nLast.key) { + newLastIndex--; + oldLastIndex--; + continue; + } + /* flip-flop case, nodes have been swapped, in some way or another + both could have been swapped. + -> [ a b c ] <- old children + -> [ c b a ] <- new children */ + else if (oFirst.key === nLast.key && nFirst.key === oLast.key) { + var nextSib = oFirst.domRef.nextSibling; + parent.insertBefore(oFirst.domRef, oLast.domRef); + parent.insertBefore(nextSib, oLast.domRef); + newFirstIndex++; + oldFirstIndex++; + oldLastIndex--; + newLastIndex--; + continue; + } + + /* or just one could be swapped (d's align here) + -> [ d b g ] <- old children + -> [ a k d ] <- new children + on either side (e's align here) + -> [ e b c ] <- old children + -> [ b c e ] <- new children */ + + /* For now, the above case is handled in the "you're screwed case" below. */ + + /* 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 + */ + + else { + var P = [], I = {}, i = 0, nLen = newLastIndex - newFirstIndex, oLen = oldLastIndex - oldFirstIndex, + foundKey, last = -1, moved = false, newNodeIndex, removedNodes = 0; + /* Create array with length of new children list */ + /* -1 means a new node should be inserted */ + for (i = nLen; i > 0; i--) P.append(-1); + /* Create index I that maps keys with node positions of the remaining nodes from the new children */ + for (i = newFirstIndex; i <= newLastIndex; i++) I[ns[i].key] = i; + /* Iterate over old nodes with Index, check if we can find node with same key in index */ + for (i = oldFirstIndex; i <= oldLastIndex; i++) { + node = os[i]; /* This will always return a match in this loop */ + newNodeIndex = I[node.key]; + /* If old node doesn't exist in new node list, remove it */ + if (!newNodeIndex) { + parent.removeChild(node.domRef); + removedNodes++; + } + /* Found new node in index map */ + else { + /* Assign position of the node in the old children list to the positions array. */ + P[newNodeIndex] = i; + /* When assigning positions in the positions array, we also keep the last seen node position of the new children + list. If the last seen position is larger than current position of the node at the new list, then we are switching + `moved` flag to `true`. */ + + /* First check if last seen node position is larger than current node position */ + if (last > newNodeIndex) moved = true; + /* Update last seen */ + last = newNodeIndex; + } + } + /* If `moved` flag is on, or if the length of the old children list minus the number of + removed nodes isn't equal to the length of the new children list. Then go to the next step */ + if (moved /* DMJ: not sure we need this predicate ? ===> */ || (oLen - removedNodes !== nLen)) { + /* Find minimum number of moves if `moved` flag is on, or insert new nodes if the length is changed. */ + LIS = lis(P); + lisIndex = LIS.length - 1; + while (nLen > -1) { + if (P[lisIndex] === nLen) { + listIndex--; + continue; + } + else if (LIS[lisIndex] !== nLen) { + /* node has moved */ + ns[nLen].domRef = os[P[nLen]].domRef; + parent.insertBefore(ns[nLen].domRef, os[nLen].domRef); + } + nLen--; + } + } else if (!moved) { + /* When moved flag is off, we don't need to find LIS, and we just + iterate over the new children list and check its + current position in the positions array, if it is `-1`, + then we insert new node. */ + for (i = newFirstIndex; i <= newLastIndex; i++) { + if (P[i] === -1) { + createNodeDontAppend(ns[i]); + /* Replace whatever is at current */ + /* parent.replaceChild(ns[i].domRef, parent.children[i]); ... this doesn't seem right to me... */ + parent.insertBefore(ns[i].domRef, parent.children[i+1]); + } + } + } + } + } +} + + +/* Thanks Boris :) */ +function lis(a) { + var p = a.slice(0); + var result = [], u, v, il, c, j; + result.push(0); + + for (var i = 0, il = a.length; i < il; i++) { + if (a[i] === -1) { + continue; + } + + j = result[result.length - 1]; + if (a[j] < a[i]) { + p[i] = j; + result.push(i); + continue; + } + + u = 0; + v = result.length - 1; + + while (u < v) { + c = ((u + v) / 2) | 0; + if (a[result[c]] < a[i]) { + u = c + 1; + } else { + v = c; + } + } + + if (a[i] < a[result[u]]) { + if (u > 0) { + p[i] = result[u - 1]; + } + result[u] = i; + } + } + + u = result.length; + v = result[u - 1]; + + while (u-- > 0) { + result[u] = v; + v = p[v]; + } + + return result; +} diff --git a/jsbits/isomorphic.js b/jsbits/isomorphic.js new file mode 100644 --- /dev/null +++ b/jsbits/isomorphic.js @@ -0,0 +1,13 @@ +function copyDOMIntoVTree (vtree) { + walk (vtree, document.body.firstChild); +} + +function walk (vtree, node) { + var i = 0; + vtree.domRef = node; + while (i < vtree.children.length) { + walk(vtree.children[i], node.children[i]); + i++; + } +} + diff --git a/jsbits/util.js b/jsbits/util.js new file mode 100644 --- /dev/null +++ b/jsbits/util.js @@ -0,0 +1,13 @@ +function callFocus(id) { + setTimeout(function(){ + var ele = document.getElementById(id); + if (ele && ele.focus) ele.focus() + }, 50); +} + +function callBlur(id) { + setTimeout(function(){ + var ele = document.getElementById(id); + if (ele && ele.blur) ele.blur() + }, 50); +} diff --git a/miso.cabal b/miso.cabal new file mode 100644 --- /dev/null +++ b/miso.cabal @@ -0,0 +1,173 @@ +name: miso +version: 0.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/miso-haskell/miso +copyright: Copyright (c) 2016 David M. Johnson +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.22 +synopsis: Haskell front-end framework +description: + Miso is a Haskell front-end framework featuring a virtual-dom, fast hand-rolled javascript diffing / patching algorithm, event delegation, event batching, SVG support, and an extensible Subscription-based subsystem. Inspired by Elm, Redux and Bobril, Miso currently supports WebSocket, Window, Mouse, History and KeysDown subscriptions. `IO` and other effects (such as `XHR`) can be introduced into the system via the `Effect` data type inside the `update` function. Pre-rendered templates and shared server-routing are made possible with servant. Minimal dependencies. + +extra-source-files: + README.md + examples/todo-mvc/index.html + examples/mario/imgs/jump/right.gif + examples/mario/imgs/jump/left.gif + examples/mario/imgs/stand/right.gif + examples/mario/imgs/stand/left.gif + examples/mario/imgs/walk/right.gif + examples/mario/imgs/walk/left.gif + +flag examples + default: + False + description: + Builds Miso's examples + +flag tests + default: + False + description: + Builds Miso's tests + +executable todo-mvc + if !impl(ghcjs) || !flag(examples) + buildable: False + main-is: + Main.hs + hs-source-dirs: + examples/todo-mvc + build-depends: + base < 5, + aeson, + containers, + miso + default-language: + Haskell2010 + +executable mario + if !impl(ghcjs) || !flag(examples) + buildable: False + main-is: + Main.hs + hs-source-dirs: + examples/mario + build-depends: + base < 5, + containers, + miso + default-language: + Haskell2010 + +executable simple + if !impl(ghcjs) || !flag(examples) + buildable: False + main-is: + Main.hs + hs-source-dirs: + exe + build-depends: + aeson, + base < 5, + containers, + miso + default-language: + Haskell2010 + +executable tests + if !impl(ghcjs) || !flag(tests) + buildable: False + hs-source-dirs: + tests + main-is: + Main.hs + build-depends: + aeson, + base < 5, + miso, + hspec, + hspec-core, + ghcjs-base + default-language: + Haskell2010 + +library + default-language: + Haskell2010 + exposed-modules: + Miso.Html + Miso.Html.Element + Miso.Html.Event + Miso.Html.Property + Miso.Event + Miso.Event.Decoder + Miso.Event.Types + Miso.Svg + Miso.Svg.Attribute + Miso.Svg.Element + Miso.Svg.Event + Miso.String + other-modules: + Miso.Concurrent + Miso.Html.Internal + ghc-options: + -Wall + hs-source-dirs: + src + build-depends: + aeson, + base < 5, + bytestring, + containers, + network-uri, + text + if impl(ghcjs) + hs-source-dirs: + ghcjs-src + build-depends: + ghcjs-base, + containers, + scientific, + unordered-containers, + servant, + transformers, + vector + js-sources: + jsbits/diff.js + jsbits/delegate.js + jsbits/isomorphic.js + jsbits/util.js + exposed-modules: + Miso + Miso.Effect + Miso.Effect.Storage + Miso.Effect.XHR + Miso.Effect.DOM + Miso.Subscription + Miso.Subscription.History + Miso.Subscription.Keyboard + Miso.Subscription.Mouse + Miso.Subscription.WebSocket + Miso.Subscription.Window + Miso.Subscription.SSE + Miso.Types + other-modules: + Miso.Diff + Miso.FFI + Miso.Delegate + else + build-depends: + lucid, + vector + hs-source-dirs: + ghc-src + +source-repository head + type: git + location: https://github.com/dmjio/miso.git diff --git a/src/Miso/Concurrent.hs b/src/Miso/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Concurrent.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Concurrent +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Concurrent ( + Notify (..) + , newNotify + , EventWriter (..) + , newEventWriter + ) where + +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Monad + +-- | Concurrent API for receiving events and writing to an event sink +data EventWriter action = EventWriter { + writeEvent :: action -> IO () + , getEvent :: IO action + } + +-- | Creates a new `EventWriter` +newEventWriter :: IO () -> IO (EventWriter m) +newEventWriter notify' = do + chan <- newChan + pure $ EventWriter (write chan) (readChan chan) + where + write chan event = + void . forkIO $ do + writeChan chan event + notify' + +-- | Concurrent API for `SkipChan` implementation +data Notify = Notify { + wait :: IO () + , notify :: IO () + } + +-- | Create a new `Notify` +newNotify :: IO Notify +newNotify = do + skipChan <- newSkipChan + pure $ Notify + (getSkipChan skipChan) + (putSkipChan skipChan ()) + +data SkipChan a = + SkipChan (MVar (a, [MVar ()])) (MVar ()) + +newSkipChan :: IO (SkipChan a) +newSkipChan = do + sem <- newEmptyMVar + main <- newMVar (undefined, [sem]) + return (SkipChan main sem) + +putSkipChan :: SkipChan a -> a -> IO () +putSkipChan (SkipChan main _) v = do + (_, sems) <- takeMVar main + putMVar main (v, []) + mapM_ (\sem -> putMVar sem ()) sems + +getSkipChan :: SkipChan a -> IO a +getSkipChan (SkipChan main sem) = do + takeMVar sem + (v, sems) <- takeMVar main + putMVar main (v, sem:sems) + return v + diff --git a/src/Miso/Event.hs b/src/Miso/Event.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Event.hs @@ -0,0 +1,17 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Event +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Event + ( module Miso.Event.Decoder + , module Miso.Event.Types + ) where + +import Miso.Event.Decoder +import Miso.Event.Types + diff --git a/src/Miso/Event/Decoder.hs b/src/Miso/Event/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Event/Decoder.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Event.Decoder +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Event.Decoder + ( -- * Decoder + Decoder (..) + , at + -- * Decoders + , emptyDecoder + , keycodeDecoder + , checkedDecoder + , valueDecoder + ) + where + +import Data.Aeson.Types +import Control.Applicative + +import Miso.Event.Types +import Miso.String + +-- | Decoder data type for parsing events +data Decoder a = Decoder { + decoder :: Value -> Parser a -- ^ FromJSON-based Event decoder +, decodeAt :: [MisoString] -- ^ Location in DOM of where to decode +} + +-- | Smart constructor for building +at :: [MisoString] -> (Value -> Parser a) -> Decoder a +at decodeAt decoder = Decoder {..} + +-- | Empty decoder for use with events like "click" that do not +-- return any meaningful values +emptyDecoder :: Decoder () +emptyDecoder = mempty `at` go + where + go = withObject "emptyDecoder" $ \_ -> pure () + +-- | Retrieves either "keyCode", "which" or "charCode" field in `Decoder` +keycodeDecoder :: Decoder KeyCode +keycodeDecoder = Decoder {..} + where + decodeAt = mempty + decoder = withObject "event" $ \o -> + KeyCode <$> (o .: "keyCode" <|> o .: "which" <|> o .: "charCode") + +-- | Retrieves "value" field in `Decoder` +valueDecoder :: Decoder MisoString +valueDecoder = Decoder {..} + where + decodeAt = ["target"] + decoder = withObject "target" $ \o -> o .: "value" + +-- | Retrieves "checked" field in Decoder +checkedDecoder :: Decoder Checked +checkedDecoder = Decoder {..} + where + decodeAt = ["target"] + decoder = withObject "target" $ \o -> + Checked <$> (o .: "checked") diff --git a/src/Miso/Event/Types.hs b/src/Miso/Event/Types.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Event/Types.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Event.Types +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Event.Types where + +import qualified Data.Map as M +import GHC.Generics +import Miso.String +import Data.Aeson + +-- | Type used for Keyboard events +newtype KeyCode = KeyCode Int + deriving (Show, Eq, Ord, FromJSON) + +-- | Type used for Checkbox events +newtype Checked = Checked Bool + deriving (Show, Eq, Ord, FromJSON) + +-- | Options for handling event propagation +data Options = Options { + preventDefault :: Bool + , stopPropagation :: Bool + } deriving (Show, Eq, Generic) + +-- | Default options +defaultOptions :: Options +defaultOptions = Options False False + +-- | Related to using drop-related events +newtype AllowDrop = AllowDrop Bool + deriving (Show, Eq, FromJSON) + +-- | Default delegated events +defaultEvents :: M.Map MisoString Bool +defaultEvents = M.fromList [ + ("blur", True) + , ("change", False) + , ("click", False) + , ("dblclick", False) + , ("focus", False) + , ("input", False) + , ("keydown", False) + , ("keypress", False) + , ("keyup", False) + , ("mouseup", False) + , ("mousedown", False) + , ("mouseenter", False) + , ("mouseleave", False) + , ("mouseover", False) + , ("mouseout", False) + , ("dragstart", False) + , ("dragover", False) + , ("dragend", False) + , ("dragenter", False) + , ("dragleave", False) + , ("drag", False) + , ("drop", False) + , ("submit", False) + ] diff --git a/src/Miso/Html.hs b/src/Miso/Html.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Html.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Html +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +-- +-- Example usage: +-- +-- @ +-- import Miso +-- +-- data IntAction = Add | Subtract +-- +-- intView :: Int -> View IntAction +-- intView n = div_ [ class_ "main" ] [ +-- btn_ [ onClick Add ] [ text_ "+" ] +-- , text_ $ pack (show n) +-- , btn_ [ onClick Subtract ] [ text_ "-" ] +-- ] +-- @ +-- +-- More information on how to use `miso` is available on GitHub +-- +-- +-- +---------------------------------------------------------------------------- +module Miso.Html + ( module Miso.Html.Element + , module Miso.Html.Event + , module Miso.Html.Internal + , module Miso.Html.Property + ) where + +import Miso.Html.Element +import Miso.Html.Event +import Miso.Html.Internal +import Miso.Html.Property hiding (form_) diff --git a/src/Miso/Html/Element.hs b/src/Miso/Html/Element.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Html/Element.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Html.Element +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Html.Element + ( -- * Construct an Element + nodeHtml + , nodeHtmlKeyed + -- * Headers + , h1_ + , h2_ + , h3_ + , h4_ + , h5_ + , h6_ + -- * Grouping Content + , div_ + , p_ + , hr_ + , pre_ + , blockquote_ + -- * Text + , code_ + , em_ + , span_ + , a_ + , strong_ + , i_ + , b_ + , u_ + , sub_ + , sup_ + , br_ + -- * Lists + , ol_ + , ul_ + , li_ + , liKeyed_ + , dl_ + , dt_ + , dd_ + -- * Embedded Content + , img_ + , iframe_ + , canvas_ + , math_ + -- * Inputs + , select_ + , option_ + , textarea_ + , form_ + , input_ + , button_ + -- * Sections + , section_ + , header_ + , footer_ + , nav_ + , article_ + , aside_ + , address_ + , main_ + , body_ + -- * Figures + , figure_ + , figcaption_ + -- * Tables + , table_ + , caption_ + , colgroup_ + , col_ + , tbody_ + , thead_ + , tfoot_ + , tr_ + , td_ + , th_ + -- * Less common elements + , label_ + , fieldset_ + , legend_ + , datalist_ + , optgroup_ + , keygen_ + , output_ + , progress_ + , meter_ + -- * Audio and Video + , audio_ + , video_ + , source_ + , track_ + -- * Embedded objects + , embed_ + , object_ + , param_ + -- * Text edits + , ins_ + , del_ + -- * Semantic text + , small_ + , cite_ + , dfn_ + , abbr_ + , time_ + , var_ + , samp_ + , kbd_ + , q_ + , s_ + -- * Less common tags + , mark_ + , ruby_ + , rt_ + , rp_ + , bdi_ + , bdo_ + , wbr_ + -- * Interactive elemnts + , details_ + , summary_ + , menuitem_ + , menu_ + ) where + +import Miso.Html.Internal +import Miso.String (MisoString) + +-- | Used to construct `VNode`'s in `View` +nodeHtml :: MisoString -> [Attribute action] -> [View action] -> View action +nodeHtml = flip (node HTML) Nothing + +-- | Construct a node with a `Key` +nodeHtmlKeyed :: MisoString -> Key -> [Attribute action] -> [View action] -> View action +nodeHtmlKeyed name = node HTML name . pure + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/div +div_ :: [Attribute action] -> [View action] -> View action +div_ = nodeHtml "div" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/table +table_ :: [Attribute action] -> [View action] -> View action +table_ = nodeHtml "table" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/thead +thead_ :: [Attribute action] -> [View action] -> View action +thead_ = nodeHtml "thead" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/tbody +tbody_ :: [Attribute action] -> [View action] -> View action +tbody_ = nodeHtml "tbody" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/tr +tr_ :: [Attribute action] -> [View action] -> View action +tr_ = nodeHtml "tr" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/th +th_ :: [Attribute action] -> [View action] -> View action +th_ = nodeHtml "th" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/td +td_ :: [Attribute action] -> [View action] -> View action +td_ = nodeHtml "td" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/tfoot +tfoot_ :: [Attribute action] -> [View action] -> View action +tfoot_ = nodeHtml "tfoot" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/section +section_ :: [Attribute action] -> [View action] -> View action +section_ = nodeHtml "section" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/header +header_ :: [Attribute action] -> [View action] -> View action +header_ = nodeHtml "header" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/footer +footer_ :: [Attribute action] -> [View action] -> View action +footer_ = nodeHtml "footer" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/button +button_ :: [Attribute action] -> [View action] -> View action +button_ = nodeHtml "button" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/form +form_ :: [Attribute action] -> [View action] -> View action +form_ = nodeHtml "form" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/p +p_ :: [Attribute action] -> [View action] -> View action +p_ = nodeHtml "p" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/s +s_ :: [Attribute action] -> [View action] -> View action +s_ = nodeHtml "s" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ul +ul_ :: [Attribute action] -> [View action] -> View action +ul_ = nodeHtml "ul" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/span +span_ :: [Attribute action] -> [View action] -> View action +span_ = nodeHtml "span" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/strong +strong_ :: [Attribute action] -> [View action] -> View action +strong_ = nodeHtml "strong" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/li +li_ :: [Attribute action] -> [View action] -> View action +li_ = nodeHtml "li" + +-- | Contains `Key`, inteded to be used for child replacement patch +-- +-- +-- +liKeyed_ :: Key -> [Attribute action] -> [View action] -> View action +liKeyed_ = node HTML "li" . pure + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h1 +h1_ :: [Attribute action] -> [View action] -> View action +h1_ = nodeHtml "h1" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h2 +h2_ :: [Attribute action] -> [View action] -> View action +h2_ = nodeHtml "h2" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h3 +h3_ :: [Attribute action] -> [View action] -> View action +h3_ = nodeHtml "h3" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h4 +h4_ :: [Attribute action] -> [View action] -> View action +h4_ = nodeHtml "h4" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h5 +h5_ :: [Attribute action] -> [View action] -> View action +h5_ = nodeHtml "h5" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h6 +h6_ :: [Attribute action] -> [View action] -> View action +h6_ = nodeHtml "h6" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/hr +hr_ :: [Attribute action] -> [View action] -> View action +hr_ = nodeHtml "hr" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/pre +pre_ :: [Attribute action] -> [View action] -> View action +pre_ = nodeHtml "pre" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/input +input_ :: [Attribute action] -> [View action] -> View action +input_ = nodeHtml "input" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/label +label_ :: [Attribute action] -> [View action] -> View action +label_ = nodeHtml "label" + +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/a +a_ :: [Attribute action] -> [View action] -> View action +a_ = nodeHtml "a" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/mark +mark_ :: [Attribute action] -> [View action] -> View action +mark_ = nodeHtml "mark" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ruby +ruby_ :: [Attribute action] -> [View action] -> View action +ruby_ = nodeHtml "ruby" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/rt +rt_ :: [Attribute action] -> [View action] -> View action +rt_ = nodeHtml "rt" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/rp +rp_ :: [Attribute action] -> [View action] -> View action +rp_ = nodeHtml "rp" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/bdi +bdi_ :: [Attribute action] -> [View action] -> View action +bdi_ = nodeHtml "bdi" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/bdo +bdo_ :: [Attribute action] -> [View action] -> View action +bdo_ = nodeHtml "bdo" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/wbr +wbr_ :: [Attribute action] -> [View action] -> View action +wbr_ = nodeHtml "wbr" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/details +details_ :: [Attribute action] -> [View action] -> View action +details_ = nodeHtml "details" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/summary +summary_ :: [Attribute action] -> [View action] -> View action +summary_ = nodeHtml "summary" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/menuitem +menuitem_ :: [Attribute action] -> [View action] -> View action +menuitem_ = nodeHtml "menuitem" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/menu +menu_ :: [Attribute action] -> [View action] -> View action +menu_ = nodeHtml "menu" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/fieldset +fieldset_ :: [Attribute action] -> [View action] -> View action +fieldset_ = nodeHtml "fieldset" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/legend +legend_ :: [Attribute action] -> [View action] -> View action +legend_ = nodeHtml "legend" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/datalist +datalist_ :: [Attribute action] -> [View action] -> View action +datalist_ = nodeHtml "datalist" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/optgroup +optgroup_ :: [Attribute action] -> [View action] -> View action +optgroup_ = nodeHtml "optgroup" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/keygen +keygen_ :: [Attribute action] -> [View action] -> View action +keygen_ = nodeHtml "keygen" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/output +output_ :: [Attribute action] -> [View action] -> View action +output_ = nodeHtml "output" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/progress +progress_ :: [Attribute action] -> [View action] -> View action +progress_ = nodeHtml "progress" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/meter +meter_ :: [Attribute action] -> [View action] -> View action +meter_ = nodeHtml "meter" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/audio +audio_ :: [Attribute action] -> [View action] -> View action +audio_ = nodeHtml "audio" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/video +video_ :: [Attribute action] -> [View action] -> View action +video_ = nodeHtml "video" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/source +source_ :: [Attribute action] -> [View action] -> View action +source_ = nodeHtml "source" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/track +track_ :: [Attribute action] -> [View action] -> View action +track_ = nodeHtml "track" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/embed +embed_ :: [Attribute action] -> [View action] -> View action +embed_ = nodeHtml "embed" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/object +object_ :: [Attribute action] -> [View action] -> View action +object_ = nodeHtml "object" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/param +param_ :: [Attribute action] -> [View action] -> View action +param_ = nodeHtml "param" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ins +ins_ :: [Attribute action] -> [View action] -> View action +ins_ = nodeHtml "ins" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/del +del_ :: [Attribute action] -> [View action] -> View action +del_ = nodeHtml "del" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/small +small_ :: [Attribute action] -> [View action] -> View action +small_ = nodeHtml "small" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/cite +cite_ :: [Attribute action] -> [View action] -> View action +cite_ = nodeHtml "cite" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dfn +dfn_ :: [Attribute action] -> [View action] -> View action +dfn_ = nodeHtml "dfn" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/abbr +abbr_ :: [Attribute action] -> [View action] -> View action +abbr_ = nodeHtml "abbr" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/time +time_ :: [Attribute action] -> [View action] -> View action +time_ = nodeHtml "time" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/var +var_ :: [Attribute action] -> [View action] -> View action +var_ = nodeHtml "var" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/samp +samp_ :: [Attribute action] -> [View action] -> View action +samp_ = nodeHtml "samp" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/kbd +kbd_ :: [Attribute action] -> [View action] -> View action +kbd_ = nodeHtml "kbd" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/caption +caption_ :: [Attribute action] -> [View action] -> View action +caption_ = nodeHtml "caption" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/colgroup +colgroup_ :: [Attribute action] -> [View action] -> View action +colgroup_ = nodeHtml "colgroup" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/col +col_ :: [Attribute action] -> [View action] -> View action +col_ = nodeHtml "col" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/nav +nav_ :: [Attribute action] -> [View action] -> View action +nav_ = nodeHtml "nav" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/article +article_ :: [Attribute action] -> [View action] -> View action +article_ = nodeHtml "article" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/aside +aside_ :: [Attribute action] -> [View action] -> View action +aside_ = nodeHtml "aside" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/address +address_ :: [Attribute action] -> [View action] -> View action +address_ = nodeHtml "address" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/main +main_ :: [Attribute action] -> [View action] -> View action +main_ = nodeHtml "main" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/body +body_ :: [Attribute action] -> [View action] -> View action +body_ = nodeHtml "body" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/figure +figure_ :: [Attribute action] -> [View action] -> View action +figure_ = nodeHtml "figure" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/figcaption +figcaption_ :: [Attribute action] -> [View action] -> View action +figcaption_ = nodeHtml "figcaption" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dl +dl_ :: [Attribute action] -> [View action] -> View action +dl_ = nodeHtml "dl" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dt +dt_ :: [Attribute action] -> [View action] -> View action +dt_ = nodeHtml "dt" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dd +dd_ :: [Attribute action] -> [View action] -> View action +dd_ = nodeHtml "dd" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/img +img_ :: [Attribute action] -> [View action] -> View action +img_ = nodeHtml "img" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/iframe +iframe_ :: [Attribute action] -> [View action] -> View action +iframe_ = nodeHtml "iframe" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/canvas +canvas_ :: [Attribute action] -> [View action] -> View action +canvas_ = nodeHtml "canvas" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/math +math_ :: [Attribute action] -> [View action] -> View action +math_ = nodeHtml "math" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/select +select_ :: [Attribute action] -> [View action] -> View action +select_ = nodeHtml "select" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/option +option_ :: [Attribute action] -> [View action] -> View action +option_ = nodeHtml "option" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/textarea +textarea_ :: [Attribute action] -> [View action] -> View action +textarea_ = nodeHtml "textarea" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/sub +sub_ :: [Attribute action] -> [View action] -> View action +sub_ = nodeHtml "sub" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/sup +sup_ :: [Attribute action] -> [View action] -> View action +sup_ = nodeHtml "sup" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/br +br_ :: [Attribute action] -> [View action] -> View action +br_ = nodeHtml "br" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ol +ol_ :: [Attribute action] -> [View action] -> View action +ol_ = nodeHtml "ol" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/blockquote +blockquote_ :: [Attribute action] -> [View action] -> View action +blockquote_ = nodeHtml "blockquote" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/code +code_ :: [Attribute action] -> [View action] -> View action +code_ = nodeHtml "code" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/em +em_ :: [Attribute action] -> [View action] -> View action +em_ = nodeHtml "em" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/i +i_ :: [Attribute action] -> [View action] -> View action +i_ = nodeHtml "i" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/b +b_ :: [Attribute actbon] -> [View actbon] -> View actbon +b_ = nodeHtml "b" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/u +u_ :: [Attribute actuon] -> [View actuon] -> View actuon +u_ = nodeHtml "u" +-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/q +q_ :: [Attribute actqon] -> [View actqon] -> View actqon +q_ = nodeHtml "q" diff --git a/src/Miso/Html/Event.hs b/src/Miso/Html/Event.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Html/Event.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Html.Event +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +-- +---------------------------------------------------------------------------- +module Miso.Html.Event + ( -- * Custom event handlers + on + , onWithOptions + , Options (..) + , defaultOptions + -- * Mouse events + , onClick + , onDoubleClick + , onMouseDown + , onMouseUp + , onMouseEnter + , onMouseLeave + , onMouseOver + , onMouseOut + -- * Keyboard events + , onKeyDown + , onKeyPress + , onKeyUp + -- * Form events + , onInput + , onChecked + , onSubmit + -- * Focus events + , onBlur + , onFocus + -- * Drag events + , onDrag + , onDragLeave + , onDragEnter + , onDragEnd + , onDragStart + , onDragOver + -- * Drop events + , onDrop + ) where + +import Miso.Html.Internal ( Attribute, on, onWithOptions ) +import Miso.Event +import Miso.String (MisoString) + +-- | `blur` event defined with custom options +-- +-- +-- +onBlur :: action -> Attribute action +onBlur action = on "blur" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/change +onChecked :: (Checked -> action) -> Attribute action +onChecked = on "change" checkedDecoder + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/click +onClick :: action -> Attribute action +onClick action = on "click" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/focus +onFocus :: action -> Attribute action +onFocus action = on "focus" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/dblclick +onDoubleClick :: action -> Attribute action +onDoubleClick action = on "dblclick" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/input +onInput :: (MisoString -> action) -> Attribute action +onInput = on "input" valueDecoder + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/keydown +onKeyDown :: (KeyCode -> action) -> Attribute action +onKeyDown = on "keydown" keycodeDecoder + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/keypress +onKeyPress :: (KeyCode -> action) -> Attribute action +onKeyPress = on "keypress" keycodeDecoder + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/keyup +onKeyUp :: (KeyCode -> action) -> Attribute action +onKeyUp = on "keyup" keycodeDecoder + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/mouseup +onMouseUp :: action -> Attribute action +onMouseUp action = on "mouseup" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/mousedown +onMouseDown :: action -> Attribute action +onMouseDown action = on "mousedown" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/mouseenter +onMouseEnter :: action -> Attribute action +onMouseEnter action = on "mouseenter" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/mouseleave +onMouseLeave :: action -> Attribute action +onMouseLeave action = on "mouseleave" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/mouseover +onMouseOver :: action -> Attribute action +onMouseOver action = on "mouseover" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/mouseout +onMouseOut :: action -> Attribute action +onMouseOut action = on "mouseout" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/dragstart +onDragStart :: action -> Attribute action +onDragStart action = on "dragstart" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/dragover +onDragOver :: action -> Attribute action +onDragOver action = on "dragover" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/dragend +onDragEnd :: action -> Attribute action +onDragEnd action = on "dragend" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/dragenter +onDragEnter :: action -> Attribute action +onDragEnter action = on "dragenter" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/dragleave +onDragLeave :: action -> Attribute action +onDragLeave action = on "dragleave" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/drag +onDrag :: action -> Attribute action +onDrag action = on "drag" emptyDecoder $ \() -> action + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/drop +onDrop :: AllowDrop -> action -> Attribute action +onDrop (AllowDrop allowDrop) action = + onWithOptions defaultOptions { preventDefault = allowDrop } + "drop" emptyDecoder (\() -> action) + +-- | https://developer.mozilla.org/en-US/docs/Web/Events/submit +onSubmit :: action -> Attribute action +onSubmit action = + onWithOptions defaultOptions { preventDefault = True } + "submit" emptyDecoder $ \() -> action diff --git a/src/Miso/Html/Property.hs b/src/Miso/Html/Property.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Html/Property.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Html.Property +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +-- +-- Construct custom properties on DOM elements +-- +-- > div_ [ prop "id" "foo" ] [ ] +-- +---------------------------------------------------------------------------- +module Miso.Html.Property + ( -- * Construction + textProp + , stringProp + , boolProp + , intProp + , integerProp + , doubleProp + -- * Common attributes + , class_ + , classList_ + , id_ + , title_ + , hidden_ + -- * Inputs + , type_ + , value_ + , defaultValue_ + , checked_ + , placeholder_ + , selected_ + -- * Input Helpers + , accept_ + , acceptCharset_ + , action_ + , autocomplete_ + , autofocus_ + , autosave_ + , disabled_ + , enctype_ + , formation_ + , list_ + , maxlength_ + , minlength_ + , method_ + , multiple_ + , name_ + , novalidate_ + , pattern_ + , readonly_ + , required_ + , size_ + , for_ + , form_ + -- * Input Ranges + , max_ + , min_ + , step_ + -- * Input Text areas + , cols_ + , rows_ + , wrap_ + -- * Links and areas + , href_ + , target_ + , download_ + , downloadAs_ + , hreflang_ + , media_ + , ping_ + , rel_ + -- * Maps + , ismap_ + , usemap_ + , shape_ + , coords_ + -- * Embedded Content + , src_ + , height_ + , width_ + , alt_ + -- * Audio and Video + , autoplay_ + , controls_ + , loop_ + , preload_ + , poster_ + , default_ + , kind_ + , srclang_ + -- * iframes + , sandbox_ + , seamless_ + , srcdoc_ + -- * Ordered lists + , reversed_ + , start_ + -- * Tables + , align_ + , colspan_ + , rowspan_ + , headers_ + , scope_ + -- * Headers + , async_ + , charset_ + , content_ + , defer_ + , httpEquiv_ + , language_ + , scoped_ + ) where + +import Miso.Html.Internal +import Miso.String (MisoString, intercalate) + +-- | Set field to `Bool` value +boolProp :: MisoString -> Bool -> Attribute action +boolProp = prop +-- | Set field to `String` value +stringProp :: MisoString -> String -> Attribute action +stringProp = prop +-- | Set field to `Text` value +textProp :: MisoString -> MisoString -> Attribute action +textProp = prop +-- | Set field to `Int` value +intProp :: MisoString -> Int -> Attribute action +intProp = prop +-- | Set field to `Integer` value +integerProp :: MisoString -> Int -> Attribute action +integerProp = prop +-- | Set field to `Double` value +doubleProp :: MisoString -> Double -> Attribute action +doubleProp = prop +-- | Define multiple classes conditionally +-- +-- > div_ [ classList_ [ ("empty", null items) ] [ ] +-- +classList_ :: [(MisoString, Bool)] -> Attribute action +classList_ xs = + textProp "class" $ intercalate (" " :: MisoString) [ t | (t, True) <- xs ] +-- | +title_ :: MisoString -> Attribute action +title_ = textProp "title" +-- | +selected_ :: Bool -> Attribute action +selected_ = boolProp "selected" +-- |