xhtml-3000.2.1/ 0000755 0001060 0001060 00000000000 11755733475 011634 5 ustar ross ross xhtml-3000.2.1/Text/ 0000775 0001060 0001060 00000000000 11752502453 012545 5 ustar ross ross xhtml-3000.2.1/Text/XHtml.hs 0000664 0001060 0001060 00000004101 11752502453 014131 0 ustar ross ross #if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Text.XHtml
-- 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 : Chris Dornan
-- Stability : Stable
-- Portability : Portable
--
-- An XHTML combinator library.
--
-- Based on the original Text.Html library by Andy Gill.
-- See for
-- an introduction to that library.
--
-- This module re-exports "Text.XHtml.Transitional", which produces
-- XHTML 1.0 Transitional.
-- Use "Text.XHtml.Strict" if you want XHTML 1.0 Strict,
-- and "Text.XHtml.Frameset" if you want
-- to produce XHTML 1.0 Frameset.
--
-- See for more information about
-- XHTML 1.0.
-----------------------------------------------------------------------------
{-
-- Changes by Bjorn Bringert:
--
-- * produces XHTML 1.0 Transitional ()
--
-- * escapes characters inside attribute values
--
-- * changed 'height' to a String attribute
--
-- * added 'Monoid' instance for 'Html'.
--
-- * added elements from HTML 4.0: 'abbr', 'acronym', 'bdo', 'button', 'col',
-- 'colgroup', 'del', 'iframe', 'ins', 'label', 'legend', 'noframes',
-- 'noscript', 'object', 'optgroup', 'script', 'strike', 'tbody', 'tfoot',
-- 'thead', and 'quote'.
--
-- * 'defList' no longer makes terms bold.
--
-- * deprecated functions for elements and attributes
-- deprecated in HTML 4.0
--
-- * hid or removed some internal functions.
--
-- TODO:
--
-- * add new attributes introduced in HTML 4.0
--
-- * character encoding
-}
module Text.XHtml (
module Text.XHtml.Transitional,
module Text.XHtml.Table,
module Text.XHtml.Debug
) where
import Text.XHtml.Transitional
import Text.XHtml.Table
import Text.XHtml.Debug
xhtml-3000.2.1/Text/XHtml/ 0000775 0001060 0001060 00000000000 11752502453 013601 5 ustar ross ross xhtml-3000.2.1/Text/XHtml/Internals.hs 0000664 0001060 0001060 00000025454 11752525425 016112 0 ustar ross ross {-# OPTIONS_HADDOCK hide #-}
-- #hide
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Text.XHtml.internals
-- 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 : Chris Dornan
-- Stability : Stable
-- Portability : Portable
--
-- Internals of the XHTML combinator library.
-----------------------------------------------------------------------------
module Text.XHtml.Internals where
import Data.Char
import Data.Monoid
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
-- ^ ..just..plain..normal..text... but using © and &amb;, etc.
| HtmlTag {
markupTag :: String,
markupAttrs :: [HtmlAttr],
markupContent :: Html
}
-- ^ tag with internal markup
-- | Attributes with name and value.
data HtmlAttr = HtmlAttr String String
htmlAttrPair :: HtmlAttr -> (String,String)
htmlAttrPair (HtmlAttr n v) = (n,v)
newtype Html = Html { getHtmlElements :: [HtmlElement] }
--
-- * Classes
--
instance Show Html where
showsPrec _ html = showString (renderHtmlFragment html)
showList htmls = foldr (.) id (map shows htmls)
instance Show HtmlAttr where
showsPrec _ (HtmlAttr str val) =
showString str .
showString "=" .
shows val
instance Monoid Html where
mempty = noHtml
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,
-- or a 'String', for example.
class HTML a where
toHtml :: a -> Html
toHtmlFromList :: [a] -> Html
toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])
instance HTML Html where
toHtml a = a
instance HTML Char where
toHtml a = toHtml [a]
toHtmlFromList [] = Html []
toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
instance (HTML a) => HTML [a] where
toHtml xs = toHtmlFromList xs
instance HTML a => HTML (Maybe a) where
toHtml = maybe noHtml toHtml
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
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)
where
addAttrs (html@(HtmlTag { markupAttrs = attrs }) )
= html { markupAttrs = attrs ++ attr }
addAttrs html = html
instance CHANGEATTRS Html where
changeAttrs (Html htmls) f = Html (map addAttrs htmls)
where
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 -> b) -- ^ Parent
-> a -- ^ Child
-> b
fn << arg = fn (toHtml arg)
concatHtml :: (HTML a) => [a] -> Html
concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))
-- | 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))
-- | An empty piece of HTML.
noHtml :: Html
noHtml = Html []
-- | Checks whether the given piece of HTML is empty.
isNoHtml :: Html -> Bool
isNoHtml (Html xs) = null xs
-- | Constructs an element with a custom name.
tag :: String -- ^ Element name
-> Html -- ^ Element contents
-> Html
tag str htmls = Html [
HtmlTag {
markupTag = str,
markupAttrs = [],
markupContent = htmls }]
-- | Constructs an element with a custom name, and
-- without any children.
itag :: String -> Html
itag str = tag str noHtml
emptyAttr :: String -> 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)
htmlAttr :: String -> Html -> HtmlAttr
htmlAttr s t = HtmlAttr s (show t)
{-
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)
= 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) ++ ";"
-- | 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]
--
-- * Html Rendering
--
mkHtml :: HTML html => html -> Html
mkHtml = (tag "html" ! [strAttr "xmlns" "http://www.w3.org/1999/xhtml"] <<)
-- | 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)
-- | Outputs indented HTML. Because space matters in
-- HTML, the output is quite messy.
renderHtmlInternal :: HTML html =>
String -- ^ DOCTYPE declaration
-> html -> String
renderHtmlInternal docType theHtml =
docType ++ "\n" ++ renderHtmlFragment (mkHtml theHtml) ++ "\n"
-- | Outputs indented HTML, with indentation inside elements.
-- 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 =>
String -- ^ DOCTYPE declaration
-> html -> String
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) ""
-- | 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) ""
-- | 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
-- 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
-- | Show a single HTML element, without adding whitespace.
showHtml' :: HtmlElement -> ShowS
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
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))
where
nl n' = "\n" ++ replicate (n' `div` 8) '\t'
++ replicate (n' `mod` 8) ' '
prettyHtml' :: HtmlElement -> [String]
prettyHtml' (HtmlString str) = [str]
prettyHtml' (HtmlTag
{ markupTag = name,
markupContent = html,
markupAttrs = attrs })
= if isNoHtml html && elem name validHtmlITags
then
[rmNL (renderTag True name attrs "" "")]
else
[rmNL (renderTag False name attrs "" "")] ++
shift (concat (map prettyHtml' (getHtmlElements html))) ++
[rmNL (renderEndTag name "" "")]
where
shift = map (\x -> " " ++ x)
rmNL = filter (/= '\n')
-- | 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 ++ shownAttrs ++ nl ++ close ++ r
where
close = if empty then " />" else ">"
shownAttrs = concat [' ':showPair attr | attr <- attrs ]
showPair :: HtmlAttr -> String
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 = "" ++ r
-- | The names of all elements which can represented using the empty tag
-- short-hand.
validHtmlITags :: [String]
validHtmlITags = [
"area",
"base",
"basefont",
"br",
"col",
"frame",
"hr",
"img",
"input",
"isindex",
"link",
"meta",
"param"
]
xhtml-3000.2.1/Text/XHtml/Transitional/ 0000775 0001060 0001060 00000000000 11752502453 016250 5 ustar ross ross xhtml-3000.2.1/Text/XHtml/Transitional/Elements.hs 0000664 0001060 0001060 00000003011 11752502453 020353 0 ustar ross ross {-# OPTIONS_HADDOCK hide #-}
-- #hide
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Text.XHtml.Transitional.Elements where
import Text.XHtml.Internals
-- * Extra elements in XHTML Transitional
{-# DEPRECATED applet "This element is deprecated in XHTML 1.0" #-}
applet :: Html -> Html
applet = tag "applet"
{-# DEPRECATED basefont "This element is deprecated in XHTML 1.0" #-}
basefont :: Html
basefont = itag "basefont"
{-# DEPRECATED center "This element is deprecated in XHTML 1.0" #-}
center :: Html -> Html
center = tag "center"
{-# DEPRECATED dir "This element is deprecated in XHTML 1.0" #-}
dir :: Html -> Html
dir = tag "dir"
{-# DEPRECATED font "This element is deprecated in XHTML 1.0" #-}
font :: Html -> Html
font = tag "font"
iframe :: Html -> Html
iframe = tag "iframe"
{-# DEPRECATED isindex "This element is deprecated in XHTML 1.0" #-}
isindex :: Html
isindex = itag "isindex"
{-# DEPRECATED themenu "This element is deprecated in XHTML 1.0" #-}
themenu :: Html -> Html
themenu = tag "menu"
{-# DEPRECATED strike "This element is deprecated in XHTML 1.0" #-}
strike :: Html -> Html
strike = tag "strike"
{-# DEPRECATED underline "This element is deprecated in XHTML 1.0" #-}
underline :: Html -> Html
underline = tag "u"
xhtml-3000.2.1/Text/XHtml/Transitional/Attributes.hs 0000664 0001060 0001060 00000007444 11752502453 020743 0 ustar ross ross {-# OPTIONS_HADDOCK hide #-}
-- #hide
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Text.XHtml.Transitional.Attributes where
import Text.XHtml.Internals
-- * Extra attributes in XHTML Transitional
{-# DEPRECATED alink "This attribute is deprecated in XHTML 1.0" #-}
alink :: String -> HtmlAttr
alink = strAttr "alink"
{-# DEPRECATED background "This attribute is deprecated in XHTML 1.0" #-}
background :: String -> HtmlAttr
background = strAttr "background"
{-# DEPRECATED bgcolor "This attribute is deprecated in XHTML 1.0" #-}
bgcolor :: String -> HtmlAttr
bgcolor = strAttr "bgcolor"
{-# DEPRECATED clear "This attribute is deprecated in XHTML 1.0" #-}
clear :: String -> HtmlAttr
clear = strAttr "clear"
{-# DEPRECATED code "This attribute is deprecated in XHTML 1.0" #-}
code :: String -> HtmlAttr
code = strAttr "code"
{-# DEPRECATED color "This attribute is deprecated in XHTML 1.0" #-}
color :: String -> HtmlAttr
color = strAttr "color"
{-# DEPRECATED compact "This attribute is deprecated in XHTML 1.0" #-}
compact :: HtmlAttr
compact = emptyAttr "compact"
{-# DEPRECATED face "This attribute is deprecated in XHTML 1.0" #-}
face :: String -> HtmlAttr
face = strAttr "face"
{-# DEPRECATED hspace "This attribute is deprecated in XHTML 1.0" #-}
hspace :: Int -> HtmlAttr
hspace = intAttr "hspace"
{-# DEPRECATED link "This attribute is deprecated in XHTML 1.0" #-}
link :: String -> HtmlAttr
link = strAttr "link"
{-# DEPRECATED noshade "This attribute is deprecated in XHTML 1.0" #-}
noshade :: HtmlAttr
noshade = emptyAttr "noshade"
{-# DEPRECATED nowrap "This attribute is deprecated in XHTML 1.0" #-}
nowrap :: HtmlAttr
nowrap = emptyAttr "nowrap"
{-# DEPRECATED start "This attribute is deprecated in XHTML 1.0" #-}
start :: Int -> HtmlAttr
start = intAttr "start"
target :: String -> HtmlAttr
target = strAttr "target"
{-# DEPRECATED text "This attribute is deprecated in XHTML 1.0" #-}
text :: String -> HtmlAttr
text = strAttr "text"
{-# DEPRECATED version "This attribute is deprecated in XHTML 1.0" #-}
version :: String -> HtmlAttr
version = strAttr "version"
{-# DEPRECATED vlink "This attribute is deprecated in XHTML 1.0" #-}
vlink :: String -> HtmlAttr
vlink = strAttr "vlink"
{-# DEPRECATED vspace "This attribute is deprecated in XHTML 1.0" #-}
vspace :: Int -> HtmlAttr
vspace = intAttr "vspace"
--
-- * Html colors
--
{-# 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 = "aqua"
black = "black"
blue = "blue"
fuchsia = "fuchsia"
gray = "gray"
green = "green"
lime = "lime"
maroon = "maroon"
navy = "navy"
olive = "olive"
purple = "purple"
red = "red"
silver = "silver"
teal = "teal"
yellow = "yellow"
white = "white"
xhtml-3000.2.1/Text/XHtml/Strict/ 0000775 0001060 0001060 00000000000 11752502453 015051 5 ustar ross ross xhtml-3000.2.1/Text/XHtml/Strict/Elements.hs 0000664 0001060 0001060 00000012717 11752502453 017171 0 ustar ross ross {-# OPTIONS_HADDOCK hide #-}
-- #hide
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Text.XHtml.Strict.Elements where
import Text.XHtml.Internals
-- * Elements in XHTML Strict
abbr :: Html -> Html
acronym :: Html -> Html
address :: Html -> Html
anchor :: Html -> Html
area :: Html
bdo :: Html -> Html
big :: Html -> Html
blockquote :: Html -> Html
body :: Html -> Html
bold :: Html -> Html
br :: Html
button :: Html -> Html
caption :: Html -> Html
cite :: Html -> Html
col :: Html -> Html
colgroup :: Html -> Html
del :: Html -> Html
ddef :: Html -> Html
define :: Html -> Html
dlist :: Html -> Html
dterm :: Html -> Html
emphasize :: Html -> Html
fieldset :: Html -> Html
form :: Html -> Html
h1 :: Html -> Html
h2 :: Html -> Html
h3 :: Html -> Html
h4 :: Html -> Html
h5 :: Html -> Html
h6 :: Html -> Html
header :: Html -> Html
hr :: Html
image :: Html
input :: Html
ins :: Html -> Html
italics :: Html -> Html
keyboard :: Html -> Html
label :: Html -> Html
legend :: Html -> Html
li :: Html -> Html
meta :: Html
noscript :: Html -> Html
object :: Html -> Html
olist :: Html -> Html
optgroup :: Html -> Html
option :: Html -> Html
paragraph :: Html -> Html
param :: Html
pre :: Html -> Html
quote :: Html -> Html
sample :: Html -> Html
script :: Html -> Html
select :: Html -> Html
small :: Html -> Html
strong :: Html -> Html
style :: Html -> Html
sub :: Html -> Html
sup :: Html -> Html
table :: Html -> Html
tbody :: Html -> Html
td :: Html -> Html
textarea :: Html -> Html
tfoot :: Html -> Html
th :: Html -> Html
thead :: Html -> Html
thebase :: Html
thecode :: Html -> Html
thediv :: Html -> Html
thehtml :: Html -> Html
thelink :: Html -> Html
themap :: Html -> Html
thespan :: Html -> Html
thetitle :: Html -> Html
tr :: Html -> Html
tt :: Html -> Html
ulist :: Html -> Html
variable :: Html -> Html
abbr = tag "abbr"
acronym = tag "acronym"
address = tag "address"
anchor = tag "a"
area = itag "area"
bdo = tag "bdo"
big = tag "big"
blockquote = tag "blockquote"
body = tag "body"
bold = tag "b"
button = tag "button"
br = itag "br"
caption = tag "caption"
cite = tag "cite"
col = tag "col"
colgroup = tag "colgroup"
ddef = tag "dd"
define = tag "dfn"
del = tag "del"
dlist = tag "dl"
dterm = tag "dt"
emphasize = tag "em"
fieldset = tag "fieldset"
form = tag "form"
h1 = tag "h1"
h2 = tag "h2"
h3 = tag "h3"
h4 = tag "h4"
h5 = tag "h5"
h6 = tag "h6"
header = tag "head"
hr = itag "hr"
image = itag "img"
input = itag "input"
ins = tag "ins"
italics = tag "i"
keyboard = tag "kbd"
label = tag "label"
legend = tag "legend"
li = tag "li"
meta = itag "meta"
noscript = tag "noscript"
object = tag "object"
olist = tag "ol"
optgroup = tag "optgroup"
option = tag "option"
paragraph = tag "p"
param = itag "param"
pre = tag "pre"
quote = tag "q"
sample = tag "samp"
script = tag "script"
select = tag "select"
small = tag "small"
strong = tag "strong"
style = tag "style"
sub = tag "sub"
sup = tag "sup"
table = tag "table"
tbody = tag "tbody"
td = tag "td"
textarea = tag "textarea"
tfoot = tag "tfoot"
th = tag "th"
thead = tag "thead"
thebase = itag "base"
thecode = tag "code"
thediv = tag "div"
thehtml = tag "html"
thelink = tag "link"
themap = tag "map"
thespan = tag "span"
thetitle = tag "title"
tr = tag "tr"
tt = tag "tt"
ulist = tag "ul"
variable = tag "var"
xhtml-3000.2.1/Text/XHtml/Strict/Attributes.hs 0000664 0001060 0001060 00000010133 11752502453 017531 0 ustar ross ross {-# OPTIONS_HADDOCK hide #-}
-- #hide
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Text.XHtml.Strict.Attributes where
import Text.XHtml.Internals
-- * Attributes in XHTML Strict
action :: String -> HtmlAttr
align :: String -> HtmlAttr
alt :: String -> HtmlAttr
altcode :: String -> HtmlAttr
archive :: String -> HtmlAttr
base :: String -> HtmlAttr
border :: Int -> HtmlAttr
bordercolor :: String -> HtmlAttr
cellpadding :: Int -> HtmlAttr
cellspacing :: Int -> HtmlAttr
checked :: HtmlAttr
codebase :: String -> HtmlAttr
cols :: String -> HtmlAttr
colspan :: Int -> HtmlAttr
content :: String -> HtmlAttr
coords :: String -> HtmlAttr
disabled :: HtmlAttr
enctype :: String -> HtmlAttr
height :: String -> HtmlAttr
href :: String -> HtmlAttr
hreflang :: String -> HtmlAttr
httpequiv :: String -> HtmlAttr
identifier :: String -> HtmlAttr
ismap :: HtmlAttr
lang :: String -> HtmlAttr
maxlength :: Int -> HtmlAttr
method :: String -> HtmlAttr
multiple :: HtmlAttr
name :: String -> HtmlAttr
nohref :: HtmlAttr
rel :: String -> HtmlAttr
rev :: String -> HtmlAttr
rows :: String -> HtmlAttr
rowspan :: Int -> HtmlAttr
rules :: String -> 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
action = strAttr "action"
align = strAttr "align"
alt = strAttr "alt"
altcode = strAttr "altcode"
archive = strAttr "archive"
base = strAttr "base"
border = intAttr "border"
bordercolor = strAttr "bordercolor"
cellpadding = intAttr "cellpadding"
cellspacing = intAttr "cellspacing"
checked = emptyAttr "checked"
codebase = strAttr "codebase"
cols = strAttr "cols"
colspan = intAttr "colspan"
content = strAttr "content"
coords = strAttr "coords"
disabled = emptyAttr "disabled"
enctype = strAttr "enctype"
height = strAttr "height"
href = strAttr "href"
hreflang = strAttr "hreflang"
httpequiv = strAttr "http-equiv"
identifier = strAttr "id"
ismap = emptyAttr "ismap"
lang = strAttr "lang"
maxlength = intAttr "maxlength"
method = strAttr "method"
multiple = emptyAttr "multiple"
name = strAttr "name"
nohref = emptyAttr "nohref"
rel = strAttr "rel"
rev = strAttr "rev"
rows = strAttr "rows"
rowspan = intAttr "rowspan"
rules = strAttr "rules"
selected = emptyAttr "selected"
shape = strAttr "shape"
size = strAttr "size"
src = strAttr "src"
theclass = strAttr "class"
thefor = strAttr "for"
thestyle = strAttr "style"
thetype = strAttr "type"
title = strAttr "title"
usemap = strAttr "usemap"
valign = strAttr "valign"
value = strAttr "value"
width = strAttr "width"
xhtml-3000.2.1/Text/XHtml/Extras.hs 0000664 0001060 0001060 00000006670 11752502453 015414 0 ustar ross ross #if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Text.XHtml.Extras where
import Text.XHtml.Internals
import Text.XHtml.Strict.Elements
import Text.XHtml.Strict.Attributes
--
-- * Converting strings to HTML
--
-- | Convert a 'String' to 'Html', converting
-- characters that need to be escaped to HTML entities.
stringToHtml :: String -> Html
stringToHtml = primHtml . stringToHtmlString
-- | This converts a string, but keeps spaces as non-line-breakable.
lineToHtml :: String -> Html
lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString
where
htmlizeChar2 ' ' = " "
htmlizeChar2 c = [c]
-- | 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:xs) = lineToHtml x +++ br +++ linesToHtml xs
--
-- * Html abbreviations
--
primHtmlChar :: String -> Html
-- | Copyright sign.
copyright :: Html
-- | Non-breaking space.
spaceHtml :: Html
bullet :: Html
primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";")
copyright = primHtmlChar "copy"
spaceHtml = primHtmlChar "nbsp"
bullet = primHtmlChar "#149"
-- | Same as 'paragraph'.
p :: Html -> Html
p = paragraph
--
-- * Hotlinks
--
type URL = String
data HotLink = HotLink {
hotLinkURL :: URL,
hotLinkContents :: Html,
hotLinkAttributes :: [HtmlAttr]
} deriving Show
instance HTML HotLink where
toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)
<< hotLinkContents hl
instance ADDATTRS HotLink where
hl ! attr = hl { hotLinkAttributes = hotLinkAttributes hl ++ attr }
hotlink :: URL -> Html -> HotLink
hotlink url h = HotLink {
hotLinkURL = url,
hotLinkContents = h,
hotLinkAttributes = [] }
--
-- * Lists
--
-- (Abridged from Erik Meijer's Original Html library)
ordList :: (HTML a) => [a] -> Html
ordList items = olist << map (li <<) items
unordList :: (HTML a) => [a] -> Html
unordList items = ulist << map (li <<) items
defList :: (HTML a,HTML b) => [(a,b)] -> Html
defList items
= dlist << [ [ dterm << dt, ddef << dd ] | (dt,dd) <- items ]
--
-- * Forms
--
widget :: String -> String -> [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
checkbox n v = widget "checkbox" n [value v]
hidden n v = widget "hidden" n [value v]
radio n v = widget "radio" n [value v]
reset n v = widget "reset" n [value v]
submit n v = widget "submit" n [value v]
password n = widget "password" n []
textfield n = widget "text" n []
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 n choices
= select ! [name n] << [ option << p << choice | choice <- choices ]
gui :: String -> Html -> Html
gui act = form ! [action act,method "post"]
xhtml-3000.2.1/Text/XHtml/Debug.hs 0000664 0001060 0001060 00000007366 11752502453 015177 0 ustar ross ross {-# OPTIONS_HADDOCK hide #-}
-- #hide
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
-- | This module contains functions for displaying
-- HTML as a pretty tree.
module Text.XHtml.Debug ( HtmlTree(..), treeHtml, treeColors, debugHtml ) where
import Text.XHtml.Internals
import Text.XHtml.Extras
import Text.XHtml.Table
import Text.XHtml.Strict.Elements
import Text.XHtml.Strict.Attributes
--
-- * Tree Displaying Combinators
--
-- | The basic idea is you render your structure in the form
-- of this tree, and then use treeHtml to turn it into a Html
-- object with the structure explicit.
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 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"
instance HTML HtmlTree where
toHtml x = treeHtml treeColors x
-- type "length treeColors" to see how many colors are here.
treeColors :: [String]
treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
--
-- * Html Debugging Combinators
--
-- | This uses the above tree rendering function, and displays the
-- Html as a tree structure, allowing debugging of what is
-- actually getting produced.
debugHtml :: (HTML a) => a -> Html
debugHtml obj = table ! [border 0] <<
( th ! [bgcolor' "#008888"]
<< underline'
<< "Debugging Output"
td << (toHtml (debug' (toHtml obj)))
)
where
debug' :: Html -> [HtmlTree]
debug' (Html markups) = map debug markups
debug :: HtmlElement -> HtmlTree
debug (HtmlString str) = HtmlLeaf (spaceHtml +++
linesToHtml (lines str))
debug (HtmlTag {
markupTag = tag',
markupContent = content',
markupAttrs = attrs
}) =
case content' of
Html [] -> HtmlNode hd [] noHtml
Html xs -> HtmlNode hd (map debug xs) tl
where
args = if null attrs
then ""
else " " ++ unwords (map show attrs)
hd = xsmallFont << ("<" ++ tag' ++ args ++ ">")
tl = xsmallFont << ("")
bgcolor' :: String -> HtmlAttr
bgcolor' c = thestyle ("background-color:" ++ c)
underline' :: Html -> Html
underline' = thespan ! [thestyle ("text-decoration:underline")]
xsmallFont :: Html -> Html
xsmallFont = thespan ! [thestyle ("font-size:x-small")]
xhtml-3000.2.1/Text/XHtml/Frameset/ 0000775 0001060 0001060 00000000000 11752502453 015347 5 ustar ross ross xhtml-3000.2.1/Text/XHtml/Frameset/Elements.hs 0000664 0001060 0001060 00000000657 11752502453 017467 0 ustar ross ross {-# OPTIONS_HADDOCK hide #-}
-- #hide
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Text.XHtml.Frameset.Elements where
import Text.XHtml.Internals
-- * Extra elements in XHTML Frameset
frame :: Html -> Html
frame = tag "frame"
frameset :: Html -> Html
frameset = tag "frameset"
noframes :: Html -> Html
noframes = tag "noframes"
xhtml-3000.2.1/Text/XHtml/Frameset/Attributes.hs 0000664 0001060 0001060 00000001216 11752502453 020031 0 ustar ross ross {-# OPTIONS_HADDOCK hide #-}
-- #hide
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Text.XHtml.Frameset.Attributes where
import Text.XHtml.Internals
-- * Extra attributes in XHTML Frameset
frameborder :: Int -> HtmlAttr
frameborder = intAttr "frameborder"
marginheight :: Int -> HtmlAttr
marginheight = intAttr "marginheight"
marginwidth :: Int -> HtmlAttr
marginwidth = intAttr "marginwidth"
noresize :: HtmlAttr
noresize = emptyAttr "noresize"
scrolling :: String -> HtmlAttr
scrolling = strAttr "scrolling"
xhtml-3000.2.1/Text/XHtml/Frameset.hs 0000664 0001060 0001060 00000003600 11752505630 015702 0 ustar ross ross #if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
-- | Produces XHTML 1.0 Frameset.
module Text.XHtml.Frameset (
-- * Data types
Html, HtmlAttr,
-- * Classes
HTML(..), ADDATTRS(..), CHANGEATTRS(..),
-- * Primitives and basic combinators
(<<), concatHtml, (+++),
noHtml, isNoHtml, tag, itag,
htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr,
primHtml,
-- * Rendering
showHtml, renderHtml, prettyHtml,
showHtmlFragment, renderHtmlFragment, prettyHtmlFragment,
module Text.XHtml.Strict.Elements,
module Text.XHtml.Frameset.Elements,
module Text.XHtml.Strict.Attributes,
module Text.XHtml.Frameset.Attributes,
module Text.XHtml.Extras
) where
import Text.XHtml.Internals
import Text.XHtml.Strict.Elements
import Text.XHtml.Frameset.Elements
import Text.XHtml.Strict.Attributes
import Text.XHtml.Frameset.Attributes
import Text.XHtml.Extras
docType :: String
docType =
""
-- | 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
showHtml = showHtmlInternal docType
-- | Outputs indented HTML. Because space matters in
-- HTML, the output is quite messy.
renderHtml :: HTML html => html -> String
renderHtml = renderHtmlInternal docType
-- | Outputs indented HTML, with indentation inside elements.
-- 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
xhtml-3000.2.1/Text/XHtml/Transitional.hs 0000664 0001060 0001060 00000004102 11752505315 016601 0 ustar ross ross #if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
-- | Produces XHTML 1.0 Transitional.
module Text.XHtml.Transitional (
-- * Data types
Html, HtmlAttr,
-- * Classes
HTML(..), ADDATTRS(..), CHANGEATTRS(..),
-- * Primitives and basic combinators
(<<), concatHtml, (+++),
noHtml, isNoHtml, tag, itag,
htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr,
primHtml,
-- * Rendering
showHtml, renderHtml, prettyHtml,
showHtmlFragment, renderHtmlFragment, prettyHtmlFragment,
module Text.XHtml.Strict.Elements,
module Text.XHtml.Frameset.Elements,
module Text.XHtml.Transitional.Elements,
module Text.XHtml.Strict.Attributes,
module Text.XHtml.Frameset.Attributes,
module Text.XHtml.Transitional.Attributes,
module Text.XHtml.Extras
) where
import Text.XHtml.Internals
import Text.XHtml.Strict.Elements
import Text.XHtml.Frameset.Elements
import Text.XHtml.Transitional.Elements
import Text.XHtml.Strict.Attributes
import Text.XHtml.Frameset.Attributes
import Text.XHtml.Transitional.Attributes
import Text.XHtml.Extras
docType :: String
docType =
""
-- | 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
showHtml = showHtmlInternal docType
-- | Outputs indented HTML. Because space matters in
-- HTML, the output is quite messy.
renderHtml :: HTML html => html -> String
renderHtml = renderHtmlInternal docType
-- | Outputs indented HTML, with indentation inside elements.
-- 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
xhtml-3000.2.1/Text/XHtml/Table.hs 0000664 0001060 0001060 00000007036 11752502453 015172 0 ustar ross ross {-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
-- | Table combinators for XHTML.
module Text.XHtml.Table (HtmlTable, HTMLTABLE(..),
(), above, (<->), beside,
aboves, besides,
simpleTable) where
import Text.XHtml.Internals
import Text.XHtml.Strict.Elements
import Text.XHtml.Strict.Attributes
import qualified Text.XHtml.BlockTable as BT
infixr 3 -- combining table cells
infixr 4 <-> -- combining table cells
--
-- * Tables
--
class HTMLTABLE ht where
cell :: ht -> HtmlTable
instance HTMLTABLE HtmlTable where
cell = id
instance HTMLTABLE Html where
cell h =
let
cellFn x y = h ! (add x colspan $ add y rowspan $ [])
add 1 _ rest = rest
add n fn rest = fn n : rest
r = BT.single cellFn
in
mkHtmlTable r
-- | We internally represent the Cell inside a Table with an
-- object of the type
--
-- > Int -> Int -> Html
--
-- When we render it later, we find out how many columns
-- or rows this cell will span over, and can
-- include the correct colspan\/rowspan command.
newtype HtmlTable
= HtmlTable (BT.BlockTable (Int -> Int -> Html))
mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
mkHtmlTable r = HtmlTable r
-- We give both infix and nonfix, take your pick.
-- Notice that there is no concept of a row/column
-- of zero items.
(),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
=> ht1 -> ht2 -> HtmlTable
above a b = combine BT.above (cell a) (cell b)
() = above
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.
-- here is no concept of a empty row or column in these
-- table combinators.
aboves :: (HTMLTABLE ht) => [ht] -> HtmlTable
aboves [] = error "aboves []"
aboves xs = foldr1 () (map cell xs)
besides :: (HTMLTABLE ht) => [ht] -> HtmlTable
besides [] = error "besides []"
besides xs = foldr1 (<->) (map cell xs)
-- | renderTable takes the HtmlTable, and renders it back into
-- and Html object.
renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
renderTable theTable
= concatHtml
[tr << [theCell x y | (theCell,(x,y)) <- theRow ]
| theRow <- BT.getMatrix theTable]
instance HTML HtmlTable where
toHtml (HtmlTable tab) = renderTable tab
instance Show HtmlTable where
showsPrec _ (HtmlTable tab) = shows (renderTable tab)
-- | If you can't be bothered with the above, then you
-- can build simple tables with simpleTable.
-- Just provide the attributes for the whole table,
-- attributes for the cells (same for every cell),
-- and a list of lists of cell contents,
-- and this function will build the table for you.
-- It does presume that all the lists are non-empty,
-- and there is at least one list.
--
-- Different length lists means that the last cell
-- gets padded. If you want more power, then
-- use the system above, or build tables explicitly.
simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html
simpleTable attr cellAttr lst
= table ! attr
<< (aboves
. map (besides . map ((td ! cellAttr) . toHtml))
) lst
xhtml-3000.2.1/Text/XHtml/Strict.hs 0000664 0001060 0001060 00000004656 11752505370 015421 0 ustar ross ross #if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
-- | Produces XHTML 1.0 Strict.
module Text.XHtml.Strict (
-- * Data types
Html, HtmlAttr,
-- * Classes
HTML(..), ADDATTRS(..), CHANGEATTRS(..),
-- * Primitives and basic combinators
(<<), concatHtml, (+++),
noHtml, isNoHtml, tag, itag,
htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr,
primHtml, stringToHtmlString,
docType,
-- * Rendering
showHtml, renderHtml, renderHtmlWithLanguage, prettyHtml,
showHtmlFragment, renderHtmlFragment, prettyHtmlFragment,
module Text.XHtml.Strict.Elements,
module Text.XHtml.Strict.Attributes,
module Text.XHtml.Extras
) where
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 = ""
-- | 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
showHtml = showHtmlInternal docType
-- | Outputs indented HTML. Because space matters in
-- HTML, the output is quite messy.
renderHtml :: HTML html => html -> String
renderHtml = renderHtmlInternal docType
-- | 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.
-> html -- ^ All the 'Html', including a header.
-> String
renderHtmlWithLanguage l theHtml =
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
-- | Outputs indented HTML, with indentation inside elements.
-- 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
xhtml-3000.2.1/Text/XHtml/BlockTable.hs 0000664 0001060 0001060 00000011057 11752502453 016143 0 ustar ross ross #if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
-----------------------------------------------------------------------------
-- |
-- 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 : Chris Dornan
-- Stability : Stable
-- Portability : Portable
--
-- An XHTML combinator library
--
-- These combinators can be used to build formated 2D tables.
-- The specific target usage is for HTML table generation.
-----------------------------------------------------------------------------
{-
Examples of use:
> table1 :: BlockTable String
> table1 = single "Hello" +-----+
|Hello|
This is a 1x1 cell +-----+
Note: single has type
single :: a -> BlockTable a
So the cells can contain anything.
> table2 :: BlockTable String
> table2 = single "World" +-----+
|World|
+-----+
> table3 :: BlockTable String
> table3 = table1 %-% table2 +-----%-----+
|Hello%World|
% is used to indicate +-----%-----+
the join edge between
the two Tables.
> table4 :: BlockTable String
> table4 = table3 %/% table2 +-----+-----+
|Hello|World|
Notice the padding on the %%%%%%%%%%%%%
smaller (bottom) cell to |World |
force the table to be a +-----------+
rectangle.
> table5 :: BlockTable String
> table5 = table1 %-% table4 +-----%-----+-----+
|Hello%Hello|World|
Notice the padding on the | %-----+-----+
leftmost cell, again to | %World |
force the table to be a +-----%-----------+
rectangle.
Now the table can be rendered with processTable, for example:
Main> processTable table5
[[("Hello",(1,2)),
("Hello",(1,1)),
("World",(1,1))],
[("World",(2,1))]] :: [[([Char],(Int,Int))]]
Main>
-}
module Text.XHtml.BlockTable (
-- * Datatypes
BlockTable,
-- * Contruction Functions
single,
above,
beside,
-- * Investigation Functions
getMatrix,
showsTable,
showTable,
) where
infixr 4 `beside`
infixr 3 `above`
--
-- * Construction Functions
--
-- Perhaps one day I'll write the Show instance
-- to show boxes aka the above ascii renditions.
instance (Show a) => Show (BlockTable a) where
showsPrec _ = showsTable
type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]]
data BlockTable a = Table (Int -> Int -> TableI a) Int Int
-- | Creates a (1x1) table entry
single :: a -> BlockTable a
single a = Table (\ x y z -> [(a,(x+1,y+1))] : z) 1 1
-- | Composes tables vertically.
above :: BlockTable a -> BlockTable a -> BlockTable a
-- | Composes tables horizontally.
beside :: BlockTable a -> BlockTable a -> BlockTable a
t1 `above` t2 = trans (combine (trans t1) (trans t2) (.))
t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r ->
let
-- Note this depends on the fact that
-- that the result has the same number
-- of lines as the y dimention; 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
in
beside' (lst1 []) (lst2 []))
-- | trans flips (transposes) over the x and y axis of
-- the table. It is only used internally, and typically
-- in pairs, ie. (flip ... munge ... (un)flip).
trans :: BlockTable a -> BlockTable a
trans (Table f1 x1 y1) = Table (flip f1) y1 x1
combine :: BlockTable a
-> BlockTable b
-> (TableI a -> TableI b -> TableI c)
-> BlockTable c
combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y
where
max_y = max y1 y2
new_fn x y =
case compare y1 y2 of
EQ -> comb (f1 0 y) (f2 x y)
GT -> comb (f1 0 y) (f2 x (y + y1 - y2))
LT -> comb (f1 0 (y + y2 - y1)) (f2 x y)
--
-- * Investigation Functions
--
-- | This is the other thing you can do with a Table;
-- turn it into a 2D list, tagged with the (x,y)
-- sizes of each cell in the table.
getMatrix :: BlockTable a -> [[(a,(Int,Int))]]
getMatrix (Table r _ _) = r 0 0 []
-- You can also look at a table
showsTable :: (Show a) => BlockTable a -> ShowS
showsTable table = shows (getMatrix table)
showTable :: (Show a) => BlockTable a -> String
showTable table = showsTable table ""
xhtml-3000.2.1/LICENSE 0000664 0001060 0001060 00000003151 11752502453 012626 0 ustar ross ross Copyright 2001-2005, The University Court of the University of
Glasgow, Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer, Sven Panne
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
- Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
- Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
- Neither name of the University nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
xhtml-3000.2.1/xhtml.cabal 0000664 0001060 0001060 00000003201 11752532347 013742 0 ustar ross ross Name: xhtml
Version: 3000.2.1
Copyright: Bjorn Bringert 2004-2006, Andy Gill and the Oregon
Graduate Institute of Science and Technology, 1999-2001
Maintainer: Chris Dornan
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
Build-type: Simple
Cabal-version: >= 1.6
Source-repository head
type: git
location: https://github.com/haskell/xhtml
library
Build-depends: base >= 4.0 && < 5.0
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
Extensions: CPP
xhtml-3000.2.1/Setup.hs 0000664 0001060 0001060 00000000127 11752502453 013255 0 ustar ross ross module Main (main) where
import Distribution.Simple
main :: IO ()
main = defaultMain
xhtml-3000.2.1/README 0000664 0001060 0001060 00000000165 11752502453 012503 0 ustar ross ross This package provides combinators for producing XHTML 1.0, including
the Strict, Transitional and Frameset variants.