diff --git a/examples/canvas/Main.hs b/examples/canvas/Main.hs --- a/examples/canvas/Main.hs +++ b/examples/canvas/Main.hs @@ -80,7 +80,7 @@ c # moveTo (100,150) c # lineTo (450,50) c # closePath - c # setLineWidth 15 + c # lineWidth := 15 c # stroke example_1_2_3 :: JSObject -> JSCanvas -> JSA () @@ -89,8 +89,8 @@ c # moveTo (100,150) c # lineTo (450,50) c # closePath - c # setLineWidth 5 - c # setStrokeStyle "#ff0000" + c # lineWidth := 5 + c # strokeStyle := "#ff0000" c # stroke example_1_2_4 :: JSObject -> JSCanvas -> JSA () @@ -102,9 +102,9 @@ c # moveTo (200, h / 2 + n) c # lineTo (w - 200, h / 2 + n) c # closePath - c # setLineWidth 20 - c # setStrokeStyle "#0000ff" - c # setLineCap cap + c # lineWidth := 20 + c # strokeStyle := "#0000ff" + c # lineCap := cap c # stroke | (cap,n) <- zip ["butt","round","square"] [-50,0,50] ] @@ -122,8 +122,8 @@ c # beginPath c # arc' (centerX, centerY) radius (startingAngle, endingAngle) counterclockwise c # closePath - c # setLineWidth 15 - c # setStrokeStyle "black" + c # lineWidth := 15 + c # strokeStyle := "black" c # stroke example_1_5_4 :: JSObject -> JSCanvas -> JSA () @@ -135,28 +135,28 @@ let radius = 70 c # beginPath c # arc' (centerX, centerY) radius (0, 2 * pi) false - c # setFillStyle "#8ED6FF" + c # fillStyle := "#8ED6FF" c # fill - c # setLineWidth 5 - c # setStrokeStyle "black" + c # lineWidth := 5 + c # strokeStyle := "black" c # stroke example_1_8_1 :: JSObject -> JSCanvas -> JSA () example_1_8_1 canvas c = do - c # setFont "40pt Calibri" + c # font := "40pt Calibri" c # fillText "Hello World!" (150, 100) example_1_8_2 :: JSObject -> JSCanvas -> JSA () example_1_8_2 canvas c = do - c # setFont "40pt Calibri" - c # setFillStyle "#0000ff" + c # font := "40pt Calibri" + c # fillStyle := "#0000ff" c # fillText "Hello World!" (150, 100) example_1_8_3 :: JSObject -> JSCanvas -> JSA () example_1_8_3 canvas c = do - c # setFont "60pt Calibri" - c # setLineWidth 3 - c # setStrokeStyle "blue" + c # font := "60pt Calibri" + c # lineWidth := 3 + c # strokeStyle := "blue" c # strokeText "Hello World!" (80, 110) example_1_8_4 :: JSObject -> JSCanvas -> JSA () @@ -166,21 +166,21 @@ let x = w / 2 let y = h / 2 -- Draw alignment line - c # setStrokeStyle "red" + c # strokeStyle := "red" c # beginPath c # moveTo (x, 0) c # lineTo (x, h) c # closePath - c # setLineWidth 1 + c # lineWidth := 1 c # stroke -- Draw text - c # setFont "30px Calibri" - c # setTextBaseline "top" - c # setFillStyle "blue" + c # font := "30px Calibri" + c # textBaseline := "top" + c # fillStyle := "blue" -- Function to draw baseline identifier on its baseline. let textFun :: JSString -> JSNumber -> JSA JSNumber textFun al offset = do - c # setTextAlign al + c # textAlign := al c # fillText al (x, offset) return $ offset + 30 -- Line the different identifiers up after each other. @@ -192,21 +192,21 @@ h <- evaluate $ canvas ! height let y = h / 2 -- Draw baseline - c # setStrokeStyle "red" + c # strokeStyle := "red" c # beginPath c # moveTo (0, y) c # lineTo (w, y) c # closePath - c # setLineWidth 1 + c # lineWidth := 1 c # stroke -- Draw text - c # setFont "15pt Calibri" - c # setTextAlign "left" - c # setFillStyle "blue" + c # font := "15pt Calibri" + c # textAlign := "left" + c # fillStyle := "blue" -- Function to draw baseline identifier on its baseline. let textFun :: JSString -> JSNumber -> JSA JSNumber textFun bl offset = do - c # setTextBaseline bl + c # textBaseline := bl c # fillText bl (offset, y) tm <- c # measureText bl return $ offset + (tm ! width) @@ -228,9 +228,9 @@ message :: JSObject -> JSCanvas -> JSString -> JSA () message canvas c msg = do c # save - c # setFont "30pt Calibri" - c # setTextAlign "left" - c # setTextBaseline "alphabetic" - c # setFillStyle "#8090a0" + c # font := "30pt Calibri" + c # textAlign := "left" + c # textBaseline := "alphabetic" + c # fillStyle := "#8090a0" c # fillText msg (10, (canvas ! height) - 10) c # restore diff --git a/examples/clock/Main.hs b/examples/clock/Main.hs --- a/examples/clock/Main.hs +++ b/examples/clock/Main.hs @@ -46,8 +46,8 @@ (c # lineTo (0, -u * 0.8)) -- Minute line (c # lineTo (0, -u * 0.9)) -- Hour line ifB (n `mod` 15 ==* 0) - (c # setLineWidth 8) -- Quarter line - (c # setLineWidth 3) -- Non-Quarter line + (c # lineWidth := 8) -- Quarter line + (c # lineWidth := 3) -- Non-Quarter line c # stroke c # closePath -- Draw of the hour numbers @@ -62,9 +62,9 @@ -- Renders a single clock pointer. renderClockPointer <- function $ \(c :: JSCanvas, u :: JSNumber, angle :: JSNumber, width :: JSNumber, len :: JSNumber) -> do c # save - c # setLineCap "round" + c # lineCap := "round" c # rotate angle - c # setLineWidth width + c # lineWidth := width c # beginPath c # moveTo (0, u * 0.1) c # lineTo (0, -u * len) @@ -75,7 +75,7 @@ renderClockPointers <- function $ \(c :: JSCanvas, u :: JSNumber) -> do (h, m, s) <- currentTime c # save - c # setLineCap "round" + c # lineCap := "round" -- Hour pointer renderClockPointer $$ (c, u, (2 * pi / 12) * ((h `mod` 12) + (m `mod` 60) / 60), 15, 0.4) @@ -83,7 +83,7 @@ renderClockPointer $$ ( c, u, (2 * pi / 60) * ((m `mod` 60) + (s `mod` 60) / 60), 10, 0.7) -- Second pointer - c # setStrokeStyle "red" + c # strokeStyle := "red" renderClockPointer $$ ( c, u, (2 * pi / 60) * (s `mod` 60), 4, 0.9) -- Restore everything c # restore @@ -108,12 +108,12 @@ c <- context -- Basic setup c # save - c # setFillStyle "black" - c # setStrokeStyle "black" - c # setLineCap "round" - c # setTextAlign "center" - c # setFont ((cast $ u * 0.1) <> "px serif") - c # setTextBaseline "top" + c # fillStyle := "black" + c # strokeStyle := "black" + c # lineCap := "round" + c # textAlign := "center" + c # font := ((cast $ u * 0.1) <> "px serif") + c # textBaseline := "top" c # clearRect (0,0) (w,h) c # translate (w / 2, h / 2) -- Draw all hour lines. diff --git a/examples/unit/Main.hs b/examples/unit/Main.hs --- a/examples/unit/Main.hs +++ b/examples/unit/Main.hs @@ -37,6 +37,7 @@ import Language.Sunroof.JS.Object import Language.Sunroof.JS.Array as A import Language.Sunroof.Classes +import qualified Language.Sunroof.JS.Map as M import System.Random import System.IO @@ -116,8 +117,12 @@ , Test 100 "Arbitrary Boolean" (checkArbitraryBool doc) ]) , ("Conditionals", - [ Test 10 "if/then/else -> Int (A)" (checkArbitraryIfThenElse_Int doc tA) - , Test 10 "if/then/else -> Int (B)" (checkArbitraryIfThenElse_Int doc tB) + [ Test 10 "if/then/else -> Int (A)" (checkArbitraryIfThenElse_Int doc tA) + , Test 10 "if/then/else -> Int (B)" (checkArbitraryIfThenElse_Int doc tB) + , Test 10 "if/then/else -> () (A)" (checkArbitraryIfThenElse_Unit doc tA) + , Test 10 "if/then/else -> () (B)" (checkArbitraryIfThenElse_Unit doc tB) + , Test 10 "if/then/else -> (Int,Int) (A)" (checkArbitraryIfThenElse_Int_Int doc tA) + , Test 10 "if/then/else -> (Int,Int) (B)" (checkArbitraryIfThenElse_Int_Int doc tB) ]) , ("Uplink & Downlink", [ Test 100 "Constant String" (checkDownlinkUplink' doc (==) :: String -> Property) @@ -126,6 +131,7 @@ ]) , ("Data Structures", [ Test 100 "Array" (checkArbitraryArray doc) + , Test 100 "Map" (checkArbitraryMap doc) ] ) , ("Channels and MVars", @@ -161,6 +167,7 @@ checkConstValue :: ( Eq a , SunroofValue a , SunroofResult (ValueOf a) + , Sunroof (ValueOf a) , a ~ ResultOf (ValueOf a) ) => TestEngine -> a -> Property checkConstValue doc n = monadicIO $ do @@ -201,6 +208,7 @@ b' <- run $ syncJS (srEngine doc) (return e) assert $ b == b' +-- TODO: add an effect to the if/then/else's checkArbitraryIfThenElse_Int :: forall t . (SunroofThread t) => TestEngine -> ThreadProxy t -> Int -> Property checkArbitraryIfThenElse_Int doc ThreadProxy seed = monadicIO $ do let n = (abs seed `mod` 8) + 1 @@ -216,6 +224,36 @@ r12' <- run $ syncJS (srEngine doc) (ifB e (return e1) (return e2) >>= return :: JS t JSNumber) assert $ (if b then r1 else r2) == r12' +-- TODO: add an effect to the if/then/else's +checkArbitraryIfThenElse_Int_Int :: forall t . (SunroofThread t) => TestEngine -> ThreadProxy t -> Int -> Property +checkArbitraryIfThenElse_Int_Int doc ThreadProxy seed = monadicIO $ do + let n = (abs seed `mod` 8) + 1 + (b, e) <- pick $ sameSeed (boolExprGen n :: Gen Bool) + (boolExprGen n :: Gen JSBool) + (r1, e1) <- pick $ sameSeed (numExprGen n :: Gen Double) + (numExprGen n :: Gen JSNumber) + (r2, e2) <- pick $ sameSeed (numExprGen n :: Gen Double) + (numExprGen n :: Gen JSNumber) + pre $ abs r1 < (1000000 :: Double) + pre $ abs r2 < (1000000 :: Double) +-- run $ print ("e,e1,e2",e,e1,e2) + -- TODO lift the restriction about returning tuples + r12' <- run $ syncJS (srEngine doc) ( + do (x1,x2) <- ifB e (return (e1,e2)) (return (e2,e1)) + return (x1 * 100 + x2) :: JS t JSNumber) + assert $ (if b then (r1 * 100 + r2) else (r2 * 100 + r1)) == r12' + + + +checkArbitraryIfThenElse_Unit :: forall t . (SunroofThread t) => TestEngine -> ThreadProxy t -> Int -> Property +checkArbitraryIfThenElse_Unit doc ThreadProxy seed = monadicIO $ do + let n = (abs seed `mod` 8) + 1 + (b, e) <- pick $ sameSeed (boolExprGen n :: Gen Bool) + (boolExprGen n :: Gen JSBool) +-- run $ print ("e,e1,e2",e,e1,e2) + r12' <- run $ syncJS (srEngine doc) (ifB e (return ()) (return ()) >>= return :: JS t ()) + assert $ () == r12' + {- checkArbitraryArray_Int checkArbitraryArray_Int doc seed = monadicIO $ do @@ -361,7 +399,7 @@ LookupArray n ok -> do v <- evaluate $ lookup' (js n) arr case ok of - Just (Val n) -> do + Val n -> do ifB (js n /=* v) (return false) (k $$ ()) @@ -406,6 +444,59 @@ assert $ res +checkArbitraryMap + :: TestEngine + -> Property +checkArbitraryMap doc = monadicIO $ do + ops :: [MapOp SmallString SmallNat] <- pick (genMapOps 10) + + run $ print ops + + res :: Bool <- run $ syncJS (srEngine doc) $ do + mp <- M.newMap + let km = foldr (\ (op :: MapOp SmallString SmallNat) (km :: JSA (JSFunction () JSBool)) -> do + function $ \ () -> do + k <- km + case op of + LookupMap key ok -> do + v <- M.lookup (js key) mp + case ok of + Val n -> do + ifB (js n /=* v) + (return false) + (k $$ ()) + _ -> ifB (cast v /=* object "undefined") + (return false) + (k $$ ()) + InsertMap key v -> do + mp # M.insert (js key) (js v) + k $$ () + SizeMap n -> do + v <- M.size mp + ifB (v /=* js n) + (return false) + (k $$ ()) +{- + ElemsMap xs -> do + arr <- M.elems mp + bs <- sequence [ do v <- evaluate $ arr ! index (js n) + case x of + Val v' -> return (v ==* js v') + _ -> return (cast v ==* object "undefined") + | (n :: Int,x) <- [0..] `zip` xs ] + ifB (foldr (&&*) true bs) + (k $$ ()) + (return false) +-} + ) + (function $ \ () -> return true) + ops + return () + k <- km + -- returns true or false + k $$ () + + assert $ res -- | Check if simple arithmetic expressions with one operator produce -- the same value after sync. runFib :: TestEngine -> Int -> Property @@ -449,8 +540,10 @@ runTests doc all_tests = do syncJS (srEngine doc) $ do -- Set the fatal callback to continue, because we are testing things. - fatal <- function $ \ (_::JSObject,_::JSObject,_::JSObject,f::JSFunction () ()) -> + fatal <- function $ \ (a::JSObject,b::JSObject,c::JSObject,f::JSFunction () ()) -> forkJS $ do + -- This should be a command line thing +-- B.alert("FAILURE" <> cast a <> cast b <> cast c) -- wait a second before retrying SR.threadDelay 1000 apply f () @@ -733,9 +826,9 @@ deriving (Eq, Ord, Show) data ArrayOp n - = LookupArray Int (Maybe (Val n)) -- n is the expected result + = LookupArray Int (Val n) -- n is the expected result | InsertArray Int n - | LengthArray Int -- number of elements + | LengthArray Int -- number of elements | ElemsArray [Val n] deriving Show @@ -755,37 +848,86 @@ rest <- pick (i - 1) mp return (c : rest) - pick 0 mp = return [] - pick i mp = oneof - [ do ok :: Bool <- arbitrary - k <- if (ok && not (Map.null mp)) - then elements (Map.keys mp) - else choose (-10,100) -- This *might* hit; see test below - next i mp (LookupArray k (Map.lookup k mp)) - , do k <- choose (-10,100) + modifiers i mp = + [ do k <- choose (-10,100) v <- arbitrary let mp1 = if k < 0 then mp else Map.insert k (Val v) mp `Map.union` Map.fromList [ (k,Undefined) | k <- [(Map.size mp)..(k-1)]] next i mp1 (InsertArray k v) + ] + + observers i mp = + [ do ok :: Bool <- arbitrary + k <- if (ok && not (Map.null mp)) + then elements (Map.keys mp) + else choose (-10,100) -- This *might* hit; see test below + next i mp (LookupArray k + $ (\ v -> case v of + Just n -> n + _ -> Undefined) + $ Map.lookup k mp) , do next i mp (ElemsArray (Map.elems mp)) , do next i mp (LengthArray (Map.size mp)) ] + pick 0 mp = return [] + pick 1 mp = oneof (observers 1 mp) + pick i mp = oneof (observers i mp ++ modifiers i mp) + ops <- pick n (Map.fromList $ zip [0..] (case cons of NewEmptyArray -> [] NewArray xs -> map Val xs)) return (cons,ops) -test = quickCheck (forAll (genArrayOps (10,10) :: Gen (ArrayConstructor SmallNat,[ArrayOp SmallNat])) - $ \ c -> P.label (show c) True) +data MapOp k n + = LookupMap k (Val n) -- n is the expected result + | InsertMap k n + | DeleteMap k + | SizeMap Int -- number of elements +-- | ElemsMap [n] -- tricky to test + deriving Show +genMapOps :: (Ord k, Arbitrary k, Arbitrary n) => Int -> Gen [MapOp k n] +genMapOps sz1 = do + n <- choose (0,sz1) -- how many operations? -prop :: ArrayConstructor Int -> Property -prop c = P.label (show c) $ True + let next i mp c = do + rest <- pick (i - 1) mp + return (c : rest) + modifiers i mp = + [ do k <- arbitrary + v <- arbitrary + let mp1 = Map.insert k v mp + next i mp1 (InsertMap k v) + ] + + observers i mp = + [ do ok :: Bool <- arbitrary + k <- if (ok && not (Map.null mp)) + then elements (Map.keys mp) + else arbitrary + next i mp (LookupMap k + $ (\ v -> case v of + Just n -> Val n + _ -> Undefined) + $ Map.lookup k mp) +-- , do next i mp (ElemsMap (Map.elems mp)) + , do next i mp (SizeMap (Map.size mp)) + ] + + pick 0 mp = return [] + pick 1 mp = oneof (observers 1 mp) + pick i mp = oneof (observers i mp ++ modifiers i mp) + + ops <- pick n (Map.empty) + + return ops + + newtype SmallNat = SmallNat Int deriving (Eq, Ord) @@ -797,14 +939,32 @@ show (SmallNat n) = show n instance Arbitrary SmallNat where - arbitrary = fmap (SmallNat . fromInteger) $ choose (0::Integer,10000) + arbitrary = sized $ \ n -> fmap (SmallNat . fromInteger) $ choose (0::Integer,max 0 (min (fromIntegral n) 100)) +newtype SmallString = SmallString String + deriving (Eq, Ord) + +instance SunroofValue SmallString where + type ValueOf SmallString = JSString + js (SmallString n) = js n + +instance Show SmallString where + show (SmallString n) = show n + +instance Arbitrary SmallString where + arbitrary = sized $ \ n -> do + str <- sequence [ elements "ABC$ " + | _ <- [1.. min n 3] + ] + return $ SmallString str + + ------------------------------------------------------ -data TestMap k a - = InsertMap k a - | LookupMap k - | SizeMap - | DeleteMap k +test = quickCheck (forAll (genMapOps 10 :: Gen [MapOp SmallString SmallNat]) + $ \ c -> P.label (show c) True) + +prop :: ArrayConstructor Int -> Property +prop c = P.label (show c) $ True diff --git a/sunroof-examples.cabal b/sunroof-examples.cabal --- a/sunroof-examples.cabal +++ b/sunroof-examples.cabal @@ -1,5 +1,5 @@ Name: sunroof-examples -Version: 0.2 +Version: 0.2.2 Synopsis: Tests for Sunroof Homepage: https://github.com/ku-fpg/sunroof-examples Bug-reports: https://github.com/ku-fpg/sunroof-examples @@ -42,8 +42,8 @@ Other-Modules: Paths_sunroof_examples Build-Depends: base >= 4.6, - sunroof-compiler == 0.2, - sunroof-server == 0.2, + sunroof-compiler == 0.2.1, + sunroof-server == 0.2.1, Boolean >= 0.2, semigroups >= 0.9, data-default >= 0.5 @@ -56,8 +56,8 @@ Executable sunroof-canvas Build-Depends: base >= 4.6, - sunroof-compiler == 0.2, - sunroof-server == 0.2, + sunroof-compiler == 0.2.1, + sunroof-server == 0.2.1, Boolean >= 0.2, data-default >= 0.5 @@ -69,7 +69,7 @@ Executable sunroof-clock Build-Depends: base >= 4.6, - sunroof-compiler == 0.2, + sunroof-compiler == 0.2.1, Boolean >= 0.2, data-default >= 0.5, filepath >= 0.1 @@ -83,8 +83,8 @@ Executable sunroof-fib Build-Depends: base >= 4.6, - sunroof-compiler == 0.2, - sunroof-server == 0.2, + sunroof-compiler == 0.2.1, + sunroof-server == 0.2.1, Boolean >= 0.2, semigroups >= 0.9, data-default >= 0.5 @@ -97,8 +97,8 @@ Executable sunroof-unit Other-Modules: Paths_sunroof_examples Build-Depends: - sunroof-compiler == 0.2, - sunroof-server == 0.2, + sunroof-compiler == 0.2.1, + sunroof-server == 0.2.1, Boolean >= 0.2, data-default >= 0.5, semigroups >= 0.9,