Try with a Seq instead of a dlist

Text/XHtml/Debug.hs

@@ -11,6 +11,7 @@ import Text.XHtml.Extras
 import Text.XHtml.Table
 import Text.XHtml.Strict.Elements
 import Text.XHtml.Strict.Attributes
+import Data.Foldable (toList)
 
 import Data.List (uncons)
 
@@ -85,8 +86,8 @@ debugHtml obj = table ! [border 0] <<
               )
   where
 
-      debug' :: Html -> [HtmlTree]
-      debug' (Html markups) = map debug (markups [])
+      debug' :: Html -> Seq HtmlTree
+      debug' (Html markups) = fmap debug markups
 
       debug :: HtmlElement -> HtmlTree
       debug (HtmlString str) = HtmlLeaf (spaceHtml +++
@@ -98,7 +99,7 @@ debugHtml obj = table ! [border 0] <<
               }) =
               if isNoHtml content'
                 then HtmlNode hd [] noHtml
-                else HtmlNode hd (map debug (getHtmlElements content')) tl
+                else HtmlNode hd (toList $ fmap debug (getHtmlElements content')) tl
         where
               attrs = mkAttrs []
               args = if null attrs

Text/XHtml/Internals.hs

@@ -18,6 +18,7 @@
 module Text.XHtml.Internals
     ( module Text.XHtml.Internals
     , Builder
+    , Seq
     ) where
 
 import qualified Data.Text as Text
@@ -30,6 +31,9 @@ import qualified Data.Monoid as Mon
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Text (Text)
+import qualified Data.Sequence as Seq
+import Data.Sequence (Seq)
+import Data.Foldable (toList)
 
 infixr 2 +++  -- combining Html
 infixr 7 <<   -- nesting Html
@@ -59,10 +63,10 @@ htmlAttrPair :: HtmlAttr -> (Builder,Builder)
 htmlAttrPair (HtmlAttr n v) = (n,v)
 
 
-newtype Html = Html { unHtml :: [HtmlElement] -> [HtmlElement] }
+newtype Html = Html { unHtml :: Seq HtmlElement }
 
-getHtmlElements :: Html -> [HtmlElement]
-getHtmlElements html = unHtml html []
+getHtmlElements :: Html -> Seq HtmlElement
+getHtmlElements = unHtml
 
 builderToString :: Builder -> String
 builderToString =
@@ -84,7 +88,7 @@ instance Show HtmlAttr where
 
 -- | @since 3000.2.2
 instance Sem.Semigroup Html where
-    (<>) = (+++)
+    Html a <> Html b = Html (a <> b)
 
 instance Mon.Monoid Html where
     mempty = noHtml
@@ -97,25 +101,28 @@ class HTML a where
       toHtml     :: a -> Html
       toHtmlFromList :: [a] -> Html
 
-      toHtmlFromList xs = Html (foldr (\x acc -> unHtml (toHtml x) . acc) id xs)
+      toHtmlFromList xs = Html (foldr (\x acc -> unHtml (toHtml x) <> acc) mempty xs)
 
 instance HTML Html where
       toHtml a    = a
 
 instance HTML Char where
       toHtml       a = toHtml [a]
-      toHtmlFromList []  = Html id
-      toHtmlFromList str = Html (HtmlString (stringToHtmlString str) :)
+      toHtmlFromList []  = Html mempty
+      toHtmlFromList str = Html (pure (HtmlString (stringToHtmlString str)))
 
 instance (HTML a) => HTML [a] where
       toHtml xs = toHtmlFromList xs
 
+instance (HTML a) => HTML (Seq a) where
+    toHtml xs = toHtmlFromList (toList xs)
+
 instance HTML a => HTML (Maybe a) where
       toHtml = maybe noHtml toHtml
 
 instance HTML Text where
-    toHtml "" = Html id
-    toHtml xs = Html (HtmlString (textToHtmlString xs) :)
+    toHtml "" = Html mempty
+    toHtml xs = Html (pure (HtmlString (textToHtmlString xs)))
 
 mapDlist :: (a -> b) -> ([a] -> [a]) -> [b] -> [b]
 mapDlist f as = (map f (as []) ++)
@@ -134,7 +141,7 @@ instance (CHANGEATTRS b) => CHANGEATTRS (a -> b) where
       changeAttrs fn f = \ arg -> changeAttrs (fn arg) f
 
 instance ADDATTRS Html where
-    (Html htmls) ! attr = Html (mapDlist addAttrs htmls)
+    (Html htmls) ! attr = Html (fmap addAttrs htmls)
       where
         addAttrs html =
             case html of
@@ -148,7 +155,7 @@ instance ADDATTRS Html where
 
 
 instance CHANGEATTRS Html where
-      changeAttrs (Html htmls) f = Html (mapDlist addAttrs htmls)
+      changeAttrs (Html htmls) f = Html (fmap addAttrs htmls)
         where
               addAttrs (html@(HtmlTag { markupAttrs = attrs }) )
                             = html { markupAttrs = (f . attrs) }
@@ -168,37 +175,34 @@ fn << arg = fn (toHtml arg)
 
 
 concatHtml :: (HTML a) => [a] -> Html
-concatHtml = Html . foldr (.) id . map (unHtml . toHtml)
+concatHtml = Html . foldMap (unHtml . toHtml)
 
 -- | Create a piece of HTML which is the concatenation
 --   of two things which can be made into HTML.
 (+++) :: (HTML a, HTML b) => a -> b -> Html
-a +++ b = Html (unHtml (toHtml a) . unHtml (toHtml b))
+a +++ b = toHtml a <> toHtml b
 
 
 -- | An empty piece of HTML.
 noHtml :: Html
-noHtml = Html id
+noHtml = Html mempty
 
 -- | Checks whether the given piece of HTML is empty. This materializes the
 -- list, so it's not great to do this a bunch.
 isNoHtml :: Html -> Bool
-isNoHtml (Html xs) = null (xs [])
+isNoHtml (Html xs) = Seq.null xs
 
 -- | Constructs an element with a custom name.
 tag :: Builder -- ^ Element name
     -> Html -- ^ Element contents
     -> Html
 tag str htmls =
-    Html
-        (
-        HtmlTag
+    Html $
+        pure HtmlTag
             { markupTag = str
             , markupAttrs = id
             , markupContent = htmls
             }
-        :
-        )
 
 -- | Constructs an element with a custom name, and
 --   without any children.
@@ -249,12 +253,12 @@ textToHtmlString = Text.foldr (\c acc -> fixChar c <> acc) mempty
 -- use stringToHtml or lineToHtml instead, for user strings,
 -- because they understand special chars, like @'<'@.
 primHtml :: String -> Html
-primHtml x | null x    = Html id
-           | otherwise = Html (HtmlString (stringUtf8 x) :)
+primHtml x | null x    = Html mempty
+           | otherwise = Html (pure (HtmlString (stringUtf8 x)))
 
 -- | Does not process special characters, or check to see if it is empty.
 primHtmlNonEmptyBuilder :: Builder -> Html
-primHtmlNonEmptyBuilder x = Html (HtmlString x :)
+primHtmlNonEmptyBuilder x = Html (pure $ HtmlString x)
 
 
 --
@@ -314,7 +318,7 @@ renderHtmlFragment h =
 --   better off using 'showHtmlFragment' or 'renderHtmlFragment'.
 prettyHtmlFragment :: HTML html => html -> String
 prettyHtmlFragment =
-    unlines . concat . map prettyHtml' . getHtmlElements . toHtml
+    unlines . toList . foldMap prettyHtml' . getHtmlElements . toHtml
 
 -- | Show a single HTML element, without adding whitespace.
 showHtml' :: HtmlElement -> Builder
@@ -357,7 +361,7 @@ prettyHtml' (HtmlTag
          [rmNL (renderTag True name (attrs []) "")]
         else
          [rmNL (renderTag False name (attrs []) "")] ++
-          shift (concat (map prettyHtml' (getHtmlElements html))) ++
+          shift (foldMap prettyHtml' (getHtmlElements html)) ++
          [rmNL (renderEndTag name "")]
   where
       shift = map (\x -> "   " ++ x)