From aadb2bf04603e88c0e458e71e26a69776ec823d0 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 21 Feb 2001 16:24:34 +0000 Subject: [PATCH] [project @ 2001-02-21 16:24:34 by simonmar] Make this work with GHC 4.08, and remove duplicate (old) copy of Andy Gill's HTML combinator package. --- glafp-utils/nofib-analyse/ClassTable.hs | 94 ---------- glafp-utils/nofib-analyse/DataHtml.hs | 309 ------------------------------- glafp-utils/nofib-analyse/Main.hs | 95 +++++----- glafp-utils/nofib-analyse/Makefile | 4 +- glafp-utils/nofib-analyse/OptTable.hs | 92 --------- glafp-utils/nofib-analyse/Printf.lhs | 22 ++- 6 files changed, 64 insertions(+), 552 deletions(-) delete mode 100644 glafp-utils/nofib-analyse/ClassTable.hs delete mode 100644 glafp-utils/nofib-analyse/DataHtml.hs delete mode 100644 glafp-utils/nofib-analyse/OptTable.hs diff --git a/glafp-utils/nofib-analyse/ClassTable.hs b/glafp-utils/nofib-analyse/ClassTable.hs deleted file mode 100644 index 9472f16..0000000 --- a/glafp-utils/nofib-analyse/ClassTable.hs +++ /dev/null @@ -1,94 +0,0 @@ ------------------------------------------------------------------------------ --- 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 "" - - diff --git a/glafp-utils/nofib-analyse/DataHtml.hs b/glafp-utils/nofib-analyse/DataHtml.hs deleted file mode 100644 index a603dff..0000000 --- a/glafp-utils/nofib-analyse/DataHtml.hs +++ /dev/null @@ -1,309 +0,0 @@ -------------------------------------------------------------------------------- --- $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\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 " ("",""," ") - 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)) - - ------------------------------------------------------------------------------- diff --git a/glafp-utils/nofib-analyse/Main.hs b/glafp-utils/nofib-analyse/Main.hs index 91cdfd1..3822860 100644 --- a/glafp-utils/nofib-analyse/Main.hs +++ b/glafp-utils/nofib-analyse/Main.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 ----------------------------------------------------------------------------- @@ -9,9 +9,9 @@ module Main where import GenUtils import Printf import Slurp -import DataHtml import CmdLine +import Html hiding ((!)) import GlaExts import FiniteMap import GetOpt @@ -22,6 +22,8 @@ import Array import System import List +( tooquick_threshold ----------------------------------------------------------------------------- -- 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 String -> Html -sectHeading s nm - = h2 [] (anchor [name nm] (htmlStr s)) +sectHeading s nm = h2 << anchor 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]) ] @@ -180,14 +181,14 @@ htmlShowMultiResults 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)] @@ -208,11 +209,11 @@ htmlShowMultiResults (r:rs) ss f result_ok = 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 (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] @@ -220,9 +221,9 @@ htmlShowMultiResults (r:rs) ss f result_ok = 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 besides (map (\s -> td cellHtml [align "right", width "100"] - (bold [] (htmlStr s))) ss) + = besides (map (\s -> (td Html -mkTable = renderTable [cellspacing 0, cellpadding 0, border 0] +mkTable t = table logHeaders ss multiTabHeader ss - = cellHtml [align "left", width "100"] (bold [] (htmlStr "Program")) - +-+ cellHtml [align "left", width "100"] (bold [] (htmlStr "Module")) - +-+ logHeaders ss + = (td (td logHeaders ss -- Calculate a color ranging from bright blue for -100% to bright red for +100%. diff --git a/glafp-utils/nofib-analyse/Makefile b/glafp-utils/nofib-analyse/Makefile index 7b67b24..f4704da 100644 --- a/glafp-utils/nofib-analyse/Makefile +++ b/glafp-utils/nofib-analyse/Makefile @@ -1,11 +1,11 @@ # ----------------------------------------------------------------------------- -# $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 diff --git a/glafp-utils/nofib-analyse/OptTable.hs b/glafp-utils/nofib-analyse/OptTable.hs deleted file mode 100644 index 41ca789..0000000 --- a/glafp-utils/nofib-analyse/OptTable.hs +++ /dev/null @@ -1,92 +0,0 @@ ------------------------------------------------------------------------------ --- $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 [] - diff --git a/glafp-utils/nofib-analyse/Printf.lhs b/glafp-utils/nofib-analyse/Printf.lhs index 1fdc8c9..8d65c0c 100644 --- a/glafp-utils/nofib-analyse/Printf.lhs +++ b/glafp-utils/nofib-analyse/Printf.lhs @@ -1,12 +1,17 @@ ----------------------------------------------------------------------------- --- $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 @@ -23,15 +28,15 @@ > 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 > ) > @@ -54,3 +59,6 @@ > if_maybe Nothing f = [] > if_maybe (Just s) f = f s + +> type PackedString = ByteArray Int +> foreign import unsafe snprintf :: Addr -> CSize -> PackedString -> Float -> IO () -- 1.7.10.4