From bfc7faaf3b8cdff7ca6baec6b3358aef531eb9e2 Mon Sep 17 00:00:00 2001 From: Artyom Shalkhakov Date: Tue, 7 Mar 2017 13:47:55 +0000 Subject: Adding support for emitting JS to a given file. --- src/settings.sml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'src/settings.sml') diff --git a/src/settings.sml b/src/settings.sml index 70ea1861..9fdc2232 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -951,6 +951,10 @@ fun addJsFile LoadFromFilename = fun listJsFiles () = SM.listItems (!jsFiles) +val jsOutput = ref (NONE : string option) +fun setOutputJsFile so = jsOutput := so +fun getOutputJsFile () = !jsOutput + fun reset () = (Globals.setResetTime (); urlPrefixFull := "/"; @@ -996,6 +1000,7 @@ fun reset () = mimeTypes := NONE; files := SM.empty; jsFiles := SM.empty; - filePath := ".") + filePath := "."; + jsOutput := NONE) end -- cgit v1.2.3 From ab29028d5fa3aa14e043fa133e481fe2c165eca1 Mon Sep 17 00:00:00 2001 From: Vladimir Shabanov Date: Thu, 15 Jun 2017 18:02:48 +0300 Subject: Option to prefix all user JavaScript FFI functions with a module name (jsModule .urp option). --- src/compiler.sig | 1 + src/compiler.sml | 15 ++++++++++++++- src/demo.sml | 7 ++++--- src/settings.sig | 1 + src/settings.sml | 12 +++++++++--- 5 files changed, 29 insertions(+), 7 deletions(-) (limited to 'src/settings.sml') diff --git a/src/compiler.sig b/src/compiler.sig index a4b3e562..952c7070 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -48,6 +48,7 @@ signature COMPILER = sig benignEffectful : Settings.ffi list, clientOnly : Settings.ffi list, serverOnly : Settings.ffi list, + jsModule : string option, jsFuncs : (Settings.ffi * string) list, rewrites : Settings.rewrite list, filterUrl : Settings.rule list, diff --git a/src/compiler.sml b/src/compiler.sml index 3e08fcc6..c13de304 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -52,6 +52,7 @@ type job = { benignEffectful : Settings.ffi list, clientOnly : Settings.ffi list, serverOnly : Settings.ffi list, + jsModule : string option, jsFuncs : (Settings.ffi * string) list, rewrites : Settings.rewrite list, filterUrl : Settings.rule list, @@ -273,7 +274,7 @@ val parseUr = { fun p_job ({prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers, scripts, - clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) = + clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) = let open Print.PD open Print @@ -312,6 +313,9 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile, p_ffi "BenignEffectful" benignEffectful, p_ffi "ClientOnly" clientOnly, p_ffi "ServerOnly" serverOnly, + case jsModule of + NONE => string "No JavaScript FFI module" + | SOME m => string ("JavaScript FFI module: " ^ m), p_list_sep (box []) (fn ((m, s), s') => box [string "JsFunc", space, string m, string ".", string s, space, string "=", space, string s', newline]) jsFuncs, @@ -368,6 +372,7 @@ fun institutionalizeJob (job : job) = Settings.setBenignEffectful (#benignEffectful job); Settings.setClientOnly (#clientOnly job); Settings.setServerOnly (#serverOnly job); + Settings.setJsModule (#jsModule job); Settings.setJsFuncs (#jsFuncs job); Settings.setRewriteRules (#rewrites job); Settings.setUrlRules (#filterUrl job); @@ -445,6 +450,7 @@ fun parseUrp' accLibs fname = benignEffectful = [], clientOnly = [], serverOnly = [], + jsModule = NONE, jsFuncs = [], rewrites = [{pkind = Settings.Any, kind = Settings.Prefix, @@ -579,6 +585,7 @@ fun parseUrp' accLibs fname = val benignEffectful = ref [] val clientOnly = ref [] val serverOnly = ref [] + val jsModule = ref NONE val jsFuncs = ref [] val rewrites = ref [] val url = ref [] @@ -616,6 +623,7 @@ fun parseUrp' accLibs fname = benignEffectful = rev (!benignEffectful), clientOnly = rev (!clientOnly), serverOnly = rev (!serverOnly), + jsModule = !jsModule, jsFuncs = rev (!jsFuncs), rewrites = rev (!rewrites), filterUrl = rev (!url), @@ -674,6 +682,7 @@ fun parseUrp' accLibs fname = benignEffectful = #benignEffectful old @ #benignEffectful new, clientOnly = #clientOnly old @ #clientOnly new, serverOnly = #serverOnly old @ #serverOnly new, + jsModule = #jsModule old, jsFuncs = #jsFuncs old @ #jsFuncs new, rewrites = #rewrites old @ #rewrites new, filterUrl = #filterUrl old @ #filterUrl new, @@ -809,6 +818,10 @@ fun parseUrp' accLibs fname = | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful | "clientOnly" => clientOnly := ffiS () :: !clientOnly | "serverOnly" => serverOnly := ffiS () :: !serverOnly + | "jsModule" => + (case !jsModule of + NONE => jsModule := SOME arg + | SOME _ => ()) | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs | "rewrite" => let diff --git a/src/demo.sml b/src/demo.sml index 47d22395..62b9037a 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -111,6 +111,7 @@ fun make' {prefix, dirname, guided} = benignEffectful = [], clientOnly = [], serverOnly = [], + jsModule = NONE, jsFuncs = [], rewrites = #rewrites combined @ #rewrites urp, filterUrl = #filterUrl combined @ #filterUrl urp, @@ -280,7 +281,7 @@ fun make' {prefix, dirname, guided} = val (urpData, out) = startUrp urp in finished (); - + SOME (readUrp (urpData, out)) end @@ -399,7 +400,7 @@ fun make' {prefix, dirname, guided} = case #kind rule of Settings.Exact => () | Settings.Prefix => TextIO.output (outf, "*"); - TextIO.output (outf, "\n"))) + TextIO.output (outf, "\n"))) in Option.app (fn db => (TextIO.output (outf, "database "); TextIO.output (outf, db); diff --git a/src/settings.sig b/src/settings.sig index 0ae81b13..256a12b5 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -96,6 +96,7 @@ signature SETTINGS = sig val isServerOnly : ffi -> bool (* Which FFI functions may be run in JavaScript? (JavaScript function names included) *) + val setJsModule : string option -> unit val setJsFuncs : (ffi * string) list -> unit val addJsFunc : ffi * string -> unit val jsFunc : ffi -> string option diff --git a/src/settings.sml b/src/settings.sml index 9fdc2232..7ae4bf85 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -346,7 +346,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("asin", "asin"), ("acos", "acos"), ("atan", "atan"), - ("atan2", "atan2"), + ("atan2", "atan2"), ("abs", "abs"), ("now", "now"), @@ -395,9 +395,15 @@ val jsFuncsBase = basisM [("alert", "alert"), ("htmlifySpecialChar", "htmlifySpecialChar"), ("chr", "chr")] val jsFuncs = ref jsFuncsBase -fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls +val jsModule = ref NONE +fun setJsModule m = jsModule := m +fun jsFuncName f = + case !jsModule of + SOME m => m ^ "." ^ f + | NONE => f +fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, jsFuncName v)) jsFuncsBase ls fun jsFunc x = M.find (!jsFuncs, x) -fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v) +fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, jsFuncName v) fun allJsFuncs () = M.listItemsi (!jsFuncs) datatype pattern_kind = Exact | Prefix -- cgit v1.2.3 From 6d9522c001574db729262073cadb96c75f0f7c44 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 12 Jul 2017 16:23:51 -0400 Subject: Allow inexhaustive patterns for lefthand sides of top-level 'val' declarations --- doc/manual.tex | 4 +-- src/elaborate.sml | 69 +++++++++++++++++++++++++++++++++++++++--------- src/settings.sml | 2 +- src/source.sml | 2 +- src/source_print.sml | 10 ++++--- src/urweb.grm | 40 ++++++++++++++++++++++++---- tests/topLevelPattern.ur | 5 ++++ 7 files changed, 107 insertions(+), 25 deletions(-) create mode 100644 tests/topLevelPattern.ur (limited to 'src/settings.sml') diff --git a/doc/manual.tex b/doc/manual.tex index 3d73b948..eaf7aab5 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -555,7 +555,7 @@ $$\begin{array}{rrcll} &&& \_ & \textrm{wildcard} \\ &&& (e) & \textrm{explicit precedence} \\ \\ - \textrm{Local declarations} & ed &::=& \cd{val} \; x : \tau = e & \textrm{non-recursive value} \\ + \textrm{Local declarations} & ed &::=& \cd{val} \; p = e & \textrm{non-recursive value} \\ &&& \cd{val} \; \cd{rec} \; (x : \tau = e \; \cd{and})^+ & \textrm{mutually recursive values} \\ \end{array}$$ @@ -566,7 +566,7 @@ $$\begin{array}{rrcll} \textrm{Declarations} & d &::=& \mt{con} \; x :: \kappa = c & \textrm{constructor synonym} \\ &&& \mt{datatype} \; x \; x^* = dc\mid^+ & \textrm{algebraic datatype definition} \\ &&& \mt{datatype} \; x = \mt{datatype} \; M.x & \textrm{algebraic datatype import} \\ - &&& \mt{val} \; x : \tau = e & \textrm{value} \\ + &&& \mt{val} \; p = e & \textrm{value} \\ &&& \mt{val} \; \cd{rec} \; (x : \tau = e \; \mt{and})^+ & \textrm{mutually recursive values} \\ &&& \mt{structure} \; X : S = M & \textrm{module definition} \\ &&& \mt{signature} \; X = S & \textrm{signature definition} \\ diff --git a/src/elaborate.sml b/src/elaborate.sml index 6965adfd..4a04d4bf 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2489,6 +2489,15 @@ fun queryOf () = (L'.CModProj (!basis_r, [], "sql_query"), ErrorMsg.dummySpan) fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan) +fun patVarsOf (p : L.pat) = + case #1 p of + L.PVar x => [x] + | L.PPrim _ => [] + | L.PCon (_, _, NONE) => [] + | L.PCon (_, _, SOME p) => patVarsOf p + | L.PRecord (xps, _) => ListUtil.mapConcat (fn (_, p) => patVarsOf p) xps + | L.PAnnot (p', _) => patVarsOf p' + fun dopenConstraints (loc, env, denv) {str, strs} = case E.lookupStr env str of NONE => (strError env (UnboundStr (loc, str)); @@ -3807,7 +3816,8 @@ and wildifyStr env (str, sgn) = foldl (fn ((d, _), nd) => case d of L.DCon (x, _, _) => ndelCon (nd, x) - | L.DVal (x, _, _) => ndelVal (nd, x) + | L.DVal (p, _) => + foldl (fn (x, nd) => ndelVal (nd, x)) nd (patVarsOf p) | L.DOpen _ => nempty | L.DStr (x, _, _, (L.StrConst ds', _), _) => (case SM.find (nmods nd, x) of @@ -3855,7 +3865,7 @@ and wildifyStr env (str, sgn) = | xs => let val ewild = (L.EWild, #2 str) - val ds'' = map (fn x => (L.DVal (x, NONE, ewild), #2 str)) xs + val ds'' = map (fn x => (L.DVal ((L.PVar x, #2 str), ewild), #2 str)) xs in ds'' @ ds' end @@ -4022,22 +4032,55 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = ([], (env, denv, []))) end) - | L.DVal (x, co, e) => + | L.DVal (p, e) => let - val (c', _, gs1) = case co of - NONE => (cunif env (loc, ktype), ktype, []) - | SOME c => elabCon (env, denv) c + val ((p', pt), (env', bound)) = elabPat (p, (env, SS.empty)) - val (e', et, gs2) = elabExp (env, denv) e + val (e', et, gs1) = elabExp (env, denv) e - val () = checkCon env e' et c' + val c' = normClassConstraint env et - val c' = normClassConstraint env c' - val (env', n) = E.pushENamed env x c' + fun singleVar (p : L.pat) = + case #1 p of + L.PVar x => SOME x + | L.PAnnot (p', _) => singleVar p' + | _ => NONE in - (*prefaces "DVal" [("x", Print.PD.string x), - ("c'", p_con env c')];*) - ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ gs)) + unifyCons env loc et pt; + + (case exhaustive (env, et, [p'], loc) of + NONE => () + | SOME p => if !mayDelay then + delayedExhaustives := (env, et, [p'], loc) :: !delayedExhaustives + else + expError env (Inexhaustive (loc, p))); + + case singleVar p of + SOME x => + let + val (env', n) = E.pushENamed env x et + in + ([(L'.DVal (x, n, c', e'), loc)], (env', denv, gs1 @ gs)) + end + | NONE => + let + val (env', n) = E.pushENamed env "$tmp" et + val vars = SS.listItems bound + val (decls, env') = + ListUtil.foldlMap (fn (x, env') => + let + val e = (L.ECase ((L.EVar ([], "$tmp", L.Infer), loc), + [(p, (L.EVar ([], x, L.Infer), loc))]), loc) + val (e', t, _) = elabExp (env', denv) e + val (env', n) = E.pushENamed env' x t + in + ((L'.DVal (x, n, t, e'), loc), + env') + end) env' vars + in + ((L'.DVal ("$tmp", n, c', e'), loc) :: decls, + (env', denv, gs1 @ gs)) + end end | L.DValRec vis => let diff --git a/src/settings.sml b/src/settings.sml index 7ae4bf85..a3263c06 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -395,7 +395,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("htmlifySpecialChar", "htmlifySpecialChar"), ("chr", "chr")] val jsFuncs = ref jsFuncsBase -val jsModule = ref NONE +val jsModule = ref (NONE : string option) fun setJsModule m = jsModule := m fun jsFuncName f = case !jsModule of diff --git a/src/source.sml b/src/source.sml index 9971ca93..2d8c1ed3 100644 --- a/src/source.sml +++ b/src/source.sml @@ -157,7 +157,7 @@ datatype decl' = DCon of string * kind option * con | DDatatype of (string * string list * (string * con option) list) list | DDatatypeImp of string * string list * string - | DVal of string * con option * exp + | DVal of pat * exp | DValRec of (string * con option * exp) list | DSgn of string * sgn | DStr of string * sgn option * Time.time option * str * bool (* did this module come from the '-root' directive? *) diff --git a/src/source_print.sml b/src/source_print.sml index 7b657422..e18a82f9 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -560,9 +560,13 @@ fun p_decl ((d, _) : decl) = string "datatype", space, p_list_sep (string ".") string (ms @ [x'])] - | DVal vi => box [string "val", - space, - p_vali vi] + | DVal (p, e) => box [string "val", + space, + p_pat p, + space, + string "=", + space, + p_exp e] | DValRec vis => box [string "val", space, string "rec", diff --git a/src/urweb.grm b/src/urweb.grm index db5473a6..2a3fe283 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -490,7 +490,7 @@ fun patternOut (e : exp) = | earga of exp * con -> exp * con | eargs of exp * con -> exp * con | eargl of exp * con -> exp * con - | eargl2 of exp * con -> exp * con + | eargl2 of bool * (exp * con -> exp * con) | branch of pat * exp | branchs of (pat * exp) list @@ -622,7 +622,37 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let (case dargs of [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))] | _ => raise Fail "Arguments specified for imported datatype") - | VAL vali ([(DVal vali, s (VALleft, valiright))]) + | VAL pat eargl2 copt EQ eexp (let + fun justVar (p : pat) = + case #1 p of + PVar x => SOME x + | PAnnot (p', _) => justVar p' + | _ => NONE + + val loc = s (VALleft, eexpright) + in + case justVar pat of + SOME x => + let + val t = Option.getOpt (copt, (CWild (KType, loc), loc)) + val (e, t) = #2 eargl2 (eexp, t) + in + [(DVal (pat, e), loc)] + end + | NONE => + let + val pat = + case copt of + SOME t => (PAnnot (pat, t), loc) + | _ => pat + in + (if #1 eargl2 then + ErrorMsg.errorAt loc "Additional arguments not allowed after pattern" + else + ()); + [(DVal (pat, eexp), loc)] + end + end) | VAL REC valis ([(DValRec valis, s (VALleft, valisright))]) | FUN valis ([(DValRec valis, s (FUNleft, valisright))]) @@ -695,7 +725,7 @@ vali : SYMBOL eargl2 copt EQ eexp (let val loc = s (SYMBOLleft, eexpright) val t = Option.getOpt (copt, (CWild (KType, loc), loc)) - val (e, t) = eargl2 (eexp, t) + val (e, t) = #2 eargl2 (eexp, t) in (SYMBOL, SOME t, e) end) @@ -1279,8 +1309,8 @@ eargs : earg (earg) eargl : eargp eargp (eargp1 o eargp2) | eargp eargl (eargp o eargl) -eargl2 : (fn x => x) - | eargp eargl2 (eargp o eargl2) +eargl2 : (false, fn x => x) + | eargp eargl2 (true, eargp o #2 eargl2) earg : patS (fn (e, t) => let diff --git a/tests/topLevelPattern.ur b/tests/topLevelPattern.ur new file mode 100644 index 00000000..e272c30c --- /dev/null +++ b/tests/topLevelPattern.ur @@ -0,0 +1,5 @@ +val (x, y) = (1, 2) + +fun main () : transaction page = return + {[x]} + {[y]} = {[x + y]} + -- cgit v1.2.3