diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright factis research GmbH (c) 2017 + +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 Kierán Meinhardt 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# text-plus 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/src/Data/Text/Plus.hs b/src/Data/Text/Plus.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Plus.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} +module Data.Text.Plus + ( module Data.Text + , module Data.Text.Encoding + , decodeUtf8M + , showText + , readText + , groupOn + , withoutTags + , showTable + , showTableRaw + , filename + , splitOnNoEmpty + , nothingIfEmpty + , noneIfEmpty + , emptyIfNone + , limitTo + , sep, unsep, unsep' + , shorten + , shortenL + , firstToUpper + , shortenLinesL + , lenientDecodeUtf8, lenientDecodeUtf8L + , toLazy + , fromLazy + , indicesOfOccurences + , tokenize + , commonPrefixTotal + , firstLine + , firstParagraph + , escapeXml + , fixed + , fixed' + ) +where + +import Data.Fail +import Data.Option +import Safe.Plus + +import Data.Char (isSpace) +import Data.Function +import Data.Maybe +import Data.Monoid +import Data.Text +import Data.Text.Encoding hiding (Decoding(Some)) +import Test.QuickCheck +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Char as C +import qualified Data.Foldable as F +import qualified Data.Text as T +import qualified Data.Text.Encoding.Error as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE + +fixed :: Int -> T.Text -> T.Text +fixed = fixed' '0' + +fixed' :: Char -> Int -> T.Text -> T.Text +fixed' ch i s = + let n = i - T.length s + in T.replicate n (T.singleton ch) `T.append` s + +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary + shrink t = T.pack <$> shrink (T.unpack t) + +fromLazy :: TL.Text -> T.Text +fromLazy = TL.toStrict + +toLazy :: T.Text -> TL.Text +toLazy = TL.fromStrict + +showText :: Show a => a -> T.Text +showText = T.pack . show + +showTextL :: Show a => a -> TL.Text +showTextL = TL.pack . show + +readText :: Read a => T.Text -> a +readText = read . T.unpack + +limitTo :: Int -> T.Text -> T.Text +limitTo lim t + | lim <= 5 = t + | T.length t <= lim = t + | otherwise = + T.take (lim - 4) t + <> "..." + <> T.drop (T.length t - 1) t + +groupOn :: Eq a => (Char -> a) -> Text -> [(a, T.Text)] +groupOn _ "" = [] +groupOn proj t = (x', x `T.cons` ys) : groupOn proj zs + where + x = T.head t + xs = T.tail t + x' = proj x + (ys,zs) = T.span ((==x') . proj) xs + +firstToUpper :: T.Text -> T.Text +firstToUpper t = + case T.uncons t of + Nothing -> "" + Just (fstChr, rstText) -> + C.toUpper fstChr `cons` rstText + +-- |Removes HTML Tags +withoutTags :: T.Text -> T.Text +withoutTags = + let betweenTags ('<':xs) = inTag xs + betweenTags (x:xs) = x:betweenTags xs + betweenTags [] = [] + inTag ('>':xs) = betweenTags xs + inTag ('\'':xs) = inSingQuot xs + inTag ('"':xs) = inDoubleQuot xs + inTag (_:xs) = inTag xs + inTag [] = [] -- incorrect HTML + inSingQuot ('\'':xs) = inTag xs + inSingQuot (_:xs) = inSingQuot xs + inSingQuot [] = [] -- incorrect HTML + inDoubleQuot ('\"':xs) = inTag xs + inDoubleQuot (_:xs) = inDoubleQuot xs + inDoubleQuot [] = [] -- incorrect HTML + in T.pack . betweenTags . T.unpack + +-- indicesOfOccurences needle haystack returns all indices i s.t. +-- +-- prop> needle `T.isPrefixOf` (T.drop i haystack) +-- +-- Note that: T.breakOnAll - does not return overlapping matches, e.g. +-- +-- prop> indicesOfOccurences "edited" "editedited" == [0,4] +-- +-- but +-- +-- prop> map (T.length . fst) (T.breakOnAll "edited" "editedited") == [0] +-- +indicesOfOccurences :: T.Text -> T.Text -> [Int] +indicesOfOccurences needle = go 0 + where + go off haystack + | Just (_, matchTail) <- T.uncons match = newOff:go (newOff+1) matchTail + | otherwise = [] + where + newOff = off + T.length prefix + (prefix, match) = T.breakOn needle haystack + +-- | Simple tokenizer - that doesn't destroy delimiters, e.g. +-- +-- >>> tokenize (T.pack "This is blind-text, with punctuation.") +-- ["This"," ","is"," ","blind","-","text",", ","with"," ","punctuation","."] +-- +-- prop> T.concat (tokenize x) == x +-- +-- Note: URLs, numbers won't be handled very well. +tokenize :: T.Text -> [T.Text] +tokenize = T.groupBy ((==) `on` C.isAlphaNum) + +-- | @commonPrefixTotal s t@ returns a trippel @(r,st,tt)@ s.t. +-- @ +-- s = r `T.append` st, t = r `T.append` tt +-- @ +-- such that @r@ is longest possible. +-- +-- Note: Contrary to Data.commonPrefix there is no special case when @T.null r@. +commonPrefixTotal :: T.Text -> T.Text -> (T.Text, T.Text, T.Text) +commonPrefixTotal s t = fromMaybe ("", s, t) $ T.commonPrefixes s t + +showTable :: (Traversable t) => [(T.Text, a -> T.Text)] -> t a -> T.Text +showTable headersAccessors rows = + showTableRaw (fmap fst headersAccessors) (fmap (\x -> fmap (($ x) . snd) headersAccessors) rows) + +showTableRaw :: (Traversable t1, Traversable t2) => [T.Text] -> t1 (t2 T.Text) -> T.Text +showTableRaw headers rows = table + where + rows' = fmap (fmap (wrap ' ')) rows + columnHeaders = + fmap (wrap ' ') headers + header = renderRow columnHeaders + headerBodySeperator = + wrap '|' (T.intercalate "+" (fmap (`T.replicate` "-") fieldWidths)) + renderRow rowElems = + wrap '|' (T.intercalate "|" (adjust (F.toList rowElems))) + wrap char = T.cons char . (`T.snoc` char) + table = + flip T.snoc '\n' . T.intercalate "\n" $ + header : headerBodySeperator : F.toList (fmap renderRow rows') + adjust = Prelude.zipWith (`T.justifyLeft` ' ') fieldWidths + fieldWidths = + Prelude.foldr (Prelude.zipWith (\a b -> max (T.length a) b)) + (F.toList (fmap T.length columnHeaders)) (fmap F.toList rows') + +nothingIfEmpty :: T.Text -> Maybe T.Text +nothingIfEmpty t = + if T.null $ T.strip t then Nothing else Just t + +noneIfEmpty :: T.Text -> Option T.Text +noneIfEmpty = maybeToOption . nothingIfEmpty + +emptyIfNone :: Option T.Text -> T.Text +emptyIfNone None = T.empty +emptyIfNone (Some t) = t + +sep :: T.Text -> Char -> T.Text -> T.Text +sep prefix ch suffix + | T.any (==ch) prefix = + safeError ("Oh dear! Won't separate `" ++ T.unpack prefix ++ "' with `" ++ show ch + ++ "' because it contains that character!") + | otherwise = T.concat [prefix, T.singleton ch, suffix] + +unsep' :: Monad m => Char -> T.Text -> m (T.Text, T.Text) +unsep' ch full = + case T.span (/=ch) full of + (prefix, T.uncons -> Just (ch', suffix)) | ch == ch' -> return (prefix, suffix) + _ -> safeFail ("Can't unsep `" ++ T.unpack full ++ "' using `" ++ show ch ++ "'.") + +unsep :: Char -> T.Text -> (T.Text, T.Text) +unsep ch x = safeFromOk (unsep' ch x) + +shorten :: Int -> T.Text -> T.Text +shorten len = TL.toStrict . shortenL len . TL.fromStrict + +shortenL :: Int -> TL.Text -> TL.Text +shortenL (fromIntegral -> maxLen) s = + let actualLen = TL.length s + skipMsg = TL.concat ["... (", showTextL (actualLen - maxLen), " more chars)"] + skipMsgLen = TL.length skipMsg + in if actualLen <= maxLen + skipMsgLen + then s + else TL.concat [TL.take maxLen s, skipMsg] + +shortenLinesL :: Int -> Int -> TL.Text -> TL.Text +shortenLinesL maxLines maxLineLength (Prelude.map (shortenL maxLineLength) . TL.lines -> xs) = + let actualLines = Prelude.length xs + skipMsg = TL.concat ["(", showTextL (actualLines - maxLines), " more lines)"] + lines + | actualLines <= maxLines + 1 = xs + | otherwise = Prelude.take maxLines xs ++ [skipMsg] + in TL.unlines lines + +filename :: T.Text -> T.Text +filename = T.replace "?" "_" . T.replace "/" "_" . T.replace "." "_" . T.replace " " "_" + +splitOnNoEmpty :: T.Text -> T.Text -> [T.Text] +splitOnNoEmpty break t = + Prelude.filter (/= "") $ T.splitOn break t + +lenientDecodeUtf8 :: BS.ByteString -> T.Text +lenientDecodeUtf8 = decodeUtf8With TE.lenientDecode + +lenientDecodeUtf8L :: BSL.ByteString -> TL.Text +lenientDecodeUtf8L = TLE.decodeUtf8With TE.lenientDecode + +decodeUtf8M :: BS.ByteString -> Fail T.Text +decodeUtf8M bs = + case decodeUtf8' bs of + Left (TE.DecodeError err (Just w8)) -> + Fail $ + "Failed decoding " ++ show bs ++ " as UTF-8 on character " ++ show w8 ++ ": " ++ err + Left (TE.DecodeError err Nothing) -> + Fail $ "Failed decoding " ++ show bs ++ " as UTF-8: " ++ err + Left _ -> safeError "Never used according to documentation." + Right txt -> Ok txt + +firstParagraph :: T.Text -> T.Text +firstParagraph = + T.unlines . Prelude.takeWhile (not . endOfParagraph) . T.lines + where + endOfParagraph = T.all isSpace + +firstLine :: T.Text -> T.Text +firstLine = T.takeWhile (/='\n') + +escapeXml :: T.Text -> T.Text +escapeXml = T.concatMap escape + where + escape c = + case c of + '<' -> "<" + '>' -> ">" + '&' -> "&" + '"' -> """ + '\'' -> "'" + c -> T.singleton c diff --git a/test/Data/Text/PlusSpec.hs b/test/Data/Text/PlusSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Text/PlusSpec.hs @@ -0,0 +1,135 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.Text.PlusSpec (htf_thisModulesTests) where + +import Data.Text.Plus + +import Test.Framework +import qualified Data.Char as C +import qualified Data.Text as T + +test_groupOn :: IO () +test_groupOn = + do assertEqual [] $ groupOn id "" + assertEqual [(False, "abc"), (True, "123"), (False, "def")] $ groupOn C.isDigit "abc123def" + +test_firstToUpper :: IO () +test_firstToUpper = + do assertEqual "Hallo" $ firstToUpper "hallo" + assertEqual "HAllo" $ firstToUpper "HAllo" + assertEqual "" $ firstToUpper "" + +test_withoutTags :: IO () +test_withoutTags = + do assertEqual "Hello laboratory report!" + (withoutTags $ "

Hello 

laboratory
report!

") + assertEqual "Hello laboratory report!" + (withoutTags $ "

x<\">Hello 

laboratory
report!

") + assertEqual "Hello report!" + (withoutTags $ "

Hello report!

") + +prop_indicesOverlapping :: Property +prop_indicesOverlapping = once $ prop_indices "aba" "ababa" + +prop_indicesThree :: Property +prop_indicesThree = once $ prop_indices "a" "ababa" + +prop_indicesNone :: Property +prop_indicesNone = once $ prop_indices "foo" "ababa" + +prop_indicesSingle :: Property +prop_indicesSingle = once $ prop_indices "bab" "ababa" + +prop_indices :: T.Text -> T.Text -> Property +prop_indices n h = not (T.null n) ==> + (indicesOfOccurences n h === [ i | i <- [0..(T.length h - 1)], n `T.isPrefixOf` (T.drop i h)]) + +test_tokenize :: IO () +test_tokenize = + assertEqual ["This"," ","is"," ","blind","-","text",", ","with", " ", "punctuation", "."] $ + tokenize "This is blind-text, with punctuation." + +test_tokenizeWithNum :: IO () +test_tokenizeWithNum = + assertEqual ["100"," ","sheep"] $ tokenize "100 sheep" + +test_tokenizeEmpty :: IO () +test_tokenizeEmpty = + assertEqual [] $ tokenize "" + +test_showTableRaw :: IO () +test_showTableRaw = + let header = ["Col1", "Col2", "Col3"] + table = [["longfield", "-", ""], ["short", "longfield", ""]] + in assertEqual (showTableRaw header table) $ + T.concat + [ "| Col1 | Col2 | Col3 |\n" + , "|-----------+-----------+------|\n" + , "| longfield | - | |\n" + , "| short | longfield | |\n" + ] + +test_shortenL :: IO () +test_shortenL = + do assertEqual "123456789012345678901" (shortenL 20 "123456789012345678901") + assertEqual "123456789012345678901" (shortenL 21 "123456789012345678901") + assertEqual "123456789012345678901" (shortenL 22 "123456789012345678901") + assertEqual "123456789012345678901" (shortenL 2 "123456789012345678901") + assertEqual "1... (20 more chars)" (shortenL 1 "123456789012345678901") + assertEqual "... (21 more chars)" (shortenL 0 "123456789012345678901") + +test_shortenLinesL1 :: IO () +test_shortenLinesL1 = + assertEqual outp (shortenLinesL 2 1 inp) + where + outp = + "1... (20 more chars)\n\ + \1... (20 more chars)\n\ + \(4 more lines)\n" + inp = + "123456789012345678901\n123456789012345678901\n123456789012345678901\n\ + \123456789012345678901\n123456789012345678901\n123456789012345678901" + +test_shortenLinesL2 :: IO () +test_shortenLinesL2 = + assertEqual outp (shortenLinesL 0 0 inp) + where + outp = "(6 more lines)\n" + inp = + "123456789012345678901\n123456789012345678901\n123456789012345678901\n\ + \123456789012345678901\n123456789012345678901\n123456789012345678901" + +test_filename :: IO () +test_filename = + do assertEqual "Foo" (filename "Foo") + assertEqual "Foo_Bar" (filename "Foo Bar") + assertEqual "Foo_Bar" (filename "Foo/Bar") + assertEqual "Foo_Bar" (filename "Foo.Bar") + assertEqual "Foo_Bar" (filename "Foo?Bar") + +test_sepUnsep :: IO () +test_sepUnsep = + do assertEqual ("foo|bar") (sep "foo" '|' "bar") + assertEqual ("foo", "bar") (unsep '|' "foo|bar") + assertEqual ("foo", "bar|baz") (unsep '|' "foo|bar|baz") + +test_firstLine :: IO () +test_firstLine = + do assertEqual "Hello World" (firstLine "Hello World") + assertEqual "Hello World" (firstLine "Hello World\nsecond line") + assertEqual "Hello World " (firstLine "Hello World \nsecond line") + +test_firstParagraph :: IO () +test_firstParagraph = + do assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld" + assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld\n" + assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld\n\nSecond paragraph.\n" + assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld\n\nSecond paragraph." + assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld\n\nSecond paragraph.\n\nThird." + assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld\n \nSecond paragraph." + +test_escapeXml :: IO () +test_escapeXml = + do assertEqual "foobar" (escapeXml "foobar") + assertEqual "Hallo <Welt>" (escapeXml "Hallo ") + assertEqual "Hallo 'Welt>" (escapeXml "Hallo 'Welt>") diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Main where + +import {-@ HTF_TESTS @-} Data.Text.PlusSpec + +import Test.DocTest +import Test.Framework + +main :: IO () +main = + do doctest ["src"] + htfMain htf_importedTests diff --git a/text-plus.cabal b/text-plus.cabal new file mode 100644 --- /dev/null +++ b/text-plus.cabal @@ -0,0 +1,43 @@ +name: text-plus +version: 0.1.0.1 +synopsis: Utils for text +description: Utils for text +homepage: https://github.com/factisresearch/opensource-mono#readme +license: BSD3 +license-file: LICENSE +author: factis research GmbH +maintainer: kieran.meinhardt@gmail.com +copyright: 2017 factis research GmbH +category: Data +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.Text.Plus + build-depends: base >= 4.7 && < 5 + , QuickCheck + , bytestring + , pretty + , strict-data + , text + , util-plus + default-language: Haskell2010 + +test-suite text-plus-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Data.Text.PlusSpec + build-depends: base + , HTF + , doctest + , text + , text-plus + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/kmein/text-plus