--- /dev/null
+-----------------------------------------------------------------------------\r
+-- TableClass : Class for combinators used in building 2D tables.\r
+--\r
+-- Copyright (c) 1999 Andy Gill\r
+--\r
+-- This module is distributed as Open Source software under the\r
+-- Artistic License; see the file "Artistic" that is included\r
+-- in the distribution for details.\r
+-----------------------------------------------------------------------------\r
+\r
+module ClassTable (\r
+ Table(..),\r
+ showsTable,\r
+ showTable,\r
+ ) where\r
+\r
+infixr 4 `beside`\r
+infixr 3 `above`\r
+\r
+{----------------------------------------------------------------------------\r
+ These combinators can be used to build formated 2D tables.\r
+ The specific target useage is for HTML table generation.\r
+ ----------------------------------------------------------------------------\r
+\r
+ Examples of use:\r
+\r
+ > table1 :: (Table t) => t String\r
+ > table1 = single "Hello" +-----+\r
+ |Hello|\r
+ This is a 1x1 cell +-----+\r
+ Note: single has type\r
+ \r
+ single :: (Table t) => a -> t a\r
+ \r
+ So the cells can contain anything.\r
+ \r
+ > table2 :: (Table t) => t String\r
+ > table2 = single "World" +-----+\r
+ |World|\r
+ +-----+\r
+\r
+\r
+ > table3 :: (Table t) => t String\r
+ > table3 = table1 %-% table2 +-----%-----+\r
+ |Hello%World|\r
+ % is used to indicate +-----%-----+\r
+ the join edge between\r
+ the two Tables. \r
+\r
+ > table4 :: (Table t) => t String\r
+ > table4 = table3 %/% table2 +-----+-----+\r
+ |Hello|World|\r
+ Notice the padding on the %%%%%%%%%%%%%\r
+ smaller (bottom) cell to |World |\r
+ force the table to be a +-----------+\r
+ rectangle.\r
+\r
+ > table5 :: (Table t) => t String\r
+ > table5 = table1 %-% table4 +-----%-----+-----+\r
+ |Hello%Hello|World|\r
+ Notice the padding on the | %-----+-----+\r
+ leftmost cell, again to | %World |\r
+ force the table to be a +-----%-----------+\r
+ rectangle.\r
+ \r
+ Now the table can be rendered with processTable, for example:\r
+ Main> processTable table5\r
+ [[("Hello",(1,2)),\r
+ ("Hello",(1,1)),\r
+ ("World",(1,1))],\r
+ [("World",(2,1))]] :: [[([Char],(Int,Int))]]\r
+ Main> \r
+\r
+----------------------------------------------------------------------------}\r
+\r
+class Table t where\r
+ -- There are no empty tables\r
+\r
+ --Single element table\r
+ single :: a -> t a\r
+ -- horizontal composition\r
+ beside :: t a -> t a -> t a\r
+ -- vertical composition\r
+ above :: t a -> t a -> t a\r
+ -- generation of raw table matrix\r
+ getMatrix :: t a -> [[(a,(Int,Int))]]\r
+\r
+showsTable :: (Show a,Table t) => t a -> ShowS\r
+showsTable table = shows (getMatrix table)\r
+\r
+showTable :: (Show a,Table t) => t a -> String\r
+showTable table = showsTable table ""\r
+\r
+\r
--- /dev/null
+-----------------------------------------------------------------------------
+-- CmdLine.hs
+
+-- (c) Simon Marlow 1999
+-----------------------------------------------------------------------------
+
+module CmdLine where
+
+import GetOpt
+import System
+import IOExts
+
+-----------------------------------------------------------------------------
+-- Command line arguments
+
+args = unsafePerformIO getArgs
+(flags, other_args, cmdline_errors) = getOpt Permute argInfo args
+
+default_tooquick_threshold = 0.2 {- secs -} :: Float
+tooquick_threshold
+ = case [ i | OptIgnoreSmallTimes i <- flags ] of
+ [] -> default_tooquick_threshold
+ (i:_) -> i
+
+data CLIFlags
+ = OptASCIIOutput
+ | OptHTMLOutput
+ | OptIgnoreSmallTimes Float
+ | OptHelp
+ deriving Eq
+
+argInfo :: [ OptDescr CLIFlags ]
+argInfo =
+ [ Option ['?'] ["help"] (NoArg OptHelp)
+ "Display this message"
+ , Option ['a'] ["ascii"] (NoArg OptASCIIOutput)
+ "Produce ASCII output (default)"
+ , Option ['h'] ["html"] (NoArg OptHTMLOutput)
+ "Produce HTML output"
+ , Option ['i'] ["ignore"] (ReqArg (OptIgnoreSmallTimes . read) "secs")
+ "Ignore runtimes smaller than <secs>"
+ ]
+
--- /dev/null
+-------------------------------------------------------------------------------\r
+-- $Id: DataHtml.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $\r
+--\r
+-- Copyright (c) 1999 Andy Gill\r
+-------------------------------------------------------------------------------\r
+\r
+module DataHtml (\r
+ Html, HtmlName, HtmlAttr, HtmlTable,\r
+ (+++), verbatim, {- tag, atag, -} noHtml, primHtml, \r
+ concatHtml, htmlStr, htmlLine,\r
+ h1,h2,h3,h4,h5,h6, \r
+ font, bold, anchor, header, body, theTitle, paragraph, italics,\r
+ ul, tt,\r
+ bar, meta, li,\r
+ {- tr, int, percent -}\r
+ color, bgcolor, href, name, title, height, width, align, valign,\r
+ border, size, cellpadding, cellspacing,\r
+ p, hr, copyright, spaceHtml, \r
+ renderHtml, \r
+ cellHtml, (+/+), above, (+-+), beside, aboves, besides, \r
+ renderTable, simpleTable, \r
+ ) where\r
+\r
+import qualified OptTable as OT\r
+\r
+infixr 5 +++ -- appending Html\r
+infixr 3 +/+ -- combining HtmlTable\r
+infixr 4 +-+ -- combining HtmlTable\r
+\r
+data Html\r
+ = HtmlAppend Html Html -- Some Html, followed by more text\r
+ | HtmlVerbatim Html -- Turn on or off smart formating\r
+ | HtmlEmpty -- Nothing!\r
+ | HtmlNestingTag HtmlName [HtmlAttr] Html\r
+ | HtmlSimpleTag HtmlName [HtmlAttr]\r
+ | HtmlString String\r
+ deriving (Show)\r
+\r
+{-\r
+ - A important property of Html is all strings inside the\r
+ - structure are already in Html friendly format.\r
+ - For example, use of >,etc.\r
+ -}\r
+\r
+type HtmlName = String\r
+type HtmlAttr = (HtmlName,Either Int String)\r
+type HtmlTable = OT.OptTable (Int -> Int -> Html)\r
+\r
+------------------------------------------------------------------------------\r
+-- Interface\r
+------------------------------------------------------------------------------\r
+\r
+-- primitive combinators\r
+(+++) :: Html -> Html -> Html\r
+verbatim :: Html -> Html\r
+tag :: String -> [HtmlAttr] -> Html -> Html\r
+atag :: String -> [HtmlAttr] -> Html\r
+noHtml :: Html\r
+primHtml :: String -> Html\r
+\r
+-- useful combinators\r
+concatHtml :: [Html] -> Html\r
+htmlStr, htmlLine :: String -> Html\r
+\r
+-- html constructors\r
+h1,h2,h3,h4,h5,h6 :: [HtmlAttr] -> Html -> Html\r
+font, bold, anchor, \r
+ header, body, \r
+ theTitle, paragraph,\r
+ italics, ul, tt :: [HtmlAttr] -> Html -> Html\r
+bar, meta, li :: [HtmlAttr] -> Html\r
+\r
+-- html attributes\r
+str :: String -> String -> HtmlAttr\r
+int :: String -> Int -> HtmlAttr\r
+percent :: String -> Int -> HtmlAttr\r
+\r
+color, bgcolor, href,\r
+ name, title, height,\r
+ width, align, valign :: String -> HtmlAttr\r
+\r
+border, size,\r
+ cellpadding,\r
+ cellspacing :: Int -> HtmlAttr \r
+\r
+-- abbriviations\r
+\r
+p :: Html -> Html\r
+hr :: Html\r
+copyright :: Html\r
+spaceHtml :: Html\r
+\r
+-- rendering\r
+renderHtml :: Html -> String\r
+\r
+-- html tables\r
+cellHtml :: [HtmlAttr] -> Html -> HtmlTable\r
+(+/+),above,\r
+ (+-+),beside :: HtmlTable -> HtmlTable -> HtmlTable\r
+aboves, besides :: [HtmlTable] -> HtmlTable\r
+renderTable :: [HtmlAttr] -> HtmlTable -> Html\r
+simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] \r
+ -> Html\r
+\r
+------------------------------------------------------------------------------\r
+-- Basic, primitive combinators\r
+\r
+-- This is intentionally lazy in the second argument.\r
+(HtmlAppend x y) +++ z = x +++ (y +++ z)\r
+(HtmlEmpty) +++ z = z\r
+x +++ z = HtmlAppend x z\r
+\r
+verbatim = HtmlVerbatim\r
+tag = HtmlNestingTag\r
+atag = HtmlSimpleTag\r
+noHtml = HtmlEmpty\r
+\r
+-- This is not processed for special chars. \r
+-- It is used to output them, though!\r
+primHtml = HtmlString\r
+\r
+------------------------------------------------------------------------------\r
+-- Useful Combinators\r
+\r
+concatHtml = foldr (+++) noHtml\r
+-- Processing Strings into Html friendly things.\r
+-- This converts a string to an Html.\r
+htmlStr = primHtml . htmlizeStr\r
+\r
+-- This converts a string, but keeps spaces as non-line-breakable\r
+htmlLine = primHtml . concat . map htmlizeChar2\r
+ where \r
+ htmlizeChar2 ' ' = " "\r
+ htmlizeChar2 c = htmlizeChar c\r
+\r
+-- Local Utilites\r
+htmlizeStr :: String -> String\r
+htmlizeStr = concat . map htmlizeChar\r
+\r
+htmlizeChar :: Char -> String\r
+htmlizeChar '<' = ">"\r
+htmlizeChar '>' = "<"\r
+htmlizeChar '&' = "&amb;"\r
+htmlizeChar '"' = """\r
+htmlizeChar c = [c]\r
+\r
+------------------------------------------------------------------------------\r
+-- Html Constructors\r
+h n = tag ("h" ++ show n)\r
+\r
+-- Isn't Haskell great!\r
+[h1,h2,h3,h4,h5,h6] = map h [1..6]\r
+\r
+-- tags\r
+font = tag "font"\r
+bold = tag "b"\r
+anchor = tag "a"\r
+header = tag "header"\r
+body = tag "body"\r
+theTitle = tag "title"\r
+paragraph = tag "p"\r
+italics = tag "i"\r
+ul = tag "ul"\r
+tt = tag "tt"\r
+\r
+bar = atag "hr"\r
+meta = atag "meta"\r
+li = atag "li"\r
+\r
+------------------------------------------------------------------------------\r
+-- Html Attributes\r
+\r
+-- note: the string is presumed to be formated for output\r
+--str :: String -> String -> HtmlAttr\r
+str n s = (n,Right s)\r
+\r
+--int :: String -> Int -> HtmlAttr\r
+int n v = (n,Left v)\r
+\r
+--percent :: String -> Int -> HtmlAttr\r
+percent n v = str n (show v ++ "%")\r
+\r
+-- attributes\r
+color = str "color"\r
+bgcolor = str "bgcolor"\r
+href = str "href"\r
+name = str "name"\r
+title = str "tile"\r
+height = str "height" \r
+width = str "width"\r
+align = str "align"\r
+valign = str "valign"\r
+\r
+border = int "border" \r
+size = int "size"\r
+cellpadding = int "cellpadding"\r
+cellspacing = int "cellspacing"\r
+\r
+------------------------------------------------------------------------------\r
+-- abbriviations\r
+p = paragraph []\r
+hr = atag "hr" []\r
+copyright = primHtml "©"\r
+spaceHtml = primHtml " "\r
+\r
+------------------------------------------------------------------------------\r
+-- Rendering\r
+\r
+renderHtml html = renderHtml' html (Just 0) ++ footerMessage\r
+\r
+footerMessage \r
+ = "\n<!-- Generated using the Haskell HTML generator package HaskHTML -->\n"\r
+\r
+renderHtml' (HtmlAppend html1 html2) d\r
+ = renderHtml' html1 d ++ renderHtml' html2 d\r
+renderHtml' (HtmlVerbatim html1) d\r
+ = renderHtml' html1 Nothing\r
+renderHtml' (HtmlEmpty) d = ""\r
+renderHtml' (HtmlSimpleTag name attr) d\r
+ = renderTag True name attr d\r
+renderHtml' (HtmlNestingTag name attr html) d\r
+ = renderTag True name attr d ++ renderHtml' html (incDepth d) ++\r
+ renderTag False name [] d\r
+renderHtml' (HtmlString str) _ = str\r
+\r
+incDepth :: Maybe Int -> Maybe Int\r
+incDepth = fmap (+4)\r
+\r
+-- This prints the tags in \r
+renderTag :: Bool -> HtmlName -> [HtmlAttr] -> Maybe Int -> String\r
+renderTag x name attrs n = start ++ base_spaces ++ open ++ name ++ rest attrs ++ ">"\r
+ where\r
+ open = if x then "<" else "</"\r
+ (start,base_spaces,sep) = case n of\r
+ Nothing -> ("",""," ")\r
+ Just n -> ("\n",replicate n ' ',"\n")\r
+ \r
+ rest [] = ""\r
+ rest [(tag,val)] = " " ++ tag ++ "=" ++ myShow val \r
+ rest (hd:tl) = " " ++ showPair hd ++ sep ++\r
+ foldr1 (\ x y -> x ++ sep ++ y)\r
+ [ base_spaces ++ replicate (1 + length name + 1) ' ' \r
+ ++ showPair p | p <- tl ]\r
+\r
+ showPair :: HtmlAttr -> String\r
+ showPair (tag,val) = tag ++ replicate (tagsz - length tag) ' ' ++ \r
+ " = " ++ myShow val \r
+ myShow (Left n) = show n\r
+ myShow (Right s) = "\"" ++ s ++ "\""\r
+\r
+ tagsz = maximum (map (length.fst) attrs)\r
+\r
+------------------------------------------------------------------------------\r
+-- Html table related things\r
+\r
+cellHtml attr html = OT.single cellFn\r
+ where\r
+ cellFn x y = tag "td" (addX x (addY y attr)) html\r
+ addX 1 rest = rest\r
+ addX n rest = int "colspan" n : rest\r
+ addY 1 rest = rest\r
+ addY n rest = int "rowspan" n : rest\r
+\r
+above = OT.above\r
+(+/+) = above\r
+beside = OT.beside\r
+(+-+) = beside\r
+\r
+{-\r
+ - Note: Both aboves and besides presume a non-empty list.\r
+ -}\r
+\r
+aboves = foldl1 (+/+)\r
+besides = foldl1 (+-+)\r
+\r
+-- renderTable takes the HtmlTable, and renders it back into\r
+-- and Html object. The attributes are added to the outside\r
+-- table tag.\r
+\r
+renderTable attr theTable\r
+ = table [row [theCell x y | (theCell,(x,y)) <- theRow ] \r
+ | theRow <- OT.getMatrix theTable]\r
+ where\r
+ row :: [Html] -> Html\r
+ row = tag "tr" [] . concatHtml\r
+\r
+ table :: [Html] -> Html\r
+ table = tag "table" attr . concatHtml\r
+\r
+-- If you cant be bothered with the above, then you\r
+-- can build simple tables with this.\r
+-- Just provide the attributes for the whole table,\r
+-- attributes for the cells (same for every cell),\r
+-- and a list of list of cell contents,\r
+-- and this function will build the table for you.\r
+-- It does presume that all the lists are non-empty,\r
+-- and there is at least one list.\r
+-- \r
+-- Different length lists means that the last cell\r
+-- gets padded. If you want more power, then\r
+-- use the system above.\r
+\r
+simpleTable attr cellAttr\r
+ = renderTable attr \r
+ . aboves\r
+ . map (besides . map (cellHtml cellAttr))\r
+\r
+ \r
+------------------------------------------------------------------------------\r
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: GenUtils.lhs,v 1.1 1999/11/12 11:54:17 simonmar Exp $
+
+-- Some General Utilities, including sorts, etc.
+-- This is realy just an extended prelude.
+-- All the code below is understood to be in the public domain.
+-----------------------------------------------------------------------------
+
+> module GenUtils (
+
+> partition', tack,
+> assocMaybeErr,
+> arrElem,
+> memoise,
+> returnMaybe,handleMaybe, findJust,
+> MaybeErr(..),
+> maybeMap,
+> joinMaybe,
+> mkClosure,
+> foldb,
+> sortWith,
+> sort,
+> cjustify,
+> ljustify,
+> rjustify,
+> space,
+> copy,
+> combinePairs,
+> --trace, -- re-export it
+> fst3,
+> snd3,
+> thd3
+
+#if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
+
+> ,Cmp(..), compare, lookup, isJust
+
+#endif
+
+> ) where
+
+#if __HASKELL1__ >= 3 && ( !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 200 )
+
+> import Ix ( Ix(..) )
+> import Array ( listArray, array, (!) )
+
+#define Text Show
+#define ASSOC(a,b) (a , b)
+#else
+#define ASSOC(a,b) (a := b)
+#endif
+
+%------------------------------------------------------------------------------
+
+Here are two defs that everyone seems to define ...
+HBC has it in one of its builtin modules
+
+#ifdef __GOFER__
+
+ primitive primPrint "primPrint" :: Int -> a -> ShowS
+
+#endif
+
+#ifdef __GOFER__
+
+ primitive primGenericEq "primGenericEq",
+ primGenericNe "primGenericNe",
+ primGenericLe "primGenericLe",
+ primGenericLt "primGenericLt",
+ primGenericGe "primGenericGe",
+ primGenericGt "primGenericGt" :: a -> a -> Bool
+
+ instance Text (Maybe a) where { showsPrec = primPrint }
+ instance Eq (Maybe a) where
+ (==) = primGenericEq
+ (/=) = primGenericNe
+
+ instance (Ord a) => Ord (Maybe a)
+ where
+ Nothing <= _ = True
+ _ <= Nothing = True
+ (Just a) <= (Just b) = a <= b
+
+#endif
+
+> maybeMap :: (a -> b) -> Maybe a -> Maybe b
+> maybeMap f (Just a) = Just (f a)
+> maybeMap f Nothing = Nothing
+
+> joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
+> joinMaybe _ Nothing Nothing = Nothing
+> joinMaybe _ (Just g) Nothing = Just g
+> joinMaybe _ Nothing (Just g) = Just g
+> joinMaybe f (Just g) (Just h) = Just (f g h)
+
+> data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Text)
+
+@mkClosure@ makes a closure, when given a comparison and iteration loop.
+Be careful, because if the functional always makes the object different,
+This will never terminate.
+
+> mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a
+> mkClosure eq f = match . iterate f
+> where
+> match (a:b:c) | a `eq` b = a
+> match (_:c) = match c
+
+> foldb :: (a -> a -> a) -> [a] -> a
+> foldb f [] = error "can't reduce an empty list using foldb"
+> foldb f [x] = x
+> foldb f l = foldb f (foldb' l)
+> where
+> foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs
+> foldb' (x:y:xs) = f x y : foldb' xs
+> foldb' xs = xs
+
+Merge two ordered lists into one ordered list.
+
+> mergeWith :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+> mergeWith _ [] ys = ys
+> mergeWith _ xs [] = xs
+> mergeWith le (x:xs) (y:ys)
+> | x `le` y = x : mergeWith le xs (y:ys)
+> | otherwise = y : mergeWith le (x:xs) ys
+
+> insertWith :: (a -> a -> Bool) -> a -> [a] -> [a]
+> insertWith _ x [] = [x]
+> insertWith le x (y:ys)
+> | x `le` y = x:y:ys
+> | otherwise = y:insertWith le x ys
+
+Sorting is something almost every program needs, and this is the
+quickest sorting function I know of.
+
+> sortWith :: (a -> a -> Bool) -> [a] -> [a]
+> sortWith le [] = []
+> sortWith le lst = foldb (mergeWith le) (splitList lst)
+> where
+> splitList (a1:a2:a3:a4:a5:xs) =
+> insertWith le a1
+> (insertWith le a2
+> (insertWith le a3
+> (insertWith le a4 [a5]))) : splitList xs
+> splitList [] = []
+> splitList (r:rs) = [foldr (insertWith le) [r] rs]
+
+> sort :: (Ord a) => [a] -> [a]
+> sort = sortWith (<=)
+
+> returnMaybe :: a -> Maybe a
+> returnMaybe = Just
+
+> handleMaybe :: Maybe a -> Maybe a -> Maybe a
+> handleMaybe m k = case m of
+> Nothing -> k
+> _ -> m
+
+> findJust :: (a -> Maybe b) -> [a] -> Maybe b
+> findJust f = foldr handleMaybe Nothing . map f
+
+
+Gofer-like stuff:
+
+> fst3 (a,_,_) = a
+> snd3 (_,a,_) = a
+> thd3 (_,a,_) = a
+
+> cjustify, ljustify, rjustify :: Int -> String -> String
+> cjustify n s = space halfm ++ s ++ space (m - halfm)
+> where m = n - length s
+> halfm = m `div` 2
+> ljustify n s = s ++ space (n - length s)
+> rjustify n s = let s' = take n s in space (n - length s') ++ s'
+
+> space :: Int -> String
+> space n | n < 0 = ""
+> | otherwise = copy n ' '
+
+> copy :: Int -> a -> [a] -- make list of n copies of x
+> copy n x = take n xs where xs = x:xs
+
+> partition' :: (Eq b) => (a -> b) -> [a] -> [[a]]
+> partition' f [] = []
+> partition' f [x] = [[x]]
+> partition' f (x:x':xs) | f x == f x'
+> = tack x (partition' f (x':xs))
+> | otherwise
+> = [x] : partition' f (x':xs)
+
+> tack x xss = (x : head xss) : tail xss
+
+> combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
+> combinePairs xs =
+> combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs]
+> where
+> combine [] = []
+> combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)
+> combine (a:r) = a : combine r
+>
+
+#if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
+
+> lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
+> lookup k env = case [ val | (key,val) <- env, k == key] of
+> [] -> Nothing
+> (val:vs) -> Just val
+>
+
+> data Cmp = LT | EQ | GT
+
+> compare a b | a < b = LT
+> | a == b = EQ
+> | otherwise = GT
+
+> isJust :: Maybe a -> Bool
+> isJust (Just _) = True
+> isJust _ = False
+
+#endif
+
+> assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String
+> assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of
+> [] -> Failed "assoc: "
+> (val:vs) -> Succeeded val
+>
+
+Now some utilties involving arrays.
+Here is a version of @elem@ that uses partual application
+to optimise lookup.
+
+> arrElem :: (Ix a) => [a] -> a -> Bool
+> arrElem obj = \x -> inRange size x && arr ! x
+> where
+> obj' = sort obj
+> size = (head obj',last obj')
+> arr = listArray size [ i `elem` obj | i <- range size ]
+
+
+You can use this function to simulate memoisation. For example:
+
+ > fib = memoise (0,100) fib'
+ > where
+ > fib' 0 = 0
+ > fib' 1 = 0
+ > fib' n = fib (n-1) + fib (n-2)
+
+will give a very efficent variation of the fib function.
+
+
+> memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b
+> memoise bds f = (!) arr
+> where arr = array bds [ ASSOC(t, f t) | t <- range bds ]
+
+> mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
+> -- and accumulator, returning new
+> -- accumulator and elt of result list
+> -> acc -- Initial accumulator
+> -> [x] -- Input list
+> -> (acc, [y]) -- Final accumulator and result list
+>
+> mapAccumR f b [] = (b, [])
+> mapAccumR f b (x:xs) = (b'', x':xs') where
+> (b'', x') = f b' x
+> (b', xs') = mapAccumR f b xs
+
+> mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
+> -- and accumulator, returning new
+> -- accumulator and elt of result list
+> -> acc -- Initial accumulator
+> -> [x] -- Input list
+> -> (acc, [y]) -- Final accumulator and result list
+>
+> mapAccumL f b [] = (b, [])
+> mapAccumL f b (x:xs) = (b'', x':xs') where
+> (b', x') = f b x
+> (b'', xs') = mapAccumL f b' xs
+
+Here is the bi-directional version ...
+
+> mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
+> -- Function of elt of input list
+> -- and accumulator, returning new
+> -- accumulator and elt of result list
+> -> accl -- Initial accumulator from left
+> -> accr -- Initial accumulator from right
+> -> [x] -- Input list
+> -> (accl, accr, [y]) -- Final accumulator and result list
+>
+> mapAccumB f a b [] = (a,b,[])
+> mapAccumB f a b (x:xs) = (a'',b'',y:ys)
+> where
+> (a',b'',y) = f a b' x
+> (a'',b',ys) = mapAccumB f a' b xs
+
+
+> assert False x = error "assert Failed"
+> assert True x = x
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: Main.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $
+
+-- (c) Simon Marlow 1997-1999
+-----------------------------------------------------------------------------
+
+module Main where
+
+import GenUtils
+import Printf
+import Slurp
+import DataHtml
+import CmdLine
+
+import GlaExts
+import FiniteMap
+import GetOpt
+
+import Char
+import IO
+import Array
+import System
+import List
+
+-----------------------------------------------------------------------------
+-- Top level stuff
+
+die :: String -> IO a
+die s = hPutStr stderr s >> exitWith (ExitFailure 1)
+
+usageHeader = "usage: nofib-analyse [OPTION...] <logfile1> <logfile2> ..."
+
+main = do
+
+ if not (null cmdline_errors) || OptHelp `elem` flags
+ then die (concat cmdline_errors ++ usageInfo usageHeader argInfo)
+ else do
+
+ let { html = OptHTMLOutput `elem` flags;
+ ascii = OptASCIIOutput `elem` flags
+ }
+
+ if ascii && html
+ then die "Can't produce both ASCII and HTML"
+ else do
+
+ results <- parse_logs other_args
+
+ let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args
+
+ if html
+ then putStr (renderHtml (htmlPage results column_headings))
+ else putStr (asciiPage results column_headings)
+
+
+parse_logs :: [String] -> IO [ResultTable]
+parse_logs [] = do
+ f <- hGetContents stdin
+ return [parse_log f]
+parse_logs log_files =
+ mapM (\f -> do h <- openFile f ReadMode
+ c <- hGetContents h
+ return (parse_log c)) log_files
+
+-----------------------------------------------------------------------------
+-- List of tables we're going to generate
+
+data PerProgTableSpec =
+ forall a . Result a =>
+ SpecP
+ String -- Name of the table
+ String -- HTML tag for the table
+ (Results -> Maybe a) -- How to get the result
+ (Results -> Status) -- How to get the status of this result
+ (a -> Bool) -- Result within reasonable limits?
+
+data PerModuleTableSpec =
+ forall a . Result a =>
+ SpecM
+ String -- Name of the table
+ String -- HTML tag for the table
+ (Results -> FiniteMap String a) -- get the module map
+ (a -> Bool) -- Result within reasonable limits?
+
+per_prog_result_tab =
+ [ SpecP "Binary Sizes" "binary-sizes" binary_size compile_status always_ok
+ , SpecP "Allocations" "allocations" allocs run_status always_ok
+ , SpecP "Run Time" "run-times" run_time run_status time_ok
+ , SpecP "Mutator Time" "mutator-time" mut_time run_status time_ok
+ , SpecP "GC Time" "gc-time" gc_time run_status time_ok
+ , SpecP "GC Work" "gc-work" gc_work run_status always_ok
+ , SpecP "Instructions" "instrs" instrs run_status always_ok
+ , SpecP "Memory Reads" "mem-reads" mem_reads run_status always_ok
+ , SpecP "Memory Writes" "mem-writes" mem_writes run_status always_ok
+ ]
+
+per_module_result_tab =
+ [ SpecM "Module Sizes" "mod-sizes" module_size always_ok
+ , SpecM "Compile Times" "compile-time" compile_time time_ok
+ ]
+
+always_ok :: a -> Bool
+always_ok = const True
+
+time_ok :: Float -> Bool
+time_ok t = t > tooquick_threshold
+
+-----------------------------------------------------------------------------
+-- HTML page generation
+
+htmlPage results args
+ = header [] (theTitle [] (htmlStr "NoFib Results"))
+ +++ bar []
+ +++ gen_menu
+ +++ bar []
+ +++ 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)))
+
+prog_menu_item (SpecP name anc _ _ _) = anchor [href ('#':anc)] (htmlStr name)
+module_menu_item (SpecM name anc _ _) = anchor [href ('#':anc)] (htmlStr name)
+
+gen_tables results args =
+ foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab)
+ +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_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 []
+
+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 []
+
+sectHeading :: String -> String -> Html
+sectHeading s nm
+ = h2 [] (anchor [name nm] (htmlStr s))
+
+htmlShowResults
+ :: Result a
+ => [ResultTable]
+ -> [String]
+ -> (Results -> Maybe a)
+ -> (Results -> Status)
+ -> (a -> Bool)
+ -> HtmlTable
+
+htmlShowResults (r:rs) ss f stat result_ok
+ = tabHeader ss
+ +/+ foldr1 (+/+) (zipWith tableRow [1..] results_per_prog)
+ +/+ tableRow (-1) ("Average", geometric_means)
+ where
+ -- results_per_prog :: [ (String,[BoxValue a]) ]
+ results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
+
+ results_per_run = transpose (map snd results_per_prog)
+ geometric_means = map calc_gm results_per_run
+
+htmlShowMultiResults
+ :: Result a
+ => [ResultTable]
+ -> [String]
+ -> (Results -> FiniteMap String a)
+ -> (a -> Bool)
+ -> HtmlTable
+
+htmlShowMultiResults (r:rs) ss f result_ok =
+ multiTabHeader ss
+ +/+ foldr1 (+/+) (map show_results_for_prog base_results)
+
+ where
+ base_results = fmToList r :: [(String,Results)]
+
+ show_results_for_prog (prog,r) =
+ cellHtml [valign "top"] (bold [] (htmlStr prog))
+ +-+ (if null base then
+ cellHtml [] (htmlStr "(no modules compiled)")
+ else
+ foldr1 (+/+) (map (show_one_result fms) base))
+
+ where
+ base = fmToList (f r)
+ fms = map (get_results_for prog) rs
+
+ get_results_for prog m = case lookupFM m prog of
+ Nothing -> emptyFM
+ Just r -> f r
+
+ show_one_result other_results (id,attribute) =
+ tableRow 0 (
+ calc_result other_results Just (const Success)
+ result_ok (id,attribute)
+ )
+
+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)
+ where clr | row_no < 0 = bgcolor average_row_color
+ | even row_no = bgcolor even_row_color
+ | otherwise = bgcolor odd_row_color
+
+left_column_color = "#d0d0ff" -- light blue
+odd_row_color = "#d0d0ff" -- light blue
+even_row_color = "#f0f0ff" -- v. light blue
+average_row_color = "#ffd0d0" -- light red
+
+{-
+findBest :: Result a => [BoxValue a] -> [(Bool,BoxValue a)]
+findBest stuff@(Result base : rest)
+ = map (\a -> (a==base, a))
+ where
+ best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff
+
+ no_pcnt_stuff = map unPcnt stuff
+
+ unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest
+ unPcnt (r@(Result a) : rest) = (a, r) : unPcnt rest
+ unPcnt (_ : rest) = unPcnt rest
+-}
+
+logHeaders ss
+ = foldr1 (+-+) (map (\s -> cellHtml [align "right", width "100"]
+ (bold [] (htmlStr s))) ss)
+
+mkTable :: HtmlTable -> Html
+mkTable = renderTable [cellspacing 0, cellpadding 0, border 0]
+
+tabHeader ss
+ = cellHtml [align "left", width "100"] (bold [] (htmlStr "Program"))
+ +-+ logHeaders ss
+
+multiTabHeader ss
+ = cellHtml [align "left", width "100"] (bold [] (htmlStr "Program"))
+ +-+ cellHtml [align "left", width "100"] (bold [] (htmlStr "Module"))
+ +-+ logHeaders ss
+
+-- Calculate a color ranging from bright blue for -100% to bright red for +100%.
+
+calcColor :: Int -> String
+calcColor p | p >= 0 = "#" ++ (showHex red 2 "0000")
+ | otherwise = "#0000" ++ (showHex blue 2 "")
+ where red = p * 255 `div` 100
+ blue = (-p) * 255 `div` 100
+
+showHex 0 f s = if f > 0 then take f (repeat '0') ++ s else s
+showHex i f s = showHex (i `div` 16) (f-1) (hexDig (i `mod` 16) : s)
+
+hexDig i | i > 10 = chr (i-10 + ord 'a')
+ | otherwise = chr (i + ord '0')
+
+-----------------------------------------------------------------------------
+-- ASCII page generation
+
+asciiPage results args =
+ ( interleave "\n\n" (map (asciiGenProgTable results args) per_prog_result_tab)
+ . str "\n"
+ . interleave "\n\n" (map (asciiGenModTable results args) per_module_result_tab)
+ ) "\n"
+
+asciiGenProgTable results args (SpecP title anc get_result get_status result_ok)
+ = str title
+ . str "\n"
+ . ascii_show_results results args get_result get_status result_ok
+
+asciiGenModTable results args (SpecM title anc get_result result_ok)
+ = str title
+ . str "\n"
+ . ascii_show_multi_results results args get_result result_ok
+
+ascii_header ss
+ = str "\n-------------------------------------------------------------------------------\n"
+ . str (rjustify 15 "Program")
+ . str (space 5)
+ . foldr (.) id (map (str . rjustify fIELD_WIDTH) ss)
+ . str "\n-------------------------------------------------------------------------------\n"
+
+ascii_show_results
+ :: Result a
+ => [ResultTable]
+ -> [String]
+ -> (Results -> Maybe a)
+ -> (Results -> Status)
+ -> (a -> Bool)
+ -> ShowS
+
+ascii_show_results (r:rs) ss f stat result_ok
+ = ascii_header ss
+ . interleave "\n" (map show_per_prog_results results_per_prog)
+ . str "\n"
+ . show_per_prog_results ("Average",geometric_means)
+ where
+ -- results_per_prog :: [ (String,[BoxValue a]) ]
+ results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
+
+ results_per_run = transpose (map snd results_per_prog)
+ geometric_means = map calc_gm results_per_run
+
+ascii_show_multi_results
+ :: Result a
+ => [ResultTable]
+ -> [String]
+ -> (Results -> FiniteMap String a)
+ -> (a -> Bool)
+ -> ShowS
+
+ascii_show_multi_results (r:rs) ss f result_ok
+ = ascii_header ss
+ . interleave "\n" (map show_results_for_prog base_results)
+ where
+ base_results = fmToList r :: [(String,Results)]
+
+ show_results_for_prog (prog,r) =
+ str ("\n"++prog++"\n")
+ . (if null base then
+ str "(no modules compiled)\n"
+ else
+ interleave "\n" (map (show_one_result fms) base))
+
+ where
+ base = fmToList (f r)
+ fms = map (get_results_for prog) rs
+
+ get_results_for prog m = case lookupFM m prog of
+ Nothing -> emptyFM
+ Just r -> f r
+
+ show_one_result other_results (id,attribute) =
+ show_per_prog_results (
+ calc_result other_results Just (const Success)
+ result_ok (id,attribute)
+ )
+
+show_per_prog_results :: Result a => (String, [BoxValue a]) -> ShowS
+show_per_prog_results (prog,results)
+ = str (rjustify 15 prog)
+ . str (space 5)
+ . foldr (.) id (map (str . rjustify fIELD_WIDTH . show_box) results)
+
+-----------------------------------------------------------------------------
+-- Show the Results
+
+class Num a => Result a where
+ result_to_string :: a -> String
+ convert_to_percentage :: a -> a -> Float
+
+-- We assume an Int is a size, and print it in kilobytes.
+
+instance Result Int where
+ convert_to_percentage 0 size = 100
+ convert_to_percentage base size = (fromInt size / fromInt base) * 100
+
+ result_to_string n = show (n `div` 1024) ++ "k"
+
+instance Result Integer where
+ convert_to_percentage 0 size = 100
+ convert_to_percentage base size = (fromInteger size / fromInteger base) * 100
+
+ result_to_string n = show (n `quot` 1024) ++ "k"
+
+instance Result Float where
+ convert_to_percentage 0.0 size = 100.0
+ convert_to_percentage base size = size / base * 100
+
+ result_to_string = showFloat' Nothing (Just 2)
+
+data BoxValue a = RunFailed Status | Percentage Float | Result a
+
+-- calc_result is a nice exercise in higher-order programming...
+calc_result
+ :: Result a
+ => [FiniteMap String b] -- accumulated results
+ -> (b -> Maybe a) -- get a result from the b
+ -> (b -> Status) -- get a status from the b
+ -> (a -> Bool) -- is this result ok?
+ -> (String,b) -- the baseline result
+ -> (String,[BoxValue a])
+
+calc_result rts get_maybe_a get_stat result_ok (prog,base_r) =
+ (prog, (just_result baseline base_stat :
+
+ let
+ rts' = map (\rt -> get_stuff (lookupFM rt prog)) rts
+
+ get_stuff Nothing = (Nothing, NotDone)
+ get_stuff (Just r) = (get_maybe_a r, get_stat r)
+ in
+ (
+ case baseline of
+ Just base | result_ok base
+ -> map (\(r,s) -> percentage r s base) rts'
+ _other
+ -> map (\(r,s) -> just_result r s) rts'
+ )))
+ where
+ baseline = get_maybe_a base_r
+ base_stat = get_stat base_r
+
+ just_result Nothing s = RunFailed s
+ just_result (Just a) s = Result a
+
+ percentage Nothing s base = RunFailed s
+ percentage (Just a) s base = Percentage
+ (convert_to_percentage base a)
+show_box (RunFailed s) = show_stat s
+show_box (Percentage p) = show_pcntage p
+show_box (Result a) = result_to_string a
+
+-----------------------------------------------------------------------------
+-- Calculating geometric means
+
+{-
+This is done using the log method, to avoid needing really large
+intermediate results. The formula for a geometric mean is
+
+ (a1 * .... * an) ^ 1/n
+
+which is equivalent to
+
+ e ^ ( (log a1 + ... + log an) / n )
+
+where log is the natural logarithm function.
+-}
+
+calc_gm :: [BoxValue a] -> BoxValue Float
+calc_gm xs
+ | null percentages = RunFailed NotDone
+ | otherwise = Percentage (exp (sum (map log percentages) /
+ fromInt (length percentages)))
+ where
+ percentages = [ f | Percentage f <- xs, f /= 0.0 ]
+ -- can't do log(0.0), so exclude zeros
+
+-----------------------------------------------------------------------------
+-- Generic stuff for results generation
+
+show_pcntage n = show_float_signed (n-100) ++ "%"
+
+show_float_signed = showFloat False False True False False Nothing (Just 2)
+
+show_stat Success = "(no result)"
+show_stat WrongStdout = "(stdout)"
+show_stat WrongStderr = "(stderr)"
+show_stat (Exit x) = "exit(" ++ show x ++")"
+show_stat OutOfHeap = "(heap)"
+show_stat OutOfStack = "(stack)"
+show_stat NotDone = "-----"
+
+str = showString
+
+interleave s = foldr1 (\a b -> a . str s . b)
+
+fIELD_WIDTH = 16 :: Int
+
+-----------------------------------------------------------------------------
--- /dev/null
+TOP=..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_HC_OPTS += -fglasgow-exts -syslib misc -cpp
+HS_PROG = nofib-analyse
+
+include $(TOP)/mk/target.mk
--- /dev/null
+-----------------------------------------------------------------------------\r
+-- $Id: OptTable.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $\r
+--\r
+-- OGI_Table : Class for combinators used in building 2D tables.\r
+--\r
+-- Copyright (c) 1999 Andy Gill\r
+--\r
+-- This module is distributed as Open Source software under the\r
+-- Artistic License; see the file "Artistic" that is included\r
+-- in the distribution for details.\r
+-----------------------------------------------------------------------------\r
+\r
+module OptTable (\r
+ OptTable, -- abstract\r
+ single,\r
+ beside,\r
+ above,\r
+ getMatrix,\r
+ ) where\r
+\r
+import qualified ClassTable as TC\r
+\r
+instance TC.Table OptTable where\r
+ single = OptTable.single\r
+ beside = OptTable.beside\r
+ above = OptTable.above\r
+ getMatrix = OptTable.getMatrix\r
+\r
+instance (Show a) => Show (OptTable a) where\r
+ showsPrec p = TC.showsTable\r
+\r
+type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]]\r
+\r
+data OptTable a = Table (Int -> Int -> TableI a) Int Int\r
+\r
+{-\r
+ - Perhaps one day I'll fell adventureous, and write the Show instance\r
+ - to show boxes aka the above ascii renditions.\r
+ -}\r
+\r
+-- You can create a (1x1) table entry\r
+single :: a -> OptTable a\r
+single a = Table (\ x y z -> [(a,(x+1,y+1))] : z) 1 1\r
+\r
+-- You can compose tables, horizonally and vertically\r
+above :: OptTable a -> OptTable a -> OptTable a\r
+beside :: OptTable a -> OptTable a -> OptTable a\r
+\r
+t1 `above` t2 = trans (combine (trans t1) (trans t2) (.))\r
+\r
+t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r ->\r
+ let\r
+ -- Note this depends on the fact that\r
+ -- that the result has the same number\r
+ -- of lines as the y dimention; one list\r
+ -- per line. This is not true in general\r
+ -- but is always true for these combinators.\r
+ -- I should assert this!\r
+ beside (x:xs) (y:ys) = (x ++ y) : beside xs ys\r
+ beside (x:xs) [] = x : xs ++ r\r
+ beside [] (y:ys) = y : ys ++ r\r
+ beside [] [] = r\r
+ in\r
+ beside (lst1 []) (lst2 []))\r
+\r
+-- trans flips (transposes) over the x and y axis of\r
+-- the table. It is only used internally, and typically\r
+-- in pairs, ie. (flip ... munge ... (un)flip).\r
+\r
+trans :: OptTable a -> OptTable a\r
+trans (Table f1 x1 y1) = Table (flip f1) y1 x1\r
+\r
+combine :: OptTable a \r
+ -> OptTable b \r
+ -> (TableI a -> TableI b -> TableI c) \r
+ -> OptTable c\r
+combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y\r
+ where\r
+ max_y = max y1 y2\r
+ new_fn x y =\r
+ case compare y1 y2 of\r
+ EQ -> comb (f1 0 y) (f2 x y)\r
+ GT -> comb (f1 0 y) (f2 x (y + y1 - y2))\r
+ LT -> comb (f1 0 (y + y2 - y1)) (f2 x y)\r
+\r
+-- This is the other thing you can do with a Table;\r
+-- turn it into a 2D list, tagged with the (x,y)\r
+-- sizes of each cell in the table.\r
+\r
+getMatrix :: OptTable a -> [[(a,(Int,Int))]]\r
+getMatrix (Table r _ _) = r 0 0 []\r
+\r
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: Printf.lhs,v 1.1 1999/11/12 11:54:17 simonmar Exp $
+
+-- (c) Simon Marlow 1997-1999
+-----------------------------------------------------------------------------
+
+> module Printf (showFloat, showFloat') where
+
+> import GlaExts
+> import PrelPack (unpackCString)
+
+> showFloat
+> :: Bool -- Always print decimal point
+> -> Bool -- Left adjustment
+> -> Bool -- Always print sign
+> -> Bool -- Leave blank before positive number
+> -> Bool -- Use zero padding
+> -> Maybe Int -- Field Width
+> -> Maybe Int -- Precision
+> -> Float
+> -> String
+
+> 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
+> 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
+> return s
+> )
+>
+> where
+> format = '%' :
+> if_bool alt "#" ++
+> if_bool left "-" ++
+> if_bool sign "+" ++
+> if_bool blank " " ++
+> if_bool zero "0" ++
+> if_maybe width show ++
+> if_maybe prec (\s -> "." ++ show s) ++
+> "f"
+
+> showFloat' :: Maybe Int -> Maybe Int -> Float -> String
+> showFloat' = showFloat False False False False False
+
+> if_bool False s = []
+> if_bool True s = s
+
+> if_maybe Nothing f = []
+> if_maybe (Just s) f = f s
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: Slurp.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $
+
+-- (c) Simon Marlow 1997-1999
+-----------------------------------------------------------------------------
+
+module Slurp (Status(..), Results(..), ResultTable(..), parse_log) where
+
+import CmdLine
+import FiniteMap
+import RegexString
+import Maybe
+
+-----------------------------------------------------------------------------
+-- This is the structure into which we collect our results:
+
+type ResultTable = FiniteMap String Results
+
+data Status
+ = NotDone
+ | Success
+ | OutOfHeap
+ | OutOfStack
+ | Exit Int
+ | WrongStdout
+ | WrongStderr
+
+data Results = Results {
+ compile_time :: FiniteMap String Float,
+ module_size :: FiniteMap String Int,
+ binary_size :: Maybe Int,
+ link_time :: Maybe Float,
+ run_time :: Maybe Float,
+ mut_time :: Maybe Float,
+ instrs :: Maybe Integer,
+ mem_reads :: Maybe Integer,
+ mem_writes :: Maybe Integer,
+ gc_work :: Maybe Integer,
+ gc_time :: Maybe Float,
+ allocs :: Maybe Integer,
+ run_status :: Status,
+ compile_status :: Status
+ }
+
+emptyResults = Results {
+ compile_time = emptyFM,
+ module_size = emptyFM,
+ binary_size = Nothing,
+ link_time = Nothing,
+ run_time = Nothing,
+ mut_time = Nothing,
+ instrs = Nothing,
+ mem_reads = Nothing,
+ mem_writes = Nothing,
+ gc_time = Nothing,
+ gc_work = Nothing,
+ allocs = Nothing,
+ compile_status = NotDone,
+ run_status = NotDone
+ }
+
+-----------------------------------------------------------------------------
+-- Parse the log file
+
+{-
+Various banner lines:
+
+==nofib== awards: size of QSort.o follows...
+==nofib== banner: size of banner follows...
+==nofib== awards: time to link awards follows...
+==nofib== awards: time to run awards follows...
+==nofib== boyer2: time to compile Checker follows...
+-}
+
+banner_re = mkRegex "^==nofib==[ \t]+([A-Za-z0-9_]+):[ \t]+(size of|time to link|time to run|time to compile)[ \t]+([A-Za-z0-9_]+)(\\.o)?[ \t]+follows"
+
+{-
+This regexp for the output of "time" works on FreeBSD, other versions
+of "time" will need different regexps.
+-}
+
+time_re = mkRegex "^[ \t]*([0-9.]+)[ \t]+real[ \t]+([0-9.]+)[ \t]+user[ \t]+([0-9.]+)[ \t]+sys[ \t]*$"
+
+size_re = mkRegex "^[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)"
+
+{-
+<<ghc: 5820820 bytes, 0 GCs, 0/0 avg/max bytes residency (0 samples), 41087234 bytes GC work, 0.00 INIT (0.05 elapsed), 0.08 MUT (0.18 elapsed), 0.00 GC (0.00 elapsed) :ghc>>
+
+ = (bytes, gcs, avg_resid, max_resid, samples, gc_work,
+ init, init_elapsed, mut, mut_elapsed, gc, gc_elapsed)
+
+ghc1_re = pre GHC 4.02
+ghc2_re = GHC 4.02 (includes "xxM in use")
+ghc3_re = GHC 4.03 (includes "xxxx bytes GC work")
+-}
+
+ghc1_re = mkRegex "^<<ghc:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+) bytes GC work, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\) :ghc>>"
+
+ghc2_re = mkRegex "^<<ghc:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+)M in use, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\) :ghc>>"
+
+ghc3_re = mkRegex "^<<ghc:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+) bytes GC work, ([0-9]+)M in use, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\) :ghc>>"
+
+ghc4_re = mkRegex "^<<ghc-instrs:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+) bytes GC work, ([0-9]+)M in use, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\), ([0-9]+) instructions, ([0-9]+) memory reads, ([0-9]+) memory writes :ghc-instrs>>"
+
+wrong_exit_status = mkRegex "^\\**[ \t]*expected exit status ([0-9]+) not seen ; got ([0-9]+)"
+
+wrong_output = mkRegex "^expected (stdout|stderr) not matched by reality$"
+
+out_of_heap = mkRegex "^\\+ Heap exhausted;$"
+
+out_of_stack = mkRegex "^\\+ Stack space overflow:"
+
+parse_log :: String -> ResultTable
+parse_log
+ = combine_results -- collate information
+ . concat
+ . map process_chunk -- get information from each chunk
+ . tail -- first chunk is junk
+ . chunk_log [] [] -- break at banner lines
+ . lines
+
+combine_results :: [(String,Results)] -> FiniteMap String Results
+combine_results = foldr f emptyFM
+ where
+ f (prog,results) fm = addToFM_C comb fm prog results
+ comb Results{ compile_time = ct1, link_time = lt1,
+ module_size = ms1,
+ run_time = rt1, mut_time = mt1,
+ instrs = is1, mem_reads = mr1, mem_writes = mw1,
+ gc_time = gt1, gc_work = gw1,
+ binary_size = bs1, allocs = al1,
+ run_status = rs1, compile_status = cs1 }
+ Results{ compile_time = ct2, link_time = lt2,
+ module_size = ms2,
+ run_time = rt2, mut_time = mt2,
+ instrs = is2, mem_reads = mr2, mem_writes = mw2,
+ gc_time = gt2, gc_work = gw2,
+ binary_size = bs2, allocs = al2,
+ run_status = rs2, compile_status = cs2 }
+ = Results{ compile_time = plusFM_C const ct1 ct2,
+ module_size = plusFM_C const ms1 ms2,
+ link_time = combMaybes lt1 lt2,
+ run_time = combMaybes rt1 rt2,
+ mut_time = combMaybes mt1 mt2,
+ instrs = combMaybes is1 is2,
+ mem_reads = combMaybes mr1 mr2,
+ mem_writes = combMaybes mw1 mw2,
+ gc_time = combMaybes gt1 gt2,
+ gc_work = combMaybes gw1 gw2,
+ binary_size = combMaybes bs1 bs2,
+ allocs = combMaybes al1 al2,
+ run_status = combStatus rs1 rs2,
+ compile_status = combStatus cs1 cs2 }
+
+combMaybes m1 m2 = case maybeToList m1 ++ maybeToList m2 of
+ [] -> Nothing
+ (x:_) -> Just x
+
+combStatus NotDone x = x
+combStatus x NotDone = x
+combStatus x y = x
+
+chunk_log :: [String] -> [String] -> [String] -> [([String],[String])]
+chunk_log header chunk [] = [(header,chunk)]
+chunk_log header chunk (l:ls) =
+ case matchRegex banner_re l of
+ Nothing -> chunk_log header (l:chunk) ls
+ Just stuff -> (header,chunk) : chunk_log stuff [] ls
+
+process_chunk :: ([String],[String]) -> [(String,Results)]
+process_chunk (prog : what : mod : _, chk) =
+ case what of
+ "time to compile" -> parse_compile_time prog mod chk
+ "time to run" -> parse_run_time prog (reverse chk) NotDone
+ "time to link" -> parse_link_time prog chk
+ "size of" -> parse_size prog mod chk
+ _ -> error ("process_chunk: "++what)
+
+parse_compile_time prog mod [] = []
+parse_compile_time prog mod (l:ls) =
+ case matchRegex time_re l of {
+ Just (real:user:system:_) ->
+ let ct = addToFM emptyFM mod (read user)
+ in
+ [(prog,emptyResults{compile_time = ct})];
+ Nothing ->
+
+ case matchRegex ghc1_re l of {
+ Just (allocs:_:_:_:_:init:_:mut:_:gc:_) ->
+ let
+ read_mut = read mut
+ read_gc = read gc
+ time = (read init + read_mut + read_gc) :: Float
+ ct = addToFM emptyFM mod time
+ in
+ [(prog,emptyResults{compile_time = ct})];
+ Nothing ->
+
+ case matchRegex ghc2_re l of {
+ Just (allocs:_:_:_:_:_:init:_:mut:_:gc:_) ->
+ let
+ read_mut = read mut
+ read_gc = read gc
+ time = (read init + read_mut + read_gc) :: Float
+ ct = addToFM emptyFM mod time
+ in
+ [(prog,emptyResults{compile_time = ct})];
+ Nothing ->
+
+ case matchRegex ghc3_re l of {
+ Just (allocs:_:_:_:_:_:_:init:_:mut:_:gc:_) ->
+ let
+ read_mut = read mut
+ read_gc = read gc
+ time = (read init + read_mut + read_gc) :: Float
+ ct = addToFM emptyFM mod time
+ in
+ [(prog,emptyResults{compile_time = ct})];
+ Nothing ->
+
+ case matchRegex ghc4_re l of {
+ Just (allocs:_:_:_:_:_:_:init:_:mut:_:gc:_:_:_:_) ->
+ let
+ read_mut = read mut
+ read_gc = read gc
+ time = (read init + read_mut + read_gc) :: Float
+ ct = addToFM emptyFM mod time
+ in
+ [(prog,emptyResults{compile_time = ct})];
+ Nothing ->
+
+ parse_compile_time prog mod ls
+ }}}}}
+
+parse_link_time prog [] = []
+parse_link_time prog (l:ls) =
+ case matchRegex time_re l of
+ Nothing -> parse_link_time prog ls
+ Just (real:user:system:_) ->
+ [(prog,emptyResults{link_time = Just (read user)})]
+
+parse_run_time prog [] NotDone = []
+parse_run_time prog [] ex =[(prog,emptyResults{run_status=ex})]
+parse_run_time prog (l:ls) ex =
+ case matchRegex ghc1_re l of {
+ Just (allocs:_:_:_:_:init:_:mut:_:gc:_) ->
+ let
+ read_mut = read mut
+ read_gc = read gc
+ time = (read init + read_mut + read_gc) :: Float
+ in
+ [(prog,emptyResults{run_time = Just time,
+ mut_time = Just read_mut,
+ gc_time = Just read_gc,
+ allocs = Just (read allocs),
+ run_status = Success })];
+ Nothing ->
+
+ case matchRegex ghc2_re l of {
+ Just (allocs:_:_:_:_:_:init:_:mut:_:gc:_) ->
+ let
+ read_mut = read mut
+ read_gc = read gc
+ time = (read init + read_mut + read_gc) :: Float
+ in
+ [(prog,emptyResults{run_time = Just time,
+ mut_time = Just read_mut,
+ gc_time = Just read_gc,
+ allocs = Just (read allocs),
+ run_status = Success })];
+ Nothing ->
+
+ case matchRegex ghc3_re l of {
+ Just (allocs:_:_:_:_:gc_work:_:init:_:mut:_:gc:_) ->
+ let
+ read_mut = read mut
+ read_gc = read gc
+ read_gc_work = read gc_work
+ time = (read init + read_mut + read_gc) :: Float
+ in
+ [(prog,emptyResults{run_time = Just time,
+ mut_time = Just read_mut,
+ gc_work = Just read_gc_work,
+ gc_time = Just read_gc,
+ allocs = Just (read allocs),
+ run_status = Success })];
+ Nothing ->
+
+ case matchRegex ghc4_re l of {
+ Just (allocs:_:_:_:_:gc_work:_:init:_:mut:_:gc:_:is:mem_rs:mem_ws:_) ->
+ let
+ read_mut = read mut
+ read_gc = read gc
+ read_gc_work = read gc_work
+ time = (read init + read_mut + read_gc) :: Float
+ in
+ [(prog,emptyResults{run_time = Just time,
+ mut_time = Just read_mut,
+ gc_work = Just read_gc_work,
+ gc_time = Just read_gc,
+ instrs = Just (read is),
+ mem_writes = Just (read mem_ws),
+ mem_reads = Just (read mem_rs),
+ allocs = Just (read allocs),
+ run_status = Success })];
+ Nothing ->
+
+ case matchRegex wrong_output l of {
+ Just ("stdout":_) ->
+ parse_run_time prog ls (combineRunResult WrongStdout ex);
+ Just ("stderr":_) ->
+ parse_run_time prog ls (combineRunResult WrongStderr ex);
+ Nothing ->
+
+ case matchRegex wrong_exit_status l of {
+ Just (wanted:got:_) ->
+ parse_run_time prog ls (combineRunResult (Exit (read got)) ex);
+ Nothing ->
+
+ case matchRegex out_of_heap l of {
+ Just _ ->
+ parse_run_time prog ls (combineRunResult OutOfHeap ex);
+ Nothing ->
+
+ case matchRegex out_of_stack l of {
+ Just _ ->
+ parse_run_time prog ls (combineRunResult OutOfStack ex);
+ Nothing ->
+ parse_run_time prog ls ex;
+
+ }}}}}}}}
+
+combineRunResult OutOfHeap _ = OutOfHeap
+combineRunResult _ OutOfHeap = OutOfHeap
+combineRunResult OutOfStack _ = OutOfStack
+combineRunResult _ OutOfStack = OutOfStack
+combineRunResult (Exit e) _ = Exit e
+combineRunResult _ (Exit e) = Exit e
+combineRunResult exit _ = exit
+
+parse_size prog mod [] = []
+parse_size prog mod (l:ls) =
+ case matchRegex size_re l of
+ Nothing -> parse_size prog mod ls
+ Just (text:datas:bss:_)
+ | prog == mod ->
+ [(prog,emptyResults{binary_size =
+ Just (read text + read datas),
+ compile_status = Success})]
+ | otherwise ->
+ let ms = addToFM emptyFM mod (read text)
+ in
+ [(prog,emptyResults{module_size = ms})]
+
projects / ghc-hetmet.git / commitdiff