diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,1 @@ +*~ diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/shell.nix b/shell.nix new file mode 100644 --- /dev/null +++ b/shell.nix @@ -0,0 +1,19 @@ +with (import {}).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 diff --git a/src/Data/Text/Titlecase.hs b/src/Data/Text/Titlecase.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Titlecase.hs @@ -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: +-- . +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 diff --git a/src/Data/Text/Titlecase/Internal.hs b/src/Data/Text/Titlecase/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Titlecase/Internal.hs @@ -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") + ] diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -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] diff --git a/tests/Test/Property.hs b/tests/Test/Property.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Property.hs @@ -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 diff --git a/tests/Test/Unit.hs b/tests/Test/Unit.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Unit.hs @@ -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 diff --git a/titlecase.cabal b/titlecase.cabal new file mode 100644 --- /dev/null +++ b/titlecase.cabal @@ -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: + . + +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