[project @ 1999-11-12 11:54:09 by simonmar]

Initial revision

glafp-utils/nofib-analyse/ClassTable.hs

+-----------------------------------------------------------------------------
+-- 	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 ""
+
+

glafp-utils/nofib-analyse/CmdLine.hs

+-----------------------------------------------------------------------------
+-- 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>"
+  ]
+

glafp-utils/nofib-analyse/DataHtml.hs

+-------------------------------------------------------------------------------
+-- $Id: DataHtml.hs,v 1.1 1999/11/12 11:54:17 simonmar 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 '<' = "&gt;"
+htmlizeChar '>' = "&lt;"
+htmlizeChar '&' = "&amb;"
+htmlizeChar '"' = "&quot;"
+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 "&copy;"
+spaceHtml 	= primHtml "&nbsp;"
+
+------------------------------------------------------------------------------
+-- 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))
+
+	
+------------------------------------------------------------------------------

glafp-utils/nofib-analyse/GenUtils.lhs

+-----------------------------------------------------------------------------
+-- $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
+