From 7d103e7740446724c68c52755622219a6be48986 Mon Sep 17 00:00:00 2001 From: rbasso Date: Tue, 27 Sep 2016 14:11:35 +0900 Subject: [PATCH] zipper: Rewrite tests to use hspec with fail-fast. - Rewrite test to use `hspec` with fail-fast. - Remove comments from stub solution. --- exercises/zipper/package.yaml | 2 +- exercises/zipper/src/Zipper.hs | 58 ++++++------------ exercises/zipper/test/Tests.hs | 108 ++++++++++++++++++--------------- 3 files changed, 81 insertions(+), 87 deletions(-) diff --git a/exercises/zipper/package.yaml b/exercises/zipper/package.yaml index 545f963c0..56723461d 100644 --- a/exercises/zipper/package.yaml +++ b/exercises/zipper/package.yaml @@ -16,4 +16,4 @@ tests: source-dirs: test dependencies: - zipper - - HUnit + - hspec diff --git a/exercises/zipper/src/Zipper.hs b/exercises/zipper/src/Zipper.hs index db6aef6b1..1c9e169f8 100644 --- a/exercises/zipper/src/Zipper.hs +++ b/exercises/zipper/src/Zipper.hs @@ -1,62 +1,44 @@ -module Zipper ( - BinTree(..), - Zipper, - - fromTree, - toTree, - - value, - left, - right, - up, - - setValue, - setLeft, - setRight -) where - --- | A binary tree. -data BinTree a = BT { - btValue :: a -- ^ Value - , btLeft :: Maybe (BinTree a) -- ^ Left child - , btRight :: Maybe (BinTree a) -- ^ Right child -} deriving (Eq, Show) - --- | A zipper for a binary tree. -data Zipper a -- Complete this definition - --- | Get a zipper focussed on the root node. +module Zipper + ( BinTree(BT) + , fromTree + , left + , right + , setLeft + , setRight + , setValue + , toTree + , up + , value + ) where + +data BinTree a = BT { btValue :: a + , btLeft :: Maybe (BinTree a) + , btRight :: Maybe (BinTree a) + } deriving (Eq, Show) + fromTree :: BinTree a -> Zipper a fromTree = undefined --- | Get the complete tree from a zipper. toTree :: Zipper a -> BinTree a toTree = undefined --- | Get the value of the focus node. value :: Zipper a -> a -value = undefined +value = undefined --- | Get the left child of the focus node, if any. left :: Zipper a -> Maybe (Zipper a) left = undefined --- | Get the right child of the focus node, if any. right :: Zipper a -> Maybe (Zipper a) right = undefined --- | Get the parent of the focus node, if any. up :: Zipper a -> Maybe (Zipper a) up = undefined --- | Set the value of the focus node. setValue :: a -> Zipper a -> Zipper a setValue = undefined --- | Replace a left child tree. setLeft :: Maybe (BinTree a) -> Zipper a -> Zipper a -setLeft = undefined +setLeft = undefined --- | Replace a right child tree. setRight :: Maybe (BinTree a) -> Zipper a -> Zipper a setRight = undefined diff --git a/exercises/zipper/test/Tests.hs b/exercises/zipper/test/Tests.hs index 5bd6ec355..588684ebf 100644 --- a/exercises/zipper/test/Tests.hs +++ b/exercises/zipper/test/Tests.hs @@ -1,52 +1,64 @@ -import Test.HUnit (Assertion, (@=?), runTestTT, Test(..), Counts(..)) -import System.Exit (ExitCode(..), exitWith) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.Runner (configFastFail, defaultConfig, hspecWith) + import Zipper + ( BinTree(BT) + , fromTree + , left + , right + , setLeft + , setRight + , setValue + , toTree + , up + , value + ) -exitProperly :: IO Counts -> IO () -exitProperly m = do - counts <- m - exitWith $ if failures counts /= 0 || errors counts /= 0 then ExitFailure 1 else ExitSuccess +main :: IO () +main = hspecWith defaultConfig {configFastFail = True} specs -testCase :: String -> Assertion -> Test -testCase label assertion = TestLabel label (TestCase assertion) +specs :: Spec +specs = describe "zipper" $ do -main :: IO () -main = exitProperly $ runTestTT $ TestList - [ TestList zipperTests ] - -empty :: Maybe (BinTree a) -empty = Nothing - -bt :: Int -> Maybe (BinTree Int) -> Maybe (BinTree Int) -> Maybe (BinTree Int) -bt v l r = Just (BT v l r) - -leaf :: Int -> Maybe (BinTree Int) -leaf v = bt v Nothing Nothing - -t1, t2, t3, t4 :: BinTree Int -t1 = BT 1 (bt 2 empty (leaf 3)) (leaf 4) -t2 = BT 1 (bt 5 empty (leaf 3)) (leaf 4) -t3 = BT 1 (bt 2 (leaf 5) (leaf 3)) (leaf 4) -t4 = BT 1 (leaf 2) (leaf 4) - -zipperTests :: [Test] -zipperTests = - [ testCase "data is retained" $ - t1 @=? toTree (fromTree t1) - , testCase "left, right and value" $ - 3 @=? (value . fromJust . right . fromJust . left . fromTree $ t1) - , testCase "dead end" $ - Nothing @=? (left . fromJust . left . fromTree $ t1) - , testCase "tree from deep focus" $ - t1 @=? (toTree . fromJust . right . fromJust . left . fromTree $ t1) - , testCase "setValue" $ - t2 @=? (toTree . setValue 5 . fromJust . left . fromTree $ t1) - , testCase "setLeft with Just" $ - t3 @=? (toTree . setLeft (Just (BT 5 Nothing Nothing)) . fromJust . left . fromTree $ t1) - , testCase "setRight with Nothing" $ - t4 @=? (toTree . setRight Nothing . fromJust . left . fromTree $ t1) - , testCase "different paths to same zipper" $ - (right . fromTree $ t1) @=? - (right . fromJust . up . fromJust . left . fromTree $ t1) - ] + -- As of 2016-09-27, there was no reference file + -- for the test cases in `exercism/x-common`. + + let leaf v = node v Nothing Nothing + node v l r = Just (BT v l r :: BinTree Int) + t1 = BT 1 (node 2 Nothing $ leaf 3) $ leaf 4 + t2 = BT 1 (node 5 Nothing $ leaf 3) $ leaf 4 + t3 = BT 1 (node 2 (leaf 5) $ leaf 3) $ leaf 4 + t4 = BT 1 (leaf 2 ) $ leaf 4 + + it "data is retained" $ + toTree (fromTree t1) + `shouldBe` t1 + + it "left, right and value" $ + (value . fromJust . right . fromJust . left . fromTree) t1 + `shouldBe` 3 + + it "dead end" $ + (left . fromJust . left . fromTree) t1 + `shouldBe` Nothing + + it "tree from deep focus" $ + (toTree . fromJust . right . fromJust . left . fromTree) t1 + `shouldBe` t1 + + it "setValue" $ + (toTree . setValue 5 . fromJust . left . fromTree) t1 + `shouldBe` t2 + + it "setLeft with Just" $ + (toTree . setLeft (leaf 5) . fromJust . left . fromTree) t1 + `shouldBe` t3 + + it "setRight with Nothing" $ + (toTree . setRight Nothing . fromJust . left . fromTree) t1 + `shouldBe` t4 + + it "different paths to same zipper" $ + (right . fromJust . up . fromJust . left . fromTree) t1 + `shouldBe` (right . fromTree) t1