PrintUtil.icl 3.71 KB
Newer Older
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
1
2
3
4
5
6
implementation module PrintUtil

import StdArray, StdFile, StdList, StdString, ArgEnv
import StdGeneric
import StdStrictLists
import Gerda
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
7
import DataFile
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

:: Url 	:== String

generic gHpr a :: !*HtmlStream !a -> *HtmlStream

gHpr{|String|}              file s              = [|s:file]			// the only entry that actually prints something
																	// all others eventually come here converted to string

gHpr{|Int|}                 file i              = [|toString i:file]
gHpr{|Real|}                file r              = [|toString r:file] 
gHpr{|Bool|}                file b              = [|toString b:file]
gHpr{|Char|}                file c              = [|toString c:file]
gHpr{|UNIT|}                file _ 				= file
gHpr{|PAIR|}   gHpra gHprb  file (PAIR a b) 	= gHprb (gHpra file a) b
gHpr{|EITHER|} gHprl gHprr  file (LEFT left) 	= gHprl file left
gHpr{|EITHER|} gHprl gHprr  file (RIGHT right) 	= gHprr file right
gHpr{|OBJECT|} gHpro        file (OBJECT object)= gHpro file object 

gHpr{|CONS of t|} gPrHtmlc prev (CONS c)		// constructor names are printed, prefix Foo_ is stripped
= case t.gcd_name.[0] of
	'`' 	= 	gPrHtmlc prev c					// just skip this constructor name
	else	=	case t.gcd_arity of
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
30
31
					0 = prev <+ myprint t.gcd_name	 
					1 = gPrHtmlc (prev <+ " " <+ myprint t.gcd_name <+ "=\"") c	<+ "\"" 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
					n = gPrHtmlc (prev <+ " " <+ myprint t.gcd_name         ) c
where
	myprint :: String -> String
	myprint string = {toLower` char \\ char <-: stripprefix string }
	
	toLower` '_' = '-'
	toLower` c = toLower c 

	stripprefix string 
	# list = fromString string
	| isMember '_' list = toString (tl (dropWhile ((<>) '_') list))
	| otherwise 		= string  

gHpr{|[]|} gHlist file list = myfold file list 
where
	myfold file [x:xs] = myfold (gHlist file x) xs
	myfold file [] = file

// utility print functions based on gHpr

print			:: !String -> FoF
print a			= \f -> [|a:f]

(<+)  infixl	:: !*HtmlStream !a -> *HtmlStream | gHpr{|*|} a
(<+)  file new	= gHpr{|*|} file new

(<+>) infixl	:: !*HtmlStream !FoF -> *HtmlStream
(<+>) file new	= new file

print_to_stdout :: !a !*NWorld -> *NWorld | gHpr{|*|} a
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
62
print_to_stdout value nw=:{inout}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
# inout = inout <+ value
= {nw & inout = inout}

htmlCmnd		:: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
htmlCmnd		hdr txt			= \file -> closeCmnd hdr (openCmnd hdr "" file <+ txt)

openCmnd		:: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
openCmnd		hdr attr		= \file -> [|"<":file]  <+ hdr <+ attr <+ ">"

closeCmnd		:: !a -> FoF | gHpr{|*|} a
closeCmnd		hdr				= \file -> print "</" file <+ hdr <+ ">"

htmlAttrCmnd	:: !hdr !attr !body -> FoF | gHpr{|*|} hdr & gHpr{|*|} attr & gHpr{|*|} body
htmlAttrCmnd	hdr attr txt	= \file -> closeCmnd hdr (openCmnd hdr attr file <+ txt)

styleCmnd		:: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
styleCmnd		stylename attr	= \file -> print "." file <+ stylename <+ "{" <+ attr <+ "}"

styleAttrCmnd	:: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
styleAttrCmnd	name value		= \file -> print "" file <+ name <+ ": " <+ value <+ ";"

instance FileSystem NWorld where
	fopen string int nworld=:{worldC}
		# (bool,file,worldC) = fopen string int worldC
		= (bool,file,{nworld & worldC = worldC})

	fclose file nworld=:{worldC}
		# (bool,worldC) = fclose file worldC
		= (bool,{nworld & worldC = worldC})

	stdio nworld=:{worldC}
		# (file,worldC) = stdio worldC
		= (file,{nworld & worldC = worldC})

	sfopen string int nworld=:{worldC}
		# (bool,file,worldC) = sfopen string int worldC
		= (bool,file,{nworld & worldC = worldC})

appWorldNWorld :: !.(*World -> *World) !*NWorld -> *NWorld
appWorldNWorld f nw=:{worldC}
	= {nw & worldC=f worldC}

accWorldNWorld :: !.(*World -> *(.a,*World)) !*NWorld -> (.a,!*NWorld)
accWorldNWorld f nw=:{worldC}
	# (a,worldC)	= f worldC
	= (a,{nw & worldC=worldC})