sunroof-examples 0.2 → 0.2.2
raw patch · 4 files changed
+239/−79 lines, 4 filesdep ~sunroof-compilerdep ~sunroof-server
Dependency ranges changed: sunroof-compiler, sunroof-server
Files
- examples/canvas/Main.hs +33/−33
- examples/clock/Main.hs +12/−12
- examples/unit/Main.hs +184/−24
- sunroof-examples.cabal +10/−10
examples/canvas/Main.hs view
@@ -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
examples/clock/Main.hs view
@@ -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.
examples/unit/Main.hs view
@@ -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
sunroof-examples.cabal view
@@ -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,