1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
4 * This program is free software
; you can redistribute it
and/or
5 * modify it under the terms
of the GNU General Public License
6 * as published by the Free Software Foundation
; either version
2
7 * of the License
, or (at your option
) any later version
.
9 * This program is distributed
in the hope that it will be useful
,
10 * but WITHOUT ANY WARRANTY
; without even the implied warranty
of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
. See the
12 * GNU General Public License for more details
.
14 * You should have received a copy
of the GNU General Public License
15 * along
with this program
; if not
, write to the Free Software
16 * Foundation
, Inc
., 51 Franklin Street
, Fifth Floor
, Boston
, MA
02110-1301, USA
.
19 (* Pretty
-printing Domtool configuration file ASTs for HTML
*)
21 structure HtmlPrint
:> HTML_PRINT
= struct
25 val prov
: providers option ref
= ref NONE
26 fun setProviders p
= prov
:= SOME p
28 structure TextToken
= struct
30 type style
= HTMLDev
.style
32 fun style t
= HTMLDev
.styleTT
33 fun size t
= String.size t
36 structure SM
= PPStreamFn(structure Token
= TextToken
37 structure Device
= HTMLDev
)
39 structure PD
= PPDescFn(SM
)
42 fun dBox ds
= hovBox (PPS
.Rel
1, ds
)
43 fun dvBox ds
= vBox (PPS
.Rel
0, ds
)
44 fun ivBox ds
= vBox (PPS
.Rel
1, ds
)
46 fun keyword s
= style (HTMLDev
.styleB
, [string s
])
51 val file
' = #
file (OS
.Path
.splitDirFile file
)
52 val file
' = #
base (OS
.Path
.splitBaseExt file
')
58 case providesContext (valOf (!prov
), s
) of
60 | SOME m
=> style (HTMLDev
.link (modify m ^
".html#C_" ^ s
), [string s
])
62 case providesType (valOf (!prov
), s
) of
64 | SOME m
=> style (HTMLDev
.link (modify m ^
".html#T_" ^ s
), [string s
])
66 case providesValue (valOf (!prov
), s
) of
68 | SOME m
=> style (HTMLDev
.link (modify m ^
".html#V_" ^ s
), [string s
])
76 dBox (punct
"(" :: ds @
[punct
")"])
80 fun p_pred
' pn (p
, _
) =
82 CRoot
=> keyword
"Root"
83 | CConst s
=> context s
84 | CPrefix p
=> dBox
[punct
"^", p_pred
' true p
]
85 | CNot p
=> dBox
[punct
"!", p_pred
' true p
]
87 parenIf pn
[p_pred
' true p1
, space
1, punct
"&", space
1, p_pred
' true p2
]
89 val p_pred
= p_pred
' false
91 fun p_predBoxed p
= dBox
[punct
"[", p_pred p
, punct
"]"]
93 fun p_typ
' pn (t
, _
) =
96 | TList t
=> dBox
[punct
"[", p_typ
' false t
, punct
"]"]
98 parenIf pn
[p_typ
' true t1
, space
1, punct
"->", space
1, p_typ
' false t2
]
99 |
TAction (p
, r1
, r2
) =>
100 (case (StringMap
.numItems r1
, StringMap
.numItems r2
) of
101 (0, 0) => parenIf pn
[p_predBoxed p
]
102 |
(_
, 0) => parenIf pn
[p_predBoxed p
, space
1, p_record r1
]
103 | _
=> parenIf pn
[p_predBoxed p
, space
1, p_record r1
, space
1,
104 punct
"=>", space
1, p_record r2
])
106 parenIf pn
[p_pred
' false p
, space
1, punct
"=>", space
1, p_typ
' false t
]
108 | TError
=> keyword
"<error>"
109 |
TUnif (_
, ref (SOME t
)) => p_typ
' pn t
110 |
TUnif (name
, ref NONE
) => string ("<" ^ name ^
">")
113 case StringMap
.foldri (fn (name
, t
, d
) =>
115 NONE
=> dBox
[field name
, space
1,
116 punct
":", space
1, p_typ t
]
117 | SOME d
=> dBox
[dBox
[field name
, space
1,
118 punct
":", space
1, p_typ t
],
119 punct
",", space
1, d
]))
122 | SOME d
=> dBox
[punct
"{", d
, punct
"}"]
124 and p_typ t
= p_typ
' false t
128 EInt n
=> lit (Int.toString n
)
129 | EString s
=> lit (String.concat
["\"", String.toString s
, "\""])
131 (case foldr (fn (e
, d
) =>
134 | SOME d
=> dBox
[p_exp e
, punct
",", space
1, d
]))
137 | SOME d
=> dBox
[punct
"[", d
, punct
"]"])
139 |
ELam (x
, NONE
, e
) => dBox
[punct
"(\\", space
1, exp x
, space
1,
140 punct
"->", space
1, p_exp e
, punct
")"]
141 |
ELam (x
, SOME t
, e
) => dBox
[punct
"(\\", space
1, exp x
, space
1,
143 dBox
[punct
"(", p_typ t
, punct
")"],
144 space
1, punct
"->", space
1, p_exp e
, punct
")"]
145 |
EALam (x
, p
, e
) => dBox
[punct
"(\\", space
1, exp x
, space
1,
146 punct
":", space
1, p_pred p
,
147 space
1, punct
"->", space
1, p_exp e
, punct
")"]
150 |
EApp (e1
, e2
) => dBox
[punct
"(", p_exp e1
, break
{nsp
= 1, offset
= 0}, p_exp e2
, punct
")"]
152 | ESkip
=> keyword
"_"
153 |
ESet (x
, e
) => dBox
[exp x
, space
1, punct
"=", space
1, p_exp e
]
154 |
EGet (x1
, x2
, e
) => dBox
[dBox
[exp x1
, space
1, punct
"<-",
155 space
1, exp x2
, punct
";", space
1],
157 | ESeq es
=> dBox (valOf (foldr (fn (e
, NONE
) => SOME
[p_exp e
]
158 |
(e
, SOME ds
) => SOME (dBox
[p_exp e
, punct
";", newline
] :: ds
))
160 |
ELocal (e1
, e2
) => dBox
[keyword
"let", space
1,
162 keyword
"in", space
1,
165 |
EWith (e1
, (ESkip
, _
)) => dBox
[p_exp e1
, space
1, keyword
"with", space
1, keyword
"end"]
166 |
EWith (e1
, e2
) => dBox
[p_exp e1
, space
1, keyword
"with", p_exp e2
, space
1, keyword
"end"]
170 DExternType name
=> style (HTMLDev
.anchor ("T_" ^ name
),
171 [dBox
[keyword
"extern", space
1,
172 keyword
"type", space
1,
174 |
DExternVal (name
, t
) => style (HTMLDev
.anchor ("V_" ^ name
),
175 [dBox
[keyword
"extern", space
1,
176 keyword
"val", space
1,
180 |
DVal (name
, NONE
, _
) => string "Unannotated val declaration!"
181 |
DVal (name
, SOME t
, _
) => style (HTMLDev
.anchor ("V_" ^ name
),
182 [dBox
[keyword
"val", space
1,
186 | DContext name
=> style (HTMLDev
.anchor ("C_" ^ name
),
187 [dBox
[keyword
"context", space
1,
192 DExternType name
=> dBox
[keyword
"extern", space
1,
193 keyword
"type", space
1,
194 style (HTMLDev
.link ("#T_" ^ name
), [ident name
])]
195 |
DExternVal (name
, t
) => dBox
[keyword
"extern", space
1,
196 keyword
"val", space
1,
197 style (HTMLDev
.link ("#V_" ^ name
), [ident name
]),
201 |
DVal (name
, NONE
, _
) => string "Unannotated val declaration!"
202 |
DVal (name
, SOME t
, _
) => dBox
[keyword
"val", space
1,
203 style (HTMLDev
.link ("#V_" ^ name
), [ident name
]),
207 | DContext name
=> dBox
[keyword
"context", space
1,
208 style (HTMLDev
.link ("#C_" ^ name
), [ident name
])]
212 val dev
= HTMLDev
.openDev
{wid
= 80,
214 val myStream
= SM
.openStream dev
216 description (myStream
, d
);
217 SM
.flushStream myStream
;