Extend collection of tests, improve coverage

slug.cabal

@@ -77,12 +77,11 @@ test-suite tests
     ghc-options:      -O2 -Wall
   default-extensions: OverloadedStrings
   build-depends:      QuickCheck                 >= 2.4 && < 3
-                    , HUnit                      >= 1.2 && < 1.4
                     , base                       >= 4.6 && < 5
+                    , exceptions                 >= 0.6
                     , path-pieces                >= 0.1.5
-                    , slug                       >= 0.1
+                    , slug                       >= 0.1.1
                     , test-framework             >= 0.6 && < 1
-                    , test-framework-hunit       >= 0.2 && < 0.4
                     , test-framework-quickcheck2 >= 0.3 && < 0.4
                     , text                       >= 1.0
   default-language:   Haskell2010

tests/Main.hs

@@ -37,13 +37,13 @@
 module Main (main) where
 
 import Control.Monad ((>=>))
-import Data.Char (isAlphaNum)
-import Data.Maybe (isJust)
+import Control.Monad.Catch (MonadThrow (..))
+import Data.Char (isAlphaNum, isUpper)
+import Data.Function (on)
+import Data.Maybe (fromJust, isJust, isNothing)
 import Data.Text (Text)
 import Test.Framework
-import Test.Framework.Providers.HUnit (testCase)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.HUnit hiding (Test, path)
 import Test.QuickCheck
 import Web.PathPieces
 import Web.Slug
@@ -58,22 +58,95 @@ main = defaultMain [tests]
 
 tests :: Test
 tests = testGroup "Slug properties"
-  [ testProperty "Slug of slug is the slug" prop_changeStops
-  , testProperty "Alpha-numeric chars are necessary and sufficient"
-    prop_needAlphaNum
+  [ -- Properties of valid slugs
+    testProperty "Slug cannot be empty" prop_nonEmpty
+  , testProperty "Only dashes and alpha-numeric" prop_validContent
+  , testProperty "Slug cannot begin with a dash" prop_noBegDash
+  , testProperty "Slug cannot end with a dash" prop_noEndDash
+  , testProperty "Non-empty word between dashes" prop_noEmptyWords
+  , testProperty "No upper-cased chars in slugs" prop_noUpperCase
+    -- Properties of helper-functions
+  , testProperty "Slug of slug is the slug" prop_changeStops
+  , testProperty "Parsing of slugs (success)" prop_parsing0
+  , testProperty "Parsing of slugs (failure)" prop_parsing1
+  , testProperty "Slug truncation" prop_truncation
+  , testProperty "Reading of slugs (success)" prop_read0
+  , testProperty "Reading of slugs (failure)" prop_read1
+    -- Additional properties
+  , testProperty "Rendering of slugs" prop_showSlug
+  , testProperty "Alpha-numerics are necessary and sufficient" prop_needAlphaNum
   , testProperty "Path pieces accept correct slugs" prop_pathPiece
-  , testCase "Removal of apostrophe" prop_apostropheRemoval
-  , testCase "Path pieces ignore case of slugs" prop_pathPieceCase
   ]
 
 instance Arbitrary Text where
   arbitrary = T.pack <$> arbitrary
 
+instance Arbitrary Slug where
+  arbitrary = fromJust <$> ((mkSlug <$> arbitrary) `suchThat` isJust)
+
+----------------------------------------------------------------------------
+-- Properties of valid slugs
+
+prop_nonEmpty :: Slug -> Property
+prop_nonEmpty = expectFailure . T.null . unSlug
+
+prop_validContent :: Slug -> Property
+prop_validContent = property . T.all f . unSlug
+  where f x = isAlphaNum x || x == '-'
+
+prop_noBegDash :: Slug -> Property
+prop_noBegDash s = expectFailure $ T.head (unSlug s) === '-'
+
+prop_noEndDash :: Slug -> Property
+prop_noEndDash s = expectFailure $ T.last (unSlug s) === '-'
+
+prop_noEmptyWords :: Slug -> Property
+prop_noEmptyWords = expectFailure . any T.null . T.splitOn "-" . unSlug
+
+prop_noUpperCase :: Slug -> Property
+prop_noUpperCase = expectFailure . T.any isUpper . unSlug
+
+----------------------------------------------------------------------------
+-- Properties of helper-functions
+
+infix 4 ====
+
+(====) :: (Show a, Show b, Eq b) => Either a b -> Either a b -> Property
+(====) = (===) `on` displayLeft
+
+displayLeft :: Show a => Either a b -> Either String b
+displayLeft = either (Left . show) Right
+
 prop_changeStops :: Text -> Property
-prop_changeStops x = v (f x) === v (g x)
+prop_changeStops x = f x ==== g x
   where f = mkSlug
         g = mkSlug >=> mkSlug . unSlug
-        v = either (Left . show) Right
+
+prop_parsing0 :: Slug -> Property
+prop_parsing0 s = parseSlug (unSlug s) === Just s
+
+prop_parsing1 :: Text -> Property
+prop_parsing1 x = (unSlug <$> mkSlug x) `notElem` [Nothing, Just x]
+  ==> parseSlug x ==== throwM (InvalidSlug x)
+
+prop_truncation :: Int -> Slug -> Property
+prop_truncation n s =
+  case truncateSlug n s of
+    Left e -> n < 1 ==> show e === show (InvalidLength n)
+    Right t -> n > 0 ==> T.length (unSlug t) <= n
+
+prop_read0 :: Slug -> Property
+prop_read0 s = read (show s) === s
+
+prop_read1 :: Text -> Property
+prop_read1 s = isNothing (parseSlug s)
+  ==> (reads (show s) :: [(Slug, String)]) === []
+
+----------------------------------------------------------------------------
+-- Additional properties
+
+prop_showSlug :: Slug -> Property
+prop_showSlug s = show s === show (unSlug s)
 
 prop_needAlphaNum :: Text -> Property
 prop_needAlphaNum x = hasAlphaNum x ==> isJust (mkSlug x)
@@ -84,12 +157,3 @@ prop_pathPiece x =
   case mkSlug x of
     Nothing -> property True
     Just slug -> fromPathPiece (unSlug slug) === Just slug
-
-prop_apostropheRemoval :: Assertion
-prop_apostropheRemoval = unSlug <$> mkSlug text @?= Just slug
-  where text = "That's what I thought about doin' that stuff!"
-        slug = "thats-what-i-thought-about-doin-that-stuff"
-
-prop_pathPieceCase :: Assertion
-prop_pathPieceCase = fromPathPiece text @?= mkSlug text
-  where text = "thiS-Строка-hAs-коМбиНацию-of-DiffErent-Cases" :: Text