summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sml1
-rw-r--r--src/corify.sml75
-rw-r--r--src/elab.sml3
-rw-r--r--src/elab_env.sml1
-rw-r--r--src/elab_print.sml1
-rw-r--r--src/elab_util.sml8
-rw-r--r--src/elaborate.sml15
-rw-r--r--src/elisp/urweb-mode.el2
-rw-r--r--src/expl.sml1
-rw-r--r--src/expl_env.sml1
-rw-r--r--src/expl_print.sml1
-rw-r--r--src/expl_rename.sml10
-rw-r--r--src/explify.sml1
-rw-r--r--src/settings.sig7
-rw-r--r--src/settings.sml8
-rw-r--r--src/source.sml8
-rw-r--r--src/source_print.sml1
-rw-r--r--src/unnest.sml1
-rw-r--r--src/urweb.grm21
-rw-r--r--src/urweb.lex1
20 files changed, 155 insertions, 12 deletions
diff --git a/src/compiler.sml b/src/compiler.sml
index cc4e33c5..269a7824 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -874,6 +874,7 @@ fun parseUrp' accLibs fname =
| "timeFormat" => Settings.setTimeFormat arg
| "noMangleSql" => Settings.setMangleSql false
| "html5" => Settings.setIsHtml5 true
+ | "lessSafeFfi" => Settings.setLessSafeFfi true
| _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
read ()
diff --git a/src/corify.sml b/src/corify.sml
index 085b2eb8..b08ef7eb 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -643,6 +643,12 @@ fun corifyExp st (e, loc) =
| L.ELet (x, t, e1, e2) => (L'.ELet (x, corifyCon st t, corifyExp st e1, corifyExp st e2), loc)
+fun isTransactional (c, _) =
+ case c of
+ L'.TFun (_, c) => isTransactional c
+ | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true
+ | _ => false
+
fun corifyDecl mods (all as (d, loc : EM.span), st) =
case d of
L.DCon (x, n, k, c) =>
@@ -970,12 +976,6 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
in
transactify c
end
-
- fun isTransactional (c, _) =
- case c of
- L'.TFun (_, c) => isTransactional c
- | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true
- | _ => false
in
if isTransactional c then
let
@@ -1164,6 +1164,66 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
([], st))
end
+ | L.DFfi (x, n, modes, t) =>
+ let
+ val m = case St.name st of
+ [m] => m
+ | _ => (ErrorMsg.errorAt loc "Used 'ffi' declaration beneath module top level";
+ "")
+
+ val name = (m, x)
+
+ val (st, n) = St.bindVal st x n
+ val s = doRestify Settings.Url (mods, x)
+
+ val t' = corifyCon st t
+
+ fun numArgs (t : L'.con) =
+ case #1 t of
+ L'.TFun (_, ran) => 1 + numArgs ran
+ | _ => 0
+
+ fun makeArgs (i, t : L'.con, acc) =
+ case #1 t of
+ L'.TFun (dom, ran) => makeArgs (i-1, ran, ((L'.ERel i, loc), dom) :: acc)
+ | _ => rev acc
+
+ fun wrapAbs (i, t : L'.con, tTrans, e) =
+ case (#1 t, #1 tTrans) of
+ (L'.TFun (dom, ran), L'.TFun (_, ran')) => (L'.EAbs ("x" ^ Int.toString i, dom, ran, wrapAbs (i+1, ran, ran', e)), loc)
+ | _ => e
+
+ fun getRan (t : L'.con) =
+ case #1 t of
+ L'.TFun (_, ran) => getRan ran
+ | _ => t
+
+ fun addLastBit (t : L'.con) =
+ case #1 t of
+ L'.TFun (dom, ran) => (L'.TFun (dom, addLastBit ran), #2 t)
+ | _ => (L'.TFun ((L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), t), loc)
+
+ val e = (L'.EFfiApp (m, x, makeArgs (numArgs t' - 1, t', [])), loc)
+ val (e, tTrans) = if isTransactional t' then
+ ((L'.EAbs ("_", (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), getRan t', e), loc), addLastBit t')
+ else
+ (e, t')
+ val e = wrapAbs (0, t', tTrans, e)
+ in
+ app (fn Source.Effectful => Settings.addEffectful name
+ | Source.BenignEffectful => Settings.addBenignEffectful name
+ | Source.ClientOnly => Settings.addClientOnly name
+ | Source.ServerOnly => Settings.addServerOnly name
+ | Source.JsFunc s => Settings.addJsFunc (name, s)) modes;
+
+ if isTransactional t' andalso not (Settings.isBenignEffectful name) then
+ Settings.addEffectful name
+ else
+ ();
+
+ ([(L'.DVal (x, n, t', e, s), loc)], st)
+ end
+
and corifyStr mods ((str, loc), st) =
case str of
L.StrConst ds =>
@@ -1237,7 +1297,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
| L.DStyle (_, _, n') => Int.max (n, n')
| L.DTask _ => n
| L.DPolicy _ => n
- | L.DOnError _ => n)
+ | L.DOnError _ => n
+ | L.DFfi (_, n', _, _) => Int.max (n, n'))
0 ds
and maxNameStr (str, _) =
diff --git a/src/elab.sml b/src/elab.sml
index 2dab5c34..249531f1 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2011, Adam Chlipala
+(* Copyright (c) 2008-2011, 2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -181,6 +181,7 @@ datatype decl' =
| DTask of exp * exp
| DPolicy of exp
| DOnError of int * string list * string
+ | DFfi of string * int * Source.ffi_mode list * con
and str' =
StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 465fb7e4..9fbe7bd7 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1681,5 +1681,6 @@ fun declBinds env (d, loc) =
| DTask _ => env
| DPolicy _ => env
| DOnError _ => env
+ | DFfi (x, n, _, t) => pushENamedAs env x n t
end
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 7ce94c97..957d4646 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -852,6 +852,7 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
p_exp env e1]
| DOnError _ => string "ONERROR"
+ | DFfi _ => string "FFI"
and p_str env (str, _) =
case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 60245585..fef55852 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -927,7 +927,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc)))
| DTask _ => ctx
| DPolicy _ => ctx
- | DOnError _ => ctx,
+ | DOnError _ => ctx
+ | DFfi (x, _, _, t) => bind (ctx, NamedE (x, t)),
mfd ctx d)) ctx ds,
fn ds' => (StrConst ds', loc))
| StrVar _ => S.return2 strAll
@@ -1056,6 +1057,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
fn e1' =>
(DPolicy e1', loc))
| DOnError _ => S.return2 dAll
+ | DFfi (x, n, modes, t) =>
+ S.map2 (mfc ctx t,
+ fn t' =>
+ (DFfi (x, n, modes, t'), loc))
and mfvi ctx (x, n, c, e) =
S.bind2 (mfc ctx c,
@@ -1234,6 +1239,7 @@ and maxNameDecl (d, _) =
| DTask _ => 0
| DPolicy _ => 0
| DOnError _ => 0
+ | DFfi (_, n, _, _) => n
and maxNameStr (str, _) =
case str of
StrConst ds => maxName ds
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 97ac610b..d492883f 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2999,6 +2999,7 @@ and sgiOfDecl (d, loc) =
| L'.DTask _ => []
| L'.DPolicy _ => []
| L'.DOnError _ => []
+ | L'.DFfi (x, n, _, t) => [(L'.SgiVal (x, n, t), loc)]
and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
@@ -4298,6 +4299,20 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
([(L'.DOnError (n, ms, s), loc)], (env, denv, gs))
end)
+ | L.DFfi (x, modes, t) =>
+ let
+ val () = if Settings.getLessSafeFfi () then
+ ()
+ else
+ ErrorMsg.errorAt loc "To enable 'ffi' declarations, the .urp directive 'lessSafeFfi' is mandatory."
+
+ val (t', _, gs1) = elabCon (env, denv) t
+ val t' = normClassConstraint env t'
+ val (env', n) = E.pushENamed env x t'
+ in
+ ([(L'.DFfi (x, n, modes, t'), loc)], (env', denv, enD gs1 @ gs))
+ end
+
(*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
in
(*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll),
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index f183a9ab..edbff1b0 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -139,7 +139,7 @@ See doc for the variable `urweb-mode-info'."
"of" "open" "let" "in"
"rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy"
"struct" "structure" "table" "view" "then" "type" "val" "where"
- "with"
+ "with" "ffi"
"Name" "Type" "Unit")
"A regexp that matches any non-SQL keywords of Ur/Web.")
diff --git a/src/expl.sml b/src/expl.sml
index 0d4e63cc..3d784e3f 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -150,6 +150,7 @@ datatype decl' =
| DTask of exp * exp
| DPolicy of exp
| DOnError of int * string list * string
+ | DFfi of string * int * Source.ffi_mode list * con
and str' =
StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index f5a5eb0a..5712a72d 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -346,6 +346,7 @@ fun declBinds env (d, loc) =
| DTask _ => env
| DPolicy _ => env
| DOnError _ => env
+ | DFfi (x, n, _, t) => pushENamed env x n t
fun sgiBinds env (sgi, loc) =
case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index a830dccb..22d246e2 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -731,6 +731,7 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
p_exp env e1]
| DOnError _ => string "ONERROR"
+ | DFfi _ => string "FFI"
and p_str env (str, _) =
case str of
diff --git a/src/expl_rename.sml b/src/expl_rename.sml
index 7e7a155a..bb763a60 100644
--- a/src/expl_rename.sml
+++ b/src/expl_rename.sml
@@ -219,6 +219,7 @@ fun renameDecl st (all as (d, loc)) =
(case St.lookup (st, n) of
NONE => all
| SOME n' => (DOnError (n', xs, x), loc))
+ | DFfi (x, n, modes, t) => (DFfi (x, n, modes, renameCon st t), loc)
and renameStr st (all as (str, loc)) =
case str of
@@ -413,6 +414,15 @@ fun dupDecl (all as (d, loc), st) =
(case St.lookup (st, n) of
NONE => ([all], st)
| SOME n' => ([(DOnError (n', xs, x), loc)], st))
+ | DFfi (x, n, modes, t) =>
+ let
+ val (st, n') = St.bind (st, n)
+ val t' = renameCon st t
+ in
+ ([(DFfi (x, n, modes, t'), loc),
+ (DVal (x, n', t', (ENamed n, loc)), loc)],
+ st)
+ end
fun rename {NextId, FormalName, FormalId, Body = all as (str, loc)} =
case str of
diff --git a/src/explify.sml b/src/explify.sml
index 4c60bd20..fd0f3277 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -198,6 +198,7 @@ fun explifyDecl (d, loc : EM.span) =
| L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc)
| L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc)
| L.DOnError v => SOME (L'.DOnError v, loc)
+ | L.DFfi (x, n, modes, t) => SOME (L'.DFfi (x, n, modes, explifyCon t), loc)
and explifyStr (str, loc) =
case str of
diff --git a/src/settings.sig b/src/settings.sig
index 20dd00c2..29c4c506 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -78,18 +78,22 @@ signature SETTINGS = sig
(* Which FFI functions should not have their calls removed or reordered, but cause no lasting effects? *)
val setBenignEffectful : ffi list -> unit
+ val addBenignEffectful : ffi -> unit
val isBenignEffectful : ffi -> bool
(* Which FFI functions may only be run in clients? *)
val setClientOnly : ffi list -> unit
+ val addClientOnly : ffi -> unit
val isClientOnly : ffi -> bool
(* Which FFI functions may only be run on servers? *)
val setServerOnly : ffi list -> unit
+ val addServerOnly : ffi -> unit
val isServerOnly : ffi -> bool
(* Which FFI functions may be run in JavaScript? (JavaScript function names included) *)
val setJsFuncs : (ffi * string) list -> unit
+ val addJsFunc : ffi * string -> unit
val jsFunc : ffi -> string option
val allJsFuncs : unit -> (ffi * string) list
@@ -271,4 +275,7 @@ signature SETTINGS = sig
val setIsHtml5 : bool -> unit
val getIsHtml5 : unit -> bool
+
+ val setLessSafeFfi : bool -> unit
+ val getLessSafeFfi : unit -> bool
end
diff --git a/src/settings.sml b/src/settings.sml
index 4cdb4119..f00a4853 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -194,6 +194,7 @@ val benignBase = basis ["get_cookie",
val benign = ref benignBase
fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
+fun addBenignEffectful x = benign := S.add (!benign, x)
fun isBenignEffectful x = S.member (!benign, x)
val clientBase = basis ["get_client_source",
@@ -225,6 +226,7 @@ val clientBase = basis ["get_client_source",
"giveFocus"]
val client = ref clientBase
fun setClientOnly ls = client := S.addList (clientBase, ls)
+fun addClientOnly x = client := S.add (!client, x)
fun isClientOnly x = S.member (!client, x)
val serverBase = basis ["requestHeader",
@@ -240,6 +242,7 @@ val serverBase = basis ["requestHeader",
"firstFormField"]
val server = ref serverBase
fun setServerOnly ls = server := S.addList (serverBase, ls)
+fun addServerOnly x = server := S.add (!server, x)
fun isServerOnly x = S.member (!server, x)
val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
@@ -364,6 +367,7 @@ val jsFuncsBase = basisM [("alert", "alert"),
val jsFuncs = ref jsFuncsBase
fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
fun jsFunc x = M.find (!jsFuncs, x)
+fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v)
fun allJsFuncs () = M.listItemsi (!jsFuncs)
datatype pattern_kind = Exact | Prefix
@@ -735,4 +739,8 @@ val html5 = ref false
fun setIsHtml5 b = html5 := b
fun getIsHtml5 () = !html5
+val less = ref false
+fun setLessSafeFfi b = less := b
+fun getLessSafeFfi () = !less
+
end
diff --git a/src/source.sml b/src/source.sml
index eea7ad4c..2a741dd9 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -147,6 +147,13 @@ and pat = pat' located
and exp = exp' located
and edecl = edecl' located
+datatype ffi_mode =
+ Effectful
+ | BenignEffectful
+ | ClientOnly
+ | ServerOnly
+ | JsFunc of string
+
datatype decl' =
DCon of string * kind option * con
| DDatatype of (string * string list * (string * con option) list) list
@@ -169,6 +176,7 @@ datatype decl' =
| DTask of exp * exp
| DPolicy of exp
| DOnError of string * string list * string
+ | DFfi of string * ffi_mode list * con
and str' =
StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index fdacfe6c..db56a0db 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -674,6 +674,7 @@ fun p_decl ((d, _) : decl) =
space,
p_exp e1]
| DOnError _ => string "ONERROR"
+ | DFfi _ => string "FFI"
and p_str (str, _) =
case str of
diff --git a/src/unnest.sml b/src/unnest.sml
index 17bfd39f..fceb5026 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -452,6 +452,7 @@ fun unnest file =
| DTask _ => explore ()
| DPolicy _ => explore ()
| DOnError _ => default ()
+ | DFfi _ => default ()
end
and doStr (all as (str, loc), st) =
diff --git a/src/urweb.grm b/src/urweb.grm
index 7aec9492..157ecfac 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2012, Adam Chlipala
+(* Copyright (c) 2008-2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -365,7 +365,7 @@ fun patternOut (e : exp) =
| LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
| EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR
| PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
- | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
+ | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS | FFI
| DATATYPE | OF
| TYPE | NAME
| ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
@@ -532,6 +532,9 @@ fun patternOut (e : exp) =
| enterDml of unit
| leaveDml of unit
+ | ffi_mode of ffi_mode
+ | ffi_modes of ffi_mode list
+
%verbose (* print summary of errors *)
%pos int (* positions *)
@@ -645,6 +648,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
| STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
| TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))])
| POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))])
+ | FFI SYMBOL ffi_modes COLON cexp([(DFfi (SYMBOL, ffi_modes, cexp), s (FFIleft, cexpright))])
dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons)
@@ -2267,3 +2271,16 @@ sqlagg : AVG ("avg")
| SUM ("sum")
| MIN ("min")
| MAX ("max")
+
+ffi_mode : SYMBOL (case SYMBOL of
+ "effectful" => Effectful
+ | "benignEffectful" => BenignEffectful
+ | "clientOnly" => ClientOnly
+ | "serverOnly" => ServerOnly
+ | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful))
+ | SYMBOL STRING (case SYMBOL of
+ "jsFunc" => JsFunc STRING
+ | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful))
+
+ffi_modes : ([])
+ | ffi_mode ffi_modes (ffi_mode :: ffi_modes)
diff --git a/src/urweb.lex b/src/urweb.lex
index 293c6dc6..15ae448e 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -445,6 +445,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
<INITIAL> "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
<INITIAL> "task" => (Tokens.TASK (pos yypos, pos yypos + size yytext));
<INITIAL> "policy" => (Tokens.POLICY (pos yypos, pos yypos + size yytext));
+<INITIAL> "ffi" => (Tokens.FFI (pos yypos, pos yypos + size yytext));
<INITIAL> "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
<INITIAL> "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext));
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-28 23:08:54 +0000