html (empty) → 1.0
raw patch · 5 files changed
+1241/−0 lines, 5 filesdep +basebuild-type:Customsetup-changed
Dependencies added: base
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- Text/Html.hs +1024/−0
- Text/Html/BlockTable.hs +175/−0
- html.cabal +13/−0
+ LICENSE view
@@ -0,0 +1,27 @@+The Haskell Html Library is Copyright (c) Andy Gill, and the Oregon+Graduate Institute of Science and Technology, 1999, All rights+reserved, and is distributed as free software under the following+license.++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.++- Neither name of the copyright holders 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 COPYRIGHT HOLDERS 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 COPYRIGHT+HOLDERS 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Html.hs view
@@ -0,0 +1,1024 @@+-----------------------------------------------------------------------------+-- |+-- Module : Text.Html+-- Copyright : (c) Andy Gill and OGI, 1999-2001+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : Andy Gill <andy@galconn.com>+-- Stability : provisional+-- Portability : portable+--+-- An Html combinator library+--+-----------------------------------------------------------------------------++module Text.Html (+ module Text.Html,+ ) where++import qualified Text.Html.BlockTable as BT++infixr 3 </> -- combining table cells +infixr 4 <-> -- combining table cells+infixr 2 +++ -- combining Html+infixr 7 << -- nesting Html+infixl 8 ! -- adding optional arguments+++-- A important property of Html is that all strings inside the+-- structure are already in Html friendly format.+-- For example, use of >,etc.++data HtmlElement+{-+ - ..just..plain..normal..text... but using © and &amb;, etc.+ -}+ = HtmlString String+{-+ - <thetag {..attrs..}> ..content.. </thetag>+ -}+ | HtmlTag { -- tag with internal markup+ markupTag :: String,+ markupAttrs :: [HtmlAttr],+ markupContent :: Html+ }++{- These are the index-value pairs.+ - The empty string is a synonym for tags with no arguments.+ - (not strictly HTML, but anyway).+ -}+++data HtmlAttr = HtmlAttr String String+++newtype Html = Html { getHtmlElements :: [HtmlElement] }++-- Read MARKUP as the class of things that can be validly rendered+-- inside MARKUP tag brackets. So this can be one or more Html's,+-- 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++class ADDATTRS a where+ (!) :: a -> [HtmlAttr] -> a++instance (ADDATTRS b) => ADDATTRS (a -> b) where+ fn ! attr = \ arg -> fn arg ! attr++instance ADDATTRS Html where+ (Html htmls) ! attr = Html (map addAttrs htmls)+ where+ addAttrs (html@(HtmlTag { markupAttrs = markupAttrs }) )+ = html { markupAttrs = markupAttrs ++ attr }+ addAttrs html = html+++(<<) :: (HTML a) => (Html -> b) -> a -> b+fn << arg = fn (toHtml arg)+++concatHtml :: (HTML a) => [a] -> Html+concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))++(+++) :: (HTML a,HTML b) => a -> b -> Html+a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))++noHtml :: Html+noHtml = Html []+++isNoHtml (Html xs) = null xs+++tag :: String -> Html -> Html+tag str htmls = Html [+ HtmlTag {+ markupTag = str,+ markupAttrs = [],+ markupContent = htmls }]++itag :: String -> Html+itag str = tag str noHtml++emptyAttr :: String -> HtmlAttr+emptyAttr s = HtmlAttr s ""++intAttr :: String -> Int -> HtmlAttr+intAttr s i = HtmlAttr s (show i)++strAttr :: String -> String -> HtmlAttr+strAttr s t = HtmlAttr s 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.+-- This converts a String to a Html String.+stringToHtmlString :: String -> String+stringToHtmlString = concatMap fixChar+ where+ fixChar '<' = "<"+ fixChar '>' = ">"+ fixChar '&' = "&"+ fixChar '"' = """+ fixChar c = [c] ++-- ---------------------------------------------------------------------------+-- Classes++instance Show Html where+ showsPrec _ html = showString (prettyHtml html)+ showList htmls = showString (concat (map show htmls))++instance Show HtmlAttr where+ showsPrec _ (HtmlAttr str val) = + showString str .+ showString "=" .+ shows val+++-- ---------------------------------------------------------------------------+-- Data types++type URL = String++-- ---------------------------------------------------------------------------+-- Basic primitives++-- 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 = Html [HtmlString x]++-- ---------------------------------------------------------------------------+-- Basic Combinators++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]++-- ---------------------------------------------------------------------------+-- Html Constructors++-- (automatically generated)++address :: Html -> Html+anchor :: Html -> Html+applet :: Html -> Html+area :: Html+basefont :: Html+big :: Html -> Html+blockquote :: Html -> Html+body :: Html -> Html+bold :: Html -> Html+br :: Html+caption :: Html -> Html+center :: Html -> Html+cite :: Html -> Html+ddef :: Html -> Html+define :: Html -> Html+dlist :: Html -> Html+dterm :: Html -> Html+emphasize :: Html -> Html+fieldset :: Html -> Html+font :: Html -> Html+form :: Html -> Html+frame :: Html -> Html+frameset :: 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+italics :: Html -> Html+keyboard :: Html -> Html+legend :: Html -> Html+li :: Html -> Html+meta :: Html+noframes :: Html -> Html+olist :: Html -> Html+option :: Html -> Html+paragraph :: Html -> Html+param :: Html+pre :: Html -> Html+sample :: Html -> Html+select :: Html -> Html+small :: Html -> Html+strong :: Html -> Html+style :: Html -> Html+sub :: Html -> Html+sup :: Html -> Html+table :: Html -> Html+td :: Html -> Html+textarea :: Html -> Html+th :: 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+underline :: Html -> Html+variable :: Html -> Html++address = tag "ADDRESS"+anchor = tag "A"+applet = tag "APPLET"+area = itag "AREA"+basefont = itag "BASEFONT"+big = tag "BIG"+blockquote = tag "BLOCKQUOTE"+body = tag "BODY"+bold = tag "B"+br = itag "BR"+caption = tag "CAPTION"+center = tag "CENTER"+cite = tag "CITE"+ddef = tag "DD"+define = tag "DFN"+dlist = tag "DL"+dterm = tag "DT"+emphasize = tag "EM"+fieldset = tag "FIELDSET"+font = tag "FONT"+form = tag "FORM"+frame = tag "FRAME"+frameset = tag "FRAMESET"+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"+italics = tag "I"+keyboard = tag "KBD"+legend = tag "LEGEND"+li = tag "LI"+meta = itag "META"+noframes = tag "NOFRAMES"+olist = tag "OL"+option = tag "OPTION"+paragraph = tag "P"+param = itag "PARAM"+pre = tag "PRE"+sample = tag "SAMP"+select = tag "SELECT"+small = tag "SMALL"+strong = tag "STRONG"+style = tag "STYLE"+sub = tag "SUB"+sup = tag "SUP"+table = tag "TABLE"+td = tag "TD"+textarea = tag "TEXTAREA"+th = tag "TH"+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"+underline = tag "U"+variable = tag "VAR"++-- ---------------------------------------------------------------------------+-- Html Attributes++-- (automatically generated)++action :: String -> HtmlAttr+align :: String -> HtmlAttr+alink :: String -> HtmlAttr+alt :: String -> HtmlAttr+altcode :: String -> HtmlAttr+archive :: String -> HtmlAttr+background :: String -> HtmlAttr+base :: String -> HtmlAttr+bgcolor :: String -> HtmlAttr+border :: Int -> HtmlAttr+bordercolor :: String -> HtmlAttr+cellpadding :: Int -> HtmlAttr+cellspacing :: Int -> HtmlAttr+checked :: HtmlAttr+clear :: String -> HtmlAttr+code :: String -> HtmlAttr+codebase :: String -> HtmlAttr+color :: String -> HtmlAttr+cols :: String -> HtmlAttr+colspan :: Int -> HtmlAttr+compact :: HtmlAttr+content :: String -> HtmlAttr+coords :: String -> HtmlAttr+enctype :: String -> HtmlAttr+face :: String -> HtmlAttr+frameborder :: Int -> HtmlAttr+height :: Int -> HtmlAttr+href :: String -> HtmlAttr+hspace :: Int -> HtmlAttr+httpequiv :: String -> HtmlAttr+identifier :: String -> HtmlAttr+ismap :: HtmlAttr+lang :: String -> HtmlAttr+link :: String -> HtmlAttr+marginheight :: Int -> HtmlAttr+marginwidth :: Int -> HtmlAttr+maxlength :: Int -> HtmlAttr+method :: String -> HtmlAttr+multiple :: HtmlAttr+name :: String -> HtmlAttr+nohref :: HtmlAttr+noresize :: HtmlAttr+noshade :: HtmlAttr+nowrap :: HtmlAttr+rel :: String -> HtmlAttr+rev :: String -> HtmlAttr+rows :: String -> HtmlAttr+rowspan :: Int -> HtmlAttr+rules :: String -> HtmlAttr+scrolling :: String -> HtmlAttr+selected :: HtmlAttr+shape :: String -> HtmlAttr+size :: String -> HtmlAttr+src :: String -> HtmlAttr+start :: Int -> HtmlAttr+target :: String -> HtmlAttr+text :: String -> HtmlAttr+theclass :: String -> HtmlAttr+thestyle :: String -> HtmlAttr+thetype :: String -> HtmlAttr+title :: String -> HtmlAttr+usemap :: String -> HtmlAttr+valign :: String -> HtmlAttr+value :: String -> HtmlAttr+version :: String -> HtmlAttr+vlink :: String -> HtmlAttr+vspace :: Int -> HtmlAttr+width :: String -> HtmlAttr++action = strAttr "ACTION"+align = strAttr "ALIGN"+alink = strAttr "ALINK"+alt = strAttr "ALT"+altcode = strAttr "ALTCODE"+archive = strAttr "ARCHIVE"+background = strAttr "BACKGROUND"+base = strAttr "BASE"+bgcolor = strAttr "BGCOLOR"+border = intAttr "BORDER"+bordercolor = strAttr "BORDERCOLOR"+cellpadding = intAttr "CELLPADDING"+cellspacing = intAttr "CELLSPACING"+checked = emptyAttr "CHECKED"+clear = strAttr "CLEAR"+code = strAttr "CODE"+codebase = strAttr "CODEBASE"+color = strAttr "COLOR"+cols = strAttr "COLS"+colspan = intAttr "COLSPAN"+compact = emptyAttr "COMPACT"+content = strAttr "CONTENT"+coords = strAttr "COORDS"+enctype = strAttr "ENCTYPE"+face = strAttr "FACE"+frameborder = intAttr "FRAMEBORDER"+height = intAttr "HEIGHT"+href = strAttr "HREF"+hspace = intAttr "HSPACE"+httpequiv = strAttr "HTTP-EQUIV"+identifier = strAttr "ID"+ismap = emptyAttr "ISMAP"+lang = strAttr "LANG"+link = strAttr "LINK"+marginheight = intAttr "MARGINHEIGHT"+marginwidth = intAttr "MARGINWIDTH"+maxlength = intAttr "MAXLENGTH"+method = strAttr "METHOD"+multiple = emptyAttr "MULTIPLE"+name = strAttr "NAME"+nohref = emptyAttr "NOHREF"+noresize = emptyAttr "NORESIZE"+noshade = emptyAttr "NOSHADE"+nowrap = emptyAttr "NOWRAP"+rel = strAttr "REL"+rev = strAttr "REV"+rows = strAttr "ROWS"+rowspan = intAttr "ROWSPAN"+rules = strAttr "RULES"+scrolling = strAttr "SCROLLING"+selected = emptyAttr "SELECTED"+shape = strAttr "SHAPE"+size = strAttr "SIZE"+src = strAttr "SRC"+start = intAttr "START"+target = strAttr "TARGET"+text = strAttr "TEXT"+theclass = strAttr "CLASS"+thestyle = strAttr "STYLE"+thetype = strAttr "TYPE"+title = strAttr "TITLE"+usemap = strAttr "USEMAP"+valign = strAttr "VALIGN"+value = strAttr "VALUE"+version = strAttr "VERSION"+vlink = strAttr "VLINK"+vspace = intAttr "VSPACE"+width = strAttr "WIDTH"++-- ---------------------------------------------------------------------------+-- Html Constructors++-- (automatically generated)++validHtmlTags :: [String]+validHtmlTags = [+ "ADDRESS",+ "A",+ "APPLET",+ "BIG",+ "BLOCKQUOTE",+ "BODY",+ "B",+ "CAPTION",+ "CENTER",+ "CITE",+ "DD",+ "DFN",+ "DL",+ "DT",+ "EM",+ "FIELDSET",+ "FONT",+ "FORM",+ "FRAME",+ "FRAMESET",+ "H1",+ "H2",+ "H3",+ "H4",+ "H5",+ "H6",+ "HEAD",+ "I",+ "KBD",+ "LEGEND",+ "LI",+ "NOFRAMES",+ "OL",+ "OPTION",+ "P",+ "PRE",+ "SAMP",+ "SELECT",+ "SMALL",+ "STRONG",+ "STYLE",+ "SUB",+ "SUP",+ "TABLE",+ "TD",+ "TEXTAREA",+ "TH",+ "CODE",+ "DIV",+ "HTML",+ "LINK",+ "MAP",+ "TITLE",+ "TR",+ "TT",+ "UL",+ "U",+ "VAR"]++validHtmlITags :: [String]+validHtmlITags = [+ "AREA",+ "BASEFONT",+ "BR",+ "HR",+ "IMG",+ "INPUT",+ "META",+ "PARAM",+ "BASE"]++validHtmlAttrs :: [String]+validHtmlAttrs = [+ "ACTION",+ "ALIGN",+ "ALINK",+ "ALT",+ "ALTCODE",+ "ARCHIVE",+ "BACKGROUND",+ "BASE",+ "BGCOLOR",+ "BORDER",+ "BORDERCOLOR",+ "CELLPADDING",+ "CELLSPACING",+ "CHECKED",+ "CLEAR",+ "CODE",+ "CODEBASE",+ "COLOR",+ "COLS",+ "COLSPAN",+ "COMPACT",+ "CONTENT",+ "COORDS",+ "ENCTYPE",+ "FACE",+ "FRAMEBORDER",+ "HEIGHT",+ "HREF",+ "HSPACE",+ "HTTP-EQUIV",+ "ID",+ "ISMAP",+ "LANG",+ "LINK",+ "MARGINHEIGHT",+ "MARGINWIDTH",+ "MAXLENGTH",+ "METHOD",+ "MULTIPLE",+ "NAME",+ "NOHREF",+ "NORESIZE",+ "NOSHADE",+ "NOWRAP",+ "REL",+ "REV",+ "ROWS",+ "ROWSPAN",+ "RULES",+ "SCROLLING",+ "SELECTED",+ "SHAPE",+ "SIZE",+ "SRC",+ "START",+ "TARGET",+ "TEXT",+ "CLASS",+ "STYLE",+ "TYPE",+ "TITLE",+ "USEMAP",+ "VALIGN",+ "VALUE",+ "VERSION",+ "VLINK",+ "VSPACE",+ "WIDTH"]++-- ---------------------------------------------------------------------------+-- Html colors++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"++-- ---------------------------------------------------------------------------+-- Basic Combinators++linesToHtml :: [String] -> Html++linesToHtml [] = noHtml+linesToHtml (x:[]) = lineToHtml x+linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs+++-- ---------------------------------------------------------------------------+-- Html abbriviations++primHtmlChar :: String -> Html+copyright :: Html+spaceHtml :: Html+bullet :: Html+p :: Html -> Html++primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";")+copyright = primHtmlChar "copy"+spaceHtml = primHtmlChar "nbsp"+bullet = primHtmlChar "#149"++p = paragraph++-- ---------------------------------------------------------------------------+-- Html 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 fn 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+-- \pre{+-- 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))+++(</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)+ => ht1 -> ht2 -> HtmlTable+aboves,besides :: (HTMLTABLE ht) => [ht] -> HtmlTable+simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> 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 a b = combine BT.above (cell a) (cell b)+(</>) = above+beside a b = combine BT.beside (cell a) (cell b)+(<->) = beside+++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 [] = error "aboves []"+aboves xs = foldr1 (</>) (map cell xs)+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 attr cellAttr lst+ = table ! attr + << (aboves + . map (besides . map ((td ! cellAttr) . toHtml))+ ) lst+++-- ---------------------------------------------------------------------------+-- 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' (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"++instance HTML HtmlTree where+ toHtml x = treeHtml treeColors x++-- type "length treeColors" to see how many colors are here.+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 = markupTag,+ markupContent = markupContent,+ markupAttrs = markupAttrs+ }) =+ case markupContent of+ Html [] -> HtmlNode hd [] noHtml+ Html xs -> HtmlNode hd (map debug xs) tl+ where+ args = if null markupAttrs+ then ""+ else " " ++ unwords (map show markupAttrs) + hd = font ! [size "1"] << ("<" ++ markupTag ++ args ++ ">")+ tl = font ! [size "1"] << ("</" ++ markupTag ++ ">")++-- ---------------------------------------------------------------------------+-- Hotlink datatype++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++hotlink :: URL -> [Html] -> HotLink+hotlink url h = HotLink {+ hotLinkURL = url,+ hotLinkContents = h,+ hotLinkAttributes = [] }+++-- ---------------------------------------------------------------------------+-- More Combinators++-- (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 << bold << dt, ddef << dd ] | (dt,dd) <- items ]+++widget :: String -> String -> [HtmlAttr] -> Html+widget w n markupAttrs = input ! ([thetype w,name n] ++ markupAttrs)++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 []++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"]++-- ---------------------------------------------------------------------------+-- Html Rendering+ +-- Uses the append trick to optimize appending.+-- The output is quite messy, because space matters in+-- HTML, so we must not generate needless spaces.++renderHtml :: (HTML html) => html -> String+renderHtml theHtml =+ renderMessage ++ + foldr (.) id (map (renderHtml' 0)+ (getHtmlElements (tag "HTML" << theHtml))) "\n"++renderMessage =+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 FINAL//EN\">\n" +++ "<!--Rendered using the Haskell Html Library v0.2-->\n"++-- Warning: spaces matters in HTML. You are better using renderHtml.+-- This is intentually very inefficent to "encorage" this,+-- but the neater version in easier when debugging.++-- Local Utilities+prettyHtml :: (HTML html) => html -> String+prettyHtml theHtml = + unlines+ $ concat+ $ map prettyHtml'+ $ getHtmlElements+ $ toHtml theHtml++renderHtml' :: Int -> HtmlElement -> ShowS+renderHtml' _ (HtmlString str) = (++) str+renderHtml' n (HtmlTag+ { markupTag = name,+ markupContent = html,+ markupAttrs = markupAttrs })+ = if isNoHtml html && elem name validHtmlITags+ then renderTag True name markupAttrs n+ else (renderTag True name markupAttrs n+ . foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html))+ . renderTag False name [] n)++prettyHtml' :: HtmlElement -> [String]+prettyHtml' (HtmlString str) = [str]+prettyHtml' (HtmlTag+ { markupTag = name,+ markupContent = html,+ markupAttrs = markupAttrs })+ = if isNoHtml html && elem name validHtmlITags+ then + [rmNL (renderTag True name markupAttrs 0 "")]+ else+ [rmNL (renderTag True name markupAttrs 0 "")] ++ + shift (concat (map prettyHtml' (getHtmlElements html))) +++ [rmNL (renderTag False name [] 0 "")]+ where+ shift = map (\x -> " " ++ x)+rmNL = filter (/= '\n')++-- This prints the Tags The lack of spaces in intentunal, because Html is+-- actually space dependant.++renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS+renderTag x name markupAttrs n r+ = open ++ name ++ rest markupAttrs ++ ">" ++ r+ where+ open = if x then "<" else "</"+ + nl = "\n" ++ replicate (n `div` 8) '\t' + ++ replicate (n `mod` 8) ' '++ rest [] = nl+ rest attr = " " ++ unwords (map showPair attr) ++ nl++ showPair :: HtmlAttr -> String+ showPair (HtmlAttr tag val)+ = tag ++ " = \"" ++ val ++ "\""+
+ Text/Html/BlockTable.hs view
@@ -0,0 +1,175 @@+-----------------------------------------------------------------------------+-- |+-- Module : Text.Html.BlockTable+-- Copyright : (c) Andy Gill and OGI, 1999-2001+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : Andy Gill <andy@galconn.com>+-- Stability : provisional+-- Portability : portable+--+-- An Html combinator library+--+-----------------------------------------------------------------------------++module Text.Html.BlockTable (++-- Datatypes:++ BlockTable, -- abstract++-- Contruction Functions: ++ single,+ empty,+ above,+ beside,++-- Investigation Functions: ++ getMatrix,+ showsTable,+ showTable,++ ) where++infixr 4 `beside`+infixr 3 `above`++-- These combinators can be used to build formated 2D tables.+-- The specific target useage 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> +-}++-- ---------------------------------------------------------------------------+-- Contruction 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+++-- You can create a (1x1) table entry++single :: a -> BlockTable a+single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1++empty :: BlockTable a+empty = Table (\ _ _ r -> r) 0 0+++-- You can compose tables, horizonally and vertically++above :: BlockTable a -> BlockTable a -> BlockTable a+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 ""
+ html.cabal view
@@ -0,0 +1,13 @@+name: html+version: 1.0+license: BSD3+license-file: LICENSE+maintainer: libraries@haskell.org+synopsis: HTML combinator library+build-depends: base>=2.0+description:+ This package contains a combinator library for constructing+ HTML documents.+exposed-modules:+ Text.Html+ Text.Html.BlockTable