Define ‘Semigroup’ instance for ‘Slug’

CHANGELOG.md

@@ -1,3 +1,7 @@
+## Slug 0.1.7
+
+* Define `Semigroup` instance for `Slug`.
+
 ## Slug 0.1.6
 
 * Allowed Aeson 1.1.

Web/Slug.hs

@@ -29,6 +29,7 @@ import Data.Aeson.Types (ToJSON (..), FromJSON (..))
 import Data.Char (isAlphaNum)
 import Data.Data (Data)
 import Data.Maybe (isJust, fromJust)
+import Data.Semigroup
 import Data.Text (Text)
 import Data.Typeable (Typeable)
 import Database.Persist.Class (PersistField (..))
@@ -74,6 +75,9 @@ instance Exception SlugException where
 
 newtype Slug = Slug Text deriving (Eq, Ord, Data, Typeable)
 
+instance Semigroup Slug where
+  x <> y = Slug (unSlug x <> "-" <> unSlug y)
+
 -- | Create a 'Slug' from a 'Text' value, all necessary transformations are
 -- applied. Argument of this function can be title of an article or
 -- something like that.

slug.cabal

@@ -61,6 +61,8 @@ library
                     , path-pieces  >= 0.1.5 && < 0.3
                     , persistent   >= 2.0   && < 3.0
                     , text         >= 1.0   && < 1.3
+  if !impl(ghc >= 8.0)
+    build-depends:    semigroups   == 0.18.*
   default-extensions: OverloadedStrings
   exposed-modules:    Web.Slug
   if flag(dev)
@@ -86,6 +88,8 @@ test-suite tests
                     , path-pieces  >= 0.1.5 && < 0.3
                     , slug
                     , text         >= 1.0   && < 1.3
+  if !impl(ghc >= 8.0)
+    build-depends:    semigroups   == 0.18.*
   default-language:   Haskell2010
 
 source-repository head

tests/Main.hs

@@ -39,6 +39,7 @@ import Control.Monad ((>=>))
 import Data.Char (isAlphaNum, isUpper)
 import Data.Function (on)
 import Data.Maybe (isJust, isNothing)
+import Data.Semigroup
 import Data.Text (Text)
 import Test.Hspec
 import Test.QuickCheck
@@ -91,6 +92,12 @@ spec = do
     it "valid Slug text is a valid HTTP API data" $
       property $ \slug ->
         parseUrlPiece (toUrlPiece slug) === Right (slug :: Slug)
+  describe "Semigroup instance of Slug" $
+    it "the (<>) operation produces valid slugs in all cases" $
+      property $ \x y -> do
+        let slug = unSlug (x <> y)
+        slug' <- unSlug <$> parseSlug slug
+        slug' `shouldBe` slug
   describe "mkSlug" $ do
     it "Slug transformation in idempotent" $
       property $ \x ->