Skip to content
Browse files

Migrating to blaze-markup

  • Loading branch information...
1 parent 3d1c66b commit c1ed30850488691d9b600a6768edc798bb87bdbb @deepakjois deepakjois committed Mar 31, 2012
View
10 blaze-html.cabal
@@ -1,5 +1,5 @@
Name: blaze-html
-Version: 0.4.3.3
+Version: 0.4.4.0
Homepage: http://jaspervdj.be/blaze
Bug-Reports: http://github.com/jaspervdj/blaze-html/issues
License: BSD3
@@ -27,7 +27,7 @@ Library
Ghc-Options: -Wall
Exposed-modules:
- Text.Blaze
+ Text.Blaze.Html
Text.Blaze.Html4.FrameSet
Text.Blaze.Html4.FrameSet.Attributes
Text.Blaze.Html4.Strict
@@ -36,11 +36,6 @@ Library
Text.Blaze.Html4.Transitional.Attributes
Text.Blaze.Html5
Text.Blaze.Html5.Attributes
- Text.Blaze.Internal
- Text.Blaze.Renderer.Pretty
- Text.Blaze.Renderer.String
- Text.Blaze.Renderer.Text
- Text.Blaze.Renderer.Utf8
Text.Blaze.XHtml1.FrameSet
Text.Blaze.XHtml1.FrameSet.Attributes
Text.Blaze.XHtml1.Strict
@@ -51,6 +46,7 @@ Library
Build-depends:
base >= 4 && < 5,
blaze-builder >= 0.2 && < 0.4,
+ blaze-markup >= 0.1 && < 0.2,
text >= 0.10 && < 0.12,
bytestring >= 0.9 && < 0.10
View
179 src/Text/Blaze.hs
@@ -1,179 +0,0 @@
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
--- | BlazeHtml is an HTML combinator library. It provides a way to embed HTML in
--- Haskell in an efficient and convenient way, with a light-weight syntax.
---
--- To use the library, one needs to import a set of HTML combinators. For
--- example, you can use HTML 4 Strict.
---
--- > {-# 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 (renderHtml)
---
--- Now, you can describe pages using the imported combinators.
---
--- > page1 :: Html
--- > 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 BlazeHtml syntax."
--- > ul $ mapM_ (li . toHtml . show) [1, 2, 3]
---
--- The resulting HTML can now be extracted using:
---
--- > renderHtml page1
---
-module Text.Blaze
- (
- -- * Important types.
- Html
- , Tag
- , Attribute
- , AttributeValue
-
- -- * Creating attributes.
- , dataAttribute
- , customAttribute
-
- -- * Converting values to HTML.
- , ToHtml (..)
- , text
- , preEscapedText
- , lazyText
- , preEscapedLazyText
- , string
- , preEscapedString
- , unsafeByteString
- , unsafeLazyByteString
-
- -- * Creating tags.
- , textTag
- , stringTag
-
- -- * Converting values to attribute values.
- , ToValue (..)
- , textValue
- , preEscapedTextValue
- , lazyTextValue
- , preEscapedLazyTextValue
- , stringValue
- , 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 HTML values
---
-class ToHtml a where
- -- | Convert a value to HTML.
- --
- toHtml :: a -> Html
-
-instance ToHtml Html where
- toHtml = id
- {-# INLINE toHtml #-}
-
-instance ToHtml [Html] where
- toHtml = mconcat
- {-# INLINE toHtml #-}
-
-instance ToHtml Text where
- toHtml = text
- {-# INLINE toHtml #-}
-
-instance ToHtml LT.Text where
- toHtml = lazyText
- {-# INLINE toHtml #-}
-
-instance ToHtml String where
- toHtml = string
- {-# INLINE toHtml #-}
-
-instance ToHtml Int where
- toHtml = string . show
- {-# INLINE toHtml #-}
-
-instance ToHtml Char where
- toHtml = string . return
- {-# INLINE toHtml #-}
-
-instance ToHtml Bool where
- toHtml = string . show
- {-# INLINE toHtml #-}
-
-instance ToHtml Integer where
- toHtml = string . show
- {-# INLINE toHtml #-}
-
-instance ToHtml Float where
- toHtml = string . show
- {-# INLINE toHtml #-}
-
-instance ToHtml Double where
- toHtml = string . show
- {-# INLINE toHtml #-}
-
--- | Class allowing us to use a single function for attribute values
---
-class ToValue a where
- -- | Convert a value to an HTML 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 #-}
View
9 src/Text/Blaze/Html.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE NoMonomorphismRestriction, RankNTypes #-}
+module Text.Blaze.Html where
+
+import Text.Blaze
+
+type Html = Markup
+
+toHtml :: forall a. ToMarkup a => a -> Markup
+toHtml = toMarkup
View
419 src/Text/Blaze/Internal.hs
@@ -1,419 +0,0 @@
-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, Rank2Types,
- FlexibleInstances, ExistentialQuantification, DeriveDataTypeable #-}
--- | The BlazeHtml core, consisting of functions that offer the power to
--- generate custom HTML 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 (..)
- , HtmlM (..)
- , Html
- , 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 HTML datatype.
---
-data HtmlM a
- -- | Tag, open tag, end tag, content
- = forall b. Parent StaticString StaticString StaticString (HtmlM b)
- -- | Tag, open tag, end tag
- | Leaf StaticString StaticString StaticString
- -- | HTML content
- | Content ChoiceString
- -- | Concatenation of two HTML pieces
- | forall b c. Append (HtmlM b) (HtmlM c)
- -- | Add an attribute to the inner HTML. Raw key, key, value, HTML to
- -- receive the attribute.
- | AddAttribute StaticString StaticString ChoiceString (HtmlM a)
- -- | Add a custom attribute to the inner HTML.
- | AddCustomAttribute ChoiceString ChoiceString ChoiceString (HtmlM a)
- -- | Empty HTML.
- | Empty
- deriving (Typeable)
-
--- | Simplification of the 'HtmlM' datatype.
---
-type Html = HtmlM ()
-
-instance Monoid a => Monoid (HtmlM a) where
- mempty = Empty
- {-# INLINE mempty #-}
- mappend x y = Append x y
- {-# INLINE mappend #-}
- mconcat = foldr Append Empty
- {-# INLINE mconcat #-}
-
-instance Functor HtmlM where
- -- Safe because it does not contain a value anyway
- fmap _ = unsafeCoerce
-
-instance Monad HtmlM where
- return _ = Empty
- {-# INLINE return #-}
- (>>) = Append
- {-# INLINE (>>) #-}
- h1 >>= f = h1 >> f
- (error "Text.Blaze.Internal.HtmlM: invalid use of monadic bind")
- {-# INLINE (>>=) #-}
-
-instance IsString (HtmlM a) where
- fromString = Content . fromString
- {-# INLINE fromString #-}
-
--- | Type for an HTML tag. This can be seen as an internal string type used by
--- BlazeHtml.
---
-newtype Tag = Tag { unTag :: StaticString }
- deriving (IsString)
-
--- | Type for an attribute.
---
-newtype Attribute = Attribute (forall a. HtmlM a -> HtmlM 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 BlazeHtml using this funcion. The above fragment could
--- be described using BlazeHtml 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.
- -> Html -- ^ Resulting HTML fragment.
-text = Content . Text
-{-# DEPRECATED text "Use Blaze.Html.toHtml" #-}
-{-# INLINE text #-}
-
--- | Render text without escaping.
---
-preEscapedText :: Text -- ^ Text to insert
- -> Html -- ^ Resulting HTML fragment
-preEscapedText = Content . PreEscaped . Text
-{-# INLINE preEscapedText #-}
-
--- | A variant of 'text' for lazy 'LT.Text'.
---
-lazyText :: LT.Text -- ^ Text to insert
- -> Html -- ^ Resulting HTML fragment
-lazyText = mconcat . map text . LT.toChunks
-{-# DEPRECATED lazyText "Use Blaze.Html.toHtml" #-}
-{-# INLINE lazyText #-}
-
--- | A variant of 'preEscapedText' for lazy 'LT.Text'
---
-preEscapedLazyText :: LT.Text -- ^ Text to insert
- -> Html -- ^ Resulting HTML fragment
-preEscapedLazyText = mconcat . map preEscapedText . LT.toChunks
-
--- | Create an HTML snippet from a 'String'.
---
-string :: String -- ^ String to insert.
- -> Html -- ^ Resulting HTML fragment.
-string = Content . String
-{-# DEPRECATED string "Use Blaze.Html.toHtml" #-}
-{-# INLINE string #-}
-
--- | Create an HTML snippet from a 'String' without escaping
---
-preEscapedString :: String -- ^ String to insert.
- -> Html -- ^ 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.
- -> Html -- ^ 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
- -> Html -- ^ 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
-{-# DEPRECATED textValue "Use Blaze.Html.toValue" #-}
-{-# 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
-{-# DEPRECATED lazyTextValue "Use Blaze.Html.toValue" #-}
-{-# 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
-{-# DEPRECATED stringValue "Use Blaze.Html.toValue" #-}
-{-# 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 (HtmlM a) where
- h ! (Attribute f) = f h
- {-# INLINE (!) #-}
-
-instance Attributable (HtmlM a -> HtmlM 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 :: HtmlM a -> HtmlM 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 #-}
View
44 src/Text/Blaze/Renderer/Pretty.hs
@@ -1,44 +0,0 @@
--- | A renderer that produces pretty HTML, mostly meant for debugging purposes.
---
-module Text.Blaze.Renderer.Pretty
- ( renderHtml
- ) where
-
-import Text.Blaze.Internal
-import Text.Blaze.Renderer.String (fromChoiceString)
-
--- | Render some 'Html' to an appending 'String'.
---
-renderString :: Html -- ^ HTML to render
- -> String -- ^ String to append
- -> String -- ^ Resulting String
-renderString = go 0 id
- where
- go :: Int -> (String -> String) -> HtmlM 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 HTML to a lazy 'String'. The result is prettified.
---
-renderHtml :: Html -- ^ HTML to render
- -> String -- ^ Resulting 'String'.
-renderHtml html = renderString html ""
-{-# INLINE renderHtml #-}
View
82 src/Text/Blaze/Renderer/String.hs
@@ -1,82 +0,0 @@
--- | A renderer that produces a native Haskell 'String', mostly meant for
--- debugging purposes.
---
-{-# LANGUAGE OverloadedStrings #-}
-module Text.Blaze.Renderer.String
- ( fromChoiceString
- , 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 HTML entities in a string
---
-escapeHtmlEntities :: String -- ^ String to escape
- -> String -- ^ String to append
- -> String -- ^ Resulting string
-escapeHtmlEntities [] k = k
-escapeHtmlEntities (c:cs) k = case c of
- '<' -> '&' : 'l' : 't' : ';' : escapeHtmlEntities cs k
- '>' -> '&' : 'g' : 't' : ';' : escapeHtmlEntities cs k
- '&' -> '&' : 'a' : 'm' : 'p' : ';' : escapeHtmlEntities cs k
- '"' -> '&' : 'q' : 'u' : 'o' : 't' : ';' : escapeHtmlEntities cs k
- '\'' -> '&' : '#' : '3' : '9' : ';' : escapeHtmlEntities cs k
- x -> x : escapeHtmlEntities 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) = escapeHtmlEntities s
-fromChoiceString (Text s) = escapeHtmlEntities $ 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 'Html' to an appending 'String'.
---
-renderString :: Html -- ^ HTML to render
- -> String -- ^ String to append
- -> String -- ^ Resulting String
-renderString = go id
- where
- go :: (String -> String) -> HtmlM 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 HTML to a lazy 'String'.
---
-renderHtml :: Html -- ^ HTML to render
- -> String -- ^ Resulting 'String'
-renderHtml html = renderString html ""
-{-# INLINE renderHtml #-}
View
120 src/Text/Blaze/Renderer/Text.hs
@@ -1,120 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
--- | A renderer that produces a lazy 'L.Text' value, using the Text Builder.
---
-module Text.Blaze.Renderer.Text
- ( 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 HTML entities in a text value
---
-escapeHtmlEntities :: Text -- ^ Text to escape
- -> Builder -- ^ Resulting text builder
-escapeHtmlEntities = 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) = escapeHtmlEntities $ T.pack s
-fromChoiceString _ (Text s) = escapeHtmlEntities 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 HTML to a text builder
-renderHtmlBuilder :: Html
- -> Builder
-renderHtmlBuilder = renderHtmlBuilderWith decodeUtf8
-{-# INLINE renderHtmlBuilder #-}
-
--- | Render some 'Html' to a Text 'Builder'.
---
-renderHtmlBuilderWith :: (ByteString -> Text) -- ^ Decoder for bytestrings
- -> Html -- ^ HTML to render
- -> Builder -- ^ Resulting builder
-renderHtmlBuilderWith d = go mempty
- where
- go :: Builder -> HtmlM 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 renderHtmlBuilderWith #-}
-
--- | Render HTML to a lazy Text value. If there are any ByteString's in the
--- input HTML, this function will consider them as UTF-8 encoded values and
--- decode them that way.
---
-renderHtml :: Html -- ^ HTML to render
- -> L.Text -- ^ Resulting 'L.Text'
-renderHtml = renderHtmlWith decodeUtf8
-{-# INLINE renderHtml #-}
-
--- | Render HTML 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...
---
-renderHtmlWith :: (ByteString -> Text) -- ^ Decoder for ByteString's.
- -> Html -- ^ HTML to render
- -> L.Text -- Resulting lazy text
-renderHtmlWith d = B.toLazyText . renderHtmlBuilderWith d
View
91 src/Text/Blaze/Renderer/Utf8.hs
@@ -1,91 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Text.Blaze.Renderer.Utf8
- ( 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 'Html' to a 'Builder'.
---
-renderHtmlBuilder :: Html -- ^ HTML to render
- -> Builder -- ^ Resulting builder
-renderHtmlBuilder = go mempty
- where
- go :: Builder -> HtmlM 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 renderHtmlBuilder #-}
-
--- | Render HTML to a lazy UTF-8 encoded 'L.ByteString.'
---
-renderHtml :: Html -- ^ HTML to render
- -> L.ByteString -- ^ Resulting 'L.ByteString'
-renderHtml = B.toLazyByteString . renderHtmlBuilder
-{-# INLINE renderHtml #-}
-
--- | Repeatedly render HTML to a buffer and process this buffer using the given
--- IO action.
---
-renderHtmlToByteStringIO :: (S.ByteString -> IO ())
- -- ^ IO action to execute per rendered buffer
- -> Html -- ^ HTML to render
- -> IO () -- ^ Resulting IO action
-renderHtmlToByteStringIO io = B.toByteStringIO io . renderHtmlBuilder
-{-# INLINE renderHtmlToByteStringIO #-}
View
2 src/Util/GenerateHtmlCombinators.hs
@@ -71,6 +71,7 @@ writeHtmlVariant htmlVariant = do
, "-- | This module exports HTML combinators used to create documents."
, "--"
, exportList modulName $ "module Text.Blaze"
+ : "module Text.Blaze.Html"
: "docType"
: "docTypeHtml"
: map (sanitize . fst) sortedTags
@@ -79,6 +80,7 @@ writeHtmlVariant htmlVariant = do
, ""
, "import Text.Blaze"
, "import Text.Blaze.Internal"
+ , "import Text.Blaze.Html"
, ""
, makeDocType $ docType htmlVariant
, makeDocTypeHtml $ docType htmlVariant
View
4 tests/TestSuite.hs
@@ -4,13 +4,11 @@ module Main where
import Test.Framework (defaultMain, testGroup)
-import qualified Text.Blaze.Tests
import qualified Text.Blaze.Tests.Cases
import qualified Util.Tests
main :: IO ()
main = defaultMain
- [ testGroup "Text.Blaze.Tests" Text.Blaze.Tests.tests
- , testGroup "Text.Blaze.Tests.Cases" Text.Blaze.Tests.Cases.tests
+ [ testGroup "Text.Blaze.Tests.Cases" Text.Blaze.Tests.Cases.tests
, testGroup "Util.Tests" Util.Tests.tests
]
View
178 tests/Text/Blaze/Tests.hs
@@ -1,178 +0,0 @@
-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
-{-# 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.Html5 hiding (map)
-import Text.Blaze.Html5.Attributes (id, class_, name)
-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 :: Html -> Bool
-monoidLeftIdentity h = (return () >> h) == h
-
--- | The right identity Monoid law.
---
-monoidRightIdentity :: Html -> Bool
-monoidRightIdentity h = (h >> return ()) == h
-
--- | The associativity Monoid law.
---
-monoidAssociativity :: Html -> Html -> Html -> Bool
-monoidAssociativity x y z = (x >> (y >> z)) == ((x >> y) >> z)
-
--- | Concatenation Monoid law.
---
-monoidConcat :: [Html] -> 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 :: Html -> 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 :: Html -> 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 Html where
- show = show . renderUsingUtf8
-
--- Eq instance for the HTML type, so we can compare the results.
---
-instance Eq Html 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 Html where
- arbitrary = arbitraryHtml 4
-
--- | Auxiliary function for the arbitrary instance of the HTML type, used
--- to limit the depth and size of the type.
---
-arbitraryHtml :: Int -- ^ Maximum depth.
- -> Gen Html -- ^ Resulting arbitrary HTML snippet.
-arbitraryHtml 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 <$> arbitraryHtml (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

0 comments on commit c1ed308

Please sign in to comment.
Something went wrong with that request. Please try again.