Switch to Builder and Text

ChangeLog.md

@@ -1,3 +1,9 @@
+## 3000.3.0.0
+
+- The internal representation has changed from `String` and `[String]` to a
+  `Data.ByteString.Builder` and difference lists.
+  [#19](https://github.com/haskell/xhtml/pull/19)
+
 ## 3000.2.2.1
 
 - Special release which supports *only* `base >= 4.11`

Text/XHtml/Debug.hs

@@ -1,5 +1,7 @@
 {-# OPTIONS_HADDOCK hide #-}
 
+{-# language OverloadedStrings #-}
+
 -- | This module contains functions for displaying
 --   HTML as a pretty tree.
 module Text.XHtml.Debug ( HtmlTree(..), treeHtml, treeColors, debugHtml ) where
@@ -9,6 +11,7 @@ import Text.XHtml.Extras
 import Text.XHtml.Table
 import Text.XHtml.Strict.Elements
 import Text.XHtml.Strict.Attributes
+import qualified Data.Text.Lazy as LText
 
 import Data.List (uncons)
 
@@ -23,92 +26,89 @@ data HtmlTree
       = HtmlLeaf Html
       | HtmlNode Html [HtmlTree] Html
 
-treeHtml :: [String] -> HtmlTree -> Html
-treeHtml colors h = table ! [
-                    border 0,
-                    cellpadding 0,
-                    cellspacing 2] << treeHtml' colors h
-     where
-      manycolors = scanr (:) []
-
-      treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
-      treeHtmls c ts = aboves (zipWith treeHtml' c ts)
-
-      treeHtml' :: [String] -> HtmlTree -> HtmlTable
-      treeHtml' _ (HtmlLeaf leaf) = cell
-                                         (td ! [width "100%"] 
-                                            << bold  
-                                               << leaf)
-      treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
-          if null ts && isNoHtml hclose
-          then
-              cell hd 
-          else if null ts
-          then
-              hd </> bar `beside` (td ! [bgcolor' c2] << spaceHtml)
-                 </> tl
-          else
-              hd </> (bar `beside` treeHtmls morecolors ts)
-                 </> tl
-        where
-              -- This stops a column of colors being the same
-              -- color as the immediately outside nesting bar.
-              morecolors = filter (maybe True ((/= c) . fst) . uncons) (manycolors cs)
-              bar = td ! [bgcolor' c,width "10"] << spaceHtml
-              hd = td ! [bgcolor' c] << hopen
-              tl = td ! [bgcolor' c] << hclose
-      treeHtml' _ _ = error "The imposible happens"
+treeHtml :: [LText.Text] -> HtmlTree -> Html
+treeHtml colors h =
+    table !
+      [ border 0,
+        cellpadding 0,
+        cellspacing 2
+      ]
+      << treeHtml' colors h
+  where
+    manycolors = scanr (:) []
+
+    treeHtmls :: [[LText.Text]] -> [HtmlTree] -> HtmlTable
+    treeHtmls c ts = aboves (zipWith treeHtml' c ts)
+
+    treeHtml' :: [LText.Text] -> HtmlTree -> HtmlTable
+    treeHtml' _ (HtmlLeaf leaf) = cell
+                                        (td ! [width "100%"]
+                                          << bold
+                                              << leaf)
+    treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose)
+        | null ts && isNoHtml hclose = cell hd
+        | null ts = hd </> bar `beside` (td ! [bgcolor' c2] << spaceHtml) </> tl
+        | otherwise = hd </> (bar `beside` treeHtmls morecolors ts) </> tl
+      where
+        -- This stops a column of colors being the same
+        -- color as the immediately outside nesting bar.
+        morecolors = filter (maybe True ((/= c) . fst) . uncons) (manycolors cs)
+        bar = td ! [bgcolor' c,width "10"] << spaceHtml
+        hd = td ! [bgcolor' c] << hopen
+        tl = td ! [bgcolor' c] << hclose
+    treeHtml' _ _ = error "The imposible happens"
 
 instance HTML HtmlTree where
-      toHtml x = treeHtml treeColors x
+      toHtml = treeHtml treeColors
 
 -- type "length treeColors" to see how many colors are here.
-treeColors :: [String]
+treeColors :: [LText.Text]
 treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
 
 
--- 
+--
 -- * Html Debugging Combinators
 --
 
 -- | This uses the above tree rendering function, and displays the
 -- Html as a tree structure, allowing debugging of what is
 -- actually getting produced.
 debugHtml :: (HTML a) => a -> Html
-debugHtml obj = table ! [border 0] << 
+debugHtml obj = table ! [border 0] <<
                   ( th ! [bgcolor' "#008888"]
                      << underline'
-                       << "Debugging Output"
-               </>  td << (toHtml (debug' (toHtml obj)))
+                       << ("Debugging Output" :: String)
+               </>  td << toHtml (debug' (toHtml obj))
               )
   where
 
       debug' :: Html -> [HtmlTree]
-      debug' (Html markups) = map debug markups
+      debug' (Html markups) = map debug (markups [])
 
       debug :: HtmlElement -> HtmlTree
       debug (HtmlString str) = HtmlLeaf (spaceHtml +++
-                                              linesToHtml (lines str))
+                                              linesToHtml (lines (builderToString str)))
       debug (HtmlTag {
               markupTag = tag',
               markupContent = content',
-              markupAttrs  = attrs
+              markupAttrs  = mkAttrs
               }) =
-              case content' of
-                Html [] -> HtmlNode hd [] noHtml
-                Html xs -> HtmlNode hd (map debug xs) tl
+              if isNoHtml content'
+                then HtmlNode hd [] noHtml
+                else HtmlNode hd (map debug (getHtmlElements content')) tl
         where
+              attrs = mkAttrs []
               args = if null attrs
                      then ""
-                     else "  " ++ unwords (map show attrs)
-              hd = xsmallFont << ("<" ++ tag' ++ args ++ ">")
-              tl = xsmallFont << ("</" ++ tag' ++ ">")
+                     else "  " <> unwords (map show attrs)
+              hd = xsmallFont << ("<" <> builderToString tag' <> args <> ">")
+              tl = xsmallFont << ("</" <> builderToString tag' <> ">")
 
-bgcolor' :: String -> HtmlAttr
-bgcolor' c = thestyle ("background-color:" ++ c)
+bgcolor' :: LText.Text -> HtmlAttr
+bgcolor' c = thestyle ("background-color:" <> c)
 
 underline' :: Html -> Html
-underline' = thespan ! [thestyle ("text-decoration:underline")]
+underline' = thespan ! [thestyle "text-decoration:underline"]
 
 xsmallFont :: Html -> Html
-xsmallFont  = thespan ! [thestyle ("font-size:x-small")]
+xsmallFont  = thespan ! [thestyle "font-size:x-small"]

Text/XHtml/Extras.hs

@@ -1,5 +1,9 @@
+{-# language OverloadedStrings #-}
+
 module Text.XHtml.Extras where
 
+import qualified Data.Text.Lazy as LText
+
 import Text.XHtml.Internals
 import Text.XHtml.Strict.Elements
 import Text.XHtml.Strict.Attributes
@@ -11,22 +15,29 @@ import Text.XHtml.Strict.Attributes
 -- | Convert a 'String' to 'Html', converting
 --   characters that need to be escaped to HTML entities.
 stringToHtml :: String -> Html
-stringToHtml = primHtml . stringToHtmlString 
+stringToHtml = primHtml . builderToString . stringToHtmlString
+
+{-# INLINE stringToHtml #-}
 
 -- | This converts a string, but keeps spaces as non-line-breakable.
 lineToHtml :: String -> Html
-lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString 
-   where 
-      htmlizeChar2 ' ' = " "
-      htmlizeChar2 c   = [c]
+lineToHtml =
+    primHtmlNonEmptyBuilder . stringToHtmlString . foldMap htmlizeChar2
+  where
+    htmlizeChar2 ' ' = " "
+    htmlizeChar2 c   = [c]
+
+{-# INLINE lineToHtml #-}
 
 -- | This converts a string, but keeps spaces as non-line-breakable,
 --   and adds line breaks between each of the strings in the input list.
 linesToHtml :: [String] -> Html
 linesToHtml []     = noHtml
-linesToHtml (x:[]) = lineToHtml x
+linesToHtml [x]    = lineToHtml x
 linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs
 
+{-# INLINE linesToHtml #-}
+
 --
 -- * Html abbreviations
 --
@@ -41,10 +52,10 @@ spaceHtml     :: Html
 bullet        :: Html
 
 
-primHtmlChar  = \ x -> primHtml ("&" ++ x ++ ";")
-copyright     = primHtmlChar "copy"
-spaceHtml     = primHtmlChar "nbsp"
-bullet        = primHtmlChar "#149"
+primHtmlChar x = primHtml ("&" ++ x ++ ";")
+copyright      = primHtmlChar "copy"
+spaceHtml      = primHtmlChar "nbsp"
+bullet         = primHtmlChar "#149"
 
 -- | Same as 'paragraph'.
 p :: Html -> Html
@@ -54,7 +65,7 @@ p =  paragraph
 -- * Hotlinks
 --
 
-type URL = String
+type URL = LText.Text
 
 data HotLink = HotLink {
       hotLinkURL        :: URL,
@@ -76,7 +87,7 @@ hotlink url h = HotLink {
       hotLinkAttributes = [] }
 
 
--- 
+--
 -- * Lists
 --
 
@@ -96,19 +107,19 @@ defList items
 -- * Forms
 --
 
-widget :: String -> String -> [HtmlAttr] -> Html
+widget :: LText.Text -> LText.Text -> [HtmlAttr] -> Html
 widget w n attrs = input ! ([thetype w] ++ ns ++ attrs)
-  where ns = if null n then [] else [name n,identifier n]
-
-checkbox :: String -> String -> Html
-hidden   :: String -> String -> Html
-radio    :: String -> String -> Html
-reset    :: String -> String -> Html
-submit   :: String -> String -> Html
-password :: String           -> Html
-textfield :: String          -> Html
-afile    :: String           -> Html
-clickmap :: String           -> Html
+  where ns = if LText.null n then [] else [name n,identifier n]
+
+checkbox :: LText.Text -> LText.Text -> Html
+hidden   :: LText.Text -> LText.Text -> Html
+radio    :: LText.Text -> LText.Text -> Html
+reset    :: LText.Text -> LText.Text -> Html
+submit   :: LText.Text -> LText.Text -> Html
+password :: LText.Text           -> Html
+textfield :: LText.Text          -> Html
+afile    :: LText.Text           -> Html
+clickmap :: LText.Text           -> Html
 
 checkbox n v = widget "checkbox" n [value v]
 hidden   n v = widget "hidden"   n [value v]
@@ -121,9 +132,9 @@ afile    n   = widget "file"     n []
 clickmap n   = widget "image"    n []
 
 {-# DEPRECATED menu "menu generates strange XHTML, and is not flexible enough. Roll your own that suits your needs." #-}
-menu :: String -> [Html] -> Html
+menu :: LText.Text -> [Html] -> Html
 menu n choices
    = select ! [name n] << [ option << p << choice | choice <- choices ]
 
-gui :: String -> Html -> Html
+gui :: LText.Text -> Html -> Html
 gui act = form ! [action act,method "post"]

Text/XHtml/Frameset.hs

@@ -1,16 +1,18 @@
+{-# language OverloadedStrings #-}
+
 -- | Produces XHTML 1.0 Frameset.
 module Text.XHtml.Frameset (
      -- * Data types
      Html, HtmlAttr,
      -- * Classes
      HTML(..), ADDATTRS(..), CHANGEATTRS(..),
      -- * Primitives and basic combinators
-     (<<), concatHtml, (+++), 
+     (<<), concatHtml, (+++),
      noHtml, isNoHtml, tag, itag,
      htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr,
-     primHtml, 
+     primHtml,
      -- * Rendering
-     showHtml, renderHtml, prettyHtml, 
+     showHtml, renderHtml, prettyHtml,
      showHtmlFragment, renderHtmlFragment, prettyHtmlFragment,
      module Text.XHtml.Strict.Elements,
      module Text.XHtml.Frameset.Elements,
@@ -28,26 +30,26 @@ import Text.XHtml.Frameset.Attributes
 
 import Text.XHtml.Extras
 
-docType :: String
+docType :: Builder
 docType =
-      "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\"" ++
+      "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\"" <>
      " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
 
 -- | Output the HTML without adding newlines or spaces within the markup.
 --   This should be the most time and space efficient way to
 --   render HTML, though the output is quite unreadable.
-showHtml :: HTML html => html -> String
+showHtml :: HTML html => html -> Builder
 showHtml = showHtmlInternal docType
 
 -- | Outputs indented HTML. Because space matters in
 --   HTML, the output is quite messy.
-renderHtml :: HTML html => html -> String
+renderHtml :: HTML html => html -> Builder
 renderHtml = renderHtmlInternal docType
 
 -- | Outputs indented HTML, with indentation inside elements.
---   This can change the meaning of the HTML document, and 
+--   This can change the meaning of the HTML document, and
 --   is mostly useful for debugging the HTML output.
 --   The implementation is inefficient, and you are normally
 --   better off using 'showHtml' or 'renderHtml'.
 prettyHtml :: HTML html => html -> String
-prettyHtml = prettyHtmlInternal docType
+prettyHtml = prettyHtmlInternal (builderToString docType)

Text/XHtml/Frameset/Attributes.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Text.XHtml.Frameset.Attributes where
 
@@ -18,5 +19,5 @@ marginwidth         =   intAttr "marginwidth"
 noresize            ::           HtmlAttr
 noresize            = emptyAttr "noresize"
 
-scrolling           :: String -> HtmlAttr
+scrolling           :: LText -> HtmlAttr
 scrolling           =   strAttr "scrolling"

Text/XHtml/Frameset/Elements.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Text.XHtml.Frameset.Elements where