diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Main ( main ) where - -import Data.Text.Titlecase -import System.Environment - -main :: IO () -main = getArgs >>= parseArgs >>= putStrLn . titlecase - where parseArgs :: [String] -> IO String - parseArgs [] = getContents - parseArgs xs = return $ unwords xs diff --git a/src/Data/Text/Titlecase.hs b/src/Data/Text/Titlecase.hs --- a/src/Data/Text/Titlecase.hs +++ b/src/Data/Text/Titlecase.hs @@ -3,18 +3,30 @@ module Data.Text.Titlecase ( titlecase ) where import Data.Text.Titlecase.Internal +import Data.Char ( isSpace ) -- | 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). +-- ASCII hyphens separate components, which follow the same rules as words. +-- Whitespace and hyphens are preserved exactly. titlecase :: String -> String -titlecase t = go 1 ws +titlecase t = restoreSeparators t (words (go 1 ws)) where + -- The parser changes capitalization, but never the number of words. + -- Put its output words back between the original separator runs. + restoreSeparators :: String -> [String] -> String + restoreSeparators original [] = original + restoreSeparators original (w:rest) = + let (spacing, text) = span isSeparator original + remaining = dropWhile (not . isSeparator) text + in spacing ++ w ++ restoreSeparators remaining rest + ws :: [String] - ws = words t + ws = words (map (\c -> if c == '-' then ' ' else c) t) + isSeparator c = isSpace c || c == '-' isFirst i = i == 1 - isLast i = i == length ws go :: Int -> [String] -> String go _ [] = "" @@ -52,7 +64,7 @@ parse1 i a tt = if isOneWordPreposition a || isConjunction a || isArticle a - then if isFirst i || isLast i + then if isFirst i || null tt then toTitle a <#> go (succ i) tt else a <#> go (succ i) tt else toTitle a <#> go (succ i) tt diff --git a/src/Data/Text/Titlecase/Internal.hs b/src/Data/Text/Titlecase/Internal.hs --- a/src/Data/Text/Titlecase/Internal.hs +++ b/src/Data/Text/Titlecase/Internal.hs @@ -153,4 +153,4 @@ 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 +isElem f xs = (`elem` fmap f xs) . map toLower diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,12 +0,0 @@ -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] diff --git a/tests/Property.hs b/tests/Property.hs --- a/tests/Property.hs +++ b/tests/Property.hs @@ -1,9 +1,9 @@ module Property where import Data.Text.Titlecase -import Data.Text.Titlecase.Internal +import qualified Data.Text.Titlecase.Internal as Titlecase -import Data.List as List +import Data.Char ( isSpace, toUpper ) import Test.Tasty import Test.Tasty.QuickCheck @@ -13,33 +13,88 @@ , firstWordCapitalized , lastWordCapitalized , titlecaseIdempotent + , whitespacePreserved + , wordContentsPreserved + , hyphensPreserved + , hyphensSeparateComponents + , whitespaceDoesNotAffectCapitalization ] ignoreList :: [String] ignoreList = - (fmap unArticle articles) - ++ (fmap unConjunction conjunctions) - ++ (fmap unPreposition prepositions) + fmap Titlecase.unArticle Titlecase.articles + ++ fmap Titlecase.unConjunction Titlecase.conjunctions + ++ fmap Titlecase.unPreposition Titlecase.prepositions +-- Include complete multi-word prepositions as well as words outside the +-- exception lists. Mixed case and punctuation exercise preservation rules. arbitraryText :: Gen String -arbitraryText = elements ignoreList +arbitraryText = frequency + [ (3, unwords <$> listOf (elements ignoreList)) + , (7, concat <$> listOf (frequency + [ (4, elements ignoreList) + , (3, elements ["hello", "world", "Perfect", "iPhone", "NASA", "éclair", "über", "123", "follow-up", "state-of-the-art", "in-front-of", "\"hello\"", "(world)", "story:", "and,"]) + , (3, elements [" ", " ", "\t", "\n", "\r\n", "\160", "\8195", "\t \n", "-", "--"]) + ])) + ] +-- Shrinking strings can remove words, shorten them, and simplify separators. +-- All properties below also cover empty and whitespace-only inputs. +forText :: (String -> Property) -> Property +forText = forAllShrink arbitraryText shrink + sameLength :: TestTree -sameLength = testProperty "titlecase doesn't change the length" $ - forAll arbitraryText $ \t -> length (titlecase t) === length t +sameLength = testProperty "Titlecase preserves length" $ + forText $ \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) + forText $ \t -> case (components t, components (titlecase t)) of + ([], result) -> result === [] + ((c:cs):_, result:_) -> result === toUpper c : cs + _ -> counterexample "Missing first word" False 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) + forText $ \t -> case (reverse (components t), reverse (components (titlecase t))) of + ([], result) -> result === [] + ((c:cs):_, result:_) -> result === toUpper c : cs + _ -> counterexample "Missing last word" False titlecaseIdempotent :: TestTree titlecaseIdempotent = testProperty "Applying titlecase twice is the same as doing it once" $ - forAll arbitraryText $ \t -> titlecase (titlecase t) === titlecase t + forText $ \t -> titlecase (titlecase t) === titlecase t + +whitespacePreserved :: TestTree +whitespacePreserved = testProperty "Whitespace characters keep their positions" $ + forText $ \t -> + let whitespacePositions = filter (isSpace . snd) . zip [0 :: Int ..] + in whitespacePositions (titlecase t) === whitespacePositions t + +wordContentsPreserved :: TestTree +wordContentsPreserved = testProperty "Only component-initial characters may change" $ + forText $ \t -> + let original = components t + result = components (titlecase t) + unchanged inputWord outputWord = case (inputWord, outputWord) of + (c:cs, d:ds) -> conjoin [cs === ds, property (d == c || d == toUpper c)] + _ -> counterexample "Unexpected empty word" False + in conjoin ((length result === length original) : zipWith unchanged original result) + +whitespaceDoesNotAffectCapitalization :: TestTree +whitespaceDoesNotAffectCapitalization = testProperty "Whitespace does not affect capitalization" $ + forText $ \t -> words (titlecase t) === words (titlecase (unwords (words t))) + +-- A component ends at either whitespace or an ASCII hyphen. +components :: String -> [String] +components = words . map (\c -> if c == '-' then ' ' else c) + +hyphensPreserved :: TestTree +hyphensPreserved = testProperty "Hyphens keep their positions" $ + forText $ \t -> + let positions = filter ((== '-') . snd) . zip [0 :: Int ..] + in positions (titlecase t) === positions t + +hyphensSeparateComponents :: TestTree +hyphensSeparateComponents = testProperty "Hyphenated components follow word rules" $ + forText $ \t -> components (titlecase t) === words (titlecase (unwords (components t))) diff --git a/tests/Unit.hs b/tests/Unit.hs --- a/tests/Unit.hs +++ b/tests/Unit.hs @@ -6,50 +6,99 @@ import Test.Tasty import Test.Tasty.HUnit -import Data.Char ( toLower ) +import Data.Char ( toUpper ) tests :: TestTree -tests = testGroup "Unit tests" [articles, conjunctions, prepositions] - -articles :: TestTree -articles = testGroup "Articles" [articleFirst, articleLast, articleIgnored] +tests = testGroup "Unit tests" [articles, conjunctions, prepositions, issue4, issue5, issue7, examples] -conjunctions :: TestTree -conjunctions = testGroup "Conjunctions" [conjunctionFirst, conjunctionLast, conjunctionIgnored] +issue5 :: TestTree +issue5 = testGroup "#5: hyphenated titles" + [ testCase label $ titlecase input @?= expected + | (label, input, expected) <- + [ ("reported example", "John wins follow-up election", "John Wins Follow-up Election") + , ("final up", "a follow-up", "A Follow-Up") + , ("internal exceptions", "state-of-the-art design", "State-of-the-Art Design") + , ("mother-in-law", "mother-in-law", "Mother-in-Law") + , ("final component", "a walk-in", "A Walk-In") + , ("internal final component", "a walk-in closet", "A Walk-in Closet") + , ("existing case", "non-English text", "Non-English Text") + , ("conjunction", "a pick-and-mix selection", "A Pick-and-Mix Selection") + , ("first component", "the-art of writing", "The-Art of Writing") + , ("multi-word preposition", "in-front-of", "In-front-Of") + , ("four-word preposition", "at-the-behest-of", "At-the-behest-Of") + , ("mixed separators", " far-from perfect:\tthings to complain-about ", " Far-from Perfect:\tThings to Complain-About ") + , ("repeated and boundary hyphens", "--the--story-of--", "--The--Story-Of--") + , ("hyphens only", " - --\t- ", " - --\t- ") + , ("Unicode components", "vis-à-vis", "Vis-À-Vis") + , ("en dash is unchanged", "hello–world", "Hello–world") + , ("em dash is unchanged", "hello—world", "Hello—world") + ] + ] -prepositions :: TestTree -prepositions = testGroup "Prepositions" [prepositionFirst, prepositionLast, prepositionIgnored] +issue7 :: TestTree +issue7 = testGroup "#7: preserve whitespace" + [ testCase label $ titlecase input @?= expected + | (label, input, expected) <- + [ ("leading spaces", " foo bar", " Foo Bar") + , ("trailing spaces", "foo bar ", "Foo Bar ") + , ("repeated spaces", "foo bar", "Foo Bar") + , ("tab", "foo\tbar", "Foo\tBar") + , ("nonbreaking space", "foo\160bar", "Foo\160Bar") + , ("newlines", "foo\r\nbar\n", "Foo\r\nBar\n") + , ("empty input", "", "") + , ("whitespace only", " \t\r\n\160 ", " \t\r\n\160 ") + , ("padded boundary words", "\tthe story of\n", "\tThe Story Of\n") + , ("two-word preposition", "\tfar from perfect about\n", "\tFar from Perfect About\n") + , ("three-word preposition", "in\tfront of", "In\tfront Of") + , ("four-word preposition", "at\tthe\nbehest\160of ", "At\tthe\nbehest\160Of ") + , ("internal preposition", "a tale in\tfront of us", "A Tale in\tfront of Us") + ] + ] -testTitlecase, testFirst, testLast, testIgnored :: String -> Assertion -testTitlecase t = titlecase (map toLower t) @?= t +issue4 :: TestTree +issue4 = testCase "#4: capitalize final word after a multi-word preposition" $ + titlecase "far from perfect: things to complain about" + @?= "Far from Perfect: Things to Complain About" -toTitleFirst :: String -> String -toTitleFirst t = unwords $ case words t of - [] -> [] - (x:xs) -> toTitle x : xs +-- Each phrase is a separate test so failures identify the exact exception. +articles, conjunctions, prepositions :: TestTree +articles = exceptionTests "Articles" (map unArticle Titlecase.articles) +conjunctions = exceptionTests "Conjunctions" (map unConjunction Titlecase.conjunctions) +-- Hyphenated entries are governed by component rules, tested in issue5. +prepositions = exceptionTests "Prepositions" (filter (notElem '-') (map unPreposition Titlecase.prepositions)) -toTitleLast :: String -> String -toTitleLast t = unwords $ go $ words t +exceptionTests :: String -> [String] -> TestTree +exceptionTests label phrases = testGroup label + [ testGroup phrase + [ testCase "first" $ + titlecase (phrase ++ " example") @?= capitalize phrase ++ " Example" + , testCase "last" $ + titlecase ("example " ++ phrase) @?= "Example " ++ capitalizeLast phrase + , testCase "internal" $ + titlecase ("example " ++ phrase ++ " example") @?= "Example " ++ phrase ++ " Example" + , testCase "whole title" $ + titlecase phrase @?= capitalize (capitalizeLast phrase) + ] + | phrase <- phrases + ] 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 + capitalize "" = "" + capitalize (c:cs) = toUpper c : cs + capitalizeLast = unwords . reverse . firstUpper . reverse . words + firstUpper [] = [] + firstUpper (w:ws) = capitalize w : ws -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 +examples :: TestTree +examples = testGroup "Examples" + [ testCase label $ titlecase input @?= expected + | (label, input, expected) <- + [ ("ordinary words and exceptions", "a journey through the world", "A Journey through the World") + , ("single article", "the", "The") + , ("single ordinary word", "hello", "Hello") + , ("preserve existing case", "an iPhone and NASA", "An IPhone and NASA") + , ("Unicode initials", "éclair and über", "Éclair and Über") + , ("digits", "123 stories", "123 Stories") + , ("punctuation preserved", "hello, world!", "Hello, World!") + , ("overlapping prepositions", "in front of the house", "In front of the House") + ] + ] diff --git a/tests/regression-tests.hs b/tests/regression-tests.hs new file mode 100644 --- /dev/null +++ b/tests/regression-tests.hs @@ -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] diff --git a/titlecase.cabal b/titlecase.cabal --- a/titlecase.cabal +++ b/titlecase.cabal @@ -1,9 +1,5 @@ --- This file has been generated from package.yaml by hpack version 0.18.1. --- --- see: https://github.com/sol/hpack - name: titlecase -version: 1.0.1 +version: 1.0.2 license: BSD3 license-file: LICENSE author: Nikita Karetnikov, @@ -18,12 +14,19 @@ 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 . -tested-with: GHC > 7.6 && < 8.1 +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 + . +tested-with: GHC == 8.4.4, GHC == 8.6.5, + GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, + GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3, + GHC == 9.12.4, GHC == 9.14.1 source-repository head type: git - location: https://github.com/peti/titlecase + location: https://github.com/peti/titlecase.git library default-language: Haskell2010 @@ -41,15 +44,15 @@ executable titlecase default-language: Haskell2010 - main-is: Main.hs + main-is: titlecase.hs ghc-options: -Wall build-depends: base <5, titlecase -test-suite test +test-suite regression-tests type: exitcode-stdio-1.0 - main-is: Main.hs + main-is: regression-tests.hs hs-source-dirs: tests ghc-options: -Wall diff --git a/titlecase.hs b/titlecase.hs new file mode 100644 --- /dev/null +++ b/titlecase.hs @@ -0,0 +1,10 @@ +module Main ( main ) where + +import Data.Text.Titlecase +import System.Environment + +main :: IO () +main = getArgs >>= parseArgs >>= putStrLn . titlecase + where parseArgs :: [String] -> IO String + parseArgs [] = getContents + parseArgs xs = return $ unwords xs