html-1.0.1.2/0000755000175000000120000000000011074216767011447 5ustar donswheelhtml-1.0.1.2/Text/0000755000175000000120000000000011074216767012373 5ustar donswheelhtml-1.0.1.2/Text/Html.hs0000644000175000000120000007402511074216767013643 0ustar donswheel----------------------------------------------------------------------------- -- | -- Module : Text.Html -- Copyright : (c) Andy Gill and OGI, 1999-2001 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : Andy Gill -- 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 {- - ..content.. -} | 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"] << ("") -- --------------------------------------------------------------------------- -- 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 = "\n" ++ "\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 " String showPair (HtmlAttr tag val) = tag ++ " = \"" ++ val ++ "\"" html-1.0.1.2/Text/Html/0000755000175000000120000000000011074216767013277 5ustar donswheelhtml-1.0.1.2/Text/Html/BlockTable.hs0000644000175000000120000001120611074216767015635 0ustar donswheel----------------------------------------------------------------------------- -- | -- Module : Text.Html.BlockTable -- Copyright : (c) Andy Gill and OGI, 1999-2001 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : Andy Gill -- 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-1.0.1.2/LICENSE0000644000175000000120000000263011074216767012455 0ustar donswheelThe 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. html-1.0.1.2/Setup.hs0000644000175000000120000000012711074216767013103 0ustar donswheelmodule Main (main) where import Distribution.Simple main :: IO () main = defaultMain html-1.0.1.2/prologue.txt0000644000175000000120000000003411074216767014041 0ustar donswheelAn Html combinator library. html-1.0.1.2/html.cabal0000644000175000000120000000056211074216767013402 0ustar donswheelname: html version: 1.0.1.2 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org synopsis: HTML combinator library category: Web build-depends: base>=2.0 description: This package contains a combinator library for constructing HTML documents. build-type: Simple exposed-modules: Text.Html Text.Html.BlockTable nhc98-options: -K2M