From f5c5e5e61612c7f9333087c8a12854030257be95 Mon Sep 17 00:00:00 2001 From: David Johnson Date: Tue, 19 Sep 2017 19:22:58 +0000 Subject: [PATCH] Initial commit of jsvalToValue fixes, QuickCheck tests added --- ghcjs-src/Miso/FFI.hs | 24 ++++++++++++------ miso-ghcjs.nix | 4 +-- miso.cabal | 21 +++++++++++++--- tests/Main.hs | 57 +++++++++++++++++++++++++++++++++++++++---- 4 files changed, 88 insertions(+), 18 deletions(-) diff --git a/ghcjs-src/Miso/FFI.hs b/ghcjs-src/Miso/FFI.hs index 53b97602..056e1fb6 100644 --- 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 @@ module Miso.FFI 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 @@ jsvalToValue r = do <$> 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/miso-ghcjs.nix b/miso-ghcjs.nix index 9e50ee60..41adf06a 100644 --- a/miso-ghcjs.nix +++ b/miso-ghcjs.nix @@ -1,7 +1,7 @@ { mkDerivation, aeson, base, bytestring, containers, ghcjs-base , network-uri, scientific, stdenv, text, transformers , unordered-containers, vector, hspec, hspec-core, servant -, http-types, http-api-data +, http-types, http-api-data, QuickCheck, quickcheck-instances }: mkDerivation { pname = "miso"; @@ -12,7 +12,7 @@ mkDerivation { libraryHaskellDepends = [ aeson base bytestring containers ghcjs-base network-uri scientific text transformers unordered-containers vector hspec hspec-core servant - http-types http-api-data + http-types http-api-data QuickCheck quickcheck-instances ]; homepage = "http://github.com/dmjio/miso"; description = "A tasty Haskell front-end framework"; diff --git a/miso.cabal b/miso.cabal index 785dd012..0317ee26 100644 --- a/miso.cabal +++ b/miso.cabal @@ -220,14 +220,29 @@ executable tests 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 index 8df5f87e..61542562 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,15 +1,54 @@ +{-# 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 + +instance Arbitrary Value where + arbitrary = sized sizedArbitraryValue -import Test.Hspec (it, hspec, describe, shouldSatisfy, shouldBe, Spec) -import Test.Hspec.Core.Runner (hspecResult, Summary(..)) -import Data.Aeson +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 -import Miso +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 @@ -19,6 +58,7 @@ main = do tests :: Spec tests = do storageTests + roundTripJSVal storageTests :: Spec storageTests = describe "Storage tests" $ do @@ -33,6 +73,13 @@ storageTests = describe "Storage tests" $ do 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 | x <= 0 = phantomExitSuccess