diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,85 @@ +# Changelog + +- 0.8.3.0 (2023-09-25) + * Add `ToMarkup` and `ToValue` instances for `NonEmpty Char` + * Bump `bytestring` upper bound to 0.13 + * Bump `text` upper bound to 2.1 + +- 0.8.2.8 (2021-03-04) + * Bump `base` upper bound to 4.16 + * Bump `tasty` upper bound to 1.5 + * Bump `bytestring` upper bound to 0.12 + +- 0.8.2.7 (2020-06-30) + * Bump Cabal version lower bound to 1.10 + +- 0.8.2.6 (2020-06-30) + * Bump `tasty` upper bound to 1.4 + +- 0.8.2.5 (2020-04-20) + * Bump `base` upper bound to 4.15 + +- 0.8.2.4 (2020-03-29) + * Bump `QuickCheck` upper bound to 2.15 + +- 0.8.2.3 (2019-10-02) + * Bump `base` to 4.13 + * Bump `tasty` to 1.2 + * Bump `QuickCheck` to 2.13 + +- 0.8.2.2 (2018-09-25) + * Bump `base` to 4.12 + * Bump `containers` to 0.6 + * Bump `tasty` to 1.1 + +- 0.8.2.1 (2018-04-09) + * Bump `QuickCheck` dependency to allow 2.11 + * Bump `tasty` dependency to allow 1.0 + * Bump `tasty-hunit` dependency to allow 0.10 + * Bump `tasty-quickcheck` dependency to allow 0.10 + +- 0.8.2.0 (2018-01-09) + * Define `ToMarkup` instance for `Natural`. + +- 0.8.1.0 (2017-09-16) + * Compatibility with Semigroup/Monoid proposal + * Switch to `tasty` for running tests + +- 0.8.0.0 (2017-01-30) + * Make `MarkupM` finally adhere to the Monad laws + * Stricten the `IsString` instance to only work with `MarkupM ()` and not + `MarkupM a` + * Change the type of `contents` to `MarkupM a -> MarkupM a` + * Add a `Semigroup` instance for `MarkupM` + +- 0.7.1.1 + * Bump `HUnit` dependency to allow 1.5 + +- 0.7.1.0 + * Relax `QuickCheck` dependency to allow 2.9 + * Add text builder instances + +- 0.7.0.3 + * Relax `HUnit` dependency to allow 1.3 + +- 0.7.0.2 + * Relax `blaze-builder` dependency to allow 0.3 + +- 0.7.0.1 + * Bump `QuickCheck` dependency to allow 2.8 + +- 0.7.0.0 + * Depend on blaze-builder 0.4 + +- 0.6.3.0 + * Add combinators to insert HTML comments + +- 0.6.2.0 + * Add `Applicative` instance for `MarkupM` + +- 0.6.1.1 + * Bump `text` dependency to allow 1.2 + - 0.6.1.0 * Add the `null` query to Text.Blaze.Internal. diff --git a/blaze-markup.cabal b/blaze-markup.cabal --- a/blaze-markup.cabal +++ b/blaze-markup.cabal @@ -1,5 +1,5 @@ Name: blaze-markup -Version: 0.6.1.0 +Version: 0.8.3.0 Homepage: http://jaspervdj.be/blaze Bug-Reports: http://github.com/jaspervdj/blaze-markup/issues License: BSD3 @@ -16,14 +16,29 @@ . Build-type: Simple -Cabal-version: >= 1.8 +Cabal-version: >= 1.10 +Tested-with: + GHC == 9.6.2 + GHC == 9.4.5 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 + GHC == 7.10.3 + GHC == 7.8.4 + Extra-source-files: CHANGELOG Library - Hs-source-dirs: src - Ghc-Options: -Wall + Hs-source-dirs: src + Ghc-Options: -Wall + Default-language: Haskell2010 Exposed-modules: Text.Blaze @@ -35,32 +50,40 @@ Build-depends: base >= 4 && < 5, - blaze-builder >= 0.2 && < 0.4, - text >= 0.10 && < 1.2, - bytestring >= 0.9 && < 0.11 + blaze-builder >= 0.3 && < 0.5, + text >= 0.10 && < 2.1, + bytestring >= 0.9 && < 0.13 Test-suite blaze-markup-tests - Type: exitcode-stdio-1.0 - Hs-source-dirs: src tests - Main-is: TestSuite.hs - Ghc-options: -Wall + Type: exitcode-stdio-1.0 + Hs-source-dirs: src tests + Main-is: TestSuite.hs + Ghc-options: -Wall + Default-language: Haskell2010 Other-modules: + Text.Blaze + Text.Blaze.Internal + Text.Blaze.Renderer.Pretty + Text.Blaze.Renderer.String + Text.Blaze.Renderer.Text + Text.Blaze.Renderer.Utf8 Text.Blaze.Tests Text.Blaze.Tests.Util Build-depends: - HUnit >= 1.2 && < 1.3, - QuickCheck >= 2.4 && < 2.8, - containers >= 0.3 && < 0.6, - test-framework >= 0.4 && < 0.9, - test-framework-hunit >= 0.3 && < 0.4, - test-framework-quickcheck2 >= 0.3 && < 0.4, -- Copied from regular dependencies... - base >= 4 && < 5, - blaze-builder >= 0.2 && < 0.4, - text >= 0.10 && < 1.2, - bytestring >= 0.9 && < 0.11 + base + , blaze-builder + , text + , bytestring + -- Extra dependencies + , HUnit >= 1.2 && < 1.7 + , QuickCheck >= 2.7 && < 2.15 + , containers >= 0.3 && < 0.7 + , tasty >= 1.0 && < 1.5 + , tasty-hunit >= 0.10 && < 0.11 + , tasty-quickcheck >= 0.10 && < 0.11 Source-repository head Type: git diff --git a/src/Text/Blaze.hs b/src/Text/Blaze.hs --- a/src/Text/Blaze.hs +++ b/src/Text/Blaze.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} -- | BlazeMarkup is a markup combinator library. It provides a way to embed -- markup languages like HTML and SVG in Haskell in an efficient and convenient -- way, with a light-weight syntax. @@ -46,15 +49,34 @@ -- * Converting values to Markup. , ToMarkup (..) + , text + , preEscapedText + , lazyText + , preEscapedLazyText + , string + , preEscapedString , unsafeByteString , unsafeLazyByteString + -- * Comments + , textComment + , lazyTextComment + , stringComment + , unsafeByteStringComment + , unsafeLazyByteStringComment + -- * Creating tags. , textTag , stringTag -- * Converting values to attribute values. , ToValue (..) + , textValue + , preEscapedTextValue + , lazyTextValue + , preEscapedLazyTextValue + , stringValue + , preEscapedStringValue , unsafeByteStringValue , unsafeLazyByteStringValue @@ -62,18 +84,25 @@ , (!) , (!?) - -- * Modifiying Markup trees + -- * Modifying Markup trees , contents ) where -import Data.Monoid (mconcat) -import Data.Int (Int32, Int64) -import Data.Word (Word, Word32, Word64) +import Data.Int (Int32, Int64) +import Data.Monoid (mconcat) +import Data.Word (Word, Word32, Word64) +#if MIN_VERSION_base(4,8,0) +import Numeric.Natural (Natural) +#endif +#if MIN_VERSION_base(4,9,0) +import Data.List.NonEmpty (NonEmpty (..)) +#endif -import Data.Text (Text) -import qualified Data.Text.Lazy as LT +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as LTB -import Text.Blaze.Internal +import Text.Blaze.Internal -- | Class allowing us to use a single function for Markup values -- @@ -108,6 +137,12 @@ preEscapedToMarkup = preEscapedLazyText {-# INLINE preEscapedToMarkup #-} +instance ToMarkup LTB.Builder where + toMarkup = textBuilder + {-# INLINE toMarkup #-} + preEscapedToMarkup = preEscapedTextBuilder + {-# INLINE preEscapedToMarkup #-} + instance ToMarkup String where toMarkup = string {-# INLINE toMarkup #-} @@ -126,6 +161,12 @@ toMarkup = string . show {-# INLINE toMarkup #-} +#if MIN_VERSION_base(4,8,0) +instance ToMarkup Natural where + toMarkup = string . show + {-# INLINE toMarkup #-} +#endif + instance ToMarkup Char where toMarkup = string . return {-# INLINE toMarkup #-} @@ -187,6 +228,12 @@ preEscapedToValue = preEscapedLazyTextValue {-# INLINE preEscapedToValue #-} +instance ToValue LTB.Builder where + toValue = textBuilderValue + {-# INLINE toValue #-} + preEscapedToValue = preEscapedTextBuilderValue + {-# INLINE preEscapedToValue #-} + instance ToValue String where toValue = stringValue {-# INLINE toValue #-} @@ -236,3 +283,13 @@ instance ToValue Word64 where toValue = stringValue . show {-# INLINE toValue #-} + +-- Non-empty strings +#if MIN_VERSION_base(4,9,0) +instance ToMarkup (NonEmpty Char) where + toMarkup (x :| xs) = string (x : xs) + preEscapedToMarkup (x :| xs) = preEscapedString (x : xs) + +instance ToValue (NonEmpty Char) where + toValue (x :| xs) = stringValue (x : xs) +#endif diff --git a/src/Text/Blaze/Internal.hs b/src/Text/Blaze/Internal.hs --- a/src/Text/Blaze/Internal.hs +++ b/src/Text/Blaze/Internal.hs @@ -1,9 +1,14 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, Rank2Types, - FlexibleInstances, ExistentialQuantification, - DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} -- | The BlazeMarkup core, consisting of functions that offer the power to -- generate custom markup elements. It also offers user-centric functions, --- which are exposed through 'Text.Blaze'. +-- which are exposed through "Text.Blaze". -- -- While this module is exported, usage of it is not recommended, unless you -- know what you are doing. This module might undergo changes at any time. @@ -31,11 +36,20 @@ , preEscapedText , lazyText , preEscapedLazyText + , textBuilder + , preEscapedTextBuilder , string , preEscapedString , unsafeByteString , unsafeLazyByteString + -- * Comments + , textComment + , lazyTextComment + , stringComment + , unsafeByteStringComment + , unsafeLazyByteStringComment + -- * Converting values to tags. , textTag , stringTag @@ -45,6 +59,8 @@ , preEscapedTextValue , lazyTextValue , preEscapedLazyTextValue + , textBuilderValue + , preEscapedTextBuilderValue , stringValue , preEscapedStringValue , unsafeByteStringValue @@ -63,21 +79,26 @@ , null ) where -import Prelude hiding (null) -import Data.Monoid (Monoid, mappend, mempty, mconcat) -import Unsafe.Coerce (unsafeCoerce) -import qualified Data.List as List +import Control.Applicative (Applicative (..)) +import qualified Data.List as List +import Data.Monoid (Monoid, mappend, mconcat, mempty) +import Prelude hiding (null) -import Data.ByteString.Char8 (ByteString) -import Data.Text (Text) -import Data.Typeable (Typeable) -import GHC.Exts (IsString (..)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as LT +import qualified Data.ByteString as B +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as LTB +import Data.Typeable (Typeable) +import GHC.Exts (IsString (..)) +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup(..)) +#endif + -- | A static string that supports efficient output to all possible backends. -- data StaticString = StaticString @@ -113,11 +134,19 @@ -- | Empty string | EmptyChoiceString +#if MIN_VERSION_base(4,9,0) +instance Semigroup ChoiceString where + (<>) = AppendChoiceString + {-# INLINE (<>) #-} +#endif + instance Monoid ChoiceString where mempty = EmptyChoiceString {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) mappend = AppendChoiceString {-# INLINE mappend #-} +#endif instance IsString ChoiceString where fromString = String @@ -127,24 +156,27 @@ -- data MarkupM a -- | Tag, open tag, end tag, content - = forall b. Parent StaticString StaticString StaticString (MarkupM b) + = Parent StaticString StaticString StaticString (MarkupM a) -- | Custom parent - | forall b. CustomParent ChoiceString (MarkupM b) + | CustomParent ChoiceString (MarkupM a) -- | Tag, open tag, end tag - | Leaf StaticString StaticString StaticString + | Leaf StaticString StaticString StaticString a -- | Custom leaf - | CustomLeaf ChoiceString Bool + | CustomLeaf ChoiceString Bool a -- | HTML content - | Content ChoiceString + | Content ChoiceString a + -- | HTML comment. Note: you should wrap the 'ChoiceString' in a + -- 'PreEscaped'. + | Comment ChoiceString a -- | Concatenation of two HTML pieces - | forall b c. Append (MarkupM b) (MarkupM c) + | forall b. Append (MarkupM b) (MarkupM a) -- | Add an attribute to the inner HTML. Raw key, key, value, HTML to -- receive the attribute. | AddAttribute StaticString StaticString ChoiceString (MarkupM a) -- | Add a custom attribute to the inner HTML. | AddCustomAttribute ChoiceString ChoiceString (MarkupM a) -- | Empty HTML. - | Empty + | Empty a deriving (Typeable) -- | Simplification of the 'MarkupM' datatype. @@ -152,30 +184,68 @@ type Markup = MarkupM () instance Monoid a => Monoid (MarkupM a) where - mempty = Empty + mempty = Empty mempty {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) mappend x y = Append x y {-# INLINE mappend #-} - mconcat = foldr Append Empty + mconcat = foldr Append (Empty mempty) {-# INLINE mconcat #-} +#endif +#if MIN_VERSION_base(4,9,0) +instance Monoid a => Semigroup (MarkupM a) where + x <> y = Append x y + {-# INLINE (<>) #-} + sconcat = foldr Append (Empty mempty) + {-# INLINE sconcat #-} +#endif + instance Functor MarkupM where - -- Safe because it does not contain a value anyway - fmap _ = unsafeCoerce + fmap f x = + -- Instead of traversing through all the nodes, we just store an extra + -- 'Empty' node with the new result. + Append x (Empty (f (markupValue x))) +instance Applicative MarkupM where + pure x = Empty x + {-# INLINE pure #-} + (<*>) x y = + -- We need to add an extra 'Empty' node to store the result. + Append (Append x y) (Empty (markupValue x (markupValue y))) + {-# INLINE (<*>) #-} + (*>) = Append + {-# INLINE (*>) #-} + -- (<*) = Append + -- {-# INLINE (<*) #-} + instance Monad MarkupM where - return _ = Empty + return x = Empty x {-# INLINE return #-} (>>) = Append {-# INLINE (>>) #-} - h1 >>= f = h1 >> f - (error "Text.Blaze.Internal.MarkupM: invalid use of monadic bind") + h1 >>= f = Append h1 (f (markupValue h1)) {-# INLINE (>>=) #-} -instance IsString (MarkupM a) where - fromString = Content . fromString +instance (a ~ ()) => IsString (MarkupM a) where + fromString x = Content (fromString x) mempty {-# INLINE fromString #-} +-- | Get the value from a 'MarkupM'. +-- +markupValue :: MarkupM a -> a +markupValue m0 = case m0 of + Parent _ _ _ m1 -> markupValue m1 + CustomParent _ m1 -> markupValue m1 + Leaf _ _ _ x -> x + CustomLeaf _ _ x -> x + Content _ x -> x + Comment _ x -> x + Append _ m1 -> markupValue m1 + AddAttribute _ _ _ m1 -> markupValue m1 + AddCustomAttribute _ _ m1 -> markupValue m1 + Empty x -> x + -- | Type for an HTML tag. This can be seen as an internal string type used by -- BlazeMarkup. -- @@ -186,26 +256,37 @@ -- newtype Attribute = Attribute (forall a. MarkupM a -> MarkupM a) +#if MIN_VERSION_base(4,9,0) +instance Semigroup Attribute where + Attribute f <> Attribute g = Attribute (g . f) +#endif + instance Monoid Attribute where mempty = Attribute id +#if !(MIN_VERSION_base(4,11,0)) Attribute f `mappend` Attribute g = Attribute (g . f) +#endif -- | The type for the value part of an attribute. -- newtype AttributeValue = AttributeValue { unAttributeValue :: ChoiceString } - deriving (IsString, Monoid) + deriving (IsString, Monoid +#if MIN_VERSION_base(4,9,0) + ,Semigroup +#endif + ) -- | Create a custom parent element customParent :: Tag -- ^ Element tag -> Markup -- ^ Content -> Markup -- ^ Resulting markup -customParent tag = CustomParent (Static $ unTag tag) +customParent tag cont = CustomParent (Static $ unTag tag) cont -- | Create a custom leaf element customLeaf :: Tag -- ^ Element tag -> Bool -- ^ Close the leaf? -> Markup -- ^ Resulting markup -customLeaf tag = CustomLeaf (Static $ unTag tag) +customLeaf tag close = CustomLeaf (Static $ unTag tag) close () -- | Create an HTML attribute that can be applied to an HTML element later using -- the '!' operator. @@ -224,7 +305,7 @@ -- -- >

Hello.

-- --- We support this in BlazeMarkup using this funcion. The above fragment could +-- We support this in BlazeMarkup using this function. The above fragment could -- be described using BlazeMarkup with: -- -- > p ! dataAttribute "foo" "bar" $ "Hello." @@ -260,14 +341,14 @@ -- text :: Text -- ^ Text to render. -> Markup -- ^ Resulting HTML fragment. -text = Content . Text +text = content . Text {-# INLINE text #-} -- | Render text without escaping. -- preEscapedText :: Text -- ^ Text to insert -> Markup -- ^ Resulting HTML fragment -preEscapedText = Content . PreEscaped . Text +preEscapedText = content . PreEscaped . Text {-# INLINE preEscapedText #-} -- | A variant of 'text' for lazy 'LT.Text'. @@ -282,19 +363,38 @@ preEscapedLazyText :: LT.Text -- ^ Text to insert -> Markup -- ^ Resulting HTML fragment preEscapedLazyText = mconcat . map preEscapedText . LT.toChunks +{-# INLINE preEscapedLazyText #-} +-- | A variant of 'text' for text 'LTB.Builder'. +-- +textBuilder :: LTB.Builder -- ^ Text to insert + -> Markup -- ^ Resulting HTML fragment +textBuilder = lazyText . LTB.toLazyText +{-# INLINE textBuilder #-} + +-- | A variant of 'preEscapedText' for lazy 'LT.Text' +-- +preEscapedTextBuilder :: LTB.Builder -- ^ Text to insert + -> Markup -- ^ Resulting HTML fragment +preEscapedTextBuilder = preEscapedLazyText . LTB.toLazyText +{-# INLINE preEscapedTextBuilder #-} + +content :: ChoiceString -> Markup +content cs = Content cs () +{-# INLINE content #-} + -- | Create an HTML snippet from a 'String'. -- string :: String -- ^ String to insert. -> Markup -- ^ Resulting HTML fragment. -string = Content . String +string = content . String {-# INLINE string #-} -- | Create an HTML snippet from a 'String' without escaping -- preEscapedString :: String -- ^ String to insert. -> Markup -- ^ Resulting HTML fragment. -preEscapedString = Content . PreEscaped . String +preEscapedString = content . PreEscaped . String {-# INLINE preEscapedString #-} -- | Insert a 'ByteString'. This is an unsafe operation: @@ -306,7 +406,7 @@ -- unsafeByteString :: ByteString -- ^ Value to insert. -> Markup -- ^ Resulting HTML fragment. -unsafeByteString = Content . ByteString +unsafeByteString = content . ByteString {-# INLINE unsafeByteString #-} -- | Insert a lazy 'BL.ByteString'. See 'unsafeByteString' for reasons why this @@ -317,6 +417,41 @@ unsafeLazyByteString = mconcat . map unsafeByteString . BL.toChunks {-# INLINE unsafeLazyByteString #-} +comment :: ChoiceString -> Markup +comment cs = Comment cs () +{-# INLINE comment #-} + +-- | Create a comment from a 'Text' value. +-- The text should not contain @"--"@. +-- This is not checked by the library. +textComment :: Text -> Markup +textComment = comment . PreEscaped . Text + +-- | Create a comment from a 'LT.Text' value. +-- The text should not contain @"--"@. +-- This is not checked by the library. +lazyTextComment :: LT.Text -> Markup +lazyTextComment = comment . mconcat . map (PreEscaped . Text) . LT.toChunks + +-- | Create a comment from a 'String' value. +-- The text should not contain @"--"@. +-- This is not checked by the library. +stringComment :: String -> Markup +stringComment = comment . PreEscaped . String + +-- | Create a comment from a 'ByteString' value. +-- The text should not contain @"--"@. +-- This is not checked by the library. +unsafeByteStringComment :: ByteString -> Markup +unsafeByteStringComment = comment . PreEscaped . ByteString + +-- | Create a comment from a 'BL.ByteString' value. +-- The text should not contain @"--"@. +-- This is not checked by the library. +unsafeLazyByteStringComment :: BL.ByteString -> Markup +unsafeLazyByteStringComment = + comment . mconcat . map (PreEscaped . ByteString) . BL.toChunks + -- | Create a 'Tag' from some 'Text'. -- textTag :: Text -- ^ Text to create a tag from @@ -357,6 +492,20 @@ preEscapedLazyTextValue = mconcat . map preEscapedTextValue . LT.toChunks {-# INLINE preEscapedLazyTextValue #-} +-- | A variant of 'textValue' for text 'LTB.Builder' +-- +textBuilderValue :: LTB.Builder -- ^ The actual value + -> AttributeValue -- ^ Resulting attribute value +textBuilderValue = lazyTextValue . LTB.toLazyText +{-# INLINE textBuilderValue #-} + +-- | A variant of 'preEscapedTextValue' for text 'LTB.Builder' +-- +preEscapedTextBuilderValue :: LTB.Builder -- ^ The actual value + -> AttributeValue -- ^ Resulting attribute value +preEscapedTextBuilderValue = preEscapedLazyTextValue . LTB.toLazyText +{-# INLINE preEscapedTextBuilderValue #-} + -- | Create an attribute value from a 'String'. -- stringValue :: String -> AttributeValue @@ -441,13 +590,13 @@ -- combinators. -- external :: MarkupM a -> MarkupM a -external (Content x) = Content $ External x -external (Append x y) = Append (external x) (external y) -external (Parent x y z i) = Parent x y z $ external i -external (CustomParent x i) = CustomParent x $ external i -external (AddAttribute x y z i) = AddAttribute x y z $ external i +external (Content x a) = Content (External x) a +external (Append x y) = Append (external x) (external y) +external (Parent x y z i) = Parent x y z $ external i +external (CustomParent x i) = CustomParent x $ external i +external (AddAttribute x y z i) = AddAttribute x y z $ external i external (AddCustomAttribute x y i) = AddCustomAttribute x y $ external i -external x = x +external x = x {-# INLINE external #-} -- | Take only the text content of an HTML tree. @@ -460,14 +609,14 @@ -- -- > Hello World! -- -contents :: MarkupM a -> MarkupM b +contents :: MarkupM a -> MarkupM a contents (Parent _ _ _ c) = contents c contents (CustomParent _ c) = contents c -contents (Content c) = Content c +contents (Content c x) = Content c x contents (Append c1 c2) = Append (contents c1) (contents c2) contents (AddAttribute _ _ _ c) = contents c contents (AddCustomAttribute _ _ c) = contents c -contents _ = Empty +contents m = Empty (markupValue m) -- | Check if a 'Markup' value is completely empty (renders to the empty -- string). @@ -475,13 +624,14 @@ null markup = case markup of Parent _ _ _ _ -> False CustomParent _ _ -> False - Leaf _ _ _ -> False - CustomLeaf _ _ -> False - Content c -> emptyChoiceString c + Leaf _ _ _ _ -> False + CustomLeaf _ _ _ -> False + Content c _ -> emptyChoiceString c + Comment c _ -> emptyChoiceString c Append c1 c2 -> null c1 && null c2 AddAttribute _ _ _ c -> null c AddCustomAttribute _ _ c -> null c - Empty -> True + Empty _ -> True where emptyChoiceString cs = case cs of Static ss -> emptyStaticString ss diff --git a/src/Text/Blaze/Renderer/Pretty.hs b/src/Text/Blaze/Renderer/Pretty.hs --- a/src/Text/Blaze/Renderer/Pretty.hs +++ b/src/Text/Blaze/Renderer/Pretty.hs @@ -23,9 +23,9 @@ ind i . ('<' :) . fromChoiceString tag . attrs . (">\n" ++) . go (inc i) id content . ind i . ("\n" ++) - go i attrs (Leaf _ begin end) = + go i attrs (Leaf _ begin end _) = ind i . getString begin . attrs . getString end . ('\n' :) - go i attrs (CustomLeaf tag close) = + go i attrs (CustomLeaf tag close _) = ind i . ('<' :) . fromChoiceString tag . attrs . ((if close then " />\n" else ">\n") ++) go i attrs (AddAttribute _ key value h) = flip (go i) h $ @@ -33,9 +33,11 @@ go i attrs (AddCustomAttribute key value h) = flip (go i) h $ (' ' : ) . fromChoiceString key . ("=\"" ++) . fromChoiceString value . ('"' :) . attrs - go i _ (Content content) = ind i . fromChoiceString content . ('\n' :) + go i _ (Content content _) = ind i . fromChoiceString content . ('\n' :) + go i _ (Comment comment _) = ind i . + ("\n" ++) go i attrs (Append h1 h2) = go i attrs h1 . go i attrs h2 - go _ _ Empty = id + go _ _ (Empty _) = id {-# NOINLINE go #-} -- Increase the indentation diff --git a/src/Text/Blaze/Renderer/String.hs b/src/Text/Blaze/Renderer/String.hs --- a/src/Text/Blaze/Renderer/String.hs +++ b/src/Text/Blaze/Renderer/String.hs @@ -59,7 +59,7 @@ renderString :: Markup -- ^ Markup to render -> String -- ^ String to append -> String -- ^ Resulting String -renderString = go id +renderString = go id where go :: (String -> String) -> MarkupM b -> String -> String go attrs (Parent _ open close content) = @@ -67,8 +67,8 @@ go attrs (CustomParent tag content) = ('<' :) . fromChoiceString tag . attrs . ('>' :) . go id content . ("' :) - go attrs (Leaf _ begin end) = getString begin . attrs . getString end - go attrs (CustomLeaf tag close) = + go attrs (Leaf _ begin end _) = getString begin . attrs . getString end + go attrs (CustomLeaf tag close _) = ('<' :) . fromChoiceString tag . attrs . (if close then (" />" ++) else ('>' :)) go attrs (AddAttribute _ key value h) = flip go h $ @@ -76,9 +76,11 @@ go attrs (AddCustomAttribute key value h) = flip go h $ (' ' :) . fromChoiceString key . ("=\"" ++) . fromChoiceString value . ('"' :) . attrs - go _ (Content content) = fromChoiceString content + go _ (Content content _) = fromChoiceString content + go _ (Comment comment _) = + ("" ++) go attrs (Append h1 h2) = go attrs h1 . go attrs h2 - go _ Empty = id + go _ (Empty _) = id {-# NOINLINE go #-} {-# INLINE renderString #-} diff --git a/src/Text/Blaze/Renderer/Text.hs b/src/Text/Blaze/Renderer/Text.hs --- a/src/Text/Blaze/Renderer/Text.hs +++ b/src/Text/Blaze/Renderer/Text.hs @@ -99,11 +99,11 @@ `mappend` B.fromText "' - go attrs (Leaf _ begin end) = + go attrs (Leaf _ begin end _) = B.fromText (getText begin) `mappend` attrs `mappend` B.fromText (getText end) - go attrs (CustomLeaf tag close) = + go attrs (CustomLeaf tag close _) = B.singleton '<' `mappend` fromChoiceString d tag `mappend` attrs @@ -120,9 +120,13 @@ `mappend` fromChoiceString d value `mappend` B.singleton '"' `mappend` attrs) h - go _ (Content content) = fromChoiceString d content + go _ (Content content _) = fromChoiceString d content + go _ (Comment comment _) = + B.fromText "" go attrs (Append h1 h2) = go attrs h1 `mappend` go attrs h2 - go _ Empty = mempty + go _ (Empty _) = mempty {-# NOINLINE go #-} {-# INLINE renderMarkupBuilderWith #-} diff --git a/src/Text/Blaze/Renderer/Utf8.hs b/src/Text/Blaze/Renderer/Utf8.hs --- a/src/Text/Blaze/Renderer/Utf8.hs +++ b/src/Text/Blaze/Renderer/Utf8.hs @@ -65,11 +65,11 @@ `mappend` B.fromByteString "' - go attrs (Leaf _ begin end) = + go attrs (Leaf _ begin end _) = B.copyByteString (getUtf8ByteString begin) `mappend` attrs `mappend` B.copyByteString (getUtf8ByteString end) - go attrs (CustomLeaf tag close) = + go attrs (CustomLeaf tag close _) = B.fromChar '<' `mappend` fromChoiceString tag `mappend` attrs @@ -86,9 +86,13 @@ `mappend` fromChoiceString value `mappend` B.fromChar '"' `mappend` attrs) h - go _ (Content content) = fromChoiceString content + go _ (Content content _) = fromChoiceString content + go _ (Comment comment _) = + B.fromByteString "" go attrs (Append h1 h2) = go attrs h1 `mappend` go attrs h2 - go _ Empty = mempty + go _ (Empty _) = mempty {-# NOINLINE go #-} {-# INLINE renderMarkupBuilder #-} diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -2,11 +2,10 @@ -- module Main where -import Test.Framework (defaultMain, testGroup) +import qualified Test.Tasty as Tasty import qualified Text.Blaze.Tests main :: IO () -main = defaultMain - [ testGroup "Text.Blaze.Tests" Text.Blaze.Tests.tests - ] +main = Tasty.defaultMain $ + Tasty.testGroup "Text.Blaze.Tests" Text.Blaze.Tests.tests diff --git a/tests/Text/Blaze/Tests.hs b/tests/Text/Blaze/Tests.hs --- a/tests/Text/Blaze/Tests.hs +++ b/tests/Text/Blaze/Tests.hs @@ -8,28 +8,31 @@ import Prelude hiding (div, id, null) import Data.Monoid (mempty, mappend) import Control.Monad (replicateM) -import Control.Applicative ((<$>)) +import Control.Applicative (Applicative (..), (<$>)) import Data.Word (Word8) -import Data.Char (ord) +import Data.Char (ord, isControl) import qualified Data.List as List +import qualified Prelude as Prelude -import Test.Framework (Test) +import Test.Tasty (TestTree) import Test.HUnit (Assertion, (@=?)) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Tasty.HUnit (testCase) +import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.Char8 as LBC +import Text.Blaze import Text.Blaze.Internal import Text.Blaze.Tests.Util -tests :: [Test] +tests :: [TestTree] tests = [ testProperty "left identity Monoid law" monoidLeftIdentity , testProperty "right identity Monoid law" monoidRightIdentity , testProperty "associativity Monoid law" monoidAssociativity , testProperty "mconcat Monoid law" monoidConcat + , testProperty "identity Applicative law" applicativeIdentity , testProperty "post escaping characters" postEscapingCharacters , testProperty "valid UTF-8" isValidUtf8 , testProperty "external Bool monoidConcat xs = sequence_ xs == foldr (>>) (return ()) xs +-- | Applicative identity law. +-- +applicativeIdentity :: Markup -> Bool +applicativeIdentity x = (pure Prelude.id <*> x) == x + -- | Escaped content cannot contain certain characters. -- postEscapingCharacters :: String -> Bool @@ -132,6 +141,7 @@ html :: Markup html = div $ do p ! id "para" $ "Hello " + stringComment "Test test" img ! name "An image" p "World!" @@ -150,6 +160,15 @@ html :: Markup html = "" `mappend` "" `mappend` p "a" +comment1 :: Assertion +comment1 = preEscapedString "
Hello World!
" @=? html + where + html :: Markup + html = div $ do + "Hello " + stringComment "Test" + " World!" + -- Show instance for the HTML type, so we can debug. -- instance Show Markup where @@ -206,11 +225,14 @@ -- Generate arbitrary string element. arbitraryString = do - s <- arbitrary + s <- genString return $ string s -- Generate an arbitrary HTML attribute. arbitraryAttribute = do attr <- elements [id, class_, name] - value <- arbitrary + value <- genString return $ attr $ stringValue value + + -- Don't use control characters + genString = filter (not . isControl) <$> arbitrary diff --git a/tests/Text/Blaze/Tests/Util.hs b/tests/Text/Blaze/Tests/Util.hs --- a/tests/Text/Blaze/Tests/Util.hs +++ b/tests/Text/Blaze/Tests/Util.hs @@ -5,8 +5,8 @@ ( renderUsingString , renderUsingText , renderUsingUtf8 - , p, div, table, img, br, area - , id, class_, name + , p, div, table, img, br, area + , id, class_, name ) where import Prelude hiding (div, id) @@ -50,13 +50,13 @@ table = Parent "table" "" img :: Markup -- ^ Resulting HTML. -img = Leaf "img" "" +img = Leaf "img" "" () br :: Markup -- ^ Resulting HTML. -br = Leaf "br" "" +br = Leaf "br" "" () area :: Markup -- ^ Resulting HTML. -area = Leaf "area" "" +area = Leaf "area" "" () class_ :: AttributeValue -- ^ Attribute value. -> Attribute -- ^ Resulting attribute.