diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -46,6 +46,7 @@ - [TodoMVC](#todomvc) - [Flatris](#flatris) - [2048](#2048) + - [Snake](#snake) - [Mario](#mario) - [Websocket](#websocket) - [SSE](#sse) @@ -298,6 +299,9 @@ ### 2048 - [Link](http://2048.haskell-miso.org/) / [Source](https://github.com/ptigwe/hs2048/) +### Snake + - [Link](http://snake.haskell-miso.org/) / [Source](https://github.com/lbonn/miso-snake) + ### Mario - [Link](https://mario.haskell-miso.org/) / [Source](https://github.com/dmjio/miso/blob/master/examples/mario/Main.hs) @@ -338,15 +342,16 @@ ## Sample application ```haskell --- | Haskell language pragmas +-- | Haskell language pragma {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} -- | Haskell module declaration module Main where -- | Miso framework import import Miso +import Miso.String -- | Type synonym for an application model type Model = Int @@ -364,11 +369,11 @@ main = startApp App {..} where initialAction = SayHelloWorld -- initial action to be executed on application load - model = 0 -- initial model - update = updateModel -- update function - view = viewModel -- view function - events = defaultEvents -- default delegated events - subs = [] -- empty subscription list + model = 0 -- initial model + update = updateModel -- update function + view = viewModel -- view function + events = defaultEvents -- default delegated events + subs = [] -- empty subscription list -- | Updates model, optionally introduces side effects updateModel :: Action -> Model -> Effect Action Model @@ -382,7 +387,7 @@ viewModel :: Model -> View Action viewModel x = div_ [] [ button_ [ onClick AddOne ] [ text "+" ] - , text $ toMisoString (show x) + , text (ms (show x)) , button_ [ onClick SubtractOne ] [ text "-" ] ] ``` diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs --- a/ghcjs-src/Miso.hs +++ b/ghcjs-src/Miso.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -121,7 +122,7 @@ :: (action -> IO ()) -> (action -> model -> Effect action model) -> (model, IO ()) -> action -> (model, IO ()) -foldEffects sink update = \(model, as) action -> +foldEffects sink update = \(!model, !as) action -> case update action model of Effect newModel effs -> (newModel, newAs) where diff --git a/ghcjs-src/Miso/FFI.hs b/ghcjs-src/Miso/FFI.hs --- a/ghcjs-src/Miso/FFI.hs +++ b/ghcjs-src/Miso/FFI.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} @@ -28,18 +29,21 @@ 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 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 qualified Data.JSString.Text as JSS +import Data.Maybe import Data.Scientific -import qualified Data.Vector as V +import qualified Data.Vector as V import GHCJS.Foreign.Callback import GHCJS.Foreign.Internal import GHCJS.Marshal import GHCJS.Types +import JavaScript.Array.Internal import qualified JavaScript.Object.Internal as OI +import Unsafe.Coerce -- | Convert JSVal to Maybe `Value` jsvalToValue :: JSVal -> IO (Maybe Value) @@ -52,12 +56,16 @@ <$> fromJSVal r JSONBool -> liftM AE.Bool <$> fromJSVal r JSONString -> liftM AE.String <$> fromJSVal r - JSONArray -> liftM (Array . V.fromList) <$> fromJSVal r + JSONArray -> do + xs :: [Value] <- + catMaybes <$> + forM (toList (unsafeCoerce r)) jsvalToValue + pure . pure $ Array . V.fromList $ xs JSONObject -> do - Just props<- fromJSVal =<< getKeys (OI.Object r) + Just (props :: [JSString]) <- fromJSVal =<< getKeys (OI.Object r) runMaybeT $ do propVals <- forM props $ \p -> do - v <- MaybeT (fromJSVal =<< OI.getProp p (OI.Object r)) + v <- MaybeT (jsvalToValue =<< OI.getProp p (OI.Object r)) return (JSS.textFromJSString p, v) return (AE.Object (H.fromList propVals)) diff --git a/jsbits/diff.js b/jsbits/diff.js --- a/jsbits/diff.js +++ b/jsbits/diff.js @@ -80,7 +80,7 @@ node.setAttributeNS("http://www.w3.org/1999/xlink", "class", newProp); else node.setAttribute(c, newProp); - } else if (c in node) { + } else if (c in node && !(c === "list" || c === "form")) { node[c] = newProp; } else { node.setAttribute(c, newProp); @@ -99,7 +99,7 @@ node.setAttributeNS("http://www.w3.org/1999/xlink", "class", newProp); else node.setAttribute(n, newProp); - } else if (n in node) { + } else if (n in node && !(n === "list" || n === "form")) { node[n] = nProps[n]; } else { node.setAttribute(n, newProp); diff --git a/miso.cabal b/miso.cabal --- a/miso.cabal +++ b/miso.cabal @@ -1,5 +1,5 @@ name: miso -version: 0.7.5.0 +version: 0.7.6.0 category: Web, Miso, Data Structures license: BSD3 license-file: LICENSE @@ -220,14 +220,29 @@ buildable: False else hs-source-dirs: - tests + tests, ghcjs-src, src + other-modules: + Miso.FFI build-depends: aeson, base < 5, - miso, + bytestring, hspec, hspec-core, - ghcjs-base + ghcjs-base, + QuickCheck, + quickcheck-instances, + miso, + http-types, + network-uri, + http-api-data, + containers, + scientific, + servant, + text, + unordered-containers, + transformers, + vector default-language: Haskell2010 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,16 +1,55 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} +module Main where +import Control.Monad +import Data.Aeson +import qualified Data.HashMap.Strict as H +import Data.Scientific +import qualified Data.Vector as V +import Debug.Trace +import GHCJS.Marshal +import Test.Hspec (it, hspec, describe, shouldSatisfy, shouldBe, Spec) +import Test.Hspec.Core.Runner (hspecResult, Summary(..)) +import Test.QuickCheck +import Test.QuickCheck.Instances -module Main where +import Miso +import Miso.FFI +import System.IO.Unsafe -import Test.Hspec (it, hspec, describe, shouldSatisfy, shouldBe, Spec) -import Test.Hspec.Core.Runner (hspecResult, Summary(..)) -import Data.Aeson +instance Arbitrary Value where + arbitrary = sized sizedArbitraryValue -import Miso +sizedArbitraryValue :: Int -> Gen Value +sizedArbitraryValue n + | n <= 0 = oneof [pure Null, bool, number, string] + | otherwise = resize n' $ oneof [pure Null, bool, string, number, array, object'] + where + n' = n `div` 2 + bool = Bool <$> arbitrary + number = Number <$> arbitrary + string = String <$> arbitrary + array = Array <$> arbitrary + object' = Object <$> arbitrary +compareValue :: Value -> Value -> Bool +compareValue (Object x) (Object y) = and $ zipWith compareValue (H.elems x) (H.elems y) +compareValue (Array x) (Array y) = and $ zipWith compareValue (V.toList x) (V.toList y) +compareValue (String x) (String y) = x == y +compareValue (Bool x) (Bool y) = x == y +compareValue Null Null = True +compareValue (Number x) (Number y) = closeEnough x y +compareValue _ _ = False + +closeEnough x y + = let d = max (abs x) (abs y) + relDiff = if (d == 0.0) then d else abs (x - y) / d + in relDiff <= 0.00001 + main :: IO () main = do Summary { summaryFailures } <- hspecResult tests @@ -19,6 +58,7 @@ tests :: Spec tests = do storageTests + roundTripJSVal storageTests :: Spec storageTests = describe "Storage tests" $ do @@ -32,6 +72,13 @@ setSessionStorage "foo" obj Right r <- getLocalStorage "foo" r `shouldBe` obj + +roundTripJSVal = + describe "Serialization tests" $ do + it "Should round trip JSVal" $ do + property $ (\(x :: Value) -> do + Just y <- jsvalToValue =<< toJSVal x + compareValue x y `shouldBe` True) phantomExit :: Int -> IO () phantomExit x