xhtml 3000.2.0.1 → 3000.4.1.0
raw patch · 17 files changed
Files
- ChangeLog.md +25/−0
- Text/XHtml.hs +3/−3
- Text/XHtml/BlockTable.hs +11/−13
- Text/XHtml/Debug.hs +59/−55
- Text/XHtml/Extras.hs +36/−27
- Text/XHtml/Frameset.hs +14/−11
- Text/XHtml/Frameset/Attributes.hs +3/−2
- Text/XHtml/Frameset/Elements.hs +2/−1
- Text/XHtml/Internals.hs +365/−151
- Text/XHtml/Strict.hs +26/−15
- Text/XHtml/Strict/Attributes.hs +88/−38
- Text/XHtml/Strict/Elements.hs +81/−1
- Text/XHtml/Table.hs +7/−2
- Text/XHtml/Transitional.hs +17/−11
- Text/XHtml/Transitional/Attributes.hs +31/−29
- Text/XHtml/Transitional/Elements.hs +2/−1
- xhtml.cabal +66/−33
+ ChangeLog.md view
@@ -0,0 +1,25 @@+## 3000.4.1.0++- Fix Inconsistent single quote escaping between String and Text HTML instances [#24](github.com/haskell/xhtml/pull/24)++## 3000.4.0.0++- Memory allocation improvements [#20](https://github.com/haskell/xhtml/pull/20)++## 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`+ (while 3000.2.2 supports `base < 4.11`) but is otherwise+ morally the same as `xhtml-3000.2.2`.++## 3000.2.2++- Add `Semigroup Html` instance+- Update to `cabal-version:>=1.10`+- Clean-up compiler warnings
Text/XHtml.hs view
@@ -5,9 +5,9 @@ -- Science and Technology, 1999-2001, -- (c) Bjorn Bringert, 2004-2006 -- License : BSD-style (see the file LICENSE)--- Maintainer : Bjorn Bringert <bjorn@bringert.net>--- Stability : experimental--- Portability : portable+-- Maintainer : Chris Dornan <chris@chrisdornan.com>+-- Stability : Stable+-- Portability : Portable -- -- An XHTML combinator library. --
Text/XHtml/BlockTable.hs view
@@ -1,18 +1,16 @@--- #hide- ----------------------------------------------------------------------------- -- | -- Module : Text.XHtml.BlockTable -- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of -- Science and Technology, 1999-2001 -- License : BSD-style (see the file LICENSE)--- Maintainer : Bjorn Bringert <bjorn@bringert.net>--- Stability : experimental--- Portability : portable+-- Maintainer : Chris Dornan <chris@chrisdornan.com>+-- Stability : Stable+-- Portability : Portable -- -- An XHTML combinator library ----- These combinators can be used to build formated 2D tables.+-- These combinators can be used to build formatted 2D tables. -- The specific target usage is for HTML table generation. ----------------------------------------------------------------------------- @@ -69,7 +67,7 @@ module Text.XHtml.BlockTable ( -- * Datatypes BlockTable,- -- * Contruction Functions+ -- * Construction Functions single, above, beside,@@ -116,17 +114,17 @@ let -- Note this depends on the fact that -- that the result has the same number- -- of lines as the y dimention; one list+ -- of lines as the y dimension; one list -- per line. This is not true in general -- but is always true for these combinators. -- I should assert this! -- I should even prove this.- beside (x:xs) (y:ys) = (x ++ y) : beside xs ys- beside (x:xs) [] = x : xs ++ r- beside [] (y:ys) = y : ys ++ r- beside [] [] = r+ beside' (x:xs) (y:ys) = (x ++ y) : beside' xs ys+ beside' (x:xs) [] = x : xs ++ r+ beside' [] (y:ys) = y : ys ++ r+ beside' [] [] = r in- beside (lst1 []) (lst2 []))+ beside' (lst1 []) (lst2 [])) -- | trans flips (transposes) over the x and y axis of -- the table. It is only used internally, and typically
Text/XHtml/Debug.hs view
@@ -1,3 +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@@ -7,7 +11,10 @@ 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)+ -- -- * Tree Displaying Combinators --@@ -19,51 +26,47 @@ = 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 (:) []+treeHtml :: [LText.Text] -> 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)+ treeHtmls :: [[LText.Text]] -> [HtmlTree] -> HtmlTable+ treeHtmls c ts = aboves (zipWith treeHtml' c ts) - treeHtml' :: [String] -> HtmlTree -> HtmlTable- treeHtml' (c:_) (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 immeduately outside nesting bar.- morecolors = filter ((/= c).head) (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 -> 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 -- @@ -71,40 +74,41 @@ -- 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 = markupTag,- markupContent = markupContent,- markupAttrs = markupAttrs+ markupTag = tag',+ markupContent = content',+ markupAttrs = mkAttrs }) =- case markupContent 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- args = if null markupAttrs+ attrs = mkAttrs []+ args = if null attrs then ""- else " " ++ unwords (map show markupAttrs) - hd = xsmallFont << ("<" ++ markupTag ++ args ++ ">")- tl = xsmallFont << ("</" ++ markupTag ++ ">")+ else " " <> unwords (map show attrs)+ hd = xsmallFont << ("<" <> lazyByteStringToString tag' <> args <> ">")+ tl = xsmallFont << ("</" <> lazyByteStringToString 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 view
@@ -1,7 +1,9 @@--- #hide+{-# 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@@ -13,22 +15,29 @@ -- | 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 --@@ -43,10 +52,10 @@ 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@@ -56,7 +65,7 @@ -- * Hotlinks -- -type URL = String+type URL = LText.Text data HotLink = HotLink { hotLinkURL :: URL,@@ -78,7 +87,7 @@ hotLinkAttributes = [] } --- +-- -- * Lists -- @@ -98,19 +107,19 @@ -- * Forms -- -widget :: String -> String -> [HtmlAttr] -> Html-widget w n markupAttrs = input ! ([thetype w] ++ ns ++ markupAttrs)- where ns = if null n then [] else [name n,identifier n]+widget :: LText.Text -> LText.Text -> [HtmlAttr] -> Html+widget w n attrs = input ! ([thetype w] ++ ns ++ attrs)+ where ns = if LText.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+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]@@ -123,9 +132,9 @@ 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 view
@@ -1,16 +1,18 @@+{-# language OverloadedStrings #-}+ -- | Produces XHTML 1.0 Frameset. module Text.XHtml.Frameset ( -- * Data types Html, HtmlAttr, -- * Classes- HTML(..), ADDATTRS(..),+ HTML(..), ADDATTRS(..), CHANGEATTRS(..), -- * Primitives and basic combinators- (<<), concatHtml, (+++), + (<<), concatHtml, (+++), noHtml, isNoHtml, tag, itag,- emptyAttr, intAttr, strAttr, htmlAttr,- primHtml, + htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr,+ primHtml, -- * Rendering- showHtml, renderHtml, prettyHtml, + showHtml, renderHtml, prettyHtml, showHtmlFragment, renderHtmlFragment, prettyHtmlFragment, module Text.XHtml.Strict.Elements, module Text.XHtml.Frameset.Elements,@@ -28,25 +30,26 @@ import Text.XHtml.Extras +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 ouput is quite unreadable.-showHtml :: HTML html => html -> String+-- render HTML, though the output is quite unreadable.+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 view
@@ -1,4 +1,5 @@--- #hide+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-} module Text.XHtml.Frameset.Attributes where @@ -18,5 +19,5 @@ noresize :: HtmlAttr noresize = emptyAttr "noresize" -scrolling :: String -> HtmlAttr+scrolling :: LText -> HtmlAttr scrolling = strAttr "scrolling"
Text/XHtml/Frameset/Elements.hs view
@@ -1,4 +1,5 @@--- #hide+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-} module Text.XHtml.Frameset.Elements where
Text/XHtml/Internals.hs view
@@ -1,67 +1,107 @@--- #hide+{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, BangPatterns, RecordWildCards #-}+ ----------------------------------------------------------------------------- -- | -- Module : Text.XHtml.internals--- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of +-- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of -- Science and Technology, 1999-2001, -- (c) Bjorn Bringert, 2004-2006 -- License : BSD-style (see the file LICENSE)--- Maintainer : Bjorn Bringert <bjorn@bringert.net>--- Stability : experimental--- Portability : portable+-- Maintainer : Chris Dornan <chris@chrisdornan.com>+-- Stability : Stable+-- Portability : Portable -- -- Internals of the XHTML combinator library. ------------------------------------------------------------------------------module Text.XHtml.Internals where+module Text.XHtml.Internals+ ( module Text.XHtml.Internals+ , Builder+ ) where -import Data.Char-import Data.Monoid+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 as BS+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 infixl 8 ! -- adding optional arguments --- +-- -- * Data types -- -- | 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+ | HtmlTag {+ markupTag :: !BSL.ByteString,+ markupAttrs :: [HtmlAttr] -> [HtmlAttr],+ markupContent :: !Html } -- ^ tag with internal markup -- | Attributes with name and value.-data HtmlAttr = HtmlAttr String String+data HtmlAttr = HtmlAttr !Builder !Builder -newtype Html = Html { getHtmlElements :: [HtmlElement] }+htmlAttrPair :: HtmlAttr -> (Builder,Builder)+htmlAttrPair (HtmlAttr n v) = (n,v) --- +newtype Html = Html { unHtml :: [HtmlElement] -> [HtmlElement] }++getHtmlElements :: Html -> [HtmlElement]+getHtmlElements html = unHtml html []++builderToString :: Builder -> String+builderToString =+ LText.unpack . LText.decodeUtf8 . toLazyByteString++lazyByteStringToString :: BSL.ByteString -> String+lazyByteStringToString =+ LText.unpack . LText.decodeUtf8++-- -- * 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 .+ showsPrec _ (HtmlAttr str val) =+ showString (builderToString str) . showString "=" .- shows val+ shows (builderToString val) -instance Monoid Html where+-- | @since 3000.2.2+instance Sem.Semigroup Html where+ (<>) = (+++)+ {-# INLINE (<>) #-}++instance Mon.Monoid Html where mempty = noHtml- mappend = (+++)+ 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,@@ -70,269 +110,443 @@ 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 #-}++instance HTML BSL.ByteString where+ toHtml "" = Html id+ toHtml xs = Html (HtmlString (lazyByteString xs) : )+ {-# INLINE toHtml #-}++instance HTML BS.ByteString where+ toHtml "" = Html id+ toHtml xs = Html (HtmlString (byteString 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+ instance (ADDATTRS b) => ADDATTRS (a -> b) where- fn ! attr = \ arg -> fn arg ! attr+ fn ! attr = \ arg -> fn arg ! attr+ {-# INLINE (!) #-} +instance (CHANGEATTRS b) => CHANGEATTRS (a -> b) where+ changeAttrs fn f arg = changeAttrs (fn arg) f+ instance ADDATTRS Html where- (Html htmls) ! attr = Html (map addAttrs htmls)+ (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 (mapDlist addAttrs htmls) where- addAttrs (html@(HtmlTag { markupAttrs = markupAttrs }) )- = html { markupAttrs = markupAttrs ++ attr }+ addAttrs html@(HtmlTag { markupAttrs = attrs })+ = html { markupAttrs = f . attrs } addAttrs html = html --- +-- -- * Html primitives and basic combinators -- -- | Put something inside an HTML element.-(<<) :: (HTML a) => +(<<) :: (HTML a) => (Html -> b) -- ^ Parent -> a -- ^ Child -> 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 :: BSL.ByteString -- ^ 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 :: BSL.ByteString -> 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) +foldHtml :: (String -> [HtmlAttr] -> [a] -> a) -> (String -> a) -> Html -> a-foldHtml f g (HtmlTag str attr fmls) - = f str attr (map (foldHtml f g) fmls) -foldHtml f g (HtmlString str) +foldHtml f g (HtmlTag str attr fmls)+ = f str attr (map (foldHtml f g) fmls)+foldHtml f g (HtmlString str) = g 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 --- | This is not processed for special chars. --- use stringToHtml or lineToHtml instead, for user strings, + {-# 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 (\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 -- 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 ouput is quite unreadable.-showHtmlInternal :: HTML html => - String -- ^ DOCTYPE declaration- -> html -> String-showHtmlInternal docType theHtml = - docType ++ showHtmlFragment (mkHtml theHtml)+-- render HTML, though the output is quite unreadable.+showHtmlInternal :: HTML html =>+ Builder -- ^ DOCTYPE declaration+ -> html -> Builder+showHtmlInternal docType 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+renderHtmlInternal :: HTML html =>+ 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 +-- 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'.-prettyHtmlInternal :: HTML html => +prettyHtmlInternal :: HTML html => String -- ^ DOCTYPE declaration -> html -> String-prettyHtmlInternal docType theHtml = +prettyHtmlInternal docType theHtml = docType ++ "\n" ++ prettyHtmlFragment (mkHtml 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 h = - (foldr (.) id $ map showHtml' $ getHtmlElements $ toHtml h) ""+showHtmlFragment :: HTML html => html -> Builder+showHtmlFragment 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 h = - (foldr (.) id $ map (renderHtml' 0) $ getHtmlElements $ toHtml h) ""+renderHtmlFragment :: HTML html => html -> Builder+renderHtmlFragment h =+ go $ getHtmlElements $ toHtml h+ where+ go [] = mempty+ go (x:xs) = renderHtml' 0 x <> go xs --- | Render a piece of indented HTML without adding a DOCTYPE declaration +{-# SPECIALIZE renderHtmlFragment :: Html -> Builder #-}+{-# INLINABLE renderHtmlFragment #-}++-- | Render a piece of indented HTML without adding a DOCTYPE declaration -- or a root element. -- The indentation is done 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 'showHtmlFragment' or 'renderHtmlFragment'. prettyHtmlFragment :: HTML html => html -> String-prettyHtmlFragment = - unlines . concat . map prettyHtml' . getHtmlElements . toHtml+prettyHtmlFragment =+ 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 = markupAttrs })- = if isNoHtml html && elem name validHtmlITags- then renderTag True name markupAttrs ""- else (renderTag False name markupAttrs ""- . foldr (.) id (map showHtml' (getHtmlElements html))- . renderEndTag name "")+ markupAttrs = attrs })+ = if isValidHtmlITag name && isNoHtml html+ then renderTag True nameBuilder (attrs []) ""+ else renderTag False nameBuilder (attrs []) ""+ <> go (getHtmlElements html)+ <> renderEndTag nameBuilder ""+ where+ go [] = mempty+ go (x:xs) = showHtml' x <> go xs -renderHtml' :: Int -> HtmlElement -> ShowS-renderHtml' _ (HtmlString str) = (++) str+ nameBuilder :: Builder+ nameBuilder = lazyByteString name++renderHtml' :: Int -> HtmlElement -> Builder+renderHtml' _ (HtmlString str) = str renderHtml' n (HtmlTag { markupTag = name, markupContent = html,- markupAttrs = markupAttrs })- = if isNoHtml html && elem name validHtmlITags- then renderTag True name markupAttrs (nl n)- else (renderTag False name markupAttrs (nl n)- . foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html))- . renderEndTag name (nl n))+ markupAttrs = attrs })+ = if isValidHtmlITag name && isNoHtml html+ then renderTag True nameBuilder (attrs []) nl+ else renderTag False nameBuilder (attrs []) nl+ <> foldMap (renderHtml' (n+2)) (getHtmlElements html)+ <> renderEndTag nameBuilder 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 ' ')++ nameBuilder :: Builder+ nameBuilder = lazyByteString name++ prettyHtml' :: HtmlElement -> [String]-prettyHtml' (HtmlString str) = [str]+prettyHtml' (HtmlString str) = [builderToString str] prettyHtml' (HtmlTag { markupTag = name, markupContent = html,- markupAttrs = markupAttrs })- = if isNoHtml html && elem name validHtmlITags- then - [rmNL (renderTag True name markupAttrs "" "")]+ markupAttrs = attrs })+ = if isValidHtmlITag name && isNoHtml html+ then+ [rmNL (renderTag True nameBuilder (attrs []) "")] else- [rmNL (renderTag False name markupAttrs "" "")] ++ - shift (concat (map prettyHtml' (getHtmlElements html))) ++- [rmNL (renderEndTag name "" "")]+ [rmNL (renderTag False nameBuilder (attrs []) "")] +++ shift (concatMap prettyHtml' (getHtmlElements html)) +++ [rmNL (renderEndTag nameBuilder "")] where- shift = map (\x -> " " ++ x)- rmNL = filter (/= '\n')+ shift = map (" " ++)+ rmNL = filter (/= '\n') . builderToString + nameBuilder :: Builder+ nameBuilder = lazyByteString name + -- | Show a start tag renderTag :: Bool -- ^ 'True' if the empty tag shorthand should be used- -> String -- ^ Tag name- -> [HtmlAttr] -- ^ Attributes- -> String -- ^ Whitespace to add after attributes- -> ShowS-renderTag empty name attrs nl r- = "<" ++ name ++ showAttrs attrs ++ nl ++ close ++ r+ -> Builder -- ^ Tag name+ -> [HtmlAttr] -- ^ Attributes+ -> Builder -- ^ Whitespace to add after attributes+ -> Builder+renderTag empty name attrs nl+ = "<" <> name <> shownAttrs <> nl <> close where close = if empty then " />" else ">" - showAttrs attrs = concat [' ':showPair attr | attr <- attrs ]+ shownAttrs = foldr (\attr acc -> charUtf8 ' ' <> showPair attr <> acc) mempty attrs - showPair :: HtmlAttr -> String- showPair (HtmlAttr tag val)- = tag ++ "=\"" ++ val ++ "\""+ showPair :: HtmlAttr -> Builder+ showPair (HtmlAttr 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 :: BSL.ByteString -> Bool+isValidHtmlITag bs = bs `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 = [- "area",- "base",- "basefont",- "br",+validHtmlITags :: Set BSL.ByteString+validHtmlITags = Set.fromList [+ "area",+ "base",+ "basefont",+ "br", "col", "frame",- "hr",- "img",- "input",+ "hr",+ "img",+ "input", "isindex", "link",- "meta",- "param"- ]+ "meta",+ "param"+ ]
Text/XHtml/Strict.hs view
@@ -1,13 +1,15 @@+{-# language OverloadedStrings #-}+ -- | Produces XHTML 1.0 Strict. module Text.XHtml.Strict ( -- * Data types Html, HtmlAttr, -- * Classes- HTML(..), ADDATTRS(..),+ HTML(..), ADDATTRS(..), CHANGEATTRS(..), -- * Primitives and basic combinators- (<<), concatHtml, (+++), + (<<), concatHtml, (+++), noHtml, isNoHtml, tag, itag,- emptyAttr, intAttr, strAttr, htmlAttr,+ htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr, primHtml, stringToHtmlString, docType, -- * Rendering@@ -18,44 +20,53 @@ 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 :: 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 ouput is quite unreadable.-showHtml :: HTML html => html -> String+-- render HTML, though the output is quite unreadable.+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)
Text/XHtml/Strict/Attributes.hs view
@@ -1,60 +1,62 @@--- #hide+{-# 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 @@ 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 #-}
Text/XHtml/Strict/Elements.hs view
@@ -1,5 +1,7 @@--- #hide+{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-}+ module Text.XHtml.Strict.Elements where import Text.XHtml.Internals@@ -161,3 +163,81 @@ 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 #-}
Text/XHtml/Table.hs view
@@ -28,7 +28,7 @@ cell h = let cellFn x y = h ! (add x colspan $ add y rowspan $ [])- add 1 fn rest = rest+ add 1 _ rest = rest add n fn rest = fn n : rest r = BT.single cellFn in @@ -60,7 +60,12 @@ beside a b = combine BT.beside (cell a) (cell b) (<->) = beside -+combine :: (BT.BlockTable (Int -> Int -> Html) ->+ BT.BlockTable (Int -> Int -> Html) ->+ BT.BlockTable (Int -> Int -> Html))+ -> HtmlTable+ -> HtmlTable+ -> HtmlTable combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b) -- Both aboves and besides presume a non-empty list.
Text/XHtml/Transitional.hs view
@@ -1,17 +1,22 @@+{-# language OverloadedStrings #-}+ -- | Produces XHTML 1.0 Transitional. module Text.XHtml.Transitional ( -- * Data types Html, HtmlAttr, -- * Classes- HTML(..), ADDATTRS(..),+ HTML(..), ADDATTRS(..), CHANGEATTRS(..), -- * Primitives and basic combinators- (<<), concatHtml, (+++), + (<<), concatHtml, (+++), noHtml, isNoHtml, tag, itag,- emptyAttr, intAttr, strAttr, htmlAttr,- primHtml, + htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr,+ 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,25 +39,26 @@ import Text.XHtml.Extras +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 ouput is quite unreadable.-showHtml :: HTML html => html -> String+-- render HTML, though the output is quite unreadable.+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/Transitional/Attributes.hs view
@@ -1,5 +1,7 @@--- #hide+{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-}+ module Text.XHtml.Transitional.Attributes where import Text.XHtml.Internals@@ -7,27 +9,27 @@ -- * 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 = 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 = 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 @@ 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 @@ -- {-# 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"
Text/XHtml/Transitional/Elements.hs view
@@ -1,4 +1,5 @@--- #hide+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-} module Text.XHtml.Transitional.Elements where
xhtml.cabal view
@@ -1,33 +1,66 @@-Name: xhtml-Version: 3000.2.0.1-Copyright: Bjorn Bringert 2004-2006, Andy Gill, and the Oregon Graduate - Institute of Science and Technology, 1999-2001-Maintainer: bjorn@bringert.net-Author: Bjorn Bringert-License: BSD3-License-file: LICENSE-build-depends: base-Extensions: -Synopsis: An XHTML combinator library-Description:- This package provides combinators for producing- XHTML 1.0, including the Strict, Transitional and Frameset variants.-Build-Type: Simple-Exposed-Modules: - Text.XHtml, - Text.XHtml.Frameset,- Text.XHtml.Strict,- Text.XHtml.Transitional,- Text.XHtml.Debug,- Text.XHtml.Table-Other-modules:- Text.XHtml.Strict.Attributes,- Text.XHtml.Strict.Elements,- Text.XHtml.Frameset.Attributes,- Text.XHtml.Frameset.Elements,- Text.XHtml.Transitional.Attributes,- Text.XHtml.Transitional.Elements,- Text.XHtml.BlockTable,- Text.XHtml.Extras,- Text.XHtml.Internals-ghc-options: -O2 -W+Cabal-version: >= 1.10+Name: xhtml+Version: 3000.4.1.0+Copyright: Bjorn Bringert 2004-2006, Andy Gill and the Oregon+ Graduate Institute of Science and Technology, 1999-2001+Maintainer: hecate@glitchbra.in+Author: Bjorn Bringert+License: BSD3+License-file: LICENSE+Synopsis: An XHTML combinator library+Description: This package provides combinators for producing+ XHTML 1.0, including the Strict, Transitional and+ Frameset variants.+Stability: Stable+Category: Web, XML, Pretty Printer+Homepage: https://github.com/haskell/xhtml+Bug-Reports: https://github.com/haskell/xhtml/issues+Build-type: Simple+extra-source-files: ChangeLog.md++Source-repository head+ type: git+ location: https://github.com/haskell/xhtml++library+ Default-Language: Haskell2010+ 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-monad-instances+ else+ -- This provides compatibility with versions prior to GHC 8.0 / base-4.9, when `Data.Semigroup`+ -- still lived in `semigroups`.++ -- Note: semigroups-0.8 is a reasonably early version depending only on base & containers,+ -- and `xhtml` only needs to define the class instance+ -- so we can easily support a wide range of major+ -- versions of `semigroups`+ Build-depends: semigroups >= 0.8 && < 0.19++ Exposed-modules:+ Text.XHtml,+ Text.XHtml.Frameset,+ Text.XHtml.Strict,+ Text.XHtml.Transitional,+ Text.XHtml.Debug,+ Text.XHtml.Table+ Other-modules:+ Text.XHtml.Strict.Attributes,+ Text.XHtml.Strict.Elements,+ Text.XHtml.Frameset.Attributes,+ Text.XHtml.Frameset.Elements,+ Text.XHtml.Transitional.Attributes,+ Text.XHtml.Transitional.Elements,+ Text.XHtml.BlockTable,+ Text.XHtml.Extras,+ Text.XHtml.Internals++ ghc-options: -Wall -fwarn-tabs