summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/cjr.sml10
-rw-r--r--src/cjr_env.sig3
-rw-r--r--src/cjr_env.sml25
-rw-r--r--src/cjr_print.sml103
-rw-r--r--src/cjrize.sig2
-rw-r--r--src/cjrize.sml81
-rw-r--r--src/cloconv.sig32
-rw-r--r--src/cloconv.sml239
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml32
-rw-r--r--src/core.sml4
-rw-r--r--src/core_env.sig4
-rw-r--r--src/core_env.sml12
-rw-r--r--src/core_print.sml29
-rw-r--r--src/core_util.sig2
-rw-r--r--src/core_util.sml17
-rw-r--r--src/corify.sml72
-rw-r--r--src/elab.sml2
-rw-r--r--src/elab_env.sig2
-rw-r--r--src/elab_env.sml10
-rw-r--r--src/elab_print.sml12
-rw-r--r--src/elab_util.sml14
-rw-r--r--src/elaborate.sml52
-rw-r--r--src/expl.sml4
-rw-r--r--src/expl_env.sml2
-rw-r--r--src/expl_print.sml20
-rw-r--r--src/expl_util.sml5
-rw-r--r--src/explify.sml2
-rw-r--r--src/flat.sml72
-rw-r--r--src/flat_env.sig53
-rw-r--r--src/flat_env.sml116
-rw-r--r--src/flat_print.sig37
-rw-r--r--src/flat_print.sml236
-rw-r--r--src/flat_util.sig125
-rw-r--r--src/flat_util.sml376
-rw-r--r--src/lacweb.grm4
-rw-r--r--src/lacweb.lex2
-rw-r--r--src/mono.sml4
-rw-r--r--src/mono_env.sig4
-rw-r--r--src/mono_env.sml10
-rw-r--r--src/mono_print.sml36
-rw-r--r--src/mono_util.sig5
-rw-r--r--src/mono_util.sml62
-rw-r--r--src/monoize.sml12
-rw-r--r--src/reduce.sml4
-rw-r--r--src/shake.sml24
-rw-r--r--src/source.sml2
-rw-r--r--src/source_print.sml6
-rw-r--r--src/sources14
-rw-r--r--tests/attrs.lac2
-rw-r--r--tests/attrs_escape.lac2
-rw-r--r--tests/html_fn.lac2
52 files changed, 337 insertions, 1667 deletions
diff --git a/src/cjr.sml b/src/cjr.sml
index d22b38f4..a47c77fe 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -31,8 +31,7 @@ type 'a located = 'a ErrorMsg.located
datatype typ' =
TTop
- | TFun
- | TCode of typ * typ
+ | TFun of typ * typ
| TRecord of int
| TNamed of int
| TFfi of string * string
@@ -45,14 +44,11 @@ datatype exp' =
| ENamed of int
| EFfi of string * string
| EFfiApp of string * string * exp list
- | ECode of int
| EApp of exp * exp
| ERecord of int * (string * exp) list
| EField of exp * string
- | ELet of (string * typ * exp) list * exp
-
| EWrite of exp
| ESeq of exp * exp
@@ -61,10 +57,10 @@ withtype exp = exp' located
datatype decl' =
DStruct of int * (string * typ) list
| DVal of string * int * typ * exp
- | DFun of int * string * typ * typ * exp
+ | DFun of string * int * string * typ * typ * exp
withtype decl = decl' located
-type file = decl list * ((string * typ) list * exp) list
+type file = decl list * int list
end
diff --git a/src/cjr_env.sig b/src/cjr_env.sig
index 2aa785d5..36c3d682 100644
--- a/src/cjr_env.sig
+++ b/src/cjr_env.sig
@@ -47,9 +47,6 @@ signature CJR_ENV = sig
val pushENamed : env -> string -> int -> Cjr.typ -> env
val lookupENamed : env -> int -> string * Cjr.typ
- val pushF : env -> int -> string -> Cjr.typ -> Cjr.typ -> env
- val lookupF : env -> int -> string * Cjr.typ * Cjr.typ
-
val pushStruct : env -> int -> (string * Cjr.typ) list -> env
val lookupStruct : env -> int -> (string * Cjr.typ) list
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index de1c31a1..686c99b1 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -44,7 +44,6 @@ type env = {
relE : (string * typ) list,
namedE : (string * typ) IM.map,
- F : (string * typ * typ) IM.map,
structs : (string * typ) list IM.map
}
@@ -55,7 +54,6 @@ val empty = {
relE = [],
namedE = IM.empty,
- F = IM.empty,
structs = IM.empty
}
@@ -66,7 +64,6 @@ fun pushTNamed (env : env) x n co =
relE = #relE env,
namedE = #namedE env,
- F = #F env,
structs = #structs env}
fun lookupTNamed (env : env) n =
@@ -81,7 +78,6 @@ fun pushERel (env : env) x t =
relE = (x, t) :: #relE env,
namedE = #namedE env,
- F = #F env,
structs = #structs env}
fun lookupERel (env : env) n =
@@ -99,7 +95,6 @@ fun pushENamed (env : env) x n t =
relE = #relE env,
namedE = IM.insert (#namedE env, n, (x, t)),
- F = #F env,
structs = #structs env}
fun lookupENamed (env : env) n =
@@ -107,21 +102,6 @@ fun lookupENamed (env : env) n =
NONE => raise UnboundNamed n
| SOME x => x
-fun pushF (env : env) n x dom ran =
- {namedT = #namedT env,
-
- numRelE = #numRelE env,
- relE = #relE env,
- namedE = #namedE env,
-
- F = IM.insert (#F env, n, (x, dom, ran)),
- structs = #structs env}
-
-fun lookupF (env : env) n =
- case IM.find (#F env, n) of
- NONE => raise UnboundF n
- | SOME x => x
-
fun pushStruct (env : env) n xts =
{namedT = #namedT env,
@@ -129,7 +109,6 @@ fun pushStruct (env : env) n xts =
relE = #relE env,
namedE = #namedE env,
- F = #F env,
structs = IM.insert (#structs env, n, xts)}
fun lookupStruct (env : env) n =
@@ -137,10 +116,10 @@ fun lookupStruct (env : env) n =
NONE => raise UnboundStruct n
| SOME x => x
-fun declBinds env (d, _) =
+fun declBinds env (d, loc) =
case d of
DVal (x, n, t, _) => pushENamed env x n t
- | DFun (n, x, dom, ran, _) => pushF env n x dom ran
+ | DFun (fx, n, _, dom, ran, _) => pushENamed env fx n (TFun (dom, ran), loc)
| DStruct (n, xts) => pushStruct env n xts
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 44e9f847..32c43d23 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -44,16 +44,13 @@ val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
fun p_typ' par env (t, loc) =
case t of
TTop => string "void*"
- | TFun =>
- (EM.errorAt loc "Undetermined function type";
- string "?->")
- | TCode (t1, t2) => parenIf par (box [p_typ' true env t2,
- space,
- string "(*)",
- space,
- string "(",
- p_typ env t1,
- string ")"])
+ | TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
+ space,
+ string "(*)",
+ space,
+ string "(",
+ p_typ env t1,
+ string ")"])
| TRecord i => box [string "struct",
space,
string "__lws_",
@@ -68,13 +65,16 @@ and p_typ env = p_typ' false env
fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
+fun p_enamed env n =
+ string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
+ handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n)
+
fun p_exp' par env (e, _) =
case e of
EPrim p => Prim.p_t p
| ERel n => p_rel env n
- | ENamed n =>
- (string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
- handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n))
+ | ENamed n => p_enamed env n
+
| EFfi (m, x) => box [string "lw_", string m, string "_", string x]
| EFfiApp (m, x, es) => box [string "lw_",
string m,
@@ -83,7 +83,6 @@ fun p_exp' par env (e, _) =
string "(",
p_list (p_exp env) es,
string ")"]
- | ECode n => string ("__lwc_" ^ Int.toString n)
| EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
string "(",
p_exp env e2,
@@ -112,36 +111,6 @@ fun p_exp' par env (e, _) =
string ".",
string x]
- | ELet (xes, e) =>
- let
- val (env, pps) = foldl (fn ((x, t, e), (env, pps)) =>
- let
- val env' = E.pushERel env x t
- in
- (env',
- List.revAppend ([p_typ env t,
- space,
- p_rel env' 0,
- space,
- string "=",
- space,
- p_exp env e,
- string ";",
- newline],
- pps))
- end)
- (env, []) xes
- in
- box [string "({",
- newline,
- box (rev pps),
- p_exp env e,
- space,
- string ";",
- newline,
- string "})"]
- end
-
| EWrite e => box [string "(lw_write(",
p_exp env e,
string "), lw_unit_v)"]
@@ -180,7 +149,7 @@ fun p_decl env ((d, _) : decl) =
space,
p_exp env e,
string ";"]
- | DFun (n, x, dom, ran, e) =>
+ | DFun (fx, n, x, dom, ran, e) =>
let
val env' = E.pushERel env x dom
in
@@ -188,7 +157,7 @@ fun p_decl env ((d, _) : decl) =
space,
p_typ env ran,
space,
- string ("__lwc_" ^ Int.toString n),
+ string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
string "(",
p_typ env dom,
space,
@@ -204,46 +173,8 @@ fun p_decl env ((d, _) : decl) =
string "}"]
end
-fun p_page env (xts, (e, loc)) =
- case e of
- ERecord (_, xes) =>
- let
- fun read x = ListUtil.search (fn (x', e) => if x' = x then SOME e else NONE) xes
- in
- case (read "code", read "env") of
- (SOME code, SOME envx) =>
- (case #1 code of
- ECode i =>
- let
- val (_, (dom, _), _) = E.lookupF env i
- in
- case dom of
- TRecord ri =>
- let
- val axts = E.lookupStruct env ri
- fun read x = ListUtil.search (fn (x', t) => if x' = x then SOME t else NONE) axts
- in
- case read "arg" of
- NONE => string "Page handler is too complicated! [5]"
- | SOME (at, _) =>
- case at of
- TRecord ari =>
- let
- val r = (ERecord (ri, [("env", envx),
- ("arg", (ERecord (ari, []), loc))]), loc)
- in
- box [p_exp env (EApp (code, r), loc),
- string ";"]
- end
- | _ => string "Page handler is too complicated! [6]"
- end
- | _ => string "Page handler is too complicated! [4]"
- end
- | _ => string "Page handler is too complicated! [3]")
-
- | _ => string "Page handler is too complicated! [1]"
- end
- | _ => string "Page handler is too complicated! [2]"
+fun p_page env n = box [p_enamed env n,
+ string "(lw_unit_v);"]
fun p_file env (ds, ps) =
let
diff --git a/src/cjrize.sig b/src/cjrize.sig
index 44bf4fd2..fb8d37f5 100644
--- a/src/cjrize.sig
+++ b/src/cjrize.sig
@@ -27,6 +27,6 @@
signature CJRIZE = sig
- val cjrize : Flat.file -> Cjr.file
+ val cjrize : Mono.file -> Cjr.file
end
diff --git a/src/cjrize.sml b/src/cjrize.sml
index da436720..52b1b4ac 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -27,7 +27,7 @@
structure Cjrize :> CJRIZE = struct
-structure L = Flat
+structure L = Mono
structure L' = Cjr
structure Sm :> sig
@@ -41,7 +41,7 @@ end = struct
structure FM = BinaryMapFn(struct
type ord_key = L.typ
- val compare = FlatUtil.Typ.compare
+ val compare = MonoUtil.Typ.compare
end)
type t = int * int FM.map * (int * (string * L'.typ) list) list
@@ -63,20 +63,12 @@ end
fun cifyTyp ((t, loc), sm) =
case t of
- L.TTop => ((L'.TTop, loc), sm)
- | L.TFun (t1, t2) =>
- let
- val (_, sm) = cifyTyp (t1, sm)
- val (_, sm) = cifyTyp (t2, sm)
- in
- ((L'.TFun, loc), sm)
- end
- | L.TCode (t1, t2) =>
+ L.TFun (t1, t2) =>
let
val (t1, sm) = cifyTyp (t1, sm)
val (t2, sm) = cifyTyp (t2, sm)
in
- ((L'.TCode (t1, t2), loc), sm)
+ ((L'.TFun (t1, t2), loc), sm)
end
| L.TRecord xts =>
let
@@ -95,6 +87,8 @@ fun cifyTyp ((t, loc), sm) =
| L.TNamed n => ((L'.TNamed n, loc), sm)
| L.TFfi mx => ((L'.TFfi mx, loc), sm)
+val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)
+
fun cifyExp ((e, loc), sm) =
case e of
L.EPrim p => ((L'.EPrim p, loc), sm)
@@ -107,7 +101,6 @@ fun cifyExp ((e, loc), sm) =
in
((L'.EFfiApp (m, x, es), loc), sm)
end
- | L.ECode n => ((L'.ECode n, loc), sm)
| L.EApp (e1, e2) =>
let
val (e1, sm) = cifyExp (e1, sm)
@@ -115,6 +108,8 @@ fun cifyExp ((e, loc), sm) =
in
((L'.EApp (e1, e2), loc), sm)
end
+ | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
+ (dummye, sm))
| L.ERecord xes =>
let
@@ -143,21 +138,6 @@ fun cifyExp ((e, loc), sm) =
((L'.EField (e, x), loc), sm)
end
- | L.ELet (xes, e) =>
- let
- val (xes, sm) = ListUtil.foldlMap (fn ((x, t, e), sm) =>
- let
- val (t, sm) = cifyTyp (t, sm)
- val (e, sm) = cifyExp (e, sm)
- in
- ((x, t, e), sm)
- end)
- sm xes
- val (e, sm) = cifyExp (e, sm)
- in
- ((L'.ELet (xes, e), loc), sm)
- end
-
| L.EStrcat _ => raise Fail "Cjrize EStrcat"
| L.EWrite e =>
@@ -177,34 +157,31 @@ fun cifyExp ((e, loc), sm) =
fun cifyDecl ((d, loc), sm) =
case d of
- L.DVal (x, n, t, e) =>
+ L.DVal (x, n, t, e, _) =>
let
val (t, sm) = cifyTyp (t, sm)
- val (e, sm) = cifyExp (e, sm)
- in
- (SOME (L'.DVal (x, n, t, e), loc), NONE, sm)
- end
- | L.DFun (n, x, dom, ran, e) =>
- let
- val (dom, sm) = cifyTyp (dom, sm)
- val (ran, sm) = cifyTyp (ran, sm)
- val (e, sm) = cifyExp (e, sm)
- in
- (SOME (L'.DFun (n, x, dom, ran, e), loc), NONE, sm)
- end
- | L.DPage (xts, e) =>
- let
- val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
- let
- val (t, sm) = cifyTyp (t, sm)
- in
- ((x, t), sm)
- end)
- sm xts
- val (e, sm) = cifyExp (e, sm)
+
+ val (d, sm) = case #1 t of
+ L'.TFun (dom, ran) =>
+ (case #1 e of
+ L.EAbs (ax, _, _, e) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ in
+ (L'.DFun (x, n, ax, dom, ran, e), sm)
+ end
+ | _ => (ErrorMsg.errorAt loc "Function isn't explicit at code generation";
+ (L'.DVal ("", 0, t, (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)), sm)))
+ | _ =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ in
+ (L'.DVal (x, n, t, e), sm)
+ end
in
- (NONE, SOME (xts, e), sm)
+ (SOME (d, loc), NONE, sm)
end
+ | L.DExport n => (NONE, SOME n, sm)
fun cjrize ds =
let
diff --git a/src/cloconv.sig b/src/cloconv.sig
deleted file mode 100644
index d71d3201..00000000
--- a/src/cloconv.sig
+++ /dev/null
@@ -1,32 +0,0 @@
-(* Copyright (c) 2008, Adam Chlipala
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * - Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- * - Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- * - The names of contributors may not be used to endorse or promote products
- * derived from this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
- * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
- * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
- * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *)
-
-signature CLOCONV = sig
-
- val cloconv : Mono.file -> Flat.file
-
-end
diff --git a/src/cloconv.sml b/src/cloconv.sml
deleted file mode 100644
index b5ea56ca..00000000
--- a/src/cloconv.sml
+++ /dev/null
@@ -1,239 +0,0 @@
-(* Copyright (c) 2008, Adam Chlipala
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * - Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- * - Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- * - The names of contributors may not be used to endorse or promote products
- * derived from this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
- * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
- * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
- * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *)
-
-structure Cloconv :> CLOCONV = struct
-
-structure L = Mono
-structure L' = Flat
-
-structure IS = IntBinarySet
-
-structure U = FlatUtil
-structure E = FlatEnv
-
-open Print.PD
-open Print
-
-val liftExpInExp =
- U.Exp.mapB {typ = fn t => t,
- exp = fn bound => fn e =>
- case e of
- L'.ERel xn =>
- if xn < bound then
- e
- else
- L'.ERel (xn + 1)
- | _ => e,
- bind = fn (bound, U.Exp.RelE _) => bound + 1
- | (bound, _) => bound}
-val subExpInExp =
- U.Exp.mapB {typ = fn t => t,
- exp = fn (xn, rep) => fn e =>
- case e of
- L'.ERel xn' =>
- (case Int.compare (xn', xn) of
- EQUAL => #1 rep
- | GREATER => L'.ERel (xn' - 1)
- | _ => e)
- | _ => e,
- bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
- | (ctx, _) => ctx}
-
-
-fun ccTyp (t, loc) =
- case t of
- L.TFun (t1, t2) => (L'.TFun (ccTyp t1, ccTyp t2), loc)
- | L.TRecord xts => (L'.TRecord (map (fn (x, t) => (x, ccTyp t)) xts), loc)
- | L.TNamed n => (L'.TNamed n, loc)
- | L.TFfi mx => (L'.TFfi mx, loc)
-
-structure Ds :> sig
- type t
-
- val empty : t
-
- val exp : t -> string * int * L'.typ * L'.exp -> t
- val func : t -> string * L'.typ * L'.typ * L'.exp -> t * int
- val page : t -> (string * L'.typ) list * L'.exp -> t
- val decls : t -> L'.decl list
-
- val enter : t -> t
- val used : t * int -> t
- val leave : t -> t
- val listUsed : t -> int list
-end = struct
-
-type t = int * L'.decl list * IS.set
-
-val empty = (0, [], IS.empty)
-
-fun exp (fc, ds, vm) (v as (_, _, _, (_, loc))) = (fc, (L'.DVal v, loc) :: ds, vm)
-
-fun func (fc, ds, vm) (x, dom, ran, e as (_, loc)) =
- ((fc+1, (L'.DFun (fc, x, dom, ran, e), loc) :: ds, vm), fc)
-
-fun page (fc, ds, vm) (xts, e as (_, loc)) = (fc, (L'.DPage (xts, e), loc) :: ds, vm)
-
-fun decls (_, ds, _) = rev ds
-
-fun enter (fc, ds, vm) = (fc, ds, IS.map (fn n => n + 1) vm)
-fun used ((fc, ds, vm), n) = (fc, ds, IS.add (vm, n))
-fun leave (fc, ds, vm) = (fc, ds, IS.map (fn n => n - 1) (IS.delete (vm, 0) handle NotFound => vm))
-
-fun listUsed (_, _, vm) = IS.listItems vm
-
-end
-
-
-fun ccExp env ((e, loc), D) =
- case e of
- L.EPrim p => ((L'.EPrim p, loc), D)
- | L.ERel n => ((L'.ERel n, loc), Ds.used (D, n))
- | L.ENamed n => ((L'.ENamed n, loc), D)
- | L.EFfi mx => ((L'.EFfi mx, loc), D)
- | L.EFfiApp (m, x, es) =>
- let
- val (es, D) = ListUtil.foldlMap (ccExp env) D es
- in
- ((L'.EFfiApp (m, x, es), loc), D)
- end
- | L.EApp (e1, e2) =>
- let
- val (e1, D) = ccExp env (e1, D)
- val (e2, D) = ccExp env (e2, D)
- in
- ((L'.ELet ([("closure", (L'.TTop, loc), e1),
- ("arg", (L'.TTop, loc), liftExpInExp 0 e2),
- ("code", (L'.TTop, loc), (L'.EField ((L'.ERel 1, loc), "func"), loc)),
- ("env", (L'.TTop, loc), (L'.EField ((L'.ERel 2, loc), "env"), loc))],
- (L'.EApp ((L'.ERel 1, loc),
- (L'.ERecord [("env", (L'.ERel 0, loc), (L'.TTop, loc)),
- ("arg", (L'.ERel 2, loc), (L'.TTop, loc))], loc)), loc)), loc), D)
- end
- | L.EAbs (x, dom, ran, e) =>
- let
- val dom = ccTyp dom
- val ran = ccTyp ran
- val (e, D) = ccExp (E.pushERel env x dom) (e, Ds.enter D)
- val ns = Ds.listUsed D
- val ns = List.filter (fn n => n <> 0) ns
- val D = Ds.leave D
-
- val envT = (L'.TRecord (map (fn n => ("fv" ^ Int.toString n, #2 (E.lookupERel env (n-1)))) ns), loc)
-
- (*val () = Print.preface ("Before", FlatPrint.p_exp FlatEnv.basis e)
- val () = List.app (fn (x, t) => preface ("Bound", box [string x,
- space,
- string ":",
- space,
- FlatPrint.p_typ env t]))
- (E.listERels env)
- val () = List.app (fn n => preface ("Free", FlatPrint.p_exp (E.pushERel env x dom)
- (L'.ERel n, loc))) ns*)
- val body = foldl (fn (n, e) =>
- subExpInExp (n, (L'.EField ((L'.ERel 1, loc), "fv" ^ Int.toString n), loc)) e)
- e ns
- (*val () = Print.preface (" After", FlatPrint.p_exp FlatEnv.basis body)*)
- val body = (L'.ELet ([("env", envT, (L'.EField ((L'.ERel 0, loc), "env"), loc)),
- ("arg", dom, (L'.EField ((L'.ERel 1, loc), "arg"), loc))],
- body), loc)
-
- val (D, fi) = Ds.func D (x, (L'.TRecord [("env", envT), ("arg", dom)], loc), ran, body)
- in
- ((L'.ERecord [("code", (L'.ECode fi, loc), (L'.TTop, loc)),
- ("env", (L'.ERecord (map (fn n => ("fv" ^ Int.toString n,
- (L'.ERel (n-1), loc),
- #2 (E.lookupERel env (n-1)))) ns), loc),
- envT)], loc), D)
- end
-
- | L.ERecord xes =>
- let
- val (xes, D) = ListUtil.foldlMap (fn ((x, e, t), D) =>
- let
- val (e, D) = ccExp env (e, D)
- in
- ((x, e, ccTyp t), D)
- end) D xes
- in
- ((L'.ERecord xes, loc), D)
- end
- | L.EField (e1, x) =>
- let
- val (e1, D) = ccExp env (e1, D)
- in
- ((L'.EField (e1, x), loc), D)
- end
-
- | L.EStrcat (e1, e2) =>
- let
- val (e1, D) = ccExp env (e1, D)
- val (e2, D) = ccExp env (e2, D)
- in
- ((L'.EStrcat (e1, e2), loc), D)
- end
-
- | L.EWrite e =>
- let
- val (e, D) = ccExp env (e, D)
- in
- ((L'.EWrite e, loc), D)
- end
-
- | L.ESeq (e1, e2) =>
- let
- val (e1, D) = ccExp env (e1, D)
- val (e2, D) = ccExp env (e2, D)
- in
- ((L'.ESeq (e1, e2), loc), D)
- end
-
-fun ccDecl ((d, loc), D) =
- case d of
- L.DVal (x, n, t, e) =>
- let
- val t = ccTyp t
- val (e, D) = ccExp E.empty (e, D)
- in
- Ds.exp D (x, n, t, e)
- end
- | L.DPage (xts, e) =>
- let
- val xts = map (fn (x, t) => (x, ccTyp t)) xts
- val (e, D) = ccExp E.empty (e, D)
- in
- Ds.page D (xts, e)
- end
-
-fun cloconv ds =
- let
- val D = foldl ccDecl Ds.empty ds
- in
- Ds.decls D
- end
-
-end
diff --git a/src/compiler.sig b/src/compiler.sig
index c85eba39..62d38308 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -47,7 +47,6 @@ signature COMPILER = sig
val shake : job -> Core.file option
val monoize : job -> Mono.file option
val mono_opt : job -> Mono.file option
- val cloconv : job -> Flat.file option
val cjrize : job -> Cjr.file option
val testParse : job -> unit
@@ -59,7 +58,6 @@ signature COMPILER = sig
val testShake : job -> unit
val testMonoize : job -> unit
val testMono_opt : job -> unit
- val testCloconv : job -> unit
val testCjrize : job -> unit
end
diff --git a/src/compiler.sml b/src/compiler.sml
index 1e40cb11..1f063633 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -111,9 +111,11 @@ fun capitalize "" = ""
fun parse fnames =
let
+ fun nameOf fname = capitalize (OS.Path.file fname)
+
fun parseOne fname =
let
- val mname = capitalize (OS.Path.file fname)
+ val mname = nameOf fname
val lac = OS.Path.joinBaseExt {base = fname, ext = SOME "lac"}
val lig = OS.Path.joinBaseExt {base = fname, ext = SOME "lig"}
@@ -137,7 +139,13 @@ fun parse fnames =
SOME (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
end
- val ds = List.mapPartial parseOne fnames
+ val ds = List.mapPartial parseOne fnames
+ val ds =
+ let
+ val final = nameOf (List.last fnames)
+ in
+ ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
+ end handle Empty => ds
in
if ErrorMsg.anyErrors () then
NONE
@@ -224,17 +232,8 @@ fun mono_opt job =
else
SOME (MonoOpt.optimize file)
-fun cloconv job =
- case mono_opt job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (Cloconv.cloconv file)
-
fun cjrize job =
- case cloconv job of
+ case mono_opt job of
NONE => NONE
| SOME file =>
if ErrorMsg.anyErrors () then
@@ -322,15 +321,6 @@ fun testMono_opt job =
handle MonoEnv.UnboundNamed n =>
print ("Unbound named " ^ Int.toString n ^ "\n")
-fun testCloconv job =
- (case cloconv job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (FlatPrint.p_file FlatEnv.empty file);
- print "\n"))
- handle FlatEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
fun testCjrize job =
(case cjrize job of
NONE => print "Failed\n"
diff --git a/src/core.sml b/src/core.sml
index 4572a8d9..fe969d18 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -80,8 +80,8 @@ withtype exp = exp' located
datatype decl' =
DCon of string * int * kind * con
- | DVal of string * int * con * exp
- | DPage of con * exp
+ | DVal of string * int * con * exp * string
+ | DExport of int
withtype decl = decl' located
diff --git a/src/core_env.sig b/src/core_env.sig
index 56945972..59087ace 100644
--- a/src/core_env.sig
+++ b/src/core_env.sig
@@ -45,8 +45,8 @@ signature CORE_ENV = sig
val pushERel : env -> string -> Core.con -> env
val lookupERel : env -> int -> string * Core.con
- val pushENamed : env -> string -> int -> Core.con -> Core.exp option -> env
- val lookupENamed : env -> int -> string * Core.con * Core.exp option
+ val pushENamed : env -> string -> int -> Core.con -> Core.exp option -> string -> env
+ val lookupENamed : env -> int -> string * Core.con * Core.exp option * string
val declBinds : env -> Core.decl -> env
diff --git a/src/core_env.sml b/src/core_env.sml
index 2b6de82c..5a24a82a 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -62,7 +62,7 @@ type env = {
namedC : (string * kind * con option) IM.map,
relE : (string * con) list,
- namedE : (string * con * exp option) IM.map
+ namedE : (string * con * exp option * string) IM.map
}
val empty = {
@@ -78,7 +78,7 @@ fun pushCRel (env : env) x k =
namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env),
relE = map (fn (x, c) => (x, lift c)) (#relE env),
- namedE = IM.map (fn (x, c, eo) => (x, lift c, eo)) (#namedE env)}
+ namedE = IM.map (fn (x, c, eo, s) => (x, lift c, eo, s)) (#namedE env)}
fun lookupCRel (env : env) n =
(List.nth (#relC env, n))
@@ -107,12 +107,12 @@ fun lookupERel (env : env) n =
(List.nth (#relE env, n))
handle Subscript => raise UnboundRel n
-fun pushENamed (env : env) x n t eo =
+fun pushENamed (env : env) x n t eo s =
{relC = #relC env,
namedC = #namedC env,
relE = #relE env,
- namedE = IM.insert (#namedE env, n, (x, t, eo))}
+ namedE = IM.insert (#namedE env, n, (x, t, eo, s))}
fun lookupENamed (env : env) n =
case IM.find (#namedE env, n) of
@@ -122,7 +122,7 @@ fun lookupENamed (env : env) n =
fun declBinds env (d, _) =
case d of
DCon (x, n, k, c) => pushCNamed env x n k (SOME c)
- | DVal (x, n, t, e) => pushENamed env x n t (SOME e)
- | DPage _ => env
+ | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
+ | DExport _ => env
end
diff --git a/src/core_print.sml b/src/core_print.sml
index be2f7387..b1cc9c2d 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -145,6 +145,13 @@ and p_name env (all as (c, _)) =
CName s => string s
| _ => p_con env all
+fun p_enamed env n =
+ (if !debug then
+ string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
+ else
+ string (#1 (E.lookupENamed env n)))
+ handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
+
fun p_exp' par env (e, _) =
case e of
EPrim p => Prim.p_t p
@@ -154,12 +161,7 @@ fun p_exp' par env (e, _) =
else
string (#1 (E.lookupERel env n)))
handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
- | ENamed n =>
- ((if !debug then
- string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
- else
- string (#1 (E.lookupENamed env n)))
- handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n))
+ | ENamed n => p_enamed env n
| EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
| EFfiApp (m, x, es) => box [string "FFI(",
string m,
@@ -255,7 +257,7 @@ fun p_decl env ((d, _) : decl) =
space,
p_con env c]
end
- | DVal (x, n, t, e) =>
+ | DVal (x, n, t, e, s) =>
let
val xp = if !debug then
box [string x,
@@ -268,6 +270,10 @@ fun p_decl env ((d, _) : decl) =
space,
xp,
space,
+ string "as",
+ space,
+ string s,
+ space,
string ":",
space,
p_con env t,
@@ -276,12 +282,9 @@ fun p_decl env ((d, _) : decl) =
space,
p_exp env e]
end
- | DPage (c, e) => box [string "page",
- p_con env c,
- space,
- string "=",
- space,
- p_exp env e]
+ | DExport n => box [string "export",
+ space,
+ p_enamed env n]
fun p_file env file =
let
diff --git a/src/core_util.sig b/src/core_util.sig
index 64cd671b..423b93b4 100644
--- a/src/core_util.sig
+++ b/src/core_util.sig
@@ -69,7 +69,7 @@ structure Exp : sig
RelC of string * Core.kind
| NamedC of string * int * Core.kind * Core.con option
| RelE of string * Core.con
- | NamedE of string * int * Core.con * Core.exp option
+ | NamedE of string * int * Core.con * Core.exp option * string
val mapfoldB : {kind : (Core.kind', 'state, 'abort) Search.mapfolder,
con : ('context, Core.con', 'state, 'abort) Search.mapfolderB,
diff --git a/src/core_util.sml b/src/core_util.sml
index df20ef9a..11d70de9 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -203,7 +203,7 @@ datatype binder =
RelC of string * kind
| NamedC of string * int * kind * con option
| RelE of string * con
- | NamedE of string * int * con * exp option
+ | NamedE of string * int * con * exp option * string
fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
let
@@ -375,18 +375,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
S.map2 (mfc ctx c,
fn c' =>
(DCon (x, n, k', c'), loc)))
- | DVal (x, n, t, e) =>
+ | DVal (x, n, t, e, s) =>
S.bind2 (mfc ctx t,
fn t' =>
S.map2 (mfe ctx e,
fn e' =>
- (DVal (x, n, t', e'), loc)))
- | DPage (c, e) =>
- S.bind2 (mfc ctx c,
- fn c' =>
- S.map2 (mfe ctx e,
- fn e' =>
- (DPage (c', e'), loc)))
+ (DVal (x, n, t', e', s), loc)))
+ | DExport _ => S.return2 dAll
in
mfd
end
@@ -426,8 +421,8 @@ fun mapfoldB (all as {bind, ...}) =
val ctx' =
case #1 d' of
DCon (x, n, k, c) => bind (ctx, NamedC (x, n, k, SOME c))
- | DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e))
- | DPage _ => ctx
+ | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
+ | DExport _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
diff --git a/src/corify.sml b/src/corify.sml
index 43acedfc..faeda0d1 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -362,6 +362,7 @@ fun corifyExp st (e, loc) =
| L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c,
{field = corifyCon st field, rest = corifyCon st rest}), loc)
| L.EFold k => (L'.EFold (corifyKind k), loc)
+ | L.EWrite e => (L'.EWrite (corifyExp st e), loc)
fun corifyDecl ((d, loc : EM.span), st) =
case d of
@@ -375,7 +376,7 @@ fun corifyDecl ((d, loc : EM.span), st) =
let
val (st, n) = St.bindVal st x n
in
- ([(L'.DVal (x, n, corifyCon st t, corifyExp st e), loc)], st)
+ ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, x), loc)], st)
end
| L.DSgn _ => ([], st)
@@ -427,19 +428,60 @@ fun corifyDecl ((d, loc : EM.span), st) =
end
| _ => raise Fail "Non-const signature for FFI structure")
- | L.DPage (c, e) =>
- let
- val c = corifyCon st c
- val e = corifyExp st e
-
- val dom = (L'.TRecord c, loc)
- val ran = (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)
- val e = (L'.EAbs ("vs", dom, ran,
- (L'.EWrite (L'.EApp (e, (L'.ERel 0, loc)), loc), loc)), loc)
-
- in
- ([(L'.DPage (c, e), loc)], st)
- end
+ | L.DExport (en, sgn, str) =>
+ (case #1 sgn of
+ L.SgnConst sgis =>
+ let
+ fun pathify (str, _) =
+ case str of
+ L.StrVar m => SOME (m, [])
+ | L.StrProj (str, s) =>
+ Option.map (fn (m, ms) => (m, ms @ [s])) (pathify str)
+ | _ => NONE
+ in
+ case pathify str of
+ NONE => (ErrorMsg.errorAt loc "Structure is too fancy to export";
+ ([], st))
+ | SOME (m, ms) =>
+ let
+ fun wrapSgi ((sgi, _), (wds, eds)) =
+ case sgi of
+ L.SgiVal (s, _, t as (L.TFun (dom, ran), _)) =>
+ (case (#1 dom, #1 ran) of
+ (L.TRecord _,
+ L.CApp ((L.CModProj (_, [], "xml"), _),
+ (L.TRecord (L.CRecord (_, [((L.CName "Html", _),
+ _)]), _), _))) =>
+ let
+ val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc)
+ val e = (L.EModProj (m, ms, s), loc)
+ val e = (L.EAbs ("vs", dom, ran,
+ (L.EWrite (L.EApp (e, (L.ERel 0, loc)), loc), loc)), loc)
+ in
+ ((L.DVal ("wrap_" ^ s, 0,
+ (L.TFun (dom, ran), loc),
+ e), loc) :: wds,
+ (fn st =>
+ case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of
+ L'.ENamed n => (L'.DExport n, loc)
+ | _ => raise Fail "Corify: Value to export didn't corify properly")
+ :: eds)
+ end
+ | _ => (wds, eds))
+ | _ => (wds, eds)
+
+ val (wds, eds) = foldl wrapSgi ([], []) sgis
+ val wrapper = (L.StrConst wds, loc)
+ val (ds, {inner, outer}) = corifyStr (wrapper, st)
+ val st = St.bindStr outer "wrapper" en inner
+
+ val ds = ds @ map (fn f => f st) eds
+ in
+ (ds, st)
+ end
+ end
+ | _ => raise Fail "Non-const signature for 'export'")
+
and corifyStr ((str, _), st) =
case str of
@@ -487,7 +529,7 @@ fun maxName ds = foldl (fn ((d, _), n) =>
| L.DSgn (_, n', _) => Int.max (n, n')
| L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str))
| L.DFfiStr (_, n', _) => Int.max (n, n')
- | L.DPage _ => n)
+ | L.DExport _ => n)
0 ds
and maxNameStr (str, _) =
diff --git a/src/elab.sml b/src/elab.sml
index 9fca4e13..d9d59d98 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -115,7 +115,7 @@ datatype decl' =
| DStr of string * int * sgn * str
| DFfiStr of string * int * sgn
| DConstraint of con * con
- | DPage of con * exp
+ | DExport of int * sgn * str
and str' =
StrConst of decl list
diff --git a/src/elab_env.sig b/src/elab_env.sig
index 0e43c9a7..83490b69 100644
--- a/src/elab_env.sig
+++ b/src/elab_env.sig
@@ -83,4 +83,6 @@ signature ELAB_ENV = sig
val projectStr : env -> { sgn : Elab.sgn, str : Elab.str, field : string } -> Elab.sgn option
val projectConstraints : env -> { sgn : Elab.sgn, str : Elab.str } -> (Elab.con * Elab.con) list option
+ val newNamed : unit -> int
+
end
diff --git a/src/elab_env.sml b/src/elab_env.sml
index be49d06f..b0550299 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -91,6 +91,14 @@ type env = {
val namedCounter = ref 0
+fun newNamed () =
+ let
+ val r = !namedCounter
+ in
+ namedCounter := r + 1;
+ r
+ end
+
val empty = {
renameC = SM.empty,
relC = [],
@@ -292,7 +300,7 @@ fun declBinds env (d, _) =
| DStr (x, n, sgn, _) => pushStrNamedAs env x n sgn
| DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn
| DConstraint _ => env
- | DPage _ => env
+ | DExport _ => env
fun sgiBinds env (sgi, _) =
case sgi of
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 51ff6a95..8d676f4a 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -450,12 +450,12 @@ fun p_decl env ((d, _) : decl) =
string "~",
space,
p_con env c2]
- | DPage (c, e) => box [string "page",
- p_con env c,
- space,
- string "=",
- space,
- p_exp env e]
+ | DExport (_, sgn, str) => box [string "export",
+ p_str env str,
+ space,
+ string ":",
+ space,
+ p_sgn env sgn]
and p_str env (str, _) =
case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 293e53ac..c14b2c60 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -511,7 +511,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
| DFfiStr (x, _, sgn) =>
bind (ctx, Str (x, sgn))
| DConstraint _ => ctx
- | DPage _ => ctx,
+ | DExport _ => ctx,
mfd ctx d)) ctx ds,
fn ds' => (StrConst ds', loc))
| StrVar _ => S.return2 strAll
@@ -572,12 +572,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
S.map2 (mfc ctx c2,
fn c2' =>
(DConstraint (c1', c2'), loc)))
- | DPage (c, e) =>
- S.bind2 (mfc ctx c,
- fn c' =>
- S.map2 (mfe ctx e,
- fn e' =>
- (DPage (c', e'), loc)))
+ | DExport (en, sgn, str) =>
+ S.bind2 (mfsg ctx sgn,
+ fn sgn' =>
+ S.map2 (mfst ctx str,
+ fn str' =>
+ (DExport (en, sgn', str'), loc)))
in
mfd
end
diff --git a/src/elaborate.sml b/src/elaborate.sml
index faa19ec4..81b3e8c4 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1599,7 +1599,7 @@ fun sgiOfDecl (d, loc) =
| L'.DStr (x, n, sgn, _) => SOME (L'.SgiStr (x, n, sgn), loc)
| L'.DFfiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, sgn), loc)
| L'.DConstraint cs => SOME (L'.SgiConstraint cs, loc)
- | L'.DPage _ => NONE
+ | L'.DExport _ => NONE
fun sgiBindsD (env, denv) (sgi, _) =
case sgi of
@@ -1929,27 +1929,41 @@ fun elabDecl ((d, loc), (env, denv, gs)) =
([], (env, denv, []))
end
- | L.DPage e =>
+ | L.DExport str =>
let
- val basis =
- case E.lookupStr env "Basis" of
- NONE => raise Fail "elabExp: Unbound Basis"
- | SOME (n, _) => n
-
- val (e', t, gs1) = elabExp (env, denv) e
-
- val k = (L'.KRecord (L'.KType, loc), loc)
- val vs = cunif (loc, k)
-
- val c = (L'.TFun ((L'.TRecord vs, loc),
- (L'.CApp ((L'.CModProj (basis, [], "xml"), loc),
- (L'.CRecord ((L'.KUnit, loc),
- [((L'.CName "Html", loc),
- (L'.CUnit, loc))]), loc)), loc)), loc)
+ val (str', sgn, gs) = elabStr (env, denv) str
- val gs2 = checkCon (env, denv) e' t c
+ val sgn =
+ case #1 (hnormSgn env sgn) of
+ L'.SgnConst sgis =>
+ let
+ fun doOne (all as (sgi, _)) =
+ case sgi of
+ L'.SgiVal (x, n, t) =>
+ (case hnormCon (env, denv) t of
+ ((L'.TFun (dom, ran), _), []) =>
+ (case (hnormCon (env, denv) dom, hnormCon (env, denv) ran) of
+ (((L'.TRecord domR, _), []),
+ ((L'.CApp (tf, ranR), _), [])) =>
+ (case hnormCon (env, denv) ranR of
+ (ranR, []) =>
+ (case (hnormCon (env, denv) domR, hnormCon (env, denv) ranR) of
+ ((domR, []), (ranR, [])) =>
+ (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR, loc),
+ (L'.CApp (tf,
+ (L'.TRecord ranR, loc)), loc)),
+ loc)), loc)
+ | _ => all)
+ | _ => all)
+ | _ => all)
+ | _ => all)
+ | _ => all
+ in
+ (L'.SgnConst (map doOne sgis), loc)
+ end
+ | _ => sgn
in
- ([(L'.DPage (vs, e'), loc)], (env, denv, gs1 @ gs2))
+ ([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs))
end
and elabStr (env, denv) (str, loc) =
diff --git a/src/expl.sml b/src/expl.sml
index bf40a511..d6ceb35b 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -73,6 +73,8 @@ datatype exp' =
| EField of exp * con * { field : con, rest : con }
| EFold of kind
+ | EWrite of exp
+
withtype exp = exp' located
datatype sgn_item' =
@@ -98,7 +100,7 @@ datatype decl' =
| DSgn of string * int * sgn
| DStr of string * int * sgn * str
| DFfiStr of string * int * sgn
- | DPage of con * exp
+ | DExport of int * sgn * str
and str' =
StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index 93d21c31..b9c95605 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -243,7 +243,7 @@ fun declBinds env (d, _) =
| DSgn (x, n, sgn) => pushSgnNamed env x n sgn
| DStr (x, n, sgn, _) => pushStrNamed env x n sgn
| DFfiStr (x, n, sgn) => pushStrNamed env x n sgn
- | DPage _ => env
+ | DExport _ => env
fun sgiBinds env (sgi, _) =
case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index c891528f..1e8f514a 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -92,7 +92,8 @@ fun p_con' par env (c, _) =
handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
| CModProj (m1, ms, x) =>
let
- val (m1x, sgn) = E.lookupStrNamed env m1
+ val m1x = #1 (E.lookupStrNamed env m1)
+ handle E.UnboundNamed _ => "UNBOUND"
val m1s = if !debug then
m1x ^ "__" ^ Int.toString m1
@@ -237,6 +238,10 @@ fun p_exp' par env (e, _) =
p_con' true env c]
| EFold _ => string "fold"
+ | EWrite e => box [string "write(",
+ p_exp env e,
+ string ")"]
+
and p_exp env = p_exp' false env
fun p_named x n =
@@ -392,12 +397,13 @@ fun p_decl env ((d, _) : decl) =
string ":",
space,
p_sgn env sgn]
- | DPage (c, e) => box [string "page",
- p_con env c,
- space,
- string "=",
- space,
- p_exp env e]
+ | DExport (_, sgn, str) => box [string "export",
+ space,
+ p_str env str,
+ space,
+ string ":",
+ space,
+ p_sgn env sgn]
and p_str env (str, _) =
case str of
diff --git a/src/expl_util.sml b/src/expl_util.sml
index 57498fde..c4f1b1d7 100644
--- a/src/expl_util.sml
+++ b/src/expl_util.sml
@@ -271,6 +271,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
S.map2 (mfk k,
fn k' =>
(EFold k', loc))
+
+ | EWrite e =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (EWrite e', loc))
in
mfe
end
diff --git a/src/explify.sml b/src/explify.sml
index 8c6cc9f5..ecca21f8 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -116,7 +116,7 @@ fun explifyDecl (d, loc : EM.span) =
| L.DStr (x, n, sgn, str) => SOME (L'.DStr (x, n, explifySgn sgn, explifyStr str), loc)
| L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc)
| L.DConstraint (c1, c2) => NONE
- | L.DPage (c, e) => SOME (L'.DPage (explifyCon c, explifyExp e), loc)
+ | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc)
and explifyStr (str, loc) =
case str of
diff --git a/src/flat.sml b/src/flat.sml
deleted file mode 100644
index 2b63bc24..00000000
--- a/src/flat.sml
+++ /dev/null
@@ -1,72 +0,0 @@
-(* Copyright (c) 2008, Adam Chlipala
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * - Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- * - Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- * - The names of contributors may not be used to endorse or promote products
- * derived from this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
- * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
- * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
- * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *)
-
-structure Flat = struct
-
-type 'a located = 'a ErrorMsg.located
-
-datatype typ' =
- TTop
- | TFun of typ * typ
- | TCode of typ * typ
- | TRecord of (string * typ) list
- | TNamed of int
- | TFfi of string * string
-
-withtype typ = typ' located
-
-datatype exp' =
- EPrim of Prim.t
- | ERel of int
- | ENamed of int
- | EFfi of string * string
- | EFfiApp of string * string * exp list
- | ECode of int
- | EApp of exp * exp
-
- | ERecord of (string * exp * typ) list
- | EField of exp * string
-
- | ELet of (string * typ * exp) list * exp
-
- | EStrcat of exp * exp
-
- | EWrite of exp
- | ESeq of exp * exp
-
-withtype exp = exp' located
-
-datatype decl' =
- DVal of string * int * typ * exp
- | DFun of int * string * typ * typ * exp
- | DPage of (string * typ) list * exp
-
-withtype decl = decl' located
-
-type file = decl list
-
-end
diff --git a/src/flat_env.sig b/src/flat_env.sig
deleted file mode 100644
index 9fc1fc57..00000000
--- a/src/flat_env.sig
+++ /dev/null
@@ -1,53 +0,0 @@
-(* Copyright (c) 2008, Adam Chlipala
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * - Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- * - Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- * - The names of contributors may not be used to endorse or promote products
- * derived from this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
- * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
- * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
- * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *)
-
-signature FLAT_ENV = sig
-
- type env
-
- val empty : env
-
- exception UnboundRel of int
- exception UnboundNamed of int
- exception UnboundF of int
-
- val pushTNamed : env -> string -> int -> Flat.typ option -> env
- val lookupTNamed : env -> int -> string * Flat.typ option
-
- val pushERel : env -> string -> Flat.typ -> env
- val lookupERel : env -> int -> string * Flat.typ
- val listERels : env -> (string * Flat.typ) list
-
- val pushENamed : env -> string -> int -> Flat.typ -> env
- val lookupENamed : env -> int -> string * Flat.typ
-
- val pushF : env -> int -> string -> Flat.typ -> Flat.typ -> env
- val lookupF : env -> int -> string * Flat.typ * Flat.typ
-
- val declBinds : env -> Flat.decl -> env
-
-end
diff --git a/src/flat_env.sml b/src/flat_env.sml
deleted file mode 100644
index d86b6c97..00000000
--- a/src/flat_env.sml
+++ /dev/null
@@ -1,116 +0,0 @@
-(* Copyright (c) 2008, Adam Chlipala
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * - Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- * - Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- * - The names of contributors may not be used to endorse or promote products
- * derived from this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
- * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
- * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
- * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *)
-
-structure FlatEnv :> FLAT_ENV = struct
-
-open Flat
-
-structure IM = IntBinaryMap
-
-
-exception UnboundRel of int
-exception UnboundNamed of int
-exception UnboundF of int
-
-type env = {
- namedT : (string * typ option) IM.map,
-
- relE : (string * typ) list,
- namedE : (string * typ) IM.map,
-
- F : (string * typ * typ) IM.map
-}
-
-val empty = {
- namedT = IM.empty,
-
- relE = [],
- namedE = IM.empty,
-
- F = IM.empty
-}
-
-fun pushTNamed (env : env) x n co =
- {namedT = IM.insert (#namedT env, n, (x, co)),
-
- relE = #relE env,
- namedE = #namedE env,
-
- F = #F env}
-
-fun lookupTNamed (env : env) n =
- case IM.find (#namedT env, n) of
- NONE => raise UnboundNamed n
- | SOME x => x
-
-fun pushERel (env : env) x t =
- {namedT = #namedT env,
-
- relE = (x, t) :: #relE env,
- namedE = #namedE env,
-
- F = #F env}
-
-fun lookupERel (env : env) n =
- (List.nth (#relE env, n))
- handle Subscript => raise UnboundRel n
-
-fun listERels (env : env) = #relE env
-
-fun pushENamed (env : env) x n t =
- {namedT = #namedT env,
-
- relE = #relE env,
- namedE = IM.insert (#namedE env, n, (x, t)),
-
- F = #F env}
-
-fun lookupENamed (env : env) n =
- case IM.find (#namedE env, n) of
- NONE => raise UnboundNamed n
- | SOME x => x
-
-fun pushF (env : env) n x dom ran =
- {namedT = #namedT env,
-
- relE = #relE env,
- namedE = #namedE env,
-
- F = IM.insert (#F env, n, (x, dom, ran))}
-
-fun lookupF (env : env) n =
- case IM.find (#F env, n) of
- NONE => raise UnboundF n
- | SOME x => x
-
-fun declBinds env (d, _) =
- case d of
- DVal (x, n, t, _) => pushENamed env x n t
- | DFun (n, x, dom, ran, _) => pushF env n x dom ran
- | DPage _ => env
-
-end
diff --git a/src/flat_print.sig b/src/flat_print.sig
deleted file mode 100644
index 627bfee9..00000000
--- a/src/flat_print.sig
+++ /dev/null
@@ -1,37 +0,0 @@
-(* Copyright (c) 2008, Adam Chlipala
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * - Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- * - Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- * - The names of contributors may not be used to endorse or promote products
- * derived from this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
- * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
- * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
- * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *)
-
-(* Pretty-printing Laconic/Web flat-code language *)
-
-signature FLAT_PRINT = sig
- val p_typ : FlatEnv.env -> Flat.typ Print.printer
- val p_exp : FlatEnv.env -> Flat.exp Print.printer
- val p_decl : FlatEnv.env -> Flat.decl Print.printer
- val p_file : FlatEnv.env -> Flat.file Print.printer
-
- val debug : bool ref
-end
diff --git a/src/flat_print.sml b/src/flat_print.sml
deleted file mode 100644
index f94614b4..00000000
--- a/src/flat_print.sml
+++ /dev/null
@@ -1,236 +0,0 @@
-(* Copyright (c) 2008, Adam Chlipala
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * - Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- * - Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- * - The names of contributors may not be used to endorse or promote products
- * derived from this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
- * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
- * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
- * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *)
-
-(* Pretty-printing flat-code Laconic/Web *)
-
-structure FlatPrint :> FLAT_PRINT = struct
-
-open Print.PD
-open Print
-
-open Flat
-
-structure E = FlatEnv
-
-val debug = ref false
-
-val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
-
-fun p_typ' par env (t, _) =
- case t of
- TTop => string "?"
- | TFun (t1, t2) => parenIf par (box [p_typ' true env t1,
- space,
- string "->",
- space,
- p_typ env t2])
- | TCode (t1, t2) => parenIf par (box [p_typ' true env t1,
- space,
- string "-->",
- space,
- p_typ env t2])
- | TRecord xcs => box [string "{",
- p_list (fn (x, t) =>
- box [string x,
- space,
- string ":",
- space,
- p_typ env t]) xcs,
- string "}"]
- | TNamed n =>
- if !debug then
- string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n)
- else
- string (#1 (E.lookupTNamed env n))
- | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
-
-and p_typ env = p_typ' false env
-
-fun p_exp' par env (e, _) =
- case e of
- EPrim p => Prim.p_t p
- | ERel n =>
- ((if !debug then
- string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
- else
- string (#1 (E.lookupERel env n)))
- handle E.UnboundRel _ => string ("UNBOUND" ^ Int.toString n))
- | ENamed n =>
- if !debug then
- string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
- else
- string (#1 (E.lookupENamed env n))
- | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
- | EFfiApp (m, x, es) => box [string "FFI(",
- string m,
- string ".",
- string x,
- string "(",
- p_list (p_exp env) es,
- string "))"]
- | ECode n => string ("code$" ^ Int.toString n)
- | EApp (e1, e2) => parenIf par (box [p_exp env e1,
- space,
- p_exp' true env e2])
-
- | ERecord xes => box [string "{",
- p_list (fn (x, e, _) =>
- box [string x,
- space,
- string "=",
- space,
- p_exp env e]) xes,
- string "}"]
- | EField (e, x) =>
- box [p_exp' true env e,
- string ".",
- string x]
-
- | ELet (xes, e) =>
- let
- val (env, pps) = foldl (fn ((x, _, e), (env, pps)) =>
- (E.pushERel env x dummyTyp,
- List.revAppend ([space,
- string "val",
- space,
- string x,
- space,
- string "=",
- space,
- p_exp env e],
- pps)))
- (env, []) xes
- in
- box [string "let",
- space,
- box (rev pps),
- space,
- string "in",
- space,
- p_exp env e,
- space,
- string "end"]
- end
-
- | EStrcat (e1, e2) => box [p_exp' true env e1,
- space,
- string "^",
- space,
- p_exp' true env e2]
-
- | EWrite e => box [string "write(",
- p_exp env e,
- string ")"]
-
- | ESeq (e1, e2) => box [p_exp env e1,
- string ";",
- space,
- p_exp env e2]
-
-and p_exp env = p_exp' false env
-
-fun p_decl env ((d, _) : decl) =
- case d of
- DVal (x, n, t, e) =>
- let
- val xp = if !debug then
- box [string x,
- string "__",
- string (Int.toString n)]
- else
- string x
- in
- box [string "val",
- space,
- xp,
- space,
- string ":",
- space,
- p_typ env t,
- space,
- string "=",
- space,
- p_exp env e]
-
- end
- | DFun (n, x, dom, ran, e) =>
- let
- val xp = if !debug then
- box [string x,
- string "__",
- string (Int.toString n)]
- else
- string x
- in
- box [string "fun",
- space,
- string "code$",
- string (Int.toString n),
- space,
- string "(",
- xp,
- space,
- string ":",
- space,
- p_typ env dom,
- string ")",
- space,
- string ":",
- space,
- p_typ env ran,
- space,
- string "=",
- space,
- p_exp (E.pushERel env x dom) e]
-
- end
-
- | DPage (xcs, e) => box [string "page",
- string "[",
- p_list (fn (x, t) =>
- box [string x,
- space,
- string ":",
- space,
- p_typ env t]) xcs,
- string "]",
- space,
- string "=",
- space,
- p_exp env e]
-
-fun p_file env file =
- let
- val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
- (p_decl env d,
- E.declBinds env d))
- env file
- in
- p_list_sep newline (fn x => x) pds
- end
-
-end
diff --git a/src/flat_util.sig b/src/flat_util.sig
deleted file mode 100644
index ff7edcd1..00000000
--- a/src/flat_util.sig
+++ /dev/null
@@ -1,125 +0,0 @@
-(* Copyright (c) 2008, Adam Chlipala
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * - Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- * - Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- * - The names of contributors may not be used to endorse or promote products
- * derived from this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
- * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
- * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
- * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *)
-
-signature FLAT_UTIL = sig
-
-structure Typ : sig
- val compare : Flat.typ * Flat.typ -> order
- val sortFields : (string * Flat.typ) list -> (string * Flat.typ) list
-
- val mapfold : (Flat.typ', 'state, 'abort) Search.mapfolder
- -> (Flat.typ, 'state, 'abort) Search.mapfolder
-
- val map : (Flat.typ' -> Flat.typ')
- -> Flat.typ -> Flat.typ
-
- val fold : (Flat.typ' * 'state -> 'state)
- -> 'state -> Flat.typ -> 'state
-
- val exists : (Flat.typ' -> bool) -> Flat.typ -> bool
-end
-
-structure Exp : sig
- datatype binder =
- NamedT of string * int * Flat.typ option
- | RelE of string * Flat.typ
- | NamedE of string * int * Flat.typ * Flat.exp option
-
- val mapfoldB : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder,
- exp : ('typtext, Flat.exp', 'state, 'abort) Search.mapfolderB,
- bind : 'typtext * binder -> 'typtext}
- -> ('typtext, Flat.exp, 'state, 'abort) Search.mapfolderB
- val mapfold : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder,
- exp : (Flat.exp', 'state, 'abort) Search.mapfolder}
- -> (Flat.exp, 'state, 'abort) Search.mapfolder
-
- val map : {typ : Flat.typ' -> Flat.typ',
- exp : Flat.exp' -> Flat.exp'}
- -> Flat.exp -> Flat.exp
- val mapB : {typ : Flat.typ' -> Flat.typ',
- exp : 'typtext -> Flat.exp' -> Flat.exp',
- bind : 'typtext * binder -> 'typtext}
- -> 'typtext -> (Flat.exp -> Flat.exp)
-
- val fold : {typ : Flat.typ' * 'state -> 'state,
- exp : Flat.exp' * 'state -> 'state}
- -> 'state -> Flat.exp -> 'state
-
- val exists : {typ : Flat.typ' -> bool,
- exp : Flat.exp' -> bool} -> Flat.exp -> bool
-end
-
-structure Decl : sig
- datatype binder = datatype Exp.binder
-
- val mapfoldB : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder,
- exp : ('typtext, Flat.exp', 'state, 'abort) Search.mapfolderB,
- decl : ('typtext, Flat.decl', 'state, 'abort) Search.mapfolderB,
- bind : 'typtext * binder -> 'typtext}
- -> ('typtext, Flat.decl, 'state, 'abort) Search.mapfolderB
- val mapfold : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder,
- exp : (Flat.exp', 'state, 'abort) Search.mapfolder,
- decl : (Flat.decl', 'state, 'abort) Search.mapfolder}
- -> (Flat.decl, 'state, 'abort) Search.mapfolder
-
- val fold : {typ : Flat.typ' * 'state -> 'state,
- exp : Flat.exp' * 'state -> 'state,
- decl : Flat.decl' * 'state -> 'state}
- -> 'state -> Flat.decl -> 'state
-end
-
-structure File : sig
- datatype binder =
- NamedT of string * int * Flat.typ option
- | RelE of string * Flat.typ
- | NamedE of string * int * Flat.typ * Flat.exp option
- | F of int * string * Flat.typ * Flat.typ * Flat.exp
-
- val mapfoldB : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder,
- exp : ('typtext, Flat.exp', 'state, 'abort) Search.mapfolderB,
- decl : ('typtext, Flat.decl', 'state, 'abort) Search.mapfolderB,
- bind : 'typtext * binder -> 'typtext}
- -> ('typtext, Flat.file, 'state, 'abort) Search.mapfolderB
-
- val mapfold : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder,
- exp : (Flat.exp', 'state, 'abort) Search.mapfolder,
- decl : (Flat.decl', 'state, 'abort) Search.mapfolder}
- -> (Flat.file, 'state, 'abort) Search.mapfolder
-
- val mapB : {typ : Flat.typ' -> Flat.typ',
- exp : 'typtext -> Flat.exp' -> Flat.exp',
- decl : 'typtext -> Flat.decl' -> Flat.decl',
- bind : 'typtext * binder -> 'typtext}
- -> 'typtext -> Flat.file -> Flat.file
-
- val fold : {typ : Flat.typ' * 'state -> 'state,
- exp : Flat.exp' * 'state -> 'state,
- decl : Flat.decl' * 'state -> 'state}
- -> 'state -> Flat.file -> 'state
-end
-
-end
diff --git a/src/flat_util.sml b/src/flat_util.sml
deleted file mode 100644
index 7e52381d..00000000
--- a/src/flat_util.sml
+++ /dev/null
@@ -1,376 +0,0 @@
-(* Copyright (c) 2008, Adam Chlipala
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * - Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- * - Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- * - The names of contributors may not be used to endorse or promote products
- * derived from this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
- * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
- * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
- * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *)
-
-structure FlatUtil :> FLAT_UTIL = struct
-
-open Flat
-
-structure S = Search
-
-structure Typ = struct
-
-fun join (o1, o2) =
- case o1 of
- EQUAL => o2 ()
- | v => v
-
-fun joinL f (os1, os2) =
- case (os1, os2) of
- (nil, nil) => EQUAL
- | (nil, _) => LESS
- | (h1 :: t1, h2 :: t2) =>
- join (f (h1, h2), fn () => joinL f (t1, t2))
- | (_ :: _, nil) => GREATER
-
-fun compare ((t1, _), (t2, _)) =
- case (t1, t2) of
- (TTop, TTop) => EQUAL
- | (TFun (d1, r1), TFun (d2, r2)) =>
- join (compare (d1, d2), fn () => compare (r1, r2))
- | (TCode (d1, r1), TCode (d2, r2)) =>
- join (compare (d1, d2), fn () => compare (r1, r2))
- | (TRecord xts1, TRecord xts2) =>
- let
- val xts1 = sortFields xts1
- val xts2 = sortFields xts2
- in
- joinL compareFields (xts1, xts2)
- end
- | (TNamed n1, TNamed n2) => Int.compare (n1, n2)
- | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
-
- | (TTop, _) => LESS
- | (_, TTop) => GREATER
-
- | (TFun _, _) => LESS
- | (_, TFun _) => GREATER
-
- | (TCode _, _) => LESS
- | (_, TCode _) => GREATER
-
- | (TRecord _, _) => LESS
- | (_, TRecord _) => GREATER
-
- | (TNamed _, _) => LESS
- | (_, TNamed _) => GREATER
-
-and compareFields ((x1, t1), (x2, t2)) =
- join (String.compare (x1, x2),
- fn () => compare (t1, t2))
-
-and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts
-
-fun mapfold fc =
- let
- fun mft c acc =
- S.bindP (mft' c acc, fc)
-
- and mft' (cAll as (c, loc)) =
- case c of
- TTop => S.return2 cAll
- | TFun (t1, t2) =>
- S.bind2 (mft t1,
- fn t1' =>
- S.map2 (mft t2,
- fn t2' =>
- (TFun (t1', t2'), loc)))
- | TCode (t1, t2) =>
- S.bind2 (mft t1,
- fn t1' =>
- S.map2 (mft t2,
- fn t2' =>
- (TCode (t1', t2'), loc)))
- | TRecord xts =>
- S.map2 (ListUtil.mapfold (fn (x, t) =>
- S.map2 (mft t,
- fn t' =>
- (x, t')))
- xts,
- fn xts' => (TRecord xts', loc))
- | TNamed _ => S.return2 cAll
- | TFfi _ => S.return2 cAll
- in
- mft
- end
-
-fun map typ c =
- case mapfold (fn c => fn () => S.Continue (typ c, ())) c () of
- S.Return () => raise Fail "Flat_util.Typ.map"
- | S.Continue (c, ()) => c
-
-fun fold typ s c =
- case mapfold (fn c => fn s => S.Continue (c, typ (c, s))) c s of
- S.Continue (_, s) => s
- | S.Return _ => raise Fail "FlatUtil.Typ.fold: Impossible"
-
-fun exists typ k =
- case mapfold (fn c => fn () =>
- if typ c then
- S.Return ()
- else
- S.Continue (c, ())) k () of
- S.Return _ => true
- | S.Continue _ => false
-
-end
-
-structure Exp = struct
-
-datatype binder =
- NamedT of string * int * typ option
- | RelE of string * typ
- | NamedE of string * int * typ * exp option
-
-fun mapfoldB {typ = fc, exp = fe, bind} =
- let
- val mft = Typ.mapfold fc
-
- fun mfe ctx e acc =
- S.bindP (mfe' ctx e acc, fe ctx)
-
- and mfe' ctx (eAll as (e, loc)) =
- case e of
- EPrim _ => S.return2 eAll
- | ERel _ => S.return2 eAll
- | ENamed _ => S.return2 eAll
- | EFfi _ => S.return2 eAll
- | EFfiApp (m, x, es) =>
- S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es,
- fn es' =>
- (EFfiApp (m, x, es'), loc))
- | ECode _ => S.return2 eAll
- | EApp (e1, e2) =>
- S.bind2 (mfe ctx e1,
- fn e1' =>
- S.map2 (mfe ctx e2,
- fn e2' =>
- (EApp (e1', e2'), loc)))
-
- | ERecord xes =>
- S.map2 (ListUtil.mapfold (fn (x, e, t) =>
- S.bind2 (mfe ctx e,
- fn e' =>
- S.map2 (mft t,
- fn t' =>
- (x, e', t'))))
- xes,
- fn xes' =>
- (ERecord xes', loc))
- | EField (e, x) =>
- S.map2 (mfe ctx e,
- fn e' =>
- (EField (e', x), loc))
-
- | ELet (xes, e) =>
- S.bind2 (ListUtil.mapfold (fn (x, t, e) =>
- S.bind2 (mft t,
- fn t' =>
- S.map2 (mfe ctx e,
- fn e' =>
- (x, t', e'))))
- xes,
- fn xes' =>
- S.map2 (mfe ctx e,
- fn e' =>
- (ELet (xes', e'), loc)))
-
- | EStrcat (e1, e2) =>
- S.bind2 (mfe ctx e1,
- fn e1' =>
- S.map2 (mfe ctx e2,
- fn e2' =>
- (EStrcat (e1', e2'), loc)))
-
- | EWrite e =>
- S.map2 (mfe ctx e,
- fn e' =>
- (EWrite e', loc))
-
- | ESeq (e1, e2) =>
- S.bind2 (mfe ctx e1,
- fn e1' =>
- S.map2 (mfe ctx e2,
- fn e2' =>
- (ESeq (e1', e2'), loc)))
- in
- mfe
- end
-
-fun mapfold {typ = fc, exp = fe} =
- mapfoldB {typ = fc,
- exp = fn () => fe,
- bind = fn ((), _) => ()} ()
-
-fun mapB {typ, exp, bind} ctx e =
- case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
- exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
- bind = bind} ctx e () of
- S.Continue (e, ()) => e
- | S.Return _ => raise Fail "FlatUtil.Exp.mapB: Impossible"
-
-fun map {typ, exp} e =
- case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
- exp = fn e => fn () => S.Continue (exp e, ())} e () of
- S.Return () => raise Fail "Flat_util.Exp.map"
- | S.Continue (e, ()) => e
-
-fun fold {typ, exp} s e =
- case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
- exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of
- S.Continue (_, s) => s
- | S.Return _ => raise Fail "FlatUtil.Exp.fold: Impossible"
-
-fun exists {typ, exp} k =
- case mapfold {typ = fn c => fn () =>
- if typ c then
- S.Return ()
- else
- S.Continue (c, ()),
- exp = fn e => fn () =>
- if exp e then
- S.Return ()
- else
- S.Continue (e, ())} k () of
- S.Return _ => true
- | S.Continue _ => false
-
-end
-
-structure Decl = struct
-
-datatype binder = datatype Exp.binder
-
-fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
- let
- val mft = Typ.mapfold fc
-
- val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind}
-
- fun mfd ctx d acc =
- S.bindP (mfd' ctx d acc, fd ctx)
-
- and mfd' ctx (dAll as (d, loc)) =
- case d of
- DVal (x, n, t, e) =>
- S.bind2 (mft t,
- fn t' =>
- S.map2 (mfe ctx e,
- fn e' =>
- (DVal (x, n, t', e'), loc)))
- | DFun (n, x, dom, ran, e) =>
- S.bind2 (mft dom,
- fn dom' =>
- S.bind2 (mft ran,
- fn ran' =>
- S.map2 (mfe ctx e,
- fn e' =>
- (DFun (n, x, dom', ran', e'), loc))))
- | DPage (xts, e) =>
- S.bind2 (ListUtil.mapfold (fn (x, t) =>
- S.map2 (mft t,
- fn t' =>
- (x, t'))) xts,
- fn xts' =>
- S.map2 (mfe ctx e,
- fn e' =>
- (DPage (xts', e'), loc)))
- in
- mfd
- end
-
-fun mapfold {typ = fc, exp = fe, decl = fd} =
- mapfoldB {typ = fc,
- exp = fn () => fe,
- decl = fn () => fd,
- bind = fn ((), _) => ()} ()
-
-fun fold {typ, exp, decl} s d =
- case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
- exp = fn e => fn s => S.Continue (e, exp (e, s)),
- decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
- S.Continue (_, s) => s
- | S.Return _ => raise Fail "FlatUtil.Decl.fold: Impossible"
-
-end
-
-structure File = struct
-
-datatype binder =
- NamedT of string * int * typ option
- | RelE of string * typ
- | NamedE of string * int * typ * exp option
- | F of int * string * Flat.typ * Flat.typ * Flat.exp
-
-fun mapfoldB (all as {bind, ...}) =
- let
- val mfd = Decl.mapfoldB all
-
- fun mff ctx ds =
- case ds of
- nil => S.return2 nil
- | d :: ds' =>
- S.bind2 (mfd ctx d,
- fn d' =>
- let
- val ctx' =
- case #1 d' of
- DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e))
- | DFun v => bind (ctx, F v)
- | DPage _ => ctx
- in
- S.map2 (mff ctx' ds',
- fn ds' =>
- d' :: ds')
- end)
- in
- mff
- end
-
-fun mapfold {typ = fc, exp = fe, decl = fd} =
- mapfoldB {typ = fc,
- exp = fn () => fe,
- decl = fn () => fd,
- bind = fn ((), _) => ()} ()
-
-fun mapB {typ, exp, decl, bind} ctx ds =
- case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
- exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
- decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
- bind = bind} ctx ds () of
- S.Continue (ds, ()) => ds
- | S.Return _ => raise Fail "FlatUtil.File.mapB: Impossible"
-
-fun fold {typ, exp, decl} s d =
- case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
- exp = fn e => fn s => S.Continue (e, exp (e, s)),
- decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
- S.Continue (_, s) => s
- | S.Return _ => raise Fail "FlatUtil.File.fold: Impossible"
-
-end
-
-end
diff --git a/src/lacweb.grm b/src/lacweb.grm
index 6e71721f..914f3551 100644
--- a/src/lacweb.grm
+++ b/src/lacweb.grm
@@ -49,7 +49,7 @@ fun uppercaseFirst "" = ""
| ARROW | LARROW | DARROW
| FN | PLUSPLUS | DOLLAR | TWIDDLE
| STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN
- | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | PAGE
+ | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT
| XML_BEGIN of string | XML_END
| NOTAGS of string
@@ -147,7 +147,7 @@ decl : CON SYMBOL EQ cexp (DCon (SYMBOL, NONE, cexp), s (CONleft,
[] => raise Fail "Impossible mpath parse [3]"
| m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright)))
| CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
- | PAGE eexp (DPage eexp, s (PAGEleft, eexpright))
+ | EXPORT spath (DExport spath, s (EXPORTleft, spathright))
sgn : sgntm (sgntm)
| FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
diff --git a/src/lacweb.lex b/src/lacweb.lex
index 4856bdf2..41163a61 100644
--- a/src/lacweb.lex
+++ b/src/lacweb.lex
@@ -264,7 +264,7 @@ notags = [^<{\n]+;
<INITIAL> "open" => (Tokens.OPEN (pos yypos, pos yypos + size yytext));
<INITIAL> "constraint"=> (Tokens.CONSTRAINT (pos yypos, pos yypos + size yytext));
<INITIAL> "constraints"=> (Tokens.CONSTRAINTS (pos yypos, pos yypos + size yytext));
-<INITIAL> "page" => (Tokens.PAGE (pos yypos, pos yypos + size yytext));
+<INITIAL> "export" => (Tokens.EXPORT (pos yypos, pos yypos + size yytext));
<INITIAL> "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
<INITIAL> "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext));
diff --git a/src/mono.sml b/src/mono.sml
index 3e9e2638..913650fa 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -58,8 +58,8 @@ datatype exp' =
withtype exp = exp' located
datatype decl' =
- DVal of string * int * typ * exp
- | DPage of (string * typ) list * exp
+ DVal of string * int * typ * exp * string
+ | DExport of int
withtype decl = decl' located
diff --git a/src/mono_env.sig b/src/mono_env.sig
index f0d0b0a6..e1e78b48 100644
--- a/src/mono_env.sig
+++ b/src/mono_env.sig
@@ -40,8 +40,8 @@ signature MONO_ENV = sig
val pushERel : env -> string -> Mono.typ -> env
val lookupERel : env -> int -> string * Mono.typ
- val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> env
- val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option
+ val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> string -> env
+ val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option * string
val declBinds : env -> Mono.decl -> env
diff --git a/src/mono_env.sml b/src/mono_env.sml
index cfe7b159..9af80d23 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -39,7 +39,7 @@ type env = {
namedT : (string * typ option) IM.map,
relE : (string * typ) list,
- namedE : (string * typ * exp option) IM.map
+ namedE : (string * typ * exp option * string) IM.map
}
val empty = {
@@ -70,11 +70,11 @@ fun lookupERel (env : env) n =
(List.nth (#relE env, n))
handle Subscript => raise UnboundRel n
-fun pushENamed (env : env) x n t eo =
+fun pushENamed (env : env) x n t eo s =
{namedT = #namedT env,
relE = #relE env,
- namedE = IM.insert (#namedE env, n, (x, t, eo))}
+ namedE = IM.insert (#namedE env, n, (x, t, eo, s))}
fun lookupENamed (env : env) n =
case IM.find (#namedE env, n) of
@@ -83,7 +83,7 @@ fun lookupENamed (env : env) n =
fun declBinds env (d, _) =
case d of
- DVal (x, n, t, e) => pushENamed env x n t (SOME e)
- | DPage _ => env
+ DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
+ | DExport _ => env
end
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 3797aefa..a936c146 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -62,6 +62,12 @@ fun p_typ' par env (t, _) =
and p_typ env = p_typ' false env
+fun p_enamed env n =
+ if !debug then
+ string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
+ else
+ string (#1 (E.lookupENamed env n))
+
fun p_exp' par env (e, _) =
case e of
EPrim p => Prim.p_t p
@@ -70,11 +76,8 @@ fun p_exp' par env (e, _) =
string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
else
string (#1 (E.lookupERel env n))
- | ENamed n =>
- if !debug then
- string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
- else
- string (#1 (E.lookupENamed env n))
+ | ENamed n => p_enamed env n
+
| EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
| EFfiApp (m, x, es) => box [string "FFI(",
string m,
@@ -131,7 +134,7 @@ and p_exp env = p_exp' false env
fun p_decl env ((d, _) : decl) =
case d of
- DVal (x, n, t, e) =>
+ DVal (x, n, t, e, s) =>
let
val xp = if !debug then
box [string x,
@@ -144,6 +147,10 @@ fun p_decl env ((d, _) : decl) =
space,
xp,
space,
+ string "as",
+ space,
+ string s,
+ space,
string ":",
space,
p_typ env t,
@@ -152,19 +159,10 @@ fun p_decl env ((d, _) : decl) =
space,
p_exp env e]
end
- | DPage (xcs, e) => box [string "page",
- string "[",
- p_list (fn (x, t) =>
- box [string x,
- space,
- string ":",
- space,
- p_typ env t]) xcs,
- string "]",
- space,
- string "=",
- space,
- p_exp env e]
+
+ | DExport n => box [string "export",
+ space,
+ p_enamed env n]
fun p_file env file =
let
diff --git a/src/mono_util.sig b/src/mono_util.sig
index ab851aea..4a48671d 100644
--- a/src/mono_util.sig
+++ b/src/mono_util.sig
@@ -28,6 +28,9 @@
signature MONO_UTIL = sig
structure Typ : sig
+ val compare : Mono.typ * Mono.typ -> order
+ val sortFields : (string * Mono.typ) list -> (string * Mono.typ) list
+
val mapfold : (Mono.typ', 'state, 'abort) Search.mapfolder
-> (Mono.typ, 'state, 'abort) Search.mapfolder
@@ -44,7 +47,7 @@ structure Exp : sig
datatype binder =
NamedT of string * int * Mono.typ option
| RelE of string * Mono.typ
- | NamedE of string * int * Mono.typ * Mono.exp option
+ | NamedE of string * int * Mono.typ * Mono.exp option * string
val mapfoldB : {typ : (Mono.typ', 'state, 'abort) Search.mapfolder,
exp : ('typtext, Mono.exp', 'state, 'abort) Search.mapfolderB,
diff --git a/src/mono_util.sml b/src/mono_util.sml
index d5c047a7..1a7c8f5b 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -33,6 +33,48 @@ structure S = Search
structure Typ = struct
+fun join (o1, o2) =
+ case o1 of
+ EQUAL => o2 ()
+ | v => v
+
+fun joinL f (os1, os2) =
+ case (os1, os2) of
+ (nil, nil) => EQUAL
+ | (nil, _) => LESS
+ | (h1 :: t1, h2 :: t2) =>
+ join (f (h1, h2), fn () => joinL f (t1, t2))
+ | (_ :: _, nil) => GREATER
+
+fun compare ((t1, _), (t2, _)) =
+ case (t1, t2) of
+ (TFun (d1, r1), TFun (d2, r2)) =>
+ join (compare (d1, d2), fn () => compare (r1, r2))
+ | (TRecord xts1, TRecord xts2) =>
+ let
+ val xts1 = sortFields xts1
+ val xts2 = sortFields xts2
+ in
+ joinL compareFields (xts1, xts2)
+ end
+ | (TNamed n1, TNamed n2) => Int.compare (n1, n2)
+ | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
+
+ | (TFun _, _) => LESS
+ | (_, TFun _) => GREATER
+
+ | (TRecord _, _) => LESS
+ | (_, TRecord _) => GREATER
+
+ | (TNamed _, _) => LESS
+ | (_, TNamed _) => GREATER
+
+and compareFields ((x1, t1), (x2, t2)) =
+ join (String.compare (x1, x2),
+ fn () => compare (t1, t2))
+
+and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts
+
fun mapfold fc =
let
fun mft c acc =
@@ -85,7 +127,7 @@ structure Exp = struct
datatype binder =
NamedT of string * int * typ option
| RelE of string * typ
- | NamedE of string * int * typ * exp option
+ | NamedE of string * int * typ * exp option * string
fun mapfoldB {typ = fc, exp = fe, bind} =
let
@@ -211,21 +253,13 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
and mfd' ctx (dAll as (d, loc)) =
case d of
- DVal (x, n, t, e) =>
+ DVal (x, n, t, e, s) =>
S.bind2 (mft t,
fn t' =>
S.map2 (mfe ctx e,
fn e' =>
- (DVal (x, n, t', e'), loc)))
- | DPage (xts, e) =>
- S.bind2 (ListUtil.mapfold (fn (x, t) =>
- S.map2 (mft t,
- fn t' =>
- (x, t'))) xts,
- fn xts' =>
- S.map2 (mfe ctx e,
- fn e' =>
- (DPage (xts', e'), loc)))
+ (DVal (x, n, t', e', s), loc)))
+ | DExport _ => S.return2 dAll
in
mfd
end
@@ -262,8 +296,8 @@ fun mapfoldB (all as {bind, ...}) =
let
val ctx' =
case #1 d' of
- DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e))
- | DPage _ => ctx
+ DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
+ | DExport _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index 1d95a303..5f5db692 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -203,15 +203,9 @@ fun monoDecl env (all as (d, loc)) =
in
case d of
L.DCon _ => NONE
- | L.DVal (x, n, t, e) => SOME (Env.pushENamed env x n t (SOME e),
- (L'.DVal (x, n, monoType env t, monoExp env e), loc))
- | L.DPage ((c, _), e) =>
- (case c of
- L.CRecord (_, vs) => SOME (env,
- (L'.DPage (map (fn (nm, t) => (monoName env nm,
- monoType env t)) vs,
- monoExp env e), loc))
- | _ => poly ())
+ | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s,
+ (L'.DVal (x, n, monoType env t, monoExp env e, s), loc))
+ | L.DExport n => SOME (env, (L'.DExport n, loc))
end
fun monoize env ds =
diff --git a/src/reduce.sml b/src/reduce.sml
index 967eb790..cdf24725 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -115,7 +115,7 @@ fun bind (env, b) =
U.Decl.RelC (x, k) => E.pushCRel env x k
| U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co
| U.Decl.RelE (x, t) => E.pushERel env x t
- | U.Decl.NamedE (x, n, t, eo) => E.pushENamed env x n t eo
+ | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
fun kind k = k
@@ -143,7 +143,7 @@ fun exp env e =
case e of
ENamed n =>
(case E.lookupENamed env n of
- (_, _, SOME e') => #1 e'
+ (_, _, SOME e', _) => #1 e'
| _ => e)
| ECApp ((EApp ((EApp ((ECApp ((EFold ks, _), ran), _), f), _), i), _), (CRecord (k, xcs), loc)) =>
diff --git a/src/shake.sml b/src/shake.sml
index 36657dfc..b7ce58d7 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -43,13 +43,13 @@ type free = {
fun shake file =
let
- val (page_cs, page_es) = List.foldl
- (fn ((DPage (c, e), _), (cs, es)) => (c :: cs, e :: es)
- | (_, acc) => acc) ([], []) file
+ val page_es = List.foldl
+ (fn ((DExport n, _), page_es) => n :: page_es
+ | (_, page_es) => page_es) [] file
val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, c), edef)
- | ((DVal (_, n, t, e), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e)))
- | ((DPage _, _), acc) => acc)
+ | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e)))
+ | ((DExport _, _), acc) => acc)
(IM.empty, IM.empty) file
fun kind (_, s) = s
@@ -90,14 +90,16 @@ fun shake file =
and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s
- val s = {con = IS.empty, exp = IS.empty}
-
- val s = foldl (fn (c, s) => U.Con.fold {kind = kind, con = con} s c) s page_cs
- val s = foldl (fn (e, s) => U.Exp.fold {kind = kind, con = con, exp = exp} s e) s page_es
+ val s = {con = IS.empty, exp = IS.addList (IS.empty, page_es)}
+
+ val s = foldl (fn (n, s) =>
+ case IM.find (edef, n) of
+ NONE => raise Fail "Shake: Couldn't find 'val'"
+ | SOME (t, e) => shakeExp (shakeCon s t) e) s page_es
in
List.filter (fn (DCon (_, n, _, _), _) => IS.member (#con s, n)
- | (DVal (_, n, _, _), _) => IS.member (#exp s, n)
- | (DPage _, _) => true) file
+ | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
+ | (DExport _, _) => true) file
end
end
diff --git a/src/source.sml b/src/source.sml
index e52f5630..d5aa137e 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -113,7 +113,7 @@ datatype decl' =
| DOpen of string * string list
| DConstraint of con * con
| DOpenConstraints of string * string list
- | DPage of exp
+ | DExport of str
and str' =
StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index 827bb554..760f46bf 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -418,9 +418,9 @@ fun p_decl ((d, _) : decl) =
space,
p_list_sep (string ".") string (m :: ms)]
- | DPage e => box [string "page",
- space,
- p_exp e]
+ | DExport str => box [string "export",
+ space,
+ p_str str]
and p_str (str, _) =
case str of
diff --git a/src/sources b/src/sources
index c4b9849e..7faec26b 100644
--- a/src/sources
+++ b/src/sources
@@ -92,20 +92,6 @@ monoize.sml
mono_opt.sig
mono_opt.sml
-flat.sml
-
-flat_util.sig
-flat_util.sml
-
-flat_env.sig
-flat_env.sml
-
-flat_print.sig
-flat_print.sml
-
-cloconv.sig
-cloconv.sml
-
cjr.sml
cjr_env.sig
diff --git a/tests/attrs.lac b/tests/attrs.lac
index 940971d4..ffc52c67 100644
--- a/tests/attrs.lac
+++ b/tests/attrs.lac
@@ -1,5 +1,3 @@
val main = fn () => <html><body>
<font size=42 face="awesome">Welcome</font>
</body></html>
-
-page main
diff --git a/tests/attrs_escape.lac b/tests/attrs_escape.lac
index 2194ce09..12de101e 100644
--- a/tests/attrs_escape.lac
+++ b/tests/attrs_escape.lac
@@ -2,5 +2,3 @@ val main = fn () => <html><body>
<font face="\"Well hey\"
Wow">Welcome</font>
</body></html>
-
-page main
diff --git a/tests/html_fn.lac b/tests/html_fn.lac
index c4f0cb1d..9b81b73d 100644
--- a/tests/html_fn.lac
+++ b/tests/html_fn.lac
@@ -7,5 +7,3 @@ val main = fn () => <html>
<b>Hello</b> <i>World</i>!
</body>
</html>
-
-page main