diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Marcel Ruegenberg + +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 Marcel Ruegenberg 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/Text/Blaze/Truncate.hs b/Text/Blaze/Truncate.hs new file mode 100644 --- /dev/null +++ b/Text/Blaze/Truncate.hs @@ -0,0 +1,98 @@ +module Text.Blaze.Truncate(truncateHtml) where + +-- from Blaze 0.4 to 0.5: Html -> Markup; HtmlM -> MarkupM; AddCustomAttribute has an additional first argument +import Text.Blaze(Html) +import Text.Blaze.Internal(HtmlM(..),ChoiceString(..),StaticString(..)) +import Data.Char +import qualified Data.Text as T +import qualified Data.ByteString as B +import GHC.Exts (IsString (..)) +import Data.List(dropWhileEnd) + +data Tagged a = Tagged Int a +instance Functor Tagged where + fmap f (Tagged n a) = Tagged n (f a) + +-- type Html = Markup +-- type HtmlM a = MarkupM a + +-- | Truncate the given HTML to a certain length, preserving tags. Returns the truncated Html or `Nothing` if no truncation occured. +-- Words are preserved, so if the truncated text ends within some word, that whole word is cut. +truncateHtml :: Int -- ^ The amount of characters (not counting tags) which the truncated text should have at most + -> Html -- ^ The HTML to truncate + -> Maybe Html -- ^ `Just` the truncated HTML or `Nothing` if no truncation occured +truncateHtml n html = case go n html of Tagged n' html' -> if n' /= n then Just html' else Nothing + where + go :: Int -> HtmlM b -> Tagged (HtmlM b) + go i (Parent t open close content) = fmap (Parent t open close) (go i content) + go i (Leaf t begin end) = Tagged i (Leaf t begin end) + go i (AddAttribute t key value h) = fmap (AddAttribute t key value) (go i h) + go i (AddCustomAttribute t key value h) = fmap (AddCustomAttribute t key value) (go i h) + go i (Append h1 h2) = case go i h1 of + Tagged j h1' -> fmap (Append h1') (go j h2) + go i Empty = Tagged i Empty + go i (Content content) = fmap Content (truncateChoiceString i content) + +splitAt' :: Int -> ChoiceString -> (ChoiceString, ChoiceString) +splitAt' i (Static str) = case splitAt i ((getString str) "") of (str',str'') -> (Static (fromString str'),Static (fromString str'')) +splitAt' i (String str) = case splitAt i str of (str',str'') -> (String str',String str'') +splitAt' i (Text str) = case T.splitAt i str of (str',str'') -> (Text str',Text str'') +splitAt' i (ByteString str) = case B.splitAt i str of (str',str'') -> (ByteString str',ByteString str'') +splitAt' i (PreEscaped str) = case splitAt' i str of (str',str'') -> (PreEscaped str',PreEscaped str'') +splitAt' _ (External str) = (External str,External EmptyChoiceString) -- note: these should not be truncated, so the behavior is a bit special here +splitAt' i (AppendChoiceString str1 str2) = case splitAt' i str1 of + (str1',str1'') -> + if empty' str1'' then case splitAt' (i - (length' str1')) str2 of + (str2',str2'') -> (AppendChoiceString str1' str2',str2'') + else (str1',AppendChoiceString str1'' str2) +splitAt' _ EmptyChoiceString = (EmptyChoiceString,EmptyChoiceString) + +length' :: ChoiceString -> Int +length' (Static str) = length ((getString str) "") +length' (String str) = length str +length' (Text str) = T.length str +length' (ByteString str) = B.length str +length' (PreEscaped str) = length' str +length' (External str) = 0 -- note: these should not be truncated, so the behavior is a bit special here +length' (AppendChoiceString str1 str2) = length' str1 + length' str2 +length' EmptyChoiceString = 0 + +empty' :: ChoiceString -> Bool +empty' (Static str) = null ((getString str) "") +empty' (String str) = null str +empty' (Text str) = T.null str +empty' (ByteString str) = B.null str +empty' (PreEscaped str) = empty' str +empty' (External str) = True -- note: these should not be truncated, so the behavior is a bit special here +empty' (AppendChoiceString str1 str2) = empty' str1 && empty' str2 +empty' EmptyChoiceString = True + +head' :: ChoiceString -> Char +head' (Static str) = head ((getString str) "") +head' (String str) = head str +head' (Text str) = T.head str +head' (ByteString str) = (head . show . B.head) str +head' (PreEscaped str) = head' str +head' (External str) = undefined -- note: these should not be truncated, so the behavior is a bit special here +head' (AppendChoiceString str1 str2) = if empty' str1 then head' str2 else head' str1 +head' EmptyChoiceString = undefined + +dropWhileEnd' :: (Char -> Bool) -> ChoiceString -> ChoiceString +dropWhileEnd' f (Static str) = Static (fromString (dropWhileEnd f ((getString str) ""))) +dropWhileEnd' f (String str) = String (dropWhileEnd f str) +dropWhileEnd' f (Text str) = Text (T.dropWhileEnd f str) +dropWhileEnd' f (ByteString str) = ByteString (fst $ B.spanEnd (f . head . show) str) -- FIXME: inefficient +dropWhileEnd' f (PreEscaped str) = dropWhileEnd' f str +dropWhileEnd' f (External str) = External str -- note: these should not be truncated, so the behavior is a bit special here +dropWhileEnd' f (AppendChoiceString str1 str2) = case dropWhileEnd' f str2 of + str2' -> if empty' str2' then dropWhileEnd' f str1 + else (AppendChoiceString str1 str2') +dropWhileEnd' f EmptyChoiceString = EmptyChoiceString + +truncateChoiceString :: Int -> ChoiceString -> Tagged ChoiceString +truncateChoiceString i str = case splitAt' i str of + (str',rst) -> if (empty' rst) || (isSpace $ head' rst) + then Tagged (i - (length' str')) str' + else case dropWhileEnd' (not. isSpace) (dropWhileEnd' isSpace str') of + str'' -> Tagged (i - length' str'') str'' + diff --git a/blaze-html-truncate.cabal b/blaze-html-truncate.cabal new file mode 100644 --- /dev/null +++ b/blaze-html-truncate.cabal @@ -0,0 +1,28 @@ +-- Initial blaze-html-truncate.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: blaze-html-truncate +version: 0.1.0.0 +synopsis: A truncator for blaze-html +description: This package provides a simple function to truncate HTML, preserving tags and preventing cut-off words. +homepage: http://github.com/mruegenberg/blaze-html-truncate +license: BSD3 +license-file: LICENSE +author: Marcel Ruegenberg +maintainer: m.ruegenberg@picodesign.de +-- copyright: +category: Text +build-type: Simple +cabal-version: >=1.8 + +source-repository head + type: git + location: git://github.com/mruegenberg/blaze-html-truncate.git + +library + exposed-modules: Text.Blaze.Truncate + -- other-modules: + build-depends: base ==4.5.* + , blaze-html >= 0.4.0.0 && < 0.5.0.0 + , bytestring >= 0.9 + , text >= 0.10