Merge pull request #290 from haskell-miso/jsvalToValue

jsvalToValue

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))
 

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";

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
 

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