blaze-markup 0.6.1.0 → 0.8.3.0
raw patch · 11 files changed
Files
- CHANGELOG +82/−0
- blaze-markup.cabal +44/−21
- src/Text/Blaze.hs +65/−8
- src/Text/Blaze/Internal.hs +205/−55
- src/Text/Blaze/Renderer/Pretty.hs +6/−4
- src/Text/Blaze/Renderer/String.hs +7/−5
- src/Text/Blaze/Renderer/Text.hs +8/−4
- src/Text/Blaze/Renderer/Utf8.hs +8/−4
- tests/TestSuite.hs +3/−4
- tests/Text/Blaze/Tests.hs +30/−8
- tests/Text/Blaze/Tests/Util.hs +5/−5
CHANGELOG view
@@ -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.
blaze-markup.cabal view
@@ -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 @@ <http://jaspervdj.be/blaze/tutorial.html>. 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
src/Text/Blaze.hs view
@@ -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
src/Text/Blaze/Internal.hs view
@@ -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 @@ -- -- > <p data-foo="bar">Hello.</p> ----- 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
src/Text/Blaze/Renderer/Pretty.hs view
@@ -23,9 +23,9 @@ ind i . ('<' :) . fromChoiceString tag . attrs . (">\n" ++) . go (inc i) id content . ind i . ("</" ++) . fromChoiceString tag . (">\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 .+ ("<!-- " ++) . fromChoiceString comment . (" -->\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
src/Text/Blaze/Renderer/String.hs view
@@ -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 . ("</" ++) . fromChoiceString tag . ('>' :)- 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 _) =+ ("<!-- " ++) . fromChoiceString comment . (" -->" ++) go attrs (Append h1 h2) = go attrs h1 . go attrs h2- go _ Empty = id+ go _ (Empty _) = id {-# NOINLINE go #-} {-# INLINE renderString #-}
src/Text/Blaze/Renderer/Text.hs view
@@ -99,11 +99,11 @@ `mappend` B.fromText "</" `mappend` fromChoiceString d tag `mappend` B.singleton '>'- 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 "<!-- "+ `mappend` fromChoiceString d comment+ `mappend` " -->" go attrs (Append h1 h2) = go attrs h1 `mappend` go attrs h2- go _ Empty = mempty+ go _ (Empty _) = mempty {-# NOINLINE go #-} {-# INLINE renderMarkupBuilderWith #-}
src/Text/Blaze/Renderer/Utf8.hs view
@@ -65,11 +65,11 @@ `mappend` B.fromByteString "</" `mappend` fromChoiceString tag `mappend` B.fromChar '>'- 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 "<!-- "+ `mappend` fromChoiceString comment+ `mappend` B.fromByteString " -->" go attrs (Append h1 h2) = go attrs h1 `mappend` go attrs h2- go _ Empty = mempty+ go _ (Empty _) = mempty {-# NOINLINE go #-} {-# INLINE renderMarkupBuilder #-}
tests/TestSuite.hs view
@@ -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
tests/Text/Blaze/Tests.hs view
@@ -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 </ sequence" externalEndSequence@@ -40,6 +43,7 @@ , testCase "contents 1" contents1 , testCase "empty 1" empty1 , testCase "empty 2" empty2+ , testCase "comment 1" comment1 ] -- | The left identity Monoid law.@@ -62,6 +66,11 @@ monoidConcat :: [Markup] -> 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 "<div>Hello <!-- Test --> World!</div>" @=? 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
tests/Text/Blaze/Tests/Util.hs view
@@ -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" "<table" "</table>" img :: Markup -- ^ Resulting HTML.-img = Leaf "img" "<img" ">"+img = Leaf "img" "<img" ">" () br :: Markup -- ^ Resulting HTML.-br = Leaf "br" "<br" ">"+br = Leaf "br" "<br" ">" () area :: Markup -- ^ Resulting HTML.-area = Leaf "area" "<area" ">"+area = Leaf "area" "<area" ">" () class_ :: AttributeValue -- ^ Attribute value. -> Attribute -- ^ Resulting attribute.