summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml36
-rw-r--r--src/mono.sml58
-rw-r--r--src/mono_env.sig49
-rw-r--r--src/mono_env.sml99
-rw-r--r--src/mono_print.sig38
-rw-r--r--src/mono_print.sml141
-rw-r--r--src/monoize.sig32
-rw-r--r--src/monoize.sml121
-rw-r--r--src/sources11
10 files changed, 584 insertions, 3 deletions
diff --git a/src/compiler.sig b/src/compiler.sig
index c06ac765..3e6ed1a3 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -34,11 +34,13 @@ signature COMPILER = sig
val corify : ElabEnv.env -> CoreEnv.env -> string -> Core.file option
val reduce : ElabEnv.env -> CoreEnv.env -> string -> Core.file option
val shake : ElabEnv.env -> CoreEnv.env -> string -> Core.file option
+ val monoize : ElabEnv.env -> CoreEnv.env -> string -> Mono.file option
val testParse : string -> unit
val testElaborate : string -> unit
val testCorify : string -> unit
val testReduce : string -> unit
val testShake : string -> unit
+ val testMonoize : string -> unit
end
diff --git a/src/compiler.sml b/src/compiler.sml
index 45fd88e4..20eb3ef5 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -70,17 +70,38 @@ fun elaborate env filename =
fun corify eenv cenv filename =
case elaborate eenv filename of
NONE => NONE
- | SOME (_, file) => SOME (Corify.corify file)
+ | SOME (_, file) =>
+ if ErrorMsg.anyErrors () then
+ NONE
+ else
+ SOME (Corify.corify file)
fun reduce eenv cenv filename =
case corify eenv cenv filename of
NONE => NONE
- | SOME file => SOME (Reduce.reduce (Shake.shake file))
+ | SOME file =>
+ if ErrorMsg.anyErrors () then
+ NONE
+ else
+ SOME (Reduce.reduce (Shake.shake file))
fun shake eenv cenv filename =
case reduce eenv cenv filename of
NONE => NONE
- | SOME file => SOME (Shake.shake file)
+ | SOME file =>
+ if ErrorMsg.anyErrors () then
+ NONE
+ else
+ SOME (Shake.shake file)
+
+fun monoize eenv cenv filename =
+ case shake eenv cenv filename of
+ NONE => NONE
+ | SOME file =>
+ if ErrorMsg.anyErrors () then
+ NONE
+ else
+ SOME (Monoize.monoize cenv file)
fun testParse filename =
case parse filename of
@@ -125,4 +146,13 @@ fun testShake filename =
handle CoreEnv.UnboundNamed n =>
print ("Unbound named " ^ Int.toString n ^ "\n")
+fun testMonoize filename =
+ (case monoize ElabEnv.basis CoreEnv.basis filename of
+ NONE => print "Failed\n"
+ | SOME file =>
+ (Print.print (MonoPrint.p_file MonoEnv.basis file);
+ print "\n"))
+ handle MonoEnv.UnboundNamed n =>
+ print ("Unbound named " ^ Int.toString n ^ "\n")
+
end
diff --git a/src/mono.sml b/src/mono.sml
new file mode 100644
index 00000000..7a4b54ee
--- /dev/null
+++ b/src/mono.sml
@@ -0,0 +1,58 @@
+(* 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 Mono = struct
+
+type 'a located = 'a ErrorMsg.located
+
+datatype typ' =
+ TFun of typ * typ
+ | TRecord of (string * typ) list
+ | TNamed of int
+
+withtype typ = typ' located
+
+datatype exp' =
+ EPrim of Prim.t
+ | ERel of int
+ | ENamed of int
+ | EApp of exp * exp
+ | EAbs of string * typ * exp
+
+ | ERecord of (string * exp) list
+ | EField of exp * string
+
+withtype exp = exp' located
+
+datatype decl' =
+ DVal of string * int * typ * exp
+
+withtype decl = decl' located
+
+type file = decl list
+
+end
diff --git a/src/mono_env.sig b/src/mono_env.sig
new file mode 100644
index 00000000..f3936998
--- /dev/null
+++ b/src/mono_env.sig
@@ -0,0 +1,49 @@
+(* 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 MONO_ENV = sig
+
+ type env
+
+ val empty : env
+ val basis : env
+
+ exception UnboundRel of int
+ exception UnboundNamed of int
+
+ val pushTNamed : env -> string -> int -> Mono.typ option -> env
+ val lookupTNamed : env -> int -> string * Mono.typ option
+
+ 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 declBinds : env -> Mono.decl -> env
+
+end
diff --git a/src/mono_env.sml b/src/mono_env.sml
new file mode 100644
index 00000000..60c6f609
--- /dev/null
+++ b/src/mono_env.sml
@@ -0,0 +1,99 @@
+(* 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 MonoEnv :> MONO_ENV = struct
+
+open Mono
+
+structure IM = IntBinaryMap
+
+
+exception UnboundRel of int
+exception UnboundNamed of int
+
+type env = {
+ namedT : (string * typ option) IM.map,
+
+ relE : (string * typ) list,
+ namedE : (string * typ * exp option) IM.map
+}
+
+val empty = {
+ namedT = IM.empty,
+
+ relE = [],
+ namedE = IM.empty
+}
+
+fun pushTNamed (env : env) x n co =
+ {namedT = IM.insert (#namedT env, n, (x, co)),
+
+ relE = #relE env,
+ namedE = #namedE 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}
+
+fun lookupERel (env : env) n =
+ (List.nth (#relE env, n))
+ handle Subscript => raise UnboundRel n
+
+fun pushENamed (env : env) x n t eo =
+ {namedT = #namedT env,
+
+ relE = #relE env,
+ namedE = IM.insert (#namedE env, n, (x, t, eo))}
+
+fun lookupENamed (env : env) n =
+ case IM.find (#namedE env, n) of
+ NONE => raise UnboundNamed n
+ | SOME x => x
+
+fun declBinds env (d, _) =
+ case d of
+ DVal (x, n, t, e) => pushENamed env x n t (SOME e)
+
+fun bbind env x =
+ case ElabEnv.lookupC ElabEnv.basis x of
+ ElabEnv.NotBound => raise Fail "MonoEnv.bbind: Not bound"
+ | ElabEnv.Rel _ => raise Fail "MonoEnv.bbind: Rel"
+ | ElabEnv.Named (n, _) => pushTNamed env x n NONE
+
+val basis = empty
+val basis = bbind basis "int"
+val basis = bbind basis "float"
+val basis = bbind basis "string"
+
+end
diff --git a/src/mono_print.sig b/src/mono_print.sig
new file mode 100644
index 00000000..6f7f09a9
--- /dev/null
+++ b/src/mono_print.sig
@@ -0,0 +1,38 @@
+(* 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 monomorphic language *)
+
+signature MONO_PRINT = sig
+ val p_typ : MonoEnv.env -> Mono.typ Print.printer
+ val p_exp : MonoEnv.env -> Mono.exp Print.printer
+ val p_decl : MonoEnv.env -> Mono.decl Print.printer
+ val p_file : MonoEnv.env -> Mono.file Print.printer
+
+ val debug : bool ref
+end
+
diff --git a/src/mono_print.sml b/src/mono_print.sml
new file mode 100644
index 00000000..a23296f9
--- /dev/null
+++ b/src/mono_print.sml
@@ -0,0 +1,141 @@
+(* 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 monomorphic Laconic/Web *)
+
+structure MonoPrint :> MONO_PRINT = struct
+
+open Print.PD
+open Print
+
+open Mono
+
+structure E = MonoEnv
+
+val debug = ref false
+
+fun p_typ' par env (t, _) =
+ case t of
+ TFun (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))
+
+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))
+ | ENamed n =>
+ if !debug then
+ string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
+ else
+ string (#1 (E.lookupENamed env n))
+ | EApp (e1, e2) => parenIf par (box [p_exp env e1,
+ space,
+ p_exp' true env e2])
+ | EAbs (x, t, e) => parenIf par (box [string "fn",
+ space,
+ string x,
+ space,
+ string ":",
+ space,
+ p_typ env t,
+ space,
+ string "=>",
+ space,
+ p_exp (E.pushERel env x t) e])
+
+ | 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]
+
+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
+
+fun p_file env file =
+ let
+ val (_, pds) = ListUtil.mapfoldl (fn (d, env) =>
+ (E.declBinds env d,
+ p_decl env d))
+ env file
+ in
+ p_list_sep newline (fn x => x) pds
+ end
+
+end
diff --git a/src/monoize.sig b/src/monoize.sig
new file mode 100644
index 00000000..0e9c23c3
--- /dev/null
+++ b/src/monoize.sig
@@ -0,0 +1,32 @@
+(* 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 MONOIZE = sig
+
+ val monoize : CoreEnv.env -> Core.file -> Mono.file
+
+end
diff --git a/src/monoize.sml b/src/monoize.sml
new file mode 100644
index 00000000..e72d7b1b
--- /dev/null
+++ b/src/monoize.sml
@@ -0,0 +1,121 @@
+(* 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 Monoize :> MONOIZE = struct
+
+structure E = ErrorMsg
+structure Env = CoreEnv
+
+structure L = Core
+structure L' = Mono
+
+val dummyTyp = (L'.TNamed 0, E.dummySpan)
+
+fun monoName env (all as (c, loc)) =
+ let
+ fun poly () =
+ (E.errorAt loc "Unsupported name constructor";
+ Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
+ "")
+ in
+ case c of
+ L.CName s => s
+ | _ => poly ()
+ end
+
+fun monoType env (all as (c, loc)) =
+ let
+ fun poly () =
+ (E.errorAt loc "Unsupported type constructor";
+ Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
+ dummyTyp)
+ in
+ case c of
+ L.TFun (c1, c2) => (L'.TFun (monoType env c1, monoType env c2), loc)
+ | L.TCFun _ => poly ()
+ | L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
+ (L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc)
+ | L.TRecord _ => poly ()
+
+ | L.CRel _ => poly ()
+ | L.CNamed n => (L'.TNamed n, loc)
+ | L.CApp _ => poly ()
+ | L.CAbs _ => poly ()
+
+ | L.CName _ => poly ()
+
+ | L.CRecord _ => poly ()
+ | L.CConcat _ => poly ()
+ end
+
+val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
+
+fun monoExp env (all as (e, loc)) =
+ let
+ fun poly () =
+ (E.errorAt loc "Unsupported expression";
+ Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
+ dummyExp)
+ in
+ case e of
+ L.EPrim p => (L'.EPrim p, loc)
+ | L.ERel n => (L'.ERel n, loc)
+ | L.ENamed n => (L'.ENamed n, loc)
+ | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc)
+ | L.EAbs (x, t, e) =>
+ (L'.EAbs (x, monoType env t, monoExp (Env.pushERel env x t) e), loc)
+ | L.ECApp _ => poly ()
+ | L.ECAbs _ => poly ()
+
+ | L.ERecord xes => (L'.ERecord (map (fn (x, e) => (monoName env x, monoExp env e)) xes), loc)
+ | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc)
+ end
+
+fun monoDecl env (all as (d, loc)) =
+ let
+ fun poly () =
+ (E.errorAt loc "Unsupported declaration";
+ Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
+ NONE)
+ 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))
+ end
+
+fun monoize env ds =
+ let
+ val (_, ds) = List.foldl (fn (d, (env, ds)) =>
+ case monoDecl env d of
+ NONE => (env, ds)
+ | SOME (env, d) => (env, d :: ds)) (env, []) ds
+ in
+ rev ds
+ end
+
+end
diff --git a/src/sources b/src/sources
index f10e0e90..adcda7e9 100644
--- a/src/sources
+++ b/src/sources
@@ -55,5 +55,16 @@ reduce.sml
shake.sig
shake.sml
+mono.sml
+
+monoize.sig
+monoize.sml
+
+mono_env.sig
+mono_env.sml
+
+mono_print.sig
+mono_print.sml
+
compiler.sig
compiler.sml