From 6a326e3bb3eb16e04f3cca082f0dd67278e85785 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Apr 2010 12:29:34 -0400 Subject: Pushing policies through --- src/cjrize.sml | 1 + src/core.sml | 1 + src/core_env.sml | 1 + src/core_print.sml | 3 +++ src/core_util.sml | 8 +++++++- src/corify.sml | 6 +++++- src/css.sml | 1 + src/elab.sml | 1 + src/elab_env.sml | 1 + src/elab_print.sml | 3 +++ src/elab_util.sml | 8 +++++++- src/elaborate.sml | 10 ++++++++++ src/elisp/urweb-defs.el | 6 +++--- src/elisp/urweb-mode.el | 4 ++-- src/expl.sml | 1 + src/expl_env.sml | 1 + src/expl_print.sml | 3 +++ src/explify.sml | 1 + src/mono.sml | 6 +++++- src/mono_env.sml | 1 + src/mono_print.sml | 9 +++++++++ src/mono_shake.sml | 13 +++++++++++-- src/mono_util.sml | 14 +++++++++++++- src/monoize.sml | 14 ++++++++++++++ src/reduce.sml | 9 +++++++++ src/reduce_local.sml | 1 + src/shake.sml | 11 +++++++++-- src/source.sml | 1 + src/source_print.sml | 3 +++ src/unnest.sml | 1 + src/urweb.grm | 3 ++- src/urweb.lex | 1 + 32 files changed, 132 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/cjrize.sml b/src/cjrize.sml index 6e41a69b..b98b3c25 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -674,6 +674,7 @@ fun cifyDecl ((d, loc), sm) = end | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined"; (NONE, NONE, sm))) + | L.DPolicy _ => (NONE, NONE, sm) fun cjrize ds = let diff --git a/src/core.sml b/src/core.sml index 90005f16..e5358f48 100644 --- a/src/core.sml +++ b/src/core.sml @@ -135,6 +135,7 @@ datatype decl' = | DCookie of string * int * con * string | DStyle of string * int * string | DTask of exp * exp + | DPolicy of exp withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 9001e29c..478ef495 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -349,6 +349,7 @@ fun declBinds env (d, loc) = pushENamed env x n t NONE s end | DTask _ => env + | DPolicy _ => env fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index d6be76a3..fd0556e6 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -618,6 +618,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index 247dd32e..eedcd2bb 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -992,6 +992,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = S.map2 (mfe ctx e2, fn e2' => (DTask (e1', e2'), loc))) + | DPolicy e => + S.map2 (mfe ctx e, + fn e' => + (DPolicy e', loc)) and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1147,6 +1151,7 @@ fun mapfoldB (all as {bind, ...}) = bind (ctx, NamedE (x, n, t, NONE, s)) end | DTask _ => ctx + | DPolicy _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1210,7 +1215,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count) - | DTask _ => count) 0 + | DTask _ => count + | DPolicy _ => count) 0 end diff --git a/src/corify.sml b/src/corify.sml index 6931600e..88473455 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1080,6 +1080,9 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | L.DTask (e1, e2) => ([(L'.DTask (corifyExp st e1, corifyExp st e2), loc)], st) + | L.DPolicy e1 => + ([(L'.DPolicy (corifyExp st e1), loc)], st) + and corifyStr mods ((str, _), st) = case str of L.StrConst ds => @@ -1137,7 +1140,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n') | L.DStyle (_, _, n') => Int.max (n, n') - | L.DTask _ => n) + | L.DTask _ => n + | L.DPolicy _ => n) 0 ds and maxNameStr (str, _) = diff --git a/src/css.sml b/src/css.sml index 7189904f..3df35ed1 100644 --- a/src/css.sml +++ b/src/css.sml @@ -287,6 +287,7 @@ fun summarize file = | DCookie _ => st | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes) | DTask _ => st + | DPolicy _ => st end val (globals, classes) = foldl decl (IM.empty, IM.empty) file diff --git a/src/elab.sml b/src/elab.sml index a0f9a4e8..e040a059 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -171,6 +171,7 @@ datatype decl' = | DCookie of int * string * int * con | DStyle of int * string * int | DTask of exp * exp + | DPolicy of exp and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 5092c6fb..dd050c9e 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1623,5 +1623,6 @@ fun declBinds env (d, loc) = pushENamedAs env x n t end | DTask _ => env + | DPolicy _ => env end diff --git a/src/elab_print.sml b/src/elab_print.sml index 62b5262f..86448659 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -806,6 +806,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index d0e140c5..8345e3f3 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -854,7 +854,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f c), loc))) | DStyle (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) - | DTask _ => ctx, + | DTask _ => ctx + | DPolicy _ => ctx, mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -985,6 +986,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfe ctx e2, fn e2' => (DTask (e1', e2'), loc))) + | DPolicy e1 => + S.map2 (mfe ctx e1, + fn e1' => + (DPolicy e1', loc)) and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1128,6 +1133,7 @@ and maxNameDecl (d, _) = | DCookie (n1, _, n2, _) => Int.max (n1, n2) | DStyle (n1, _, n2) => Int.max (n1, n2) | DTask _ => 0 + | DPolicy _ => 0 and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index 1651f344..07818a57 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2595,6 +2595,7 @@ and sgiOfDecl (d, loc) = | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] | L'.DTask _ => [] + | L'.DPolicy _ => [] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3729,6 +3730,15 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = checkCon env e2' t2 t2'; ([(L'.DTask (e1', e2'), loc)], (env, denv, gs2 @ gs1 @ gs)) end + | L.DPolicy e1 => + let + val (e1', t1, gs1) = elabExp (env, denv) e1 + + val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc) + in + checkCon env e1' t1 t1'; + ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs)) + end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el index c697a274..8054d829 100644 --- a/src/elisp/urweb-defs.el +++ b/src/elisp/urweb-defs.el @@ -108,7 +108,7 @@ notion of \"the end of an outline\".") "datatype" "type" "open" "include" urweb-module-head-syms "con" "map" "where" "extern" "constraint" "constraints" - "table" "sequence" "class" "cookie" "task") + "table" "sequence" "class" "cookie" "task" "policy") "Symbols starting an sexp.") ;; (defconst urweb-not-arg-start-re @@ -135,7 +135,7 @@ notion of \"the end of an outline\".") (("case" "datatype" "if" "then" "else" "let" "open" "sig" "struct" "type" "val" "con" "constraint" "table" "sequence" "class" "cookie" - "task"))))) + "task" "policy"))))) (defconst urweb-starters-indent-after (urweb-syms-re "let" "in" "struct" "sig") @@ -190,7 +190,7 @@ for all symbols and in all lines starting with the given symbol." '("datatype" "fun" "open" "type" "val" "and" "con" "constraint" "table" "sequence" "class" "cookie" - "task")) + "task" "policy")) "The starters of new expressions.") (defconst urweb-exptrail-syms diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 107ea3bc..c9fe5f19 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'." "datatype" "else" "end" "extern" "fn" "map" "fun" "functor" "if" "include" "of" "open" "let" "in" - "rec" "sequence" "sig" "signature" "cookie" "style" "task" + "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy" "struct" "structure" "table" "view" "then" "type" "val" "where" "with" @@ -226,7 +226,7 @@ See doc for the variable `urweb-mode-info'." ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)" (1 font-lock-keyword-face) (3 (amAttribute font-lock-type-def-face))) - ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" + ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\|policy\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" (1 font-lock-keyword-face) (3 (amAttribute font-lock-variable-name-face))) ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)" diff --git a/src/expl.sml b/src/expl.sml index 17797626..1212383f 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -148,6 +148,7 @@ datatype decl' = | DCookie of int * string * int * con | DStyle of int * string * int | DTask of exp * exp + | DPolicy of exp and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 0bf7323f..583e4881 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -344,6 +344,7 @@ fun declBinds env (d, loc) = pushENamed env x n t end | DTask _ => env + | DPolicy _ => env fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 5284eecb..15838729 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -720,6 +720,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index aff91a34..0013906f 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -196,6 +196,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc) + | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 898feb9b..33ab5bd4 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -123,6 +123,8 @@ datatype exp' = withtype exp = exp' located +datatype policy = PolQuery of exp + datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list | DVal of string * int * typ * exp * string @@ -141,6 +143,8 @@ datatype decl' = | DTask of exp * exp + | DPolicy of policy + withtype decl = decl' located type file = decl list diff --git a/src/mono_env.sml b/src/mono_env.sml index c2e6cf02..87f96488 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -130,6 +130,7 @@ fun declBinds env (d, loc) = | DCookie _ => env | DStyle _ => env | DTask _ => env + | DPolicy _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index d1f5fc27..50c4717a 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -412,6 +412,12 @@ fun p_datatype env (x, n, cons) = cons] end +fun p_policy env pol = + case pol of + PolQuery e => box [string "query", + space, + p_exp env e] + fun p_decl env (dAll as (d, _) : decl) = case d of DDatatype x => box [string "datatype", @@ -506,6 +512,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy p => box [string "policy", + space, + p_policy env p] fun p_file env file = diff --git a/src/mono_shake.sml b/src/mono_shake.sml index e53b6930..358b31d2 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -58,6 +58,13 @@ fun shake file = | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) => (page_cs, IS.addList (page_es, [n1, n2])) | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1 + | ((DPolicy pol, _), st) => + let + val e1 = case pol of + PolQuery e1 => e1 + in + usedVars st e1 + end | (_, st) => st) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => @@ -74,7 +81,8 @@ fun shake file = | ((DJavaScript _, _), acc) => acc | ((DCookie _, _), acc) => acc | ((DStyle _, _), acc) => acc - | ((DTask _, _), acc) => acc) + | ((DTask _, _), acc) => acc + | ((DPolicy _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -141,7 +149,8 @@ fun shake file = | (DJavaScript _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true - | (DTask _, _) => true) file + | (DTask _, _) => true + | (DPolicy _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index a75843c4..094f216b 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -534,6 +534,16 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = S.map2 (mfe ctx e2, fn e2' => (DTask (e1', e2'), loc))) + | DPolicy pol => + S.map2 (mfpol ctx pol, + fn p' => + (DPolicy p', loc)) + + and mfpol ctx pol = + case pol of + PolQuery e => + S.map2 (mfe ctx e, + PolQuery) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -621,6 +631,7 @@ fun mapfoldB (all as {bind, ...}) = | DCookie _ => ctx | DStyle _ => ctx | DTask _ => ctx + | DPolicy _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -674,7 +685,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DJavaScript _ => count | DCookie _ => count | DStyle _ => count - | DTask _ => count) 0 + | DTask _ => count + | DPolicy _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 25ea87f5..6f229766 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3738,6 +3738,20 @@ fun monoDecl (env, fm) (all as (d, loc)) = fm, [(L'.DTask (e1, e2), loc)]) end + | L.DPolicy e => + let + val (e, make) = + case #1 e of + L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "query_policy"), _), _), _), _), _), e) => + (e, L'.PolQuery) + | _ => (poly (); (e, L'.PolQuery)) + + val (e, fm) = monoExp (env, St.empty, fm) e + in + SOME (env, + fm, + [(L'.DPolicy (make e), loc)]) + end end datatype expungable = Client | Channel diff --git a/src/reduce.sml b/src/reduce.sml index b7ad567a..cefe1955 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -746,6 +746,15 @@ fun reduce file = namedC, namedE)) end + | DPolicy e1 => + let + val e1 = exp (namedC, namedE) [] e1 + in + ((DPolicy e1, loc), + (polyC, + namedC, + namedE)) + end val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file in diff --git a/src/reduce_local.sml b/src/reduce_local.sml index b040a1ec..4c5ab52e 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -252,6 +252,7 @@ fun reduce file = | DCookie _ => d | DStyle _ => d | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) + | DPolicy e1 => (DPolicy (exp [] e1), loc) in map doDecl file end diff --git a/src/shake.sml b/src/shake.sml index 686a043c..f679c6e8 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -90,6 +90,11 @@ fun shake file = st else usedVars (usedVars st e1) e2 + | ((DPolicy e1, _), st) => + if !sliceDb then + st + else + usedVars st e1 | (_, acc) => acc) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) @@ -116,7 +121,8 @@ fun shake file = (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DStyle (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) - | ((DTask _, _), acc) => acc) + | ((DTask _, _), acc) => acc + | ((DPolicy _, _), acc) => acc) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -203,7 +209,8 @@ fun shake file = | (DDatabase _, _) => not (!sliceDb) | (DCookie _, _) => not (!sliceDb) | (DStyle _, _) => not (!sliceDb) - | (DTask _, _) => not (!sliceDb)) file + | (DTask _, _) => not (!sliceDb) + | (DPolicy _, _) => not (!sliceDb)) file end end diff --git a/src/source.sml b/src/source.sml index dc867026..9768cfc0 100644 --- a/src/source.sml +++ b/src/source.sml @@ -168,6 +168,7 @@ datatype decl' = | DCookie of string * con | DStyle of string | DTask of exp * exp + | DPolicy of exp and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index e3b4fe94..590d15d5 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -669,6 +669,9 @@ fun p_decl ((d, _) : decl) = string "=", space, p_exp e2] + | DPolicy e1 => box [string "policy", + space, + p_exp e1] and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index e030bbc6..77589bfb 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -423,6 +423,7 @@ fun unnest file = | DCookie _ => default () | DStyle _ => default () | DTask _ => explore () + | DPolicy _ => explore () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index ad3de6b2..3df9554f 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -202,7 +202,7 @@ fun patType loc (p : pat) = | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW - | COOKIE | STYLE | TASK + | COOKIE | STYLE | TASK | POLICY | CASE | IF | THEN | ELSE | ANDALSO | ORELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -481,6 +481,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))]) + | POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))]) dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons) diff --git a/src/urweb.lex b/src/urweb.lex index 45f555dd..8930c463 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -416,6 +416,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); "task" => (Tokens.TASK (pos yypos, pos yypos + size yytext)); + "policy" => (Tokens.POLICY (pos yypos, pos yypos + size yytext)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); -- cgit v1.2.3