From 6b020742f893fed869a9473680271b6a68e1ce09 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 6 Nov 2008 10:48:02 -0500
Subject: Cookies through shake2

---
 src/core.sml       |  1 +
 src/core_env.sml   |  6 ++++++
 src/core_print.sml | 11 +++++++++++
 src/core_util.sml  | 17 ++++++++++++++---
 src/corify.sml     | 11 ++++++++++-
 src/shake.sml      |  7 +++++--
 6 files changed, 47 insertions(+), 6 deletions(-)

(limited to 'src')

diff --git a/src/core.sml b/src/core.sml
index 0b81e50e..1a181a68 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -120,6 +120,7 @@ datatype decl' =
        | DTable of string * int * con * string
        | DSequence of string * int * string
        | DDatabase of string
+       | DCookie of string * int * con * string
 
 withtype decl = decl' located
 
diff --git a/src/core_env.sml b/src/core_env.sml
index 0faf5aab..07162606 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -257,6 +257,12 @@ fun declBinds env (d, loc) =
             pushENamed env x n t NONE s
         end
       | DDatabase _ => env
+      | DCookie (x, n, c, s) =>
+        let
+            val t = (CApp ((CFfi ("Basis", "http_cookie"), loc), c), loc)
+        in
+            pushENamed env x n t NONE s
+        end
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/core_print.sml b/src/core_print.sml
index cd31487e..7de31568 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -504,6 +504,17 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DDatabase s => box [string "database",
                             space,
                             string s]
+      | DCookie (x, n, c, s) => box [string "cookie",
+                                     space,
+                                     p_named x n,
+                                     space,
+                                     string "as",
+                                     space,
+                                     string s,
+                                     space,
+                                     string ":",
+                                     space,
+                                     p_con env c]
 
 fun p_file env file =
     let
diff --git a/src/core_util.sml b/src/core_util.sml
index 2450562f..7e1440a1 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -656,10 +656,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
               | DExport _ => S.return2 dAll
               | DTable (x, n, c, s) =>
                 S.map2 (mfc ctx c,
-                        fn c' =>
-                           (DTable (x, n, c', s), loc))
+                     fn c' =>
+                        (DTable (x, n, c', s), loc))
               | DSequence _ => S.return2 dAll
               | DDatabase _ => S.return2 dAll
+              | DCookie (x, n, c, s) =>
+                S.map2 (mfc ctx c,
+                     fn c' =>
+                        (DCookie (x, n, c', s), loc))
 
         and mfvi ctx (x, n, t, e, s) =
             S.bind2 (mfc ctx t,
@@ -755,6 +759,12 @@ fun mapfoldB (all as {bind, ...}) =
                                             bind (ctx, NamedE (x, n, t, NONE, s))
                                         end
                                       | DDatabase _ => ctx
+                                      | DCookie (x, n, c, s) =>
+                                        let
+                                            val t = (CApp ((CFfi ("Basis", "http_cookie"), #2 d'), c), #2 d')
+                                        in
+                                            bind (ctx, NamedE (x, n, t, NONE, s))
+                                        end
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -807,7 +817,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DExport _ => count
                           | DTable (_, n, _, _) => Int.max (n, count)
                           | DSequence (_, n, _) => Int.max (n, count)
-                          | DDatabase _ => count) 0
+                          | DDatabase _ => count
+                          | DCookie (_, n, _, _) => Int.max (n, count)) 0
               
 end
 
diff --git a/src/corify.sml b/src/corify.sml
index 8b72f9f8..2b90a8f0 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -981,6 +981,14 @@ fun corifyDecl mods ((d, loc : EM.span), st) =
 
       | L.DDatabase s => ([(L'.DDatabase s, loc)], st)
 
+      | L.DCookie (_, x, n, c) =>
+        let
+            val (st, n) = St.bindVal st x n
+            val s = doRestify (mods, x)
+        in
+            ([(L'.DCookie (x, n, corifyCon st c, s), loc)], st)
+        end
+
 and corifyStr mods ((str, _), st) =
     case str of
         L.StrConst ds =>
@@ -1034,7 +1042,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
                              | L.DExport _ => n
                              | L.DTable (_, _, n', _) => Int.max (n, n')
                              | L.DSequence (_, _, n') => Int.max (n, n')
-                             | L.DDatabase _ => n)
+                             | L.DDatabase _ => n
+                             | L.DCookie (_, _, n', _) => Int.max (n, n'))
                        0 ds
 
 and maxNameStr (str, _) =
diff --git a/src/shake.sml b/src/shake.sml
index 4ebd1b0b..e062743d 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -68,7 +68,9 @@ fun shake file =
                                      (cdef, IM.insert (edef, n, ([], c, dummye)))
                                    | ((DSequence (_, n, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], dummyt, dummye)))
-                                   | ((DDatabase _, _), acc) => acc)
+                                   | ((DDatabase _, _), acc) => acc
+                                   | ((DCookie (_, n, c, _), _), (cdef, edef)) =>
+                                     (cdef, IM.insert (edef, n, ([], c, dummye))))
                                  (IM.empty, IM.empty) file
 
         fun kind (_, s) = s
@@ -136,7 +138,8 @@ fun shake file =
                       | (DExport _, _) => true
                       | (DTable _, _) => true
                       | (DSequence _, _) => true
-                      | (DDatabase _, _) => true) file
+                      | (DDatabase _, _) => true
+                      | (DCookie _, _) => true) file
     end
 
 end
-- 
cgit v1.2.3