slug 0.1.5 → 0.1.6
raw patch · 6 files changed
+146/−120 lines, 6 filesdep +hspecdep +http-api-datadep −test-frameworkdep −test-framework-quickcheck2dep ~aesondep ~basedep ~slug
Dependencies added: hspec, http-api-data
Dependencies removed: test-framework, test-framework-quickcheck2
Dependency ranges changed: aeson, base, slug
Files
- CHANGELOG.md +18/−0
- LICENSE.md +1/−1
- README.md +1/−1
- Web/Slug.hs +39/−10
- slug.cabal +14/−12
- tests/Main.hs +73/−96
CHANGELOG.md view
@@ -1,3 +1,21 @@+## Slug 0.1.6++* Allowed Aeson 1.1.++* Switched to Hspec for test suite.++* Made public `Arbitrary` instance for `Slug`.++* Derived `Eq` for `SlugException`.++* Drop support for GHC 7.6.++* Started to use the derived `Show` instance for `SlugException`.+ Human-friendly version goes to `Exception`'s method `displayException`+ instead.++* Added instances of `ToHttpApiData` and `FromHttpApiData` for `Slug`.+ ## Slug 0.1.5 * Allow Aeson 1.0.
LICENSE.md view
@@ -1,4 +1,4 @@-Copyright © 2015–2016 Mark Karpov+Copyright © 2015–2017 Mark Karpov All rights reserved.
README.md view
@@ -54,6 +54,6 @@ ## License -Copyright © 2015–2016 Mark Karpov+Copyright © 2015–2017 Mark Karpov Distributed under BSD 3 clause license.
Web/Slug.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Web.Slug--- Copyright : © 2015–2016 Mark Karpov+-- Copyright : © 2015–2017 Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov <markkarpov@openmailbox.org>@@ -9,6 +9,7 @@ -- -- Type-safe slug implementation for Yesod ecosystem. +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} @@ -21,21 +22,28 @@ , SlugException (..) ) where -import Control.Exception (Exception)+import Control.Exception (Exception (..)) import Control.Monad ((>=>), liftM) import Control.Monad.Catch (MonadThrow (..)) import Data.Aeson.Types (ToJSON (..), FromJSON (..)) import Data.Char (isAlphaNum) import Data.Data (Data)+import Data.Maybe (isJust, fromJust) import Data.Text (Text) import Data.Typeable (Typeable) import Database.Persist.Class (PersistField (..)) import Database.Persist.Sql (PersistFieldSql (..)) import Database.Persist.Types (SqlType (..))+import Test.QuickCheck+import Web.HttpApiData import Web.PathPieces import qualified Data.Aeson as A import qualified Data.Text as T +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+ -- | This exception is thrown by 'mkSlug' when its input cannot be converted -- into proper 'Slug'. @@ -43,14 +51,14 @@ = InvalidInput Text -- ^ Slug cannot be generated for given text | InvalidSlug Text -- ^ Input is not a valid slug, see 'parseSlug' | InvalidLength Int -- ^ Requested slug length is not a positive number- deriving (Typeable)--instance Show SlugException where- show (InvalidInput text) = "Cannot build slug for " ++ show text- show (InvalidSlug text) = "The text is not a valid slug " ++ show text- show (InvalidLength n) = "Invalid slug length: " ++ show n+ deriving (Eq, Show, Typeable) -instance Exception SlugException+instance Exception SlugException where+#if MIN_VERSION_base(4,8,0)+ displayException (InvalidInput text) = "Cannot build slug for " ++ show text+ displayException (InvalidSlug text) = "The text is not a valid slug " ++ show text+ displayException (InvalidLength n) = "Invalid slug length: " ++ show n+#endif -- | Slug. Textual value inside is always guaranteed to have the following -- qualities:@@ -145,7 +153,13 @@ instance PersistField Slug where toPersistValue = toPersistValue . unSlug fromPersistValue =- fromPersistValue >=> either (Left . T.pack . show) Right . parseSlug+ fromPersistValue >=> either (Left . T.pack . f) Right . parseSlug+ where+#if MIN_VERSION_base(4,8,0)+ f = displayException+#else+ f = show+#endif instance PersistFieldSql Slug where sqlType = const SqlString@@ -153,3 +167,18 @@ instance PathPiece Slug where fromPathPiece = parseSlug toPathPiece = unSlug++instance ToHttpApiData Slug where+ toUrlPiece = unSlug++instance FromHttpApiData Slug where+ parseUrlPiece = either (Left . T.pack . f) Right . parseSlug+ where+#if MIN_VERSION_base(4,8,0)+ f = displayException+#else+ f = show+#endif++instance Arbitrary Slug where+ arbitrary = fromJust <$> (mkSlug . T.pack <$> arbitrary) `suchThat` isJust
slug.cabal view
@@ -1,7 +1,7 @@ -- -- Cabal configuration for ‘slug’. ----- Copyright © 2015–2016 Mark Karpov+-- Copyright © 2015–2017 Mark Karpov -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are@@ -31,7 +31,7 @@ -- POSSIBILITY OF SUCH DAMAGE. name: slug-version: 0.1.5+version: 0.1.6 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE.md@@ -52,9 +52,11 @@ default: False library- build-depends: aeson >= 0.8 && < 1.1- , base >= 4.6 && < 5.0+ build-depends: QuickCheck >= 2.4 && < 3.0+ , aeson >= 0.8 && < 1.2+ , base >= 4.7 && < 5.0 , exceptions >= 0.6 && < 0.9+ , http-api-data >= 0.2 && < 0.4 , path-pieces >= 0.1.5 && < 0.3 , persistent >= 2.0 && < 3.0 , text >= 1.0 && < 1.3@@ -75,14 +77,14 @@ else ghc-options: -O2 -Wall default-extensions: OverloadedStrings- build-depends: QuickCheck >= 2.4 && < 3.0- , base >= 4.6 && < 5.0- , exceptions >= 0.6 && < 0.9- , path-pieces >= 0.1.5 && < 0.3- , slug >= 0.1.5- , test-framework >= 0.6 && < 1.0- , test-framework-quickcheck2 >= 0.3 && < 0.4- , text >= 1.0 && < 1.3+ build-depends: QuickCheck >= 2.4 && < 3.0+ , base >= 4.7 && < 5.0+ , exceptions >= 0.6 && < 0.9+ , hspec >= 2.0 && < 3.0+ , http-api-data >= 0.2 && < 0.4+ , path-pieces >= 0.1.5 && < 0.3+ , slug >= 0.1.6+ , text >= 1.0 && < 1.3 default-language: Haskell2010 source-repository head
tests/Main.hs view
@@ -1,7 +1,7 @@ -- -- Slug tests. ----- Copyright © 2015–2016 Mark Karpov+-- Copyright © 2015–2017 Mark Karpov -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are@@ -36,14 +36,13 @@ module Main (main) where import Control.Monad ((>=>))-import Control.Monad.Catch (MonadThrow (..)) import Data.Char (isAlphaNum, isUpper) import Data.Function (on)-import Data.Maybe (fromJust, isJust, isNothing)+import Data.Maybe (isJust, isNothing) import Data.Text (Text)-import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Hspec import Test.QuickCheck+import Web.HttpApiData import Web.PathPieces import Web.Slug import qualified Data.Text as T@@ -53,60 +52,76 @@ #endif main :: IO ()-main = defaultMain [tests]--tests :: Test-tests = testGroup "Slug properties"- [ -- 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- ]--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+main = hspec spec -prop_noUpperCase :: Slug -> Property-prop_noUpperCase = expectFailure . T.any isUpper . unSlug+spec :: Spec+spec = do+ describe "slug properties" $ do+ it "cannot be empty" $+ property $ \slug ->+ unSlug slug `shouldNotSatisfy` T.null+ it "contains only dashes and alpha-numeric characters" $+ property $ \slug ->+ let f x = isAlphaNum x || x == '-'+ in unSlug slug `shouldSatisfy` T.all f+ it "does not begin with a dash" $+ property $ \slug ->+ T.head (unSlug slug) `shouldNotBe` '-'+ it "does not end with a dash" $+ property $ \slug ->+ T.last (unSlug slug) `shouldNotBe` '-'+ it "does not contain empty words between dashes" $+ property $ \slug ->+ T.splitOn "-" (unSlug slug) `shouldNotSatisfy` any T.null+ it "no upper-cased chars found in slugs" $+ property $ \slug ->+ unSlug slug `shouldNotSatisfy` T.any isUpper+ it "showed Slug looks the same as its inner Text" $+ property $ \slug ->+ show slug === show (unSlug slug)+ it "showed Slug can be read back again" $+ property $ \slug ->+ read (show slug) === (slug :: Slug)+ it "incorrect Slug won't be read successfully" $+ property $ \x -> isNothing (parseSlug x) ==>+ (reads (show x) :: [(Slug, String)]) === []+ it "valid Slug text is a valid path piece" $+ property $ \slug ->+ fromPathPiece (unSlug slug) === Just slug+ it "valid Slug text is a valid HTTP API data" $+ property $ \slug ->+ parseUrlPiece (toUrlPiece slug) === Right (slug :: Slug)+ describe "mkSlug" $ do+ it "Slug transformation in idempotent" $+ property $ \x ->+ let f = mkSlug+ g = mkSlug >=> mkSlug . unSlug+ in f x ==== g x+ it "text containing at least one alpha-num char is Sluggable" $ do+ let hasAlphaNum = isJust . T.find isAlphaNum+ property $ \x -> hasAlphaNum x ==>+ isJust (mkSlug x) `shouldBe` True+ describe "parseSlug" $ do+ it "succeeds on valid input" $+ property $ \slug ->+ parseSlug (unSlug slug) `shouldReturn` slug+ it "fails on invalid input" $+ property $ \x ->+ (unSlug <$> mkSlug x) `notElem` [Nothing, Just x] ==>+ parseSlug x `shouldThrow` (== InvalidSlug x)+ describe "truncateSlug" $ do+ context "when required length is less than 0" $+ it "throws InvalidLength" $+ property $ \n slug -> (n < 1) ==>+ truncateSlug n slug `shouldThrow` (== InvalidLength n)+ context "when required length is OK" $+ it "truncates to this length or one less" $+ property $ \n slug -> (n > 0) ==> do+ t <- truncateSlug n slug+ T.length (unSlug t) `shouldSatisfy` (<= n) ------------------------------------------------------------------------------- Properties of helper-functions+-- Helpers infix 4 ==== @@ -116,43 +131,5 @@ displayLeft :: Show a => Either a b -> Either String b displayLeft = either (Left . show) Right -prop_changeStops :: Text -> Property-prop_changeStops x = f x ==== g x- where f = mkSlug- g = mkSlug >=> mkSlug . unSlug--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)- where hasAlphaNum = isJust . T.find isAlphaNum--prop_pathPiece :: Text -> Property-prop_pathPiece x =- case mkSlug x of- Nothing -> property True- Just slug -> fromPathPiece (unSlug slug) === Just slug+instance Arbitrary Text where+ arbitrary = T.pack <$> arbitrary