+
+
+
+
+
+
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
@@ -27,6 +27,7 @@
, clearBody
, objectToJSON
, getWindow
+ , set
) where
import Control.Monad
@@ -46,6 +47,10 @@
import JavaScript.Array.Internal
import qualified JavaScript.Object.Internal as OI
import Unsafe.Coerce
+
+-- | Set property on object
+set :: ToJSVal v => JSString -> v -> OI.Object -> IO ()
+set k v obj = toJSVal v >>= \x -> OI.setProp k x obj
-- | Convert JSVal to Maybe `Value`
jsvalToValue :: JSVal -> IO (Maybe Value)
diff --git a/ghcjs-src/Miso/Html/Internal.hs b/ghcjs-src/Miso/Html/Internal.hs
--- a/ghcjs-src/Miso/Html/Internal.hs
+++ b/ghcjs-src/Miso/Html/Internal.hs
@@ -96,9 +96,6 @@
-- | 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
-
-- | `ToJSVal` instance for `Decoder`
instance ToJSVal DecodeTarget where
toJSVal (DecodeTarget xs) = toJSVal xs
diff --git a/ghcjs-src/Miso/Subscription/Keyboard.hs b/ghcjs-src/Miso/Subscription/Keyboard.hs
--- a/ghcjs-src/Miso/Subscription/Keyboard.hs
+++ b/ghcjs-src/Miso/Subscription/Keyboard.hs
@@ -45,7 +45,7 @@
-- | Helper function to convert keys currently pressed to `Arrow`, given a
-- mapping for keys representing up, down, left and right respectively.
toArrows :: ([Int], [Int], [Int], [Int]) -> Set Int -> Arrows
-toArrows (up, down, left, right) set =
+toArrows (up, down, left, right) set' =
Arrows {
arrowX =
case (check left, check right) of
@@ -59,7 +59,7 @@
(_,_) -> 0
}
where
- check = any (`S.member` set)
+ check = any (`S.member` set')
-- | Maps `Arrows` onto a Keyboard subscription
arrowsSub :: (Arrows -> action) -> Sub action
diff --git a/ghcjs-src/Miso/Subscription/WebSocket.hs b/ghcjs-src/Miso/Subscription/WebSocket.hs
--- a/ghcjs-src/Miso/Subscription/WebSocket.hs
+++ b/ghcjs-src/Miso/Subscription/WebSocket.hs
@@ -52,6 +52,7 @@
| WebSocketClose CloseCode WasClean Reason
| WebSocketOpen
| WebSocketError MisoString
+ deriving (Show, Eq)
websocket :: IORef (Maybe Socket)
{-# NOINLINE websocket #-}
diff --git a/miso.cabal b/miso.cabal
--- a/miso.cabal
+++ b/miso.cabal
@@ -1,5 +1,5 @@
name: miso
-version: 0.18.0.0
+version: 0.19.0.0
category: Web, Miso, Data Structures
license: BSD3
license-file: LICENSE
@@ -27,12 +27,6 @@
description:
Builds Miso's examples
-flag tests
- default:
- False
- description:
- Builds Miso's tests
-
executable todo-mvc
main-is:
Main.hs
@@ -215,7 +209,7 @@
executable tests
main-is:
Main.hs
- if !impl(ghcjs) || !flag(tests)
+ if !impl(ghcjs)
buildable: False
else
hs-source-dirs:
@@ -226,8 +220,6 @@
aeson,
base < 5,
bytestring,
- hspec,
- hspec-core,
ghcjs-base,
QuickCheck,
quickcheck-instances,
diff --git a/src/Miso/Html/Element.hs b/src/Miso/Html/Element.hs
--- a/src/Miso/Html/Element.hs
+++ b/src/Miso/Html/Element.hs
@@ -476,13 +476,13 @@
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_ :: [Attribute action] -> [View action] -> View action
b_ = nodeHtml "b"
-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/u
-u_ :: [Attribute actuon] -> [View actuon] -> View actuon
+u_ :: [Attribute action] -> [View action] -> View action
u_ = nodeHtml "u"
-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/q
-q_ :: [Attribute actqon] -> [View actqon] -> View actqon
+q_ :: [Attribute action] -> [View action] -> View action
q_ = nodeHtml "q"
-- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/script
script_ :: [Attribute action] -> [View action] -> View action
diff --git a/tests/Main.hs b/tests/Main.hs
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -1,25 +1,30 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
module Main where
+import Control.Exception hiding (assert)
import Control.Monad
-import Data.Aeson
-import qualified Data.HashMap.Strict as H
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.State
+import Data.Aeson hiding (Result(..))
+import qualified Data.HashMap.Strict as H
import Data.Scientific
-import qualified Data.Vector as V
+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 GHCJS.Types
+import qualified JavaScript.Object.Internal as OI
+import System.IO.Unsafe
import Test.QuickCheck
import Test.QuickCheck.Instances
+import Test.QuickCheck.Monadic
import Miso
import Miso.FFI
-import System.IO.Unsafe
instance Arbitrary Value where
arbitrary = sized sizedArbitraryValue
@@ -51,17 +56,12 @@
in relDiff <= 0.00001
main :: IO ()
-main = do
- Summary { summaryFailures } <- hspecResult tests
- phantomExit summaryFailures
-
-tests :: Spec
-tests = do
+main = runTests $ do
storageTests
roundTripJSVal
-storageTests :: Spec
-storageTests = describe "Storage tests" $ do
+storageTests :: TestM ()
+storageTests = do
it "should write to and read from local storage" $ do
let obj = object [ "foo" .= ("bar" :: String) ]
setLocalStorage "foo" obj
@@ -73,20 +73,108 @@
Right r <- getLocalStorage "foo"
r `shouldBe` obj
+roundTripJSVal :: TestM ()
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)
+ propTest iso_prop
-phantomExit :: Int -> IO ()
-phantomExit x
- | x <= 0 = phantomExitSuccess
- | otherwise = phantomExitFail
+roundTrip
+ :: Value
+ -> IO Bool
+roundTrip x = do
+ Just y <- jsvalToValue =<< toJSVal x
+ pure $ compareValue x y == True
-foreign import javascript unsafe "phantom.exit(0);"
- phantomExitSuccess :: IO ()
+iso_prop :: Value -> Property
+iso_prop = monadicIO . run . roundTrip
-foreign import javascript unsafe "phantom.exit(1);"
- phantomExitFail :: IO ()
+propTest :: Testable prop => prop -> IO (Bool, String)
+propTest prop = do
+ r <- flip quickCheckWithResult prop stdArgs { chatty = False }
+ pure $ case r of
+ Success { output = o } -> (True, o)
+ GaveUp { output = o } -> (False, o)
+ Failure { output = o } -> (False, o)
+ NoExpectedFailure { output = o } -> (False, o)
+ InsufficientCoverage { output = o } -> (False, o)
+
+foreign import javascript unsafe "window.global_test_results = $1;"
+ writeToGlobalObject :: JSVal -> IO ()
+
+runTests :: TestM () -> IO ()
+runTests t = do
+ results <- toJSVal =<< toResult <$> execStateT t []
+ consoleLog results
+ writeToGlobalObject results
+ where
+ toResult :: [Test] -> TestResult
+ toResult xs = TestResult failed' passed' total' duration' xs
+ where
+ passed' = length (filter result xs)
+ failed' = length (filter (not . result) xs)
+ total' = length xs
+ duration' = sum (map duration xs)
+
+instance ToJSVal TestResult where
+ toJSVal t = do
+ o@(OI.Object j) <- OI.create
+ set "passed" (passed t) o
+ set "failed" (failed t) o
+ set "total" (total t) o
+ set "duration" (duration' t) o
+ set "tests" (tests t) o
+ pure j
+
+instance ToJSVal Test where
+ toJSVal t = do
+ o@(OI.Object j) <- OI.create
+ set "name" (name t) o
+ set "result" (result t) o
+ set "message" (message t) o
+ set "duration" (duration t) o
+ pure j
+
+it :: String -> IO (Bool, String) -> TestM ()
+it name test = do
+ (result, msg, time) <- liftIO $ (do
+ ((x,msg),t) <- clock test
+ pure (x,msg,t))
+ `catch` (\(e :: SomeException) ->
+ pure (False, show e, 0))
+ modify (Test name result msg time:)
+
+data TestResult
+ = TestResult
+ { failed :: Int
+ , passed :: Int
+ , total :: Int
+ , duration' :: Double
+ , tests :: [Test]
+ } deriving (Show, Eq)
+
+data Test
+ = Test
+ { name :: String
+ , result :: Bool
+ , message :: String
+ , duration :: Double
+ } deriving (Show, Eq)
+
+type TestM a = StateT [Test] IO a
+
+shouldBe :: (Show a, Eq a, Applicative f) => a -> a -> f (Bool, String)
+shouldBe x y =
+ pure $
+ if x == y
+ then (True, mempty)
+ else (False, "Expecting: " ++ show y ++ " but got: " ++ show x)
+
+infix 0 `shouldBe`
+
+-- | Measure in seconds
+clock :: IO a -> IO (a, Double)
+clock action = do
+ start <- now
+ x <- action
+ stop <- now
+ pure (x, (stop - start) / 1000)