slug 0.1.0 → 0.1.1

raw patch · 5 files changed

+152/−36 lines, 5 filesdep −HUnitdep −test-framework-hunitdep ~slugPVP ok

version bump matches the API change (PVP)

Dependencies removed: HUnit, test-framework-hunit

Dependency ranges changed: slug

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• README.md +1/−1
• Web/Slug.hs +53/−9
• slug.cabal +5/−6
• tests/Main.hs +84/−20

@@ -1,3 +1,12 @@+## Slug 0.1.1++* Add `Read` instance of `Slug`.++* Add `parseSlug` and `truncateSlug` functions.++* Functions (including instance methods) that parse `Text` that must be+  formatted as valid slug are case-sensitive now.+ ## Slug 0.1.0  * Initial release.

@@ -15,7 +15,7 @@ ## Quick start  The package provides data type `Slug` that is instance of various type-classes, so it can be used with Persistent or as part of route. It's also+classes, so it can be used with Persistent or as part of route. It also works with `aeson` package.  The slugs are completely type-safe. When you have a `Slug`, you can be sure

@@ -10,16 +10,19 @@ -- Type-safe slug implementation for Yesod ecosystem.  {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections      #-}  module Web.Slug   ( Slug   , mkSlug   , unSlug+  , parseSlug+  , truncateSlug   , SlugException (..) ) where  import Control.Exception (Exception)-import Control.Monad (mzero, (>=>))+import Control.Monad (mzero, (>=>), liftM) import Control.Monad.Catch (MonadThrow (..)) import Data.Aeson.Types (ToJSON (..), FromJSON (..)) import Data.Char (isAlphaNum)@@ -35,10 +38,16 @@ -- | This exception is thrown by 'mkSlug' when its input cannot be converted -- into proper 'Slug'. -data SlugException = InvalidInput Text deriving (Typeable)+data SlugException+  = 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  instance Exception SlugException @@ -56,14 +65,15 @@  newtype Slug = Slug   { unSlug :: Text     -- ^ Get textual representation of 'Slug'.-  } deriving (Eq, Show, Typeable)+  } deriving (Eq, Typeable)  -- | Create 'Slug' from 'Text', all necessary transformations are -- applied. Argument of this function can be title of an article or -- something like that. -- -- Note that result is inside 'MonadThrow', that means you can just get it--- in 'Maybe', in more complex contexts it will throw 'SlugException'.+-- in 'Maybe', in more complex contexts it will throw 'SlugException'+-- exception using 'InvalidInput' constructor. -- -- This function also have a useful property: --@@ -84,22 +94,56 @@ getSlugWords = T.words . T.toLower . T.map f . T.replace "'" ""   where f x = if isAlphaNum x then x else ' ' +-- | Convert 'Text' into 'Slug' only when it is already valid slug.+--+-- This function can throw 'SlugException' exception using 'InvalidSlug'+-- constructor.++parseSlug :: MonadThrow m => Text -> m Slug+parseSlug v = mkSlug v >>= check+  where check s =+          if unSlug s == v+          then return s+          else throwM (InvalidSlug v)++-- | Ensure that given 'Slug' is not longer than given maximum number of+-- characters. If truncated slug ends in a dash, remove that dash too. (Dash+-- at the end would violate properties described in documentation for+-- 'Slug'.)+--+-- If the first argument is not a positive number, 'SlugException' is thrown+-- using 'InvalidLength' constructor.++truncateSlug :: MonadThrow m+  => Int               -- ^ Maximum length of slug, must be greater than 0+  -> Slug              -- ^ Original non-truncated slug+  -> m Slug            -- ^ Truncated slug+truncateSlug n v+  | n < 1     = throwM (InvalidLength n)+  | otherwise = mkSlug . T.take n . unSlug $ v++instance Show Slug where+  show = show . unSlug++instance Read Slug where+  readsPrec n = (readsPrec n :: ReadS Text) >=> f+    where f (s, t) = (,t) `liftM` parseSlug s+ instance ToJSON Slug where   toJSON = toJSON . unSlug  instance FromJSON Slug where-  parseJSON (A.String v) = maybe mzero return (mkSlug v)+  parseJSON (A.String v) = maybe mzero return (parseSlug v)   parseJSON _            = mzero  instance PersistField Slug where   toPersistValue   = toPersistValue . unSlug   fromPersistValue =-    fromPersistValue >=> either (Left . T.pack . show) Right . mkSlug+    fromPersistValue >=> either (Left . T.pack . show) Right . parseSlug  instance PersistFieldSql Slug where   sqlType = const SqlString  instance PathPiece Slug where-  fromPathPiece v = mkSlug v >>= check-    where check s = if unSlug s == T.toLower v then Just s else Nothing-  toPathPiece = unSlug+  fromPathPiece = parseSlug+  toPathPiece   = unSlug

@@ -32,14 +32,14 @@ -- POSSIBILITY OF SUCH DAMAGE.  name:                 slug-version:              0.1.0+version:              0.1.1 cabal-version:        >= 1.10 license:              BSD3 license-file:         LICENSE.md author:               Mark Karpov <markkarpov@opmbx.org> maintainer:           Mark Karpov <markkarpov@opmbx.org>-homepage:             https://github.com/mrkkrp/htaglib-bug-reports:          https://github.com/mrkkrp/htaglib/issues+homepage:             https://github.com/mrkkrp/slug+bug-reports:          https://github.com/mrkkrp/slug/issues category:             Web synopsis:             Type-safe slugs for Yesod ecosystem build-type:           Simple@@ -77,12 +77,11 @@     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

@@ -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,23 +58,96 @@  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)   where hasAlphaNum = isJust . T.find isAlphaNum@@ -84,12 +157,3 @@   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