summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/mono_opt.sml4
-rw-r--r--src/mono_reduce.sml39
-rw-r--r--src/monoize.sml44
-rw-r--r--src/settings.sml13
-rw-r--r--src/urweb.grm32
-rw-r--r--src/urweb.lex16
6 files changed, 125 insertions, 23 deletions
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 2d40e0f0..04ef7f50 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -630,7 +630,9 @@ fun exp e =
EFfiApp ("Basis", "writec", [e])
| EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2)))
-
+ | EBinop (_, "-", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.- (n1, n2)))
+ | EBinop (_, "*", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.* (n1, n2)))
+
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 39d02b99..61866af7 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -330,7 +330,9 @@ val freeInAbs = U.Exp.existsB {typ = fn _ => false,
U.Exp.RelE _ => n + 1
| _ => n} 0
-fun reduce (file : file) =
+val yankedCase = ref false
+
+fun reduce' (file : file) =
let
val (timpures, impures, absCounts) =
foldl (fn ((d, _), (timpures, impures, absCounts)) =>
@@ -770,17 +772,18 @@ fun reduce (file : file) =
Print.PD.string "}"]
in
if List.all (safe o #2) pes then
- EAbs ("y", dom, result,
- (ECase (liftExpInExp 0 e',
- map (fn (p, (EAbs (_, _, _, e), _)) =>
- (p, swapExpVarsPat (0, patBinds p) e)
- | (p, (EError (e, (TFun (_, t), _)), loc)) =>
- (p, (EError (liftExpInExp (patBinds p) e, t), loc))
- | (p, e) =>
- (p, (EApp (liftExpInExp (patBinds p) e,
- (ERel (patBinds p), loc)), loc)))
- pes,
- {disc = disc, result = result}), loc))
+ (yankedCase := true;
+ EAbs ("y", dom, result,
+ (ECase (liftExpInExp 0 e',
+ map (fn (p, (EAbs (_, _, _, e), _)) =>
+ (p, swapExpVarsPat (0, patBinds p) e)
+ | (p, (EError (e, (TFun (_, t), _)), loc)) =>
+ (p, (EError (liftExpInExp (patBinds p) e, t), loc))
+ | (p, e) =>
+ (p, (EApp (liftExpInExp (patBinds p) e,
+ (ERel (patBinds p), loc)), loc)))
+ pes,
+ {disc = disc, result = result}), loc)))
else
e
end
@@ -894,4 +897,16 @@ fun reduce (file : file) =
U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
end
+fun reduce file =
+ let
+ val () = yankedCase := false
+ val file' = reduce' file
+ in
+ if !yankedCase then
+ reduce file'
+ else
+ file'
+ end
+
+
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 5727d997..59c5d2ea 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3267,6 +3267,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
else
(NONE, NONE, attrs)
+ val (class, fm) = monoExp (env, st, fm) class
+ val (dynClass, fm) = monoExp (env, st, fm) dynClass
+ val (style, fm) = monoExp (env, st, fm) style
+ val (dynStyle, fm) = monoExp (env, st, fm) dynStyle
+
(* Special case for <button value=""> *)
val (attrs, extraString) = case tag of
"button" =>
@@ -3274,14 +3279,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
([(_, value, _)], rest) =>
(rest, SOME value)
| _ => (attrs, NONE))
+ | "body" =>
+ (attrs,
+ if (case (#1 dynClass, #1 dynStyle) of
+ (L'.ESome _, _) => true
+ | (_, L'.ESome _) => true
+ | _ => false) then
+ let
+ fun jsify (e : L'.exp) =
+ case #1 e of
+ L'.ESome (_, ds) => strcat [str "execD(",
+ (L'.EJavaScript (L'.Script, ds), loc),
+ str ")"]
+ | _ => str "null"
+ in
+ SOME (strcat [str "<script type=\"text/javascript\">bodyDynClass(",
+ jsify dynClass,
+ str ",",
+ jsify dynStyle,
+ str ")</script>"])
+ end
+ else
+ NONE)
| _ => (attrs, NONE)
- val (class, fm) = monoExp (env, st, fm) class
- val (dynClass, fm) = monoExp (env, st, fm) dynClass
- val (style, fm) = monoExp (env, st, fm) style
- val (dynStyle, fm) = monoExp (env, st, fm) dynStyle
-
val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"]
fun isSome (e, _) =
@@ -3825,10 +3847,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| "tabl" => normal ("table", NONE)
| _ => normal (tag, NONE)
+
+ val (dynClass', dynStyle') =
+ case tag of
+ "body" => ((L'.ENone dummyTyp, ErrorMsg.dummySpan),
+ (L'.ENone dummyTyp, ErrorMsg.dummySpan))
+ | _ => (dynClass, dynStyle)
in
- case #1 dynClass of
+ case #1 dynClass' of
L'.ENone _ =>
- (case #1 dynStyle of
+ (case #1 dynStyle' of
L'.ENone _ => baseAll
| L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"",
str (pnode ()),
@@ -3842,7 +3870,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
baseAll))
| L'.ESome (_, dc) =>
let
- val e = case #1 dynStyle of
+ val e = case #1 dynStyle' of
L'.ENone _ => str "null"
| L'.ESome (_, ds) => strcat [str "execD(",
(L'.EJavaScript (L'.Script, ds), loc),
diff --git a/src/settings.sml b/src/settings.sml
index 19ee0b4a..b61759c1 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -176,10 +176,13 @@ val benignBase = basis ["get_cookie",
"spawn",
"onClick",
"onDblclick",
+ "onContextmenu",
"onKeydown",
"onKeypress",
"onKeyup",
"onMousedown",
+ "onMouseenter",
+ "onMouseleave",
"onMousemove",
"onMouseout",
"onMouseover",
@@ -212,11 +215,14 @@ val clientBase = basis ["get_client_source",
"mouseEvent",
"keyEvent",
"onClick",
+ "onContextmenu",
"onDblclick",
"onKeydown",
"onKeypress",
"onKeyup",
"onMousedown",
+ "onMouseenter",
+ "onMouseleave",
"onMousemove",
"onMouseout",
"onMouseover",
@@ -349,11 +355,14 @@ val jsFuncsBase = basisM [("alert", "alert"),
("onClick", "uw_onClick"),
+ ("onContextmenu", "uw_onContextmenu"),
("onDblclick", "uw_onDblclick"),
("onKeydown", "uw_onKeydown"),
("onKeypress", "uw_onKeypress"),
("onKeyup", "uw_onKeyup"),
("onMousedown", "uw_onMousedown"),
+ ("onMouseenter", "uw_onMouseenter"),
+ ("onMouseleave", "uw_onMouseleave"),
("onMousemove", "uw_onMousemove"),
("onMouseout", "uw_onMouseout"),
("onMouseover", "uw_onMouseover"),
@@ -764,7 +773,7 @@ fun mangleSqlTable s =
fun mangleSql s =
if #name (currentDbms ()) = "mysql" then
if !mangle then
- "uw_" ^ allLower s
+ "uw_" ^ allLower s
else
allLower s
else
@@ -867,7 +876,7 @@ fun setFilePath path = filePath := path
fun addFile {Uri, LoadFromFilename} =
let
- val path = OS.Path.joinDirFile {dir = !filePath, file = LoadFromFilename}
+ val path = OS.Path.mkAbsolute {relativeTo = !filePath, path = LoadFromFilename}
in
case SM.find (!files, Uri) of
SOME (path', _) =>
diff --git a/src/urweb.grm b/src/urweb.grm
index 56e6d2ac..7fc34793 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -216,6 +216,14 @@ fun native_op (oper, e1, e2, loc) =
(EApp (e, e2), loc)
end
+fun top_binop (oper, e1, e2, loc) =
+ let
+ val e = (EVar (["Top"], oper, Infer), loc)
+ val e = (EApp (e, e1), loc)
+ in
+ (EApp (e, e2), loc)
+ end
+
val inDml = ref false
fun tagIn bt =
@@ -395,6 +403,8 @@ fun patternOut (e : exp) =
| CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
| JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL
| CIF | CTHEN | CELSE
+ | FWDAPP | REVAPP | COMPOSE | ANDTHEN
+ | BACKTICK_PATH of string
%nonterm
file of decl list
@@ -565,6 +575,12 @@ fun patternOut (e : exp) =
%right CAND
%nonassoc EQ NE LT LE GT GE IS
%right ARROW
+
+%left REVAPP
+%right FWDAPP
+%left BACKTICK_PATH
+%right COMPOSE ANDTHEN
+
%right CARET PLUSPLUS
%left MINUSMINUS MINUSMINUSMINUS
%left PLUS MINUS
@@ -1202,6 +1218,22 @@ eexp : eapps (case #1 eapps of
| eexp GT eexp (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right)))
| eexp GE eexp (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right)))
+ | eexp FWDAPP eexp (EApp (eexp1, eexp2), s (eexp1left, eexp2right))
+ | eexp REVAPP eexp (EApp (eexp2, eexp1), s (eexp1left, eexp2right))
+ | eexp COMPOSE eexp (top_binop ("compose", eexp1, eexp2, s (eexp1left, eexp2right)))
+ | eexp ANDTHEN eexp (top_binop ("compose", eexp2, eexp1, s (eexp1left, eexp2right)))
+ | eexp BACKTICK_PATH eexp (let
+ val path = String.tokens (fn ch => ch = #".") BACKTICK_PATH
+ val pathModules = List.take (path, (length path -1))
+ val pathOp = List.last path
+
+ val e = (EVar (pathModules, pathOp, Infer)
+ , s (BACKTICK_PATHleft, BACKTICK_PATHright))
+ val e = (EApp (e, eexp1), s (eexp1left, BACKTICK_PATHright))
+ in
+ (EApp (e, eexp2), s (eexp1left, eexp2right))
+ end)
+
| eexp ANDALSO eexp (let
val loc = s (eexp1left, eexp2right)
in
diff --git a/src/urweb.lex b/src/urweb.lex
index 195fd735..e1ffd1c3 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -182,6 +182,7 @@ cid = [A-Z][A-Za-z0-9_]*;
ws = [\ \t\012\r];
intconst = [0-9]+;
realconst = [0-9]+\.[0-9]*;
+hexconst = 0x[0-9A-F]{1,8};
notags = ([^<{\n(]|(\([^\*<{\n]))+;
xcom = ([^\-]|(-[^\-]))+;
oint = [0-9][0-9][0-9];
@@ -376,6 +377,15 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
<INITIAL> "&&" => (Tokens.ANDALSO (pos yypos, pos yypos + size yytext));
<INITIAL> "||" => (Tokens.ORELSE (pos yypos, pos yypos + size yytext));
+<INITIAL> "<<<" => (Tokens.COMPOSE (pos yypos, pos yypos + size yytext));
+<INITIAL> ">>>" => (Tokens.ANDTHEN (pos yypos, pos yypos + size yytext));
+<INITIAL> "<|" => (Tokens.FWDAPP (pos yypos, pos yypos + size yytext));
+<INITIAL> "|>" => (Tokens.REVAPP (pos yypos, pos yypos + size yytext));
+
+<INITIAL> "`" ({cid} ".")* {id} "`" => (Tokens.BACKTICK_PATH ( (* strip backticks *)
+ substring (yytext,1,size yytext -2),
+ pos yypos, pos yypos + size yytext));
+
<INITIAL> "=" => (Tokens.EQ (pos yypos, pos yypos + size yytext));
<INITIAL> "<>" => (Tokens.NE (pos yypos, pos yypos + size yytext));
<INITIAL> "<" => (Tokens.LT (pos yypos, pos yypos + size yytext));
@@ -532,6 +542,12 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
<INITIAL> {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
<INITIAL> {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
+<INITIAL> {hexconst} => (case StringCvt.scanString (Int64.scan StringCvt.HEX) (String.extract (yytext, 2, NONE)) of
+ SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
+ | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos)
+ ("Expected hexInt, received: " ^ yytext);
+ continue ()));
+
<INITIAL> {intconst} => (case Int64.fromString yytext of
SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
| NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos)
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-29 11:18:06 +0000