titlecase 0.1.0.3 → 1
raw patch · 10 files changed
+209/−260 lines, 10 filesdep −blaze-markupdep −semigroupsdep −text
Dependencies removed: blaze-markup, semigroups, text
Files
- Main.hs +1/−4
- src/Data/Text/Titlecase.hs +18/−27
- src/Data/Text/Titlecase/Internal.hs +69/−86
- tests/Main.hs +12/−0
- tests/Property.hs +45/−0
- tests/Test.hs +0/−11
- tests/Test/Property.hs +0/−56
- tests/Test/Unit.hs +0/−59
- tests/Unit.hs +55/−0
- titlecase.cabal +9/−17
Main.hs view
@@ -1,10 +1,7 @@ module Main ( main ) where -import Data.Text ( pack ) import Data.Text.Titlecase import System.Environment-import Text.Blaze-import Text.Blaze.Renderer.Pretty main :: IO ()-main = getArgs >>= putStr . renderMarkup . toMarkup . titlecase . pack . unwords+main = getArgs >>= putStrLn . titlecase . unwords
src/Data/Text/Titlecase.hs view
@@ -1,31 +1,22 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE MultiWayIf #-} -module Data.Text.Titlecase- ( Titlecase- , titlecase- ) where+module Data.Text.Titlecase ( titlecase ) where -import Prelude (Int, ($), (==), (||), (&&), succ, otherwise)-import qualified Data.List as List-import Data.Text hiding (toTitle)-import Data.Text.Titlecase.Internal+import Data.Text.Titlecase.Internal --- | Capitalize all English words except 'articles' (a, an, the),--- coordinating 'conjunctions' (for, and, nor, but, or, yet, so), and--- 'prepositions' (unless they begin or end the title). The--- 'prepositions' are taken from this list:--- <https://en.wikipedia.org/wiki/List_of_English_prepositions>.-titlecase :: Text -> Titlecase-titlecase t = Titlecase $ go 1 ws+-- | Capitalize all English words except 'articles' (a, an, the), coordinating+-- 'conjunctions' (for, and, nor, but, or, yet, so), and 'prepositions' (unless+-- they begin or end the title).++titlecase :: String -> String+titlecase t = go 1 ws where- ws :: [Text]+ ws :: [String] ws = words t isFirst i = i == 1- isLast i = i == List.length ws+ isLast i = i == length ws - go :: Int -> [Text] -> Text+ go :: Int -> [String] -> String go _ [] = "" go i (a:b:c:d:tt) = parse4 i a b c d tt go i (a:b:c :tt) = parse3 i a b c tt@@ -34,28 +25,28 @@ parse4 i a b c d tt = if isFourWordPreposition a b c d- then if | isFirst i && List.null tt+ then if | isFirst i && null tt -> unwords [toTitle a, b, c, toTitle d] | isFirst i -> unwords [toTitle a, b, c, d] <#> go (succ i) tt- | List.null tt -> unwords [ a, b, c, toTitle d]+ | null tt -> unwords [ a, b, c, toTitle d] | otherwise -> unwords [ a, b, c, d] <#> go (succ i) tt else parse3 i a b c (d:tt) parse3 i a b c tt = if isThreeWordPreposition a b c- then if | isFirst i && List.null tt+ then if | isFirst i && null tt -> unwords [toTitle a, b, toTitle c] | isFirst i -> unwords [toTitle a, b, c] <#> go (succ i) tt- | List.null tt -> unwords [ a, b, toTitle c]+ | null tt -> unwords [ a, b, toTitle c] | otherwise -> unwords [ a, b, c] <#> go (succ i) tt else parse2 i a b (c:tt) parse2 i a b tt = if isTwoWordPreposition a b- then if | isFirst i && List.null tt+ then if | isFirst i && null tt -> unwords [toTitle a, toTitle b] | isFirst i -> unwords [toTitle a, b] <#> go (succ i) tt- | List.null tt -> unwords [ a, toTitle b]+ | null tt -> unwords [ a, toTitle b] | otherwise -> unwords [ a, b] <#> go (succ i) tt else parse1 i a (b:tt)
src/Data/Text/Titlecase/Internal.hs view
@@ -1,109 +1,71 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}---- | As the name implies, this module is meant to be used only if--- you want to get access to the internals, say, if you're unhappy--- with the provided 'Data.Text.Titlecase.titlecase' function.--- "Data.Text.Titlecase.Internal" doesn't prevent you from creating--- improperly capitalized 'Titlecase' values. In any other case,--- "Data.Text.Titlecase" is what you're looking for.+-- | As the name implies, this module is meant to be used only if you want to+-- get access to the internals, say, if you're unhappy with the provided+-- 'Data.Text.Titlecase.titlecase' function. module Data.Text.Titlecase.Internal where -import Prelude (Eq, Show, Bool, ($), (.), uncurry)-import Control.Applicative-import qualified Data.Char as Char-import Data.Foldable (elem)-import Data.List.NonEmpty hiding (unwords)-import Data.Semigroup-import Data.Text hiding (toTitle)-import Text.Blaze---- * Types--newtype Titlecase = Titlecase { unTitlecase :: Text } deriving (Eq, Show)--instance ToMarkup Titlecase where- toMarkup (Titlecase t) = toMarkup t- preEscapedToMarkup (Titlecase t) = preEscapedToMarkup t+import Data.Char ( toLower, toUpper ) -newtype Article = Article { unArticle :: Text } deriving (Eq, Show)+-- * Articles -newtype Conjunction = Conjunction { unConjunction :: Text } deriving (Eq, Show)+newtype Article = Article { unArticle :: String } deriving (Eq, Show) -data Preposition = OneWordPreposition Text- | TwoWordPreposition Text Text- | ThreeWordPreposition Text Text Text- | FourWordPreposition Text Text Text Text- deriving (Eq, Show)+isArticle :: String -> Bool+isArticle = isElem unArticle articles +articles :: [Article]+articles = map Article ["a", "an", "the"] --- * Helpers+-- * Conjunctions --- | Capitalize the first character. Note that this function behaves--- differently than 'Data.Text.toTitle'.-toTitle :: Text -> Text-toTitle t = pack $ case unpack t of- "" -> ""- (x:xs) -> Char.toUpper x : xs+newtype Conjunction = Conjunction { unConjunction :: String } deriving (Eq, Show) -(<#>) :: Text -> Text -> Text-x <#> "" = x-x <#> y = x <> " " <> y+conjunctions :: [Conjunction]+conjunctions = map Conjunction ["for", "and", "nor", "but", "or", "yet", "so"] -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d-uncurry3 f (a,b,c) = f a b c+isConjunction :: String -> Bool+isConjunction = isElem unConjunction conjunctions -uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e-uncurry4 f (a,b,c,d) = f a b c d+-- * Prepositions -isElem :: (a -> Text) -> NonEmpty a -> Text -> Bool-isElem f xs = (`elem` (f <$> xs)) . toLower+data Preposition = OneWordPreposition String+ | TwoWordPreposition String String+ | ThreeWordPreposition String String String+ | FourWordPreposition String String String String+ deriving (Eq, Show) -isArticle, isConjunction,- isOneWordPreposition :: Text -> Bool-isTwoWordPreposition :: Text -> Text -> Bool-isThreeWordPreposition :: Text -> Text -> Text -> Bool-isFourWordPreposition :: Text -> Text -> Text -> Text -> Bool+-- | The words come from+-- <https://en.wikipedia.org/wiki/List_of_English_prepositions Wikipedia>+-- but without <https://en.wikipedia.org/wiki/Conjunction_%28grammar%29#Subordinating_conjunctions subordinating conjunctions>. -isArticle = isElem unArticle articles-isConjunction = isElem unConjunction conjunctions-isOneWordPreposition = isElem unPreposition oneWordPrepositions-isTwoWordPreposition a b = isElem unPreposition twoWordPrepositions $ unwords [a, b]-isThreeWordPreposition a b c = isElem unPreposition threeWordPrepositions $ unwords [a, b, c]-isFourWordPreposition a b c d = isElem unPreposition fourWordPrepositions $ unwords [a, b, c, d]+prepositions :: [Preposition]+prepositions+ = oneWordPrepositions+ ++ twoWordPrepositions+ ++ threeWordPrepositions+ ++ fourWordPrepositions -unPreposition :: Preposition -> Text+unPreposition :: Preposition -> String unPreposition p = case p of OneWordPreposition a -> a TwoWordPreposition a b -> unwords [a, b] ThreeWordPreposition a b c -> unwords [a, b, c] FourWordPreposition a b c d -> unwords [a, b, c, d] ---- * Words that are capitalized only when they start or end a title+isOneWordPreposition :: String -> Bool+isOneWordPreposition = isElem unPreposition oneWordPrepositions -articles :: NonEmpty Article-articles = Article <$> fromList ["a", "an", "the"]+isTwoWordPreposition :: String -> String -> Bool+isTwoWordPreposition a b = isElem unPreposition twoWordPrepositions $ unwords [a, b] -conjunctions :: NonEmpty Conjunction-conjunctions = Conjunction <$> fromList- ["for", "and", "nor", "but", "or", "yet", "so"]+isThreeWordPreposition :: String -> String -> String -> Bool+isThreeWordPreposition a b c = isElem unPreposition threeWordPrepositions $ unwords [a, b, c] -prepositions :: NonEmpty Preposition-prepositions- = oneWordPrepositions- <> twoWordPrepositions- <> threeWordPrepositions- <> fourWordPrepositions+isFourWordPreposition :: String -> String -> String -> String -> Bool+isFourWordPreposition a b c d = isElem unPreposition fourWordPrepositions $ unwords [a, b, c, d] --- | The words to not capitalize come from--- <https://en.wikipedia.org/wiki/List_of_English_prepositions Wikipedia primarily>,--- but removing--- <https://en.wikipedia.org/wiki/Conjunction_%28grammar%29#Subordinating_conjunctions subordinating conjunctions>--- generally.-oneWordPrepositions :: NonEmpty Preposition-oneWordPrepositions = OneWordPreposition <$> fromList+oneWordPrepositions :: [Preposition]+oneWordPrepositions = map OneWordPreposition [ "a", "abaft", "abeam", "aboard", "about", "above", "absent", "across" , "afore", "against", "along", "alongside", "amid", "amidst" , "among", "amongst", "an", "anenst", "apropos", "apud", "around"@@ -130,8 +92,8 @@ , "w/o", "worth" ] -twoWordPrepositions :: NonEmpty Preposition-twoWordPrepositions = uncurry TwoWordPreposition <$> fromList+twoWordPrepositions :: [Preposition]+twoWordPrepositions = map (uncurry TwoWordPreposition) [ ("according", "to"), ("ahead", "of"), ("apart", "from"), ("as", "for") , ("as", "of"), ("as", "per"), ("as", "regards"), ("aside", "from") , ("astern", "of")@@ -152,8 +114,8 @@ , ("up", "to") ] -threeWordPrepositions :: NonEmpty Preposition-threeWordPrepositions = uncurry3 ThreeWordPreposition <$> fromList+threeWordPrepositions :: [Preposition]+threeWordPrepositions = map (uncurry3 ThreeWordPreposition) [ ("as", "opposed", "to") , ("as", "well", "as") , ("by", "means", "of"), ("by", "virtue", "of")@@ -165,9 +127,30 @@ , ("with", "regard", "to"), ("with", "respect", "to") ] -fourWordPrepositions :: NonEmpty Preposition-fourWordPrepositions = uncurry4 FourWordPreposition <$> fromList+fourWordPrepositions :: [Preposition]+fourWordPrepositions = map (uncurry4 FourWordPreposition) [ ("at", "the", "behest", "of") , ("for", "the", "sake", "of") , ("with", "a", "view", "to") ]++-- * Helper functions++-- | Capitalize the first character of a string.++toTitle :: String -> String+toTitle "" = ""+toTitle (x:xs) = toUpper x : xs++(<#>) :: String -> String -> String+x <#> "" = x+x <#> y = x ++ " " ++ y++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (a,b,c) = f a b c++uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e+uncurry4 f (a,b,c,d) = f a b c d++isElem :: (a -> String) -> [a] -> String -> Bool+isElem f xs = (`elem` (fmap f xs)) . map toLower
+ tests/Main.hs view
@@ -0,0 +1,12 @@+module Main where++import qualified Property+import qualified Unit++import Test.Tasty++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [Property.tests, Unit.tests]
+ tests/Property.hs view
@@ -0,0 +1,45 @@+module Property where++import Data.Text.Titlecase+import Data.Text.Titlecase.Internal++import Data.List as List+import Test.Tasty+import Test.Tasty.QuickCheck++tests :: TestTree+tests = testGroup "Property tests"+ [ sameLength+ , firstWordCapitalized+ , lastWordCapitalized+ , titlecaseIdempotent+ ]++ignoreList :: [String]+ignoreList =+ (fmap unArticle articles)+ ++ (fmap unConjunction conjunctions)+ ++ (fmap unPreposition prepositions)++arbitraryText :: Gen String+arbitraryText = elements ignoreList++sameLength :: TestTree+sameLength = testProperty "titlecase doesn't change the length" $+ forAll arbitraryText $ \t -> length (titlecase t) === length t++firstWordCapitalized :: TestTree+firstWordCapitalized = testProperty "First word is always capitalized" $+ let wordsHead = List.head . words in+ forAll arbitraryText $+ \t -> not (null t) ==> wordsHead (titlecase t) === toTitle (wordsHead t)++lastWordCapitalized :: TestTree+lastWordCapitalized = testProperty "Last word is always capitalized" $+ let wordsLast = List.last . words in+ forAll arbitraryText $+ \t -> not (null t) ==> wordsLast (titlecase t) === toTitle (wordsLast t)++titlecaseIdempotent :: TestTree+titlecaseIdempotent = testProperty "Applying titlecase twice is the same as doing it once" $+ forAll arbitraryText $ \t -> titlecase (titlecase t) === titlecase t
− tests/Test.hs
@@ -1,11 +0,0 @@-module Main where--import Test.Tasty-import qualified Test.Property as Property-import qualified Test.Unit as Unit--main :: IO ()-main = defaultMain tests--tests :: TestTree-tests = testGroup "Tests" [Property.tests, Unit.tests]
− tests/Test/Property.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Test.Property where--import Prelude (($), (.), not)-import Control.Applicative-import qualified Data.List as List-import qualified Data.List.NonEmpty as NonEmpty-import Data.Semigroup-import Data.Text hiding (toTitle)-import Data.Text.Titlecase-import Data.Text.Titlecase.Internal-import Test.Tasty-import Test.Tasty.QuickCheck--tests :: TestTree-tests = testGroup "Property tests"- [ sameLength- , firstWordCapitalized- , lastWordCapitalized- , titlecaseIdempotent- ]--titlecaseUnsafe :: Text -> Text-titlecaseUnsafe = unTitlecase . titlecase--ignoreList :: [Text]-ignoreList = NonEmpty.toList- $ (unArticle <$> articles)- <> (unConjunction <$> conjunctions)- <> (unPreposition <$> prepositions)--instance Arbitrary Text where- arbitrary = elements ignoreList--sameLength :: TestTree-sameLength = testProperty "titlecase doesn't change the length" $- \t -> length (titlecaseUnsafe t) === length t--firstWordCapitalized :: TestTree-firstWordCapitalized = testProperty "First word is always capitalized" $- let wordsHead = List.head . words in- \t -> not (null t) ==>- wordsHead (titlecaseUnsafe t) === toTitle (wordsHead t)--lastWordCapitalized :: TestTree-lastWordCapitalized = testProperty "Last word is always capitalized" $- let wordsLast = List.last . words in- \t -> not (null t) ==>- wordsLast (titlecaseUnsafe t) === toTitle (wordsLast t)--titlecaseIdempotent :: TestTree-titlecaseIdempotent = testProperty "Applying titlecase twice is the same as doing it once" $- \t -> titlecaseUnsafe (titlecaseUnsafe t) === titlecaseUnsafe t
− tests/Test/Unit.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--module Test.Unit where--import Prelude (($), (.))-import Data.Foldable (mapM_)-import Data.Text hiding (toTitle)-import Data.Text.Titlecase-import Data.Text.Titlecase.Internal hiding (articles, conjunctions, prepositions)-import qualified Data.Text.Titlecase.Internal as Titlecase-import Test.Tasty-import Test.Tasty.HUnit--tests :: TestTree-tests = testGroup "Unit tests" [articles, conjunctions, prepositions]--articles :: TestTree-articles = testGroup "Articles" [articleFirst, articleLast, articleIgnored]--conjunctions :: TestTree-conjunctions = testGroup "Conjunctions" [conjunctionFirst, conjunctionLast, conjunctionIgnored]--prepositions :: TestTree-prepositions = testGroup "Prepositions" [prepositionFirst, prepositionLast, prepositionIgnored]--testTitlecase, testFirst, testLast, testIgnored :: Text -> Assertion-testTitlecase t = titlecase (toLower t) @?= Titlecase t--toTitleFirst :: Text -> Text-toTitleFirst t = unwords $ case words t of- [] -> []- (x:xs) -> toTitle x : xs--toTitleLast :: Text -> Text-toTitleLast t = unwords $ go $ words t- where- go [] = []- go [x] = [toTitle x]- go (x:xs) = x : go xs--testFirst t = testTitlecase $ toTitleFirst t <#> "Is First, so It Is Capitalized"-testLast t = testTitlecase $ "This Sentence Capitalizes" <#> toTitleLast t-testIgnored t = testTitlecase $ "This Sentence Keeps" <#> t <#> "As Is"--articleFirst, articleLast, articleIgnored :: TestTree-articleFirst = testCase "article is first" $ mapM_ (testFirst . unArticle) Titlecase.articles-articleLast = testCase "article is last" $ mapM_ (testLast . unArticle) Titlecase.articles-articleIgnored = testCase "article is ignored" $ mapM_ (testIgnored . unArticle) Titlecase.articles--conjunctionFirst, conjunctionLast, conjunctionIgnored :: TestTree-conjunctionFirst = testCase "conjunction is first" $ mapM_ (testFirst . unConjunction) Titlecase.conjunctions-conjunctionLast = testCase "conjunction is last" $ mapM_ (testLast . unConjunction) Titlecase.conjunctions-conjunctionIgnored = testCase "conjunction is ignored" $ mapM_ (testIgnored . unConjunction) Titlecase.conjunctions--prepositionFirst, prepositionLast, prepositionIgnored :: TestTree-prepositionFirst = testCase "preposition is first" $ mapM_ (testFirst . unPreposition) Titlecase.prepositions-prepositionLast = testCase "preposition is last" $ mapM_ (testLast . unPreposition) Titlecase.prepositions-prepositionIgnored = testCase "preposition is ignored" $ mapM_ (testIgnored . unPreposition) Titlecase.prepositions
+ tests/Unit.hs view
@@ -0,0 +1,55 @@+module Unit where++import Data.Text.Titlecase+import qualified Data.Text.Titlecase.Internal as Titlecase+import Data.Text.Titlecase.Internal hiding (articles, conjunctions, prepositions)++import Test.Tasty+import Test.Tasty.HUnit+import Data.Char ( toLower )++tests :: TestTree+tests = testGroup "Unit tests" [articles, conjunctions, prepositions]++articles :: TestTree+articles = testGroup "Articles" [articleFirst, articleLast, articleIgnored]++conjunctions :: TestTree+conjunctions = testGroup "Conjunctions" [conjunctionFirst, conjunctionLast, conjunctionIgnored]++prepositions :: TestTree+prepositions = testGroup "Prepositions" [prepositionFirst, prepositionLast, prepositionIgnored]++testTitlecase, testFirst, testLast, testIgnored :: String -> Assertion+testTitlecase t = titlecase (map toLower t) @?= t++toTitleFirst :: String -> String+toTitleFirst t = unwords $ case words t of+ [] -> []+ (x:xs) -> toTitle x : xs++toTitleLast :: String -> String+toTitleLast t = unwords $ go $ words t+ where+ go [] = []+ go [x] = [toTitle x]+ go (x:xs) = x : go xs++testFirst t = testTitlecase $ toTitleFirst t <#> "Is First, so It Is Capitalized"+testLast t = testTitlecase $ "This Sentence Capitalizes" <#> toTitleLast t+testIgnored t = testTitlecase $ "This Sentence Keeps" <#> t <#> "As Is"++articleFirst, articleLast, articleIgnored :: TestTree+articleFirst = testCase "article is first" $ mapM_ (testFirst . unArticle) Titlecase.articles+articleLast = testCase "article is last" $ mapM_ (testLast . unArticle) Titlecase.articles+articleIgnored = testCase "article is ignored" $ mapM_ (testIgnored . unArticle) Titlecase.articles++conjunctionFirst, conjunctionLast, conjunctionIgnored :: TestTree+conjunctionFirst = testCase "conjunction is first" $ mapM_ (testFirst . unConjunction) Titlecase.conjunctions+conjunctionLast = testCase "conjunction is last" $ mapM_ (testLast . unConjunction) Titlecase.conjunctions+conjunctionIgnored = testCase "conjunction is ignored" $ mapM_ (testIgnored . unConjunction) Titlecase.conjunctions++prepositionFirst, prepositionLast, prepositionIgnored :: TestTree+prepositionFirst = testCase "preposition is first" $ mapM_ (testFirst . unPreposition) Titlecase.prepositions+prepositionLast = testCase "preposition is last" $ mapM_ (testLast . unPreposition) Titlecase.prepositions+prepositionIgnored = testCase "preposition is ignored" $ mapM_ (testIgnored . unPreposition) Titlecase.prepositions
titlecase.cabal view
@@ -1,9 +1,9 @@--- This file has been generated from package.yaml by hpack version 0.14.1.+-- This file has been generated from package.yaml by hpack version 0.17.0. -- -- see: https://github.com/sol/hpack name: titlecase-version: 0.1.0.3+version: 1 license: BSD3 license-file: LICENSE author: Nikita Karetnikov,@@ -16,8 +16,8 @@ stability: stable build-type: Simple cabal-version: >= 1.10-synopsis: Convert English words to title case-description: Capitalize all English words except articles (a, an, the), coordinating conjunctions (for, and, nor, but, or, yet, so), and prepositions (unless they begin or end the title). The prepositions are taken from <https://en.wikipedia.org/wiki/List_of_English_prepositions>.+synopsis: Convert English Words to Title Case+description: Capitalize all English words except articles (a, an, the), coordinating conjunctions (for, and, nor, but, or, yet, so), and prepositions (unless they begin or end the title). The prepositions are taken from <https://en.wikipedia.org/wiki/List_of_English_prepositions Wikipedia>. tested-with: GHC > 7.6 && < 8.1 source-repository head@@ -28,12 +28,10 @@ default-language: Haskell2010 hs-source-dirs: src+ other-extensions: MultiWayIf ghc-options: -Wall build-depends:- base <5,- blaze-markup,- semigroups,- text+ base <5 exposed-modules: Data.Text.Titlecase Data.Text.Titlecase.Internal@@ -46,27 +44,21 @@ ghc-options: -Wall build-depends: base <5,- blaze-markup,- semigroups,- text, titlecase test-suite test type: exitcode-stdio-1.0- main-is: Test.hs+ main-is: Main.hs hs-source-dirs: tests ghc-options: -Wall build-depends: base <5,- blaze-markup,- semigroups,- text, titlecase, tasty, tasty-hunit, tasty-quickcheck other-modules:- Test.Property- Test.Unit+ Property+ Unit default-language: Haskell2010