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
,
44 (* States to thread throughout translation
*)
46 datatype state
= STATE
of {env
: StaticEnv
.staticEnv
,
47 vars
: var StringMap
.map
,
48 config
: Config
.config
,
49 templates
: StringSet
.set
}
51 datatype strct
= STRCT
of {elements
: Modules
.elements
,
52 eenv
: EntityEnv
.entityEnv
}
54 fun getElements (Modules
.SIG
{elements
, ...}) = elements
55 | getElements _
= raise Fail
"Unexpected Signature in getElements"
57 val bogusStamp
= Stamps
.special
"<bogus>"
58 val errorStrct
= STRCT
{elements
= [], eenv
= EntityEnv
.empty
}
60 fun mkState (config
, env
, templates
) =
61 STATE
{config
= config
,
63 vars
= StringMap
.empty
,
64 templates
= templates
}
66 fun addVar (STATE
{config
, env
, vars
, templates
}, v
, ty
) =
67 STATE
{config
= config
, env
= env
, vars
= StringMap
.insert (vars
, v
, ty
), templates
= templates
}
68 fun addVars (state
, vars
) = StringMap
.foldli (fn (v
, ty
, state
) => addVar (state
, v
, ty
)) state vars
70 fun getVar (STATE
{vars
, ...}, v
, pos
) = StringMap
.find (vars
, v
)
71 fun lookVal (STATE
{env
, ...}, v
, pos
) =
72 (case StaticEnv
.look (env
, Symbol
.varSymbol v
) of
73 Bindings
.VALbind var
=>
75 VarCon
.VALvar
{typ
, ...} => #
1 (TypesUtil
.instantiatePoly (!typ
))
76 | _
=> raise Fail
"Unexpected var in lookVal")
77 | Bindings
.CONbind (Types
.DATACON
{typ
, ...}) => #
1 (TypesUtil
.instantiatePoly typ
)
78 | _
=> raise Fail
"Unexpected binding in lookVal")
79 handle StaticEnv
.Unbound
=> (error (SOME pos
, "Unbound variable " ^ v
);
82 fun lookCon
' (STATE
{env
, ...}, v
) =
83 (case StaticEnv
.look (env
, Symbol
.varSymbol v
) of
84 Bindings
.CONbind (Types
.DATACON
{typ
, ...}) => #
1 (TypesUtil
.instantiatePoly typ
)
85 | _
=> raise Fail
"Unexpected binding in lookVal")
86 fun lookCon (env
, v
, pos
) = (lookCon
' (env
, v
))
87 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound constructor " ^ v
);
89 fun lookStr (STATE
{env
, ...}, v
, pos
) =
90 (case StaticEnv
.look (env
, Symbol
.strSymbol v
) of
91 Bindings
.STRbind modl
=>
93 Modules
.STR
{rlzn
= {entities
, ...}, sign
, ...} => STRCT
{elements
= getElements sign
,
95 | _
=> raise Fail
"Unexpected module in lookStr")
96 | _
=> raise Fail
"Unexpected binding in lookStr")
97 handle StaticEnv
.Unbound
=> (error (SOME pos
, "Unbound structure " ^ v
);
100 fun getStr (STRCT
{elements
, eenv
, ...}, v
, pos
) =
101 (case ModuleUtil
.getStr (elements
, eenv
, Symbol
.strSymbol v
, Access
.nullAcc
, II
.Null
) of
102 (Modules
.STR
{rlzn
= {entities
, ...}, sign
= Modules
.SIG
{elements
, ...}, ...}, _
) =>
103 STRCT
{elements
= elements
, eenv
= entities
}
104 | _
=> raise Fail
"Unexpected spec in getStr")
105 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound structure " ^ v
);
107 fun getVal (STRCT
{elements
, ...}, v
, pos
) =
108 (case ModuleUtil
.getSpec (elements
, Symbol
.varSymbol v
) of
109 Modules
.VALspec
{spec
, ...} => #
1 (TypesUtil
.instantiatePoly spec
)
110 | Modules
.CONspec
{spec
= Types
.DATACON
{typ
, ...}, ...} => #
1 (TypesUtil
.instantiatePoly typ
)
111 | _
=> raise Fail ("Unexpected spec in getVal for " ^ v
))
112 handle ModuleUtil
.Unbound _
=> (case ModuleUtil
.getSpec (elements
, Symbol
.tycSymbol v
) of
113 Modules
.CONspec
{spec
= Types
.DATACON
{typ
, ...}, ...} => #
1 (TypesUtil
.instantiatePoly typ
)
114 | _
=> raise Fail
"Unexpected spec in getVal")
115 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound variable " ^ v
);
117 fun getCon (STRCT
{elements
, ...}, v
, pos
) =
118 (case ModuleUtil
.getSpec (elements
, Symbol
.varSymbol v
) of
119 Modules
.CONspec
{spec
= Types
.DATACON
{typ
, ...}, ...} => #
1 (TypesUtil
.instantiatePoly typ
)
120 | _
=> raise Fail
"Unexpected spec in getVal")
121 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound constructor " ^ v
);
124 fun unify (STATE
{env
, ...}) (pos
, e
, t1
, t2
) =
126 val t1
= ModuleUtil
.transType eenv t1
127 val t2
= ModuleUtil
.transType eenv t2
129 Unify
.unifyTy (t1
, t2
)
131 handle Unify
.Unify msg
=>
132 (PrettyPrint
.begin_block ppstream PrettyPrint
.CONSISTENT
0;
133 PrettyPrint
.add_string ppstream
"Error unifying";
134 PrettyPrint
.add_break
ppstream (1, 0);
135 PrettyPrint
.begin_block ppstream PrettyPrint
.CONSISTENT
5;
136 PPType
.ppType env ppstream t1
;
137 PrettyPrint
.end_block ppstream
;
138 PrettyPrint
.add_break
ppstream (1, 0);
139 PrettyPrint
.add_string ppstream
"and";
140 PrettyPrint
.add_break
ppstream (1, 0);
141 PrettyPrint
.begin_block ppstream PrettyPrint
.CONSISTENT
5;
142 PPType
.ppType env ppstream t2
;
143 PrettyPrint
.end_block ppstream
;
144 PrettyPrint
.end_block ppstream
;
145 PrettyPrint
.add_break
ppstream (1, 0);
146 PrettyPrint
.flush_ppstream ppstream
;
147 error (SOME pos
, Unify
.failMessage msg ^
" for " ^
(case e
of ExpUn e
=> Tree
.expString e
148 | PatUn p
=> "<pat>")))
150 fun resolvePath (getter
, transer
) (pos
, state
, path
) =
152 fun traverse ([], _
, _
) = raise Fail
"Impossible empty variable path in pat traverse"
153 |
traverse ([v
], str
as STRCT
{eenv
, ...}, path
) =
155 val ty
= getter (str
, v
, pos
)
156 val ty
= transer eenv ty
157 fun folder (STRCT
{eenv
, ...}, ty
) = transer eenv ty
161 |
traverse (s
::rest
, str
, path
) = traverse (rest
, getStr (str
, s
, pos
), str
::path
)
164 [] => raise Fail
"Empty path to resolvePath"
165 |
[_
] => raise Fail
"Singleton path to resolvePath"
166 |
(first
::rest
) => traverse (rest
, lookStr (state
, first
, pos
), [])
169 fun resolveStructure (pos
, state
, path
) =
171 fun look (STATE
{env
, ...}, v
, pos
) =
172 (case StaticEnv
.look (env
, Symbol
.strSymbol v
) of
173 Bindings
.STRbind modl
=>
175 Modules
.STR
{rlzn
= {entities
, ...}, sign
, ...} => (getElements sign
, entities
, modl
)
176 | _
=> raise Fail
"Unexpected module in lookStr")
177 | _
=> raise Fail
"Unexpected binding in lookStr")
178 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound structure " ^ v
);
179 ([], EntityEnv
.empty
, Modules
.ERRORstr
))
181 fun get (elements
, eenv
, v
) =
183 val sym
= Symbol
.strSymbol v
185 (case ModuleUtil
.getStr (elements
, eenv
, sym
, Access
.nullAcc
, II
.Null
) of
186 (str
as Modules
.STR
{rlzn
= {entities
, ...}, sign
= Modules
.SIG
{elements
, ...}, ...}, _
) =>
187 (elements
, entities
, str
)
188 | _
=> raise Fail
"Unexpected spec in resolveStructure")
189 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound structure " ^ v
);
190 ([], EntityEnv
.empty
, Modules
.ERRORstr
))
193 fun traverse ([], (_
, _
, str
)) = str
194 |
traverse ([v
], (elements
, eenv
, _
)) = #
3 (get (elements
, eenv
, v
))
195 |
traverse (s
::rest
, (elements
, eenv
, _
)) = traverse (rest
, get (elements
, eenv
, s
))
198 [] => raise Fail
"Empty path to resolveStructure"
199 |
(first
::rest
) => traverse (rest
, look (state
, first
, pos
))
202 fun openStructure (pos
, state
as STATE
{config
, env
, vars
, templates
}, path
) =
204 val str
= resolveStructure (pos
, state
, path
)
205 val env
= ModuleUtil
.openStructure (env
, str
)
207 STATE
{config
= config
, env
= env
, vars
= vars
, templates
= templates
}
210 fun tyToString (STATE
{env
, ...}) ty
=
211 PrettyPrint
.pp_to_string
65535 (PPType
.ppType env
) ty
213 fun printFn (state
as STATE
{config
, env
, ...}) ty
=
215 val tyname
= tyToString state ty
217 Config
.printFn config tyname
220 fun isTemplate (STATE
{templates
, ...}) s
= StringSet
.member (templates
, s
)
223 fun twiddleType f ty
=
224 (case TypesUtil
.headReduceType ty
of
225 Types
.WILDCARDty
=> ty
228 val domain
= twiddleType BasicTypes
.domain
229 val range
= twiddleType BasicTypes
.range
231 (*val _
= (Unify
.debugging
:= true;
232 EntityEnv
.debugging
:= true;
233 ModuleUtil
.debugging
:= true)*)
235 fun newTyvar eq
= Types
.VARty (Types
.mkTyvar (Types
.OPEN
{depth
= 0, eq
= eq
, kind
= Types
.META
}))
236 fun newFlex elms
= Types
.VARty (Types
.mkTyvar (Types
.OPEN
{depth
= 0, eq
= false, kind
= Types
.FLEX elms
}))
238 val resolveVal
= resolvePath (getVal
, ModuleUtil
.transType
)
239 val resolveCon
= resolvePath (getCon
, ModuleUtil
.transType
)
243 val chars
= String.explode s
244 val escd
= map (fn #
"\"" => "\\\""
253 val mkTuple
= BasicTypes
.tupleTy
255 val templateTy
= BasicTypes
.--> (Types
.CONty (BasicTypes
.listTycon
,
256 [mkTuple
[BasicTypes
.stringTy
,
257 Types
.CONty (BasicTypes
.listTycon
,
258 [BasicTypes
.stringTy
])]]), BasicTypes
.unitTy
)
260 fun xexp
state (exp
as EXP (e
, pos
)) =
263 (BasicTypes
.intTy
, Int.toString n
)
265 (BasicTypes
.realTy
, Real.toString n
)
267 (BasicTypes
.stringTy
, "\"" ^ s ^
"\"")
269 (BasicTypes
.charTy
, "#\"" ^ s ^
"\"")
272 val (ty1
, es1
) = xexp state e1
273 val (ty2
, es2
) = xexp state e2
275 val parm
= newTyvar
false
276 val ran
= Types
.CONty (BasicTypes
.listTycon
, [parm
])
277 val dom
= mkTuple
[parm
, ran
]
279 val xt
= mkTuple
[ty1
, ty2
]
281 unify
state (pos
, ExpUn exp
, dom
, xt
);
282 (ran
, "(" ^ es1 ^
") :: (" ^ es2 ^
")")
284 |
Compose_e (e1
, e2
) =>
286 val (ty1
, es1
) = xexp state e1
287 val (ty2
, es2
) = xexp state e2
289 val dom1
= newTyvar
false
290 val ran1dom2
= newTyvar
false
291 val ran2
= newTyvar
false
293 unify
state (pos
, ExpUn exp
, ty2
, BasicTypes
.--> (dom1
, ran1dom2
));
294 unify
state (pos
, ExpUn exp
, ty1
, BasicTypes
.--> (ran1dom2
, ran2
));
295 (BasicTypes
.--> (dom1
, ran2
), "(" ^ es1 ^
") o (" ^ es2 ^
")")
297 |
StrCat_e (e1
, e2
) =>
299 val (ty1
, es1
) = xexp state e1
300 val (ty2
, es2
) = xexp state e2
302 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.stringTy
);
303 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.stringTy
);
304 (BasicTypes
.stringTy
, "(" ^ es1 ^
") ^ (" ^ es2 ^
")")
306 |
Orelse_e (e1
, e2
) =>
308 val (ty1
, es1
) = xexp state e1
309 val (ty2
, es2
) = xexp state e2
311 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.boolTy
);
312 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.boolTy
);
313 (BasicTypes
.boolTy
, "(" ^ es1 ^
") orelse (" ^ es2 ^
")")
315 |
Andalso_e (e1
, e2
) =>
317 val (ty1
, es1
) = xexp state e1
318 val (ty2
, es2
) = xexp state e2
320 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.boolTy
);
321 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.boolTy
);
322 (BasicTypes
.boolTy
, "(" ^ es1 ^
") andalso (" ^ es2 ^
")")
326 val (ty1
, es1
) = xexp state e1
327 val (ty2
, es2
) = xexp state e2
329 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
330 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
331 (BasicTypes
.intTy
, "(" ^ es1 ^
") + (" ^ es2 ^
")")
333 |
Minus_e (e1
, e2
) =>
335 val (ty1
, es1
) = xexp state e1
336 val (ty2
, es2
) = xexp state e2
338 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
339 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
340 (BasicTypes
.intTy
, "(" ^ es1 ^
") - (" ^ es2 ^
")")
342 |
Times_e (e1
, e2
) =>
344 val (ty1
, es1
) = xexp state e1
345 val (ty2
, es2
) = xexp state e2
347 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
348 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
349 (BasicTypes
.intTy
, "(" ^ es1 ^
") * (" ^ es2 ^
")")
351 |
Divide_e (e1
, e2
) =>
353 val (ty1
, es1
) = xexp state e1
354 val (ty2
, es2
) = xexp state e2
356 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
357 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
358 (BasicTypes
.intTy
, "(" ^ es1 ^
") div (" ^ es2 ^
")")
362 val (ty1
, es1
) = xexp state e1
363 val (ty2
, es2
) = xexp state e2
365 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
366 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
367 (BasicTypes
.intTy
, "(" ^ es1 ^
") mod (" ^ es2 ^
")")
371 val (ty1
, es1
) = xexp state e1
372 val (ty2
, es2
) = xexp state e2
374 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
375 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
376 (BasicTypes
.boolTy
, "(" ^ es1 ^
") < (" ^ es2 ^
")")
380 val (ty1
, es1
) = xexp state e1
381 val (ty2
, es2
) = xexp state e2
383 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
384 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
385 (BasicTypes
.boolTy
, "(" ^ es1 ^
") <= (" ^ es2 ^
")")
389 val (ty1
, es1
) = xexp state e1
390 val (ty2
, es2
) = xexp state e2
392 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
393 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
394 (BasicTypes
.boolTy
, "(" ^ es1 ^
") > (" ^ es2 ^
")")
398 val (ty1
, es1
) = xexp state e1
399 val (ty2
, es2
) = xexp state e2
401 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
402 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
403 (BasicTypes
.boolTy
, "(" ^ es1 ^
") >= (" ^ es2 ^
")")
405 | Param_e
=> (BasicTypes
.--> (BasicTypes
.stringTy
, BasicTypes
.stringTy
), "Web.getParam")
406 | Neg_e
=> (BasicTypes
.--> (BasicTypes
.intTy
, BasicTypes
.intTy
), "~")
408 if isTemplate state name
then
410 fun toUpper ch
= chr (ord ch
+ ord #
"A" - ord #
"a")
411 val name
= str (toUpper (String.sub (name
, 0))) ^
String.extract (name
, 1, NONE
)
413 (templateTy
, "(Web.withParams " ^ name ^
"_.exec)")
416 (error (SOME pos
, "Unknown template " ^ name
);
417 (errorTy
, "<errorTemplate>"))
420 val carried
= newTyvar
false
422 (BasicTypes
.--> (newFlex
[(Symbol
.labSymbol field
, carried
)], carried
), "#" ^ field
)
426 val (ty1
, s1
) = xexp state e1
427 val (ty2
, s2
) = xexp state e2
429 unify
state (pos
, ExpUn e1
, ty1
, ty2
);
430 unify
state (pos
, ExpUn e2
, ty1
, newTyvar
true);
431 (BasicTypes
.boolTy
, "(" ^ s1 ^
") = (" ^ s2 ^
")")
435 val (ty1
, s1
) = xexp state e1
436 val (ty2
, s2
) = xexp state e2
438 unify
state (pos
, ExpUn e1
, ty1
, ty2
);
439 unify
state (pos
, ExpUn e2
, ty1
, newTyvar
true);
440 (BasicTypes
.boolTy
, "(" ^ s1 ^
") <> (" ^ s2 ^
")")
442 | Ident_e
[] => raise Fail
"Impossible empty variable path"
444 (case getVar (state
, id
, SOME pos
) of
445 NONE
=> (lookVal (state
, id
, pos
), id
)
446 |
SOME (VAR ty
) => (ty
, id
)
447 |
SOME (REF ty
) => (ty
, "!" ^ id
))
448 |
Ident_e (path
as (s
::rest
)) =>
449 (resolveVal (pos
, state
, path
), foldl (fn (v
, st
) => st ^
"." ^ v
) s rest
)
452 val (ft
, fs
) = xexp state f
453 val (xt
, xs
) = xexp state x
455 if BasicTypes
.isArrowType ft
then
456 (unify
state (pos
, ExpUn x
, domain ft
, xt
);
457 (range ft
, "(" ^ fs ^
") (" ^ xs ^
")"))
459 (error (SOME pos
, "Applying non-function");
460 (errorTy
, "<error>"))
462 |
Case_e (e
, matches
) =>
464 val (ty
, s
) = xexp state e
466 fun folder ((p
, e
'), (first
, str
, bodyTy
)) =
468 val (pty
, vars
', ps
) = xpat state p
470 val _
= unify
state (pos
, ExpUn e
, ty
, pty
)
472 val (ty
', str
') = xexp (addVars (state
, vars
')) e
'
474 unify
state (pos
, ExpUn e
', ty
', bodyTy
);
476 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => " ^
480 val bodyTy
= newTyvar
false
482 foldl
folder (true, "(case (" ^ s ^
") of\n", bodyTy
) matches
483 val str
= str ^
")\n"
487 |
Record_e (ist
, cs
) =>
489 val (cs
, str
) = foldl (fn ((id
, e
), (cs
, str
)) =>
491 val idSym
= Symbol
.labSymbol id
492 val _
= List.all (fn (id
', _
) => idSym
<> id
') cs
493 orelse error (SOME pos
, "Duplicate label " ^ id ^
" in record")
494 val (ty
, s
) = xexp state e
496 ((idSym
, ty
) :: cs
, str ^
", " ^ id ^
" = " ^ s
)
502 | _
=> String.extract(str
, 2, NONE
)
503 val str
= "{" ^ str ^
"}"
505 (BasicTypes
.recordTy cs
, str
)
509 val dom
= newTyvar
false
510 val ran
= newTyvar
false
512 fun folder ((p
, e
'), (first
, str
)) =
514 val (pty
, vars
', ps
) = xpat state p
516 val _
= unify
state (pos
, ExpUn exp
, dom
, pty
)
518 val (ty
', str
') = xexp (addVars (state
, vars
')) e
'
520 unify
state (pos
, ExpUn e
', ty
', ran
);
522 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => " ^
526 foldl
folder (true, "(fn \n") matches
527 val str
= str ^
")\n"
529 (BasicTypes
.--> (dom
, ran
), str
)
533 val (ty
, es
) = xexp state e
535 unify
state (pos
, ExpUn e
, ty
, BasicTypes
.exnTy
);
536 (newTyvar
false, "(raise (" ^ es ^
"))")
540 val (state
, str
) = xblock state b
541 val (ty
, es
) = xexp state e
543 (ty
, "let\n" ^ str ^
"\nin\n" ^ es ^
"\nend\n")
547 val (bty
, ce
) = xexp state c
548 val (ty
, te
) = xexp state t
549 val (ty
', ee
) = xexp state e
551 unify
state (pos
, ExpUn c
, bty
, BasicTypes
.boolTy
);
552 unify
state (pos
, ExpUn exp
, ty
, ty
');
553 (ty
, "(if (" ^ ce ^
") then (" ^ te ^
") else (" ^ ee ^
"))")
555 |
RecordUpd_e (e
, cs
) =>
557 val (ty
, es
) = xexp state e
560 case TypesUtil
.headReduceType ty
of
561 Types
.CONty (Types
.RECORDtyc labs
, tys
) => ListPair.zip (labs
, tys
)
562 | _
=> error (SOME pos
, "Record update on non-record")
564 val (n
, str
) = foldl (fn ((id
, ty
), (n
, str
)) =>
565 case List.find (fn (id
', _
) => id
= Symbol
.labSymbol id
') cs
of
566 NONE
=> (n
, str ^
", " ^ Symbol
.name id ^
" = #" ^
567 Symbol
.name id ^
" " ^
"UPD'")
570 val (ty
', s
) = xexp state e
572 unify
state (pos
, ExpUn e
, ty
, ty
');
573 (n
+ 1, str ^
", " ^ Symbol
.name id ^
" = " ^ s
)
576 val _
= n
= length cs
577 orelse error (SOME pos
, "Updated fields in record update not found in starting expression")
582 | _
=> String.extract(str
, 2, NONE
)
583 val str
= "let val UPD' = " ^ es ^
" in {" ^ str ^
"} end"
587 handle Skip
=> (errorTy
, "<error>")
589 and mergePatVars
pos (vars1
, vars2
) =
590 StringMap
.foldli (fn (v
, ty
, vars
) =>
591 (case StringMap
.find (vars
, v
) of
592 NONE
=> StringMap
.insert (vars
, v
, ty
)
593 | SOME _
=> error (SOME pos
, "Duplicate variable " ^ v ^
" in pattern"))) vars1 vars2
595 and xpat
state (pat
as PAT (p
, pos
)) =
597 Ident_p
[] => raise Fail
"Impossible empty Ident_p"
599 ((lookCon
' (state
, id
), StringMap
.empty
, id
)
600 handle StaticEnv
.Unbound
=>
602 val ty
= newTyvar
false
604 (ty
, StringMap
.insert (StringMap
.empty
, id
, VAR ty
), id
)
606 |
Ident_p (path
as (s
::rest
)) =>
607 (resolveCon (pos
, state
, path
), StringMap
.empty
, foldl (fn (v
, st
) => st ^
"." ^ v
) s rest
)
608 | Wild_p
=> (newTyvar
false, StringMap
.empty
, "_")
609 | Int_p n
=> (BasicTypes
.intTy
, StringMap
.empty
, Int.toString n
)
610 | Real_p n
=> (BasicTypes
.realTy
, StringMap
.empty
, Real.toString n
)
611 | String_p s
=> (BasicTypes
.stringTy
, StringMap
.empty
, "\"" ^ s ^
"\"")
612 | Char_p s
=> (BasicTypes
.charTy
, StringMap
.empty
, "#\"" ^ s ^
"\"")
613 |
App_p ([], _
) => raise Fail
"Impossible App_p"
616 val (ty
, vars
, s
) = xpat state p
617 val tyc
= lookCon (state
, id
, pos
)
620 unify
state (pos
, PatUn p
, dom
, ty
);
621 (range tyc
, vars
, id ^
" (" ^ s ^
")")
623 |
App_p (path
as (fst
::rest
), p
) =>
625 val (ty
, vars
, s
) = xpat state p
626 val tyc
= resolveCon (pos
, state
, path
)
629 unify
state (pos
, PatUn p
, dom
, ty
);
630 (range tyc
, vars
, foldl (fn (n
, st
) => st ^
"." ^ n
) fst rest ^
" (" ^ s ^
")")
634 val (ty1
, vars
', s1
) = xpat state p1
635 val (ty2
, vars
'', s2
) = xpat state p2
637 val resty
= Types
.CONty (BasicTypes
.listTycon
, [ty1
])
639 unify
state (pos
, PatUn pat
, ty2
, resty
);
640 (resty
, mergePatVars
pos (vars
', vars
''), "(" ^ s1 ^
")::(" ^ s2 ^
")")
644 val (ty
, vars
, s
) = xpat state p
646 not (Option
.isSome (StringMap
.find(vars
, id
)))
647 orelse error (SOME pos
, "Duplicate variable " ^ id ^
" in pattern");
648 (ty
, StringMap
.insert (vars
, id
, VAR ty
), id ^
" as (" ^ s ^
")")
650 |
Record_p (ist
, cs
) =>
652 val (cs
, vars
, str
) = foldl (fn ((id
, p
), (cs
, vars
, str
)) =>
654 val (ty
, vars
', s
) = xpat state p
656 ((Symbol
.labSymbol id
, ty
)::cs
, mergePatVars
pos (vars
, vars
'),
657 str ^
", " ^ id ^
" = " ^ s
)
658 end) ([], StringMap
.empty
, "") cs
661 if String.size str
>= 2 then
662 String.extract(str
, 2, NONE
)
665 val str
= "{" ^ str ^
"}"
667 (BasicTypes
.recordTy cs
, vars
, str
)
671 val (cs
, vars
, str
) = foldl (fn ((id
, p
), (cs
, vars
, str
)) =>
673 val (ty
, vars
', s
) = xpat state p
675 ((Symbol
.labSymbol id
, ty
)::cs
, mergePatVars
pos (vars
, vars
'),
676 str ^
", " ^ id ^
" = " ^ s
)
677 end) ([], StringMap
.empty
, "") cs
680 if String.size str
>= 2 then
681 String.extract(str
, 2, NONE
)
684 val str
= "{" ^ str ^
", ...}"
686 (newFlex cs
, vars
, str
)
689 error (SOME pos
, "Not done yet!!!")*))
690 handle Skip
=> (errorTy
, StringMap
.empty
, "<error>")
692 and xblock
state (BLOCK (blocks
, pos
)) =
694 fun folder (BITEM (bi
, pos
), (state
, str
)) =
697 (state
, str ^
"val _ = Web.print (\"" ^ escapeString s ^
"\")\n")
700 fun folder ((id
, e
), (state
, str
)) =
702 val (ty
, es
) = xexp state e
704 val state
= addVar (state
, id
, REF ty
)
706 (state
, str ^
"val " ^ id ^
" = ref (" ^ es ^
")\n")
709 foldl
folder (state
, str
) rs
714 case getVar (state
, id
, SOME pos
) of
715 NONE
=> error (SOME pos
, "Unbound variable " ^ id
)
716 |
SOME (REF vty
) => vty
717 | _
=> error (SOME pos
, "Can't assign to non-ref variable " ^ id
)
719 val (ty
, es
) = xexp state e
721 unify
state (pos
, ExpUn e
, ty
, vty
);
722 (state
, str ^
"val _ = " ^ id ^
" := (" ^ es ^
")\n")
726 val (pty
, vars
, ps
) = xpat state p
727 val state
' = addVars (state
, vars
)
728 val (ty
, es
) = xexp state e
730 unify
state (pos
, ExpUn e
, pty
, ty
);
731 (state
', str ^
"val " ^ ps ^
" = (" ^ es ^
")\n")
735 val (ty
, s
) = xexp state e
736 val ty
= TypesUtil
.headReduceType ty
738 case printFn state ty
of
739 NONE
=> (if tyToString state ty
= "_" then
742 error (SOME pos
, "Unable to convert value of type " ^
743 tyToString state ty ^
" to string");
747 (state
, str ^
"val _ = " ^ printFn ^
" (" ^ s ^
")\n")
749 |
Ifthenelse_i (e
, b
, els
) =>
751 val str
= str ^
"val _ = "
752 val (ty
, s
) = xexp state e
753 val (_
, str
') = xblock state b
754 val _
= unify
state (pos
, ExpUn e
, ty
, BasicTypes
.boolTy
)
755 val str
= str ^
"if (" ^ s ^
") then let\n" ^
764 val (_
, str
') = xblock state els
773 |
Foreach_i (p
, e
, b
) =>
775 val parm
= newTyvar
false
777 val (pty
, vars
, ps
) = xpat state p
778 val (ty
, es
) = xexp state e
780 val _
= unify
state (pos
, ExpUn e
, ty
, Types
.CONty (BasicTypes
.listTycon
, [parm
]))
781 val _
= unify
state (pos
, PatUn p
, pty
, parm
)
783 val state
' = addVars (state
, vars
)
784 val (_
, bs
) = xblock state
' b
786 (state
, str ^
"fun foreach ((" ^ ps ^
") : " ^
787 tyToString state parm ^
") = let\n" ^
790 "val _ = app foreach (" ^ es ^
")\n")
792 |
For_i (id
, eFrom
, eTo
, b
) =>
794 val (ty1
, es1
) = xexp state eFrom
795 val _
= unify
state (pos
, ExpUn eFrom
, ty1
, BasicTypes
.intTy
)
797 val (ty2
, es2
) = xexp state eTo
798 val _
= unify
state (pos
, ExpUn eTo
, ty2
, BasicTypes
.intTy
)
800 val state
= addVar (state
, id
, VAR BasicTypes
.intTy
)
801 val (_
, bs
) = xblock state b
803 (state
, str ^
"fun forFunc " ^ id ^
" = let\n" ^
806 "val _ = Web.for forFunc (" ^ es1 ^
", " ^ es2 ^
")\n")
808 |
Case_i (e
, matches
) =>
810 val (ty
, s
) = xexp state e
812 fun folder ((p
, b
), (first
, str
)) =
814 val (pty
, vars
', ps
) = xpat state p
816 val _
= unify
state (pos
, PatUn p
, ty
, pty
)
818 val (_
, str
') = xblock (addVars (state
, vars
')) b
820 (*val _
= print ("Pattern type: " ^
tyToString (context
, ivmap
, pty
) ^
" vs. " ^
tyToString (context
, ivmap
, ty
) ^
"\n")*)
823 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => let\n" ^
828 foldl
folder (true, str ^
"val _ = (case (" ^ s ^
") of\n") matches
829 val str
= str ^
") handle Match => ()\n"
833 |
TryCatch_i (b
, matches
) =>
835 val (_
, bs
) = xblock state b
837 fun folder ((p
, b
), (first
, str
)) =
839 val (pty
, vars
, ps
) = xpat state p
840 val state
= addVars (state
, vars
)
841 val (_
, str
') = xblock state b
843 unify
state (pos
, PatUn p
, BasicTypes
.exnTy
, pty
);
845 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => let\n" ^
851 str ^
"val _ = (let\n" ^
853 "in () end handle\n") matches
854 val str
= str ^
")\n"
860 fun folder (path
, state
) = openStructure (pos
, state
, path
)
862 val str
= foldl (fn (path
, str
) => str ^
" " ^ Tree
.pathString path
) (str ^
"open") paths
865 (foldl folder state paths
, str
)
867 handle Skip
=> (state
, str
)
869 foldl
folder (state
, "") blocks
872 fun trans (config
, env
, templates
, name
, block
) =
874 val state
= mkState (config
, env
, templates
)
875 val (_
, str
) = xblock state block
877 "(* This file generated automatically by something or other *)\n" ^
879 "structure " ^ name ^
" :> TEMPLATE =\n" ^
881 "fun exec () = let\n" ^