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")
88 fun lookCon (env
, v
, pos
) = (lookCon
' (env
, v
))
89 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound constructor " ^ v
);
91 fun lookStr (STATE
{env
, ...}, v
, pos
) =
92 (case StaticEnv
.look (env
, Symbol
.strSymbol v
) of
93 Bindings
.STRbind modl
=>
95 Modules
.STR
{rlzn
= {entities
, ...}, sign
, ...} => STRCT
{elements
= getElements sign
,
97 | _
=> raise Fail
"Unexpected module in lookStr")
98 | _
=> raise Fail
"Unexpected binding in lookStr")
99 handle StaticEnv
.Unbound
=> (error (SOME pos
, "Unbound structure " ^ v
);
102 fun getStr (STRCT
{elements
, eenv
, ...}, v
, pos
) =
103 (case ModuleUtil
.getStr (elements
, eenv
, Symbol
.strSymbol v
, Access
.nullAcc
, []) of
104 (Modules
.STR
{rlzn
= {entities
, ...}, sign
= Modules
.SIG
{elements
, ...}, ...}, _
) =>
105 STRCT
{elements
= elements
, eenv
= entities
}
106 | _
=> raise Fail
"Unexpected spec in getStr")
107 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound structure " ^ v
);
109 fun getVal (STRCT
{elements
, ...}, v
, pos
) =
110 (case ModuleUtil
.getSpec (elements
, Symbol
.varSymbol v
) of
111 Modules
.VALspec
{spec
, ...} => #
1 (TypesUtil
.instantiatePoly spec
)
112 | Modules
.CONspec
{spec
= Types
.DATACON
{typ
, ...}, ...} => #
1 (TypesUtil
.instantiatePoly typ
)
113 | _
=> raise Fail ("Unexpected spec in getVal for " ^ v
))
114 handle ModuleUtil
.Unbound _
=> (case ModuleUtil
.getSpec (elements
, Symbol
.tycSymbol v
) of
115 Modules
.CONspec
{spec
= Types
.DATACON
{typ
, ...}, ...} => #
1 (TypesUtil
.instantiatePoly typ
)
116 | _
=> raise Fail
"Unexpected spec in getVal")
117 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound variable " ^ v
);
119 fun getCon (STRCT
{elements
, ...}, v
, pos
) =
120 (case ModuleUtil
.getSpec (elements
, Symbol
.varSymbol v
) of
121 Modules
.CONspec
{spec
= Types
.DATACON
{typ
, ...}, ...} => #
1 (TypesUtil
.instantiatePoly typ
)
122 | _
=> raise Fail
"Unexpected spec in getVal")
123 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound constructor " ^ v
);
126 fun unify (STATE
{env
, ...}) (pos
, e
, t1
, t2
) =
128 val t1
= ModuleUtil
.transType eenv t1
129 val t2
= ModuleUtil
.transType eenv t2
131 Unify
.unifyTy (t1
, t2
)
133 handle Unify
.Unify msg
=>
134 ((*PrettyPrint
.openBox
ppstream (PrettyPrint
.Abs
0);
135 PrettyPrint
.string ppstream
"Error unifying";
136 PrettyPrint
.newline ppstream
;
137 PrettyPrint
.openBox
ppstream (PrettyPrint
.Abs
5);
138 PPType
.ppType env ppstream t1
;
139 PrettyPrint
.closeBox ppstream
;
140 PrettyPrint
.newline ppstream
;
141 PrettyPrint
.string ppstream
"and";
142 PrettyPrint
.newline ppstream
;
143 PrettyPrint
.openBox
ppstream (PrettyPrint
.Abs
5);
144 PPType
.ppType env ppstream t2
;
145 PrettyPrint
.closeBox ppstream
;
146 PrettyPrint
.closeBox ppstream
;
147 PrettyPrint
.newline ppstream
;
148 PrettyPrint
.flushStream ppstream
;*)
149 error (SOME pos
, Unify
.failMessage msg ^
" for " ^
(case e
of ExpUn e
=> Tree
.expString e
150 | PatUn p
=> "<pat>")))
152 fun resolvePath (getter
, transer
) (pos
, state
, path
) =
154 fun traverse ([], _
, _
) = raise Fail
"Impossible empty variable path in pat traverse"
155 |
traverse ([v
], str
as STRCT
{eenv
, ...}, path
) =
157 val ty
= getter (str
, v
, pos
)
158 val ty
= transer eenv ty
159 fun folder (STRCT
{eenv
, ...}, ty
) = transer eenv ty
163 |
traverse (s
::rest
, str
, path
) = traverse (rest
, getStr (str
, s
, pos
), str
::path
)
166 [] => raise Fail
"Empty path to resolvePath"
167 |
[_
] => raise Fail
"Singleton path to resolvePath"
168 |
(first
::rest
) => traverse (rest
, lookStr (state
, first
, pos
), [])
171 fun resolveStructure (pos
, state
, path
) =
173 fun look (STATE
{env
, ...}, v
, pos
) =
174 (case StaticEnv
.look (env
, Symbol
.strSymbol v
) of
175 Bindings
.STRbind modl
=>
177 Modules
.STR
{rlzn
= {entities
, ...}, sign
, ...} => (getElements sign
, entities
, modl
)
178 | _
=> raise Fail
"Unexpected module in lookStr")
179 | _
=> raise Fail
"Unexpected binding in lookStr")
180 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound structure " ^ v
);
181 ([], EntityEnv
.empty
, Modules
.ERRORstr
))
183 fun get (elements
, eenv
, v
) =
185 val sym
= Symbol
.strSymbol v
187 (case ModuleUtil
.getStr (elements
, eenv
, sym
, Access
.nullAcc
, []) of
188 (str
as Modules
.STR
{rlzn
= {entities
, ...}, sign
= Modules
.SIG
{elements
, ...}, ...}, _
) =>
189 (elements
, entities
, str
)
190 | _
=> raise Fail
"Unexpected spec in resolveStructure")
191 handle ModuleUtil
.Unbound _
=> (error (SOME pos
, "Unbound structure " ^ v
);
192 ([], EntityEnv
.empty
, Modules
.ERRORstr
))
195 fun traverse ([], (_
, _
, str
)) = str
196 |
traverse ([v
], (elements
, eenv
, _
)) = #
3 (get (elements
, eenv
, v
))
197 |
traverse (s
::rest
, (elements
, eenv
, _
)) = traverse (rest
, get (elements
, eenv
, s
))
200 [] => raise Fail
"Empty path to resolveStructure"
201 |
(first
::rest
) => traverse (rest
, look (state
, first
, pos
))
204 fun openStructure (pos
, state
as STATE
{config
, env
, vars
, templates
}, path
) =
206 val str
= resolveStructure (pos
, state
, path
)
207 val env
= ModuleUtil
.openStructure (env
, str
)
209 STATE
{config
= config
, env
= env
, vars
= vars
, templates
= templates
}
212 fun tyToString (STATE
{env
, ...}) ty
=
213 PrettyPrintNew
.pp_to_string
65535 (PPType
.ppType env
) ty
215 fun printFn (state
as STATE
{config
, env
, ...}) ty
=
217 val tyname
= tyToString state ty
219 Config
.printFn config tyname
222 fun isTemplate (STATE
{templates
, ...}) s
= StringSet
.member (templates
, s
)
225 fun twiddleType f ty
=
226 (case TypesUtil
.headReduceType ty
of
227 Types
.WILDCARDty
=> ty
230 val domain
= twiddleType BasicTypes
.domain
231 val range
= twiddleType BasicTypes
.range
233 (*val _
= (Unify
.debugging
:= true;
234 EntityEnv
.debugging
:= true;
235 ModuleUtil
.debugging
:= true)*)
237 fun newTyvar eq
= Types
.VARty (Types
.mkTyvar (Types
.OPEN
{depth
= 0, eq
= eq
, kind
= Types
.META
}))
238 fun newFlex elms
= Types
.VARty (Types
.mkTyvar (Types
.OPEN
{depth
= 0, eq
= false, kind
= Types
.FLEX elms
}))
240 val resolveVal
= resolvePath (getVal
, ModuleUtil
.transType
)
241 val resolveCon
= resolvePath (getCon
, ModuleUtil
.transType
)
245 val chars
= String.explode s
246 val escd
= map (fn #
"\"" => "\\\""
255 val mkTuple
= BasicTypes
.tupleTy
257 val templateTy
= BasicTypes
.--> (Types
.CONty (BasicTypes
.listTycon
,
258 [mkTuple
[BasicTypes
.stringTy
,
259 Types
.CONty (BasicTypes
.listTycon
,
260 [BasicTypes
.stringTy
])]]), BasicTypes
.unitTy
)
262 fun xexp
state (exp
as EXP (e
, pos
)) =
265 (BasicTypes
.intTy
, Int.toString n
)
267 (BasicTypes
.realTy
, Real.toString n
)
269 (BasicTypes
.stringTy
, "\"" ^ s ^
"\"")
271 (BasicTypes
.charTy
, "#\"" ^ s ^
"\"")
274 val (ty1
, es1
) = xexp state e1
275 val (ty2
, es2
) = xexp state e2
277 val parm
= newTyvar
false
278 val ran
= Types
.CONty (BasicTypes
.listTycon
, [parm
])
279 val dom
= mkTuple
[parm
, ran
]
281 val xt
= mkTuple
[ty1
, ty2
]
283 unify
state (pos
, ExpUn exp
, dom
, xt
);
284 (ran
, "(" ^ es1 ^
") :: (" ^ es2 ^
")")
286 |
Compose_e (e1
, e2
) =>
288 val (ty1
, es1
) = xexp state e1
289 val (ty2
, es2
) = xexp state e2
291 val dom1
= newTyvar
false
292 val ran1dom2
= newTyvar
false
293 val ran2
= newTyvar
false
295 unify
state (pos
, ExpUn exp
, ty2
, BasicTypes
.--> (dom1
, ran1dom2
));
296 unify
state (pos
, ExpUn exp
, ty1
, BasicTypes
.--> (ran1dom2
, ran2
));
297 (BasicTypes
.--> (dom1
, ran2
), "(" ^ es1 ^
") o (" ^ es2 ^
")")
299 |
StrCat_e (e1
, e2
) =>
301 val (ty1
, es1
) = xexp state e1
302 val (ty2
, es2
) = xexp state e2
304 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.stringTy
);
305 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.stringTy
);
306 (BasicTypes
.stringTy
, "(" ^ es1 ^
") ^ (" ^ es2 ^
")")
308 |
Orelse_e (e1
, e2
) =>
310 val (ty1
, es1
) = xexp state e1
311 val (ty2
, es2
) = xexp state e2
313 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.boolTy
);
314 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.boolTy
);
315 (BasicTypes
.boolTy
, "(" ^ es1 ^
") orelse (" ^ es2 ^
")")
317 |
Andalso_e (e1
, e2
) =>
319 val (ty1
, es1
) = xexp state e1
320 val (ty2
, es2
) = xexp state e2
322 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.boolTy
);
323 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.boolTy
);
324 (BasicTypes
.boolTy
, "(" ^ es1 ^
") andalso (" ^ es2 ^
")")
328 val (ty1
, es1
) = xexp state e1
329 val (ty2
, es2
) = xexp state e2
331 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
332 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
333 (BasicTypes
.intTy
, "(" ^ es1 ^
") + (" ^ es2 ^
")")
335 |
Minus_e (e1
, e2
) =>
337 val (ty1
, es1
) = xexp state e1
338 val (ty2
, es2
) = xexp state e2
340 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
341 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
342 (BasicTypes
.intTy
, "(" ^ es1 ^
") - (" ^ es2 ^
")")
344 |
Times_e (e1
, e2
) =>
346 val (ty1
, es1
) = xexp state e1
347 val (ty2
, es2
) = xexp state e2
349 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
350 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
351 (BasicTypes
.intTy
, "(" ^ es1 ^
") * (" ^ es2 ^
")")
353 |
Divide_e (e1
, e2
) =>
355 val (ty1
, es1
) = xexp state e1
356 val (ty2
, es2
) = xexp state e2
358 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
359 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
360 (BasicTypes
.intTy
, "(" ^ es1 ^
") div (" ^ es2 ^
")")
364 val (ty1
, es1
) = xexp state e1
365 val (ty2
, es2
) = xexp state e2
367 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
368 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
369 (BasicTypes
.intTy
, "(" ^ es1 ^
") mod (" ^ es2 ^
")")
373 val (ty1
, es1
) = xexp state e1
374 val (ty2
, es2
) = xexp state e2
376 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
377 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
378 (BasicTypes
.boolTy
, "(" ^ es1 ^
") < (" ^ es2 ^
")")
382 val (ty1
, es1
) = xexp state e1
383 val (ty2
, es2
) = xexp state e2
385 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
386 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
387 (BasicTypes
.boolTy
, "(" ^ es1 ^
") <= (" ^ es2 ^
")")
391 val (ty1
, es1
) = xexp state e1
392 val (ty2
, es2
) = xexp state e2
394 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
395 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
396 (BasicTypes
.boolTy
, "(" ^ es1 ^
") > (" ^ es2 ^
")")
400 val (ty1
, es1
) = xexp state e1
401 val (ty2
, es2
) = xexp state e2
403 unify
state (pos
, ExpUn e1
, ty1
, BasicTypes
.intTy
);
404 unify
state (pos
, ExpUn e2
, ty2
, BasicTypes
.intTy
);
405 (BasicTypes
.boolTy
, "(" ^ es1 ^
") >= (" ^ es2 ^
")")
407 | Param_e
=> (BasicTypes
.--> (BasicTypes
.stringTy
, BasicTypes
.stringTy
), "Web.getParam")
408 | Neg_e
=> (BasicTypes
.--> (BasicTypes
.intTy
, BasicTypes
.intTy
), "~")
410 if isTemplate state name
then
412 fun toUpper ch
= chr (ord ch
+ ord #
"A" - ord #
"a")
413 val name
= str (toUpper (String.sub (name
, 0))) ^
String.extract (name
, 1, NONE
)
415 (templateTy
, "(Web.withParams " ^ name ^
"_.exec)")
418 (error (SOME pos
, "Unknown template " ^ name
);
419 (errorTy
, "<errorTemplate>"))
422 val carried
= newTyvar
false
424 (BasicTypes
.--> (newFlex
[(Symbol
.labSymbol field
, carried
)], carried
), "#" ^ field
)
428 val (ty1
, s1
) = xexp state e1
429 val (ty2
, s2
) = xexp state e2
431 unify
state (pos
, ExpUn e1
, ty1
, ty2
);
432 unify
state (pos
, ExpUn e2
, ty1
, newTyvar
true);
433 (BasicTypes
.boolTy
, "(" ^ s1 ^
") = (" ^ s2 ^
")")
437 val (ty1
, s1
) = xexp state e1
438 val (ty2
, s2
) = xexp state e2
440 unify
state (pos
, ExpUn e1
, ty1
, ty2
);
441 unify
state (pos
, ExpUn e2
, ty1
, newTyvar
true);
442 (BasicTypes
.boolTy
, "(" ^ s1 ^
") <> (" ^ s2 ^
")")
444 | Ident_e
[] => raise Fail
"Impossible empty variable path"
446 (case getVar (state
, id
, SOME pos
) of
447 NONE
=> (lookVal (state
, id
, pos
), id
)
448 |
SOME (VAR ty
) => (ty
, id
)
449 |
SOME (REF ty
) => (ty
, "!" ^ id
))
450 |
Ident_e (path
as (s
::rest
)) =>
451 (resolveVal (pos
, state
, path
), foldl (fn (v
, st
) => st ^
"." ^ v
) s rest
)
454 val (ft
, fs
) = xexp state f
455 val (xt
, xs
) = xexp state x
457 if BasicTypes
.isArrowType ft
then
458 (unify
state (pos
, ExpUn x
, domain ft
, xt
);
459 (range ft
, "(" ^ fs ^
") (" ^ xs ^
")"))
461 (error (SOME pos
, "Applying non-function");
462 (errorTy
, "<error>"))
464 |
Case_e (e
, matches
) =>
466 val (ty
, s
) = xexp state e
468 fun folder ((p
, e
'), (first
, str
, bodyTy
)) =
470 val (pty
, vars
', ps
) = xpat state p
472 val _
= unify
state (pos
, ExpUn e
, ty
, pty
)
474 val (ty
', str
') = xexp (addVars (state
, vars
')) e
'
476 unify
state (pos
, ExpUn e
', ty
', bodyTy
);
478 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => " ^
482 val bodyTy
= newTyvar
false
484 foldl
folder (true, "(case (" ^ s ^
") of\n", bodyTy
) matches
485 val str
= str ^
")\n"
489 |
Record_e (ist
, cs
) =>
491 val (cs
, str
) = foldl (fn ((id
, e
), (cs
, str
)) =>
493 val idSym
= Symbol
.labSymbol id
494 val _
= List.all (fn (id
', _
) => idSym
<> id
') cs
495 orelse error (SOME pos
, "Duplicate label " ^ id ^
" in record")
496 val (ty
, s
) = xexp state e
498 ((idSym
, ty
) :: cs
, str ^
", " ^ id ^
" = " ^ s
)
504 | _
=> String.extract(str
, 2, NONE
)
505 val str
= "{" ^ str ^
"}"
507 (BasicTypes
.recordTy cs
, str
)
511 val dom
= newTyvar
false
512 val ran
= newTyvar
false
514 fun folder ((p
, e
'), (first
, str
)) =
516 val (pty
, vars
', ps
) = xpat state p
518 val _
= unify
state (pos
, ExpUn exp
, dom
, pty
)
520 val (ty
', str
') = xexp (addVars (state
, vars
')) e
'
522 unify
state (pos
, ExpUn e
', ty
', ran
);
524 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => " ^
528 foldl
folder (true, "(fn \n") matches
529 val str
= str ^
")\n"
531 (BasicTypes
.--> (dom
, ran
), str
)
535 val (ty
, es
) = xexp state e
537 unify
state (pos
, ExpUn e
, ty
, BasicTypes
.exnTy
);
538 (newTyvar
false, "(raise (" ^ es ^
"))")
542 val (state
, str
) = xblock state b
543 val (ty
, es
) = xexp state e
545 (ty
, "let\n" ^ str ^
"\nin\n" ^ es ^
"\nend\n")
549 val (bty
, ce
) = xexp state c
550 val (ty
, te
) = xexp state t
551 val (ty
', ee
) = xexp state e
553 unify
state (pos
, ExpUn c
, bty
, BasicTypes
.boolTy
);
554 unify
state (pos
, ExpUn exp
, ty
, ty
');
555 (ty
, "(if (" ^ ce ^
") then (" ^ te ^
") else (" ^ ee ^
"))")
557 |
RecordUpd_e (e
, cs
) =>
559 val (ty
, es
) = xexp state e
562 case TypesUtil
.headReduceType ty
of
563 Types
.CONty (Types
.RECORDtyc labs
, tys
) => ListPair.zip (labs
, tys
)
564 | _
=> error (SOME pos
, "Record update on non-record")
566 val (n
, str
) = foldl (fn ((id
, ty
), (n
, str
)) =>
567 case List.find (fn (id
', _
) => id
= Symbol
.labSymbol id
') cs
of
568 NONE
=> (n
, str ^
", " ^ Symbol
.name id ^
" = #" ^
569 Symbol
.name id ^
" " ^
"UPD'")
572 val (ty
', s
) = xexp state e
574 unify
state (pos
, ExpUn e
, ty
, ty
');
575 (n
+ 1, str ^
", " ^ Symbol
.name id ^
" = " ^ s
)
578 val _
= n
= length cs
579 orelse error (SOME pos
, "Updated fields in record update not found in starting expression")
584 | _
=> String.extract(str
, 2, NONE
)
585 val str
= "let val UPD' = " ^ es ^
" in {" ^ str ^
"} end"
589 handle Skip
=> (errorTy
, "<error>")
591 and mergePatVars
pos (vars1
, vars2
) =
592 StringMap
.foldli (fn (v
, ty
, vars
) =>
593 (case StringMap
.find (vars
, v
) of
594 NONE
=> StringMap
.insert (vars
, v
, ty
)
595 | SOME _
=> error (SOME pos
, "Duplicate variable " ^ v ^
" in pattern"))) vars1 vars2
597 and xpat
state (pat
as PAT (p
, pos
)) =
599 Ident_p
[] => raise Fail
"Impossible empty Ident_p"
601 ((lookCon
' (state
, id
), StringMap
.empty
, id
)
602 handle StaticEnv
.Unbound
=>
604 val ty
= newTyvar
false
606 (ty
, StringMap
.insert (StringMap
.empty
, id
, VAR ty
), id
)
608 |
Ident_p (path
as (s
::rest
)) =>
609 (resolveCon (pos
, state
, path
), StringMap
.empty
, foldl (fn (v
, st
) => st ^
"." ^ v
) s rest
)
610 | Wild_p
=> (newTyvar
false, StringMap
.empty
, "_")
611 | Int_p n
=> (BasicTypes
.intTy
, StringMap
.empty
, Int.toString n
)
612 | Real_p n
=> (BasicTypes
.realTy
, StringMap
.empty
, Real.toString n
)
613 | String_p s
=> (BasicTypes
.stringTy
, StringMap
.empty
, "\"" ^ s ^
"\"")
614 | Char_p s
=> (BasicTypes
.charTy
, StringMap
.empty
, "#\"" ^ s ^
"\"")
615 |
App_p ([], _
) => raise Fail
"Impossible App_p"
618 val (ty
, vars
, s
) = xpat state p
619 val tyc
= lookCon (state
, id
, pos
)
622 unify
state (pos
, PatUn p
, dom
, ty
);
623 (range tyc
, vars
, id ^
" (" ^ s ^
")")
625 |
App_p (path
as (fst
::rest
), p
) =>
627 val (ty
, vars
, s
) = xpat state p
628 val tyc
= resolveCon (pos
, state
, path
)
631 unify
state (pos
, PatUn p
, dom
, ty
);
632 (range tyc
, vars
, foldl (fn (n
, st
) => st ^
"." ^ n
) fst rest ^
" (" ^ s ^
")")
636 val (ty1
, vars
', s1
) = xpat state p1
637 val (ty2
, vars
'', s2
) = xpat state p2
639 val resty
= Types
.CONty (BasicTypes
.listTycon
, [ty1
])
641 unify
state (pos
, PatUn pat
, ty2
, resty
);
642 (resty
, mergePatVars
pos (vars
', vars
''), "(" ^ s1 ^
")::(" ^ s2 ^
")")
646 val (ty
, vars
, s
) = xpat state p
648 not (Option
.isSome (StringMap
.find(vars
, id
)))
649 orelse error (SOME pos
, "Duplicate variable " ^ id ^
" in pattern");
650 (ty
, StringMap
.insert (vars
, id
, VAR ty
), id ^
" as (" ^ s ^
")")
652 |
Record_p (ist
, cs
) =>
654 val (cs
, vars
, str
) = foldl (fn ((id
, p
), (cs
, vars
, str
)) =>
656 val (ty
, vars
', s
) = xpat state p
658 ((Symbol
.labSymbol id
, ty
)::cs
, mergePatVars
pos (vars
, vars
'),
659 str ^
", " ^ id ^
" = " ^ s
)
660 end) ([], StringMap
.empty
, "") cs
663 if String.size str
>= 2 then
664 String.extract(str
, 2, NONE
)
667 val str
= "{" ^ str ^
"}"
669 (BasicTypes
.recordTy cs
, vars
, str
)
673 val (cs
, vars
, str
) = foldl (fn ((id
, p
), (cs
, vars
, str
)) =>
675 val (ty
, vars
', s
) = xpat state p
677 ((Symbol
.labSymbol id
, ty
)::cs
, mergePatVars
pos (vars
, vars
'),
678 str ^
", " ^ id ^
" = " ^ s
)
679 end) ([], StringMap
.empty
, "") cs
682 if String.size str
>= 2 then
683 String.extract(str
, 2, NONE
)
686 val str
= "{" ^ str ^
", ...}"
688 (newFlex cs
, vars
, str
)
691 error (SOME pos
, "Not done yet!!!")*))
692 handle Skip
=> (errorTy
, StringMap
.empty
, "<error>")
694 and xblock
state (BLOCK (blocks
, pos
)) =
696 fun folder (BITEM (bi
, pos
), (state
, str
)) =
699 (state
, str ^
"val _ = Web.print (\"" ^ escapeString s ^
"\")\n")
702 fun folder ((id
, e
), (state
, str
)) =
704 val (ty
, es
) = xexp state e
706 val state
= addVar (state
, id
, REF ty
)
708 (state
, str ^
"val " ^ id ^
" = ref (" ^ es ^
")\n")
711 foldl
folder (state
, str
) rs
716 case getVar (state
, id
, SOME pos
) of
717 NONE
=> error (SOME pos
, "Unbound variable " ^ id
)
718 |
SOME (REF vty
) => vty
719 | _
=> error (SOME pos
, "Can't assign to non-ref variable " ^ id
)
721 val (ty
, es
) = xexp state e
723 unify
state (pos
, ExpUn e
, ty
, vty
);
724 (state
, str ^
"val _ = " ^ id ^
" := (" ^ es ^
")\n")
728 val (pty
, vars
, ps
) = xpat state p
729 val state
' = addVars (state
, vars
)
730 val (ty
, es
) = xexp state e
732 unify
state (pos
, ExpUn e
, pty
, ty
);
733 (state
', str ^
"val " ^ ps ^
" = (" ^ es ^
")\n")
737 val (ty
, s
) = xexp state e
738 val ty
= TypesUtil
.headReduceType ty
740 case printFn state ty
of
741 NONE
=> (if tyToString state ty
= "_" then
744 error (SOME pos
, "Unable to convert value of type " ^
745 tyToString state ty ^
" to string");
749 (state
, str ^
"val _ = " ^ printFn ^
" (" ^ s ^
")\n")
751 |
Ifthenelse_i (e
, b
, els
) =>
753 val str
= str ^
"val _ = "
754 val (ty
, s
) = xexp state e
755 val (_
, str
') = xblock state b
756 val _
= unify
state (pos
, ExpUn e
, ty
, BasicTypes
.boolTy
)
757 val str
= str ^
"if (" ^ s ^
") then let\n" ^
766 val (_
, str
') = xblock state els
775 |
Foreach_i (p
, e
, b
) =>
777 val parm
= newTyvar
false
779 val (pty
, vars
, ps
) = xpat state p
780 val (ty
, es
) = xexp state e
782 val _
= unify
state (pos
, ExpUn e
, ty
, Types
.CONty (BasicTypes
.listTycon
, [parm
]))
783 val _
= unify
state (pos
, PatUn p
, pty
, parm
)
785 val state
' = addVars (state
, vars
)
786 val (_
, bs
) = xblock state
' b
788 (state
, str ^
"fun foreach ((" ^ ps ^
") : " ^
789 tyToString state parm ^
") = let\n" ^
792 "val _ = app foreach (" ^ es ^
")\n")
794 |
For_i (id
, eFrom
, eTo
, b
) =>
796 val (ty1
, es1
) = xexp state eFrom
797 val _
= unify
state (pos
, ExpUn eFrom
, ty1
, BasicTypes
.intTy
)
799 val (ty2
, es2
) = xexp state eTo
800 val _
= unify
state (pos
, ExpUn eTo
, ty2
, BasicTypes
.intTy
)
802 val state
= addVar (state
, id
, VAR BasicTypes
.intTy
)
803 val (_
, bs
) = xblock state b
805 (state
, str ^
"fun forFunc " ^ id ^
" = let\n" ^
808 "val _ = Web.for forFunc (" ^ es1 ^
", " ^ es2 ^
")\n")
810 |
Case_i (e
, matches
) =>
812 val (ty
, s
) = xexp state e
814 fun folder ((p
, b
), (first
, str
)) =
816 val (pty
, vars
', ps
) = xpat state p
818 val _
= unify
state (pos
, PatUn p
, ty
, pty
)
820 val (_
, str
') = xblock (addVars (state
, vars
')) b
822 (*val _
= print ("Pattern type: " ^
tyToString (context
, ivmap
, pty
) ^
" vs. " ^
tyToString (context
, ivmap
, ty
) ^
"\n")*)
825 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => let\n" ^
830 foldl
folder (true, str ^
"val _ = (case (" ^ s ^
") of\n") matches
831 val str
= str ^
") handle Match => ()\n"
835 |
TryCatch_i (b
, matches
) =>
837 val (_
, bs
) = xblock state b
839 fun folder ((p
, b
), (first
, str
)) =
841 val (pty
, vars
, ps
) = xpat state p
842 val state
= addVars (state
, vars
)
843 val (_
, str
') = xblock state b
845 unify
state (pos
, PatUn p
, BasicTypes
.exnTy
, pty
);
847 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => let\n" ^
853 str ^
"val _ = (let\n" ^
855 "in () end handle\n") matches
856 val str
= str ^
")\n"
862 fun folder (path
, state
) = openStructure (pos
, state
, path
)
864 val str
= foldl (fn (path
, str
) => str ^
" " ^ Tree
.pathString path
) (str ^
"open") paths
867 (foldl folder state paths
, str
)
869 handle Skip
=> (state
, str
)
871 foldl
folder (state
, "") blocks
874 fun trans (config
, env
, templates
, name
, block
) =
876 val state
= mkState (config
, env
, templates
)
877 val (_
, str
) = xblock state block
879 "(* This file generated automatically by something or other *)\n" ^
881 "structure " ^ name ^
" :> TEMPLATE =\n" ^
883 "fun exec () = let\n" ^