Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
obsidiansystems
GHC
Commits
b7081c5f
Commit
b7081c5f
authored
Nov 12, 1999
by
simonmar
Browse files
[project @ 1999-11-12 11:54:09 by simonmar]
Initial revision
parent
bfb850f9
Changes
9
Hide whitespace changes
Inline
Side-by-side
glafp-utils/nofib-analyse/ClassTable.hs
0 → 100644
View file @
b7081c5f
-----------------------------------------------------------------------------
-- 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
0 → 100644
View file @
b7081c5f
-----------------------------------------------------------------------------
-- 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
0 → 100644
View file @
b7081c5f
-------------------------------------------------------------------------------
-- $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
'<'
=
">"
htmlizeChar
'>'
=
"<"
htmlizeChar
'&'
=
"&amb;"
htmlizeChar
'"'
=
"""
htmlizeChar
c
=
[
c
]
------------------------------------------------------------------------------
-- Html Constructors
h
n
=
tag
(
"h"
++
show
n
)
-- Isn't Haskell great!
[
h1
,
h2
,
h3
,
h4
,
h5
,
h6
]
=
map
h
[
1
..
6
]
-- tags
font
=
tag
"font"
bold
=
tag
"b"
anchor
=
tag
"a"
header
=
tag
"header"
body
=
tag
"body"
theTitle
=
tag
"title"
paragraph
=
tag
"p"
italics
=
tag
"i"
ul
=
tag
"ul"
tt
=
tag
"tt"
bar
=
atag
"hr"
meta
=
atag
"meta"
li
=
atag
"li"
------------------------------------------------------------------------------
-- Html Attributes
-- note: the string is presumed to be formated for output
--str :: String -> String -> HtmlAttr
str
n
s
=
(
n
,
Right
s
)
--int :: String -> Int -> HtmlAttr
int
n
v
=
(
n
,
Left
v
)
--percent :: String -> Int -> HtmlAttr
percent
n
v
=
str
n
(
show
v
++
"%"
)
-- attributes
color
=
str
"color"
bgcolor
=
str
"bgcolor"
href
=
str
"href"
name
=
str
"name"
title
=
str
"tile"
height
=
str
"height"
width
=
str
"width"
align
=
str
"align"
valign
=
str
"valign"
border
=
int
"border"
size
=
int
"size"
cellpadding
=
int
"cellpadding"
cellspacing
=
int
"cellspacing"
------------------------------------------------------------------------------
-- abbriviations
p
=
paragraph
[]
hr
=
atag
"hr"
[]
copyright
=
primHtml
"©"
spaceHtml
=
primHtml
" "
------------------------------------------------------------------------------
-- Rendering
renderHtml
html
=
renderHtml'
html
(
Just
0
)
++
footerMessage
footerMessage
=
"
\n
<!-- Generated using the Haskell HTML generator package HaskHTML -->
\n
"
renderHtml'
(
HtmlAppend
html1
html2
)
d
=
renderHtml'
html1
d
++
renderHtml'
html2
d
renderHtml'
(
HtmlVerbatim
html1
)
d
=
renderHtml'
html1
Nothing
renderHtml'
(
HtmlEmpty
)
d
=
""
renderHtml'
(
HtmlSimpleTag
name
attr
)
d
=
renderTag
True
name
attr
d
renderHtml'
(
HtmlNestingTag
name
attr
html
)
d
=
renderTag
True
name
attr
d
++
renderHtml'
html
(
incDepth
d
)
++
renderTag
False
name
[]
d
renderHtml'
(
HtmlString
str
)
_
=
str
incDepth
::
Maybe
Int
->
Maybe
Int
incDepth
=
fmap
(
+
4
)
-- This prints the tags in
renderTag
::
Bool
->
HtmlName
->
[
HtmlAttr
]
->
Maybe
Int
->
String
renderTag
x
name
attrs
n
=
start
++
base_spaces
++
open
++
name
++
rest
attrs
++
">"
where
open
=
if
x
then
"<"
else
"</"
(
start
,
base_spaces
,
sep
)
=
case
n
of
Nothing
->
(
""
,
""
,
" "
)
Just
n
->
(
"
\n
"
,
replicate
n
' '
,
"
\n
"
)
rest
[]
=
""
rest
[(
tag
,
val
)]
=
" "
++
tag
++
"="
++
myShow
val
rest
(
hd
:
tl
)
=
" "
++
showPair
hd
++
sep
++
foldr1
(
\
x
y
->
x
++
sep
++
y
)
[
base_spaces
++
replicate
(
1
+
length
name
+
1
)
' '
++
showPair
p
|
p
<-
tl
]
showPair
::
HtmlAttr
->
String
showPair
(
tag
,
val
)
=
tag
++
replicate
(
tagsz
-
length
tag
)
' '
++
" = "
++
myShow
val
myShow
(
Left
n
)
=
show
n
myShow
(
Right
s
)
=
"
\"
"
++
s
++
"
\"
"
tagsz
=
maximum
(
map
(
length
.
fst
)
attrs
)
------------------------------------------------------------------------------
-- Html table related things
cellHtml
attr
html
=
OT
.
single
cellFn
where
cellFn
x
y
=
tag
"td"
(
addX
x
(
addY
y
attr
))
html
addX
1
rest
=
rest
addX
n
rest
=
int
"colspan"
n
:
rest
addY
1
rest
=
rest
addY
n
rest
=
int
"rowspan"
n
:
rest
above
=
OT
.
above
(
+/+
)
=
above
beside
=
OT
.
beside
(
+-+
)
=
beside
{-
- Note: Both aboves and besides presume a non-empty list.
-}
aboves
=
foldl1
(
+/+
)
besides
=
foldl1
(
+-+
)
-- renderTable takes the HtmlTable, and renders it back into
-- and Html object. The attributes are added to the outside
-- table tag.
renderTable
attr
theTable
=
table
[
row
[
theCell
x
y
|
(
theCell
,(
x
,
y
))
<-
theRow
]
|
theRow
<-
OT
.
getMatrix
theTable
]
where
row
::
[
Html
]
->
Html
row
=
tag
"tr"
[]
.
concatHtml
table
::
[
Html
]
->
Html
table
=
tag
"table"
attr
.
concatHtml
-- If you cant be bothered with the above, then you
-- can build simple tables with this.
-- Just provide the attributes for the whole table,
-- attributes for the cells (same for every cell),
-- and a list of list of cell contents,
-- and this function will build the table for you.
-- It does presume that all the lists are non-empty,
-- and there is at least one list.
--
-- Different length lists means that the last cell
-- gets padded. If you want more power, then
-- use the system above.
simpleTable
attr
cellAttr
=
renderTable
attr
.
aboves
.
map
(
besides
.
map
(
cellHtml
cellAttr
))
------------------------------------------------------------------------------
glafp-utils/nofib-analyse/GenUtils.lhs
0 → 100644
View file @
b7081c5f
-----------------------------------------------------------------------------
-- $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