+++ /dev/null
------------------------------------------------------------------------------
--- TableClass : Class for combinators used in building 2D tables.
---
--- Copyright (c) 1999 Andy Gill
---
--- This module is distributed as Open Source software under the
--- Artistic License; see the file "Artistic" that is included
--- in the distribution for details.
------------------------------------------------------------------------------
-
-module ClassTable (
- Table(..),
- 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 :: (Table t) => t String
- > table1 = single "Hello" +-----+
- |Hello|
- This is a 1x1 cell +-----+
- Note: single has type
-
- single :: (Table t) => a -> t a
-
- So the cells can contain anything.
-
- > table2 :: (Table t) => t String
- > table2 = single "World" +-----+
- |World|
- +-----+
-
-
- > table3 :: (Table t) => t String
- > table3 = table1 %-% table2 +-----%-----+
- |Hello%World|
- % is used to indicate +-----%-----+
- the join edge between
- the two Tables.
-
- > table4 :: (Table t) => t String
- > table4 = table3 %/% table2 +-----+-----+
- |Hello|World|
- Notice the padding on the %%%%%%%%%%%%%
- smaller (bottom) cell to |World |
- force the table to be a +-----------+
- rectangle.
-
- > table5 :: (Table t) => t 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>
-
-----------------------------------------------------------------------------}
-
-class Table t where
- -- There are no empty tables
-
- --Single element table
- single :: a -> t a
- -- horizontal composition
- beside :: t a -> t a -> t a
- -- vertical composition
- above :: t a -> t a -> t a
- -- generation of raw table matrix
- getMatrix :: t a -> [[(a,(Int,Int))]]
-
-showsTable :: (Show a,Table t) => t a -> ShowS
-showsTable table = shows (getMatrix table)
-
-showTable :: (Show a,Table t) => t a -> String
-showTable table = showsTable table ""
-
-
+++ /dev/null
--------------------------------------------------------------------------------
--- $Id: DataHtml.hs,v 1.2 2000/07/10 16:15:34 rrt Exp $
---
--- Copyright (c) 1999 Andy Gill
--------------------------------------------------------------------------------
-
-module DataHtml (
- Html, HtmlName, HtmlAttr, HtmlTable,
- (+++), verbatim, {- tag, atag, -} noHtml, primHtml,
- concatHtml, htmlStr, htmlLine,
- h1,h2,h3,h4,h5,h6,
- font, bold, anchor, header, body, theTitle, paragraph, italics,
- ul, tt,
- bar, meta, li,
- {- tr, int, percent -}
- color, bgcolor, href, name, title, height, width, align, valign,
- border, size, cellpadding, cellspacing,
- p, hr, copyright, spaceHtml,
- renderHtml,
- cellHtml, (+/+), above, (+-+), beside, aboves, besides,
- renderTable, simpleTable,
- ) where
-
-import qualified OptTable as OT
-
-infixr 5 +++ -- appending Html
-infixr 3 +/+ -- combining HtmlTable
-infixr 4 +-+ -- combining HtmlTable
-
-data Html
- = HtmlAppend Html Html -- Some Html, followed by more text
- | HtmlVerbatim Html -- Turn on or off smart formating
- | HtmlEmpty -- Nothing!
- | HtmlNestingTag HtmlName [HtmlAttr] Html
- | HtmlSimpleTag HtmlName [HtmlAttr]
- | HtmlString String
- deriving (Show)
-
-{-
- - A important property of Html is all strings inside the
- - structure are already in Html friendly format.
- - For example, use of >,etc.
- -}
-
-type HtmlName = String
-type HtmlAttr = (HtmlName,Either Int String)
-type HtmlTable = OT.OptTable (Int -> Int -> Html)
-
-------------------------------------------------------------------------------
--- Interface
-------------------------------------------------------------------------------
-
--- primitive combinators
-(+++) :: Html -> Html -> Html
-verbatim :: Html -> Html
-tag :: String -> [HtmlAttr] -> Html -> Html
-atag :: String -> [HtmlAttr] -> Html
-noHtml :: Html
-primHtml :: String -> Html
-
--- useful combinators
-concatHtml :: [Html] -> Html
-htmlStr, htmlLine :: String -> Html
-
--- html constructors
-h1,h2,h3,h4,h5,h6 :: [HtmlAttr] -> Html -> Html
-font, bold, anchor,
- header, body,
- theTitle, paragraph,
- italics, ul, tt :: [HtmlAttr] -> Html -> Html
-bar, meta, li :: [HtmlAttr] -> Html
-
--- html attributes
-str :: String -> String -> HtmlAttr
-int :: String -> Int -> HtmlAttr
-percent :: String -> Int -> HtmlAttr
-
-color, bgcolor, href,
- name, title, height,
- width, align, valign :: String -> HtmlAttr
-
-border, size,
- cellpadding,
- cellspacing :: Int -> HtmlAttr
-
--- abbriviations
-
-p :: Html -> Html
-hr :: Html
-copyright :: Html
-spaceHtml :: Html
-
--- rendering
-renderHtml :: Html -> String
-
--- html tables
-cellHtml :: [HtmlAttr] -> Html -> HtmlTable
-(+/+),above,
- (+-+),beside :: HtmlTable -> HtmlTable -> HtmlTable
-aboves, besides :: [HtmlTable] -> HtmlTable
-renderTable :: [HtmlAttr] -> HtmlTable -> Html
-simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]]
- -> Html
-
-------------------------------------------------------------------------------
--- Basic, primitive combinators
-
--- This is intentionally lazy in the second argument.
-(HtmlAppend x y) +++ z = x +++ (y +++ z)
-(HtmlEmpty) +++ z = z
-x +++ z = HtmlAppend x z
-
-verbatim = HtmlVerbatim
-tag = HtmlNestingTag
-atag = HtmlSimpleTag
-noHtml = HtmlEmpty
-
--- This is not processed for special chars.
--- It is used to output them, though!
-primHtml = HtmlString
-
-------------------------------------------------------------------------------
--- Useful Combinators
-
-concatHtml = foldr (+++) noHtml
--- Processing Strings into Html friendly things.
--- This converts a string to an Html.
-htmlStr = primHtml . htmlizeStr
-
--- This converts a string, but keeps spaces as non-line-breakable
-htmlLine = primHtml . concat . map htmlizeChar2
- where
- htmlizeChar2 ' ' = " "
- htmlizeChar2 c = htmlizeChar c
-
--- Local Utilites
-htmlizeStr :: String -> String
-htmlizeStr = concat . map htmlizeChar
-
-htmlizeChar :: Char -> String
-htmlizeChar '<' = ">"
-htmlizeChar '>' = "<"
-htmlizeChar '&' = "&amb;"
-htmlizeChar '"' = """
-htmlizeChar c = [c]
-
-------------------------------------------------------------------------------
--- Html Constructors
-h n = tag ("h" ++ show n)
-
--- Isn't Haskell great!
-[h1,h2,h3,h4,h5,h6] = map h [1..6]
-
--- tags
-font = tag "font"
-bold = tag "b"
-anchor = tag "a"
-header = tag "header"
-body = tag "body"
-theTitle = tag "title"
-paragraph = tag "p"
-italics = tag "i"
-ul = tag "ul"
-tt = tag "tt"
-
-bar = atag "hr"
-meta = atag "meta"
-li = atag "li"
-
-------------------------------------------------------------------------------
--- Html Attributes
-
--- note: the string is presumed to be formated for output
---str :: String -> String -> HtmlAttr
-str n s = (n,Right s)
-
---int :: String -> Int -> HtmlAttr
-int n v = (n,Left v)
-
---percent :: String -> Int -> HtmlAttr
-percent n v = str n (show v ++ "%")
-
--- attributes
-color = str "color"
-bgcolor = str "bgcolor"
-href = str "href"
-name = str "name"
-title = str "tile"
-height = str "height"
-width = str "width"
-align = str "align"
-valign = str "valign"
-
-border = int "border"
-size = int "size"
-cellpadding = int "cellpadding"
-cellspacing = int "cellspacing"
-
-------------------------------------------------------------------------------
--- abbriviations
-p = paragraph []
-hr = atag "hr" []
-copyright = primHtml "©"
-spaceHtml = primHtml " "
-
-------------------------------------------------------------------------------
--- Rendering
-
-renderHtml html = renderHtml' html (Just 0) ++ footerMessage
-
-footerMessage
- = "\n<!-- Generated using the Haskell HTML generator package HaskHTML -->\n"
-
-renderHtml' (HtmlAppend html1 html2) d
- = renderHtml' html1 d ++ renderHtml' html2 d
-renderHtml' (HtmlVerbatim html1) d
- = renderHtml' html1 Nothing
-renderHtml' (HtmlEmpty) d = ""
-renderHtml' (HtmlSimpleTag name attr) d
- = renderTag True name attr d
-renderHtml' (HtmlNestingTag name attr html) d
- = renderTag True name attr d ++ renderHtml' html (incDepth d) ++
- renderTag False name [] d
-renderHtml' (HtmlString str) _ = str
-
-incDepth :: Maybe Int -> Maybe Int
-incDepth = fmap (+4)
-
--- This prints the tags in
-renderTag :: Bool -> HtmlName -> [HtmlAttr] -> Maybe Int -> String
-renderTag x name attrs n = start ++ base_spaces ++ open ++ name ++ rest attrs ++ ">"
- where
- open = if x then "<" else "</"
- (start,base_spaces,sep) = case n of
- Nothing -> ("",""," ")
- Just n -> ("\n",replicate n ' ',"\n")
-
- rest [] = ""
- rest [(tag,val)] = " " ++ tag ++ "=" ++ myShow val
- rest (hd:tl) = " " ++ showPair hd ++ sep ++
- foldr1 (\ x y -> x ++ sep ++ y)
- [ base_spaces ++ replicate (1 + length name + 1) ' '
- ++ showPair p | p <- tl ]
-
- showPair :: HtmlAttr -> String
- showPair (tag,val) = tag ++ replicate (tagsz - length tag) ' ' ++
- " = " ++ myShow val
- myShow (Left n) = show n
- myShow (Right s) = "\"" ++ s ++ "\""
-
- tagsz = maximum (map (length.fst) attrs)
-
-------------------------------------------------------------------------------
--- Html table related things
-
-cellHtml attr html = OT.single cellFn
- where
- cellFn x y = tag "td" (addX x (addY y attr)) html
- addX 1 rest = rest
- addX n rest = int "colspan" n : rest
- addY 1 rest = rest
- addY n rest = int "rowspan" n : rest
-
-above = OT.above
-(+/+) = above
-beside = OT.beside
-(+-+) = beside
-
-{-
- - Note: Both aboves and besides presume a non-empty list.
- -}
-
-aboves = foldl1 (+/+)
-besides = foldl1 (+-+)
-
--- renderTable takes the HtmlTable, and renders it back into
--- and Html object. The attributes are added to the outside
--- table tag.
-
-renderTable attr theTable
- = table [row [theCell x y | (theCell,(x,y)) <- theRow ]
- | theRow <- OT.getMatrix theTable]
- where
- row :: [Html] -> Html
- row = tag "tr" [] . concatHtml
-
- table :: [Html] -> Html
- table = tag "table" attr . concatHtml
-
--- If you cant be bothered with the above, then you
--- can build simple tables with this.
--- Just provide the attributes for the whole table,
--- attributes for the cells (same for every cell),
--- and a list of list 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.
-
-simpleTable attr cellAttr
- = renderTable attr
- . aboves
- . map (besides . map (cellHtml cellAttr))
-
-
-------------------------------------------------------------------------------
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.4 2000/07/05 15:42:19 keithw Exp $
+-- $Id: Main.hs,v 1.5 2001/02/21 16:24:34 simonmar Exp $
-- (c) Simon Marlow 1997-1999
-----------------------------------------------------------------------------
import GenUtils
import Printf
import Slurp
-import DataHtml
import CmdLine
+import Html hiding ((!))
import GlaExts
import FiniteMap
import GetOpt
import System
import List
+(<!) = (Html.!)
+
-----------------------------------------------------------------------------
-- Top level stuff
-----------------------------------------------------------------------------
-- HTML page generation
+--htmlPage :: Results -> [String] -> Html
htmlPage results args
- = header [] (theTitle [] (htmlStr reportTitle))
- +++ bar []
- +++ h1 [] (htmlStr reportTitle)
+ = header << thetitle << reportTitle
+ +++ hr
+ +++ h1 << reportTitle
+++ gen_menu
- +++ bar []
- +++ body [] (gen_tables results args)
+ +++ hr
+ +++ body (gen_tables results args)
-gen_menu = ul [] (foldr1 (+++) (map (li [] +++)
- (map (prog_menu_item) per_prog_result_tab
- ++ map (module_menu_item) per_module_result_tab)))
+gen_menu = unordList (map (prog_menu_item) per_prog_result_tab
+ ++ map (module_menu_item) per_module_result_tab)
-prog_menu_item (SpecP name anc _ _ _) = anchor [href ('#':anc)] (htmlStr name)
-module_menu_item (SpecM name anc _ _) = anchor [href ('#':anc)] (htmlStr name)
+prog_menu_item (SpecP name anc _ _ _) = anchor <! [href ('#':anc)] << name
+module_menu_item (SpecM name anc _ _) = anchor <! [href ('#':anc)] << name
gen_tables results args =
foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab)
htmlGenProgTable results args (SpecP title anc get_result get_status result_ok)
= sectHeading title anc
- +++ font [size 1] (
- mkTable (htmlShowResults results args get_result get_status result_ok))
- +++ bar []
+ +++ font <! [size "1"]
+ << mkTable (htmlShowResults results args get_result get_status result_ok)
+ +++ hr
htmlGenModTable results args (SpecM title anc get_result result_ok)
= sectHeading title anc
- +++ font [size 1] (
- mkTable (htmlShowMultiResults results args get_result result_ok))
- +++ bar []
+ +++ font <![size "1"]
+ << mkTable (htmlShowMultiResults results args get_result result_ok)
+ +++ hr
sectHeading :: String -> String -> Html
-sectHeading s nm
- = h2 [] (anchor [name nm] (htmlStr s))
+sectHeading s nm = h2 << anchor <! [name nm] << s
htmlShowResults
:: Result a
htmlShowResults (r:rs) ss f stat result_ok
= tabHeader ss
- +/+ foldr1 (+/+) (zipWith tableRow [1..] results_per_prog)
- +/+ foldr1 (+/+) ((if nodevs then []
- else [tableRow (-1) ("-1 s.d.", lows),
- tableRow (-1) ("+1 s.d.", highs)])
+ </> aboves (zipWith tableRow [1..] results_per_prog)
+ </> aboves ((if nodevs then []
+ else [tableRow (-1) ("-1 s.d.", lows),
+ tableRow (-1) ("+1 s.d.", highs)])
++ [tableRow (-1) ("Average", gms)])
where
-- results_per_prog :: [ (String,[BoxValue a]) ]
htmlShowMultiResults (r:rs) ss f result_ok =
multiTabHeader ss
- +/+ foldr1 (+/+) (map show_results_for_prog results_per_prog_mod_run)
- +/+ foldr1 (+/+) ((if nodevs then []
- else [(cellHtml [] (bold [] (htmlStr "-1 s.d.")))
- +-+ tableRow (-1) ("", lows),
- (cellHtml [] (bold [] (htmlStr "+1 s.d.")))
- +-+ tableRow (-1) ("", highs)])
- ++ [cellHtml [] (bold [] (htmlStr "Average"))
- +-+ tableRow (-1) ("", gms)])
+ </> aboves (map show_results_for_prog results_per_prog_mod_run)
+ </> aboves ((if nodevs then []
+ else [td << bold << "-1 s.d."
+ <-> tableRow (-1) ("", lows),
+ td << bold << "+1 s.d."
+ <-> tableRow (-1) ("", highs)])
+ ++ [td << bold << "Average"
+ <-> tableRow (-1) ("", gms)])
where
base_results = fmToList r :: [(String,Results)]
result_ok (id,attr)
show_results_for_prog (prog,mrs) =
- cellHtml [valign "top"] (bold [] (htmlStr prog))
- +-+ (if null mrs then
- cellHtml [] (htmlStr "(no modules compiled)")
+ td <! [valign "top"] << bold << prog
+ <-> (if null mrs then
+ td << "(no modules compiled)"
else
- foldr1 (+/+) (map (tableRow 0) mrs))
+ toHtml (aboves (map (tableRow 0) mrs)))
results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run,
(_,xs) <- mods]
tableRow :: Result a => Int -> (String, [BoxValue a]) -> HtmlTable
tableRow row_no (prog, results)
- = cellHtml [bgcolor left_column_color] (htmlStr prog)
- +-+ foldr1 (+-+) (map (cellHtml [align "right", clr]
- . htmlStr . show_box) results)
+ = td <! [bgcolor left_column_color] << prog
+ <-> besides (map (\s -> td <! [align "right", clr] << show_box s)
+ results)
where clr | row_no < 0 = bgcolor average_row_color
| even row_no = bgcolor even_row_color
| otherwise = bgcolor odd_row_color
-}
logHeaders ss
- = foldr1 (+-+) (map (\s -> cellHtml [align "right", width "100"]
- (bold [] (htmlStr s))) ss)
+ = besides (map (\s -> (td <! [align "right", width "100"] << bold << s)) ss)
-mkTable :: HtmlTable -> Html
-mkTable = renderTable [cellspacing 0, cellpadding 0, border 0]
+mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t
tabHeader ss
- = cellHtml [align "left", width "100"] (bold [] (htmlStr "Program"))
- +-+ logHeaders ss
+ = (td <! [align "left", width "100"] << bold << "Program")
+ <-> logHeaders ss
multiTabHeader ss
- = cellHtml [align "left", width "100"] (bold [] (htmlStr "Program"))
- +-+ cellHtml [align "left", width "100"] (bold [] (htmlStr "Module"))
- +-+ logHeaders ss
+ = (td <! [align "left", width "100"] << bold << "Program")
+ <-> (td <! [align "left", width "100"] << bold << "Module")
+ <-> logHeaders ss
-- Calculate a color ranging from bright blue for -100% to bright red for +100%.
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.2 2000/02/18 10:26:19 simonmar Exp $
+# $Id: Makefile,v 1.3 2001/02/21 16:24:34 simonmar Exp $
# (c) Simon Marlow 1999-2000
TOP=..
include $(TOP)/mk/boilerplate.mk
-SRC_HC_OPTS += -fglasgow-exts -syslib util -syslib data -syslib text -cpp
+SRC_HC_OPTS += -fglasgow-exts -package util -package data -package text -cpp
HS_PROG = nofib-analyse
include $(TOP)/mk/target.mk
+++ /dev/null
------------------------------------------------------------------------------
--- $Id: OptTable.hs,v 1.2 2000/07/10 16:15:34 rrt Exp $
---
--- OGI_Table : Class for combinators used in building 2D tables.
---
--- Copyright (c) 1999 Andy Gill
---
--- This module is distributed as Open Source software under the
--- Artistic License; see the file "Artistic" that is included
--- in the distribution for details.
------------------------------------------------------------------------------
-
-module OptTable (
- OptTable, -- abstract
- single,
- beside,
- above,
- getMatrix,
- ) where
-
-import qualified ClassTable as TC
-
-instance TC.Table OptTable where
- single = OptTable.single
- beside = OptTable.beside
- above = OptTable.above
- getMatrix = OptTable.getMatrix
-
-instance (Show a) => Show (OptTable a) where
- showsPrec p = TC.showsTable
-
-type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]]
-
-data OptTable a = Table (Int -> Int -> TableI a) Int Int
-
-{-
- - Perhaps one day I'll fell adventureous, and write the Show instance
- - to show boxes aka the above ascii renditions.
- -}
-
--- You can create a (1x1) table entry
-single :: a -> OptTable a
-single a = Table (\ x y z -> [(a,(x+1,y+1))] : z) 1 1
-
--- You can compose tables, horizonally and vertically
-above :: OptTable a -> OptTable a -> OptTable a
-beside :: OptTable a -> OptTable a -> OptTable 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!
- 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 :: OptTable a -> OptTable a
-trans (Table f1 x1 y1) = Table (flip f1) y1 x1
-
-combine :: OptTable a
- -> OptTable b
- -> (TableI a -> TableI b -> TableI c)
- -> OptTable 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)
-
--- 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 :: OptTable a -> [[(a,(Int,Int))]]
-getMatrix (Table r _ _) = r 0 0 []
-
-----------------------------------------------------------------------------
--- $Id: Printf.lhs,v 1.1 1999/11/12 11:54:17 simonmar Exp $
+-- $Id: Printf.lhs,v 1.2 2001/02/21 16:24:34 simonmar Exp $
--- (c) Simon Marlow 1997-1999
+-- (c) Simon Marlow 1997-2001
-----------------------------------------------------------------------------
> module Printf (showFloat, showFloat') where
-> import GlaExts
+> import Foreign
+> import CTypes
+> import CTypesISO
+> import CString
+> import IOExts
+> import ByteArray
> import PrelPack (unpackCString)
> showFloat
> bUFSIZE = 512 :: Int
> showFloat alt left sign blank zero width prec num =
-> unsafePerformPrimIO ( do
-> buf <- _ccall_ malloc bUFSIZE :: IO Addr
-> _ccall_ snprintf buf bUFSIZE format num
+> unsafePerformIO ( do
+> buf <- malloc bUFSIZE
+> snprintf buf (fromIntegral bUFSIZE) (packString format) num
> let s = unpackCString buf
> length s `seq` -- urk! need to force the string before we
> -- free the buffer. A better solution would
> -- be to use foreign objects and finalisers,
> -- but that's just too heavyweight.
-> _ccall_ free buf
+> free buf
> return s
> )
>
> if_maybe Nothing f = []
> if_maybe (Just s) f = f s
+
+> type PackedString = ByteArray Int
+> foreign import unsafe snprintf :: Addr -> CSize -> PackedString -> Float -> IO ()
projects / ghc-hetmet.git / commitdiff