titlecase (empty) → 0.1.0.0
raw patch · 10 files changed
+461/−0 lines, 10 filesdep +basedep +blaze-markupdep +semigroupssetup-changed
Dependencies added: base, blaze-markup, semigroups, tasty, tasty-hunit, tasty-quickcheck, text, titlecase
Files
- .gitignore +1/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- shell.nix +19/−0
- src/Data/Text/Titlecase.hs +67/−0
- src/Data/Text/Titlecase/Internal.hs +163/−0
- tests/Test.hs +11/−0
- tests/Test/Property.hs +56/−0
- tests/Test/Unit.hs +59/−0
- titlecase.cabal +53/−0
+ .gitignore view
@@ -0,0 +1,1 @@+*~
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2015 Nikita Karetnikov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Nikita Karetnikov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ shell.nix view
@@ -0,0 +1,19 @@+with (import <nixpkgs> {}).pkgs;+let pkg = haskellngPackages.callPackage+ ({ mkDerivation, base, blaze-markup, cabal-install, git, semigroups+ , stdenv, text, tasty, tasty-hunit, tasty-quickcheck }:+ mkDerivation {+ pname = "titlecase";+ version = "0.1.0.0";+ src = ./.;+ buildDepends = [ base blaze-markup semigroups text ];+ testDepends = [+ base semigroups tasty tasty-hunit tasty-quickcheck text+ ];+ buildTools = [ cabal-install git ];+ homepage = "https://github.com/nkaretnikov/titlecase";+ description = "Convert English words to title case";+ license = stdenv.lib.licenses.bsd3;+ }) {};+in+ pkg.env
+ src/Data/Text/Titlecase.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-}++module Data.Text.Titlecase+ ( Titlecase+ , titlecase+ ) where++import Prelude (Int, ($), (==), (||), (&&), succ, otherwise)+import qualified Data.List as List+import Data.Text hiding (toTitle)+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+ where+ ws :: [Text]+ ws = words t+ isFirst i = i == 1+ isLast i = i == List.length ws++ go :: Int -> [Text] -> Text+ 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+ go i (a:b :tt) = parse2 i a b tt+ go i (a :tt) = parse1 i a tt++ parse4 i a b c d tt =+ if isFourWordPreposition a b c d+ then if | isFirst i && List.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]+ | 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+ -> 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]+ | 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+ -> unwords [toTitle a, toTitle b]+ | isFirst i -> unwords [toTitle a, b] <#> go (succ i) tt+ | List.null tt -> unwords [ a, toTitle b]+ | otherwise -> unwords [ a, b] <#> go (succ i) tt+ else parse1 i a (b:tt)++ parse1 i a tt =+ if isOneWordPreposition a || isConjunction a || isArticle a+ then if isFirst i || isLast i+ then toTitle a <#> go (succ i) tt+ else a <#> go (succ i) tt+ else toTitle a <#> go (succ i) tt
+ src/Data/Text/Titlecase/Internal.hs view
@@ -0,0 +1,163 @@+{-# 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.++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++newtype Article = Article { unArticle :: Text } deriving (Eq, Show)++newtype Conjunction = Conjunction { unConjunction :: Text } deriving (Eq, Show)++data Preposition = OneWordPreposition Text+ | TwoWordPreposition Text Text+ | ThreeWordPreposition Text Text Text+ | FourWordPreposition Text Text Text Text+ deriving (Eq, Show)+++-- * Helpers++-- | 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++(<#>) :: Text -> Text -> Text+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 -> Text) -> NonEmpty a -> Text -> Bool+isElem f xs = (`elem` (f <$> xs)) . toLower++isArticle, isConjunction,+ isOneWordPreposition :: Text -> Bool+isTwoWordPreposition :: Text -> Text -> Bool+isThreeWordPreposition :: Text -> Text -> Text -> Bool+isFourWordPreposition :: Text -> Text -> Text -> Text -> Bool++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]++unPreposition :: Preposition -> Text+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++articles :: NonEmpty Article+articles = Article <$> fromList ["a", "an", "the"]++conjunctions :: NonEmpty Conjunction+conjunctions = Conjunction <$> fromList+ ["for", "and", "nor", "but", "or", "yet", "so"]++prepositions :: NonEmpty Preposition+prepositions+ = oneWordPrepositions+ <> twoWordPrepositions+ <> threeWordPrepositions+ <> fourWordPrepositions++oneWordPrepositions :: NonEmpty Preposition+oneWordPrepositions = OneWordPreposition <$> fromList+ [ "a", "abaft", "abeam", "aboard", "about", "above", "absent", "across"+ , "afore", "after", "against", "along", "alongside", "amid", "amidst"+ , "among", "amongst", "an", "anenst", "apropos", "apud", "around", "as"+ , "aside", "astride", "at", "athwart", "atop"+ , "barring", "before", "behind", "below", "beneath", "beside", "besides"+ , "between", "beyond", "but", "by"+ , "chez", "circa", "concerning", "considering"+ , "despite", "down", "during"+ , "except", "excluding", "failing", "following", "for", "forenenst", "from"+ , "given"+ , "in", "including", "inside", "into"+ , "like"+ , "mid", "midst", "minus", "modulo"+ , "near", "next", "notwithstanding"+ , "of", "off", "on", "onto", "opposite", "out", "outside", "over"+ , "pace", "past", "per", "plus", "pro"+ , "qua"+ , "regarding", "round"+ , "sans", "save", "since", "than", "through"+ ]++twoWordPrepositions :: NonEmpty Preposition+twoWordPrepositions = uncurry TwoWordPreposition <$> fromList+ [ ("according", "to"), ("ahead", "of"), ("apart", "from"), ("as", "for")+ , ("as", "of"), ("as", "per"), ("as", "regards"), ("aside", "from")+ , ("astern", "of")+ , ("back", "to"), ("because", "of")+ , ("close", "to")+ , ("due", "to")+ , ("except", "for")+ , ("far", "from")+ , ("in", "to"), ("inside", "of"), ("instead", "of")+ , ("left", "of")+ , ("near", "to"), ("next", "to")+ , ("on", "to"), ("opposite", "of"), ("opposite", "to"), ("out", "from")+ , ("out", "of"), ("outside", "of"), ("owing", "to")+ , ("prior", "to"), ("pursuant", "to")+ , ("rather", "than"), ("regardless", "of"), ("right", "of")+ , ("subsequent", "to"), ("such", "as")+ , ("thanks", "to"), ("that", "of")+ , ("up", "to")+ ]++threeWordPrepositions :: NonEmpty Preposition+threeWordPrepositions = uncurry3 ThreeWordPreposition <$> fromList+ [ ("as", "far", "as"), ("as", "long", "as"), ("as", "opposed", "to")+ , ("as", "soon", "as"), ("as", "well", "as")+ , ("by", "means", "of"), ("by", "virtue", "of")+ , ("in", "accordance", "with"), ("in", "addition", "to")+ , ("in", "case", "of"), ("in", "front", "of"), ("in", "lieu", "of")+ , ("in", "order", "to"), ("in", "place", "of"), ("in", "point", "of")+ , ("in", "spite", "of")+ , ("on", "account", "of"), ("on", "behalf", "of"), ("on", "top", "of")+ , ("with", "regard", "to"), ("with", "respect", "to")+ ]++fourWordPrepositions :: NonEmpty Preposition+fourWordPrepositions = uncurry4 FourWordPreposition <$> fromList+ [ ("at", "the", "behest", "of")+ , ("for", "the", "sake", "of")+ , ("with", "a", "view", "to")+ ]
+ tests/Test.hs view
@@ -0,0 +1,11 @@+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 view
@@ -0,0 +1,56 @@+{-# 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 view
@@ -0,0 +1,59 @@+{-# 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
+ titlecase.cabal view
@@ -0,0 +1,53 @@+name: titlecase+version: 0.1.0.0+license: BSD3+license-file: LICENSE+author: Nikita Karetnikov+maintainer: nikita@karetnikov.org+homepage: https://github.com/nkaretnikov/titlecase+bug-reports: https://github.com/nkaretnikov/titlecase/issues+copyright: 2015 Nikita Karetnikov+category: Text+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 this list:+ <https://en.wikipedia.org/wiki/List_of_English_prepositions>.++extra-source-files:+ .gitignore+ shell.nix++source-repository head+ type: git+ location: https://github.com/nkaretnikov/titlecase++library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules: Data.Text.Titlecase+ , Data.Text.Titlecase.Internal+ build-depends: base >=4.7 && <4.8+ , blaze-markup+ , semigroups+ , text++test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Test.hs+ ghc-options: -Wall+ other-modules: Test.Property+ , Test.Unit+ build-depends: base >=4.7 && <4.8+ , semigroups+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , text+ , titlecase