summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/types.h1
-rw-r--r--lib/ur/basis.urs2
-rw-r--r--src/cjr.sml1
-rw-r--r--src/cjr_print.sml12
-rw-r--r--src/cjrize.sml60
-rw-r--r--src/core_print.sig1
-rw-r--r--src/core_print.sml22
-rw-r--r--src/mono.sml1
-rw-r--r--src/mono_print.sml17
-rw-r--r--src/mono_util.sml8
-rw-r--r--src/monoize.sml31
-rw-r--r--tests/list.ur30
-rw-r--r--tests/list.urp3
-rw-r--r--tests/list.urs1
14 files changed, 154 insertions, 36 deletions
diff --git a/include/types.h b/include/types.h
index ddf17552..1227a4db 100644
--- a/include/types.h
+++ b/include/types.h
@@ -21,6 +21,7 @@ typedef struct uw_context *uw_context;
typedef uw_Basis_string uw_Basis_xhtml;
typedef uw_Basis_string uw_Basis_page;
+typedef uw_Basis_string uw_Basis_xbody;
typedef uw_Basis_string uw_Basis_css_class;
typedef unsigned uw_Basis_client;
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 1881bec3..ea6f6f4a 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -10,6 +10,8 @@ datatype bool = False | True
datatype option t = None | Some of t
+datatype list t = Nil | Cons of t * list t
+
(** Basic type classes *)
diff --git a/src/cjr.sml b/src/cjr.sml
index d3fdbc22..6728e5c8 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -37,6 +37,7 @@ datatype typ' =
| TDatatype of datatype_kind * int * (string * int * typ option) list ref
| TFfi of string * string
| TOption of typ
+ | TList of typ * int
withtype typ = typ' located
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 7928ec5e..ee2307b6 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -102,6 +102,11 @@ fun p_typ' par env (t, loc) =
else
box [p_typ' par env t,
string "*"]
+ | TList (_, i) => box [string "struct",
+ space,
+ string "__uws_",
+ string (Int.toString i),
+ string "*"]
and p_typ env = p_typ' false env
@@ -147,7 +152,7 @@ fun p_patCon env pc =
PConVar n => p_con_named env n
| PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con)
-fun p_pat (env, exit, depth) (p, _) =
+fun p_pat (env, exit, depth) (p, loc) =
case p of
PWild =>
(box [], env)
@@ -328,6 +333,10 @@ fun p_pat (env, exit, depth) (p, _) =
in
(box [string "{",
newline,
+ string "/* ",
+ string (ErrorMsg.spanToString loc),
+ string "*/",
+ newline,
p_typ env t,
space,
string "disc",
@@ -574,6 +583,7 @@ fun notLeaky env allowHeapAllocated =
| TFfi ("Basis", "blob") => allowHeapAllocated
| TFfi _ => true
| TOption t => allowHeapAllocated andalso nl ok t
+ | TList (t, _) => allowHeapAllocated andalso nl ok t
in
nl IS.empty
end
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 19aeee4e..80d9842a 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -37,6 +37,7 @@ structure Sm :> sig
val empty : t
val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int
+ val findList : t * L.typ * L'.typ -> t * int
val declares : t -> (int * (string * L'.typ) list) list
val clearDeclares : t -> t
@@ -47,22 +48,54 @@ structure FM = BinaryMapFn(struct
val compare = MonoUtil.Typ.compare
end)
-type t = int * int FM.map * (int * (string * L'.typ) list) list
-
-val empty : t = (1, FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0), [])
-
-fun find ((n, m, ds), xts, xts') =
+type t = {
+ count : int,
+ normal : int FM.map,
+ lists : int FM.map,
+ decls : (int * (string * L'.typ) list) list
+}
+
+val empty : t = {
+ count = 1,
+ normal = FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0),
+ lists = FM.empty,
+ decls = []
+}
+
+fun find (v as {count, normal, decls, lists}, xts, xts') =
let
val t = (L.TRecord xts, ErrorMsg.dummySpan)
in
- case FM.find (m, t) of
- NONE => ((n+1, FM.insert (m, t, n), (n, xts') :: ds), n)
- | SOME i => ((n, m, ds), i)
+ case FM.find (normal, t) of
+ SOME i => (v, i)
+ | NONE => ({count = count+1,
+ normal = FM.insert (normal, t, count),
+ lists = lists,
+ decls = (count, xts') :: decls},
+ count)
end
-fun declares (_, _, ds) = ds
+fun findList (v as {count, normal, decls, lists}, t, t') =
+ case FM.find (lists, t) of
+ SOME i => (v, i)
+ | NONE =>
+ let
+ val xts = [("1", t), ("2", (L.TList t, #2 t))]
+ val xts' = [("1", t'), ("2", (L'.TList (t', count), #2 t'))]
+ in
+ ({count = count+1,
+ normal = FM.insert (normal, (L.TRecord xts, ErrorMsg.dummySpan), count),
+ lists = FM.insert (lists, t, count),
+ decls = (count, xts') :: decls},
+ count)
+ end
-fun clearDeclares (n, m, _) = (n, m, [])
+fun declares (v : t) = #decls v
+
+fun clearDeclares (v : t) = {count = #count v,
+ normal = #normal v,
+ lists = #lists v,
+ decls = []}
end
@@ -120,6 +153,13 @@ fun cifyTyp x =
in
((L'.TOption t, loc), sm)
end
+ | L.TList t =>
+ let
+ val (t', sm) = cify dtmap (t, sm)
+ val (sm, si) = Sm.findList (sm, t, t')
+ in
+ ((L'.TList (t', si), loc), sm)
+ end
| L.TSource => ((L'.TFfi ("Basis", "int"), loc), sm)
| L.TSignal _ => raise Fail "Cjrize: TSignal remains"
in
diff --git a/src/core_print.sig b/src/core_print.sig
index b7b41e28..aee3717d 100644
--- a/src/core_print.sig
+++ b/src/core_print.sig
@@ -30,6 +30,7 @@
signature CORE_PRINT = sig
val p_kind : CoreEnv.env -> Core.kind Print.printer
val p_con : CoreEnv.env -> Core.con Print.printer
+ val p_patCon : CoreEnv.env -> Core.patCon Print.printer
val p_pat : CoreEnv.env -> Core.pat Print.printer
val p_exp : CoreEnv.env -> Core.exp Print.printer
val p_decl : CoreEnv.env -> Core.decl Print.printer
diff --git a/src/core_print.sml b/src/core_print.sml
index f2a42a7b..971aa4b4 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -198,11 +198,23 @@ fun p_con_named env n =
fun p_patCon env pc =
case pc of
PConVar n => p_con_named env n
- | PConFfi {mod = m, con, ...} => box [string "FFIC(",
- string m,
- string ".",
- string con,
- string ")"]
+ | PConFfi {mod = m, con, arg, ...} =>
+ if !debug then
+ box [string "FFIC[",
+ case arg of
+ NONE => box []
+ | SOME t => p_con env t,
+ string "](",
+ string m,
+ string ".",
+ string con,
+ string ")"]
+ else
+ box [string "FFIC(",
+ string m,
+ string ".",
+ string con,
+ string ")"]
fun p_pat' par env (p, _) =
case p of
diff --git a/src/mono.sml b/src/mono.sml
index 7a789e2c..fa149b21 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -37,6 +37,7 @@ datatype typ' =
| TDatatype of int * (datatype_kind * (string * int * typ option) list) ref
| TFfi of string * string
| TOption of typ
+ | TList of typ
| TSource
| TSignal of typ
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a233b400..2299bc56 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -65,6 +65,9 @@ fun p_typ' par env (t, _) =
| TOption t => box [string "option(",
p_typ env t,
string ")"]
+ | TList t => box [string "list(",
+ p_typ env t,
+ string ")"]
| TSource => string "source"
| TSignal t => box [string "signal(",
p_typ env t,
@@ -114,9 +117,17 @@ fun p_pat' par env (p, _) =
p_pat env p]) xps,
string "}"]
| PNone _ => string "None"
- | PSome (_, p) => box [string "Some",
- space,
- p_pat' true env p]
+ | PSome (t, p) =>
+ if !debug then
+ box [string "Some[",
+ p_typ env t,
+ string "]",
+ space,
+ p_pat' true env p]
+ else
+ box [string "Some",
+ space,
+ p_pat' true env p]
and p_pat x = p_pat' false x
diff --git a/src/mono_util.sml b/src/mono_util.sml
index caf96ac7..ca074d9e 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -51,6 +51,7 @@ fun compare ((t1, _), (t2, _)) =
| (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
| (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
| (TOption t1, TOption t2) => compare (t1, t2)
+ | (TList t1, TList t2) => compare (t1, t2)
| (TSource, TSource) => EQUAL
| (TSignal t1, TSignal t2) => compare (t1, t2)
@@ -69,6 +70,9 @@ fun compare ((t1, _), (t2, _)) =
| (TOption _, _) => LESS
| (_, TOption _) => GREATER
+ | (TList _, _) => LESS
+ | (_, TList _) => GREATER
+
| (TSource, _) => LESS
| (_, TSource) => GREATER
@@ -104,6 +108,10 @@ fun mapfold fc =
S.map2 (mft t,
fn t' =>
(TOption t, loc))
+ | TList t =>
+ S.map2 (mft t,
+ fn t' =>
+ (TList t, loc))
| TSource => S.return2 cAll
| TSignal t =>
S.map2 (mft t,
diff --git a/src/monoize.sml b/src/monoize.sml
index ea191802..1ecf7a20 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -94,6 +94,8 @@ fun monoType env =
| L.CApp ((L.CFfi ("Basis", "option"), _), t) =>
(L'.TOption (mt env dtmap t), loc)
+ | L.CApp ((L.CFfi ("Basis", "list"), _), t) =>
+ (L'.TList (mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "eq"), _), t) =>
let
@@ -494,6 +496,9 @@ fun monoPatCon env pc =
val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan)
+
+fun listify t = (L'.TRecord [("1", t), ("2", (L'.TList t, #2 t))], #2 t)
+
fun monoPat env (all as (p, loc)) =
let
fun poly () =
@@ -506,8 +511,12 @@ fun monoPat env (all as (p, loc)) =
| L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
| L.PPrim p => (L'.PPrim p, loc)
| L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
+ | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) =>
+ (L'.PNone (listify (monoType env t)), loc)
+ | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME p) =>
+ (L'.PSome (listify (monoType env t), monoPat env p), loc)
| L.PCon (L.Option, _, [t], NONE) => (L'.PNone (monoType env t), loc)
- | L.PCon (L.Option, _, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc)
+ | L.PCon (L.Option, pc, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc)
| L.PCon _ => poly ()
| L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
end
@@ -613,6 +622,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
end
+ | L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) =>
+ ((L'.ENone (listify (monoType env t)), loc), fm)
+ | L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME e) =>
+ let
+ val (e, fm) = monoExp (env, st, fm) e
+ in
+ ((L'.ESome (listify (monoType env t), e), loc), fm)
+ end
| L.ECon (L.Option, _, [t], NONE) =>
((L'.ENone (monoType env t), loc), fm)
| L.ECon (L.Option, _, [t], SOME e) =>
@@ -2892,6 +2909,18 @@ fun monoDecl (env, fm) (all as (d, loc)) =
in
SOME (env', fm, [d])
end
+ | L.DDatatype ("list", n, [_], [("Nil", _, NONE),
+ ("Cons", _, SOME (L.TRecord (L.CRecord (_,
+ [((L.CName "1", _),
+ (L.CRel 0, _)),
+ ((L.CName "2", _),
+ (L.CApp ((L.CNamed n', _),
+ (L.CRel 0, _)),
+ _))]), _), _))]) =>
+ if n = n' then
+ NONE
+ else
+ poly ()
| L.DDatatype _ => poly ()
| L.DVal (x, n, t, e, s) =>
let
diff --git a/tests/list.ur b/tests/list.ur
index a4602d0e..815c0075 100644
--- a/tests/list.ur
+++ b/tests/list.ur
@@ -1,19 +1,17 @@
-datatype list a = Nil | Cons of a * list a
+fun isNil (t ::: Type) (ls : list t) =
+ case ls of
+ Nil => True
+ | _ => False
-val isNil = fn t ::: Type => fn ls : list t =>
- case ls of Nil => True | _ => False
+fun delist (ls : list string) : xbody =
+ case ls of
+ Nil => <xml>Nil</xml>
+ | Cons (h, t) => <xml>{[h]} :: {delist t}</xml>
-val show = fn b => if b then "True" else "False"
+fun main () = return <xml><body>
+ {[isNil (Nil : list bool)]},
+ {[isNil (Cons (1, Nil))]},
+ {[isNil (Cons ("A", Cons ("B", Nil)))]}
-val rec delist : list string -> xml body [] [] = fn x =>
- case x of
- Nil => <body>Nil</body>
- | Cons (h, t) => <body>{cdata h} :: {delist t}</body>
-
-val main : unit -> page = fn () => <html><body>
- {cdata (show (isNil (Nil : list bool)))},
- {cdata (show (isNil (Cons (1, Nil))))},
- {cdata (show (isNil (Cons ("A", Cons ("B", Nil)))))}
-
- <p>{delist (Cons ("X", Cons ("Y", Cons ("Z", Nil))))}</p>
-</body></html>
+ <p>{delist (Cons ("X", Cons ("Y", Cons ("Z", Nil))))}</p>
+</body></xml>
diff --git a/tests/list.urp b/tests/list.urp
new file mode 100644
index 00000000..d222b71a
--- /dev/null
+++ b/tests/list.urp
@@ -0,0 +1,3 @@
+debug
+
+list
diff --git a/tests/list.urs b/tests/list.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/list.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-15 00:37:51 +0000