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";
129 PrettyPrint
.add_break
ppstream (1, 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 (1, 0);
134 PrettyPrint
.add_string ppstream
"and";
135 PrettyPrint
.add_break
ppstream (1, 0);
136 PrettyPrint
.begin_block ppstream PrettyPrint
.CONSISTENT
5;
137 PPType
.ppType env ppstream t2
;
138 PrettyPrint
.end_block ppstream
;
139 PrettyPrint
.end_block ppstream
;
140 PrettyPrint
.add_break
ppstream (1, 0);
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
.realTy
, Real.toString n
)
260 (BasicTypes
.stringTy
, "\"" ^ s ^
"\"")
262 (BasicTypes
.charTy
, "#\"" ^ s ^
"\"")
265 val (ty1
, es1
) = xexp state e1
266 val (ty2
, es2
) = xexp state e2
268 val parm
= newTyvar
false
269 val ran
= Types
.CONty (BasicTypes
.listTycon
, [parm
])
270 val dom
= mkTuple
[parm
, ran
]
272 val xt
= mkTuple
[ty1
, ty2
]
274 unify
state (pos
, dom
, xt
);
275 (ran
, "(" ^ es1 ^
") :: (" ^ es2 ^
")")
277 |
StrCat_e (e1
, e2
) =>
279 val (ty1
, es1
) = xexp state e1
280 val (ty2
, es2
) = xexp state e2
282 unify
state (pos
, ty1
, BasicTypes
.stringTy
);
283 unify
state (pos
, ty2
, BasicTypes
.stringTy
);
284 (BasicTypes
.stringTy
, "(" ^ es1 ^
") ^ (" ^ es2 ^
")")
286 |
Orelse_e (e1
, e2
) =>
288 val (ty1
, es1
) = xexp state e1
289 val (ty2
, es2
) = xexp state e2
291 unify
state (pos
, ty1
, BasicTypes
.boolTy
);
292 unify
state (pos
, ty2
, BasicTypes
.boolTy
);
293 (BasicTypes
.boolTy
, "(" ^ es1 ^
") orelse (" ^ es2 ^
")")
295 |
Andalso_e (e1
, e2
) =>
297 val (ty1
, es1
) = xexp state e1
298 val (ty2
, es2
) = xexp state e2
300 unify
state (pos
, ty1
, BasicTypes
.boolTy
);
301 unify
state (pos
, ty2
, BasicTypes
.boolTy
);
302 (BasicTypes
.boolTy
, "(" ^ es1 ^
") andalso (" ^ es2 ^
")")
306 val (ty1
, es1
) = xexp state e1
307 val (ty2
, es2
) = xexp state e2
309 unify
state (pos
, ty1
, BasicTypes
.intTy
);
310 unify
state (pos
, ty2
, BasicTypes
.intTy
);
311 (BasicTypes
.intTy
, "(" ^ es1 ^
") + (" ^ es2 ^
")")
313 |
Minus_e (e1
, e2
) =>
315 val (ty1
, es1
) = xexp state e1
316 val (ty2
, es2
) = xexp state e2
318 unify
state (pos
, ty1
, BasicTypes
.intTy
);
319 unify
state (pos
, ty2
, BasicTypes
.intTy
);
320 (BasicTypes
.intTy
, "(" ^ es1 ^
") - (" ^ es2 ^
")")
322 |
Times_e (e1
, e2
) =>
324 val (ty1
, es1
) = xexp state e1
325 val (ty2
, es2
) = xexp state e2
327 unify
state (pos
, ty1
, BasicTypes
.intTy
);
328 unify
state (pos
, ty2
, BasicTypes
.intTy
);
329 (BasicTypes
.intTy
, "(" ^ es1 ^
") * (" ^ es2 ^
")")
331 |
Divide_e (e1
, e2
) =>
333 val (ty1
, es1
) = xexp state e1
334 val (ty2
, es2
) = xexp state e2
336 unify
state (pos
, ty1
, BasicTypes
.intTy
);
337 unify
state (pos
, ty2
, BasicTypes
.intTy
);
338 (BasicTypes
.intTy
, "(" ^ es1 ^
") div (" ^ es2 ^
")")
342 val (ty1
, es1
) = xexp state e1
343 val (ty2
, es2
) = xexp state e2
345 unify
state (pos
, ty1
, BasicTypes
.intTy
);
346 unify
state (pos
, ty2
, BasicTypes
.intTy
);
347 (BasicTypes
.intTy
, "(" ^ es1 ^
") mod (" ^ es2 ^
")")
351 val (ty1
, es1
) = xexp state e1
352 val (ty2
, es2
) = xexp state e2
354 unify
state (pos
, ty1
, BasicTypes
.intTy
);
355 unify
state (pos
, ty2
, BasicTypes
.intTy
);
356 (BasicTypes
.boolTy
, "(" ^ es1 ^
") < (" ^ es2 ^
")")
360 val (ty1
, es1
) = xexp state e1
361 val (ty2
, es2
) = xexp state e2
363 unify
state (pos
, ty1
, BasicTypes
.intTy
);
364 unify
state (pos
, ty2
, BasicTypes
.intTy
);
365 (BasicTypes
.boolTy
, "(" ^ es1 ^
") <= (" ^ es2 ^
")")
369 val (ty1
, es1
) = xexp state e1
370 val (ty2
, es2
) = xexp state e2
372 unify
state (pos
, ty1
, BasicTypes
.intTy
);
373 unify
state (pos
, ty2
, BasicTypes
.intTy
);
374 (BasicTypes
.boolTy
, "(" ^ es1 ^
") > (" ^ es2 ^
")")
378 val (ty1
, es1
) = xexp state e1
379 val (ty2
, es2
) = xexp state e2
381 unify
state (pos
, ty1
, BasicTypes
.intTy
);
382 unify
state (pos
, ty2
, BasicTypes
.intTy
);
383 (BasicTypes
.boolTy
, "(" ^ es1 ^
") >= (" ^ es2 ^
")")
385 | Param_e
=> (BasicTypes
.--> (BasicTypes
.stringTy
, BasicTypes
.stringTy
), "Web.getParam")
386 | Neg_e
=> (BasicTypes
.--> (BasicTypes
.intTy
, BasicTypes
.intTy
), "~")
388 if isTemplate state name
then
390 fun toUpper ch
= chr (ord ch
+ ord #
"A" - ord #
"a")
391 val name
= str (toUpper (String.sub (name
, 0))) ^
String.extract (name
, 1, NONE
)
393 (templateTy
, "(Web.withParams " ^ name ^
".exec)")
396 (error (SOME pos
, "Unknown template " ^ name
);
397 (errorTy
, "<errorTemplate>"))
400 val carried
= newTyvar
false
402 (BasicTypes
.--> (newFlex
[(Symbol
.labSymbol field
, carried
)], carried
), "#" ^ field
)
406 val (ty1
, s1
) = xexp state e1
407 val (ty2
, s2
) = xexp state e2
409 unify
state (pos
, ty1
, ty2
);
410 unify
state (pos
, ty1
, newTyvar
true);
411 (BasicTypes
.boolTy
, "(" ^ s1 ^
") = (" ^ s2 ^
")")
415 val (ty1
, s1
) = xexp state e1
416 val (ty2
, s2
) = xexp state e2
418 unify
state (pos
, ty1
, ty2
);
419 unify
state (pos
, ty1
, newTyvar
true);
420 (BasicTypes
.boolTy
, "(" ^ s1 ^
") <> (" ^ s2 ^
")")
422 | Ident_e
[] => raise Fail
"Impossible empty variable path"
424 (case getVar (state
, id
, SOME pos
) of
425 NONE
=> (lookVal (state
, id
, pos
), id
)
426 |
SOME (VAR ty
) => (ty
, id
)
427 |
SOME (REF ty
) => (ty
, "!" ^ id
))
428 |
Ident_e (path
as (s
::rest
)) =>
429 (resolveVal (pos
, state
, path
), foldl (fn (v
, st
) => st ^
"." ^ v
) s rest
)
432 val (ft
, fs
) = xexp state f
433 val (xt
, xs
) = xexp state x
435 (*val (ft
, _
) = TypesUtil
.instantiatePoly ft
*)
439 unify
state (pos
, dom
, xt
);
440 (ran
, "(" ^ fs ^
") (" ^ xs ^
")")
442 |
Case_e (e
, matches
) =>
444 val (ty
, s
) = xexp state e
446 fun folder ((p
, e
'), (first
, str
, bodyTy
)) =
448 val (pty
, vars
', ps
) = xpat state p
450 val _
= unify
state (pos
, ty
, pty
)
452 val (ty
', str
') = xexp (addVars (state
, vars
')) e
'
454 unify
state (pos
, ty
', bodyTy
);
456 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => " ^
460 val bodyTy
= newTyvar
false
462 foldl
folder (true, "(case (" ^ s ^
") of\n", bodyTy
) matches
463 val str
= str ^
")\n"
467 |
Record_e (ist
, cs
) =>
469 val (cs
, str
) = foldl (fn ((id
, e
), (cs
, str
)) =>
471 val idSym
= Symbol
.labSymbol id
472 val _
= List.all (fn (id
', _
) => idSym
<> id
') cs
473 orelse error (SOME pos
, "Duplicate label " ^ id ^
" in record")
474 val (ty
, s
) = xexp state e
476 ((idSym
, ty
) :: cs
, str ^
", " ^ id ^
" = " ^ s
)
482 | _
=> String.extract(str
, 2, NONE
)
483 val str
= "{" ^ str ^
"}"
485 (BasicTypes
.recordTy cs
, str
)
489 val dom
= newTyvar
false
490 val ran
= newTyvar
false
492 fun folder ((p
, e
'), (first
, str
)) =
494 val (pty
, vars
', ps
) = xpat state p
496 val _
= unify
state (pos
, dom
, pty
)
498 val (ty
', str
') = xexp (addVars (state
, vars
')) e
'
500 unify
state (pos
, ty
', ran
);
502 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => " ^
506 foldl
folder (true, "(fn \n") matches
507 val str
= str ^
")\n"
509 (BasicTypes
.--> (dom
, ran
), str
)
513 val (ty
, es
) = xexp state e
515 unify
state (pos
, ty
, BasicTypes
.exnTy
);
516 (newTyvar
false, "(raise (" ^ es ^
"))")
518 |
RecordUpd_e (e
, cs
) =>
520 val (ty
, es
) = xexp state e
523 case TypesUtil
.headReduceType ty
of
524 Types
.CONty (Types
.RECORDtyc labs
, tys
) => ListPair.zip (labs
, tys
)
525 | _
=> error (SOME pos
, "Record update on non-record")
527 val (n
, str
) = foldl (fn ((id
, ty
), (n
, str
)) =>
528 case List.find (fn (id
', _
) => id
= Symbol
.labSymbol id
') cs
of
529 NONE
=> (n
, str ^
", " ^ Symbol
.name id ^
" = #" ^
530 Symbol
.name id ^
" " ^
"UPD'")
533 val (ty
', s
) = xexp state e
535 unify
state (pos
, ty
, ty
');
536 (n
+ 1, str ^
", " ^ Symbol
.name id ^
" = " ^ s
)
539 val _
= n
= length cs
540 orelse error (SOME pos
, "Updated fields in record update not found in starting expression")
545 | _
=> String.extract(str
, 2, NONE
)
546 val str
= "let val UPD' = " ^ es ^
" in {" ^ str ^
"} end"
550 handle Skip
=> (errorTy
, "<error>")
552 and mergePatVars
pos (vars1
, vars2
) =
553 StringMap
.foldli (fn (v
, ty
, vars
) =>
554 (case StringMap
.find (vars
, v
) of
555 NONE
=> StringMap
.insert (vars
, v
, ty
)
556 | SOME _
=> error (SOME pos
, "Duplicate variable " ^ v ^
" in pattern"))) vars1 vars2
558 and xpat
state (PAT (p
, pos
)) =
560 Ident_p
[] => raise Fail
"Impossible empty Ident_p"
562 ((lookCon
' (state
, id
), StringMap
.empty
, id
)
563 handle StaticEnv
.Unbound
=>
565 val ty
= newTyvar
false
567 (ty
, StringMap
.insert (StringMap
.empty
, id
, VAR ty
), id
)
569 |
Ident_p (path
as (s
::rest
)) =>
570 (resolveCon (pos
, state
, path
), StringMap
.empty
, foldl (fn (v
, st
) => st ^
"." ^ v
) s rest
)
571 | Wild_p
=> (newTyvar
false, StringMap
.empty
, "_")
572 | Int_p n
=> (BasicTypes
.intTy
, StringMap
.empty
, Int.toString n
)
573 | Real_p n
=> (BasicTypes
.realTy
, StringMap
.empty
, Real.toString n
)
574 | String_p s
=> (BasicTypes
.stringTy
, StringMap
.empty
, "\"" ^ s ^
"\"")
575 | Char_p s
=> (BasicTypes
.charTy
, StringMap
.empty
, "#\"" ^ s ^
"\"")
576 |
App_p ([], _
) => raise Fail
"Impossible App_p"
579 val (ty
, vars
, s
) = xpat state p
580 val tyc
= lookCon (state
, id
, pos
)
583 unify
state (pos
, dom
, ty
);
584 (range tyc
, vars
, id ^
" (" ^ s ^
")")
586 |
App_p (path
as (fst
::rest
), p
) =>
588 val (ty
, vars
, s
) = xpat state p
589 val tyc
= resolveCon (pos
, state
, path
)
592 unify
state (pos
, dom
, ty
);
593 (range tyc
, vars
, foldl (fn (n
, st
) => st ^
"." ^ n
) fst rest ^
" (" ^ s ^
")")
597 val (ty1
, vars
', s1
) = xpat state p1
598 val (ty2
, vars
'', s2
) = xpat state p2
600 val resty
= Types
.CONty (BasicTypes
.listTycon
, [ty1
])
602 unify
state (pos
, ty2
, resty
);
603 (resty
, mergePatVars
pos (vars
', vars
''), "(" ^ s1 ^
")::(" ^ s2 ^
")")
607 val (ty
, vars
, s
) = xpat state p
609 not (Option
.isSome (StringMap
.find(vars
, id
)))
610 orelse error (SOME pos
, "Duplicate variable " ^ id ^
" in pattern");
611 (ty
, StringMap
.insert (vars
, id
, VAR ty
), id ^
" as (" ^ s ^
")")
613 |
Record_p (ist
, cs
) =>
615 val (cs
, vars
, str
) = foldl (fn ((id
, p
), (cs
, vars
, str
)) =>
617 val (ty
, vars
', s
) = xpat state p
619 ((Symbol
.labSymbol id
, ty
)::cs
, mergePatVars
pos (vars
, vars
'),
620 str ^
", " ^ id ^
" = " ^ s
)
621 end) ([], StringMap
.empty
, "") cs
624 if String.size str
>= 2 then
625 String.extract(str
, 2, NONE
)
628 val str
= "{" ^ str ^
"}"
630 (BasicTypes
.recordTy cs
, vars
, str
)
634 val (cs
, vars
, str
) = foldl (fn ((id
, p
), (cs
, vars
, str
)) =>
636 val (ty
, vars
', s
) = xpat state p
638 ((Symbol
.labSymbol id
, ty
)::cs
, mergePatVars
pos (vars
, vars
'),
639 str ^
", " ^ id ^
" = " ^ s
)
640 end) ([], StringMap
.empty
, "") cs
643 if String.size str
>= 2 then
644 String.extract(str
, 2, NONE
)
647 val str
= "{" ^ str ^
", ...}"
649 (newFlex cs
, vars
, str
)
652 error (SOME pos
, "Not done yet!!!")*))
653 handle Skip
=> (errorTy
, StringMap
.empty
, "<error>")
655 fun xblock
state (BLOCK (blocks
, pos
)) =
657 fun folder (BITEM (bi
, pos
), (state
, str
)) =
660 (state
, str ^
"val _ = Web.print (\"" ^ escapeString s ^
"\")\n")
663 fun folder ((id
, e
), (state
, str
)) =
665 val (ty
, es
) = xexp state e
667 val state
= addVar (state
, id
, REF ty
)
669 (state
, str ^
"val " ^ id ^
" = ref (" ^ es ^
")\n")
672 foldl
folder (state
, str
) rs
677 case getVar (state
, id
, SOME pos
) of
678 NONE
=> error (SOME pos
, "Unbound variable " ^ id
)
679 |
SOME (REF vty
) => vty
680 | _
=> error (SOME pos
, "Can't assign to non-ref variable " ^ id
)
682 val (ty
, es
) = xexp state e
684 unify
state (pos
, ty
, vty
);
685 (state
, str ^
"val _ = " ^ id ^
" := (" ^ es ^
")\n")
689 val (pty
, vars
, ps
) = xpat state p
690 val state
' = addVars (state
, vars
)
691 val (ty
, es
) = xexp state e
693 unify
state (pos
, pty
, ty
);
694 (state
', str ^
"val " ^ ps ^
" = (" ^ es ^
")\n")
698 val (ty
, s
) = xexp state e
699 val ty
= TypesUtil
.headReduceType ty
701 case printFn state ty
of
702 NONE
=> (if tyToString state ty
= "_" then
705 error (SOME pos
, "Unable to convert value of type " ^
706 tyToString state ty ^
" to string");
710 (state
, str ^
"val _ = " ^ printFn ^
" (" ^ s ^
")\n")
712 |
Ifthenelse_i (e
, b
, els
) =>
714 val str
= str ^
"val _ = "
715 val (ty
, s
) = xexp state e
716 val (_
, str
') = xblock state b
717 val _
= unify
state (pos
, ty
, BasicTypes
.boolTy
)
718 val str
= str ^
"if (" ^ s ^
") then let\n" ^
727 val (_
, str
') = xblock state els
736 |
Foreach_i (id
, e
, b
) =>
738 val parm
= newTyvar
false
740 val (ty
, es
) = xexp state e
742 val _
= unify
state (pos
, ty
, Types
.CONty (BasicTypes
.listTycon
, [parm
]))
744 (*val _
= print ("... to " ^
tyToString (context
, ivmap
, pty
) ^
"\n")*)
746 val state
= addVar (state
, id
, VAR parm
)
747 val (_
, bs
) = xblock state b
749 (state
, str ^
"fun foreach (" ^ id ^
" : " ^
750 tyToString state parm ^
") = let\n" ^
753 "val _ = app foreach (" ^ es ^
")\n")
755 |
For_i (id
, eFrom
, eTo
, b
) =>
757 val (ty1
, es1
) = xexp state eFrom
758 val _
= unify
state (pos
, ty1
, BasicTypes
.intTy
)
760 val (ty2
, es2
) = xexp state eTo
761 val _
= unify
state (pos
, ty2
, BasicTypes
.intTy
)
763 val state
= addVar (state
, id
, VAR BasicTypes
.intTy
)
764 val (_
, bs
) = xblock state b
766 (state
, str ^
"fun forFunc " ^ id ^
" = let\n" ^
769 "val _ = Web.for forFunc (" ^ es1 ^
", " ^ es2 ^
")\n")
771 |
Case_i (e
, matches
) =>
773 val (ty
, s
) = xexp state e
775 fun folder ((p
, b
), (first
, str
)) =
777 val (pty
, vars
', ps
) = xpat state p
779 val _
= unify
state (pos
, ty
, pty
)
781 val (_
, str
') = xblock (addVars (state
, vars
')) b
783 (*val _
= print ("Pattern type: " ^
tyToString (context
, ivmap
, pty
) ^
" vs. " ^
tyToString (context
, ivmap
, ty
) ^
"\n")*)
786 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => let\n" ^
791 foldl
folder (true, str ^
"val _ = (case (" ^ s ^
") of\n") matches
792 val str
= str ^
") handle Match => ()\n"
796 |
TryCatch_i (b
, matches
) =>
798 val (_
, bs
) = xblock state b
800 fun folder ((p
, b
), (first
, str
)) =
802 val (pty
, vars
, ps
) = xpat state p
803 val state
= addVars (state
, vars
)
804 val (_
, str
') = xblock state b
806 unify
state (pos
, BasicTypes
.exnTy
, pty
);
808 str ^
(if first
then " " else " | ") ^
"(" ^ ps ^
") => let\n" ^
814 str ^
"val _ = (let\n" ^
816 "in () end handle\n") matches
817 val str
= str ^
")\n"
823 fun folder (path
, state
) = openStructure (pos
, state
, path
)
825 val str
= foldl (fn (path
, str
) => str ^
" " ^ Tree
.pathString path
) (str ^
"open") paths
828 (foldl folder state paths
, str
)
830 handle Skip
=> (state
, str
)
832 foldl
folder (state
, "") blocks
835 fun trans (config
, env
, templates
, name
, block
) =
837 val state
= mkState (config
, env
, templates
)
838 val (_
, str
) = xblock state block
840 "(* This file generated automatically by something or other *)\n" ^
842 "structure " ^ name ^
" :> TEMPLATE =\n" ^
844 "fun exec () = let\n" ^