diff options
author | 2009-04-30 11:07:29 -0400 | |
---|---|---|
committer | 2009-04-30 11:07:29 -0400 | |
commit | 7a3ba5558cb363006aae188e02dd57dda833d356 (patch) | |
tree | be8dc60f901b2cab9ec630d505bf152d1d19340e | |
parent | 0264695e9a76f87e6164c489c34af63fa893889d (diff) |
Basis.list
-rw-r--r-- | include/types.h | 1 | ||||
-rw-r--r-- | lib/ur/basis.urs | 2 | ||||
-rw-r--r-- | src/cjr.sml | 1 | ||||
-rw-r--r-- | src/cjr_print.sml | 12 | ||||
-rw-r--r-- | src/cjrize.sml | 60 | ||||
-rw-r--r-- | src/core_print.sig | 1 | ||||
-rw-r--r-- | src/core_print.sml | 22 | ||||
-rw-r--r-- | src/mono.sml | 1 | ||||
-rw-r--r-- | src/mono_print.sml | 17 | ||||
-rw-r--r-- | src/mono_util.sml | 8 | ||||
-rw-r--r-- | src/monoize.sml | 31 | ||||
-rw-r--r-- | tests/list.ur | 30 | ||||
-rw-r--r-- | tests/list.urp | 3 | ||||
-rw-r--r-- | tests/list.urs | 1 |
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 |