packages feed

blaze-markup (empty) → 0.5.0.0

raw patch · 12 files changed

+1332/−0 lines, 12 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, blaze-builder, bytestring, containers, test-framework, test-framework-hunit, test-framework-quickcheck2, text

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Jasper Van der Jeugt 2010++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 Jasper Van der Jeugt 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ blaze-markup.cabal view
@@ -0,0 +1,64 @@+Name:         blaze-markup+Version:      0.5.0.0+Homepage:     http://jaspervdj.be/blaze+Bug-Reports:  http://github.com/jaspervdj/blaze-markup/issues+License:      BSD3+License-file: LICENSE+Author:       Jasper Van der Jeugt, Simon Meier, Deepak Jois+Maintainer:   Jasper Van der Jeugt <m@jaspervdj.be>+Stability:    Experimental+Category:     Text+Synopsis:     A blazingly fast markup combinator library for Haskell+Description:+  Core modules of a blazingly fast markup combinator library for the Haskell+  programming language. The Text.Blaze module is a good+  starting point, as well as this tutorial:+  <http://jaspervdj.be/blaze/tutorial.html>.++Build-type:    Simple+Cabal-version: >= 1.8++Library+  Hs-source-dirs: src+  Ghc-Options:    -Wall++  Exposed-modules:+    Text.Blaze+    Text.Blaze.Internal+    Text.Blaze.Renderer.Pretty+    Text.Blaze.Renderer.String+    Text.Blaze.Renderer.Text+    Text.Blaze.Renderer.Utf8++  Build-depends:+    base          >= 4    && < 5,+    blaze-builder >= 0.2  && < 0.4,+    text          >= 0.10 && < 0.12,+    bytestring    >= 0.9  && < 0.10++Test-suite blaze-markup-tests+  Type:           exitcode-stdio-1.0+  Hs-source-dirs: src tests+  Main-is:        TestSuite.hs+  Ghc-options:    -Wall++  Other-modules:+    Text.Blaze.Tests+    Text.Blaze.Tests.Util++  Build-depends:+    HUnit                      >= 1.2 && < 1.3,+    QuickCheck                 >= 2.4 && < 2.5,+    containers                 >= 0.3 && < 0.5,+    test-framework             >= 0.4 && < 0.7,+    test-framework-hunit       >= 0.2 && < 0.3,+    test-framework-quickcheck2 >= 0.2 && < 0.3,+    -- Copied from regular dependencies...+    base          >= 4    && < 5,+    blaze-builder >= 0.2  && < 0.4,+    text          >= 0.10 && < 0.12,+    bytestring    >= 0.9  && < 0.10++Source-repository head+  Type:     git+  Location: http://github.com/jaspervdj/blaze-markup
+ src/Text/Blaze.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE FlexibleInstances, 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.+--+-- To use the library, one needs to import a set of combinators. For example,+-- you can use HTML 4 Strict from BlazeHtml package.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Prelude hiding (head, id, div)+-- > import Text.Blaze.Html4.Strict hiding (map)+-- > import Text.Blaze.Html4.Strict.Attributes hiding (title)+--+-- To render the page later on, you need a so called Renderer. The recommended+-- renderer is an UTF-8 renderer which produces a lazy bytestring.+--+-- > import Text.Blaze.Renderer.Utf8 (renderMarkup)+--+-- Now, you can describe pages using the imported combinators.+--+-- > page1 :: Markup+-- > page1 = html $ do+-- >     head $ do+-- >         title "Introduction page."+-- >         link ! rel "stylesheet" ! type_ "text/css" ! href "screen.css"+-- >     body $ do+-- >         div ! id "header" $ "Syntax"+-- >         p "This is an example of BlazeMarkup syntax."+-- >         ul $ mapM_ (li . toMarkup . show) [1, 2, 3]+--+-- The resulting HTML can now be extracted using:+--+-- > renderMarkup page1+--+module Text.Blaze+    (+      -- * Important types.+      Markup+    , Tag+    , Attribute+    , AttributeValue++      -- * Creating attributes.+    , dataAttribute+    , customAttribute++      -- * Converting values to HTML.+    , ToMarkup (..)+    , preEscapedText+    , preEscapedLazyText+    , preEscapedString+    , unsafeByteString+    , unsafeLazyByteString++      -- * Creating tags.+    , textTag+    , stringTag++      -- * Converting values to attribute values.+    , ToValue (..)+    , preEscapedTextValue+    , preEscapedLazyTextValue+    , preEscapedStringValue+    , unsafeByteStringValue+    , unsafeLazyByteStringValue++      -- * Setting attributes+    , (!)+    ) where++import Data.Monoid (mconcat)++import Data.Text (Text)+import qualified Data.Text.Lazy as LT++import Text.Blaze.Internal++-- | Class allowing us to use a single function for Markup values+--+class ToMarkup a where+    -- | Convert a value to Markup.+    --+    toMarkup :: a -> Markup++instance ToMarkup Markup where+    toMarkup = id+    {-# INLINE toMarkup #-}++instance ToMarkup [Markup] where+    toMarkup = mconcat+    {-# INLINE toMarkup #-}++instance ToMarkup Text where+    toMarkup = text+    {-# INLINE toMarkup #-}++instance ToMarkup LT.Text where+    toMarkup = lazyText+    {-# INLINE toMarkup #-}++instance ToMarkup String where+    toMarkup = string+    {-# INLINE toMarkup #-}++instance ToMarkup Int where+    toMarkup = string . show+    {-# INLINE toMarkup #-}++instance ToMarkup Char where+    toMarkup = string . return+    {-# INLINE toMarkup #-}++instance ToMarkup Bool where+    toMarkup = string . show+    {-# INLINE toMarkup #-}++instance ToMarkup Integer where+    toMarkup = string . show+    {-# INLINE toMarkup #-}++instance ToMarkup Float where+    toMarkup = string . show+    {-# INLINE toMarkup #-}++instance ToMarkup Double where+    toMarkup = string . show+    {-# INLINE toMarkup #-}++-- | Class allowing us to use a single function for attribute values+--+class ToValue a where+    -- | Convert a value to an attribute value+    --+    toValue :: a -> AttributeValue++instance ToValue AttributeValue where+    toValue = id+    {-# INLINE toValue #-}++instance ToValue Text where+    toValue = textValue+    {-# INLINE toValue #-}++instance ToValue LT.Text where+    toValue = lazyTextValue+    {-# INLINE toValue #-}++instance ToValue String where+    toValue = stringValue+    {-# INLINE toValue #-}++instance ToValue Int where+    toValue = stringValue . show+    {-# INLINE toValue #-}++instance ToValue Char where+    toValue = stringValue . return+    {-# INLINE toValue #-}++instance ToValue Bool where+    toValue = stringValue . show+    {-# INLINE toValue #-}++instance ToValue Integer where+    toValue = stringValue . show+    {-# INLINE toValue #-}++instance ToValue Float where+    toValue = stringValue . show+    {-# INLINE toValue #-}++instance ToValue Double where+    toValue = stringValue . show+    {-# INLINE toValue #-}
+ src/Text/Blaze/Internal.hs view
@@ -0,0 +1,414 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, Rank2Types,+             FlexibleInstances, ExistentialQuantification,+             DeriveDataTypeable #-}+-- | 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'.+--+-- 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.+--+module Text.Blaze.Internal+    (+      -- * Important types.+      ChoiceString (..)+    , StaticString (..)+    , MarkupM (..)+    , Markup+    , Tag+    , Attribute+    , AttributeValue++      -- * Creating custom tags and attributes.+    , attribute+    , dataAttribute+    , customAttribute++      -- * Converting values to HTML.+    , text+    , preEscapedText+    , lazyText+    , preEscapedLazyText+    , string+    , preEscapedString+    , unsafeByteString+    , unsafeLazyByteString++      -- * Converting values to tags.+    , textTag+    , stringTag++      -- * Converting values to attribute values.+    , textValue+    , preEscapedTextValue+    , lazyTextValue+    , preEscapedLazyTextValue+    , stringValue+    , preEscapedStringValue+    , unsafeByteStringValue+    , unsafeLazyByteStringValue++      -- * Setting attributes+    , Attributable+    , (!)++      -- * Modifying HTML elements+    , external+    ) where++import Data.Monoid (Monoid, mappend, mempty, mconcat)+import Unsafe.Coerce (unsafeCoerce)++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++-- | A static string that supports efficient output to all possible backends.+--+data StaticString = StaticString+    { getString         :: String -> String  -- ^ Appending haskell string+    , getUtf8ByteString :: B.ByteString      -- ^ UTF-8 encoded bytestring+    , getText           :: Text              -- ^ Text value+    }++-- 'StaticString's should only be converted from string literals, as far as I+-- can see.+--+instance IsString StaticString where+    fromString s = let t = T.pack s+                   in StaticString (s ++) (T.encodeUtf8 t) t++-- | A string denoting input from different string representations.+--+data ChoiceString+    -- | Static data+    = Static {-# UNPACK #-} !StaticString+    -- | A Haskell String+    | String String+    -- | A Text value+    | Text Text+    -- | An encoded bytestring+    | ByteString B.ByteString+    -- | A pre-escaped string+    | PreEscaped ChoiceString+    -- | External data in style/script tags, should be checked for validity+    | External ChoiceString+    -- | Concatenation+    | AppendChoiceString ChoiceString ChoiceString+    -- | Empty string+    | EmptyChoiceString++instance Monoid ChoiceString where+    mempty = EmptyChoiceString+    {-# INLINE mempty #-}+    mappend = AppendChoiceString+    {-# INLINE mappend #-}++instance IsString ChoiceString where+    fromString = String+    {-# INLINE fromString #-}++-- | The core Markup datatype.+--+data MarkupM a+    -- | Tag, open tag, end tag, content+    = forall b. Parent StaticString StaticString StaticString (MarkupM b)+    -- | Tag, open tag, end tag+    | Leaf StaticString StaticString StaticString+    -- | HTML content+    | Content ChoiceString+    -- | Concatenation of two HTML pieces+    | forall b c. Append (MarkupM b) (MarkupM c)+    -- | 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 ChoiceString (MarkupM a)+    -- | Empty HTML.+    | Empty+    deriving (Typeable)++-- | Simplification of the 'MarkupM' datatype.+--+type Markup = MarkupM ()++instance Monoid a => Monoid (MarkupM a) where+    mempty = Empty+    {-# INLINE mempty #-}+    mappend x y = Append x y+    {-# INLINE mappend #-}+    mconcat = foldr Append Empty+    {-# INLINE mconcat #-}++instance Functor MarkupM where+    -- Safe because it does not contain a value anyway+    fmap _ = unsafeCoerce++instance Monad MarkupM where+    return _ = Empty+    {-# INLINE return #-}+    (>>) = Append+    {-# INLINE (>>) #-}+    h1 >>= f = h1 >> f+        (error "Text.Blaze.Internal.MarkupM: invalid use of monadic bind")+    {-# INLINE (>>=) #-}++instance IsString (MarkupM a) where+    fromString = Content . fromString+    {-# INLINE fromString #-}++-- | Type for an HTML tag. This can be seen as an internal string type used by+-- BlazeMarkup.+--+newtype Tag = Tag { unTag :: StaticString }+    deriving (IsString)++-- | Type for an attribute.+--+newtype Attribute = Attribute (forall a. MarkupM a -> MarkupM a)++instance Monoid Attribute where+    mempty                            = Attribute id+    Attribute f `mappend` Attribute g = Attribute (g . f)++-- | The type for the value part of an attribute.+--+newtype AttributeValue = AttributeValue { unAttributeValue :: ChoiceString }+    deriving (IsString, Monoid)++-- | Create an HTML attribute that can be applied to an HTML element later using+-- the '!' operator.+--+attribute :: Tag             -- ^ Raw key+          -> Tag             -- ^ Shared key string for the HTML attribute.+          -> AttributeValue  -- ^ Value for the HTML attribute.+          -> Attribute       -- ^ Resulting HTML attribute.+attribute rawKey key value = Attribute $+    AddAttribute (unTag rawKey) (unTag key) (unAttributeValue value)+{-# INLINE attribute #-}++-- | From HTML 5 onwards, the user is able to specify custom data attributes.+--+-- An example:+--+-- > <p data-foo="bar">Hello.</p>+--+-- We support this in BlazeMarkup using this funcion. The above fragment could+-- be described using BlazeMarkup with:+--+-- > p ! dataAttribute "foo" "bar" $ "Hello."+--+dataAttribute :: Tag             -- ^ Name of the attribute.+              -> AttributeValue  -- ^ Value for the attribute.+              -> Attribute       -- ^ Resulting HTML attribute.+dataAttribute tag value = Attribute $ AddCustomAttribute+    (Static "data-" `mappend` Static (unTag tag))+    (Static " data-" `mappend` Static (unTag tag) `mappend` Static "=\"")+    (unAttributeValue value)+{-# INLINE dataAttribute #-}++-- | Create a custom attribute. This is not specified in the HTML spec, but some+-- JavaScript libraries rely on it.+--+-- An example:+--+-- > <select dojoType="select">foo</select>+--+-- Can be produced using:+--+-- > select ! customAttribute "dojoType" "select" $ "foo"+--+customAttribute :: Tag             -- ^ Name of the attribute+                -> AttributeValue  -- ^ Value for the attribute+                -> Attribute       -- ^ Resulting HTML attribtue+customAttribute tag value = Attribute $ AddCustomAttribute+    (Static $ unTag tag)+    (Static " " `mappend` Static (unTag tag) `mappend` Static "=\"")+    (unAttributeValue value)+{-# INLINE customAttribute #-}++-- | Render text. Functions like these can be used to supply content in HTML.+--+text :: Text    -- ^ Text to render.+     -> Markup  -- ^ Resulting HTML fragment.+text = Content . Text+{-# INLINE text #-}++-- | Render text without escaping.+--+preEscapedText :: Text    -- ^ Text to insert+               -> Markup  -- ^ Resulting HTML fragment+preEscapedText = Content . PreEscaped . Text+{-# INLINE preEscapedText #-}++-- | A variant of 'text' for lazy 'LT.Text'.+--+lazyText :: LT.Text  -- ^ Text to insert+         -> Markup   -- ^ Resulting HTML fragment+lazyText = mconcat . map text . LT.toChunks+{-# INLINE lazyText #-}++-- | A variant of 'preEscapedText' for lazy 'LT.Text'+--+preEscapedLazyText :: LT.Text  -- ^ Text to insert+                   -> Markup   -- ^ Resulting HTML fragment+preEscapedLazyText = mconcat . map preEscapedText . LT.toChunks++-- | Create an HTML snippet from a 'String'.+--+string :: String  -- ^ String to insert.+       -> Markup  -- ^ Resulting HTML fragment.+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+{-# INLINE preEscapedString #-}++-- | Insert a 'ByteString'. This is an unsafe operation:+--+-- * The 'ByteString' could have the wrong encoding.+--+-- * The 'ByteString' might contain illegal HTML characters (no escaping is+--   done).+--+unsafeByteString :: ByteString  -- ^ Value to insert.+                 -> Markup      -- ^ Resulting HTML fragment.+unsafeByteString = Content . ByteString+{-# INLINE unsafeByteString #-}++-- | Insert a lazy 'BL.ByteString'. See 'unsafeByteString' for reasons why this+-- is an unsafe operation.+--+unsafeLazyByteString :: BL.ByteString  -- ^ Value to insert+                     -> Markup         -- ^ Resulting HTML fragment+unsafeLazyByteString = mconcat . map unsafeByteString . BL.toChunks+{-# INLINE unsafeLazyByteString #-}++-- | Create a 'Tag' from some 'Text'.+--+textTag :: Text  -- ^ Text to create a tag from+        -> Tag   -- ^ Resulting tag+textTag t = Tag $ StaticString (T.unpack t ++) (T.encodeUtf8 t) t++-- | Create a 'Tag' from a 'String'.+--+stringTag :: String  -- ^ String to create a tag from+          -> Tag     -- ^ Resulting tag+stringTag = Tag . fromString++-- | Render an attribute value from 'Text'.+--+textValue :: Text            -- ^ The actual value.+          -> AttributeValue  -- ^ Resulting attribute value.+textValue = AttributeValue . Text+{-# INLINE textValue #-}++-- | Render an attribute value from 'Text' without escaping.+--+preEscapedTextValue :: Text            -- ^ The actual value+                    -> AttributeValue  -- ^ Resulting attribute value+preEscapedTextValue = AttributeValue . PreEscaped . Text+{-# INLINE preEscapedTextValue #-}++-- | A variant of 'textValue' for lazy 'LT.Text'+--+lazyTextValue :: LT.Text         -- ^ The actual value+              -> AttributeValue  -- ^ Resulting attribute value+lazyTextValue = mconcat . map textValue . LT.toChunks+{-# INLINE lazyTextValue #-}++-- | A variant of 'preEscapedTextValue' for lazy 'LT.Text'+--+preEscapedLazyTextValue :: LT.Text         -- ^ The actual value+                        -> AttributeValue  -- ^ Resulting attribute value+preEscapedLazyTextValue = mconcat . map preEscapedTextValue . LT.toChunks+{-# INLINE preEscapedLazyTextValue #-}++-- | Create an attribute value from a 'String'.+--+stringValue :: String -> AttributeValue+stringValue = AttributeValue . String+{-# INLINE stringValue #-}++-- | Create an attribute value from a 'String' without escaping.+--+preEscapedStringValue :: String -> AttributeValue+preEscapedStringValue = AttributeValue . PreEscaped . String+{-# INLINE preEscapedStringValue #-}++-- | Create an attribute value from a 'ByteString'. See 'unsafeByteString'+-- for reasons why this might not be a good idea.+--+unsafeByteStringValue :: ByteString      -- ^ ByteString value+                      -> AttributeValue  -- ^ Resulting attribute value+unsafeByteStringValue = AttributeValue . ByteString+{-# INLINE unsafeByteStringValue #-}++-- | Create an attribute value from a lazy 'BL.ByteString'. See+-- 'unsafeByteString' for reasons why this might not be a good idea.+--+unsafeLazyByteStringValue :: BL.ByteString   -- ^ ByteString value+                          -> AttributeValue  -- ^ Resulting attribute value+unsafeLazyByteStringValue = mconcat . map unsafeByteStringValue . BL.toChunks+{-# INLINE unsafeLazyByteStringValue #-}++-- | Used for applying attributes. You should not define your own instances of+-- this class.+class Attributable h where+    -- | Apply an attribute to an element.+    --+    -- Example:+    --+    -- > img ! src "foo.png"+    --+    -- Result:+    --+    -- > <img src="foo.png" />+    --+    -- This can be used on nested elements as well.+    --+    -- Example:+    --+    -- > p ! style "float: right" $ "Hello!"+    --+    -- Result:+    --+    -- > <p style="float: right">Hello!</p>+    --+    (!) :: h -> Attribute -> h++instance Attributable (MarkupM a) where+    h ! (Attribute f) = f h+    {-# INLINE (!) #-}++instance Attributable (MarkupM a -> MarkupM b) where+    h ! f = (! f) . h+    {-# INLINE (!) #-}++-- | Mark HTML as external data. External data can be:+--+-- * CSS data in a @<style>@ tag;+--+-- * Script data in a @<script>@ tag.+--+-- This function is applied automatically when using the @style@ or @script@+-- 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 (AddAttribute x y z i) = AddAttribute x y z $ external i+external (AddCustomAttribute x y z i) = AddCustomAttribute x y z $ external i+external x = x+{-# INLINE external #-}
+ src/Text/Blaze/Renderer/Pretty.hs view
@@ -0,0 +1,49 @@+-- | A renderer that produces pretty HTML, mostly meant for debugging purposes.+--+module Text.Blaze.Renderer.Pretty+    ( renderMarkup+    , renderHtml+    ) where++import Text.Blaze.Internal+import Text.Blaze.Renderer.String (fromChoiceString)++-- | Render some 'Markup' to an appending 'String'.+--+renderString :: Markup  -- ^ Markup to render+             -> String  -- ^ String to append+             -> String  -- ^ Resulting String+renderString = go 0 id+  where+    go :: Int -> (String -> String) -> MarkupM b -> String -> String+    go i attrs (Parent _ open close content) =+        ind i . getString open . attrs . (">\n" ++) . go (inc i) id content+              . ind i . getString close .  ('\n' :)+    go i attrs (Leaf _ begin end) =+        ind i . getString begin . attrs . getString end . ('\n' :)+    go i attrs (AddAttribute _ key value h) = flip (go i) h $+        getString key . fromChoiceString value . ('"' :) . attrs+    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 attrs (Append h1 h2) = go i attrs h1 . go i attrs h2+    go _ _ Empty = id+    {-# NOINLINE go #-}++    -- Increase the indentation+    inc = (+) 4++    -- Produce appending indentation+    ind i = (replicate i ' ' ++)+{-# INLINE renderString #-}++-- | Render markup to a lazy 'String'. The result is prettified.+--+renderMarkup :: Markup -> String+renderMarkup html = renderString html ""+{-# INLINE renderMarkup #-}++renderHtml :: Markup -> String+renderHtml = renderMarkup+{-# DEPRECATED renderHtml "Use renderMarkup instead" #-}+{-# INLINE renderHtml #-}
+ src/Text/Blaze/Renderer/String.hs view
@@ -0,0 +1,88 @@+-- | A renderer that produces a native Haskell 'String', mostly meant for+-- debugging purposes.+--+{-# LANGUAGE OverloadedStrings #-}+module Text.Blaze.Renderer.String+    ( fromChoiceString+    , renderMarkup+    , renderHtml+    ) where++import Data.List (isInfixOf)++import qualified Data.ByteString.Char8 as SBC+import qualified Data.Text as T+import qualified Data.ByteString as S++import Text.Blaze.Internal++-- | Escape predefined XML entities in a string+--+escapeMarkupEntities :: String  -- ^ String to escape+                   -> String  -- ^ String to append+                   -> String  -- ^ Resulting string+escapeMarkupEntities []     k = k+escapeMarkupEntities (c:cs) k = case c of+    '<'  -> '&' : 'l' : 't' : ';'             : escapeMarkupEntities cs k+    '>'  -> '&' : 'g' : 't' : ';'             : escapeMarkupEntities cs k+    '&'  -> '&' : 'a' : 'm' : 'p' : ';'       : escapeMarkupEntities cs k+    '"'  -> '&' : 'q' : 'u' : 'o' : 't' : ';' : escapeMarkupEntities cs k+    '\'' -> '&' : '#' : '3' : '9' : ';'       : escapeMarkupEntities cs k+    x    -> x                                 : escapeMarkupEntities cs k++-- | Render a 'ChoiceString'.+--+fromChoiceString :: ChoiceString  -- ^ String to render+                 -> String        -- ^ String to append+                 -> String        -- ^ Resulting string+fromChoiceString (Static s)     = getString s+fromChoiceString (String s)     = escapeMarkupEntities s+fromChoiceString (Text s)       = escapeMarkupEntities $ T.unpack s+fromChoiceString (ByteString s) = (SBC.unpack s ++)+fromChoiceString (PreEscaped x) = case x of+    String s -> (s ++)+    Text   s -> (\k -> T.foldr (:) k s)+    s        -> fromChoiceString s+fromChoiceString (External x) = case x of+    -- Check that the sequence "</" is *not* in the external data.+    String s     -> if "</" `isInfixOf` s then id else (s ++)+    Text   s     -> if "</" `T.isInfixOf` s then id else (\k -> T.foldr (:) k s)+    ByteString s -> if "</" `S.isInfixOf` s then id else (SBC.unpack s ++)+    s            -> fromChoiceString s+fromChoiceString (AppendChoiceString x y) =+    fromChoiceString x . fromChoiceString y+fromChoiceString EmptyChoiceString = id+{-# INLINE fromChoiceString #-}++-- | Render some 'Markup' to an appending 'String'.+--+renderString :: Markup    -- ^ Markup to render+             -> String  -- ^ String to append+             -> String  -- ^ Resulting String+renderString = go id +  where+    go :: (String -> String) -> MarkupM b -> String -> String+    go attrs (Parent _ open close content) =+        getString open . attrs . ('>' :) . go id content . getString close+    go attrs (Leaf _ begin end) = getString begin . attrs . getString end+    go attrs (AddAttribute _ key value h) = flip go h $+        getString key . fromChoiceString value . ('"' :) . attrs+    go attrs (AddCustomAttribute _ key value h) = flip go h $+        fromChoiceString key . fromChoiceString value . ('"' :) . attrs+    go _ (Content content) = fromChoiceString content+    go attrs (Append h1 h2) = go attrs h1 . go attrs h2+    go _ Empty = id+    {-# NOINLINE go #-}+{-# INLINE renderString #-}++-- | Render markup to a lazy 'String'.+--+renderMarkup :: Markup -> String+renderMarkup html = renderString html ""+{-# INLINE renderMarkup #-}++renderHtml :: Markup -> String+renderHtml = renderMarkup+{-# DEPRECATED renderHtml "Use renderMarkup instead" #-}+{-# INLINE renderHtml #-}+
+ src/Text/Blaze/Renderer/Text.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE OverloadedStrings #-}+-- | A renderer that produces a lazy 'L.Text' value, using the Text Builder.+--+module Text.Blaze.Renderer.Text+    ( renderMarkupBuilder+    , renderMarkupBuilderWith+    , renderMarkup+    , renderMarkupWith+    , renderHtmlBuilder+    , renderHtmlBuilderWith+    , renderHtml+    , renderHtmlWith+    ) where++import Data.Monoid (mappend, mempty)+import Data.List (isInfixOf)++import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import qualified Data.Text.Lazy as L+import Data.ByteString (ByteString)+import qualified Data.ByteString as S (isInfixOf)++import Text.Blaze.Internal+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as B++-- | Escape predefined XML entities in a text value+--+escapeMarkupEntities :: Text     -- ^ Text to escape+                   -> Builder  -- ^ Resulting text builder+escapeMarkupEntities = T.foldr escape mempty+  where+    escape :: Char -> Builder -> Builder+    escape '<'  b = B.fromText "&lt;"   `mappend` b+    escape '>'  b = B.fromText "&gt;"   `mappend` b+    escape '&'  b = B.fromText "&amp;"  `mappend` b+    escape '"'  b = B.fromText "&quot;" `mappend` b+    escape '\'' b = B.fromText "&#39;"  `mappend` b+    escape x    b = B.singleton x       `mappend` b++-- | Render a 'ChoiceString'. TODO: Optimization possibility, apply static+-- argument transformation.+--+fromChoiceString :: (ByteString -> Text)  -- ^ Decoder for bytestrings+                 -> ChoiceString          -- ^ String to render+                 -> Builder               -- ^ Resulting builder+fromChoiceString _ (Static s)     = B.fromText $ getText s+fromChoiceString _ (String s)     = escapeMarkupEntities $ T.pack s+fromChoiceString _ (Text s)       = escapeMarkupEntities s+fromChoiceString d (ByteString s) = B.fromText $ d s+fromChoiceString d (PreEscaped x) = case x of+    String s -> B.fromText $ T.pack s+    Text   s -> B.fromText s+    s        -> fromChoiceString d s+fromChoiceString d (External x) = case x of+    -- Check that the sequence "</" is *not* in the external data.+    String s     -> if "</" `isInfixOf` s then mempty else B.fromText (T.pack s)+    Text   s     -> if "</" `T.isInfixOf` s then mempty else B.fromText s+    ByteString s -> if "</" `S.isInfixOf` s then mempty else B.fromText (d s)+    s            -> fromChoiceString d s+fromChoiceString d (AppendChoiceString x y) =+    fromChoiceString d x `mappend` fromChoiceString d y+fromChoiceString _ EmptyChoiceString = mempty+{-# INLINE fromChoiceString #-}++-- | Render markup to a text builder+renderMarkupBuilder :: Markup -> Builder+renderMarkupBuilder = renderMarkupBuilderWith decodeUtf8+{-# INLINE renderMarkupBuilder #-}++renderHtmlBuilder :: Markup -> Builder+renderHtmlBuilder = renderMarkupBuilder+{-# DEPRECATED renderHtmlBuilder "Use renderMarkupBuilder instead" #-}+{-# INLINE renderHtmlBuilder #-}++-- | Render some 'Markup' to a Text 'Builder'.+--+renderMarkupBuilderWith :: (ByteString -> Text)  -- ^ Decoder for bytestrings+                        -> Markup                -- ^ Markup to render+                        -> Builder               -- ^ Resulting builder+renderMarkupBuilderWith d = go mempty+  where+    go :: Builder -> MarkupM b -> Builder+    go attrs (Parent _ open close content) =+        B.fromText (getText open)+            `mappend` attrs+            `mappend` B.singleton '>'+            `mappend` go mempty content+            `mappend` B.fromText (getText close)+    go attrs (Leaf _ begin end) =+        B.fromText (getText begin)+            `mappend` attrs+            `mappend` B.fromText (getText end)+    go attrs (AddAttribute _ key value h) =+        go (B.fromText (getText key)+            `mappend` fromChoiceString d value+            `mappend` B.singleton '"'+            `mappend` attrs) h+    go attrs (AddCustomAttribute _ key value h) =+        go (fromChoiceString d key+            `mappend` fromChoiceString d value+            `mappend` B.singleton '"'+            `mappend` attrs) h+    go _ (Content content)  = fromChoiceString d content+    go attrs (Append h1 h2) = go attrs h1 `mappend` go attrs h2+    go _ Empty              = mempty+    {-# NOINLINE go #-}+{-# INLINE renderMarkupBuilderWith #-}++renderHtmlBuilderWith :: (ByteString -> Text)  -- ^ Decoder for bytestrings+                      -> Markup                -- ^ Markup to render+                      -> Builder               -- ^ Resulting builder+renderHtmlBuilderWith = renderMarkupBuilderWith+{-# DEPRECATED renderHtmlBuilderWith "Use renderMarkupBuilderWith instead" #-}+{-# INLINE renderHtmlBuilderWith #-}++-- | Render markup to a lazy Text value. If there are any ByteString's in the+-- input markup, this function will consider them as UTF-8 encoded values and+-- decode them that way.+--+renderMarkup :: Markup -> L.Text+renderMarkup = renderMarkupWith decodeUtf8+{-# INLINE renderMarkup #-}++renderHtml :: Markup -> L.Text+renderHtml = renderMarkup+{-# DEPRECATED renderHtml "Use renderMarkup instead" #-}+{-# INLINE renderHtml #-}++-- | Render markup to a lazy Text value. This function allows you to specify what+-- should happen with ByteString's in the input HTML. You can decode them or+-- drop them, this depends on the application...+--+renderMarkupWith :: (ByteString -> Text)  -- ^ Decoder for ByteString's.+                 -> Markup                -- ^ Markup to render+                 -> L.Text                -- Resulting lazy text+renderMarkupWith d = B.toLazyText . renderMarkupBuilderWith d++renderHtmlWith :: (ByteString -> Text)  -- ^ Decoder for ByteString's.+               -> Markup                -- ^ Markup to render+               -> L.Text                -- ^ Resulting lazy text+renderHtmlWith = renderMarkupWith+{-# DEPRECATED renderHtmlWith "Use renderMarkupWith instead" #-}
+ src/Text/Blaze/Renderer/Utf8.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Blaze.Renderer.Utf8+    ( renderMarkupBuilder+    , renderMarkup+    , renderMarkupToByteStringIO+    , renderHtmlBuilder+    , renderHtml+    , renderHtmlToByteStringIO+    ) where++import Data.Monoid (mappend, mempty)+import Data.List (isInfixOf)++import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T (isInfixOf)+import qualified Data.ByteString as S (ByteString, isInfixOf)++import Text.Blaze.Internal+import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder           as B+import qualified Blaze.ByteString.Builder.Html.Utf8 as B++-- | Render a 'ChoiceString'.+--+fromChoiceString :: ChoiceString  -- ^ String to render+                 -> Builder       -- ^ Resulting builder+fromChoiceString (Static s)     = B.copyByteString $ getUtf8ByteString s+fromChoiceString (String s)     = B.fromHtmlEscapedString s+fromChoiceString (Text s)       = B.fromHtmlEscapedText s+fromChoiceString (ByteString s) = B.fromByteString s+fromChoiceString (PreEscaped x) = case x of+    String s -> B.fromString s+    Text   s -> B.fromText s+    s        -> fromChoiceString s+fromChoiceString (External x) = case x of+    -- Check that the sequence "</" is *not* in the external data.+    String s     -> if "</" `isInfixOf` s then mempty else B.fromString s+    Text   s     -> if "</" `T.isInfixOf` s then mempty else B.fromText s+    ByteString s -> if "</" `S.isInfixOf` s then mempty else B.fromByteString s+    s            -> fromChoiceString s+fromChoiceString (AppendChoiceString x y) =+    fromChoiceString x `mappend` fromChoiceString y+fromChoiceString EmptyChoiceString = mempty+{-# INLINE fromChoiceString #-}++-- | Render some 'Markup' to a 'Builder'.+--+renderMarkupBuilder, renderHtmlBuilder :: Markup     -- ^ Markup to render+                  -> Builder  -- ^ Resulting builder+renderMarkupBuilder = go mempty+  where+    go :: Builder -> MarkupM b -> Builder+    go attrs (Parent _ open close content) =+        B.copyByteString (getUtf8ByteString open)+            `mappend` attrs+            `mappend` B.fromChar '>'+            `mappend` go mempty content+            `mappend` B.copyByteString (getUtf8ByteString close)+    go attrs (Leaf _ begin end) =+        B.copyByteString (getUtf8ByteString begin)+            `mappend` attrs+            `mappend` B.copyByteString (getUtf8ByteString end)+    go attrs (AddAttribute _ key value h) =+        go (B.copyByteString (getUtf8ByteString key)+            `mappend` fromChoiceString value+            `mappend` B.fromChar '"'+            `mappend` attrs) h+    go attrs (AddCustomAttribute _ key value h) =+        go (fromChoiceString key+            `mappend` fromChoiceString value+            `mappend` B.fromChar '"'+            `mappend` attrs) h+    go _ (Content content)  = fromChoiceString content+    go attrs (Append h1 h2) = go attrs h1 `mappend` go attrs h2+    go _ Empty              = mempty+    {-# NOINLINE go #-}+{-# INLINE renderMarkupBuilder #-}++renderHtmlBuilder = renderMarkupBuilder+{-# DEPRECATED renderHtmlBuilder "Use renderMarkupBuilder instead" #-}+{-# INLINE renderHtmlBuilder #-}++-- | Render HTML to a lazy UTF-8 encoded 'L.ByteString.'+--+renderMarkup, renderHtml :: Markup          -- ^ Markup to render+                         -> L.ByteString  -- ^ Resulting 'L.ByteString'+renderMarkup = B.toLazyByteString . renderMarkupBuilder+{-# INLINE renderMarkup #-}++renderHtml = renderMarkup+{-# DEPRECATED renderHtml "Use renderMarkup instead" #-}+{-# INLINE renderHtml #-}+++-- | Repeatedly render HTML to a buffer and process this buffer using the given+-- IO action.+--+renderMarkupToByteStringIO, renderHtmlToByteStringIO :: (S.ByteString -> IO ())+                                                        -- ^ IO action to execute per rendered buffer+                                                     -> Markup          -- ^ Markup to render+                                                     -> IO ()         -- ^ Resulting IO action+renderMarkupToByteStringIO io = B.toByteStringIO io . renderMarkupBuilder+{-# INLINE renderMarkupToByteStringIO #-}++renderHtmlToByteStringIO = renderMarkupToByteStringIO+{-# DEPRECATED renderHtmlToByteStringIO "Use renderMarkupToByteStringIO instead" #-}+{-# INLINE renderHtmlToByteStringIO #-}
+ tests/TestSuite.hs view
@@ -0,0 +1,12 @@+-- | Main module to run all tests.+--+module Main where++import Test.Framework (defaultMain, testGroup)++import qualified Text.Blaze.Tests++main :: IO ()+main = defaultMain+    [ testGroup "Text.Blaze.Tests" Text.Blaze.Tests.tests+    ]
+ tests/Text/Blaze/Tests.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Text.Blaze.Tests+    ( tests+    ) where++import Prelude hiding (div, id)+import Data.Monoid (mempty)+import Control.Monad (replicateM)+import Control.Applicative ((<$>))+import Data.Word (Word8)+import Data.Char (ord)+import Data.List (isInfixOf)++import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy.Char8 as LBC+import qualified Data.ByteString.Lazy as LB+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++import Text.Blaze.Internal+import Text.Blaze.Tests.Util++tests :: [Test]+tests = [ testProperty "left identity Monoid law"  monoidLeftIdentity+        , testProperty "right identity Monoid law" monoidRightIdentity+        , testProperty "associativity Monoid law"  monoidAssociativity+        , testProperty "mconcat Monoid law"        monoidConcat+        , testProperty "post escaping characters"  postEscapingCharacters+        , testProperty "valid UTF-8"               isValidUtf8+        , testProperty "external </ sequence"      externalEndSequence+        , testProperty "well nested <>"            wellNestedBrackets+        , testProperty "unsafeByteString id"       unsafeByteStringId+        ]++-- | The left identity Monoid law.+--+monoidLeftIdentity :: Markup -> Bool+monoidLeftIdentity h = (return () >> h) == h++-- | The right identity Monoid law.+--+monoidRightIdentity :: Markup -> Bool+monoidRightIdentity h = (h >> return ()) == h++-- | The associativity Monoid law.+--+monoidAssociativity :: Markup -> Markup -> Markup -> Bool+monoidAssociativity x y z = (x >> (y >> z)) == ((x >> y) >> z)++-- | Concatenation Monoid law.+--+monoidConcat :: [Markup] -> Bool+monoidConcat xs = sequence_ xs == foldr (>>) (return ()) xs++-- | Escaped content cannot contain certain characters.+--+postEscapingCharacters :: String -> Bool+postEscapingCharacters str =+    LB.all (`notElem` forbidden) $ renderUsingUtf8 (string str)+  where+    forbidden = map (fromIntegral . ord) "\"'<>"++-- | Check if the produced bytes are valid UTF-8+--+isValidUtf8 :: Markup -> Bool+isValidUtf8 = isValidUtf8' . LB.unpack . renderUsingUtf8+  where+    isIn x y z = (x <= z) && (z <= y)+    isValidUtf8' :: [Word8] -> Bool+    isValidUtf8' [] = True+    isValidUtf8' (x:t)+        -- One byte+        | isIn 0x00 0x7f x = isValidUtf8' t+        -- Two bytes+        | isIn 0xc0 0xdf x = case t of+            (y:t') -> isIn 0x80 0xbf y && isValidUtf8' t'+            _      -> False+        -- Three bytes+        | isIn 0xe0 0xef x = case t of+            (y:z:t') -> all (isIn 0x80 0xbf) [y, z] && isValidUtf8' t'+            _        -> False+        -- Four bytes+        | isIn 0xf0 0xf7 x = case t of+            (y:z:u:t') -> all (isIn 0x80 0xbf) [y, z, u] && isValidUtf8' t'+            _          -> False+        | otherwise = False++-- | Rendering an unsafe bytestring should not do anything+--+unsafeByteStringId :: [Word8] -> Bool+unsafeByteStringId ws =+    LB.pack ws == renderUsingUtf8 (unsafeByteString $ SB.pack ws)++-- | Check if the "</" sequence does not appear in @<script>@ or @<style>@ tags.+--+externalEndSequence :: String -> Bool+externalEndSequence = not . isInfixOf "</" . LBC.unpack+                    . renderUsingUtf8 . external . string++-- | Check that the "<>" characters are well-nested.+--+wellNestedBrackets :: Markup -> Bool+wellNestedBrackets = wellNested False . LBC.unpack . renderUsingUtf8+  where+    wellNested isOpen [] = not isOpen+    wellNested isOpen (x:xs) = case x of+        '<' -> if isOpen then False else wellNested True xs+        '>' -> if isOpen then wellNested False xs else False+        _   -> wellNested isOpen xs++-- Show instance for the HTML type, so we can debug.+--+instance Show Markup where+    show = show . renderUsingUtf8++-- Eq instance for the HTML type, so we can compare the results.+--+instance Eq Markup where+    x == y =  renderUsingString x == renderUsingString y+           && renderUsingText x   == renderUsingText y+           && renderUsingUtf8 x   == renderUsingUtf8 y+           -- Some cross-checks+           && renderUsingString x == renderUsingText y+           && renderUsingText x   == renderUsingUtf8 y++-- Arbitrary instance for the HTML type.+--+instance Arbitrary Markup where+    arbitrary = arbitraryMarkup 4++-- | Auxiliary function for the arbitrary instance of the HTML type, used+-- to limit the depth and size of the type.+--+arbitraryMarkup :: Int       -- ^ Maximum depth.+              -> Gen Markup  -- ^ Resulting arbitrary HTML snippet.+arbitraryMarkup depth = do +    -- Choose the size (width) of this element.+    size <- choose (0, 3)++    -- Generate `size` new HTML snippets.+    children <- replicateM size arbitraryChild++    -- Return a concatenation of these children.+    return $ sequence_ children+  where+    -- Generate an arbitrary child. Do not take a parent when we have no depth+    -- left, obviously.+    arbitraryChild = do+        child <- oneof $  [arbitraryLeaf, arbitraryString, return mempty]+                       ++ [arbitraryParent | depth > 0]++        -- Generate some attributes for the child.+        size <- choose (0, 4)+        attributes <- replicateM size arbitraryAttribute+        return $ foldl (!) child attributes++    -- Generate an arbitrary parent element.+    arbitraryParent = do+        parent <- elements [p, div, table]+        parent <$> arbitraryMarkup (depth - 1)++    -- Generate an arbitrary leaf element.+    arbitraryLeaf = oneof $ map return [img, br, area]++    -- Generate arbitrary string element.+    arbitraryString = do+        s <- arbitrary+        return $ string s++    -- Generate an arbitrary HTML attribute.+    arbitraryAttribute = do+        attr <- elements [id, class_, name]+        value <- arbitrary+        return $ attr $ stringValue value
+ tests/Text/Blaze/Tests/Util.hs view
@@ -0,0 +1,71 @@+-- | Utility functions for the blaze tests+--+{-# LANGUAGE OverloadedStrings #-}+module Text.Blaze.Tests.Util+    ( renderUsingString+    , renderUsingText+    , renderUsingUtf8+	, p, div, table, img, br, area+	, id, class_, name+    ) where++import Prelude hiding (div, id)+import Text.Blaze.Internal++import Blaze.ByteString.Builder as B (toLazyByteString)+import Blaze.ByteString.Builder.Char.Utf8 as B (fromString)+import Data.Text.Lazy.Encoding (encodeUtf8)+import qualified Data.ByteString.Lazy as LB+import qualified Text.Blaze.Renderer.String as String (renderMarkup)+import qualified Text.Blaze.Renderer.Text as Text (renderMarkup)+import qualified Text.Blaze.Renderer.Utf8 as Utf8 (renderMarkup)++-- | Render Markup to an UTF-8 encoded ByteString using the String renderer+--+renderUsingString :: Markup -> LB.ByteString+renderUsingString = toLazyByteString . fromString . String.renderMarkup++-- | Render Markup to an UTF-8 encoded ByteString using the Text renderer+--+renderUsingText :: Markup -> LB.ByteString+renderUsingText = encodeUtf8 . Text.renderMarkup++-- | Render HTML to an UTF-8 encoded ByteString using the Utf8 renderer+--+renderUsingUtf8 :: Markup -> LB.ByteString+renderUsingUtf8 = Utf8.renderMarkup++-- Some definitions for HTML combinators to enable testing++p :: Markup   -- ^ Inner HTML.+  -> Markup   -- ^ Resulting HTML.+p = Parent "p" "<p" "</p>"++div :: Markup   -- ^ Inner HTML.+    -> Markup   -- ^ Resulting HTML.+div = Parent "div" "<div" "</div>"++table :: Markup   -- ^ Inner HTML.+      -> Markup   -- ^ Resulting HTML.+table = Parent "table" "<table" "</table>"++img :: Markup   -- ^ Resulting HTML.+img = Leaf "img" "<img" ">"++br :: Markup   -- ^ Resulting HTML.+br = Leaf "br" "<br" ">"++area :: Markup   -- ^ Resulting HTML.+area = Leaf "area" "<area" ">"++class_ :: AttributeValue  -- ^ Attribute value.+       -> Attribute       -- ^ Resulting attribute.+class_ = attribute "class" " class=\""++id :: AttributeValue  -- ^ Attribute value.+   -> Attribute       -- ^ Resulting attribute.+id = attribute "id" " id=\""++name :: AttributeValue  -- ^ Attribute value.+     -> Attribute       -- ^ Resulting attribute.+name = attribute "name" " name=\""