Mercurial > urweb
changeset 757:fa2019a63ea4
Basis.list
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 30 Apr 2009 11:07:29 -0400 |
| parents | 8ce31c052dce |
| children | 8323c1beef2e |
| files | include/types.h lib/ur/basis.urs src/cjr.sml src/cjr_print.sml src/cjrize.sml src/core_print.sig src/core_print.sml src/mono.sml src/mono_print.sml src/mono_util.sml src/monoize.sml tests/list.ur tests/list.urp tests/list.urs |
| diffstat | 14 files changed, 152 insertions(+), 34 deletions(-) [+] |
line wrap: on
line diff
--- a/include/types.h Tue Apr 28 17:26:53 2009 -0400 +++ b/include/types.h Thu Apr 30 11:07:29 2009 -0400 @@ -21,6 +21,7 @@ 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;
--- a/lib/ur/basis.urs Tue Apr 28 17:26:53 2009 -0400 +++ b/lib/ur/basis.urs Thu Apr 30 11:07:29 2009 -0400 @@ -10,6 +10,8 @@ datatype option t = None | Some of t +datatype list t = Nil | Cons of t * list t + (** Basic type classes *)
--- a/src/cjr.sml Tue Apr 28 17:26:53 2009 -0400 +++ b/src/cjr.sml Thu Apr 30 11:07:29 2009 -0400 @@ -37,6 +37,7 @@ | 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
--- a/src/cjr_print.sml Tue Apr 28 17:26:53 2009 -0400 +++ b/src/cjr_print.sml Thu Apr 30 11:07:29 2009 -0400 @@ -102,6 +102,11 @@ 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 @@ 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 @@ in (box [string "{", newline, + string "/* ", + string (ErrorMsg.spanToString loc), + string "*/", + newline, p_typ env t, space, string "disc", @@ -574,6 +583,7 @@ | 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
--- a/src/cjrize.sml Tue Apr 28 17:26:53 2009 -0400 +++ b/src/cjrize.sml Thu Apr 30 11:07:29 2009 -0400 @@ -37,6 +37,7 @@ 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 @@ val compare = MonoUtil.Typ.compare end) -type t = int * int FM.map * (int * (string * L'.typ) list) list +type t = { + count : int, + normal : int FM.map, + lists : int FM.map, + decls : (int * (string * L'.typ) list) list +} -val empty : t = (1, FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0), []) +val empty : t = { + count = 1, + normal = FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0), + lists = FM.empty, + decls = [] +} -fun find ((n, m, ds), xts, xts') = +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 @@ 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
--- a/src/core_print.sig Tue Apr 28 17:26:53 2009 -0400 +++ b/src/core_print.sig Thu Apr 30 11:07:29 2009 -0400 @@ -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
--- a/src/core_print.sml Tue Apr 28 17:26:53 2009 -0400 +++ b/src/core_print.sml Thu Apr 30 11:07:29 2009 -0400 @@ -198,11 +198,23 @@ 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
--- a/src/mono.sml Tue Apr 28 17:26:53 2009 -0400 +++ b/src/mono.sml Thu Apr 30 11:07:29 2009 -0400 @@ -37,6 +37,7 @@ | 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
--- a/src/mono_print.sml Tue Apr 28 17:26:53 2009 -0400 +++ b/src/mono_print.sml Thu Apr 30 11:07:29 2009 -0400 @@ -65,6 +65,9 @@ | 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 @@ 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
--- a/src/mono_util.sml Tue Apr 28 17:26:53 2009 -0400 +++ b/src/mono_util.sml Thu Apr 30 11:07:29 2009 -0400 @@ -51,6 +51,7 @@ | (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 @@ | (TOption _, _) => LESS | (_, TOption _) => GREATER + | (TList _, _) => LESS + | (_, TList _) => GREATER + | (TSource, _) => LESS | (_, TSource) => GREATER @@ -104,6 +108,10 @@ 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,
--- a/src/monoize.sml Tue Apr 28 17:26:53 2009 -0400 +++ b/src/monoize.sml Thu Apr 30 11:07:29 2009 -0400 @@ -94,6 +94,8 @@ | 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 @@ 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 @@ | 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 @@ 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 @@ 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
--- a/tests/list.ur Tue Apr 28 17:26:53 2009 -0400 +++ b/tests/list.ur Thu Apr 30 11:07:29 2009 -0400 @@ -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>