Commit b7081c5f authored by simonmar's avatar simonmar
Browse files

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

Initial revision
parent bfb850f9
-----------------------------------------------------------------------------
-- 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 ""
-----------------------------------------------------------------------------
-- 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>"
]
-------------------------------------------------------------------------------
-- $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 &gt;,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 ' ' = "&nbsp;"
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))
------------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- $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