diff --git a/casing.cabal b/casing.cabal index bcc311d..15ac2af 100644 --- a/casing.cabal +++ b/casing.cabal @@ -34,7 +34,9 @@ test-suite tests hs-source-dirs: tests type: exitcode-stdio-1.0 default-language: Haskell2010 - build-depends: base >=4.8 && <5 - , casing - , tasty - , tasty-hunit + build-depends: + base >=4.8 && <5 + , casing + , tasty + , tasty-hunit + , tasty-quickcheck diff --git a/src/Text/Casing.hs b/src/Text/Casing.hs index 23db530..54eb71f 100644 --- a/src/Text/Casing.hs +++ b/src/Text/Casing.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE BangPatterns, DeriveTraversable, GeneralizedNewtypeDeriving #-} -- | Conversions between several common identifier casing conventions: -- -- - @PascalCase@ - no spacing between words, first letter in word is @@ -41,7 +40,8 @@ Identifier (..) where import Data.Char -import Data.List (intersperse) +import Data.Semigroup(Semigroup((<>))) +import Data.List (intercalate) import Data.List.Split (wordsBy) import Control.Applicative @@ -49,41 +49,36 @@ import Control.Applicative newtype Identifier a = Identifier { unIdentifier :: [a] } deriving (Monad, Functor, Applicative, Show, Foldable, Traversable, Eq) +instance Semigroup (Identifier a) where + Identifier a <> Identifier b = Identifier (a <> b) + wordCase :: String -> String wordCase "" = "" wordCase (x:xs) = toUpper x : map toLower xs -- | Convert from "humped" casing (@camelCase@ or @PascalCase@) fromHumps :: String -> Identifier String -fromHumps = Identifier . go - where - go "" = [""] - go (x:[]) = [x:[]] - go xxs@(x:xs) - | isUpper x = - let lhs = takeWhile isUpper xxs - rhs = dropWhile isUpper xxs - in - if null rhs then - [lhs] - else - let curLen = length lhs - 1 - cur = take curLen lhs - rec = go rhs - nxt = drop curLen lhs ++ concat (take 1 rec) - rem = drop 1 rec - curL = if null cur then [] else [cur] - nxtL = if null nxt then [] else [nxt] - in curL ++ nxtL ++ rem - - | otherwise = - let cur = takeWhile (not . isUpper) xxs - rem = dropWhile (not . isUpper) xxs - in - if null rem then - [cur] - else - cur:go rem +fromHumps = Identifier . _fromHumps + +_fromHumps :: String -> [String] +_fromHumps "" = [""] +_fromHumps c = _fromHumps' c + +_unsnoc :: [a] -> a -> ([a], a) +_unsnoc [] x = ([], x) +_unsnoc (y:ys) x = let !(za, zb) = _unsnoc ys y in (x:za, zb) + +_fromHumps' :: String -> [String] +_fromHumps' [] = [] +_fromHumps' ca@(c:cs) + | isUpper c = go (span isUpper cs) + | otherwise = let (ba, bb) = break isUpper cs in (c:ba) : _fromHumps' bb + where go (_,[]) = [ca] + go (ls, rs) = addlsa ((l:y) : ys) + where !(lsa, l) = _unsnoc ls c + !(y:ys) = _fromHumps' rs + addlsa | null lsa = id + | otherwise = (lsa :) fromWords :: String -> Identifier String fromWords = Identifier . words @@ -102,20 +97,20 @@ fromAny str = fromHumps str >>= fromKebab >>= fromSnake >>= fromWords -- | To @PascalCase@ toPascal :: Identifier String -> String -toPascal = concat . map wordCase . unIdentifier +toPascal = concatMap wordCase . unIdentifier -- | To @camelCase@ toCamel :: Identifier String -> String toCamel (Identifier []) = "" -toCamel (Identifier (x:xs)) = concat $ map toLower x:map wordCase xs +toCamel (Identifier (x:xs)) = map toLower x ++ concatMap wordCase xs -- | To @kebab-case@ toKebab :: Identifier String -> String -toKebab = concat . intersperse "-" . map (map toLower) . unIdentifier +toKebab = intercalate "-" . map (map toLower) . unIdentifier -- | To @snake_Case@ toSnake :: Identifier String -> String -toSnake = concat . intersperse "_" . unIdentifier +toSnake = intercalate "_" . unIdentifier -- | To @quiet_snake_case@ toQuietSnake :: Identifier String -> String @@ -159,5 +154,5 @@ wordify = toWords . fromAny -- | Drop the first word from a parsed identifier. Typical usage is between -- parsing and writing, e.g.: @toKebab . dropPrefix . fromAny $ "strHelloWorld" == "hello-world"@ -dropPrefix :: Identifier String -> Identifier String -dropPrefix = Identifier . drop 1 . unIdentifier +dropPrefix :: Identifier [a] -> Identifier [a] +dropPrefix = fmap (drop 1) diff --git a/tests/Spec.hs b/tests/Spec.hs index 4d771d7..4f87c98 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,217 +1,252 @@ module Main where +import Data.Char(isUpper) import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck import Text.Casing main :: IO () main = defaultMain tests +-- Test if the new "fromHumps" is equivalent to the old one. +oldFromHumps :: String -> Identifier String +oldFromHumps = Identifier . go + where + go "" = [""] + go (x:[]) = [x:[]] + go xxs@(x:xs) + | isUpper x = + let lhs = takeWhile isUpper xxs + rhs = dropWhile isUpper xxs + in + if null rhs then + [lhs] + else + let curLen = length lhs - 1 + cur = take curLen lhs + rec = go rhs + nxt = drop curLen lhs ++ concat (take 1 rec) + rem = drop 1 rec + curL = if null cur then [] else [cur] + nxtL = if null nxt then [] else [nxt] + in curL ++ nxtL ++ rem + + | otherwise = + let cur = takeWhile (not . isUpper) xxs + rem = dropWhile (not . isUpper) xxs + in + if null rem then + [cur] + else + cur:go rem + tests :: TestTree tests = testGroup "tests" [ testGroup "parsing" [ testGroup "fromHumps" - [ testCase "no splits 1" $ do + [ testCase "no splits 1" $ assertEqual "" (Identifier ["hello"]) (fromHumps "hello") - , testCase "no splits 2" $ do + , testCase "no splits 2" $ assertEqual "" (Identifier ["Hello"]) (fromHumps "Hello") - , testCase "non-alpha, no split" $ do + , testCase "non-alpha, no split" $ assertEqual "" (Identifier ["-hello"]) (fromHumps "-hello") - , testCase "non-alpha, split" $ do + , testCase "non-alpha, split" $ assertEqual "" (Identifier ["-hello-", "World"]) (fromHumps "-hello-World") - , testCase "simple split camel" $ do + , testCase "simple split camel" $ assertEqual "" (Identifier ["hello", "World"]) (fromHumps "helloWorld") - , testCase "simple split pascal" $ do + , testCase "simple split pascal" $ assertEqual "" (Identifier ["Hello", "World"]) (fromHumps "HelloWorld") - , testCase "single letter abbrev split" $ do + , testCase "single letter abbrev split" $ assertEqual "" (Identifier ["Hello", "A", "World"]) (fromHumps "HelloAWorld") - , testCase "multi letter abbrev split" $ do + , testCase "multi letter abbrev split" $ assertEqual "" (Identifier ["Hello", "XML", "World"]) (fromHumps "HelloXMLWorld") - , testCase "multi letter acronym at the end" $ do + , testCase "multi letter acronym at the end" $ assertEqual "" (Identifier ["Hello", "XML"]) (fromHumps "HelloXML") - , testCase "single letter upper" $ do + , testCase "single letter upper" $ assertEqual "" (Identifier ["A"]) (fromHumps "A") - , testCase "single letter lower" $ do + , testCase "single letter lower" $ assertEqual "" (Identifier ["a"]) (fromHumps "a") + , testProperty "simplification fromHumps is the same" (\c -> fromHumps c == oldFromHumps c) ] , testGroup "fromKebab" - [ testCase "no splits" $ do + [ testCase "no splits" $ assertEqual "" (Identifier ["hello"]) (fromKebab "hello") - , testCase "single split" $ do + , testCase "single split" $ assertEqual "" (Identifier ["hello", "world"]) (fromKebab "hello-world") - , testCase "leading split" $ do + , testCase "leading split" $ assertEqual "" (Identifier ["world"]) (fromKebab "-world") - , testCase "trailing split" $ do + , testCase "trailing split" $ assertEqual "" (Identifier ["world"]) (fromKebab "world-") - , testCase "multiple dashes" $ do + , testCase "multiple dashes" $ assertEqual "" (Identifier ["hello", "world"]) (fromKebab "hello---world") ] , testGroup "fromSnake" - [ testCase "no splits" $ do + [ testCase "no splits" $ assertEqual "" (Identifier ["hello"]) (fromSnake "hello") - , testCase "single split" $ do + , testCase "single split" $ assertEqual "" (Identifier ["hello", "world"]) (fromSnake "hello_world") - , testCase "leading split" $ do + , testCase "leading split" $ assertEqual "" (Identifier ["world"]) (fromSnake "_world") - , testCase "trailing split" $ do + , testCase "trailing split" $ assertEqual "" (Identifier ["world"]) (fromSnake "world_") - , testCase "multiple dashes" $ do + , testCase "multiple dashes" $ assertEqual "" (Identifier ["hello", "world"]) (fromSnake "hello___world") ] , testGroup "fromWords" - [ testCase "no splits" $ do + [ testCase "no splits" $ assertEqual "" (Identifier ["hello"]) (fromWords "hello") - , testCase "single split" $ do + , testCase "single split" $ assertEqual "" (Identifier ["hello", "world"]) (fromWords "hello world") - , testCase "leading split" $ do + , testCase "leading split" $ assertEqual "" (Identifier ["world"]) (fromWords " world") - , testCase "trailing split" $ do + , testCase "trailing split" $ assertEqual "" (Identifier ["world"]) (fromWords "world ") - , testCase "multiple dashes" $ do + , testCase "multiple dashes" $ assertEqual "" (Identifier ["hello", "world"]) (fromWords "hello world") ] , testGroup "fromAny" - [ testCase "no splits 1" $ do + [ testCase "no splits 1" $ assertEqual "" (Identifier ["hello"]) (fromAny "hello") - , testCase "no splits 2" $ do + , testCase "no splits 2" $ assertEqual "" (Identifier ["Hello"]) (fromAny "Hello") - , testCase "simple split camel" $ do + , testCase "simple split camel" $ assertEqual "" (Identifier ["hello", "World"]) (fromAny "helloWorld") - , testCase "simple split pascal" $ do + , testCase "simple split pascal" $ assertEqual "" (Identifier ["Hello", "World"]) (fromAny "HelloWorld") - , testCase "single letter abbrev split" $ do + , testCase "single letter abbrev split" $ assertEqual "" (Identifier ["Hello", "A", "World"]) (fromAny "HelloAWorld") - , testCase "multi letter abbrev split" $ do + , testCase "multi letter abbrev split" $ assertEqual "" (Identifier ["Hello", "XML", "World"]) (fromAny "HelloXMLWorld") - , testCase "single letter upper" $ do + , testCase "single letter upper" $ assertEqual "" (Identifier ["A"]) (fromAny "A") - , testCase "single letter lower" $ do + , testCase "single letter lower" $ assertEqual "" (Identifier ["a"]) (fromAny "a") - , testCase "no splits" $ do + , testCase "no splits" $ assertEqual "" (Identifier ["hello"]) (fromAny "hello") - , testCase "single split" $ do + , testCase "single split" $ assertEqual "" (Identifier ["hello", "world"]) (fromAny "hello-world") - , testCase "leading split" $ do + , testCase "leading split" $ assertEqual "" (Identifier ["world"]) (fromAny "-world") - , testCase "trailing split" $ do + , testCase "trailing split" $ assertEqual "" (Identifier ["world"]) (fromAny "world-") - , testCase "multiple dashes" $ do + , testCase "multiple dashes" $ assertEqual "" (Identifier ["hello", "world"]) (fromAny "hello---world") - , testCase "no splits" $ do + , testCase "no splits" $ assertEqual "" (Identifier ["hello"]) (fromAny "hello") - , testCase "single split" $ do + , testCase "single split" $ assertEqual "" (Identifier ["hello", "world"]) (fromAny "hello_world") - , testCase "leading split" $ do + , testCase "leading split" $ assertEqual "" (Identifier ["world"]) (fromAny "_world") - , testCase "trailing split" $ do + , testCase "trailing split" $ assertEqual "" (Identifier ["world"]) (fromAny "world_") - , testCase "multiple dashes" $ do + , testCase "multiple dashes" $ assertEqual "" (Identifier ["hello", "world"]) (fromAny "hello___world") - , testCase "no splits" $ do + , testCase "no splits" $ assertEqual "" (Identifier ["hello"]) (fromAny "hello") - , testCase "single split" $ do + , testCase "single split" $ assertEqual "" (Identifier ["hello", "world"]) (fromAny "hello world") - , testCase "leading split" $ do + , testCase "leading split" $ assertEqual "" (Identifier ["world"]) (fromAny " world") - , testCase "trailing split" $ do + , testCase "trailing split" $ assertEqual "" (Identifier ["world"]) (fromAny "world ") - , testCase "multiple dashes" $ do + , testCase "multiple dashes" $ assertEqual "" (Identifier ["hello", "world"]) (fromAny "hello world") @@ -219,37 +254,37 @@ tests = testGroup "tests" ] , testGroup "writing" [ testGroup "toPascal" - [ testCase "toPascal simple" $ do + [ testCase "toPascal simple" $ assertEqual "" "HelloWorld" (toPascal $ Identifier ["hello", "world"]) ] , testGroup "toCamel" - [ testCase "toCamel simple" $ do + [ testCase "toCamel simple" $ assertEqual "" "helloWorld" (toCamel $ Identifier ["hello", "world"]) - , testCase "toCamel empty" $ do + , testCase "toCamel empty" $ assertEqual "" "" (toCamel $ Identifier []) ] , testGroup "toKebab" - [ testCase "toKebab simple" $ do + [ testCase "toKebab simple" $ assertEqual "" "hello-world" (toKebab $ Identifier ["hello", "world"]) ] , testGroup "toSnake" - [ testCase "toSnake simple" $ do + [ testCase "toSnake simple" $ assertEqual "" "hello_world" (toSnake $ Identifier ["hello", "world"]) - , testCase "toScreamingSnake simple" $ do + , testCase "toScreamingSnake simple" $ assertEqual "" "HELLO_WORLD" (toScreamingSnake $ Identifier ["hello", "world"]) - , testCase "toQuietSnake simple" $ do + , testCase "toQuietSnake simple" $ assertEqual "" "hello_world" (toQuietSnake $ Identifier ["Hello", "World"])