Basis.list

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