diff --git a/ChangeLog.md b/ChangeLog.md index 31e1716a15b3431e0a74aee2dedae5f5b63fa324..726edc946282fac03121abad7d75fdcd2c8be7d2 100644 --- a/ChangeLog.md +++ b/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` diff --git a/Text/XHtml/Debug.hs b/Text/XHtml/Debug.hs index 3c69b308392aef29980e62acc9766d374c327dc9..f20bbe41abed3ac0e1979dadb47fd53e57335d78 100644 --- a/Text/XHtml/Debug.hs +++ b/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,51 +26,47 @@ 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 -- @@ -75,40 +74,41 @@ treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors -- 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"] diff --git a/Text/XHtml/Extras.hs b/Text/XHtml/Extras.hs index 52086255362f9c3bd87f558fbfdfe554e02d8932..d9f9ab5f53a2cc10acaf94e2c86fdb833176d0e7 100644 --- a/Text/XHtml/Extras.hs +++ b/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"] diff --git a/Text/XHtml/Frameset.hs b/Text/XHtml/Frameset.hs index 2ede00ba450d360d51ace33df625d661c7baf691..75255fe5fd5f0e1f9b0c6e6f1c80087089912caf 100644 --- a/Text/XHtml/Frameset.hs +++ b/Text/XHtml/Frameset.hs @@ -1,3 +1,5 @@ +{-# language OverloadedStrings #-} + -- | Produces XHTML 1.0 Frameset. module Text.XHtml.Frameset ( -- * Data types @@ -5,12 +7,12 @@ module Text.XHtml.Frameset ( -- * 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) diff --git a/Text/XHtml/Frameset/Attributes.hs b/Text/XHtml/Frameset/Attributes.hs index 7aec0dd45f71d022490ccfe3b7dbf261b9a15fac..2b11082ac3f227e3f069e8251abfc5b55f1923c1 100644 --- a/Text/XHtml/Frameset/Attributes.hs +++ b/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" diff --git a/Text/XHtml/Frameset/Elements.hs b/Text/XHtml/Frameset/Elements.hs index f925784e10272f1bd9504347ad9fabf9012ca21f..d406d6feeb5323d25ee3d3273950e0a2e37353d0 100644 --- a/Text/XHtml/Frameset/Elements.hs +++ b/Text/XHtml/Frameset/Elements.hs @@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} module Text.XHtml.Frameset.Elements where diff --git a/Text/XHtml/Internals.hs b/Text/XHtml/Internals.hs index 514ec9acd5519ad028f7672c64166628eb167e2d..8cdd08f1a1eeddc65343923fb19eda95b481f472 100644 --- a/Text/XHtml/Internals.hs +++ b/Text/XHtml/Internals.hs @@ -1,5 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, BangPatterns, RecordWildCards #-} + ----------------------------------------------------------------------------- -- | -- Module : Text.XHtml.internals @@ -13,11 +15,27 @@ -- -- Internals of the XHTML combinator library. ----------------------------------------------------------------------------- -module Text.XHtml.Internals where - -import Data.Char +module Text.XHtml.Internals + ( module Text.XHtml.Internals + , Builder + ) where + +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy.Encoding as LText +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Builder hiding (char7) +import qualified Data.ByteString.Builder.Prim as P +import Data.ByteString.Builder.Prim hiding (intDec, charUtf8) +import Data.ByteString.Internal (c2w) import qualified Data.Semigroup as Sem import qualified Data.Monoid as Mon +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Word (Word8) + +type LText = LText.Text infixr 2 +++ -- combining Html infixr 7 << -- nesting Html @@ -30,47 +48,55 @@ infixl 8 ! -- adding optional arguments -- | A important property of Html is that all strings inside the -- structure are already in Html friendly format. data HtmlElement - = HtmlString String + = HtmlString !Builder -- ^ ..just..plain..normal..text... but using © and &amb;, etc. | HtmlTag { - markupTag :: String, - markupAttrs :: [HtmlAttr], - markupContent :: Html + markupTag :: !Builder, + markupAttrs :: [HtmlAttr] -> [HtmlAttr], + markupContent :: !Html } -- ^ tag with internal markup -- | Attributes with name and value. -data HtmlAttr = HtmlAttr String String +data HtmlAttr = HtmlAttr !Builder !Builder -htmlAttrPair :: HtmlAttr -> (String,String) +htmlAttrPair :: HtmlAttr -> (Builder,Builder) htmlAttrPair (HtmlAttr n v) = (n,v) -newtype Html = Html { getHtmlElements :: [HtmlElement] } +newtype Html = Html { unHtml :: [HtmlElement] -> [HtmlElement] } + +getHtmlElements :: Html -> [HtmlElement] +getHtmlElements html = unHtml html [] +builderToString :: Builder -> String +builderToString = + LText.unpack . LText.decodeUtf8 . toLazyByteString -- -- * Classes -- instance Show Html where - showsPrec _ html = showString (renderHtmlFragment html) - showList htmls = foldr (.) id (map shows htmls) + showsPrec _ html = showString (builderToString (renderHtmlFragment html)) + showList = foldr ((.) . shows) id instance Show HtmlAttr where showsPrec _ (HtmlAttr str val) = - showString str . + showString (builderToString str) . showString "=" . - shows val + shows (builderToString val) -- | @since 3000.2.2 instance Sem.Semigroup Html where (<>) = (+++) + {-# INLINE (<>) #-} instance Mon.Monoid Html where mempty = noHtml mappend = (Sem.<>) + {-# INLINE mappend #-} -- | HTML is the class of things that can be validly put -- inside an HTML tag. So this can be one or more 'Html' elements, @@ -79,47 +105,77 @@ class HTML a where toHtml :: a -> Html toHtmlFromList :: [a] -> Html - toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs]) + toHtmlFromList xs = Html (foldr (\x acc -> unHtml (toHtml x) . acc) id xs) instance HTML Html where toHtml a = a + {-# INLINE toHtml #-} + toHtmlFromList htmls = Html (foldr (\x acc -> unHtml x . acc) id htmls) + {-# INLINE toHtmlFromList #-} instance HTML Char where toHtml a = toHtml [a] - toHtmlFromList [] = Html [] - toHtmlFromList str = Html [HtmlString (stringToHtmlString str)] + {-# INLINE toHtml #-} + toHtmlFromList [] = Html id + toHtmlFromList str = Html (HtmlString (stringToHtmlString str) :) + {-# INLINE toHtmlFromList #-} instance (HTML a) => HTML [a] where - toHtml xs = toHtmlFromList xs + toHtml = toHtmlFromList + {-# INLINE toHtml #-} instance HTML a => HTML (Maybe a) where toHtml = maybe noHtml toHtml + {-# INLINE toHtml #-} + +instance HTML Text where + toHtml "" = Html id + toHtml xs = Html (HtmlString (textToHtmlString xs) :) + {-# INLINE toHtml #-} + +instance HTML LText.Text where + toHtml "" = Html id + toHtml xs = Html (HtmlString (lazyTextToHtmlString xs) : ) + {-# INLINE toHtml #-} + +mapDlist :: (a -> b) -> ([a] -> [a]) -> [b] -> [b] +mapDlist f as = (map f (as []) ++) +{-# INLINE mapDlist #-} class ADDATTRS a where (!) :: a -> [HtmlAttr] -> a -- | CHANGEATTRS is a more expressive alternative to ADDATTRS class CHANGEATTRS a where - changeAttrs :: a -> ([HtmlAttr]->[HtmlAttr]) -> a + changeAttrs :: a -> ([HtmlAttr] -> [HtmlAttr]) -> a instance (ADDATTRS b) => ADDATTRS (a -> b) where fn ! attr = \ arg -> fn arg ! attr + {-# INLINE (!) #-} instance (CHANGEATTRS b) => CHANGEATTRS (a -> b) where - changeAttrs fn f = \ arg -> changeAttrs (fn arg) f + changeAttrs fn f arg = changeAttrs (fn arg) f instance ADDATTRS Html where - (Html htmls) ! attr = Html (map addAttrs htmls) - where - addAttrs (html@(HtmlTag { markupAttrs = attrs }) ) - = html { markupAttrs = attrs ++ attr } - addAttrs html = html + (Html htmls) ! attr = Html (mapDlist addAttrs htmls) + where + addAttrs html = + case html of + HtmlTag { markupAttrs = attrs, .. } -> + HtmlTag + { markupAttrs = attrs . (attr ++) + , .. + } + _ -> + html + {-# INLINE (!) #-} + instance CHANGEATTRS Html where - changeAttrs (Html htmls) f = Html (map addAttrs htmls) + changeAttrs (Html htmls) f = Html (mapDlist addAttrs htmls) where - addAttrs (html@(HtmlTag { markupAttrs = attrs }) ) - = html { markupAttrs = f attrs } + addAttrs html@(HtmlTag { markupAttrs = attrs }) + = html { markupAttrs = f . attrs } addAttrs html = html @@ -134,50 +190,71 @@ instance CHANGEATTRS Html where -> b fn << arg = fn (toHtml arg) +{-# SPECIALIZE (<<) :: (Html -> b) -> String -> b #-} +{-# SPECIALIZE (<<) :: (Html -> b) -> Text -> b #-} +{-# SPECIALIZE (<<) :: (Html -> b) -> LText -> b #-} +{-# SPECIALIZE (<<) :: (Html -> b) -> Html -> b #-} +{-# SPECIALIZE (<<) :: (Html -> b) -> [Html] -> b #-} +{-# INLINABLE (<<) #-} concatHtml :: (HTML a) => [a] -> Html -concatHtml as = Html (concat (map (getHtmlElements.toHtml) as)) +concatHtml = Html . foldr ((.) . unHtml . toHtml) id + +{-# SPECIALIZE concatHtml :: [Html] -> Html #-} +{-# INLINABLE concatHtml #-} -- | 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 (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b)) +(+++) :: (HTML a, HTML b) => a -> b -> Html +a +++ b = Html (unHtml (toHtml a) . unHtml (toHtml b)) + +{-# SPECIALIZE (+++) :: Html -> Html -> Html #-} +{-# INLINABLE (+++) #-} -- | An empty piece of HTML. noHtml :: Html -noHtml = Html [] +noHtml = Html id --- | Checks whether the given piece of HTML is empty. +{-# INLINE noHtml #-} + +-- | 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) = null (xs []) -- | Constructs an element with a custom name. -tag :: String -- ^ Element name +tag :: Builder -- ^ Element name -> Html -- ^ Element contents -> Html -tag str htmls = Html [ - HtmlTag { - markupTag = str, - markupAttrs = [], - markupContent = htmls }] +tag str htmls = + Html + ( + HtmlTag + { markupTag = str + , markupAttrs = id + , markupContent = htmls + } + : + ) -- | Constructs an element with a custom name, and -- without any children. -itag :: String -> Html +itag :: Builder -> Html itag str = tag str noHtml -emptyAttr :: String -> HtmlAttr +emptyAttr :: Builder -> HtmlAttr emptyAttr s = HtmlAttr s s -intAttr :: String -> Int -> HtmlAttr -intAttr s i = HtmlAttr s (show i) - -strAttr :: String -> String -> HtmlAttr -strAttr s t = HtmlAttr s (stringToHtmlString t) +intAttr :: Builder -> Int -> HtmlAttr +intAttr s = HtmlAttr s . intDec +{-# INLINE intAttr #-} -htmlAttr :: String -> Html -> HtmlAttr -htmlAttr s t = HtmlAttr s (show t) +strAttr :: Builder -> LText.Text -> HtmlAttr +strAttr s = HtmlAttr s . lazyTextToHtmlString +{-# INLINE strAttr #-} +htmlAttr :: Builder -> Html -> HtmlAttr +htmlAttr s t = HtmlAttr s (renderHtmlFragment t) {- foldHtml :: (String -> [HtmlAttr] -> [a] -> a) @@ -192,25 +269,77 @@ foldHtml f g (HtmlString str) -} -- | Processing Strings into Html friendly things. -stringToHtmlString :: String -> String -stringToHtmlString = concatMap fixChar - where - fixChar '<' = "<" - fixChar '>' = ">" - fixChar '&' = "&" - fixChar '"' = """ - fixChar c | ord c < 0x80 = [c] - fixChar c = "&#" ++ show (ord c) ++ ";" - +stringToHtmlString :: String -> Builder +stringToHtmlString = primMapListBounded charUtf8HtmlEscaped +{-# INLINE stringToHtmlString #-} + +-- | Copied from @blaze-builder@ +{-# INLINE charUtf8HtmlEscaped #-} +charUtf8HtmlEscaped :: BoundedPrim Char +charUtf8HtmlEscaped = + condB (> '>' ) P.charUtf8 $ + condB (== '<' ) (fixed4 ('&',('l',('t',';')))) $ -- < + condB (== '>' ) (fixed4 ('&',('g',('t',';')))) $ -- > + condB (== '&' ) (fixed5 ('&',('a',('m',('p',';'))))) $ -- & + condB (== '"' ) (fixed6 ('&',('q',('u',('o',('t',';')))))) $ -- " + liftFixedToBounded P.char7 -- fallback for Chars smaller than '>' + where + {-# INLINE fixed4 #-} + fixed4 x = liftFixedToBounded $ const x >$< + char7 >*< char7 >*< char7 >*< char7 + + {-# INLINE fixed5 #-} + fixed5 x = liftFixedToBounded $ const x >$< + char7 >*< char7 >*< char7 >*< char7 >*< char7 + + {-# INLINE fixed6 #-} + fixed6 x = liftFixedToBounded $ const x >$< + char7 >*< char7 >*< char7 >*< char7 >*< char7 >*< char7 + +textToHtmlString :: Text -> Builder +textToHtmlString = Text.encodeUtf8BuilderEscaped wordHtmlEscaped +{-# INLINE textToHtmlString #-} + +lazyTextToHtmlString :: LText.Text -> Builder +lazyTextToHtmlString = LText.encodeUtf8BuilderEscaped wordHtmlEscaped + +-- | Copied from @blaze-builder@ +{-# INLINE wordHtmlEscaped #-} +wordHtmlEscaped :: P.BoundedPrim Word8 +wordHtmlEscaped = + P.condB (> c2w '>' ) (P.condB (== c2w '\DEL') P.emptyB $ P.liftFixedToBounded P.word8) $ + P.condB (== c2w '<' ) (fixed4 ('&',('l',('t',';')))) $ -- < + P.condB (== c2w '>' ) (fixed4 ('&',('g',('t',';')))) $ -- > + P.condB (== c2w '&' ) (fixed5 ('&',('a',('m',('p',';'))))) $ -- & + P.condB (== c2w '"' ) (fixed6 ('&',('q',('u',('o',('t',';')))))) $ -- " + P.condB (== c2w '\'') (fixed5 ('&',('#',('3',('9',';'))))) $ -- ' + P.condB (\c -> c >= c2w ' ' || c == c2w '\t' || c == c2w '\n' || c == c2w '\r') + (P.liftFixedToBounded P.word8) P.emptyB + where + {-# INLINE fixed4 #-} + fixed4 x = P.liftFixedToBounded $ const x P.>$< + P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8 + {-# INLINE fixed5 #-} + fixed5 x = P.liftFixedToBounded $ const x P.>$< + P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8 + {-# INLINE fixed6 #-} + fixed6 x = P.liftFixedToBounded $ const x P.>$< + P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8 -- | This is not processed for special chars. -- use stringToHtml or lineToHtml instead, for user strings, -- because they understand special chars, like @'<'@. primHtml :: String -> Html -primHtml x | null x = Html [] - | otherwise = Html [HtmlString x] +primHtml x | null x = Html id + | otherwise = Html (HtmlString (stringUtf8 x) :) +{-# INLINE primHtml #-} +-- | Does not process special characters, or check to see if it is empty. +primHtmlNonEmptyBuilder :: Builder -> Html +primHtmlNonEmptyBuilder x = Html (HtmlString x :) + +{-# INLINE primHtmlNonEmptyBuilder #-} -- -- * Html Rendering @@ -219,22 +348,32 @@ primHtml x | null x = Html [] mkHtml :: HTML html => html -> Html mkHtml = (tag "html" ! [strAttr "xmlns" "http://www.w3.org/1999/xhtml"] <<) +{-# SPECIALIZE mkHtml :: Html -> Html #-} +{-# INLINABLE mkHtml #-} + -- | 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. showHtmlInternal :: HTML html => - String -- ^ DOCTYPE declaration - -> html -> String + Builder -- ^ DOCTYPE declaration + -> html -> Builder showHtmlInternal docType theHtml = - docType ++ showHtmlFragment (mkHtml theHtml) + docType <> showHtmlFragment (mkHtml theHtml) + +{-# SPECIALIZE showHtmlInternal :: Builder -> Html -> Builder #-} +{-# INLINABLE showHtmlInternal #-} + -- | Outputs indented HTML. Because space matters in -- HTML, the output is quite messy. renderHtmlInternal :: HTML html => - String -- ^ DOCTYPE declaration - -> html -> String + Builder -- ^ DOCTYPE declaration + -> html -> Builder renderHtmlInternal docType theHtml = - docType ++ "\n" ++ renderHtmlFragment (mkHtml theHtml) ++ "\n" + docType <> "\n" <> renderHtmlFragment (mkHtml theHtml) <> "\n" + +{-# SPECIALIZE renderHtmlInternal :: Builder -> Html -> Builder #-} +{-# INLINABLE renderHtmlInternal #-} -- | Outputs indented HTML, with indentation inside elements. -- This can change the meaning of the HTML document, and @@ -249,16 +388,28 @@ prettyHtmlInternal docType theHtml = -- | Render a piece of HTML without adding a DOCTYPE declaration -- or root element. Does not add any extra whitespace. -showHtmlFragment :: HTML html => html -> String +showHtmlFragment :: HTML html => html -> Builder showHtmlFragment h = - (foldr (.) id $ map showHtml' $ getHtmlElements $ toHtml h) "" + go $ getHtmlElements $ toHtml h + where + go [] = mempty + go (x : xs) = showHtml' x <> go xs + +{-# SPECIALIZE showHtmlFragment :: Html -> Builder #-} +{-# INLINABLE showHtmlFragment #-} -- | Render a piece of indented HTML without adding a DOCTYPE declaration -- or root element. Only adds whitespace where it does not change -- the meaning of the document. -renderHtmlFragment :: HTML html => html -> String +renderHtmlFragment :: HTML html => html -> Builder renderHtmlFragment h = - (foldr (.) id $ map (renderHtml' 0) $ getHtmlElements $ toHtml h) "" + go $ getHtmlElements $ toHtml h + where + go [] = mempty + go (x:xs) = renderHtml' 0 x <> go xs + +{-# SPECIALIZE renderHtmlFragment :: Html -> Builder #-} +{-# INLINABLE renderHtmlFragment #-} -- | Render a piece of indented HTML without adding a DOCTYPE declaration -- or a root element. @@ -269,82 +420,99 @@ renderHtmlFragment h = -- better off using 'showHtmlFragment' or 'renderHtmlFragment'. prettyHtmlFragment :: HTML html => html -> String prettyHtmlFragment = - unlines . concat . map prettyHtml' . getHtmlElements . toHtml + unlines . concatMap prettyHtml' . getHtmlElements . toHtml -- | Show a single HTML element, without adding whitespace. -showHtml' :: HtmlElement -> ShowS -showHtml' (HtmlString str) = (++) str +showHtml' :: HtmlElement -> Builder +showHtml' (HtmlString str) = str showHtml'(HtmlTag { markupTag = name, markupContent = html, markupAttrs = attrs }) - = if isNoHtml html && elem name validHtmlITags - then renderTag True name attrs "" - else (renderTag False name attrs "" - . foldr (.) id (map showHtml' (getHtmlElements html)) - . renderEndTag name "") - -renderHtml' :: Int -> HtmlElement -> ShowS -renderHtml' _ (HtmlString str) = (++) str + = if isValidHtmlITag name && isNoHtml html + then renderTag True name (attrs []) "" + else renderTag False name (attrs []) "" + <> go (getHtmlElements html) + <> renderEndTag name "" + where + go [] = mempty + go (x:xs) = showHtml' x <> go xs + +renderHtml' :: Int -> HtmlElement -> Builder +renderHtml' _ (HtmlString str) = str renderHtml' n (HtmlTag { markupTag = name, markupContent = html, markupAttrs = attrs }) - = if isNoHtml html && elem name validHtmlITags - then renderTag True name attrs (nl n) - else (renderTag False name attrs (nl n) - . foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html)) - . renderEndTag name (nl n)) + = if isValidHtmlITag name && isNoHtml html + then renderTag True name (attrs []) nl + else renderTag False name (attrs []) nl + <> foldMap (renderHtml' (n+2)) (getHtmlElements html) + <> renderEndTag name nl where - nl n' = "\n" ++ replicate (n' `div` 8) '\t' - ++ replicate (n' `mod` 8) ' ' + nl :: Builder + nl = charUtf8 '\n' <> tabs <> spaces + + tabs :: Builder + tabs = + case n `div` 8 of + m | m <= 0 -> mempty + m -> Sem.stimes m (charUtf8 '\t') + + spaces :: Builder + spaces = + case n `mod` 8 of + m | m <= 0 -> mempty + m -> Sem.stimes m (charUtf8 ' ') prettyHtml' :: HtmlElement -> [String] -prettyHtml' (HtmlString str) = [str] +prettyHtml' (HtmlString str) = [builderToString str] prettyHtml' (HtmlTag { markupTag = name, markupContent = html, markupAttrs = attrs }) - = if isNoHtml html && elem name validHtmlITags + = if isValidHtmlITag name && isNoHtml html then - [rmNL (renderTag True name attrs "" "")] + [rmNL (renderTag True name (attrs []) "")] else - [rmNL (renderTag False name attrs "" "")] ++ - shift (concat (map prettyHtml' (getHtmlElements html))) ++ - [rmNL (renderEndTag name "" "")] + [rmNL (renderTag False name (attrs []) "")] ++ + shift (concatMap prettyHtml' (getHtmlElements html)) ++ + [rmNL (renderEndTag name "")] where - shift = map (\x -> " " ++ x) - rmNL = filter (/= '\n') + shift = map (" " ++) + rmNL = filter (/= '\n') . builderToString -- | Show a start tag renderTag :: Bool -- ^ 'True' if the empty tag shorthand should be used - -> String -- ^ Tag name + -> Builder -- ^ Tag name -> [HtmlAttr] -- ^ Attributes - -> String -- ^ Whitespace to add after attributes - -> ShowS -renderTag empty name attrs nl r - = "<" ++ name ++ shownAttrs ++ nl ++ close ++ r + -> Builder -- ^ Whitespace to add after attributes + -> Builder +renderTag empty name attrs nl + = "<" <> name <> shownAttrs <> nl <> close where close = if empty then " />" else ">" - shownAttrs = concat [' ':showPair attr | attr <- attrs ] + shownAttrs = foldr (\attr acc -> charUtf8 ' ' <> showPair attr <> acc) mempty attrs - showPair :: HtmlAttr -> String + showPair :: HtmlAttr -> Builder showPair (HtmlAttr key val) - = key ++ "=\"" ++ val ++ "\"" + = key <> "=\"" <> val <> "\"" -- | Show an end tag -renderEndTag :: String -- ^ Tag name - -> String -- ^ Whitespace to add after tag name - -> ShowS -renderEndTag name nl r = "</" ++ name ++ nl ++ ">" ++ r +renderEndTag :: Builder -- ^ Tag name + -> Builder -- ^ Whitespace to add after tag name + -> Builder +renderEndTag name nl = "</" <> name <> nl <> ">" +isValidHtmlITag :: Builder -> Bool +isValidHtmlITag bldr = toLazyByteString bldr `Set.member` validHtmlITags --- | The names of all elements which can represented using the empty tag +-- | The names of all elements which can be represented using the empty tag -- short-hand. -validHtmlITags :: [String] -validHtmlITags = [ +validHtmlITags :: Set BSL.ByteString +validHtmlITags = Set.fromList [ "area", "base", "basefont", diff --git a/Text/XHtml/Strict.hs b/Text/XHtml/Strict.hs index c4fc8c786eadfdfec9fe19de22c3a3f15674be5c..4ded1d44fb950d5b163dac1f737d3843d2a4a527 100644 --- a/Text/XHtml/Strict.hs +++ b/Text/XHtml/Strict.hs @@ -1,3 +1,5 @@ +{-# language OverloadedStrings #-} + -- | Produces XHTML 1.0 Strict. module Text.XHtml.Strict ( -- * Data types @@ -5,7 +7,7 @@ module Text.XHtml.Strict ( -- * Classes HTML(..), ADDATTRS(..), CHANGEATTRS(..), -- * Primitives and basic combinators - (<<), concatHtml, (+++), + (<<), concatHtml, (+++), noHtml, isNoHtml, tag, itag, htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr, primHtml, stringToHtmlString, @@ -18,45 +20,53 @@ module Text.XHtml.Strict ( 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 import Text.XHtml.Extras -- | The @DOCTYPE@ for XHTML 1.0 Strict. -docType :: String +docType :: Builder docType = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"" - ++ " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" + <> " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.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 +{-# SPECIALIZE showHtml :: Html -> Builder #-} +{-# INLINABLE showHtml #-} + -- | 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 +{-# SPECIALIZE renderHtml :: Html -> Builder #-} +{-# INLINABLE renderHtml #-} + -- | Outputs indented XHTML. Because space matters in -- HTML, the output is quite messy. renderHtmlWithLanguage :: HTML html - => String -- ^ The code of the "dominant" language of the webpage. + => LText.Text -- ^ The code of the "dominant" language of the webpage. -> html -- ^ All the 'Html', including a header. - -> String + -> Builder renderHtmlWithLanguage l theHtml = - docType ++ "\n" ++ renderHtmlFragment code ++ "\n" + docType <> "\n" <> renderHtmlFragment code <> "\n" where code = tag "html" ! [ strAttr "xmlns" "http://www.w3.org/1999/xhtml" - , strAttr "lang" l - , strAttr "xml:lang" l - ] << theHtml + , strAttr "lang" l + , strAttr "xml:lang" l + ] << theHtml -- | 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) diff --git a/Text/XHtml/Strict/Attributes.hs b/Text/XHtml/Strict/Attributes.hs index 468eb1a1007ced969eb3f32f5e4b841320679b89..7e2e3b62bcc357b627ce4f4cda3d4654e216fa4c 100644 --- a/Text/XHtml/Strict/Attributes.hs +++ b/Text/XHtml/Strict/Attributes.hs @@ -1,60 +1,62 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} + module Text.XHtml.Strict.Attributes where import Text.XHtml.Internals +import qualified Data.Text.Lazy as LText -- * Attributes in XHTML Strict -action :: String -> HtmlAttr -align :: String -> HtmlAttr - -alt :: String -> HtmlAttr -altcode :: String -> HtmlAttr -archive :: String -> HtmlAttr -base :: String -> HtmlAttr +action :: LText.Text -> HtmlAttr +align :: LText.Text -> HtmlAttr +alt :: LText.Text -> HtmlAttr +altcode :: LText.Text -> HtmlAttr +archive :: LText.Text -> HtmlAttr +base :: LText.Text -> HtmlAttr border :: Int -> HtmlAttr -bordercolor :: String -> HtmlAttr +bordercolor :: LText.Text -> HtmlAttr cellpadding :: Int -> HtmlAttr cellspacing :: Int -> HtmlAttr checked :: HtmlAttr -codebase :: String -> HtmlAttr -cols :: String -> HtmlAttr +codebase :: LText.Text -> HtmlAttr +cols :: LText.Text -> HtmlAttr colspan :: Int -> HtmlAttr -content :: String -> HtmlAttr -coords :: String -> HtmlAttr +content :: LText.Text -> HtmlAttr +coords :: LText.Text -> HtmlAttr disabled :: HtmlAttr -enctype :: String -> HtmlAttr -height :: String -> HtmlAttr -href :: String -> HtmlAttr -hreflang :: String -> HtmlAttr -httpequiv :: String -> HtmlAttr -identifier :: String -> HtmlAttr +enctype :: LText.Text -> HtmlAttr +height :: LText.Text -> HtmlAttr +href :: LText.Text -> HtmlAttr +hreflang :: LText.Text -> HtmlAttr +httpequiv :: LText.Text -> HtmlAttr +identifier :: LText.Text -> HtmlAttr ismap :: HtmlAttr -lang :: String -> HtmlAttr +lang :: LText.Text -> HtmlAttr maxlength :: Int -> HtmlAttr -method :: String -> HtmlAttr +method :: LText.Text -> HtmlAttr multiple :: HtmlAttr -name :: String -> HtmlAttr +name :: LText.Text -> HtmlAttr nohref :: HtmlAttr -rel :: String -> HtmlAttr -rev :: String -> HtmlAttr -rows :: String -> HtmlAttr +rel :: LText.Text -> HtmlAttr +rev :: LText.Text -> HtmlAttr +rows :: LText.Text -> HtmlAttr rowspan :: Int -> HtmlAttr -rules :: String -> HtmlAttr +rules :: LText.Text -> HtmlAttr selected :: HtmlAttr -shape :: String -> HtmlAttr -size :: String -> HtmlAttr -src :: String -> HtmlAttr -theclass :: String -> HtmlAttr -thefor :: String -> HtmlAttr -thestyle :: String -> HtmlAttr -thetype :: String -> HtmlAttr -title :: String -> HtmlAttr -usemap :: String -> HtmlAttr -valign :: String -> HtmlAttr -value :: String -> HtmlAttr -width :: String -> HtmlAttr +shape :: LText.Text -> HtmlAttr +size :: LText.Text -> HtmlAttr +src :: LText.Text -> HtmlAttr +theclass :: LText.Text -> HtmlAttr +thefor :: LText.Text -> HtmlAttr +thestyle :: LText.Text -> HtmlAttr +thetype :: LText.Text -> HtmlAttr +title :: LText.Text -> HtmlAttr +usemap :: LText.Text -> HtmlAttr +valign :: LText.Text -> HtmlAttr +value :: LText.Text -> HtmlAttr +width :: LText.Text -> HtmlAttr action = strAttr "action" align = strAttr "align" @@ -105,4 +107,52 @@ valign = strAttr "valign" value = strAttr "value" width = strAttr "width" +{-# INLINE action #-} +{-# INLINE align #-} +{-# INLINE alt #-} +{-# INLINE altcode #-} +{-# INLINE archive #-} +{-# INLINE base #-} +{-# INLINE border #-} +{-# INLINE bordercolor #-} +{-# INLINE cellpadding #-} +{-# INLINE cellspacing #-} +{-# INLINE checked #-} +{-# INLINE codebase #-} +{-# INLINE cols #-} +{-# INLINE colspan #-} +{-# INLINE content #-} +{-# INLINE coords #-} +{-# INLINE disabled #-} +{-# INLINE enctype #-} +{-# INLINE height #-} +{-# INLINE href #-} +{-# INLINE hreflang #-} +{-# INLINE httpequiv #-} +{-# INLINE identifier #-} +{-# INLINE ismap #-} +{-# INLINE lang #-} +{-# INLINE maxlength #-} +{-# INLINE method #-} +{-# INLINE multiple #-} +{-# INLINE name #-} +{-# INLINE nohref #-} +{-# INLINE rel #-} +{-# INLINE rev #-} +{-# INLINE rows #-} +{-# INLINE rowspan #-} +{-# INLINE rules #-} +{-# INLINE selected #-} +{-# INLINE shape #-} +{-# INLINE size #-} +{-# INLINE src #-} +{-# INLINE theclass #-} +{-# INLINE thefor #-} +{-# INLINE thestyle #-} +{-# INLINE thetype #-} +{-# INLINE title #-} +{-# INLINE usemap #-} +{-# INLINE valign #-} +{-# INLINE value #-} +{-# INLINE width #-} diff --git a/Text/XHtml/Strict/Elements.hs b/Text/XHtml/Strict/Elements.hs index 25b94d4eeee47bc8c2694bcb5c2494d96686a043..62fd3146586ffca25a8b1dc951db0079ff525bee 100644 --- a/Text/XHtml/Strict/Elements.hs +++ b/Text/XHtml/Strict/Elements.hs @@ -1,5 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} + module Text.XHtml.Strict.Elements where import Text.XHtml.Internals @@ -161,3 +163,81 @@ tr = tag "tr" tt = tag "tt" ulist = tag "ul" variable = tag "var" + +{-# INLINE abbr #-} +{-# INLINE acronym #-} +{-# INLINE address #-} +{-# INLINE anchor #-} +{-# INLINE area #-} +{-# INLINE bdo #-} +{-# INLINE big #-} +{-# INLINE blockquote #-} +{-# INLINE body #-} +{-# INLINE bold #-} +{-# INLINE button #-} +{-# INLINE br #-} +{-# INLINE caption #-} +{-# INLINE cite #-} +{-# INLINE col #-} +{-# INLINE colgroup #-} +{-# INLINE ddef #-} +{-# INLINE define #-} +{-# INLINE del #-} +{-# INLINE dlist #-} +{-# INLINE dterm #-} +{-# INLINE emphasize #-} +{-# INLINE fieldset #-} +{-# INLINE form #-} +{-# INLINE h1 #-} +{-# INLINE h2 #-} +{-# INLINE h3 #-} +{-# INLINE h4 #-} +{-# INLINE h5 #-} +{-# INLINE h6 #-} +{-# INLINE header #-} +{-# INLINE hr #-} +{-# INLINE image #-} +{-# INLINE input #-} +{-# INLINE ins #-} +{-# INLINE italics #-} +{-# INLINE keyboard #-} +{-# INLINE label #-} +{-# INLINE legend #-} +{-# INLINE li #-} +{-# INLINE meta #-} +{-# INLINE noscript #-} +{-# INLINE object #-} +{-# INLINE olist #-} +{-# INLINE optgroup #-} +{-# INLINE option #-} +{-# INLINE paragraph #-} +{-# INLINE param #-} +{-# INLINE pre #-} +{-# INLINE quote #-} +{-# INLINE sample #-} +{-# INLINE script #-} +{-# INLINE select #-} +{-# INLINE small #-} +{-# INLINE strong #-} +{-# INLINE style #-} +{-# INLINE sub #-} +{-# INLINE sup #-} +{-# INLINE table #-} +{-# INLINE tbody #-} +{-# INLINE td #-} +{-# INLINE textarea #-} +{-# INLINE tfoot #-} +{-# INLINE th #-} +{-# INLINE thead #-} +{-# INLINE thebase #-} +{-# INLINE thecode #-} +{-# INLINE thediv #-} +{-# INLINE thehtml #-} +{-# INLINE thelink #-} +{-# INLINE themap #-} +{-# INLINE thespan #-} +{-# INLINE thetitle #-} +{-# INLINE tr #-} +{-# INLINE tt #-} +{-# INLINE ulist #-} +{-# INLINE variable #-} diff --git a/Text/XHtml/Transitional.hs b/Text/XHtml/Transitional.hs index 892595edbef41d09130cce6211d72e1155a158b5..6239c7435610551bb6bcb60180e1b8120cd8c9f4 100644 --- a/Text/XHtml/Transitional.hs +++ b/Text/XHtml/Transitional.hs @@ -1,3 +1,5 @@ +{-# language OverloadedStrings #-} + -- | Produces XHTML 1.0 Transitional. module Text.XHtml.Transitional ( -- * Data types @@ -5,13 +7,16 @@ module Text.XHtml.Transitional ( -- * 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, + -- * Re-exports + LText, + Builder, module Text.XHtml.Strict.Elements, module Text.XHtml.Frameset.Elements, module Text.XHtml.Transitional.Elements, @@ -34,26 +39,26 @@ import Text.XHtml.Transitional.Attributes import Text.XHtml.Extras -docType :: String +docType :: Builder docType = - "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"" ++ + "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"" <> " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.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) diff --git a/Text/XHtml/Transitional/Attributes.hs b/Text/XHtml/Transitional/Attributes.hs index 95b2e8e35eed0b4dbccd7b08245bc05c56e2d335..4317942eb183f5abb6d7ca563c77e24007a812c7 100644 --- a/Text/XHtml/Transitional/Attributes.hs +++ b/Text/XHtml/Transitional/Attributes.hs @@ -1,5 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} + module Text.XHtml.Transitional.Attributes where import Text.XHtml.Internals @@ -7,27 +9,27 @@ import Text.XHtml.Internals -- * Extra attributes in XHTML Transitional {-# DEPRECATED alink "This attribute is deprecated in XHTML 1.0" #-} -alink :: String -> HtmlAttr +alink :: LText -> HtmlAttr alink = strAttr "alink" {-# DEPRECATED background "This attribute is deprecated in XHTML 1.0" #-} -background :: String -> HtmlAttr +background :: LText -> HtmlAttr background = strAttr "background" {-# DEPRECATED bgcolor "This attribute is deprecated in XHTML 1.0" #-} -bgcolor :: String -> HtmlAttr +bgcolor :: LText -> HtmlAttr bgcolor = strAttr "bgcolor" {-# DEPRECATED clear "This attribute is deprecated in XHTML 1.0" #-} -clear :: String -> HtmlAttr +clear :: LText -> HtmlAttr clear = strAttr "clear" {-# DEPRECATED code "This attribute is deprecated in XHTML 1.0" #-} -code :: String -> HtmlAttr +code :: LText -> HtmlAttr code = strAttr "code" {-# DEPRECATED color "This attribute is deprecated in XHTML 1.0" #-} -color :: String -> HtmlAttr +color :: LText -> HtmlAttr color = strAttr "color" {-# DEPRECATED compact "This attribute is deprecated in XHTML 1.0" #-} @@ -35,7 +37,7 @@ compact :: HtmlAttr compact = emptyAttr "compact" {-# DEPRECATED face "This attribute is deprecated in XHTML 1.0" #-} -face :: String -> HtmlAttr +face :: LText -> HtmlAttr face = strAttr "face" {-# DEPRECATED hspace "This attribute is deprecated in XHTML 1.0" #-} @@ -43,7 +45,7 @@ hspace :: Int -> HtmlAttr hspace = intAttr "hspace" {-# DEPRECATED link "This attribute is deprecated in XHTML 1.0" #-} -link :: String -> HtmlAttr +link :: LText -> HtmlAttr link = strAttr "link" {-# DEPRECATED noshade "This attribute is deprecated in XHTML 1.0" #-} @@ -58,19 +60,19 @@ nowrap = emptyAttr "nowrap" start :: Int -> HtmlAttr start = intAttr "start" -target :: String -> HtmlAttr +target :: LText -> HtmlAttr target = strAttr "target" {-# DEPRECATED text "This attribute is deprecated in XHTML 1.0" #-} -text :: String -> HtmlAttr +text :: LText -> HtmlAttr text = strAttr "text" {-# DEPRECATED version "This attribute is deprecated in XHTML 1.0" #-} -version :: String -> HtmlAttr +version :: LText -> HtmlAttr version = strAttr "version" {-# DEPRECATED vlink "This attribute is deprecated in XHTML 1.0" #-} -vlink :: String -> HtmlAttr +vlink :: LText -> HtmlAttr vlink = strAttr "vlink" {-# DEPRECATED vspace "This attribute is deprecated in XHTML 1.0" #-} @@ -84,22 +86,22 @@ vspace = intAttr "vspace" -- {-# DEPRECATED aqua,black,blue,fuchsia,gray,green,lime,maroon,navy,olive,purple,red,silver,teal,yellow,white "The use of color attibutes is deprecated in XHTML 1.0" #-} -aqua :: String -black :: String -blue :: String -fuchsia :: String -gray :: String -green :: String -lime :: String -maroon :: String -navy :: String -olive :: String -purple :: String -red :: String -silver :: String -teal :: String -yellow :: String -white :: String +aqua :: LText +black :: LText +blue :: LText +fuchsia :: LText +gray :: LText +green :: LText +lime :: LText +maroon :: LText +navy :: LText +olive :: LText +purple :: LText +red :: LText +silver :: LText +teal :: LText +yellow :: LText +white :: LText aqua = "aqua" black = "black" diff --git a/Text/XHtml/Transitional/Elements.hs b/Text/XHtml/Transitional/Elements.hs index 47303e3ba5ade3b2d2ffceef4b4c515d2fd14d45..ab20f635d1bad87c5c3a28b24951efb6b43a8692 100644 --- a/Text/XHtml/Transitional/Elements.hs +++ b/Text/XHtml/Transitional/Elements.hs @@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} module Text.XHtml.Transitional.Elements where diff --git a/xhtml.cabal b/xhtml.cabal index 98932a2450b46d430a88d435f278c5e3ef08bec8..0647c50c94edb8104867398503305d0758049b56 100644 --- a/xhtml.cabal +++ b/xhtml.cabal @@ -1,6 +1,6 @@ Cabal-version: >= 1.10 Name: xhtml -Version: 3000.2.2.1 +Version: 3000.3.0.0 Copyright: Bjorn Bringert 2004-2006, Andy Gill and the Oregon Graduate Institute of Science and Technology, 1999-2001 Maintainer: Chris Dornan <chris@chrisdornan.com> @@ -24,13 +24,17 @@ Source-repository head library Default-Language: Haskell2010 - if impl(ghc >= 7.2) - Default-Extensions: Safe + build-depends: + bytestring + , containers + , text Build-depends: base >= 4 && < 5 if impl(ghc >= 8.0) -- Enable warnings about potential future incompatibilities - ghc-options: -Wcompat -Wnoncanonical-monadfail-instances -Wnoncanonical-monad-instances + ghc-options: + -Wcompat + -Wnoncanonical-monad-instances else -- This provides compatibility with versions prior to GHC 8.0 / base-4.9, when `Data.Semigroup` -- still lived in `semigroups`.