2 * Dynamic web page generation
with Standard ML
3 * Copyright (C
) 2003 Adam Chlipala
5 * This library is free software
; you can redistribute it
and/or
6 * modify it under the terms
of the GNU Lesser General Public
7 * License
as published by the Free Software Foundation
; either
8 * version
2.1 of the License
, or (at your option
) any later version
.
10 * This library is distributed
in the hope that it will be useful
,
11 * but WITHOUT ANY WARRANTY
; without even the implied warranty
of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
. See the GNU
13 * Lesser General Public License for more details
.
15 * You should have received a copy
of the GNU Lesser General Public
16 * License along
with this library
; if not
, write to the Free Software
17 * Foundation
, Inc
., 59 Temple Place
, Suite
330, Boston
, MA
02111-1307 USA
20 (* Translation
of templates into SML source
*)
22 structure Mlt
:> MLT
=
28 fun error (pos
, msg
) = (ErrorMsg
.error pos msg
;
33 datatype var
= VAR
of Types
.ty | REF
of Types
.ty
35 val errorTy
= Types
.WILDCARDty
37 val ppstream
= PrettyPrint
.mk_ppstream
{consumer
= TextIO.print
, flush
= fn () => TextIO.flushOut
TextIO.stdOut
,
40 (* States to thread throughout translation
*)
42 datatype state
= STATE
of {env
: StaticEnv
.staticEnv
,
43 vars
: var StringMap
.map
,
44 config
: Config
.config
,
45 templates
: StringSet
.set
}
47 datatype strct
= STRCT
of {elements
: Modules
.elements
,
48 eenv
: EntityEnv
.entityEnv
}
50 fun getElements (Modules
.SIG
{elements
, ...}) = elements
51 | getElements _
= raise Fail
"Unexpected Signature in getElements"
53 val bogusStamp
= Stamps
.special
"<bogus>"
54 val errorStrct
= STRCT
{elements
= [], eenv
= EntityEnv
.empty
}
56 fun mkState (config
, env
, templates
) =
57 STATE
{config
= config
,
59 vars
= StringMap
.empty
,
60 templates
= templates
}
62 fun addVar (STATE
{config
, env
, vars
, templates
}, v
, ty
) =
63 STATE
{config
= config
, env
= env
, vars
= StringMap
.insert (vars
, v
, ty
), templates
= templates
}
64 fun addVars (state
, vars
) = StringMap
.foldli (fn (v
, ty
, state
) => addVar (state
, v
, ty
)) state vars
66 fun getVar (STATE
{vars
, ...}, v
, pos
) = StringMap
.find (vars
, v
)
67 fun lookVal (STATE
{env
, ...}, v
, pos
) =
68 (case StaticEnv
.look (env
, Symbol
.varSymbol v
) of
69 Bindings
.VALbind var
=>
71 VarCon
.VALvar
{typ
, ...} => #
1 (TypesUtil
.instantiatePoly (!typ
))
72 | _
=> raise Fail
"Unexpected var in lookVal")
73 | Bindings
.CONbind (Types
.DATACON
{typ
, ...}) => #
1 (TypesUtil
.instantiatePoly typ
)
74 | _
=> raise Fail
"Unexpected binding in lookVal")
75 handle StaticEnv
.Unbound
=> (error (SOME pos
, "Unbound variable " ^ v
);
78 fun lookCon
' (STATE
{env
, ...}, v
) =
79 (case StaticEnv
.look (env
, Symbol
.varSymbol v
) of
80 Bindings
.CONbind (Types
.DATACON
{typ
, ...}) => #
1 (TypesUtil
.instantiatePoly typ
)
81 | _
=> raise Fail
"Unexpected binding in lookVal")
82 fun lookCon (env
, v
, pos
) = (lookCon
' (env
, v
))
83 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound constructor " ^ v
);
85 fun lookStr (STATE
{env
, ...}, v
, pos
) =
86 (case StaticEnv
.look (env
, Symbol
.strSymbol v
) of
87 Bindings
.STRbind modl
=>
89 Modules
.STR
{rlzn
= {entities
, ...}, sign
, ...} => STRCT
{elements
= getElements sign
,
91 | _
=> raise Fail
"Unexpected module in lookStr")
92 | _
=> raise Fail
"Unexpected binding in lookStr")
93 handle StaticEnv
.Unbound
=> (error (SOME pos
, "Unbound structure " ^ v
);
96 fun getStr (STRCT
{elements
, eenv
, ...}, v
, pos
) =
97 (case ModuleUtil
.getStr (elements
, eenv
, Symbol
.strSymbol v
, Access
.nullAcc
, II
.Null
) of
98 (Modules
.STR
{rlzn
= {entities
, ...}, sign
= Modules
.SIG
{elements
, ...}, ...}, _
) =>
99 STRCT
{elements
= elements
, eenv
= entities
}
100 | _
=> raise Fail
"Unexpected spec in getStr")
101 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound structure " ^ v
);
103 fun getVal (STRCT
{elements
, ...}, v
, pos
) =
104 (case ModuleUtil
.getSpec (elements
, Symbol
.varSymbol v
) of
105 Modules
.VALspec
{spec
, ...} => #
1 (TypesUtil
.instantiatePoly spec
)
106 | _
=> raise Fail
"Unexpected spec in getVal")
107 handle ModuleUtil
.Unbound _
=> (case ModuleUtil
.getSpec (elements
, Symbol
.tycSymbol v
) of
108 Modules
.CONspec
{spec
= Types
.DATACON
{typ
, ...}, ...} => #
1 (TypesUtil
.instantiatePoly typ
)
109 | _
=> raise Fail
"Unexpected spec in getVal")
110 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound variable " ^ v
);
112 fun getCon (STRCT
{elements
, ...}, v
, pos
) =
113 (case ModuleUtil
.getSpec (elements
, Symbol
.varSymbol v
) of
114 Modules
.CONspec
{spec
= Types
.DATACON
{typ
, ...}, ...} => #
1 (TypesUtil
.instantiatePoly typ
)
115 | _
=> raise Fail
"Unexpected spec in getVal")
116 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound constructor " ^ v
);
119 fun unify (STATE
{env
, ...}) (pos
, t1
, t2
) =
121 val t1
= ModuleUtil
.transType eenv t1
122 val t2
= ModuleUtil
.transType eenv t2
124 Unify
.unifyTy (t1
, t2
)
126 handle Unify
.Unify msg
=>
127 (PrettyPrint
.begin_block ppstream PrettyPrint
.CONSISTENT
0;
128 PrettyPrint
.add_string ppstream
"Error unifying\n\t";
129 PrettyPrint
.add_break
ppstream (0, 0);
130 PrettyPrint
.begin_block ppstream PrettyPrint
.CONSISTENT
5;
131 PPType
.ppType env ppstream t1
;
132 PrettyPrint
.end_block ppstream
;
133 PrettyPrint
.add_break
ppstream (0, 0);
134 PrettyPrint
.add_string ppstream
"\nand\n\t";
135 PrettyPrint
.add_break
ppstream (0, 0);
136 PrettyPrint
.begin_block ppstream PrettyPrint
.CONSISTENT
5;
137 PPType
.ppType env ppstream t2
;
138 PrettyPrint
.end_block ppstream
;
139 PrettyPrint
.add_string ppstream
"\n";
140 PrettyPrint
.end_block ppstream
;
141 PrettyPrint
.flush_ppstream ppstream
;
142 error (SOME pos
, Unify
.failMessage msg
))
144 fun resolvePath (getter
, transer
) (pos
, state
, path
) =
146 fun traverse ([], _
, _
) = raise Fail
"Impossible empty variable path in pat traverse"
147 |
traverse ([v
], str
as STRCT
{eenv
, ...}, path
) =
149 val ty
= getter (str
, v
, pos
)
150 val ty
= transer eenv ty
151 fun folder (STRCT
{eenv
, ...}, ty
) = transer eenv ty
155 |
traverse (s
::rest
, str
, path
) = traverse (rest
, getStr (str
, s
, pos
), str
::path
)
158 [] => raise Fail
"Empty path to resolvePath"
159 |
[_
] => raise Fail
"Singleton path to resolvePath"
160 |
(first
::rest
) => traverse (rest
, lookStr (state
, first
, pos
), [])
163 fun resolveStructure (pos
, state
, path
) =
165 fun look (STATE
{env
, ...}, v
, pos
) =
166 (case StaticEnv
.look (env
, Symbol
.strSymbol v
) of
167 Bindings
.STRbind modl
=>
169 Modules
.STR
{rlzn
= {entities
, ...}, sign
, ...} => (getElements sign
, entities
, modl
)
170 | _
=> raise Fail
"Unexpected module in lookStr")
171 | _
=> raise Fail
"Unexpected binding in lookStr")
172 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound structure " ^ v
);
173 ([], EntityEnv
.empty
, Modules
.ERRORstr
))
175 fun get (elements
, eenv
, v
) =
177 val sym
= Symbol
.strSymbol v
179 (case ModuleUtil
.getStr (elements
, eenv
, sym
, Access
.nullAcc
, II
.Null
) of
180 (str
as Modules
.STR
{rlzn
= {entities
, ...}, sign
= Modules
.SIG
{elements
, ...}, ...}, _
) =>
181 (elements
, entities
, str
)
182 | _
=> raise Fail
"Unexpected spec in resolveStructure")
183 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound structure " ^ v
);
184 ([], EntityEnv
.empty
, Modules
.ERRORstr
))
187 fun traverse ([], (_
, _
, str
)) = str
188 |
traverse ([v
], (elements
, eenv
, _
)) = #
3 (get (elements
, eenv
, v
))
189 |
traverse (s
::rest
, (elements
, eenv
, _
)) = traverse (rest
, get (elements
, eenv
, s
))
192 [] => raise Fail
"Empty path to resolveStructure"
193 |
(first
::rest
) => traverse (rest
, look (state
, first
, pos
))
196 fun openStructure (pos
, state
as STATE
{config
, env
, vars
, templates
}, path
) =
198 val str
= resolveStructure (pos
, state
, path
)
199 val env
= ModuleUtil
.openStructure (env
, str
)
201 STATE
{config
= config
, env
= env
, vars
= vars
, templates
= templates
}
204 fun tyToString (STATE
{env
, ...}) ty
=
205 PrettyPrint
.pp_to_string
65535 (PPType
.ppType env
) ty
207 fun printFn (state
as STATE
{config
, env
, ...}) ty
=
209 val tyname
= tyToString state ty
211 Config
.printFn config tyname
214 fun isTemplate (STATE
{templates
, ...}) s
= StringSet
.member (templates
, s
)
217 fun twiddleType f ty
=
218 (case TypesUtil
.headReduceType ty
of
219 Types
.WILDCARDty
=> ty
222 val domain
= twiddleType BasicTypes
.domain
223 val range
= twiddleType BasicTypes
.range
225 (*val _
= (Unify
.debugging
:= true;
226 EntityEnv
.debugging
:= true;
227 ModuleUtil
.debugging
:= true)*)
229 fun newTyvar eq
= Types
.VARty (Types
.mkTyvar (Types
.OPEN
{depth
= 0, eq
= eq
, kind
= Types
.META
}))
230 fun newFlex elms
= Types
.VARty (Types
.mkTyvar (Types
.OPEN
{depth
= 0, eq
= false, kind
= Types
.FLEX elms
}))
232 val resolveVal
= resolvePath (getVal
, ModuleUtil
.transType
)
233 val resolveCon
= resolvePath (getCon
, ModuleUtil
.transType
)
237 val chars
= String.explode s
238 val escd
= map (fn #
"\"" => "\\\""
247 val mkTuple
= BasicTypes
.tupleTy
249 val templateTy
= BasicTypes
.--> (Types
.CONty (BasicTypes
.listTycon
,
250 [mkTuple
[BasicTypes
.stringTy
,
251 BasicTypes
.stringTy
]]), BasicTypes
.unitTy
)
253 fun xexp
state (EXP (e
, pos
)) =
256 (BasicTypes
.intTy
, Int.toString n
)
258 (BasicTypes
.stringTy
, "\"" ^ s ^
"\"")
260 (BasicTypes
.charTy
, "#\"" ^ s ^
"\"")
263 val (ty1
, es1
) = xexp state e1
264 val (ty2
, es2
) = xexp state e2
266 val parm
= newTyvar
false
267 val ran
= Types
.CONty (BasicTypes
.listTycon
, [parm
])
268 val dom
= mkTuple
[parm
, ran
]
270 val xt
= mkTuple
[ty1
, ty2
]
272 unify
state (pos
, dom
, xt
);
273 (ran
, "(" ^ es1 ^
") :: (" ^ es2 ^
")")
275 |
StrCat_e (e1
, e2
) =>
277 val (ty1
, es1
) = xexp state e1
278 val (ty2
, es2
) = xexp state e2
280 unify
state (pos
, ty1
, BasicTypes
.stringTy
);
281 unify
state (pos
, ty2
, BasicTypes
.stringTy
);
282 (BasicTypes
.stringTy
, "(" ^ es1 ^
") ^ (" ^ es2 ^
")")
284 |
Orelse_e (e1
, e2
) =>
286 val (ty1
, es1
) = xexp state e1
287 val (ty2
, es2
) = xexp state e2
289 unify
state (pos
, ty1
, BasicTypes
.boolTy
);
290 unify
state (pos
, ty2
, BasicTypes
.boolTy
);
291 (BasicTypes
.boolTy
, "(" ^ es1 ^
") orelse (" ^ es2 ^
")")
293 |
Andalso_e (e1
, e2
) =>
295 val (ty1
, es1
) = xexp state e1
296 val (ty2
, es2
) = xexp state e2
298 unify
state (pos
, ty1
, BasicTypes
.boolTy
);
299 unify
state (pos
, ty2
, BasicTypes
.boolTy
);
300 (BasicTypes
.boolTy
, "(" ^ es1 ^
") andalso (" ^ es2 ^
")")
304 val (ty1
, es1
) = xexp state e1
305 val (ty2
, es2
) = xexp state e2
307 unify
state (pos
, ty1
, BasicTypes
.intTy
);
308 unify
state (pos
, ty2
, BasicTypes
.intTy
);
309 (BasicTypes
.intTy
, "(" ^ es1 ^
") + (" ^ es2 ^
")")
311 |
Minus_e (e1
, e2
) =>
313 val (ty1
, es1
) = xexp state e1
314 val (ty2
, es2
) = xexp state e2
316 unify
state (pos
, ty1
, BasicTypes
.intTy
);
317 unify
state (pos
, ty2
, BasicTypes
.intTy
);
318 (BasicTypes
.intTy
, "(" ^ es1 ^
") - (" ^ es2 ^
")")
320 |
Times_e (e1
, e2
) =>
322 val (ty1
, es1
) = xexp state e1
323 val (ty2
, es2
) = xexp state e2
325 unify
state (pos
, ty1
, BasicTypes
.intTy
);
326 unify
state (pos
, ty2
, BasicTypes
.intTy
);
327 (BasicTypes
.intTy
, "(" ^ es1 ^
") * (" ^ es2 ^
")")
329 |
Divide_e (e1
, e2
) =>
331 val (ty1
, es1
) = xexp state e1
332 val (ty2
, es2
) = xexp state e2
334 unify
state (pos
, ty1
, BasicTypes
.intTy
);
335 unify
state (pos
, ty2
, BasicTypes
.intTy
);
336 (BasicTypes
.intTy
, "(" ^ es1 ^
") div (" ^ es2 ^
")")
340 val (ty1
, es1
) = xexp state e1
341 val (ty2
, es2
) = xexp state e2
343 unify
state (pos
, ty1
, BasicTypes
.intTy
);
344 unify
state (pos
, ty2
, BasicTypes
.intTy
);
345 (BasicTypes
.intTy
, "(" ^ es1 ^
") mod (" ^ es2 ^
")")
349 val (ty1
, es1
) = xexp state e1
350 val (ty2
, es2
) = xexp state e2
352 unify
state (pos
, ty1
, BasicTypes
.intTy
);
353 unify
state (pos
, ty2
, BasicTypes
.intTy
);
354 (BasicTypes
.boolTy
, "(" ^ es1 ^
") < (" ^ es2 ^
")")
358 val (ty1
, es1
) = xexp state e1
359 val (ty2
, es2
) = xexp state e2
361 unify
state (pos
, ty1
, BasicTypes
.intTy
);
362 unify
state (pos
, ty2
, BasicTypes
.intTy
);
363 (BasicTypes
.boolTy
, "(" ^ es1 ^
") <= (" ^ es2 ^
")")
367 val (ty1
, es1
) = xexp state e1
368 val (ty2
, es2
) = xexp state e2
370 unify
state (pos
, ty1
, BasicTypes
.intTy
);
371 unify
state (pos
, ty2
, BasicTypes
.intTy
);
372 (BasicTypes
.boolTy
, "(" ^ es1 ^
") > (" ^ es2 ^
")")
376 val (ty1
, es1
) = xexp state e1
377 val (ty2
, es2
) = xexp state e2
379 unify
state (pos
, ty1
, BasicTypes
.intTy
);
380 unify
state (pos
, ty2
, BasicTypes
.intTy
);
381 (BasicTypes
.boolTy
, "(" ^ es1 ^
") >= (" ^ es2 ^
")")
383 | Param_e
=> (BasicTypes
.--> (BasicTypes
.stringTy
, BasicTypes
.stringTy
), "Web.getParam")
384 | Neg_e
=> (BasicTypes
.--> (BasicTypes
.intTy
, BasicTypes
.intTy
), "~")
386 if isTemplate state name
then
388 fun toUpper ch
= chr (ord ch
+ ord #
"A" - ord #
"a")
389 val name
= str (toUpper (String.sub (name
, 0))) ^
String.extract (name
, 1, NONE
)
391 (templateTy
, "(Web.withParams " ^ name ^
".exec)")
394 (error (SOME pos
, "Unknown template " ^ name
);
395 (errorTy
, "<errorTemplate>"))
398 val carried
= newTyvar
false
400 (BasicTypes
.--> (newFlex
[(Symbol
.labSymbol field
, carried
)], carried
), "#" ^ field
)
404 val (ty1
, s1
) = xexp state e1
405 val (ty2
, s2
) = xexp state e2
407 unify
state (pos
, ty1
, ty2
);
408 unify
state (pos
, ty1
, newTyvar
true);
409 (BasicTypes
.boolTy
, "(" ^ s1 ^
") = (" ^ s2 ^
")")
413 val (ty1
, s1
) = xexp state e1
414 val (ty2
, s2
) = xexp state e2
416 unify
state (pos
, ty1
, ty2
);
417 unify
state (pos
, ty1
, newTyvar
true);
418 (BasicTypes
.boolTy
, "(" ^ s1 ^
") <> (" ^ s2 ^
")")
420 | Ident_e
[] => raise Fail
"Impossible empty variable path"
422 (case getVar (state
, id
, SOME pos
) of
423 NONE
=> (lookVal (state
, id
, pos
), id
)
424 |
SOME (VAR ty
) => (ty
, id
)
425 |
SOME (REF ty
) => (ty
, "!" ^ id
))
426 |
Ident_e (path
as (s
::rest
)) =>
427 (resolveVal (pos
, state
, path
), foldl (fn (v
, st
) => st ^
"." ^ v
) s rest
)
430 val (ft
, fs
) = xexp state f
431 val (xt
, xs
) = xexp state x
433 (*val (ft
, _
) = TypesUtil
.instantiatePoly ft
*)
437 unify
state (pos
, dom
, xt
);
438 (ran
, "(" ^ fs ^
") (" ^ xs ^
")")
440 |
Record_e (ist
, cs
) =>
442 val (cs
, str
) = foldl (fn ((id
, e
), (cs
, str
)) =>
444 val idSym
= Symbol
.labSymbol id
445 val _
= List.all (fn (id
', _
) => idSym
<> id
') cs
446 orelse error (SOME pos
, "Duplicate label " ^ id ^
" in record")
447 val (ty
, s
) = xexp state e
449 ((idSym
, ty
) :: cs
, str ^
", " ^ id ^
" = " ^ s
)
455 | _
=> String.extract(str
, 2, NONE
)
456 val str
= "{" ^ str ^
"}"
458 (BasicTypes
.recordTy cs
, str
)
460 |
RecordUpd_e (e
, cs
) =>
462 val (ty
, es
) = xexp state e
465 case TypesUtil
.headReduceType ty
of
466 Types
.CONty (Types
.RECORDtyc labs
, tys
) => ListPair.zip (labs
, tys
)
467 | _
=> error (SOME pos
, "Record update on non-record")
469 val (n
, str
) = foldl (fn ((id
, ty
), (n
, str
)) =>
470 case List.find (fn (id
', _
) => id
= Symbol
.labSymbol id
') cs
of
471 NONE
=> (n
, str ^
", " ^ Symbol
.name id ^
" = #" ^
472 Symbol
.name id ^
" " ^
"UPD'")
475 val (ty
', s
) = xexp state e
477 unify
state (pos
, ty
, ty
');
478 (n
+ 1, str ^
", " ^ Symbol
.name id ^
" = " ^ s
)
481 val _
= n
= length cs
482 orelse error (SOME pos
, "Updated fields in record update not found in starting expression")
487 | _
=> String.extract(str
, 2, NONE
)
488 val str
= "let val UPD' = " ^ es ^
" in {" ^ str ^
"} end"
492 handle Skip
=> (errorTy
, "<error>")
494 fun mergePatVars
pos (vars1
, vars2
) =
495 StringMap
.foldli (fn (v
, ty
, vars
) =>
496 (case StringMap
.find (vars
, v
) of
497 NONE
=> StringMap
.insert (vars
, v
, ty
)
498 | SOME _
=> error (SOME pos
, "Duplicate variable " ^ v ^
" in pattern"))) vars1 vars2
500 fun xpat
state (PAT (p
, pos
)) =
502 Ident_p
[] => raise Fail
"Impossible empty Ident_p"
504 ((lookCon
' (state
, id
), StringMap
.empty
, id
)
505 handle StaticEnv
.Unbound
=>
507 val ty
= newTyvar
false
509 (ty
, StringMap
.insert (StringMap
.empty
, id
, VAR ty
), id
)
511 |
Ident_p (path
as (s
::rest
)) =>
512 (resolveCon (pos
, state
, path
), StringMap
.empty
, foldl (fn (v
, st
) => st ^
"." ^ v
) s rest
)
513 | Wild_p
=> (newTyvar
false, StringMap
.empty
, "_")
514 | Int_p n
=> (BasicTypes
.intTy
, StringMap
.empty
, Int.toString n
)
515 | String_p s
=> (BasicTypes
.stringTy
, StringMap
.empty
, "\"" ^ s ^
"\"")
516 |
App_p ([], _
) => raise Fail
"Impossible App_p"
519 val (ty
, vars
, s
) = xpat state p
520 val tyc
= lookCon (state
, id
, pos
)
523 unify
state (pos
, dom
, ty
);
524 (range tyc
, vars
, id ^
" (" ^ s ^
")")
526 |
App_p (path
as (fst
::rest
), p
) =>
528 val (ty
, vars
, s
) = xpat state p
529 val tyc
= resolveCon (pos
, state
, path
)
532 unify
state (pos
, dom
, ty
);
533 (range tyc
, vars
, foldl (fn (n
, st
) => st ^
"." ^ n
) fst rest ^
" (" ^ s ^
")")
537 val (ty1
, vars
', s1
) = xpat state p1
538 val (ty2
, vars
'', s2
) = xpat state p2
540 val resty
= Types
.CONty (BasicTypes
.listTycon
, [ty1
])
542 unify
state (pos
, ty2
, resty
);
543 (resty
, mergePatVars
pos (vars
', vars
''), "(" ^ s1 ^
")::(" ^ s2 ^
")")
547 val (ty
, vars
, s
) = xpat state p
549 not (Option
.isSome (StringMap
.find(vars
, id
)))
550 orelse error (SOME pos
, "Duplicate variable " ^ id ^
" in pattern");
551 (ty
, StringMap
.insert (vars
, id
, VAR ty
), id ^
" as (" ^ s ^
")")
553 |
Record_p (ist
, cs
) =>
555 val (cs
, vars
, str
) = foldl (fn ((id
, p
), (cs
, vars
, str
)) =>
557 val (ty
, vars
', s
) = xpat state p
559 ((Symbol
.labSymbol id
, ty
)::cs
, mergePatVars
pos (vars
, vars
'),
560 str ^
", " ^ id ^
" = " ^ s
)
561 end) ([], StringMap
.empty
, "") cs
564 if String.size str
>= 2 then
565 String.extract(str
, 2, NONE
)
568 val str
= "{" ^ str ^
"}"
570 (BasicTypes
.recordTy cs
, vars
, str
)
574 val (cs
, vars
, str
) = foldl (fn ((id
, p
), (cs
, vars
, str
)) =>
576 val (ty
, vars
', s
) = xpat state p
578 ((Symbol
.labSymbol id
, ty
)::cs
, mergePatVars
pos (vars
, vars
'),
579 str ^
", " ^ id ^
" = " ^ s
)
580 end) ([], StringMap
.empty
, "") cs
583 if String.size str
>= 2 then
584 String.extract(str
, 2, NONE
)
587 val str
= "{" ^ str ^
", ...}"
589 (newFlex cs
, vars
, str
)
592 error (SOME pos
, "Not done yet!!!")*))
593 handle Skip
=> (errorTy
, StringMap
.empty
, "<error>")
595 fun xblock
state (BLOCK (blocks
, pos
)) =
597 fun folder (BITEM (bi
, pos
), (state
, str
)) =
600 (state
, str ^
"val _ = Web.print (\"" ^ escapeString s ^
"\")\n")
603 fun folder ((id
, e
), (state
, str
)) =
605 val (ty
, es
) = xexp state e
607 val state
= addVar (state
, id
, REF ty
)
609 (state
, str ^
"val " ^ id ^
" = ref (" ^ es ^
")\n")
612 foldl
folder (state
, str
) rs
617 case getVar (state
, id
, SOME pos
) of
618 NONE
=> error (SOME pos
, "Unbound variable " ^ id
)
619 |
SOME (REF vty
) => vty
620 | _
=> error (SOME pos
, "Can't assign to non-ref variable " ^ id
)
622 val (ty
, es
) = xexp state e
624 unify
state (pos
, ty
, vty
);
625 (state
, str ^
"val _ = " ^ id ^
" := (" ^ es ^
")\n")
629 val (pty
, vars
, ps
) = xpat state p
630 val state
' = addVars (state
, vars
)
631 val (ty
, es
) = xexp state e
633 unify
state (pos
, pty
, ty
);
634 (state
', str ^
"val " ^ ps ^
" = (" ^ es ^
")\n")
638 val (ty
, s
) = xexp state e
639 val ty
= TypesUtil
.headReduceType ty
641 case printFn state ty
of
642 NONE
=> (if tyToString state ty
= "_" then
645 error (SOME pos
, "Unable to convert value of type " ^
646 tyToString state ty ^
" to string");
650 (state
, str ^
"val _ = " ^ printFn ^
" (" ^ s ^
")\n")
652 |
Ifthenelse_i (ifs
, els
) =>
654 val str
= str ^
"val _ = "
655 fun folder ((e
, b
), (first
, str
)) =
657 val (ty
, s
) = xexp state e
658 val (_
, str
') = xblock state b
660 unify
state (pos
, ty
, BasicTypes
.boolTy
);
661 (false, str ^
(if first
then "" else "else ") ^
"if (" ^ s ^
") then let\n" ^
665 val (_
, str
) = foldl
folder (true, str
) ifs
672 val (_
, str
') = xblock state els
681 |
Foreach_i (id
, e
, b
) =>
683 val parm
= newTyvar
false
685 val (ty
, es
) = xexp state e
687 val _
= unify
state (pos
, ty
, Types
.CONty (BasicTypes
.listTycon
, [parm
]))
689 (*val _
= print ("... to " ^
tyToString (context
, ivmap
, pty
) ^
"\n")*)
691 val state
= addVar (state
, id
, VAR parm
)
692 val (_
, bs
) = xblock state b
694 (state
, str ^
"fun foreach (" ^ id ^
(*" : " ^
695 Elab
.tyToString (context
, ivmap
, pty
) ^
*) ") = let\n" ^
698 "val _ = app foreach (" ^ es ^
")\n")
700 |
For_i (id
, eFrom
, eTo
, b
) =>
702 val (ty1
, es1
) = xexp state eFrom
703 val _
= unify
state (pos
, ty1
, BasicTypes
.intTy
)
705 val (ty2
, es2
) = xexp state eTo
706 val _
= unify
state (pos
, ty2
, BasicTypes
.intTy
)
708 val state
= addVar (state
, id
, VAR BasicTypes
.intTy
)
709 val (_
, bs
) = xblock state b
711 (state
, str ^
"fun forFunc " ^ id ^
" = let\n" ^
714 "val _ = for forFunc (" ^ es1 ^
", " ^ es2 ^
")\n")
716 |
Case_i (e
, matches
) =>
718 val (ty
, s
) = xexp state e
720 fun folder ((p
, b
), (first
, str
)) =
722 val (pty
, vars
', ps
) = xpat state p
724 val _
= unify
state (pos
, ty
, pty
)
726 val (_
, str
') = xblock (addVars (state
, vars
')) b
728 (*val _
= print ("Pattern type: " ^
tyToString (context
, ivmap
, pty
) ^
" vs. " ^
tyToString (context
, ivmap
, ty
) ^
"\n")*)
731 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => let\n" ^
736 foldl
folder (true, str ^
"val _ = (case (" ^ s ^
") of\n") matches
737 val str
= str ^
") handle Match => ()\n"
741 |
TryCatch_i (b
, matches
) =>
743 val (_
, bs
) = xblock state b
745 fun folder ((p
, b
), (first
, str
)) =
747 val (pty
, vars
, ps
) = xpat state p
748 val state
= addVars (state
, vars
)
749 val (_
, str
') = xblock state b
751 unify
state (pos
, BasicTypes
.exnTy
, pty
);
753 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => let\n" ^
759 str ^
"val _ = (let\n" ^
761 "in () end handle\n") matches
762 val str
= str ^
")\n"
768 fun folder (path
, state
) = openStructure (pos
, state
, path
)
770 val str
= foldl (fn (path
, str
) => str ^
" " ^ Tree
.pathString path
) (str ^
"open") paths
773 (foldl folder state paths
, str
)
775 handle Skip
=> (state
, str
)
777 foldl
folder (state
, "") blocks
780 fun trans (config
, env
, templates
, name
, block
) =
782 val state
= mkState (config
, env
, templates
)
783 val (_
, str
) = xblock state block
785 "(* This file generated automatically by something or other *)\n" ^
787 "structure " ^ name ^
" :> TEMPLATE =\n" ^
789 "fun exec () = let\n" ^