diff options
157 files changed, 9027 insertions, 957 deletions
@@ -0,0 +1 @@ +eval "$(lorri direnv)" diff --git a/.travis.yml b/.travis.yml index df4e4abc..c9fb6537 100644 --- a/.travis.yml +++ b/.travis.yml @@ -18,11 +18,13 @@ compiler: before_install: - export CONFIGURE_ARGS="" - if command -v apt-get &>/dev/null; then sudo apt-get update -qq; fi - - if command -v apt-get &>/dev/null; then sudo apt-get install -y mlton; fi + - if command -v apt-get &>/dev/null; then sudo apt-get install -y mlton libicu-dev; fi - if command -v brew &>/dev/null; then brew update; fi - - if command -v brew &>/dev/null; then brew uninstall libtool; fi - - if command -v brew &>/dev/null; then brew install libtool; fi - - if command -v brew &>/dev/null; then brew install openssl mlton; fi + - if command -v brew &>/dev/null; then brew upgrade libtool; fi + - if command -v brew &>/dev/null; then brew install openssl mlton icu4c; fi + - if command -v brew &>/dev/null; then export ICU_INCLUDES=-I"`brew --prefix icu4c`/include"; fi + - if command -v brew &>/dev/null; then export ICU_LIBS=-L"`brew --prefix icu4c`/lib"; fi - if command -v brew &>/dev/null; then export CONFIGURE_ARGS="--with-openssl=/usr/local/opt/openssl"; fi + script: ./autogen.sh && ./configure $CONFIGURE_ARGS && make && make test @@ -1,4 +1,36 @@ ======== +20200209 +======== + +- New invocation mode 'urweb daemon restart' +- Disallow wildcards in signatures +- At compile time, start allowing "#" as a URL +- New option '-u' for generated HTTP servers, to use UNIX sockets +- New HTML tag attribute: 'step' (for <crange>) +- New SQL function: 'similar' (via pg_trgm) +- New List function: foldli +- New Json functions: json_record_withOptional, json_time, rfc3339_in, rfc3339_out +- New Datetime member: ord_month +- New JavaScript FFI function 'listen' +- Experimental support for the Language Server Protocol (helpful for IDEs) +- Bug fixes and improvements to documentation, error messages, performance, and compatibility + +======== +20190217 +======== + +- Update of standard-library string functions to handle non-ASCII UTF-8 properly +- New command-line options: -endpoints +- New .urp directive: safeGetDefault +- New Basis functions: textOfBlob, unsafeSerialized[To|From]String +- New Top functions: mapX4, foldR4 +- New List functions: allM, assocAddSorted, mapConcat, mapConcatM, mapMi, searchM +- New ListPair functions: mapM, unzip +- New Option function: mapM +- Flycheck integration +- Bug fixes and improvements to type inference, documentation, error messages, and compatibility + +======== 20180616 ======== diff --git a/Makefile.am b/Makefile.am index f0392de0..0aba6781 100644 --- a/Makefile.am +++ b/Makefile.am @@ -112,9 +112,16 @@ uninstall-local-main: uninstall-local: uninstall-local-main uninstall-emacs -EXTRA_DIST = demo doc lib/js lib/ur xml \ +EXTRA_DIST = demo/prose demo/*.urs demo/*.ur demo/*.urp demo/more/prose demo/more/*.urs demo/more/*.ur demo/more/*.urp \ + doc/Makefile doc/*.tex doc/*.ur doc/LICENSE lib/js \ + lib/ur/*.urs lib/ur/*.ur xml/parse.sml xml/*.ent \ src/coq src/*.sig src/*.sml src/*.mlb src/config.sml.in src/elisp src/*.cm src/sources src/*.grm src/*.lex \ - CHANGELOG LICENSE urweb.ebuild include/urweb/*.h bin + CHANGELOG LICENSE urweb.ebuild include/urweb/*.h tests/*.html + +dist-hook: + cd src; rm -f urweb.mlton.lex urweb.mlton.grm *.lex.* *.grm.* + cd demo; rm -f demo.ur* + cd demo/more; rm -f demo.ur* TESTDB = /tmp/urweb.db TESTPID = /tmp/urweb.pid diff --git a/configure.ac b/configure.ac index 44c6873f..1bd7fd3b 100644 --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([urweb], [20180616]) +AC_INIT([urweb], [20200209]) WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS @@ -91,6 +91,20 @@ if test [-z $SQHEADER]; then SQHEADER=sqlite3.h fi +if test [-z $ICU_INCLUDES]; then + ICU_INCLUDES= +fi + +CPPFLAGS=$ICU_INCLUDES$CPPFLAGS + +if test [-z $ICU_LIBS]; then + ICU_LIBS= +fi + +AC_CHECK_HEADERS([unicode/utypes.h], + [], + [echo "You must install ICU."; exit 1]) + if test [$WORKING_VERSION = "1"]; then VERSION="$VERSION + `git log -1 --format="%H" || echo ?`" fi @@ -111,6 +125,8 @@ pthread_t a; AC_MSG_RESULT(yes), AC_MSG_RESULT(no)) +AC_CHECK_FUNCS_ONCE([memmem]) + AC_SUBST(CC) AC_SUBST(BIN) AC_SUBST(LIB) @@ -125,6 +141,8 @@ AC_SUBST(SQHEADER) AC_SUBST(VERSION) AC_SUBST(PTHREAD_CFLAGS) AC_SUBST(PTHREAD_LIBS) +AC_SUBST(ICU_INCLUDES) +AC_SUBST(ICU_LIBS) AC_CONFIG_FILES([ Makefile @@ -148,6 +166,8 @@ Ur/Web configuration: Postgres C header: PGHEADER $PGHEADER MySQL C header: MSHEADER $MSHEADER SQLite C header: SQHEADER $SQHEADER + ICU includes: ICU_INCLUDES $ICU_INCLUDES + ICU libs: ICU_LIBS $ICU_LIBS OpenSSL: OPENSSL_LIBS $OPENSSL_LIBS pthreads: PTHREAD_CFLAGS $PTHREAD_CFLAGS PTHREAD_LIBS $PTHREAD_LIBS diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..ba9eed30 --- /dev/null +++ b/default.nix @@ -0,0 +1,9 @@ +let + pinnedNixpkgs = import (builtins.fetchTarball { + name = "pinned-nixpkgs-for-urweb-school"; + url = https://github.com/NixOS/nixpkgs/archive/5a8bfc98a23669f71596d079df20730ccdfdf04b.tar.gz; + # Hash obtained using `nix-prefetch-url --unpack <url>` + sha256 = "15qbfjjw5ak1bpiq36s0y9iq3j45azmb8nz06fpx4dgkg32i8fm5"; + }) {}; +in +{pkgs ? pinnedNixpkgs}: pkgs.callPackage ./derivation.nix {} diff --git a/demo/nested.ur b/demo/nested.ur index 31c9e1e8..5c9cd3cc 100644 --- a/demo/nested.ur +++ b/demo/nested.ur @@ -45,7 +45,7 @@ and fromA r = </head> <body> <p>Hello {[forename]}{case surname of - None => <xml/> + None => <xml></xml> | Some s => <xml> {[s]}</xml>}</p> {case surname of None => <xml><a link={pageA ()}>Previous</a></xml> @@ -59,4 +59,4 @@ and fromA r = pageC None end -val main = pageA +fun main () = pageA () @@ -5,12 +5,13 @@ <h6>Install System Dependencies</h6> <p> -<blockquote><pre>sudo apt-get install build-essential \ +<blockquote><pre>sudo apt install build-essential \ emacs-goodies-el \ libgmp-dev \ libssl-dev \ libpq-dev \ libsqlite3-dev \ + libicu-dev \ mlton \ sqlite3</blockquote></pre></p> diff --git a/derivation.nix b/derivation.nix new file mode 100644 index 00000000..e197372e --- /dev/null +++ b/derivation.nix @@ -0,0 +1,56 @@ +{ stdenv, lib, fetchFromGitHub, file, openssl, mlton +, mysql, postgresql, sqlite, gcc +, automake, autoconf, libtool, icu, nix-gitignore +}: + +stdenv.mkDerivation rec { + name = "urweb-${version}"; + version = "2018-06-22"; + + # src = fetchurl { + # url = "http://www.impredicative.com/ur/${name}.tgz"; + # sha256 = "17qh9mcmlhbv6r52yij8l9ik7j7x6x7c09lf6pznnbdh4sf8p5wb"; + # }; + + # src = fetchFromGitHub { + # owner = "FrigoEU"; + # repo = "urweb"; + # rev = "e52ce9f542f64750941cfd84efdb6d993ee20ff0"; + # sha256 = "19ba5n7g1dxy7q9949aakqplchsyzwrrnxv8v604vx5sg7fdfn3b"; + # }; + src = ./.; + + buildInputs = [ openssl mlton mysql.connector-c postgresql sqlite automake autoconf libtool icu.dev openssl.dev]; + + # prePatch = '' + # sed -e 's@/usr/bin/file@${file}/bin/file@g' -i configure + # ''; + + configureFlags = "--with-openssl=${openssl.dev}"; + + preConfigure = '' + ./autogen.sh + export PGHEADER="${postgresql}/include/libpq-fe.h"; + export MSHEADER="${mysql.connector-c}/include/mysql/mysql.h"; + export SQHEADER="${sqlite.dev}/include/sqlite3.h"; + export CC="${gcc}/bin/gcc"; + export CCARGS="-I$out/include \ + -I${icu.dev}/include \ + -L${openssl.out}/lib \ + -L${mysql.connector-c}/lib \ + -L${postgresql.lib}/lib \ + -L${sqlite.out}/lib \ + -L${icu.out}/lib"; + ''; + + # Be sure to keep the statically linked libraries + dontDisableStatic = true; + + meta = { + description = "Advanced purely-functional web programming language"; + homepage = "http://www.impredicative.com/ur/"; + license = stdenv.lib.licenses.bsd3; + platforms = stdenv.lib.platforms.linux ++ stdenv.lib.platforms.darwin; + maintainers = [ stdenv.lib.maintainers.thoughtpolice stdenv.lib.maintainers.sheganinans ]; + }; +} diff --git a/doc/manual.tex b/doc/manual.tex index 857539db..b1ac0041 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -59,9 +59,9 @@ make sudo make install \end{verbatim} -Some other packages must be installed for the above to work. At a minimum, you need a standard UNIX shell, with standard UNIX tools like sed and GCC (or an alternate C compiler) in your execution path; MLton, the whole-program optimizing compiler for Standard ML; and the development files for the OpenSSL C library. As of this writing, in the ``testing'' version of Debian Linux, this command will install the more uncommon of these dependencies: +Some other packages must be installed for the above to work. At a minimum, you need a standard UNIX shell, with standard UNIX tools like sed and GCC (or an alternate C compiler) in your execution path; MLton, the whole-program optimizing compiler for Standard ML; and the development files for the OpenSSL C library and the ICU C library. As of this writing, in the ``testing'' version of Debian Linux, this command will install the more uncommon of these dependencies: \begin{verbatim} -apt-get install mlton libssl-dev +apt-get install mlton libssl-dev libicu-dev \end{verbatim} Note that, like the Ur/Web compiler, MLton is a whole-program optimizing compiler, so it frequently requires much more memory than old-fashioned compilers do. Expect building Ur/Web with MLton to require not much less than a gigabyte of RAM. If a \texttt{mlton} invocation ends suspiciously, the most likely explanation is that it has exhausted available memory. @@ -190,6 +190,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{profile} generates an executable that may be used with gprof. \item \texttt{rewrite KIND FROM TO} gives a rule for rewriting canonical module paths. For instance, the canonical path of a page may be \texttt{Mod1.Mod2.mypage}, while you would rather the page were accessed via a URL containing only \texttt{page}. The directive \texttt{rewrite url Mod1/Mod2/mypage page} would accomplish that. The possible values of \texttt{KIND} determine which kinds of objects are affected. The kind \texttt{all} matches any object, and \texttt{url} matches page URLs. The kinds \texttt{table}, \texttt{sequence}, and \texttt{view} match those sorts of SQL entities, and \texttt{relation} matches any of those three. \texttt{cookie} matches HTTP cookies, and \texttt{style} matches CSS class names. If \texttt{FROM} ends in \texttt{/*}, it is interpreted as a prefix matching rule, and rewriting occurs by replacing only the appropriate prefix of a path with \texttt{TO}. The \texttt{TO} field may be left empty to express the idea of deleting a prefix. For instance, \texttt{rewrite url Main/*} will strip all \texttt{Main/} prefixes from URLs. While the actual external names of relations and styles have parts separated by underscores instead of slashes, all rewrite rules must be written in terms of slashes. An optional suffix of \cd{[-]} for a \cd{rewrite} directive asks to additionally replace all \cd{\_} characters with \cd{-} characters, which can be handy for, e.g., interfacing with an off-the-shelf CSS library that prefers hyphens over underscores. \item \texttt{safeGet URI} asks to allow the page handler assigned this canonical URI prefix to cause persistent side effects, even if accessed via an HTTP \cd{GET} request. +\item \texttt{safeGetDefault} asks to allow \emph{any} page handler to cause side effects, even if accessed via an HTTP \cd{GET} request. \item \texttt{script URL} adds \texttt{URL} to the list of extra JavaScript files to be included at the beginning of any page that uses JavaScript. This is most useful for importing JavaScript versions of functions found in new FFI modules. \item \texttt{serverOnly Module.ident} registers an FFI function or transaction that may only be run on the server. \item \texttt{sigfile PATH} sets a path where your application should look for a key to use in cryptographic signing. This is used to prevent cross-site request forgery attacks for any form handler that both reads a cookie and creates side effects. If the referenced file doesn't exist, an application will create it and read its saved data on future invocations. You can also initialize the file manually with any contents at least 16 bytes long; the first 16 bytes will be treated as the key. @@ -237,8 +238,27 @@ Further \cd{urweb} invocations in the same working directory will send requests \begin{verbatim} urweb daemon stop \end{verbatim} +To restart a running (or crashed) daemon, run +\begin{verbatim} +urweb daemon restart +\end{verbatim} Communication happens via a UNIX domain socket in file \cd{.urweb\_daemon} in the working directory. +Bundled with the compiler is an LSP or Language Server Protocol server. This is a program that allows various editors to request information about Ur/Web code via a standardized messaging protocol. The Ur/Web LSP server currently provides basic implementations for autocompletion, hover and compiler errors. The server is started by running +\begin{verbatim} +urweb -startLspServer +\end{verbatim} +Currently there are no prebuilt editor plugins to register this server with your editor of choice but it should be fairly simple to do so. For example in Emacs using the lsp-mode, all you need to make this work is the following configuration (assuming you use the urweb-mode bundled with the compiler): +\begin{verbatim} +(require 'lsp) +(setq lsp-language-id-configuration '((urweb-mode . "urweb"))) +(lsp-register-client + (make-lsp-client :new-connection (lsp-stdio-connection '("urweb" "-startLspServer")) + :major-modes '(urweb-mode) + :server-id 'urweb-lsp)) +\end{verbatim} +Note that to keep the server responsive we don't compile Ur/Web code in the traditional way. Rather, we use only the .urs files (or if applicable .ur files that only contain valid .urs statements) for modules that are not currently being edited. That's why the LSP server requires .urs files for all of your modules. + \medskip Some other command-line parameters are accepted: @@ -277,6 +297,8 @@ sqlite3 path/to/database/file <app.sql \item \texttt{-dumpSource}: When compilation fails, output to stderr the complete source code of the last intermediate program before the compilation phase that signaled the error. (Warning: these outputs can be very long and aren't especially optimized for readability!) +\item \texttt{-endpoints FILENAME}: Populate the specified file with a JSON description of all the HTTP endpoints that the compiled application supports, with information on MIME content type, for static resources. + \item \texttt{-explainEmbed}: Trigger more verbose error messages about inability to embed server-side values in client-side code. \item \texttt{-js FILENAME}: Ur/Web applications with client-side code link in generated JavaScript files, which, by default, are assigned random-looking names. Use this directive to override the filename chosen for the JavaScript code. Be forewarned that the default method uses a name based on hashing the code itself, which is done for a good reason: browsers are very eager to cache JavaScript code, and application changes may fail to propagate quickly to browsers if this filename stays the same between versions. In such cases, it isn't just that the user sees an old version of your application. Instead, the application runs with a mix of old and new files, leading to arbitrary bugs that Ur/Web prevents, when used properly. @@ -421,7 +443,7 @@ We give the Ur language definition in \LaTeX $\;$ math mode, since that is prett \end{tabular} \end{center} -We often write syntax like $e^*$ to indicate zero or more copies of $e$, $e^+$ to indicate one or more copies, and $e,^*$ and $e,^+$ to indicate multiple copies separated by commas. Another separator may be used in place of a comma. The $e$ term may be surrounded by parentheses to indicate grouping; those parentheses should not be included in the actual ASCII. +We often write syntax like $e^*$ to indicate zero or more copies of $e$, $e^+$ to indicate one or more copies, and $e,^*$ and $e,^+$ to indicate multiple copies separated by commas. Another separator may be used in place of a comma. When $e$ consists of multiple symbols, the $e$ term and separator (if any) are surrounded by parentheses to indicate grouping; those parentheses should not be included in the actual ASCII. We write $\ell$ for literals of the primitive types, for the most part following C conventions. There are $\mt{int}$, $\mt{float}$, $\mt{char}$, and $\mt{string}$ literals. Character literals follow the SML convention instead of the C convention, written like \texttt{\#"a"} instead of \texttt{'a'}. @@ -464,13 +486,13 @@ $$\begin{array}{rrcll} &&& c \; c & \textrm{type-level function application} \\ &&& \lambda x \; :: \; \kappa \Rightarrow c & \textrm{type-level function abstraction} \\ \\ - &&& X \Longrightarrow c & \textrm{type-level kind-polymorphic function abstraction} \\ &&& c [\kappa] & \textrm{type-level kind-polymorphic function application} \\ + &&& X \Longrightarrow c & \textrm{type-level kind-polymorphic function abstraction} \\ \\ &&& () & \textrm{type-level unit} \\ &&& \#X & \textrm{field name} \\ \\ - &&& [(c = c)^*] & \textrm{known-length type-level record} \\ + &&& [(c = c,)^*] & \textrm{known-length type-level record} \\ &&& c \rc c & \textrm{type-level record concatenation} \\ &&& \mt{map} & \textrm{type-level record map} \\ \\ @@ -550,10 +572,10 @@ $$\begin{array}{rrcll} \\ &&& \mt{let} \; ed^* \; \mt{in} \; e \; \mt{end} & \textrm{local definitions} \\ \\ - &&& \mt{case} \; e \; \mt{of} \; (p \Rightarrow e|)^+ & \textrm{pattern matching} \\ + &&& \mt{case} \; e \; \mt{of} \; (p \Rightarrow e\mid)^+ & \textrm{pattern matching} \\ \\ - &&& \lambda [c \sim c] \Rightarrow e & \textrm{guarded expression abstraction} \\ &&& e \; ! & \textrm{guarded expression application} \\ + &&& \lambda [c \sim c] \Rightarrow e & \textrm{guarded expression abstraction} \\ \\ &&& \_ & \textrm{wildcard} \\ &&& (e) & \textrm{explicit precedence} \\ @@ -600,7 +622,7 @@ There are a variety of derived syntactic forms that elaborate into the core synt In many contexts where record fields are expected, like in a projection $e.c$, a constant field may be written as simply $X$, rather than $\#X$. -A record type may be written $\{(c = c,)^*\}$, which elaborates to $\$[(c = c,)^*]$. +A record type may be written $\{(c : c,)^*\}$, which elaborates to $\$[(c = c,)^*]$. The notation $[c_1, \ldots, c_n]$ is shorthand for $[c_1 = (), \ldots, c_n = ()]$. @@ -622,7 +644,7 @@ A signature item or declaration $\mt{class} \; x = \lambda y \Rightarrow c$ may Handling of implicit and explicit constructor arguments may be tweaked with some prefixes to variable references. An expression $@x$ is a version of $x$ where all type class instance and disjointness arguments have been made explicit. (For the purposes of this paragraph, the type family $\mt{Top.folder}$ is a type class, though it isn't marked as one by the usual means; and any record type is considered to be a type class instance type when every field's type is a type class instance type.) An expression $@@x$ achieves the same effect, additionally making explicit all implicit constructor arguments. The default is that implicit arguments are inserted automatically after any reference to a variable, or after any application of a variable to one or more arguments. For such an expression, implicit wildcard arguments are added for the longest prefix of the expression's type consisting only of implicit polymorphism, type class instances, and disjointness obligations. The same syntax works for variables projected out of modules and for capitalized variables (datatype constructors). -At the expression level, an analogue is available of the composite $\lambda$ form for constructors. We define the language of binders as $b ::= p \mid [x] \mid [x \; ? \; \kappa] \mid X \mid [c \sim c]$. A lone variable $[x]$ stands for an implicit constructor variable of unspecified kind. The standard value-level function binder is recovered as the type-annotated pattern form $x : \tau$. It is a compile-time error to include a pattern $p$ that does not match every value of the appropriate type. +At the expression level, an analogue is available of the composite $\lambda$ form for constructors. We define the language of binders as $b ::= p \mid [x] \mid [x \; ? \; \kappa] \mid [X] \mid [c \sim c]$. A lone variable $[x]$ stands for an implicit constructor variable of unspecified kind. The standard value-level function binder is recovered as the type-annotated pattern form $x : \tau$. It is a compile-time error to include a pattern $p$ that does not match every value of the appropriate type. A local $\mt{val}$ declaration may bind a pattern instead of just a plain variable. As for function arguments, only irrefutable patterns are legal. @@ -745,10 +767,10 @@ $$\infer{\Gamma \vdash c_1 \; c_2 :: \kappa_2}{ }$$ $$\infer{\Gamma \vdash c[\kappa'] :: [X \mapsto \kappa']\kappa}{ - \Gamma \vdash c :: X \to \kappa + \Gamma \vdash c :: X \longrightarrow \kappa & \Gamma \vdash \kappa' } -\quad \infer{\Gamma \vdash X \Longrightarrow c :: X \to \kappa}{ +\quad \infer{\Gamma \vdash X \Longrightarrow c :: X \longrightarrow \kappa}{ \Gamma, X \vdash c :: \kappa }$$ @@ -775,7 +797,7 @@ $$\infer{\Gamma \vdash (\overline c) :: (\kappa_1 \times \ldots \times \kappa_n) \Gamma \vdash c :: (\kappa_1 \times \ldots \times \kappa_n) }$$ -$$\infer{\Gamma \vdash \lambda [c_1 \sim c_2] \Rightarrow \tau :: \mt{Type}}{ +$$\infer{\Gamma \vdash [c_1 \sim c_2] \Rightarrow \tau :: \mt{Type}}{ \Gamma \vdash c_1 :: \{\kappa\} & \Gamma \vdash c_2 :: \{\kappa'\} & \Gamma, c_1 \sim c_2 \vdash \tau :: \mt{Type} @@ -911,7 +933,7 @@ $$\infer{\Gamma \vdash e [\kappa] : [X \mapsto \kappa]\tau}{ \Gamma, X \vdash e : \tau }$$ -$$\infer{\Gamma \vdash \{\overline{c = e}\} : \{\overline{c : \tau}\}}{ +$$\infer{\Gamma \vdash \{\overline{c = e}\} : \$[\overline{c = \tau}]}{ \forall i: \Gamma \vdash c_i :: \mt{Name} & \Gamma \vdash e_i : \tau_i & \forall i \neq j: \Gamma \vdash c_i \sim c_j @@ -941,7 +963,7 @@ $$\infer{\Gamma \vdash \mt{let} \; \overline{ed} \; \mt{in} \; e \; \mt{end} : \ & \Gamma_i \vdash e_i : \tau }$$ -$$\infer{\Gamma \vdash \lambda [c_1 \sim c_2] \Rightarrow e : \lambda [c_1 \sim c_2] \Rightarrow \tau}{ +$$\infer{\Gamma \vdash \lambda [c_1 \sim c_2] \Rightarrow e : [c_1 \sim c_2] \Rightarrow \tau}{ \Gamma \vdash c_1 :: \{\kappa\} & \Gamma \vdash c_2 :: \{\kappa'\} & \Gamma, c_1 \sim c_2 \vdash e : \tau @@ -978,7 +1000,7 @@ $$\infer{\Gamma \vdash M.X \; p \leadsto \Gamma'; \overline{[x_i \mapsto \tau'_i & \Gamma \vdash p \leadsto \Gamma'; \overline{[x_i \mapsto \tau'_i]}\tau'' }$$ -$$\infer{\Gamma \vdash \{\overline{X = p}\} \leadsto \Gamma_n; \{\overline{X = \tau}\}}{ +$$\infer{\Gamma \vdash \{\overline{X = p}\} \leadsto \Gamma_n; \$[\overline{X = \tau}]}{ \Gamma_0 = \Gamma & \forall i: \Gamma_i \vdash p_i \leadsto \Gamma_{i+1}; \tau_i } @@ -1451,7 +1473,7 @@ Some operations are only allowed in server-side code or only in client-side code The Ur Basis defines the monad constructor class from Haskell. $$\begin{array}{l} - \mt{class} \; \mt{monad} :: \mt{Type} \to \mt{Type} \\ + \mt{class} \; \mt{monad} :: (\mt{Type} \to \mt{Type}) \to \mt{Type} \\ \mt{val} \; \mt{return} : \mt{m} ::: (\mt{Type} \to \mt{Type}) \to \mt{t} ::: \mt{Type} \\ \hspace{.1in} \to \mt{monad} \; \mt{m} \\ \hspace{.1in} \to \mt{t} \to \mt{m} \; \mt{t} \\ @@ -2102,7 +2124,7 @@ Configure the policy for meta names with the \texttt{allow} and \texttt{deny} \t Ur/Web supports running code on web browsers, via automatic compilation to JavaScript. -The concurrency model is \emph{cooperative multithreading}. Like with, say, POSIX threads, which uses the \emph{preemptive multithreading} model, there may be multiple threads of control active at a time. However, unlike with preemptive multithreading, the currently running thread gets to run interrupted until a well-defined \emph{context-switch} point. Specifically, four functions defined below are the context-switch points. They are $\mt{sleep}$, $\mt{rpc}$, $\mt{tryRpc}$, and $\mt{recv}$. (We explain their purposes as we come to them below.) Additional functions added via the foreign function interface might also have context-switching behavior. In any case, it is guaranteed that a running thread ``owns the processor'' until it calls a context-switching function, at which time we may switch to running a different thread instead. +The concurrency model is \emph{cooperative multithreading}. Like with, say, POSIX threads, which uses the \emph{preemptive multithreading} model, there may be multiple threads of control active at a time. However, unlike with preemptive multithreading, the currently running thread gets to run uninterrupted until a well-defined \emph{context-switch} point. Specifically, four functions defined below are the context-switch points. They are $\mt{sleep}$, $\mt{rpc}$, $\mt{tryRpc}$, and $\mt{recv}$. (We explain their purposes as we come to them below.) Additional functions added via the foreign function interface might also have context-switching behavior. In any case, it is guaranteed that a running thread ``owns the processor'' until it calls a context-switching function, at which time we may switch to running a different thread instead. This concurrency paradigm has many nice properties. For instance, there is almost never any need for locking or other synchronization between threads. @@ -2399,7 +2421,7 @@ A web application is built from a series of modules, with one module, the last o Elements of modules beside the main module, including page handlers, will only be included in the final application if they are transitive dependencies of the handlers in the main module. -Normal links are accessible via HTTP \texttt{GET}, which the relevant standard says should never cause side effects. To export a page which may cause side effects, accessible only via HTTP \texttt{POST}, include one argument of the page handler of type $\mt{Basis.postBody}$. When the handler is called, this argument will receive a value that can be deconstructed into a MIME type (with $\mt{Basis.postType}$) and payload (with $\mt{Basis.postData}$). This kind of handler should not be used with forms that exist solely within Ur/Web apps; for these, use Ur/Web's built-in support, as described below. It may still be useful to use $\mt{Basis.postBody}$ with form requests submitted by code outside an Ur/Web app. For such cases, the function $\mt{Top.postFields} : \mt{postBody} \to \mt{list} \; (\mt{string} \times \mt{string})$ may be useful, breaking a \texttt{POST} body of type \texttt{application/x-www-form-urlencoded} into its name-value pairs. +Normal links are accessible via HTTP \texttt{GET}, which the relevant standard says should never cause side effects. To export a page that may cause side effects, accessible only via HTTP \texttt{POST}, include one argument of the page handler of type $\mt{Basis.postBody}$. When the handler is called, this argument will receive a value that can be deconstructed into a MIME type (with $\mt{Basis.postType}$) and payload (with $\mt{Basis.postData}$). This kind of handler should not be used with forms that exist solely within Ur/Web apps; for these, use Ur/Web's built-in support, as described below. It may still be useful to use $\mt{Basis.postBody}$ with form requests submitted by code outside an Ur/Web app. For such cases, the function $\mt{Top.postFields} : \mt{postBody} \to \mt{list} \; (\mt{string} \times \mt{string})$ may be useful, breaking a \texttt{POST} body of type \texttt{application/x-www-form-urlencoded} into its name-value pairs. Any normal page handler may also include arguments of type $\mt{option \; Basis.queryString}$, which will be handled specially. Rather than being deserialized from the current URI, such an argument is passed the whole query string that the handler received. The string may be analyzed by calling $\mt{Basis.show}$ on it. A handler of this kind may be passed as an argument to $\mt{Basis.effectfulUrl}$ to generate a URL to a page that may be used as a ``callback'' by an external service, such that the handler is allowed to cause side effects. @@ -2418,9 +2440,7 @@ Ur/Web programs generally mix server- and client-side code in a fairly transpare \medskip -The HTTP standard suggests that GET requests only be used in ways that generate no side effects. Side effecting operations should use POST requests instead. The Ur/Web compiler enforces this rule strictly, via a simple conservative program analysis. Any page that may have a side effect must be accessed through a form, all of which use POST requests, or via a direct call to a page handler with some argument of type $\mt{Basis.postBody}$. A page is judged to have a side effect if its code depends syntactically on any of the side-effecting, server-side FFI functions. Links, forms, and most client-side event handlers are not followed during this syntactic traversal, but \texttt{<body onload=\{...\}>} handlers \emph{are} examined, since they run right away and could just as well be considered parts of main page handlers. - -Ur/Web includes a kind of automatic protection against cross site request forgery attacks. Whenever any page execution can have side effects and can also read at least one cookie value, all cookie values must be signed cryptographically, to ensure that the user has come to the current page by submitting a form on a real page generated by the proper server. Signing and signature checking are inserted automatically by the compiler. This prevents attacks like phishing schemes where users are directed to counterfeit pages with forms that submit to your application, where a user's cookies might be submitted without his knowledge, causing some undesired side effect. +The HTTP standard suggests that GET requests only be used in ways that generate no side effects. Side-effecting operations should use POST requests instead. The Ur/Web compiler enforces this rule strictly, via a simple conservative program analysis. Any page that may have a side effect must be accessed through a form, all of which use POST requests, or via a direct call to a page handler with some argument of type $\mt{Basis.postBody}$. A page is judged to have a side effect if its code depends syntactically on any of the side-effecting, server-side FFI functions. Links, forms, and most client-side event handlers are not followed during this syntactic traversal, but \texttt{<body onload=\{...\}>} handlers \emph{are} examined, since they run right away and could just as well be considered parts of main page handlers. \subsection{Tasks} @@ -2442,6 +2462,19 @@ The currently supported task kinds are: \item $\mt{periodic} \; n$: Code that is run when the application starts up and then every $n$ seconds thereafter. \end{itemize} +\subsection{Security Model} + +Ur/Web follows a pragmatic security model that, nonetheless, isn't magic. The warranty can be voided using the foreign function interface (FFI; see next section), but it is easy to check if that interface is being used, solely by inspecting \texttt{.urp} files. If such inspection shows no use of the FFI, then a number of classic security problems are precluded (modulo bugs in the implementation of Ur/Web itself, of course): +\begin{itemize} +\item There can be no \textbf{code-injection attacks}. That is, strings are never implicitly interpreted as programs and run, which can be particularly problematic for strings coming from unconstrained user input. In the case of SQL code, the specialized name for such vulnerabilities is \emph{SQL injections}. In the case of HTML or JavaScript code, the specialized name is \emph{cross-site scripting}. Ur/Web programmers need not worry about the difference, because the Ur/Web implementation promises that you will know if a string is being interpreted as a program! +\item Ur/Web includes a kind of automatic protection against \textbf{cross-site request forgery (CSRF) attacks}. Whenever any page execution can have side effects and can also read at least one cookie value, all cookie values must be signed cryptographically, to ensure that the user has come to the current page by submitting a form on a real page generated by the proper server. Signing and signature checking are inserted automatically by the compiler. This prevents attacks like phishing schemes where users are directed to counterfeit pages with forms that submit to your application, where a user's cookies might be submitted without his knowledge, causing some undesired side effect that the attacker couldn't cause directly due to lack of knowledge. +\item Quite a lot of other insecure monkey business can go in web applications. Ur/Web contains a pretty locked-down standard library, so that, for instance, it is not possible for Ur/Web code to access the file system directly... ergo it is not possible to leak secret file contents or overwrite files insecurely! The FFI must be used to summon such rights explicitly. +\end{itemize} + +However, Ur/Web doesn't guarantee ``any code that compiles is secure.'' The right model is that \emph{any HTTP endpoint exposed by the application can be called at any time with any argument values and any cookie values}. Ur/Web does nothing to guarantee that all function calls experienced by the application are possible according to legit traversal of links and forms! In particular, the cryptographic signing mentioned above is \emph{not} used to prevent users from making up whatever cookie values they like. It is just used to make sure an application only takes action based on cookie values when the user has explicitly submitted a form (and presumably the application author takes care to make all forms sufficiently intuitive, so none have surprising side effects that defy security or privacy expectations). + +Another philosophical assumption is that \emph{there is no hope of protecting a user against an attacker with access to the legit user's browser}. For instance, any attacker who can observe the HTML code of one page with CSRF protection is now able to trick the user into running arbitrary handler functions, since a cookie signature is not specific to the destination handler. Sure, we would improve security slightly (at the expense of Ur/Web implementation complexity) by making signatures handler-specific or even handler-argument-specific, but the idea is that you have already lost if an attacker has that kind of access to your browser. (And he needs browser access to see the page because of course your security-critical app is accessed only via TLS, right?) + \section{\label{ffi}The Foreign Function Interface} @@ -2453,7 +2486,7 @@ It is most convenient to encapsulate an FFI binding with a new \texttt{.urp} fil \item \texttt{clientOnly Module.ident} registers a value as being allowed only in client-side code. \item \texttt{clientToServer Module.ident} declares a type as OK to marshal between clients and servers. By default, abstract FFI types are not allowed to be marshalled, since your library might be maintaining invariants that the simple serialization code doesn't check. \item \texttt{effectful Module.ident} registers a function that can have side effects. This is the default for \texttt{transaction}-based types, and, actually, this directive is mostly present for legacy compatibility reasons, since it used to be required explicitly for each \texttt{transaction}al function. -\item \texttt{ffi FILE.urs} names the file giving your library's signature. You can include multiple such files in a single \texttt{.urp} file, and each file \texttt{mod.urp} defines an FFI module \texttt{Mod}. +\item \texttt{ffi FILE.urs} names the file giving your library's signature. You can include multiple such files in a single \texttt{.urp} file, and each file \texttt{mod.urs} defines an FFI module \texttt{Mod}. \item \texttt{include FILE} requests inclusion of a C header file. \item \texttt{jsFile FILE} requests inclusion of a JavaScript source file. \item \texttt{jsFunc Module.ident=name} gives a mapping from an Ur name for a value to a JavaScript name. @@ -2559,6 +2592,7 @@ It is possible to write JavaScript FFI code that interacts with the functional-r \item \cd{sr(v)} and \cd{sb(s, f)}, the ``return'' and ``bind'' monad operators, respectively \item \cd{ss(s)}, to produce the signal corresponding to source \cd{s} \item \cd{scur(s)}, to get the current value of signal \cd{s} + \item \cd{listen(s, f)}, to ask that function \cd{f} be called with the current value of \cd{s}, every time it changes, including immediately upon establishing this listener \end{itemize} \item The behavior of the \cd{<dyn>} pseudo-tag may be mimicked by following the right convention in a piece of HTML source code with a type like $\mt{xbody}$. Such a piece of source code may be encoded with a JavaScript string. To insert a dynamic section, include a \cd{<script>} tag whose content is just a call \cd{dyn(pnode, s)}. The argument \cd{pnode} specifies what the relevant enclosing parent tag is. Use value \cd{"tr"} when the immediate parent is \cd{<tr>}, use \cd{"table"} when the immediate parent is \cd{<table>}, and use \cd{"span"} otherwise. The argument \cd{s} is a string-valued signal giving the HTML code to be inserted at this point. As with the usual \cd{<dyn>} tag, that HTML subtree is automatically updated as the value of \cd{s} changes. diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h index 0c546d1c..c6c0dd3e 100644 --- a/include/urweb/types_cpp.h +++ b/include/urweb/types_cpp.h @@ -4,11 +4,12 @@ #include <time.h> #include <unistd.h> #include <stdint.h> +#include <unicode/utypes.h> typedef long long uw_Basis_int; typedef double uw_Basis_float; typedef char* uw_Basis_string; -typedef char uw_Basis_char; +typedef UChar32 uw_Basis_char; typedef struct { time_t seconds; unsigned microseconds; diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 5f1144b8..3209a9a6 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -103,7 +103,7 @@ char *uw_Basis_htmlifyFloat(struct uw_context *, uw_Basis_float); char *uw_Basis_htmlifyString(struct uw_context *, uw_Basis_string); char *uw_Basis_htmlifyBool(struct uw_context *, uw_Basis_bool); char *uw_Basis_htmlifyTime(struct uw_context *, uw_Basis_time); -char *uw_Basis_htmlifySpecialChar(struct uw_context *, unsigned char); +char *uw_Basis_htmlifySpecialChar(struct uw_context *, uw_Basis_char); char *uw_Basis_htmlifySource(struct uw_context *, uw_Basis_source); uw_unit uw_Basis_htmlifyInt_w(struct uw_context *, uw_Basis_int); @@ -111,7 +111,7 @@ uw_unit uw_Basis_htmlifyFloat_w(struct uw_context *, uw_Basis_float); uw_unit uw_Basis_htmlifyString_w(struct uw_context *, uw_Basis_string); uw_unit uw_Basis_htmlifyBool_w(struct uw_context *, uw_Basis_bool); uw_unit uw_Basis_htmlifyTime_w(struct uw_context *, uw_Basis_time); -uw_unit uw_Basis_htmlifySpecialChar_w(struct uw_context *, unsigned char); +uw_unit uw_Basis_htmlifySpecialChar_w(struct uw_context *, uw_Basis_char); uw_unit uw_Basis_htmlifySource_w(struct uw_context *, uw_Basis_source); char *uw_Basis_attrifyInt(struct uw_context *, uw_Basis_int); @@ -138,6 +138,7 @@ char *uw_Basis_urlifySource(struct uw_context *, uw_Basis_source); uw_unit uw_Basis_urlifyInt_w(struct uw_context *, uw_Basis_int); uw_unit uw_Basis_urlifyFloat_w(struct uw_context *, uw_Basis_float); +uw_unit uw_Basis_urlifyChar_w(struct uw_context *, uw_Basis_char); uw_unit uw_Basis_urlifyString_w(struct uw_context *, uw_Basis_string); uw_unit uw_Basis_urlifyBool_w(struct uw_context *, uw_Basis_bool); uw_unit uw_Basis_urlifyTime_w(struct uw_context *, uw_Basis_time); @@ -148,6 +149,7 @@ uw_Basis_unit uw_Basis_unurlifyUnit(struct uw_context * ctx, char **s); uw_Basis_int uw_Basis_unurlifyInt(struct uw_context *, char **); uw_Basis_float uw_Basis_unurlifyFloat(struct uw_context *, char **); uw_Basis_string uw_Basis_unurlifyString(struct uw_context *, char **); +uw_Basis_char uw_Basis_unurlifyChar(struct uw_context *, char **); uw_Basis_string uw_Basis_unurlifyString_fromClient(struct uw_context *, char **); uw_Basis_bool uw_Basis_unurlifyBool(struct uw_context *, char **); uw_Basis_time uw_Basis_unurlifyTime(struct uw_context *, char **); @@ -164,6 +166,7 @@ uw_Basis_string uw_Basis_strchr(struct uw_context *, const char *, uw_Basis_char uw_Basis_int uw_Basis_strcspn(struct uw_context *, const char *, const char *); uw_Basis_string uw_Basis_substring(struct uw_context *, const char *, uw_Basis_int, uw_Basis_int); uw_Basis_string uw_Basis_str1(struct uw_context *, uw_Basis_char); +uw_Basis_string uw_Basis_ofUnicode(struct uw_context *, uw_Basis_int); uw_Basis_string uw_strdup(struct uw_context *, const char *); uw_Basis_string uw_maybe_strdup(struct uw_context *, const char *); @@ -242,6 +245,7 @@ uw_Basis_string uw_Basis_blessEnvVar(struct uw_context *, uw_Basis_string); uw_Basis_string uw_Basis_blessMeta(struct uw_context *, uw_Basis_string); uw_Basis_string uw_Basis_checkUrl(struct uw_context *, uw_Basis_string); +uw_Basis_string uw_Basis_anchorUrl(struct uw_context *, uw_Basis_string); uw_Basis_string uw_Basis_checkMime(struct uw_context *, uw_Basis_string); uw_Basis_string uw_Basis_checkRequestHeader(struct uw_context *, uw_Basis_string); uw_Basis_string uw_Basis_checkResponseHeader(struct uw_context *, uw_Basis_string); @@ -262,6 +266,7 @@ uw_Basis_string uw_Basis_fileMimeType(struct uw_context *, uw_Basis_file); uw_Basis_blob uw_Basis_fileData(struct uw_context *, uw_Basis_file); uw_Basis_int uw_Basis_blobSize(struct uw_context *, uw_Basis_blob); uw_Basis_blob uw_Basis_textBlob(struct uw_context *, uw_Basis_string); +uw_Basis_string uw_Basis_textOfBlob(struct uw_context *, uw_Basis_blob); uw_Basis_string uw_Basis_postType(struct uw_context *, uw_Basis_postBody); uw_Basis_string uw_Basis_postData(struct uw_context *, uw_Basis_postBody); @@ -327,6 +332,7 @@ uw_Basis_bool uw_Basis_isxdigit(struct uw_context *, uw_Basis_char); uw_Basis_char uw_Basis_tolower(struct uw_context *, uw_Basis_char); uw_Basis_char uw_Basis_toupper(struct uw_context *, uw_Basis_char); +uw_Basis_bool uw_Basis_iscodepoint(struct uw_context *, uw_Basis_int); uw_Basis_int uw_Basis_ord(struct uw_context *, uw_Basis_char); uw_Basis_char uw_Basis_chr(struct uw_context *, uw_Basis_int); diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 99b45ec9..cb582788 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -7,6 +7,61 @@ function needsDynPrefix() { return scripts.length == 0; } +// Codepoint implementations brought from https://norbertlindenberg.com/2012/05/ecmascript-supplementary-characters/#String +if (!String.fromCodePoint) { + String.fromCodePoint = function () { + var chars = [], i; + for(i = 0; i < arguments.length; ++i) { + var c = Number(arguments[i]); + if (!isFinite(c) || c < 0 || c > 0x10FFFF || Math.floor(c) !== c) { + throw new RangeError("Invalid code point " + c); + } + if (c < 0x10000) { + chars.push(c); + } else { + c -= 0x10000; + chars.push((c >> 10) + 0xD800); + chars.push((c % 0x400) + 0xDC00); + } + } + return String.fromCharCode.apply(undefined, chars); + }; + + String.prototype.codePointAt = function (index) { + var str = String(this); + if (index < 0 || index >= str.length) { + return undefined; + } + var first = str.charCodeAt(index); + if (first >= 0xD800 && first <= 0xDBFF && str.length > index + 1) { + var second = str.charCodeAt(index + 1); + if (second >= 0xDC00 && second <= 0xDFFF) { + return ((first - 0xD800) << 10) + (second - 0xDC00) + 0x10000; + } + } + return first; + }; +} + +function iterateString(s, fn) { + var strIdx = 0, idx = 0, res, cp; + for (; strIdx < s.length ;) { + cp = s.codePointAt(strIdx); + if (fn) { + res = fn(String.fromCodePoint(cp), idx, strIdx); + if (res === false) return; + } + strIdx += cp > 0xFFFF ? 2 : 1; + ++idx; + } +} + +function strSplit(s) { + var chars = []; + iterateString(s, function(c) { chars.push(c); }); + return chars; +} + var dynPrefix = needsDynPrefix() ? "<span style=\"display:none\">A</span>" : ""; // Function versions of operators @@ -27,18 +82,999 @@ function le(x, y) { return x <= y; } // Characters -function isLower(c) { return c >= 'a' && c <= 'z'; } -function isUpper(c) { return c >= 'A' && c <= 'Z'; } -function isAlpha(c) { return isLower(c) || isUpper(c); } -function isDigit(c) { return c >= '0' && c <= '9'; } +function ord(c) { return c.codePointAt(0); } + +var isLowerBitm = []; +var a = isLowerBitm; +a[3] = 0x7FFFFFE; a[5] = 0x4200400; a[6] = 0x80000000; a[7] = 0xFF7FFFFF; a[8] = 0xAAAAAAAA; +a[9] = 0x55AAAAAA; a[10] = 0xAAAAAB55; a[11] = 0xD4AAAAAA; a[12] = 0x4E243129; a[13] = 0xE6512D2A; +a[14] = 0xB5555240; a[15] = 0xAA29AAAA; a[16] = 0xAAAAAAAA; a[17] = 0x93FAAAAA; a[18] = 0xFFFFAA85; +a[19] = 0xFFFFFFFF; a[20] = 0xFFEFFFFF; a[21] = 0x1FFFFFF; a[22] = 0x3; a[23] = 0x1F; +a[26] = 0x20; a[27] = 0x3C8A0000; a[28] = 0x10000; a[29] = 0xFFFFF000; a[30] = 0xAAE37FFF; +a[31] = 0x192FAAAA; a[33] = 0xFFFF0000; a[34] = 0xFFFFFFFF; a[35] = 0xAAAAAAAA; a[36] = 0xAAAAA802; +a[37] = 0xAAAAAAAA; a[38] = 0xAAAAD554; a[39] = 0xAAAAAAAA; a[40] = 0xAAAAAAAA; a[41] = 0xAAAA; +a[43] = 0xFFFFFFFE; a[44] = 0xFF; a[159] = 0x3F000000; a[228] = 0x1FF; a[232] = 0xFFFFFFFF; +a[233] = 0xFFFFFFFF; a[234] = 0xFFFFFFFF; a[235] = 0xFFFFFFFF; a[236] = 0xFFFFFFFF; a[237] = 0xFFFFFFFF; +a[240] = 0xAAAAAAAA; a[241] = 0xAAAAAAAA; a[242] = 0xAAAAAAAA; a[243] = 0xAAAAAAAA; a[244] = 0xBFEAAAAA; +a[245] = 0xAAAAAAAA; a[246] = 0xAAAAAAAA; a[247] = 0xAAAAAAAA; a[248] = 0x3F00FF; a[249] = 0xFF00FF; +a[250] = 0xFF003F; a[251] = 0x3FFF00FF; a[252] = 0xFF00FF; a[253] = 0x40DF00FF; a[254] = 0xCF00DC; +a[255] = 0xDC00FF; a[259] = 0x80020000; a[260] = 0x1FFF0000; a[264] = 0x8C400; a[265] = 0x32108000; +a[266] = 0x43C0; a[267] = 0xFFFF0000; a[268] = 0x10; a[294] = 0xFFFF0000; a[295] = 0x3FF; +a[353] = 0xFFFF0000; a[354] = 0x7FFFFFFF; a[355] = 0x3FDA1562; a[356] = 0xAAAAAAAA; a[357] = 0xAAAAAAAA; +a[358] = 0xAAAAAAAA; a[359] = 0x8501A; a[360] = 0xFFFFFFFF; a[361] = 0x20BF; a[1330] = 0xAAAAAAAA; +a[1331] = 0x2AAA; a[1332] = 0x3AAAAAAA; a[1337] = 0xAAABAAA8; a[1338] = 0xAAAAAAAA; a[1339] = 0x95FFAAAA; +a[1340] = 0xAABA50AA; a[1341] = 0xA002AA; a[1343] = 0x7000000; a[1369] = 0xFFFF0000; a[1370] = 0xF7FFFFFF; +a[1371] = 0xFFFF003F; a[1372] = 0xFFFFFFFF; a[1373] = 0xFFFFFFFF; a[2008] = 0xF8007F; a[2042] = 0x7FFFFFE; +a[2081] = 0xFFFFFF00; a[2082] = 0xFFFF; a[2086] = 0xFF000000; a[2087] = 0xFFFFFFF; a[2150] = 0xFFFFFFFF; +a[2151] = 0x7FFFF; a[2246] = 0xFFFFFFFF; a[3744] = 0xFC000000; a[3745] = 0xFFFFF; a[3746] = 0xFFDFC000; +a[3747] = 0xFF; a[3748] = 0xFFFFFFC; a[3749] = 0xEBC00000; a[3750] = 0xFFEF; a[3751] = 0xFFFFFC00; +a[3752] = 0xC000000F; a[3753] = 0xFFFFFF; a[3754] = 0xFFFC0000; a[3755] = 0xFFF; a[3756] = 0xFFFFFFC0; +a[3757] = 0xFC000000; a[3758] = 0xFFFFF; a[3759] = 0xFFFFC000; a[3760] = 0xFF; a[3761] = 0xFFFFFFC; +a[3762] = 0xFFC00000; a[3763] = 0xFFFF; a[3764] = 0xFFFFFC00; a[3765] = 0x3F; a[3766] = 0xF7FFFFFC; +a[3767] = 0xF0000003; a[3768] = 0xFDFFFFF; a[3769] = 0xFFC00000; a[3770] = 0x3F7FFF; a[3771] = 0xFFFF0000; +a[3772] = 0xFDFF; a[3773] = 0xFFFFFC00; a[3774] = 0xBF7; a[3913] = 0xFFFFFFFC; a[3914] = 0xF; + +delete a; + +function isLower(c) { + var cp = ord(c); + var idx = Math.floor(cp / 32); + var byt = isLowerBitm[idx]; + if (byt) + { + var mask = Math.pow(2, cp - idx * 32); + return (byt & mask) != 0; + } + return false; +} + +var isUpperBitm = []; +var a = isUpperBitm; +a[2] = 0x7FFFFFE; a[6] = 0x7F7FFFFF; a[8] = 0x55555555; a[9] = 0xAA555555; a[10] = 0x555554AA; +a[11] = 0x2B555555; a[12] = 0xB1DBCED6; a[13] = 0x11AED2D5; a[14] = 0x4AAAA490; a[15] = 0x55D25555; +a[16] = 0x55555555; a[17] = 0x6C055555; a[18] = 0x557A; a[27] = 0x80450000; a[28] = 0xFFFED740; +a[29] = 0xFFB; a[30] = 0x551C8000; a[31] = 0xE6905555; a[32] = 0xFFFFFFFF; a[33] = 0xFFFF; +a[35] = 0x55555555; a[36] = 0x55555401; a[37] = 0x55555555; a[38] = 0x55552AAB; a[39] = 0x55555555; +a[40] = 0x55555555; a[41] = 0xFFFE5555; a[42] = 0x7FFFFF; a[133] = 0xFFFFFFFF; a[134] = 0x20BF; +a[157] = 0xFFFFFFFF; a[158] = 0xFFFFFFFF; a[159] = 0x3FFFFF; a[240] = 0x55555555; a[241] = 0x55555555; +a[242] = 0x55555555; a[243] = 0x55555555; a[244] = 0x40155555; a[245] = 0x55555555; a[246] = 0x55555555; +a[247] = 0x55555555; a[248] = 0x3F00FF00; a[249] = 0xFF00FF00; a[250] = 0xAA003F00; a[251] = 0xFF00; +a[253] = 0xF000000; a[254] = 0xF000F00; a[255] = 0xF001F00; a[264] = 0x3E273884; a[265] = 0xC00F3D50; +a[266] = 0x20; a[267] = 0xFFFF; a[268] = 0x8; a[293] = 0xFFC00000; a[294] = 0xFFFF; +a[352] = 0xFFFFFFFF; a[353] = 0x7FFF; a[355] = 0xC025EA9D; a[356] = 0x55555555; a[357] = 0x55555555; +a[358] = 0x55555555; a[359] = 0x42805; a[1330] = 0x55555555; a[1331] = 0x1555; a[1332] = 0x5555555; +a[1337] = 0x55545554; a[1338] = 0x55555555; a[1339] = 0x6A005555; a[1340] = 0x55452855; a[1341] = 0x5F7D55; +a[2041] = 0x7FFFFFE; a[2080] = 0xFFFFFFFF; a[2081] = 0xFF; a[2085] = 0xFFFF0000; a[2086] = 0xFFFFF; +a[2148] = 0xFFFFFFFF; a[2149] = 0x7FFFF; a[2245] = 0xFFFFFFFF; a[3744] = 0x3FFFFFF; a[3745] = 0xFFF00000; +a[3746] = 0x3FFF; a[3747] = 0xFFFFFF00; a[3748] = 0xD0000003; a[3749] = 0x3FDE64; a[3750] = 0xFFFF0000; +a[3751] = 0x3FF; a[3752] = 0x1FDFE7B0; a[3753] = 0x7B000000; a[3754] = 0x1FC5F; a[3755] = 0xFFFFF000; +a[3756] = 0x3F; a[3757] = 0x3FFFFFF; a[3758] = 0xFFF00000; a[3759] = 0x3FFF; a[3760] = 0xFFFFFF00; +a[3761] = 0xF0000003; a[3762] = 0x3FFFFF; a[3763] = 0xFFFF0000; a[3764] = 0x3FF; a[3765] = 0xFFFFFF00; +a[3766] = 0x1; a[3767] = 0x7FFFFFC; a[3768] = 0xF0000000; a[3769] = 0x1FFFFF; a[3770] = 0xFFC00000; +a[3771] = 0x7FFF; a[3772] = 0xFFFF0000; a[3773] = 0x1FF; a[3774] = 0x400; a[3912] = 0xFFFFFFFF; +a[3913] = 0x3; a[3977] = 0xFFFF0000; a[3978] = 0xFFFF03FF; a[3979] = 0xFFFF03FF; a[3980] = 0x3FF; + +delete a; + +function isUpper(c) { + var cp = ord(c); + var idx = Math.floor(cp / 32); + var byt = isUpperBitm[idx]; + if (byt) { + var mask = Math.pow(2, cp - idx * 32); + return (byt & mask) != 0; + } + return false; +} + +var isAlphaBitm = (function(){ + var a = 0xFFFFFFFF; + var b = 0xFFFF0000; + var c = 0x7FFFFFFF; + var d = 0x3FFFFF; + var e = 0x3FFFFFFF; + var f = 0x1FFFFFFF; + var g = 0x7FFFFF; + var h = 0x7FFFF; + var i = 0x7FFFFFE; + var j = 0xFFFFFFFE; + var k = 0x1FFFFFF; + var l = 0x7FFFFFF; + var m = 0xF7FFFFFF; + var n = 0xFFFFF; + var o = 0xFFFFFFF; + var p = 0x3FFFF; + var q = 0xE3EDFDFF; + var r = 0xFFFDDFEF; + var s = 0xFFFF07FF; + var t = 0xFFFF7FFF; + var u = 0x3FFFFFF; + var v = 0xFFFFFDFF; + var w = 0xFFDFFFFF; + var x = 0xFF7FFFFF; + var y = 0xFFFFE000; + var z = 0xFFFFFC00; + var a0 = 0xFFF99FEF; + var a1 = 0xFFFFFEFF; + var a2 = 0xFFFF20BF; + var a3 = 0x3F3FFFFF; + var a4 = 0x7F7F7F7F; + var a5 = 0xFF800000; + var a6 = 0xFFFFFFFC; + var a7 = 0xFFF80000; + var a8 = 0xFFFCFFFF; + var a9 = 0x1FFFFF; + var b0 = 0xFFFFFFEF; + var b1 = 0xFFFF03FF; + return [ + 0, 0, i, i, 0, 0x4200400, x, x, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, 0x3FFC3, 0x501F, 0, 0, 0x20, 0xBCDF0000, 0xFFFFD740, 0xFFFFFFFB, a, 0xFFBFFFFF, a, a, a, a, 0xFFFFFC03, a, a, a, + a, 0xFFFEFFFF, 0x27FFFFF, j, 0xFF, 0xBFFF0000, 0xFFFF00B6, 0x707FF, 0x7FF0000, a, 0xFEFFFFFF, 0xFFFFC000, a, a, 0x1FEFFFFF, 0x9C00E1FE, b, a, y, a, + a, p, z, 0x43007FF, 0xFCFFFFFF, 0x1FFF, k, 0x7FF, 0, 0x3FDFFFFF, 0xFFF00000, 0xFFFF03F8, a, 0xEFFFFFFF, 0xFFE1DFFF, 0xFFFE000F, a0, 0xE3C5FDFF, 0xB080599F, 0x1003000F, + 0xFFF987EE, 0xC36DFDFF, 0x5E021987, 0x3F0000, 0xFFFBBFEE, q, 0x11BBF, 0x1E00000F, 0xFFF99FEE, q, 0xB0C0199F, 0x2000F, 0xD63DC7EC, 0xC3FFC718, 0x811DC7, 0, r, 0xE3FFFDFF, 0x7601DDF, 0xF, + r, 0xE3EFFDFF, 0x40601DDF, 0x6000F, r, 0xE7FFFFFF, 0x80F05DDF, 0xFC00000F, 0xFC7FFFEC, 0x2FFBFFFF, 0xFF5F807F, 0xC0000, j, l, 0x207F, 0, 0xFEF02596, 0x3BFFECAE, 0xF000205F, 0, + 0x1, 0, a1, 0xFFFE1FFF, 0xFEFFFF03, f, 0, 0, a, 0xF97FFFFF, b, 0xFFFFC1E7, 0x3000407F, a, a2, m, a, a, a, a, + a, a, a, a, a, a, 0x3D7F3DFF, a, 0xFFFF3DFF, 0x7F3DFFFF, 0xFF7FFF3D, a, 0xFF3DFFFF, a, 0x87FFFFFF, 0, 0xFFFF, a, a, a3, + j, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, 0xFFFF9FFF, + i, a, a, 0x1FFC7FF, 0xFDFFF, n, n, 0xDDFFF, a, 0xFFCFFFFF, 0x108001FF, 0, 0, a, a, 0xFFFFFF, a, s, a, d, + c, 0x1FF0FFF, b, 0x1F3FFF, a, 0xFFFF0FFF, 0x3FF, 0, o, a, c, 0x1FFFFE, 0, 0x80, 0, 0, a, 0xFFEFFFFF, 0xFEF, 0, + a, 0xFC00F3FF, a, 0x3FFBF, a, d, 0xFC00E000, e, 0x1FF, 0, 0, 0x6FDE00, a, a, a, a, a, a, 0, 0x1FFF80, + a, a, a, a, a, a, a, a, a3, a, 0xAAFF3F3F, e, a, 0x5FDFFFFF, 0xFCF1FDC, 0x1FDC1FFF, 0, 0, 0, 0x80020000, + 0x1FFF0000, 0, 0, 0, 0x3E2FFC84, 0xF3FFBD50, 0x43E0, a, 0x1FF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0xFFC00000, a, 0x3FF, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, t, c, a, a, a, a, 0xC781F, + a, a2, a, 0x80FF, g, a4, a4, a, 0, 0x8000, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0xE0, 0x1F3E03FE, j, a, 0xE07FFFFF, j, a, m, 0xFFFFFFE0, 0xFFFE7FFF, a, a, 0x7FFF, l, 0, b, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, d, 0, 0, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, 0x7FF, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, 0x1FFF, 0, b, e, + a, a, a, a, a, a, a, a, 0xFFFF1FFF, 0xC00, a, 0x8FF07FFF, a, a, a, 0xFFFF, a5, a6, a, a, + 0xFFFFF9FF, 0xFF7FFF, 0, a5, 0xFFFFF7BB, 0xFF, a, n, a, a, 0x2F, 0x28FC0000, z, s, h, f, a, 0xFFF7FFFF, 0x8000, 0x7C00FFDF, + a, g, 0x3FFF, 0xC47FFFFF, a, c, 0x38000005, 0x3CFFFF, 0x7E7E7E, 0xFFFF7F7F, m, 0xFFFF003F, a, a, a, 0x7FF, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, 0xFFFF000F, 0xFFFFF87F, o, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, a, a, a, a, + a, a, a, 0xFFFF3FFF, a, a, u, 0, 0xE0F8007F, 0x5F7FFDFF, 0xFFFFFFDB, a, a, p, a7, a, a, a, a, a, + a, a, a, a, a, e, b, a, a8, a, 0xFF, 0xFFF0000, 0, 0, 0, 0xFFDF0000, a, a, a, f, + 0, i, i, 0xFFFFFFC0, a, c, 0x1CFCFCFC, 0, 0xFFFFEFFF, 0xB7FFFF7F, 0x3FFF3FFF, 0, a, a, a, l, 0, 0, a, a9, + 0, 0, 0, 0, 0, 0, 0, 0, f, a, 0x1FFFF, 0, a, y, s, l, e, a, 0x3EFF0F, 0, + a, a, a, a, e, b, 0xFF0FFFFF, o, a, 0xFFFF00FF, a, 0xF, 0, 0, 0, 0, a, a, a, a, + a, a, a, a, a, g, d, 0xFF, 0, 0, 0, 0, 0xFFFFFD3F, 0x91BFFFFF, d, g, c, 0, 0, 0x37FFFF, + d, u, 0, 0, a, 0xC0FFFFFF, 0, 0, 0xFEEFF06F, n, 0, f, f, 0, a1, 0x1F, a, d, d, h, + p, 0, 0, 0, a, a, 0x1FF, 0, a, h, a, h, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, 0x3F, 0, + a6, k, b, 0x1FF, a, h, b, 0x47FFFF, a, a, 0x1400001E, 0, 0xFFFBFFFF, 0x409FFFFF, 0, 0, 0xBFFFBD7F, 0xFFFF01FF, a, 0x1FF, + a0, q, 0xE081199F, 0xF, 0, 0, 0, 0, a, a, 0x7BB, 0, a, a, 0xB3, 0, 0, 0, 0, 0, + a, 0x7F3FFFFF, 0x3F000000, 0, a, c, 0x11, 0, a, d, 0, 0, 0xE3FFFFFF, 0x7FF, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, a, a, 0x80000000, 0, 0, 0, 0, 0, 0, 0, 0, a, 0x7FE7FFFF, b, a, + 0xFFFFCF, 0, a, k, 0, 0, 0, 0, 0, 0, 0, 0, v, 0x7F7FFFFF, 0x1, 0xFFFC0000, a8, 0x7FFEFF, 0, 0, + 0xFFFFFB7F, 0xB47FFFFF, 0xCB, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, u, 0, 0, 0, a, a, a, 0x7FFF, + a, a, a, a, a, a, 0xF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, 0x7FFF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, 0x7F, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, k, c, 0, + 0, 0, b, 0x3FFF, a, g, 0xF, 0xE0FFFFF8, 0xFFFF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, 0xFFFF001F, c, + a7, 0, 0, 0x3, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, 0x1FFF, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, h, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, + a, a, a, a, c, 0, 0, b, a, a, a, a, a, a, a, a, a, a, a, o, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, 0x1FFF07FF, 0x43FF01FF, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, a, a, w, a, 0xDFFFFFFF, 0xEBFFDE64, b0, a, 0xDFDFE7BF, 0x7BFFFFFF, 0xFFFDFC5F, a, a, a, a, a, + a, a, a, a, a, 0xFFFFFF3F, 0xF7FFFFFD, m, w, w, t, t, v, v, 0xFF7, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xF9FFFF7F, 0x7DB, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, a, a, a, a, a, a, 0x1F, 0, a, a, 0x8F, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, b0, 0xAF7FE96, 0xAA96EA84, 0x5EF7F796, 0xFFFFBFF, 0xFFFFBEE, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, b, b1, b1, + 0x3FF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, g, 0, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a9, a, a, a, a, a, a, e, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, 0xFFFF0003, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, 0x1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, e + ];})(); + +function isAlpha(c) { + var cp = ord(c); + var idx = Math.floor(cp / 32); + var byt = isAlphaBitm[idx]; + if (byt) { + var mask = Math.pow(2, cp - idx * 32); + return (byt & mask) != 0; + } + return false; +} + +var isDigitBitm = []; +var a = isDigitBitm; +a[1] = 0x3FF0000; a[51] = 0x3FF; a[55] = 0x3FF0000; a[62] = 0x3FF; +a[75] = 0xFFC0; a[79] = 0xFFC0; a[83] = 0xFFC0; a[87] = 0xFFC0; +a[91] = 0xFFC0; a[95] = 0xFFC0; a[99] = 0xFFC0; a[103] = 0xFFC0; +a[107] = 0xFFC0; a[111] = 0xFFC0; a[114] = 0x3FF0000; a[118] = 0x3FF0000; +a[121] = 0x3FF; a[130] = 0x3FF; a[132] = 0x3FF0000; a[191] = 0x3FF; +a[192] = 0x3FF0000; a[202] = 0xFFC0; a[206] = 0x3FF0000; a[212] = 0x3FF03FF; +a[218] = 0x3FF0000; a[221] = 0x3FF0000; a[226] = 0x3FF03FF; a[1329] = 0x3FF; +a[1350] = 0x3FF0000; a[1352] = 0x3FF; a[1358] = 0x3FF0000; a[1359] = 0x3FF0000; +a[1362] = 0x3FF0000; a[1375] = 0x3FF0000; a[2040] = 0x3FF0000; a[2085] = 0x3FF; +a[2179] = 0xFFC0; a[2183] = 0x3FF0000; a[2185] = 0xFFC00000; a[2190] = 0x3FF0000; +a[2199] = 0x3FF0000; a[2210] = 0x3FF0000; a[2214] = 0x3FF0000; a[2226] = 0x3FF0000; +a[2230] = 0x3FF; a[2233] = 0x3FF0000; a[2247] = 0x3FF; a[2274] = 0x3FF0000; +a[2282] = 0x3FF0000; a[2899] = 0x3FF; a[2906] = 0x3FF0000; a[3774] = 0xFFFFC000; +a[3775] = 0xFFFFFFFF; a[3914] = 0x3FF0000; +delete a; + +function isDigit(c) { + var cp = ord(c); + var idx = Math.floor(cp / 32); + var byt = isDigitBitm[idx]; + if (byt) { + var mask = Math.pow(2, cp - idx * 32); + return (byt & mask) != 0; + } + return false; +} + function isAlnum(c) { return isAlpha(c) || isDigit(c); } -function isBlank(c) { return c == ' ' || c == '\t'; } -function isSpace(c) { return isBlank(c) || c == '\r' || c == '\n'; } -function isXdigit(c) { return isDigit(c) || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F'); } -function ord(c) { return c.charCodeAt(0); } -function isPrint(c) { return ord(c) > 31 && ord(c) < 127; } -function toLower(c) { return c.toLowerCase(); } -function toUpper(c) { return c.toUpperCase(); } +function isBlank(c) { + var cp = ord(c); + if (cp == 9) + return true; + if (cp == 32) + return true; + if (cp == 160) + return true; + if (cp == 5760) + return true; + if (cp >= 8192 && cp <= 8202) + return true; + if (cp == 8239) + return true; + if (cp == 8287) + return true; + if (cp == 12288) + return true; + + return false; +} +function isSpace(c) { + var cp = ord(c); + if (cp >= 10 && cp <= 13) + return true; + if (cp == 133) + return true; + if (cp == 8232) + return true; + if (cp == 8233) + return true; + + return isBlank(c); +} +function isXdigit(c) { return (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F'); } + +var isPrintBitm = (function(){ + var a = 0xFFFFFFFF; + var b = 0x7FFFFFFF; + var c = 0x7FFFFF; + var d = 0x3FFFFFFF; + var e = 0xFFFF0FFF; + var f = 0xFFFFFFF; + var g = 0x3FFFFF; + var h = 0xFFFF00FF; + var i = 0x1FFFFFFF; + var j = 0x3FFFFFF; + var k = 0xFFFFFF; + var l = 0xFFFF0000; + var m = 0xFFFFFFFE; + var n = 0x7FFFFFF; + var o = 0xFFFFF; + var p = 0xFFFF1FFF; + var q = 0xDFFFFFFF; + var r = 0xF3EDFDFF; + var s = 0xFFFDDFEF; + var t = 0x1FFFFFF; + var u = 0xFFDFFFFF; + var v = 0xFF3FFFFF; + var w = 0xFFFF7FFF; + var x = 0xFFFF000F; + var y = 0xFFFCFFFF; + var z = 0x3FF00FF; + var a0 = 0x1FFFFF; + var a1 = 0xFE7FFFFF; + var a2 = 0x3FFFF; + var a3 = 0x7FFF3FFF; + var a4 = 0xFFF99FEF; + var a5 = 0xFFFF20BF; + var a6 = 0x3F3FFFFF; + var a7 = 0x3FF03FF; + var a8 = 0xFFFF07FF; + var a9 = 0x9FFFFFFF; + var b0 = 0xFBFFFFFF; + var b1 = 0x1FFFF; + var b2 = 0xE3FFFFFF; + var b3 = 0x7F7F7F7F; + var b4 = 0xFFFE7FFF; + var b5 = 0xFFFF003F; + var b6 = 0xFFFF3FFF; + var b7 = 0xFFFF03FF; + var b8 = 0x7FFFF; + var b9 = 0xFFFF0003; + var c0 = 0xFFFFFFEF; + return [ + 0, a, a, b, 0, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, 0xFCFFFFFF, 0xFFFFD7F0, 0xFFFFFFFB, a, a, a, a, a, a, a, a, a, a, + a, 0xFFFEFFFF, a1, m, 0xFFFEE6FF, a, h, 0x1F07FF, q, a, a, a, a, a, a, a, 0xFFFFBFFF, a, 0xFFFFE7FF, a, + a, a2, a, n, a, a3, 0x4FFFFFFF, 0x7FF, 0, 0x3FDFFFFF, 0xFFF00000, a, a, a, a, a, a4, 0xF3C5FDFF, 0xB080799F, 0x3FFFFFCF, + 0xFFF987EE, 0xD36DFDFF, 0x5E023987, 0x3FFFC0, 0xFFFBBFEE, r, 0x13BBF, 0xFE03FFCF, 0xFFF99FEE, r, 0xB0C0399F, 0xFFFFCF, 0xD63DC7EC, 0xC3FFC718, 0x813DC7, 0x7FFFFC0, s, 0xE3FFFDFF, 0x7603DDF, 0xFF00FFCF, + s, 0xF3EFFDFF, 0x40603DDF, 0x6FFCF, s, a, 0xFFF0FDDF, 0xFFFFFFCF, 0xFC7FFFEC, 0x2FFBFFFF, 0xFF5F847F, 0x1CFFC0, m, 0x87FFFFFF, f, 0, 0xFEF02596, 0x3BFFECAE, 0xF3FF3F5F, 0, + a, a, 0xFFFFFEFF, 0xFFFE1FFF, 0xFEFFFFFF, q, 0x7FFDFFF, 0, a, a, a, a, a, a, a5, a, a, a, a, a, + a, a, a, a, a, a, 0x3D7F3DFF, a, 0xFFFF3DFF, 0x7F3DFFFF, 0xFF7FFF3D, a, 0xFF3DFFFF, a, 0xE7FFFFFF, i, j, a, a, a6, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + i, a, a, t, 0x1FDFFF, c, o, 0xDDFFF, a, a, d, a7, 0x3FF7FFF, a, a, k, a, a8, a, g, + b, 0xFFF0FFF, 0xFFFFFFF1, 0x1F3FFF, a, e, 0xC7FF03FF, a, 0xCFFFFFFF, a, b, a9, a7, a3, 0, 0, a, a, e, i, + a, a, a, 0xF00FFFFF, a, 0xF8FFFFFF, 0xFFFFE3FF, a, 0x1FF, 0, h, j, a, a, a, a, a, a, a, b0, + a, a, a, a, a, a, a, a, a6, a, 0xAAFF3F3F, d, a, u, 0xEFCFFFDF, 0x7FDCFFFF, a, 0xFFFFFCFF, a, 0xFFF3FFDF, + 0x1FFF7FFF, a, l, b1, a, a, a, a, e, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, 0x7F, 0x7FF, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, 0xFFCFFFFF, v, b2, 0x7FDFF, 0xF000, a, w, b, a, a, a, a, 0xFE0FFFFF, + a, a5, a, 0x800180FF, c, b3, b3, a, a, a, 0x3FF, 0, b0, a, a, o, a, a, a, a, + a, a, g, 0xFFF0000, a, a, m, a, a1, a, a, a, 0xFFFFFFE0, b4, a, a, w, n, a, x, + b, a, a, a, a, a, a, b, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, g, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, 0x7FF, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, p, a, 0xFFFF007F, a, + a, a, a, a, a, a, a, a, a, 0xFFF, a, a, a, a, a, k, a, a, a, a, + a, 0xFF7FFF, 0, 0xFF800000, a, 0x3FF0FFF, a, k, a, a, 0x3FFC03F, d, a, a, 0x800FFFFF, i, a, a, 0xC3FFBFFF, b, + a, c, 0xF3FF3FFF, a, a, a, 0xF8000007, c, 0x7E7E7E, 0xFFFF7F7F, a, b5, a, a, a, 0x3FF3FFF, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, x, 0xFFFFF87F, f, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, b6, a, a, j, 0, 0xE0F8007F, 0x5F7FFFFF, 0xFFFFFFDB, a, a, a, 0xFFF80003, a, a, a, a, a, + a, a, a, a, a, a, l, a, y, a, 0xFF, 0x3FFF0000, j, a, 0xFFF7FFFF, 0xFFDF0F7F, a, a, a, a9, + m, a, a, a, a, b, 0x1CFCFCFC, 0x3E007F7F, 0xFFFFEFFF, 0xB7FFFF7F, 0x3FFF3FFF, 0, a, a, a, n, 0xFFFFFF87, 0xFF8FFFFF, a, a, + 0xFFF7FFF, 0x1, l, d, 0, 0, 0, 0, i, a, b1, f, a, 0xFFFFE00F, a8, n, 0xBFFFFFFF, a, 0x3FFF0F, 0, + a, a, a, a, d, b7, 0xFF0FFFFF, f, a, h, a, 0x800F, 0, 0, 0, 0, a, a, a, a, + a, a, a, a, a, c, g, 0xFF, 0, 0, 0, 0, 0xFFFFFD3F, 0x91BFFFFF, 0xFFBFFFFF, a, b, 0xFF80, 0, 0xF837FFFF, + 0x8FFFFFFF, 0x83FFFFFF, 0, 0, a, 0xF0FFFFFF, y, a, 0xFEEFF06F, 0x870FFFFF, 0x1FF00FF, a, a, 0, a, 0x7FF87F, a, 0xFE3FFFFF, v, 0xFF07FFFF, + 0x1E03FFFF, 0xFE00, 0, 0, a, a, 0x1FF, 0, a, b8, a, 0xFC07FFFF, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, b, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, 0xFFFC3FFF, 0x8000FFFF, + a, a, b9, 0x3FF01FF, a, u, x, c, a, a, b6, 0x1FFFFE, 0xFFFBFFFF, b, 0, 0, 0xBFFFBD7F, b7, a, 0x3FF07FF, + a4, r, 0xE081399F, 0x1F1FCF, 0, 0, 0, 0, a, a, 0x2BFFFFFF, 0, a, a, z, 0, 0, 0, 0, 0, + a, v, d, 0, a, a, 0x3FF001F, 0x1FFF, a, k, 0x3FF, 0, b2, e, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, a, a, 0x8007FFFF, 0, 0, 0, 0, 0, 0, 0, 0, a, a, h, a, + 0xDFFFFFCF, 0x7, a, t, 0, 0, 0, 0, 0, 0, 0, 0, 0xFFFFFDFF, 0xFF7FFFFF, b5, p, y, 0x7FFEFF, 0, 0, + 0xFFFFFB7F, 0xB47FFFFF, z, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, j, 0, 0, 0, a, a, a, 0x1F7FFF, + a, a, a, a, a, a, 0xF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, 0x7FFF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, 0x7F, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, t, b, 0xC3FF, + 0, 0, l, 0x3F3FFF, a, a, 0xFBFF003F, 0xE0FFFFFB, 0xFFFF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, 0xFFFF001F, b, + 0xFFFF8000, 0, 0, 0x3, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, 0x1FFF, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b8, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, + a, a, a, a, b, 0, 0, l, a, a, a, a, a, a, a, a, a, a, a, f, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, 0x1FFF07FF, 0xF3FF01FF, 0xF, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, a, a, a, g, + a, 0xFFFFFE7F, a, a, a, a, a, 0x1FF, a, a, 0x3F, 0, 0, 0, 0, 0, a, a, c, a2, + 0, 0, 0, 0, a, a, u, a, q, 0xEBFFDE64, c0, a, 0xDFDFE7BF, 0x7BFFFFFF, 0xFFFDFC5F, a, a, a, a, a, + a, a, a, a, a, 0xFFFFFF3F, a, a, a, a, a, a, a, a, 0xFFFFCFFF, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, 0xF8000FFF, 0xFFFE, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xF9FFFF7F, 0x7DB, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, a, a, a, a, a, a, 0x7FFF9F, 0, a, a, 0xC3FF07FF, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, c0, 0xAF7FE96, 0xAA96EA84, 0x5EF7F796, 0xFFFFBFF, 0xFFFFBEE, 0, 0x30000, + 0, 0, 0, 0, 0, 0, 0, 0, a, e, a, a, o, b4, 0xFFFEFFFE, g, p, w, a, e, + a, 0x1FFF, 0, 0xFFFFFFC0, 0xFFFF0007, f, 0x301FF, 0x3F, 0, 0, 0, 0, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a0, 0x1FF1FFF, a, a, a, o, a, a, a0, 0, e, a, z, a, h, 0x3FFF, 0, 0, + e, b, p, 0xFFF, k, 0, 0xFFFF0001, 0x7F, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, c, 0, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a0, a, a, a, a, a, a, d, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, b9, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, 0x1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, d + ];})(); + +function isPrint(c) { + var cp = ord(c); + var idx = Math.floor(cp / 32); + var byt = isPrintBitm[idx]; + if (byt) { + var mask = Math.pow(2, cp - idx * 32); + return (byt & mask) != 0; + } + return false; +} + +function toLower(c) { + var cp = ord(c); + + if (cp == 304) + return chr(105); + else if (cp >= 7312 && cp <= 7354) + return c; + else if (cp >= 7357 && cp <= 7359) + return c; + else if (cp == 42936) + return c; + else if (cp >= 93760 && cp <= 93791) + return c; + return c.toLowerCase(); +} + +function toUpper(c) { + var cp = ord(c); + if (cp == 223) + return c; + else if (cp == 329) + return c; + else if (cp == 496) + return c; + else if (cp == 912) + return c; + else if (cp == 944) + return c; + else if (cp == 1415) + return c; + else if (cp >= 4304 && cp <= 4346) + return c; + else if (cp >= 4349 && cp <= 4351) + return c; + else if (cp >= 7830 && cp <= 7834) + return c; + else if (cp == 8016) + return c; + else if (cp == 8018) + return c; + else if (cp == 8020) + return c; + else if (cp == 8022) + return c; + else if (cp >= 8064 && cp <= 8071) + return chr(cp + 8) + else if (cp >= 8072 && cp <= 8079) + return c; + else if (cp >= 8080 && cp <= 8087) + return chr(cp + 8); + else if (cp >= 8088 && cp <= 8095) + return c; + else if (cp >= 8096 && cp <= 8103) + return chr(cp + 8) + else if (cp >= 8104 && cp <= 8111) + return c; + else if (cp == 8114) + return c; + else if (cp == 8115) + return chr(8124); + else if (cp == 8116) + return c; + else if (cp == 8118) + return c; + else if (cp == 8119) + return c; + else if (cp == 8124) + return c; + else if (cp == 8130) + return c; + else if (cp == 8131) + return chr(8140); + else if (cp == 8132) + return c; + else if (cp == 8134) + return c; + else if (cp == 8135) + return c; + else if (cp == 8140) + return c; + else if (cp == 8146) + return c; + else if (cp == 8147) + return c; + else if (cp == 8150) + return c; + else if (cp == 8151) + return c; + else if (cp >= 8162 && cp <= 8164) + return c; + else if (cp == 8166) + return c; + else if (cp == 8167) + return c; + else if (cp == 8178) + return c; + else if (cp == 8179) + return chr(8188); + else if (cp == 8180) + return c; + else if (cp == 8182) + return c; + else if (cp == 8183) + return c; + else if (cp == 8188) + return c; + else if (cp == 42937) + return c; + else if (cp >= 64256 && cp <= 64262) + return c; + else if (cp >= 64275 && cp <= 64279) + return c; + else if (cp >= 93792 && cp <= 93823) + return c; + else + return c.toUpperCase(); +} // Lists @@ -48,7 +1084,7 @@ function cons(v, ls) { function rev(ls) { var acc = null; for (; ls; ls = ls.next) - acc = cons(ls.data, acc); + acc = cons(ls.data, acc); return acc; } function concat(ls1, ls2) { @@ -70,8 +1106,8 @@ function remove(x, ls) { for (; ls; ls = ls.next) if (ls.data == x) return concat(acc, ls.next); - else - acc = cons(ls.data, acc); + else + acc = cons(ls.data, acc); return ls; } @@ -220,11 +1256,11 @@ function stringToTime(string) { } /* -strftime() implementation from: -YUI 3.4.1 (build 4118) -Copyright 2011 Yahoo! Inc. All rights reserved. -Licensed under the BSD License. -http://yuilibrary.com/license/ + strftime() implementation from: + YUI 3.4.1 (build 4118) + Copyright 2011 Yahoo! Inc. All rights reserved. + Licensed under the BSD License. + http://yuilibrary.com/license/ */ var xPad=function (x, pad, r) @@ -553,6 +1589,8 @@ function uw_mouseEvent() { _ScreenY : firstGood(ev.screenY, 0), _ClientX : firstGood(ev.clientX, 0), _ClientY : firstGood(ev.clientY, 0), + _OffsetX : firstGood(ev.offsetX, 0), + _OffsetY : firstGood(ev.offsetY, 0), _CtrlKey : firstGood(ev.ctrlKey, false), _ShiftKey : firstGood(ev.shiftKey, false), _AltKey : firstGood(ev.altKey, false), @@ -1097,6 +2135,16 @@ function active(s) { } } +function listen(s, onchange) { + var x = document.createElement("script"); + x.dead = false; + x.signal = s; + x.sources = null; + x.closures = null; + x.recreate = onchange; + populate(x); +} + function input(x, s, recreate, type, name) { if (name) x.name = name; if (type) x.type = type; @@ -1228,7 +2276,7 @@ function selectValue(x) { function setSelectValue(x, v) { for (var i = 0; i < x.options.length; ++i) { - if(x.options[i].value == v) { + if (x.options[i].value == v) { x.selectedIndex = i; return; } @@ -1241,8 +2289,8 @@ function sel(s, content) { var dummy = document.createElement("span"); dummy.innerHTML = "<select>" + content + "</select>"; - var x = input(dummy.firstChild, s, function(x) { return function(v) { if (selectValue(x) != v) setSelectValue(x, v); }; }); + var x = dummy.firstChild; for (var i = 0; i < x.options.length; ++i) { if (x.options[i].value == "") x.options[i].value = x.options[i].text; @@ -1250,6 +2298,8 @@ function sel(s, content) { x.options[i].value = x.options[i].value.substring(1); } + x = input(x, s, function(x) { return function(v) { if (selectValue(x) != v) setSelectValue(x, v); }; }); + setSelectValue(x, s.data); if (selectValue(x) != s.data) sv(s, selectValue(x)); @@ -1303,6 +2353,9 @@ function dynClass(pnode, html, s_class, s_style) { var x = null; var y = null; + var classNameBefore = html.className; + var styleCssBefore = html.style.cssText; + if (s_class) { x = document.createElement("script"); x.dead = false; @@ -1315,7 +2368,10 @@ function dynClass(pnode, html, s_class, s_style) { freeClosure(ls.data); var cls = {v : null}; - html.className = flatten(cls, v); + var s = flatten(cls, v); + if (classNameBefore) + s += " " + classNameBefore; + html.className = s; x.closures = concat(cls.v, htmlCls); } @@ -1335,7 +2391,10 @@ function dynClass(pnode, html, s_class, s_style) { freeClosure(ls.data); var cls = {v : null}; - html.style.cssText = flatten(cls, v); + var s = flatten(cls, v); + if (styleCssBefore) + s += " " + styleCssBefore; + html.style.cssText = s; y.closures = concat(cls.v, htmlCls2); } @@ -1432,7 +2491,7 @@ function eh(x) { if (x == null) return "NULL"; else - return x.split("&").join("&").split("<").join("<").split(">").join(">"); + return flattenLocal(x).split("&").join("&").split("<").join("<").split(">").join(">"); } function ts(x) { return x.toString() } @@ -1441,30 +2500,67 @@ function s2b(s) { return s == "True" ? true : s == "False" ? false : null; } function s2be(s) { return s == "True" ? true : s == "False" ? false : er("Illegal Boolean " ^ s); } function id(x) { return x; } -function sub(s, i) { return s.charAt(i); } -function suf(s, i) { return s.substring(i); } -function slen(s) { return s.length; } +function sub(s, i) { + var ch = undefined; + iterateString(s, function(c, idx) { if (idx == i) { ch = c; return false; }}); + if (ch == undefined) + er("String index " + i + " out of bounds") + return ch; +} +function suf(s, i) { + var off = s.length; + iterateString(s, function(_, idx, sidx) { if (idx == i) { off = sidx; return false; } }); + return s.substring(off); +} +function slen(s) { + var len = 0; + iterateString(s, function(){ ++len;}); + return len; +} function sidx(s, ch) { - var r = s.indexOf(ch); + var r = -1; + iterateString(s, function(c, idx){ if (c == ch) { r = idx; return false; } }); if (r == -1) return null; else return r; } function ssidx(h, n) { - var r = h.indexOf(n); - if (r == -1) - return null; - else - return r; + if (n == "") return 0; + var ah = strSplit(h); + var an = strSplit(n); + var i = 0, y = 0; + var top = ah.length - an.length + 1; + if (top < 0) top = 0; + var found = true; + + for(i = 0; i < top; ++i) { + found = true; + + for (y = 0; y < an.length; ++y) { + if (ah[i + y] != an[y]) { + found = false; + break; + } + } + + if (found) + return i; + } + return null; } + function sspn(s, chs) { - for (var i = 0; i < s.length; ++i) - if (chs.indexOf(s.charAt(i)) != -1) + var s2 = strSplit(s); + var chs2 = strSplit(chs); + + for (var i = 0; i < s2.length; ++i) + if (chs2.indexOf(s2[i]) != -1) return i; - return s.length; + return s2.length; } + function schr(s, ch) { var r = s.indexOf(ch); if (r == -1) @@ -1473,10 +2569,10 @@ function schr(s, ch) { return s.substring(r); } function ssub(s, start, len) { - return s.substring(start, start+len); + return strSplit(s).slice(start, start+len).join(""); } function strlenGe(s, len) { - return s.length >= len; + return slen(s) >= len; } function trimZeroes(s) { @@ -1575,11 +2671,11 @@ function strcmp(str1, str2) { } function chr(n) { - return String.fromCharCode(n); + return String.fromCodePoint(n); } function htmlifySpecialChar(ch) { - return "&#" + ch.charCodeAt(0) + ";"; + return "&#" + ch.codePointAt(0) + ";"; } @@ -2183,6 +3279,10 @@ function confrm(s) { return confirm(s) ? true : false; } +function currentUrl() { + return window.location.toString(); +} + // URL blessing @@ -2207,11 +3307,14 @@ function bless(s) { // Attribute name blessing +var maxCh = chr(127); function blessData(s) { - for (var i = 0; i < s.length; ++i) { - var c = s[i]; - if (!isAlnum(c) && c != '-' && c != '_') + var chars = strSplit(s); + + for (var i = 0; i < chars.length; ++i) { + var c = chars[i]; + if (c > maxCh || (!isAlnum(c) && c != '-' && c != '_')) er("Disallowed character in data-* attribute name"); } @@ -2222,9 +3325,11 @@ function blessData(s) { // CSS validation function atom(s) { - for (var i = 0; i < s.length; ++i) { - var c = s[i]; - if (!isAlnum(c) && c != '+' && c != '-' && c != '.' && c != '%' && c != '#') + var chars = strSplit(s); + + for (var i = 0; i < chars.length; ++i) { + var c = chars[i]; + if (c > maxCh || (!isAlnum(c) && c != '+' && c != '-' && c != '.' && c != '%' && c != '#')) er("Disallowed character in CSS atom"); } @@ -2232,10 +3337,12 @@ function atom(s) { } function css_url(s) { - for (var i = 0; i < s.length; ++i) { - var c = s[i]; - if (!isAlnum(c) && c != ':' && c != '/' && c != '.' && c != '_' && c != '+' - && c != '-' && c != '%' && c != '?' && c != '&' && c != '=' && c != '#') + var chars = strSplit(s); + + for (var i = 0; i < chars.length; ++i) { + var c = chars[i]; + if (c > maxCh || (!isAlnum(c) && c != ':' && c != '/' && c != '.' && c != '_' && c != '+' + && c != '-' && c != '%' && c != '?' && c != '&' && c != '=' && c != '#')) er("Disallowed character in CSS URL"); } @@ -2243,15 +3350,17 @@ function css_url(s) { } function property(s) { - if (s.length <= 0) + var chars = strSplit(s); + + if (chars.length <= 0) er("Empty CSS property"); - if (!isLower(s[0]) && s[0] != '_') + if (chars[0] > maxCh || (!isLower(chars[0]) && chars[0] != '_')) er("Bad initial character in CSS property"); - for (var i = 0; i < s.length; ++i) { - var c = s[i]; - if (!isLower(c) && !isDigit(c) && c != '_' && c != '-') + for (var i = 0; i < chars.length; ++i) { + var c = chars[i]; + if (c > maxCh || (!isLower(c) && !isDigit(c) && c != '_' && c != '-')) er("Disallowed character in CSS property"); } @@ -2276,5 +3385,9 @@ function giveFocus(id) { er("Tried to give focus to ID not used in document: " + id); } +function anchorUrl(id) { + return "#" + id; +} + // App-specific code diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 66cc0e50..9d6e56d5 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -79,6 +79,9 @@ val toupper : char -> char val ord : char -> int val chr : int -> char +val iscodepoint : int -> bool +val issingle : char -> bool + (** String operations *) val strlen : string -> int @@ -92,6 +95,7 @@ val strsindex : string -> string -> option int val strcspn : string -> string -> int val substring : string -> int -> int -> string val str1 : char -> string +val ofUnicode : int -> string class show val show : t ::: Type -> show t -> t -> string @@ -274,6 +278,8 @@ con serialized :: Type -> Type val serialize : t ::: Type -> t -> serialized t val deserialize : t ::: Type -> serialized t -> t val sql_serialized : t ::: Type -> sql_injectable_prim (serialized t) +val unsafeSerializedToString : t ::: Type -> serialized t -> string +val unsafeSerializedFromString : t ::: Type -> string -> serialized t con primary_key :: {Type} -> {{Unit}} -> Type val no_primary_key : fs ::: {Type} -> primary_key fs [] @@ -566,9 +572,6 @@ val sql_div : t ::: Type -> sql_arith t -> sql_binary t t t val sql_mod : sql_binary int int int val sql_eq : t ::: Type -> sql_binary t t bool -(* Note that the semantics of this operator on nullable types are different than for standard SQL! - * Instead, we do it the sane way, where [NULL = NULL]. *) - val sql_ne : t ::: Type -> sql_binary t t bool val sql_lt : t ::: Type -> sql_binary t t bool val sql_le : t ::: Type -> sql_binary t t bool @@ -620,6 +623,16 @@ val sql_known : t ::: Type -> sql_ufunc t bool val sql_lower : sql_ufunc string string val sql_upper : sql_ufunc string string +con sql_bfunc :: Type -> Type -> Type -> Type +val sql_bfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> dom1 ::: Type -> dom2 ::: Type -> ran ::: Type + -> sql_bfunc dom1 dom2 ran + -> sql_exp tables agg exps dom1 + -> sql_exp tables agg exps dom2 + -> sql_exp tables agg exps ran +val sql_similarity : sql_bfunc string string float +(* Only supported by Postgres for now, via the pg_trgm module *) + val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> sql_injectable_prim t -> sql_exp tables agg exps t @@ -803,6 +816,7 @@ type id val fresh : transaction id val giveFocus : id -> transaction unit val show_id : show id +val anchorUrl : id -> url val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ [Dyn]] => unit -> tag [Signal = signal (xml ([Dyn] ++ ctx) use bind)] ([Dyn] ++ ctx) [] use bind @@ -830,7 +844,7 @@ val meta : unit -> tag [Nam = meta, Content = string, Id = id] head [] [] [] datatype mouseButton = Left | Right | Middle -type mouseEvent = { ScreenX : int, ScreenY : int, ClientX : int, ClientY : int, +type mouseEvent = { ScreenX : int, ScreenY : int, ClientX : int, ClientY : int, OffsetX : int, OffsetY : int, CtrlKey : bool, ShiftKey : bool, AltKey : bool, MetaKey : bool, Button : mouseButton } @@ -1014,6 +1028,8 @@ val checkMime : string -> option mimeType val returnBlob : t ::: Type -> blob -> mimeType -> transaction t val blobSize : blob -> int val textBlob : string -> blob +val textOfBlob : blob -> option string +(* Returns [Some] exactly when the blob contains no zero bytes. *) type postBody val postType : postBody -> string @@ -1069,7 +1085,7 @@ val ctel : ctext val ccolor : ctext val cnumber : cformTag ([Source = source (option float), Min = float, Max = float, Step = float, Size = int] ++ boxAttrs ++ inputAttrs) [] -val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int] ++ boxAttrs ++ inputAttrs) [] +val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int, Step = float] ++ boxAttrs ++ inputAttrs) [] val cdate : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] val cdatetime : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] val cdatetime_local : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] diff --git a/lib/ur/datetime.ur b/lib/ur/datetime.ur index 9aeab291..99fd5a7d 100644 --- a/lib/ur/datetime.ur +++ b/lib/ur/datetime.ur @@ -88,7 +88,8 @@ fun intToMonth i = case i of | n => error <xml>Invalid month number {[n]}</xml> val eq_month = mkEq (fn a b => monthToInt a = monthToInt b) - +val ord_month = mkOrd {Lt = fn a b => monthToInt a < monthToInt b, + Le = fn a b => monthToInt a <= monthToInt b} fun toTime dt : time = fromDatetime dt.Year (monthToInt dt.Month) dt.Day dt.Hour dt.Minute dt.Second diff --git a/lib/ur/datetime.urs b/lib/ur/datetime.urs index 972f86bf..f8460443 100644 --- a/lib/ur/datetime.urs +++ b/lib/ur/datetime.urs @@ -20,6 +20,7 @@ val show_day_of_week : show day_of_week val show_month : show month val eq_day_of_week : eq day_of_week val eq_month : eq month +val ord_month : ord month val dayOfWeekToInt : day_of_week -> int val intToDayOfWeek : int -> day_of_week val monthToInt : month -> int diff --git a/lib/ur/json.ur b/lib/ur/json.ur index 817ec16e..1222cdbf 100644 --- a/lib/ur/json.ur +++ b/lib/ur/json.ur @@ -51,9 +51,7 @@ fun escape s = | #"\r" => "\\r" | #"\t" => "\\t" | #"\"" => "\\\"" - | #"\'" => "\\\'" | #"\\" => "\\\\" - | #"/" => "\\/" | x => String.str ch ) ^ esc (String.suffix s 1) end @@ -61,64 +59,143 @@ fun escape s = "\"" ^ esc s end +fun unhex ch = + if Char.isDigit ch then + Char.toInt ch - Char.toInt #"0" + else if Char.isXdigit ch then + if Char.isUpper ch then + 10 + (Char.toInt ch - Char.toInt #"A") + else + 10 + (Char.toInt ch - Char.toInt #"a") + else + error <xml>Invalid hexadecimal digit "{[ch]}"</xml> + fun unescape s = let val len = String.length s - fun findEnd i = + fun findEnd i s = if i >= len then error <xml>JSON unescape: string ends before quote: {[s]}</xml> else let - val ch = String.sub s i + val ch = String.sub s 0 in case ch of #"\"" => i | #"\\" => if i+1 >= len then error <xml>JSON unescape: Bad escape sequence: {[s]}</xml> + else if String.sub s 1 = #"u" then + if i+5 >= len then + error <xml>JSON unescape: Bad escape sequence: {[s]}</xml> + else + findEnd (i+6) (String.suffix s 6) else - findEnd (i+2) - | _ => findEnd (i+1) + findEnd (i+2) (String.suffix s 2) + | _ => findEnd (i+1) (String.suffix s 1) end - val last = findEnd 1 + val last = findEnd 1 (String.suffix s 1) - fun unesc i = + fun unesc i s = if i >= last then "" else let - val ch = String.sub s i + val ch = String.sub s 0 in case ch of #"\\" => if i+1 >= len then error <xml>JSON unescape: Bad escape sequence: {[s]}</xml> + else if String.sub s 1 = #"u" then + if i+5 >= len then + error <xml>JSON unescape: Unicode ends early</xml> + else + let + val n = + unhex (String.sub s 2) * (256*16) + + unhex (String.sub s 3) * 256 + + unhex (String.sub s 4) * 16 + + unhex (String.sub s 5) + in + ofUnicode n ^ unesc (i+6) (String.suffix s 6) + end else - (case String.sub s (i+1) of + (case String.sub s 1 of #"n" => "\n" | #"r" => "\r" | #"t" => "\t" | #"\"" => "\"" - | #"\'" => "\'" | #"\\" => "\\" | #"/" => "/" | x => error <xml>JSON unescape: Bad escape char: {[x]}</xml>) ^ - unesc (i+2) - | _ => String.str ch ^ unesc (i+1) + unesc (i+2) (String.suffix s 2) + | _ => String.str ch ^ unesc (i+1) (String.suffix s 1) end in if len = 0 || String.sub s 0 <> #"\"" then error <xml>JSON unescape: String doesn't start with double quote: {[s]}</xml> else - (unesc 1, String.substring s {Start = last+1, Len = len-last-1}) + (unesc 1 (String.suffix s 1), String.suffix s (last+1)) end val json_string = {ToJson = escape, FromJson = unescape} +fun rfc3339_out s = + let + val out1 = timef "%Y-%m-%dT%H:%M:%S%z" s + val len = String.length out1 + in + if len < 2 then + error <xml>timef output too short</xml> + else + String.substring out1 {Start = 0, Len = len - 2} ^ ":" + ^ String.suffix out1 (len - 2) + end + +fun rfc3339_in s = + case String.split s #"T" of + None => error <xml>Invalid RFC 3339 string "{[s]}"</xml> + | Some (date, time) => + case String.msplit {Haystack = time, Needle = "Z+-"} of + None => error <xml>Invalid RFC 3339 string "{[s]}"</xml> + | Some (time, sep, rest) => + let + val time = case String.split time #"." of + None => time + | Some (time, _) => time + + val t = case readUtc (date ^ " " ^ time) of + None => error <xml>Invalid RFC 3339 string "{[s]}"</xml> + | Some t => t + + fun withOffset multiplier = + case String.split rest #":" of + None => error <xml>Invalid RFC 3339 string "{[s]}"</xml> + | Some (h, m) => + case (read h, read m) of + (Some h, Some m) => addSeconds t (multiplier * 60 * (60 * h + m)) + | _ => error <xml>Invalid RFC 3339 string "{[s]}"</xml> + in + case sep of + #"Z" => t + | #"+" => withOffset (-1) + | #"-" => withOffset 1 + | _ => error <xml>msplit returns impossible separator</xml> + end + +val json_time = {ToJson = fn tm => escape (rfc3339_out tm), + FromJson = fn s => + let + val (v, s') = unescape s + in + (rfc3339_in v, s') + end} + fun numIn [a] (_ : read a) s : a * string = let val len = String.length s @@ -261,6 +338,91 @@ fun skipOne s = skipOne s False False 0 0 end +fun json_record_withOptional [ts ::: {Type}] [ots ::: {Type}] [ts ~ ots] + (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) + (ofl : folder ots) (ojss : $(map json ots)) (onames : $(map (fn _ => string) ots)): json $(ts ++ map option ots) = + {ToJson = fn r => + let + val withRequired = + @foldR3 [json] [fn _ => string] [ident] [fn _ => string] + (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc => + escape name ^ ":" ^ j.ToJson v ^ (case acc of + "" => "" + | acc => "," ^ acc)) + "" fl jss names (r --- _) + + val withOptional = + @foldR3 [json] [fn _ => string] [option] [fn _ => string] + (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc => + case v of + None => acc + | Some v => + escape name ^ ":" ^ j.ToJson v ^ (case acc of + "" => "" + | acc => "," ^ acc)) + withRequired ofl ojss onames (r --- _) + in + "{" ^ withOptional ^ "}" + end, + FromJson = fn s => + let + fun fromJ s (r : $(map option (ts ++ ots))) : $(map option (ts ++ ots)) * string = + if String.length s = 0 then + error <xml>JSON object doesn't end in brace</xml> + else if String.sub s 0 = #"}" then + (r, String.substring s {Start = 1, Len = String.length s - 1}) + else let + val (name, s') = unescape s + val s' = skipSpaces s' + val s' = if String.length s' = 0 || String.sub s' 0 <> #":" then + error <xml>No colon after JSON object field name</xml> + else + skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1}) + + val (r, s') = @foldR2 [json] [fn _ => string] [fn ts => $(map option ts) -> $(map option ts) * string] + (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name' acc r => + if name = name' then + let + val (v, s') = j.FromJson s' + in + (r -- nm ++ {nm = Some v}, s') + end + else + let + val (r', s') = acc (r -- nm) + in + (r' ++ {nm = r.nm}, s') + end) + (fn r => (r, skipOne s')) + (@Folder.concat ! fl ofl) (jss ++ ojss) (names ++ onames) r + + val s' = skipSpaces s' + val s' = if String.length s' <> 0 && String.sub s' 0 = #"," then + skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1}) + else + s' + in + fromJ s' r + end + in + if String.length s = 0 || String.sub s 0 <> #"{" then + error <xml>JSON record doesn't begin with brace</xml> + else + let + val (r, s') = fromJ (skipSpaces (String.substring s {Start = 1, Len = String.length s - 1})) + (@map0 [option] (fn [t ::_] => None) (@Folder.concat ! fl ofl)) + in + (@map2 [option] [fn _ => string] [ident] (fn [t] (v : option t) name => + case v of + None => error <xml>Missing JSON object field {[name]}</xml> + | Some v => v) fl (r --- _) names + ++ (r --- _), s') + end +end} + +(* At the moment, the below code is largely copied and pasted from the last + * definition, because otherwise the compiler fails to inline enough for + * compilation to succeed. *) fun json_record [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json $ts = {ToJson = fn r => "{" ^ @foldR3 [json] [fn _ => string] [ident] [fn _ => string] (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc => diff --git a/lib/ur/json.urs b/lib/ur/json.urs index b4bd6350..ad49a40f 100644 --- a/lib/ur/json.urs +++ b/lib/ur/json.urs @@ -13,10 +13,20 @@ val json_string : json string val json_int : json int val json_float : json float val json_bool : json bool +val json_time : json time val json_option : a ::: Type -> json a -> json (option a) val json_list : a ::: Type -> json a -> json (list a) +(* By the way, time formatting follows RFC 3339, and we expose the more + * primitive formatting functions here. *) +val rfc3339_out : time -> string +val rfc3339_in : string -> time + val json_record : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json $ts +val json_record_withOptional : ts ::: {Type} -> ots ::: {Type} -> [ts ~ ots] + => folder ts -> $(map json ts) -> $(map (fn _ => string) ts) + -> folder ots -> $(map json ots) -> $(map (fn _ => string) ots) + -> json $(ts ++ map option ots) val json_variant : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json (variant ts) val json_unit : json unit diff --git a/lib/ur/list.ur b/lib/ur/list.ur index 95d6fbc8..1eb7626a 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -31,6 +31,16 @@ fun foldl [a] [b] (f : a -> b -> b) = foldl' end +fun foldli [a] [b] (f : int -> a -> b -> b) = + let + fun foldli' i acc ls = + case ls of + [] => acc + | x :: ls => foldli' (i + 1) (f i x acc) ls + in + foldli' 0 + end + val rev = fn [a] => let fun rev' acc (ls : list a) = @@ -101,6 +111,16 @@ fun mp [a] [b] f = mp' [] end +fun mapConcat [a] [b] f = + let + fun mapConcat' acc ls = + case ls of + [] => rev acc + | x :: ls => mapConcat' (revAppend (f x) acc) ls + in + mapConcat' [] + end + fun mapi [a] [b] f = let fun mp' n acc ls = @@ -153,6 +173,26 @@ fun mapM [m ::: (Type -> Type)] (_ : monad m) [a] [b] f = mapM' [] end +fun mapConcatM [m] (_ : monad m) [a] [b] f = + let + fun mapConcatM' acc ls = + case ls of + [] => return (rev acc) + | x :: ls' => ls <- f x; mapConcatM' (revAppend ls acc) ls' + in + mapConcatM' [] + end + +fun mapMi [m ::: (Type -> Type)] (_ : monad m) [a] [b] f = + let + fun mapM' i acc ls = + case ls of + [] => return (rev acc) + | x :: ls => x' <- f i x; mapM' (i + 1) (x' :: acc) ls + in + mapM' 0 [] + end + fun mapPartialM [m ::: (Type -> Type)] (_ : monad m) [a] [b] f = let fun mapPartialM' acc ls = @@ -283,6 +323,20 @@ fun search [a] [b] f = search' end +fun searchM [m] (_ : monad m) [a] [b] f = + let + fun search' ls = + case ls of + [] => return None + | x :: ls => + o <- f x; + case o of + None => search' ls + | v => return v + in + search' + end + fun foldlM [m] (_ : monad m) [a] [b] f = let fun foldlM' acc ls = @@ -319,7 +373,7 @@ fun filterM [m] (_ : monad m) [a] (p : a -> m bool) = filterM' [] end -fun all [m] f = +fun all [a] f = let fun all' ls = case ls of @@ -329,6 +383,21 @@ fun all [m] f = all' end +fun allM [m] (_ : monad m) [a] f = + let + fun all' ls = + case ls of + [] => return True + | x :: ls => + b <- f x; + if b then + all' ls + else + return False + in + all' + end + fun app [m] (_ : monad m) [a] f = let fun app' ls = @@ -454,6 +523,22 @@ fun assocAdd [a] [b] (_ : eq a) (x : a) (y : b) (ls : t (a * b)) = None => (x, y) :: ls | Some _ => ls +fun assocAddSorted [a] [b] (_ : eq a) (_ : ord a) (x : a) (y : b) (ls : t (a * b)) = + let + fun aas (ls : t (a * b)) (acc : t (a * b)) = + case ls of + [] => rev ((x, y) :: acc) + | (x', y') :: ls' => + if x' = x then + revAppend ((x, y) :: acc) ls' + else if x < x' then + revAppend ((x, y) :: acc) ls + else + aas ls' ((x', y') :: acc) + in + aas ls [] + end + fun recToList [a ::: Type] [r ::: {Unit}] (fl : folder r) = @foldUR [a] [fn _ => list a] (fn [nm ::_] [rest ::_] [[nm] ~ rest] x xs => x :: xs) [] fl diff --git a/lib/ur/list.urs b/lib/ur/list.urs index fe730152..f81f38a4 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -7,6 +7,8 @@ val foldl : a ::: Type -> b ::: Type -> (a -> b -> b) -> b -> t a -> b val foldlAbort : a ::: Type -> b ::: Type -> (a -> b -> option b) -> b -> t a -> option b val foldlMapAbort : a ::: Type -> b ::: Type -> c ::: Type -> (a -> b -> option (c * b)) -> b -> t a -> option (t c * b) +val foldli : a ::: Type -> b ::: Type + -> (int -> a -> b -> b) -> b -> t a -> b val foldr : a ::: Type -> b ::: Type -> (a -> b -> b) -> b -> t a -> b @@ -20,6 +22,10 @@ val append : a ::: Type -> t a -> t a -> t a val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b +val mapConcat : a ::: Type -> b ::: Type -> (a -> t b) -> t a -> t b + +val mapConcatM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> m (t b)) -> t a -> m (t b) + val mapPartial : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> t b val mapi : a ::: Type -> b ::: Type -> (int -> a -> b) -> t a -> t b @@ -31,6 +37,9 @@ val mapXi : a ::: Type -> ctx ::: {Unit} -> (int -> a -> xml ctx [] []) -> t a - val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> m b) -> t a -> m (t b) +val mapMi : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type + -> (int -> a -> m b) -> t a -> m (t b) + val mapPartialM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> m (option b)) -> t a -> m (t b) val mapXM : m ::: (Type -> Type) -> monad m -> a ::: Type -> ctx ::: {Unit} @@ -64,8 +73,12 @@ val findM : m ::: (Type -> Type) -> monad m -> a ::: Type -> (a -> m bool) -> t val search : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> option b +val searchM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> m (option b)) -> t a -> m (option b) + val all : a ::: Type -> (a -> bool) -> t a -> bool +val allM : m ::: (Type -> Type) -> monad m -> a ::: Type -> (a -> m bool) -> t a -> m bool + val app : m ::: (Type -> Type) -> monad m -> a ::: Type -> (a -> m unit) -> t a -> m unit @@ -104,6 +117,9 @@ val assoc : a ::: Type -> b ::: Type -> eq a -> a -> t (a * b) -> option b val assocAdd : a ::: Type -> b ::: Type -> eq a -> a -> b -> t (a * b) -> t (a * b) +val assocAddSorted : a ::: Type -> b ::: Type -> eq a -> ord a -> a -> b -> t (a * b) -> t (a * b) +(* Assume the list is already sorted in ascending order and maintain that ordering. *) + (** Converting records to lists *) val recToList : a ::: Type -> r ::: {Unit} -> folder r -> $(mapU a r) -> t a diff --git a/lib/ur/listPair.ur b/lib/ur/listPair.ur index 94b92872..52c73cd8 100644 --- a/lib/ur/listPair.ur +++ b/lib/ur/listPair.ur @@ -40,7 +40,31 @@ fun mp [a] [b] [c] (f : a -> b -> c) = case (ls1, ls2) of ([], []) => [] | (x1 :: ls1, x2 :: ls2) => f x1 x2 :: map' ls1 ls2 - | _ => error <xml>ListPair.map2: Unequal list lengths</xml> + | _ => error <xml>ListPair.mp: Unequal list lengths</xml> in map' end + +fun mapM [m] (_ : monad m) [a] [b] [c] (f : a -> b -> m c) = + let + fun mapM' ls1 ls2 = + case (ls1, ls2) of + ([], []) => return [] + | (x1 :: ls1, x2 :: ls2) => + y <- f x1 x2; + ls <- mapM' ls1 ls2; + return (y :: ls) + | _ => error <xml>ListPair.mapM: Unequal list lengths</xml> + in + mapM' + end + +fun unzip [a] [b] (ls : list (a * b)) : list a * list b = + let + fun unzip' ls ls1 ls2 = + case ls of + [] => (List.rev ls1, List.rev ls2) + | (x1, x2) :: ls => unzip' ls (x1 :: ls1) (x2 :: ls2) + in + unzip' ls [] [] + end diff --git a/lib/ur/listPair.urs b/lib/ur/listPair.urs index b473e226..91d8807d 100644 --- a/lib/ur/listPair.urs +++ b/lib/ur/listPair.urs @@ -8,3 +8,8 @@ val all : a ::: Type -> b ::: Type -> (a -> b -> bool) -> list a -> list b -> bo val mp : a ::: Type -> b ::: Type -> c ::: Type -> (a -> b -> c) -> list a -> list b -> list c + +val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> c ::: Type + -> (a -> b -> m c) -> list a -> list b -> m (list c) + +val unzip : a ::: Type -> b ::: Type -> list (a * b) -> list a * list b diff --git a/lib/ur/option.ur b/lib/ur/option.ur index baa08466..dd186161 100644 --- a/lib/ur/option.ur +++ b/lib/ur/option.ur @@ -59,3 +59,8 @@ fun unsafeGet [a] (o : option a) = case o of None => error <xml>Option.unsafeGet: encountered None</xml> | Some v => v + +fun mapM [m] (_ : monad m) [a] [b] (f : a -> m b) (x : t a) : m (t b) = + case x of + None => return None + | Some y => z <- f y; return (Some z) diff --git a/lib/ur/option.urs b/lib/ur/option.urs index c30c40e7..705c0313 100644 --- a/lib/ur/option.urs +++ b/lib/ur/option.urs @@ -14,3 +14,5 @@ val bind : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> t b val get : a ::: Type -> a -> option a -> a val unsafeGet : a ::: Type -> option a -> a + +val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> m b) -> t a -> m (t b) diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 02567917..92f1ecdd 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -172,6 +172,17 @@ fun foldR3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [tr :: { f [nm] [t] [rest] r1.nm r2.nm r3.nm (acc (r1 -- nm) (r2 -- nm) (r3 -- nm))) (fn _ _ _ => i) +fun foldR4 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [tf4 :: K -> Type] [tr :: {K} -> Type] + (f : nm :: Name -> t :: K -> rest :: {K} + -> [[nm] ~ rest] => + tf1 t -> tf2 t -> tf3 t -> tf4 t -> tr rest -> tr ([nm = t] ++ rest)) + (i : tr []) [r ::: {K}] (fl : folder r) = + fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> $(map tf4 r) -> tr r] + (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] + (acc : _ -> _ -> _ -> _ -> tr rest) r1 r2 r3 r4 => + f [nm] [t] [rest] r1.nm r2.nm r3.nm r4.nm (acc (r1 -- nm) (r2 -- nm) (r3 -- nm) (r4 -- nm))) + (fn _ _ _ _ => i) + fun mapUX [tf :: Type] [ctx :: {Unit}] (f : nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] => tf -> xml ctx [] []) = @@foldR [fn _ => tf] [fn _ => xml ctx [] []] @@ -224,6 +235,16 @@ fun mapX3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [ctx :: { <xml>{f [nm] [t] [rest] r1 r2 r3}{acc}</xml>) <xml/> +fun mapX4 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [tf4 :: K -> Type] [ctx :: {Unit}] + (f : nm :: Name -> t :: K -> rest :: {K} + -> [[nm] ~ rest] => + tf1 t -> tf2 t -> tf3 t -> tf4 t -> xml ctx [] []) = + @@foldR4 [tf1] [tf2] [tf3] [tf4] [fn _ => xml ctx [] []] + (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] + r1 r2 r3 r4 acc => + <xml>{f [nm] [t] [rest] r1 r2 r3 r4}{acc}</xml>) + <xml/> + fun query1 [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [] [t = fs] []) (f : $fs -> state -> transaction state) (i : state) = query q (fn r => f r.t) i diff --git a/lib/ur/top.urs b/lib/ur/top.urs index ec098955..a367a989 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -121,6 +121,15 @@ val foldR3 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type -> tr [] -> r ::: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> tr r +(* Fold (generalized safe zip) along four heterogenously-typed records *) +val foldR4 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type) -> tf4 :: (K -> Type) + -> tr :: ({K} -> Type) + -> (nm :: Name -> t :: K -> rest :: {K} + -> [[nm] ~ rest] => + tf1 t -> tf2 t -> tf3 t -> tf4 t -> tr rest -> tr ([nm = t] ++ rest)) + -> tr [] + -> r ::: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> $(map tf4 r) -> tr r + (* Generate some XML by mapping over a uniformly-typed record *) val mapUX : tf :: Type -> ctx :: {Unit} -> (nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] => @@ -159,6 +168,13 @@ val mapX3 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type) -> r ::: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> xml ctx [] [] +val mapX4 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type) -> tf4 :: (K -> Type) -> ctx :: {Unit} + -> (nm :: Name -> t :: K -> rest :: {K} + -> [[nm] ~ rest] => + tf1 t -> tf2 t -> tf3 t -> tf4 t -> xml ctx [] []) + -> r ::: {K} -> folder r + -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> $(map tf4 r) -> xml ctx [] [] + (* Note that the next two functions return elements in the _reverse_ of the natural order! * Such a choice interacts well with the time complexity of standard list operations. * It's easy to regain the natural order by inverting a query's 'ORDER BY' condition. *) diff --git a/shell.nix b/shell.nix new file mode 100644 index 00000000..e9b047ee --- /dev/null +++ b/shell.nix @@ -0,0 +1,7 @@ +let + pkgs = import <nixpkgs> {}; + def = import ./default.nix; +in +pkgs.mkShell { + buildInputs = def.buildInputs; +} diff --git a/src/bg_thread.dummy.sml b/src/bg_thread.dummy.sml new file mode 100644 index 00000000..699fa741 --- /dev/null +++ b/src/bg_thread.dummy.sml @@ -0,0 +1,9 @@ +(* + Dummy implementation. Threading is only supported in MLton. + All other implementations just immediately run the background tasks +*) +structure BgThread:> BGTHREAD = struct + fun queueBgTask filename f = f () + fun hasBgTasks () = false + fun runBgTaskForABit () = () +end diff --git a/src/bg_thread.mlton.sml b/src/bg_thread.mlton.sml new file mode 100644 index 00000000..91195940 --- /dev/null +++ b/src/bg_thread.mlton.sml @@ -0,0 +1,65 @@ +(* Notice: API is kinda bad. We only allow queuing a single task per file *) +(* This works for us because we only do elaboration in the background, nothing else *) + +structure BgThread:> BGTHREAD = struct + open Posix.Signal + open MLton + open Itimer Signal Thread + + val topLevel: Thread.Runnable.t option ref = ref NONE + val currentRunningThreadIsForFileName: string ref = ref "" + (* FIFO queue: Max one task per fileName *) + val tasks: ((Thread.Runnable.t * string) list) ref = ref [] + fun hasBgTasks () = List.length (!tasks) > 0 + + fun setItimer t = + Itimer.set (Itimer.Real, + {value = t, + interval = t}) + + + fun done () = Thread.atomically + (fn () => + ( tasks := (List.filter (fn q => #2 q <> (!currentRunningThreadIsForFileName)) (!tasks)) + ; case !tasks of + [] => (setItimer Time.zeroTime + ; currentRunningThreadIsForFileName := "" + ; switch (fn _ => valOf (!topLevel))) + | t :: rest => (currentRunningThreadIsForFileName := #2 t + ; switch (fn _ => #1 t)))) + + fun queueBgTask fileName f = + let + fun new (f: unit -> unit): Thread.Runnable.t = + Thread.prepare + (Thread.new (fn () => ((f () handle _ => done ()) + ; done ())), + ()) + in + case List.find (fn t => #2 t = fileName) (!tasks) of + NONE => tasks := (new f, fileName) :: (!tasks) + | SOME t => + (* Move existing task to front of list *) + tasks := t :: List.filter (fn q => #2 q <> fileName) (!tasks) + end + + fun replaceInList (l: 'a list) (f: 'a -> bool) (replacement: 'a) = + List.map (fn a => if f a then replacement else a ) l + fun runBgTaskForABit () = + case !(tasks) of + [] => () + | t :: rest => + (setHandler (alrm, Handler.handler (fn t => (setItimer Time.zeroTime + (* This might some not needed, but other wise you get "Dead thread" error *) + ; tasks := replaceInList + (!tasks) + (fn t => #2 t = (!currentRunningThreadIsForFileName)) + (t, (!currentRunningThreadIsForFileName)) + ; currentRunningThreadIsForFileName := "" + ; valOf (!topLevel)))) + ; setItimer (Time.fromMilliseconds 200) + ; currentRunningThreadIsForFileName := #2 t + ; switch (fn top => (topLevel := SOME (Thread.prepare (top, ())); #1 t)) (* store top level thread and activate BG thread *) + ; setItimer Time.zeroTime + ) + end diff --git a/src/bg_thread.sig b/src/bg_thread.sig new file mode 100644 index 00000000..5455bbc8 --- /dev/null +++ b/src/bg_thread.sig @@ -0,0 +1,7 @@ +(* Notice: API is kinda bad. We only allow queuing a single task per file *) +(* This works for us because we only do elaboration in the background, nothing else *) +signature BGTHREAD = sig + val queueBgTask: string (* fileName *) -> (unit -> unit) -> unit + val hasBgTasks: unit -> bool + val runBgTaskForABit: unit -> unit +end diff --git a/src/c/Makefile.am b/src/c/Makefile.am index 58f5153c..ff4b6eaf 100644 --- a/src/c/Makefile.am +++ b/src/c/Makefile.am @@ -1,21 +1,26 @@ lib_LTLIBRARIES = liburweb.la liburweb_http.la liburweb_cgi.la liburweb_fastcgi.la liburweb_static.la -liburweb_la_SOURCES = memmem.c openssl.c urweb.c request.c queue.c +liburweb_la_SOURCES = memmem.c memmem.h openssl.c urweb.c request.c queue.c liburweb_http_la_SOURCES = http.c liburweb_cgi_la_SOURCES = cgi.c liburweb_fastcgi_la_SOURCES = fastcgi.c fastcgi.h liburweb_static_la_SOURCES = static.c -AM_CPPFLAGS = -I$(srcdir)/../../include/urweb $(OPENSSL_INCLUDES) +AM_CPPFLAGS = -I$(srcdir)/../../include/urweb $(OPENSSL_INCLUDES) $(ICU_INCLUDES) AM_CFLAGS = -Wall -Wunused-parameter -Werror -Wno-format-security -Wno-deprecated-declarations -U_FORTIFY_SOURCE $(PTHREAD_CFLAGS) liburweb_la_LDFLAGS = $(AM_LDFLAGS) $(OPENSSL_LDFLAGS) \ - -export-symbols-regex '^(client_pruner|pthread_create_big|strcmp_nullsafe|uw_.*)' -liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS) + -export-symbols-regex '^(client_pruner|pthread_create_big|strcmp_nullsafe|uw_.*)' \ + -version-info 1:0:0 +liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS) $(ICU_LIBS) -licui18n -licuuc -licudata -licuio liburweb_http_la_LIBADD = liburweb.la -liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 liburweb_cgi_la_LIBADD = liburweb.la -liburweb_cgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_cgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 liburweb_fastcgi_la_LIBADD = liburweb.la -liburweb_fastcgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_fastcgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 liburweb_static_la_LIBADD = liburweb.la -liburweb_static_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_static_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 diff --git a/src/c/http.c b/src/c/http.c index 72685508..de2f1376 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -11,6 +11,7 @@ #include <unistd.h> #include <signal.h> #include <stdarg.h> +#include <sys/un.h> #include <pthread.h> @@ -65,6 +66,7 @@ static void log_error(void *data, const char *fmt, ...) { va_start(ap, fmt); vfprintf(stderr, fmt, ap); + fflush(stderr); } static void log_debug(void *data, const char *fmt, ...) { @@ -75,12 +77,13 @@ static void log_debug(void *data, const char *fmt, ...) { va_start(ap, fmt); vprintf(fmt, ap); + fflush(stdout); } } static uw_loggers ls = {NULL, log_error, log_debug}; -static unsigned max_buf_size = 1024 * 1024; // That's 1MB. +static unsigned max_buf_size = 10 * 1024 * 1024; // That's 10MB. static void *worker(void *data) { int me = *(int *)data; @@ -333,7 +336,7 @@ static void *worker(void *data) { } static void help(char *cmd) { - printf("Usage: %s [-p <port>] [-a <IPv4 address>] [-A <IPv6 address>] [-t <thread count>] [-m <bytes>] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe '-T' option sets socket recv timeout (0 disables timeout, default is 5 sec).\nThe '-m' sets the maximum size (in bytes) for any buffer used to hold HTTP data sent by clients. (The default is 1 MB.)\n", cmd); + printf("Usage: %s [-p <port>] [-a <IPv4 address>] [-A <IPv6 address>] [-u <UNIX socket>] [-t <thread count>] [-m <bytes>] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe '-T' option sets socket recv timeout (0 disables timeout, default is 5 sec).\nThe '-m' sets the maximum size (in bytes) for any buffer used to hold HTTP data sent by clients. (The default is 1 MB.)\n", cmd); } static void sigint(int signum) { @@ -346,6 +349,7 @@ union uw_sockaddr { struct sockaddr sa; struct sockaddr_in ipv4; struct sockaddr_in6 ipv6; + struct sockaddr_un un; }; int main(int argc, char *argv[]) { @@ -365,7 +369,7 @@ int main(int argc, char *argv[]) { my_addr.sa.sa_family = AF_INET; my_addr.ipv4.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP - while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:m:")) != -1) { + while ((opt = getopt(argc, argv, "hp:a:A:u:t:kqT:m:")) != -1) { switch (opt) { case '?': fprintf(stderr, "Unknown command-line option\n"); @@ -403,6 +407,15 @@ int main(int argc, char *argv[]) { } break; + case 'u': + my_addr.sa.sa_family = AF_UNIX; + if (!strncpy(my_addr.un.sun_path, optarg, sizeof(my_addr.un.sun_path)-1)) { + fprintf(stderr, "Invalid UNIX socket filename\n"); + help(argv[0]); + return 1; + } + break; + case 't': nthreads = atoi(optarg); if (nthreads <= 0) { @@ -472,6 +485,11 @@ int main(int argc, char *argv[]) { my_size = sizeof(my_addr.ipv6); my_addr.ipv6.sin6_port = htons(uw_port); break; + + case AF_UNIX: + unlink(my_addr.un.sun_path); + my_size = sizeof(my_addr.un); + break; } if (bind(sockfd, &my_addr.sa, my_size) < 0) { diff --git a/src/c/memmem.c b/src/c/memmem.c index f31f4e31..efddd0c1 100644 --- a/src/c/memmem.c +++ b/src/c/memmem.c @@ -1,4 +1,6 @@ -#include "config.h" +#include "memmem.h" + +#ifndef HAVE_MEMMEM /* $NetBSD$ */ @@ -38,8 +40,6 @@ * POSSIBILITY OF SUCH DAMAGE. */ -// Function renamed by Adam Chlipala in 2016. - #include <sys/cdefs.h> #if defined(LIBC_SCCS) && !defined(lint) __RCSID("$NetBSD$"); @@ -54,13 +54,8 @@ __RCSID("$NetBSD$"); #define NULL ((char *)0) #endif -/* - * urweb_memmem() returns the location of the first occurence of data - * pattern b2 of size len2 in memory block b1 of size len1 or - * NULL if none is found. - */ void * -urweb_memmem(const void *b1, size_t len1, const void *b2, size_t len2) +memmem(const void *b1, size_t len1, const void *b2, size_t len2) { /* Sanity check */ if(!(b1 != NULL && b2 != NULL && len1 != 0 && len2 != 0)) @@ -85,3 +80,5 @@ urweb_memmem(const void *b1, size_t len1, const void *b2, size_t len2) return NULL; } + +#endif // !defined(HAVE_MEMMEM) diff --git a/src/c/memmem.h b/src/c/memmem.h new file mode 100644 index 00000000..0ddbb494 --- /dev/null +++ b/src/c/memmem.h @@ -0,0 +1,23 @@ +#ifndef URWEB_MEMMEM_H +#define URWEB_MEMMEM_H + +#include "config.h" + +#ifdef HAVE_MEMMEM + +#include <string.h> + +#else // !defined(HAVE_MEMMEM) + +#include <stddef.h> + +/* + * memmem() returns the location of the first occurence of data + * pattern b2 of size len2 in memory block b1 of size len1 or + * NULL if none is found. + */ +void *memmem(const void *b1, size_t len1, const void *b2, size_t len2); + +#endif // !defined(HAVE_MEMMEM) + +#endif // URWEB_MEMMEM_H diff --git a/src/c/request.c b/src/c/request.c index 3e7ac34c..195b3cdc 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -11,13 +11,12 @@ #include <pthread.h> +#include "memmem.h" #include "urweb.h" #include "request.h" #define MAX_RETRIES 5 -void *urweb_memmem(const void *b1, size_t len1, const void *b2, size_t len2); - static int try_rollback(uw_context ctx, int will_retry, void *logger_data, uw_logger log_error) { int r = uw_rollback(ctx, will_retry); @@ -422,7 +421,7 @@ request_result uw_request(uw_request_context rc, uw_context ctx, } } - part = urweb_memmem(after_sub_headers, body + body_len - after_sub_headers, boundary, boundary_len); + part = memmem(after_sub_headers, body + body_len - after_sub_headers, boundary, boundary_len); if (!part) { log_error(logger_data, "Missing boundary after multipart payload\n"); return FAILED; diff --git a/src/c/urweb.c b/src/c/urweb.c index e7efae38..0db5fc80 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -20,6 +20,10 @@ #include <pthread.h> +#include <unicode/utf8.h> +#include <unicode/ustring.h> +#include <unicode/uchar.h> + #include "types.h" #include "uthash.h" @@ -737,7 +741,10 @@ void uw_close(uw_context ctx) { } uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { - return ctx->get_header(ctx->get_header_data, h); + if (ctx->get_header) + return ctx->get_header(ctx->get_header_data, h); + else + return NULL; } void uw_set_headers(uw_context ctx, char *(*get_header)(void *, const char *), void *get_header_data) { @@ -896,9 +903,12 @@ char *uw_error_message(uw_context ctx) { return ctx->error_message; } -void uw_set_error_message(uw_context ctx, const char *msg) { - strncpy(ctx->error_message, msg, sizeof(ctx->error_message)); - ctx->error_message[sizeof(ctx->error_message)-1] = 0; +void uw_set_error_message(uw_context ctx, const char *fmt, ...) { + va_list ap; + va_start(ap, fmt); + + vsnprintf(ctx->error_message, ERROR_BUF_LEN, fmt, ap); + ctx->error_message[ERROR_BUF_LEN-1] = 0; } static input *INP(uw_context ctx) { @@ -1553,94 +1563,90 @@ const char *uw_Basis_get_settings(uw_context ctx, uw_unit u) { } } +uw_Basis_bool uw_Basis_isprint(uw_context ctx, uw_Basis_char ch); + +static void jsifyChar(char **buffer_ptr, uw_context ctx, uw_Basis_char c1) { + char* buffer = *buffer_ptr; + + switch (c1) { + case '"': + strcpy(buffer, "\\\""); + buffer += 2; + break; + case '\'': + strcpy(buffer, "\\047"); + buffer += 4; + break; + case '\\': + strcpy(buffer, "\\\\"); + buffer += 2; + break; + case '<': + strcpy(buffer, "\\074"); + buffer += 4; + break; + case '&': + strcpy(buffer, "\\046"); + buffer += 4; + break; + default: + if (uw_Basis_isprint(ctx, c1)) { + int offset = 0; + U8_APPEND_UNSAFE(buffer, offset, c1); + buffer += offset; + } else { + if(65536 > c1) { + sprintf(buffer, "\\u%04x", c1); + buffer += 6; + } else { + sprintf(buffer, "\\u{%06x}", c1); + buffer += 10; + } + } + } + + *buffer_ptr = buffer; +} + uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { char *r, *s2; + uw_Basis_char c; - uw_check_heap(ctx, strlen(s) * 4 + 3); + uw_check_heap(ctx, strlen(s) * 10 + 3); r = s2 = ctx->heap.front; *s2++ = '"'; - for (; *s; s++) { - unsigned char c = *s; - - switch (c) { - case '"': - strcpy(s2, "\\\""); - s2 += 2; - break; - case '\'': - strcpy(s2, "\\047"); - s2 += 4; - break; - case '\\': - strcpy(s2, "\\\\"); - s2 += 2; - break; - case '<': - strcpy(s2, "\\074"); - s2 += 4; - break; - case '&': - strcpy(s2, "\\046"); - s2 += 4; - break; - default: - if (isprint((int)c) || c >= 128) - *s2++ = c; - else { - sprintf(s2, "\\%03o", c); - s2 += 4; - } + int offset = 0; + while(s[offset] != 0) + { + U8_NEXT(s, offset, -1, c); + + jsifyChar(&s2, ctx, c); } - } strcpy(s2, "\""); ctx->heap.front = s2 + 2; + return r; } +uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c); + uw_Basis_string uw_Basis_jsifyChar(uw_context ctx, uw_Basis_char c1) { - unsigned char c = c1; char *r, *s2; - uw_check_heap(ctx, 7); + uw_check_heap(ctx, 10); r = s2 = ctx->heap.front; + *s2++ = '"'; - - switch (c) { - case '"': - strcpy(s2, "\\\""); - s2 += 2; - break; - case '\'': - strcpy(s2, "\\047"); - s2 += 4; - break; - case '\\': - strcpy(s2, "\\\\"); - s2 += 2; - break; - case '<': - strcpy(s2, "\\074"); - s2 += 4; - break; - case '&': - strcpy(s2, "\\046"); - s2 += 4; - break; - default: - if (isprint((int)c) || c >= 128) - *s2++ = c; - else { - sprintf(s2, "\\%03o", (unsigned char)c); - s2 += 4; - } - } + + jsifyChar(&s2, ctx, c1); strcpy(s2, "\""); ctx->heap.front = s2 + 2; + return r; } @@ -1684,6 +1690,7 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) { strcpy(s2, "\""); ctx->script.front = s2 + 1; + return r; } @@ -1951,29 +1958,61 @@ char *uw_Basis_urlifyFloat(uw_context ctx, uw_Basis_float n) { return r; } +static void aux_urlifyChar(char** ptr, uw_Basis_char c) { + char* p = *ptr; + + if((uint32_t)(c) <= 0x7f) { + sprintf(p, ".%02X", (uint8_t)(c)); + p += 3; + } else { + if((uint32_t)(c) <= 0x7ff) { + sprintf(p, ".%02X", (uint8_t)(((c)>>6)|0xc0)); + p += 3; + } else { + if((uint32_t)(c) <= 0xffff) { + sprintf(p, ".%02X", (uint8_t)(((c)>>12)|0xe0)); + p += 3; + } else { + sprintf(p, ".%02X", (uint8_t)(((c)>>18)|0xf0)); + p += 3; + sprintf(p, ".%02X", (uint8_t)((((c)>>12)&0x3f)|0x80)); + p += 3; + } + sprintf(p, ".%02X", (uint8_t)((((c)>>6)&0x3f)|0x80)); + p += 3; + } + sprintf(p, ".%02X", (uint8_t)(((c)&0x3f)|0x80)); + p += 3; + } + + *ptr = p; +} + char *uw_Basis_urlifyString(uw_context ctx, uw_Basis_string s) { char *r, *p; if (s[0] == '\0') return "_"; - uw_check_heap(ctx, strlen(s) * 3 + 1 + !!(s[0] == '_')); + uw_check_heap(ctx, strlen(s) * 12 + 1 + !!(s[0] == '_')); r = p = ctx->heap.front; if (s[0] == '_') *p++ = '_'; - for (; *s; s++) { - unsigned char c = *s; - - if (c == ' ') + uw_Basis_char c; + int offset = 0, curr = 0; + while (s[offset] != 0) { + U8_NEXT(s, offset, -1, c); + + if (U8_IS_SINGLE(s[curr]) && s[curr] == ' ') *p++ = '+'; - else if (isalnum(c)) - *p++ = c; + else if (U8_IS_SINGLE(s[curr]) && isalnum(s[curr])) + *p++ = s[curr]; else { - sprintf(p, ".%02X", c); - p += 3; + aux_urlifyChar(&p, c); } + curr = offset; } *p++ = 0; @@ -1983,7 +2022,7 @@ char *uw_Basis_urlifyString(uw_context ctx, uw_Basis_string s) { char *uw_Basis_urlifyBool(uw_context ctx, uw_Basis_bool b) { (void)ctx; - if (b == uw_Basis_False) + if (!b) return "0"; else return "1"; @@ -2043,6 +2082,29 @@ uw_unit uw_Basis_urlifyTime_w(uw_context ctx, uw_Basis_time t) { return uw_Basis_urlifyInt_w(ctx, (uw_Basis_int)t.seconds * 1000000 + t.microseconds); } +uw_unit uw_Basis_urlifyChar_w(uw_context ctx, uw_Basis_char c) { + if (c == '\0') { + uw_check(ctx, 1); + uw_writec_unsafe(ctx, '_'); + return uw_unit_v; + } + + uw_check(ctx, 12 + !!(c == '_')); + + if (c == '_') + uw_writec_unsafe(ctx, '_'); + + if (c == ' ') + uw_writec_unsafe(ctx, '+'); + else if (isalnum(c) && c <= 0x7f) + uw_writec_unsafe(ctx, c); + else { + aux_urlifyChar(&(ctx->page.front), c); + } + + return uw_unit_v; +} + uw_unit uw_Basis_urlifyString_w(uw_context ctx, uw_Basis_string s) { if (s[0] == '\0') { uw_check(ctx, 1); @@ -2050,29 +2112,31 @@ uw_unit uw_Basis_urlifyString_w(uw_context ctx, uw_Basis_string s) { return uw_unit_v; } - uw_check(ctx, strlen(s) * 3 + !!(s[0] == '_')); + uw_check(ctx, strlen(s) * 12 + !!(s[0] == '_')); if (s[0] == '_') uw_writec_unsafe(ctx, '_'); - for (; *s; s++) { - unsigned char c = *s; - - if (c == ' ') + uw_Basis_char c; + int offset = 0, curr = 0; + while (s[offset] != 0) { + U8_NEXT(s, offset, -1, c); + + if (U8_IS_SINGLE(s[curr]) && s[curr] == ' ') uw_writec_unsafe(ctx, '+'); - else if (isalnum(c)) - uw_writec_unsafe(ctx, c); - else { - sprintf(ctx->page.front, ".%02X", c); - ctx->page.front += 3; + else if (U8_IS_SINGLE(s[curr]) && isalnum(s[curr])) + uw_writec_unsafe(ctx, s[curr]); + else { + aux_urlifyChar(&(ctx->page.front), c); } + curr = offset; } return uw_unit_v; } uw_unit uw_Basis_urlifyBool_w(uw_context ctx, uw_Basis_bool b) { - if (b == uw_Basis_False) + if (!b) uw_writec(ctx, '0'); else uw_writec(ctx, '1'); @@ -2207,6 +2271,23 @@ uw_Basis_string uw_Basis_unurlifyString(uw_context ctx, char **s) { return r; } +uw_Basis_char uw_Basis_unurlifyChar(uw_context ctx, char **s) { + char *new_s = uw_unurlify_advance(*s); + char *r; + int len; + + len = strlen(*s); + uw_check_heap(ctx, len + 1); + + r = ctx->heap.front; + ctx->heap.front = uw_unurlifyString_to(0, ctx, ctx->heap.front, *s); + *s = new_s; + if (strlen(r) == 1) + return r[0]; + else + uw_error(ctx, FATAL, "Unurlified character is multiple characters long"); +} + uw_Basis_unit uw_Basis_unurlifyUnit(uw_context ctx, char **s) { (void)ctx; *s = uw_unurlify_advance(*s); @@ -2249,25 +2330,40 @@ uw_unit uw_Basis_htmlifyInt_w(uw_context ctx, uw_Basis_int n) { return uw_unit_v; } -char *uw_Basis_htmlifySpecialChar(uw_context ctx, unsigned char ch) { +char *uw_Basis_htmlifySpecialChar(uw_context ctx, uw_Basis_char ch) { unsigned int n = ch; int len; char *r; - uw_check_heap(ctx, INTS_MAX+3); + uw_check_heap(ctx, INTS_MAX+3 + 1); r = ctx->heap.front; - sprintf(r, "&#%u;%n", n, &len); + len = sprintf(r, "&#%u;", n); ctx->heap.front += len+1; + return r; } -uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, unsigned char ch) { +uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, uw_Basis_char ch) { unsigned int n = ch; - int len; + int len = 0; uw_check(ctx, INTS_MAX+3); - sprintf(ctx->page.front, "&#%u;%n", n, &len); + + if(uw_Basis_isprint(ctx, ch)) { + + int32_t len_written = 0; + UErrorCode err = U_ZERO_ERROR; + + u_strToUTF8(ctx->page.front, 5, &len_written, (const UChar*)&ch, 1, &err); + len = len_written; + } + + // either it's a non-printable character, or we failed to convert to UTF-8 + if(len == 0) { + len = sprintf(ctx->page.front, "&#%u;", n); + } ctx->page.front += len; + return uw_unit_v; } @@ -2315,23 +2411,35 @@ uw_unit uw_Basis_jsifyInt_w(uw_context ctx, uw_Basis_int n) { char *uw_Basis_htmlifyString(uw_context ctx, const char *s) { char *r, *s2; + uw_Basis_char c1; + int oldoffset = 0, offset = 0, offset2 = 0, len = 0; + + uw_check_heap(ctx, strlen(s) * (INTS_MAX + 3) + 1); - uw_check_heap(ctx, strlen(s) * 5 + 1); - - for (r = s2 = ctx->heap.front; *s; s++) { - unsigned char c = *s; - - switch (c) { - case '<': - strcpy(s2, "<"); - s2 += 4; - break; - case '&': - strcpy(s2, "&"); - s2 += 5; - break; - default: - *s2++ = c; + r = s2 = ctx->heap.front; + + while (s[offset] != 0) { + oldoffset = offset; + U8_NEXT(s, offset, -1, c1); + + if ((offset - oldoffset == 1) && uw_Basis_isprint(ctx, c1)) { + switch (c1) { + case '<': + strcpy(s2, "<"); + s2 += 4; + break; + case '&': + strcpy(s2, "&"); + s2 += 5; + break; + default: + offset2 = 0; + U8_APPEND_UNSAFE(s2, offset2, c1); + s2 += offset2; + } + } else { + len = sprintf(s2, "&#%u;", c1); + s2 += len; } } @@ -2342,20 +2450,29 @@ char *uw_Basis_htmlifyString(uw_context ctx, const char *s) { uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { uw_check(ctx, strlen(s) * 6); - - for (; *s; s++) { - unsigned char c = *s; - - switch (c) { - case '<': - uw_write_unsafe(ctx, "<"); - break; - case '&': - uw_write_unsafe(ctx, "&"); - break; - default: - uw_writec_unsafe(ctx, c); + int offset = 0, oldoffset = 0; + uw_Basis_char c1; + + while(s[offset] != 0){ + oldoffset = offset; + U8_NEXT(s, offset, -1, c1); + + if ((offset - oldoffset == 1) && uw_Basis_isprint(ctx, c1)) { + + switch (c1) { + case '<': + uw_write_unsafe(ctx, "<"); + break; + case '&': + uw_write_unsafe(ctx, "&"); + break; + default: + uw_writec_unsafe(ctx, c1); + } } + else { + uw_Basis_htmlifySpecialChar_w(ctx, c1); + } } return uw_unit_v; @@ -2363,14 +2480,14 @@ uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { uw_Basis_string uw_Basis_htmlifyBool(uw_context ctx, uw_Basis_bool b) { (void)ctx; - if (b == uw_Basis_False) + if (!b) return "False"; else return "True"; } uw_unit uw_Basis_htmlifyBool_w(uw_context ctx, uw_Basis_bool b) { - if (b == uw_Basis_False) { + if (!b) { uw_check(ctx, 6); strcpy(ctx->page.front, "False"); ctx->page.front += 5; @@ -2419,27 +2536,33 @@ uw_unit uw_Basis_htmlifySource_w(uw_context ctx, uw_Basis_source src) { } uw_Basis_char uw_Basis_strsub(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { + uw_Basis_char c; + int offset = 0; + while (n >= 0) { - if (*s == 0) + + if (s[offset] == 0) uw_error(ctx, FATAL, "Out-of-bounds strsub"); + U8_NEXT(s, offset, -1, c); + if (n == 0) - return *s; + return c; --n; - ++s; } uw_error(ctx, FATAL, "Negative strsub bound"); } uw_Basis_string uw_Basis_strsuffix(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { + int offset = 0; while (n >= 0) { - if (*s == 0 || n == 0) - return s; + if (s[offset] == 0 || n == 0) + return s + offset; + U8_FWD_1(s, offset, -1); --n; - ++s; } uw_error(ctx, FATAL, "Negative strsuffix bound"); @@ -2447,40 +2570,81 @@ uw_Basis_string uw_Basis_strsuffix(uw_context ctx, uw_Basis_string s, uw_Basis_i uw_Basis_int uw_Basis_strlen(uw_context ctx, uw_Basis_string s) { (void)ctx; - return strlen(s); + int offset = 0, iterations = 0; + while (s[offset] != 0) { + U8_FWD_1(s, offset, -1); + ++iterations; + } + return iterations; } uw_Basis_bool uw_Basis_strlenGe(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { (void)ctx; - + int offset = 0; while (n > 0) { - if (*s == 0) + if (s[offset] == 0) return uw_Basis_False; - + + U8_FWD_1(s, offset, -1); --n; - ++s; } return uw_Basis_True; } +static int aux_strchr(uw_Basis_string s, uw_Basis_char ch, int *o_offset) { + int u8idx = 0, offset = 0, offsetpr = 0; + uw_Basis_char c; + + while (s[offset] != 0) { + U8_NEXT(s, offset, -1, c); + if (c == ch) { + *o_offset = offsetpr; + return u8idx; + } + + offsetpr = offset; + ++u8idx; + } + + *o_offset = -1; + return -1; +} + uw_Basis_string uw_Basis_strchr(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) { (void)ctx; - return strchr(s, ch); + int offset = -1; + if (aux_strchr(s, ch, &offset) > -1) { + return s + offset; + } + return NULL; } uw_Basis_int uw_Basis_strcspn(uw_context ctx, uw_Basis_string s, uw_Basis_string chs) { (void)ctx; - return strcspn(s, chs); + int offset = 0, u8idx = 0, offsetChs = 0; + uw_Basis_char c; + + while (s[offset] != 0) { + U8_NEXT(s, offset, -1, c); + if (aux_strchr(chs, c, &offsetChs) > -1) { + return u8idx; + } + ++u8idx; + } + + return u8idx; } uw_Basis_int *uw_Basis_strindex(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) { - uw_Basis_string r = strchr(s, ch); - if (r == NULL) + (void)ctx; + int offset = -1; + int r = aux_strchr(s, ch, &offset); + if (r == -1) return NULL; else { uw_Basis_int *nr = uw_malloc(ctx, sizeof(uw_Basis_int)); - *nr = r - s; + *nr = r; return nr; } } @@ -2491,13 +2655,19 @@ uw_Basis_int *uw_Basis_strsindex(uw_context ctx, const char *haystack, const cha return NULL; else { uw_Basis_int *nr = uw_malloc(ctx, sizeof(uw_Basis_int)); - *nr = r - haystack; + int src = r - haystack, offset = 0, utf8idx = 0; + while (offset < src) { + U8_FWD_1(haystack, offset, -1); + ++utf8idx; + } + + *nr = utf8idx; return nr; } } uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_string s2) { - int len = uw_Basis_strlen(ctx, s1) + uw_Basis_strlen(ctx, s2) + 1; + int len = strlen(s1) + strlen(s2) + 1; char *s; uw_check_heap(ctx, len); @@ -2512,8 +2682,8 @@ uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_str } uw_Basis_string uw_Basis_substring(uw_context ctx, uw_Basis_string s, uw_Basis_int start, uw_Basis_int len) { - size_t full_len = uw_Basis_strlen(ctx, s); - + int full_len = uw_Basis_strlen(ctx, s); + if (start < 0) uw_error(ctx, FATAL, "substring: Negative start index"); if (len < 0) @@ -2521,32 +2691,53 @@ uw_Basis_string uw_Basis_substring(uw_context ctx, uw_Basis_string s, uw_Basis_i if (start + len > full_len) uw_error(ctx, FATAL, "substring: Start index plus length is too large"); - if (start + len == full_len) - return &s[start]; - else { - uw_Basis_string r = uw_malloc(ctx, len+1); - memcpy(r, s+start, len); - r[len] = 0; + int offset = 0; + U8_FWD_N(s, offset, -1, start); + + if (start + len == full_len) { + return s + offset; + } else { + int end = offset; + U8_FWD_N(s, end, -1, len); + + int actual_len = end - offset; + + uw_Basis_string r = uw_malloc(ctx, actual_len + 1); + memcpy(r, s + offset, actual_len); + r[actual_len] = 0; return r; } - } uw_Basis_string uw_Basis_str1(uw_context ctx, uw_Basis_char ch) { char *r; - - uw_check_heap(ctx, 2); + int req = U8_LENGTH(ch); + int offset = 0; + + uw_check_heap(ctx, req + 1); r = ctx->heap.front; - r[0] = ch; - r[1] = 0; - ctx->heap.front += 2; + U8_APPEND_UNSAFE(r, offset, ch); + r[req] = 0; - return r; + ctx->heap.front += req + 1; + return r; +} + +uw_Basis_string uw_Basis_ofUnicode(uw_context ctx, uw_Basis_int n) { + UChar buf16[] = {n}; + uw_Basis_string out = uw_malloc(ctx, 3); + int32_t outLen; + UErrorCode pErrorCode = 0; + + if (u_strToUTF8(out, 3, &outLen, buf16, 1, &pErrorCode) == NULL || outLen == 0) + uw_error(ctx, FATAL, "Bad Unicode string to unescape (error %s)", u_errorName(pErrorCode)); + + return out; } uw_Basis_string uw_strdup(uw_context ctx, uw_Basis_string s1) { - int len = uw_Basis_strlen(ctx, s1) + 1; + int len = strlen(s1) + 1; char *s; uw_check_heap(ctx, len); @@ -2673,7 +2864,6 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { uw_Basis_string uw_Basis_sqlifyChar(uw_context ctx, uw_Basis_char c) { char *r, *s2; - uw_check_heap(ctx, 5 + uw_Estrings + strlen(uw_sqlsuffixChar)); r = s2 = ctx->heap.front; @@ -2818,7 +3008,7 @@ uw_Basis_string uw_Basis_sqlifyStringN(uw_context ctx, uw_Basis_string s) { char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { (void)ctx; - if (b == uw_Basis_False) + if (!b) return "FALSE"; else return "TRUE"; @@ -2902,7 +3092,7 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) { static uw_Basis_int true = 1; static uw_Basis_int false = 0; - if (b == uw_Basis_False) + if (!b) return (char *)&false; else return (char *)&true; @@ -2931,15 +3121,12 @@ uw_Basis_string uw_Basis_floatToString(uw_context ctx, uw_Basis_float n) { } uw_Basis_string uw_Basis_charToString(uw_context ctx, uw_Basis_char ch) { - char *r = uw_malloc(ctx, 2); - r[0] = ch; - r[1] = 0; - return r; + return uw_Basis_str1(ctx, ch); } uw_Basis_string uw_Basis_boolToString(uw_context ctx, uw_Basis_bool b) { (void)ctx; - if (b == uw_Basis_False) + if (!b) return "False"; else return "True"; @@ -2994,11 +3181,12 @@ uw_Basis_char *uw_Basis_stringToChar(uw_context ctx, uw_Basis_string s) { uw_Basis_char *r = uw_malloc(ctx, 1); r[0] = 0; return r; - } else if (s[1] != 0) + } else if (uw_Basis_strlenGe(ctx, s, 2)) return NULL; else { uw_Basis_char *r = uw_malloc(ctx, 1); - r[0] = s[0]; + int offset = 0; + U8_NEXT(s, offset, -1, *r); return r; } } @@ -3123,10 +3311,14 @@ uw_Basis_float uw_Basis_stringToFloat_error(uw_context ctx, uw_Basis_string s) { uw_Basis_char uw_Basis_stringToChar_error(uw_context ctx, uw_Basis_string s) { if (s[0] == 0) return 0; - else if (s[1] != 0) + else if (uw_Basis_strlenGe(ctx, s, 2)) uw_error(ctx, FATAL, "Can't parse char: %s", uw_Basis_htmlifyString(ctx, s)); - else - return s[0]; + else { + uw_Basis_char c; + int offset = 0; + U8_NEXT(s, offset, -1, c); + return c; + } } uw_Basis_bool uw_Basis_stringToBool_error(uw_context ctx, uw_Basis_string s) { @@ -3229,10 +3421,19 @@ uw_Basis_blob uw_Basis_stringToBlob_error(uw_context ctx, uw_Basis_string s, siz s += 2; while (*s) { + char a = s[0]; + s += 1; + char b; + if (*s){ + b = s[0]; + } else { + b = 0; + } int n; - sscanf(s, "%02x", &n); + char buf[3] = {a, b, 0}; + n = strtol(buf, NULL, 16); *r++ = n; - s += 2; + s += 1; } } else { while (*s) { @@ -3986,6 +4187,20 @@ uw_Basis_blob uw_Basis_textBlob(uw_context ctx, uw_Basis_string s) { return b; } +uw_Basis_string uw_Basis_textOfBlob(uw_context ctx, uw_Basis_blob b) { + size_t i; + uw_Basis_string r; + + for (i = 0; i < b.size; ++i) + if (b.data[i] == 0) + return NULL; + + r = uw_malloc(ctx, b.size + 1); + memcpy(r, b.data, b.size); + r[b.size] = 0; + return r; +} + uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) { (void)ctx; return f.data; @@ -4235,7 +4450,7 @@ uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_ struct tm tm = { .tm_year = year - 1900, .tm_mon = month, .tm_mday = day, .tm_hour = hour, .tm_min = minute, .tm_sec = second, .tm_isdst = -1 }; - uw_Basis_time r = { timelocal(&tm) }; + uw_Basis_time r = { mktime(&tm) }; return r; } @@ -4325,88 +4540,108 @@ void uw_set_global(uw_context ctx, char *name, void *data, void (*free)(void*)) uw_Basis_bool uw_Basis_isalnum(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isalnum((int)c); + return !!u_hasBinaryProperty(c, UCHAR_POSIX_ALNUM); } uw_Basis_bool uw_Basis_isalpha(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isalpha((int)c); + return !!u_hasBinaryProperty(c, UCHAR_ALPHABETIC); } uw_Basis_bool uw_Basis_isblank(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isblank((int)c); + return !!u_hasBinaryProperty(c, UCHAR_POSIX_BLANK); } uw_Basis_bool uw_Basis_iscntrl(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!iscntrl((int)c); + return !!(u_charType(c)==U_CONTROL_CHAR); } uw_Basis_bool uw_Basis_isdigit(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isdigit((int)c); + return !!u_isdigit(c); } uw_Basis_bool uw_Basis_isgraph(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isgraph((int)c); + return !!u_hasBinaryProperty(c, UCHAR_POSIX_GRAPH); } uw_Basis_bool uw_Basis_islower(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!islower((int)c); + return !!u_hasBinaryProperty(c, UCHAR_LOWERCASE); } uw_Basis_bool uw_Basis_isprint(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isprint((int)c); + return !!u_hasBinaryProperty(c, UCHAR_POSIX_PRINT); } uw_Basis_bool uw_Basis_ispunct(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!ispunct((int)c); + return !!u_ispunct(c); } uw_Basis_bool uw_Basis_isspace(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isspace((int)c); + return !!u_hasBinaryProperty(c, UCHAR_WHITE_SPACE); } uw_Basis_bool uw_Basis_isupper(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isupper((int)c); + return !!u_hasBinaryProperty(c, UCHAR_UPPERCASE); } uw_Basis_bool uw_Basis_isxdigit(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isxdigit((int)c); + return !!(c <= 0x7f && u_isxdigit(c)); } uw_Basis_char uw_Basis_tolower(uw_context ctx, uw_Basis_char c) { (void)ctx; - return tolower((int)c); + return u_tolower(c); } uw_Basis_char uw_Basis_toupper(uw_context ctx, uw_Basis_char c) { (void)ctx; - return toupper((int)c); + return u_toupper(c); } uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c) { (void)ctx; - return (unsigned char)c; + return (uw_Basis_int)c; +} + +uw_Basis_bool uw_Basis_iscodepoint(uw_context ctx, uw_Basis_int n) { + (void)ctx; + return !!(n <= 0x10FFFF); +} + +uw_Basis_bool uw_Basis_issingle(uw_context ctx, uw_Basis_char c) { + (void)ctx; + return !!(c < 128); } uw_Basis_char uw_Basis_chr(uw_context ctx, uw_Basis_int n) { (void)ctx; - return n; + uw_Basis_char ch = (uw_Basis_char)n; + + if (n > 0x10FFFF) { + uw_error(ctx, FATAL, "The integer %lld is not a valid char codepoint", n); + } + + return ch; } uw_Basis_string uw_Basis_currentUrl(uw_context ctx) { return ctx->current_url; } +uw_Basis_string uw_Basis_anchorUrl(uw_context ctx, uw_Basis_string s) { + return uw_Basis_strcat(ctx, uw_Basis_strcat(ctx, ctx->current_url, "#"), s); +} + void uw_set_currentUrl(uw_context ctx, char *s) { ctx->current_url = s; } @@ -4654,7 +4889,7 @@ uw_Basis_string uw_Basis_atom(uw_context ctx, uw_Basis_string s) { for (p = s; *p; ++p) { char c = *p; - if (!isalnum((int)c) && c != '+' && c != '-' && c != '.' && c != '%' && c != '#') + if (!U8_IS_SINGLE(c) || (!isalnum((int)c) && c != '+' && c != '-' && c != '.' && c != '%' && c != '#')) uw_error(ctx, FATAL, "Disallowed character in CSS atom"); } @@ -4666,8 +4901,8 @@ uw_Basis_string uw_Basis_css_url(uw_context ctx, uw_Basis_string s) { for (p = s; *p; ++p) { char c = *p; - if (!isalnum((int)c) && c != ':' && c != '/' && c != '.' && c != '_' && c != '+' - && c != '-' && c != '%' && c != '?' && c != '&' && c != '=' && c != '#') + if (!U8_IS_SINGLE(c) || (!isalnum((int)c) && c != ':' && c != '/' && c != '.' && c != '_' && c != '+' + && c != '-' && c != '%' && c != '?' && c != '&' && c != '=' && c != '#')) uw_error(ctx, FATAL, "Disallowed character in CSS URL"); } @@ -4680,12 +4915,12 @@ uw_Basis_string uw_Basis_property(uw_context ctx, uw_Basis_string s) { if (!*s) uw_error(ctx, FATAL, "Empty CSS property"); - if (!islower((int)s[0]) && s[0] != '_') + if (!U8_IS_SINGLE(s[0]) || (!islower((int)s[0]) && s[0] != '_')) uw_error(ctx, FATAL, "Bad initial character in CSS property"); for (p = s; *p; ++p) { char c = *p; - if (!islower((int)c) && !isdigit((int)c) && c != '_' && c != '-') + if (!U8_IS_SINGLE(c) || (!islower((int)c) && !isdigit((int)c) && c != '_' && c != '-')) uw_error(ctx, FATAL, "Disallowed character in CSS property"); } @@ -4719,13 +4954,13 @@ uw_Basis_postField *uw_Basis_firstFormField(uw_context ctx, uw_Basis_string s) { f = uw_malloc(ctx, sizeof(uw_Basis_postField)); unurl = s; - f->name = uw_Basis_unurlifyString(ctx, &unurl); + f->name = uw_Basis_unurlifyString_fromClient(ctx, &unurl); s = strchr(s, 0); if (!s) uw_error(ctx, FATAL, "firstFormField: Missing null terminator"); ++s; unurl = s; - f->value = uw_Basis_unurlifyString(ctx, &unurl); + f->value = uw_Basis_unurlifyString_fromClient(ctx, &unurl); s = strchr(s, 0); if (!s) uw_error(ctx, FATAL, "firstFormField: Missing null terminator"); @@ -4738,7 +4973,7 @@ uw_Basis_string uw_Basis_blessData(uw_context ctx, uw_Basis_string s) { char *p = s; for (; *p; ++p) - if (!isalnum(*p) && *p != '-' && *p != '_') + if (!U8_IS_SINGLE(*p) || (!isalnum(*p) && *p != '-' && *p != '_')) uw_error(ctx, FATAL, "Illegal HTML5 data-* attribute: %s", s); return s; @@ -5070,7 +5305,7 @@ int strcmp_nullsafe(const char *str1, const char *str2) { static int is_valid_hash(uw_Basis_string hash) { for (; *hash; ++hash) - if (!isxdigit(*hash)) + if (!U8_IS_SINGLE(*hash) || !isxdigit(*hash)) return 0; return 1; @@ -5102,7 +5337,7 @@ uw_unit uw_Basis_cache_file(uw_context ctx, uw_Basis_blob contents) { fd = mkstemp(tempfile); if (fd < 0) - uw_error(ctx, FATAL, "Error creating temporary file for cache"); + uw_error(ctx, FATAL, "Error creating temporary file %s for cache", tempfile); while (written_so_far < contents.size) { ssize_t written_just_now = write(fd, contents.data + written_so_far, contents.size - written_so_far); @@ -5134,9 +5369,8 @@ uw_Basis_blob uw_Basis_check_filecache(uw_context ctx, uw_Basis_string hash) { // Hashes come formatted for printing by Postgres, which means they start with // two extra characters. Let's remove them. - if (!hash[0] || !hash[1]) - uw_error(ctx, FATAL, "Hash to check against file cache came in not in Postgres format: %s", hash); - hash += 2; + if (hash[0] == '\\' && hash[1] == 'x') + hash += 2; if (!dir) uw_error(ctx, FATAL, "Checking file cache when no directory is set"); diff --git a/src/cjr.sml b/src/cjr.sml index e582e6ae..9b154428 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -115,7 +115,7 @@ datatype decl' = | DTable of string * (string * typ) list * string * (string * string) list | DSequence of string | DView of string * (string * typ) list * string - | DDatabase of {name : string, expunge : int, initialize : int} + | DDatabase of {name : string, expunge : int, initialize : int, usesSimilar : bool} | DPreparedStatements of (string * int) list | DJavaScript of string diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 87d2576c..70ebdf43 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -952,7 +952,7 @@ fun unurlify fromClient env (t, loc) = newline, string ":", space, - string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", request), NULL))));"), + string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", *request), NULL))));"), newline], string "}", newline, @@ -1014,52 +1014,39 @@ fun urlify env t = let fun urlify' level (t as (_, loc)) = case #1 t of - TFfi ("Basis", "unit") => box [] + TFfi ("Basis", "unit") => box [string "uw_Basis_urlifyString_w(ctx, \"\");", + newline] | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t ^ "_w(ctx, it" ^ Int.toString level ^ ");"), newline] - | TRecord 0 => box [] + | TRecord 0 => box [string "uw_Basis_urlifyString_w(ctx, \"\");", + newline] | TRecord i => let - fun empty (t, _) = - case t of - TFfi ("Basis", "unit") => true - | TRecord 0 => true - | TRecord j => - List.all (fn (_, t) => empty t) (E.lookupStruct env j) - | _ => false - val xts = E.lookupStruct env i val (blocks, _) = foldl (fn ((x, t), (blocks, printingSinceLastSlash)) => - let - val thisEmpty = empty t - in - if thisEmpty then - (blocks, printingSinceLastSlash) - else - (box [string "{", - newline, - p_typ env t, - space, - string ("it" ^ Int.toString (level + 1)), - space, - string "=", - space, - string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"), - newline, - box (if printingSinceLastSlash then - [string "uw_write(ctx, \"/\");", - newline] - else - []), - urlify' (level + 1) t, - string "}", - newline] :: blocks, - true) - end) + (box [string "{", + newline, + p_typ env t, + space, + string ("it" ^ Int.toString (level + 1)), + space, + string "=", + space, + string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"), + newline, + box (if printingSinceLastSlash then + [string "uw_write(ctx, \"/\");", + newline] + else + []), + urlify' (level + 1) t, + string "}", + newline] :: blocks, + true)) ([], false) xts in box (rev blocks) @@ -2550,8 +2537,10 @@ fun p_decl env (dAll as (d, loc) : decl) = (case Settings.getOutputJsFile () of NONE => "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js" | SOME s => s) - val () = app_js := OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), - file = name} + val js = OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), + file = name} + val () = app_js := js + val () = Endpoints.setJavaScript js in box [string "static char jslib[] = \"", string (Prim.toCString s), @@ -3241,10 +3230,11 @@ fun p_file env (ds, ps) = val _ = foldl (fn (d, env) => ((case #1 d of - DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true; - dbstring := x; - expunge := y; - initialize := z) + DDatabase {name = x, expunge = y, initialize = z, ...} => + (hasDb := true; + dbstring := x; + expunge := y; + initialize := z) | DJavaScript _ => hasJs := true | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) => (x, sql_type_in env t)) xts) :: !tables @@ -3345,9 +3335,20 @@ fun p_file env (ds, ps) = string "}", newline] - val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds - val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds - val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) => SOME (n, x1, x2, e) | _ => NONE) ds + val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => + SOME (x1, x2, p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e) + | _ => NONE) ds + val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => + SOME (x1, x2, p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan)) + x2 dummyt) e) + | _ => NONE) ds + val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) => + SOME (n, x1, x2, p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e) + | _ => NONE) ds + + val (protos', defs') = ListPair.unzip (latestUrlHandlers ()) + val protos = protos @ protos' + val defs = defs @ defs' val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds @@ -3380,6 +3381,14 @@ fun p_file env (ds, ps) = newline, string "#include <time.h>", newline, + (case Settings.getFileCache () of + NONE => box [] + | SOME _ => box [string "#include <sys/types.h>", + newline, + string "#include <sys/stat.h>", + newline, + string "#include <unistd.h>", + newline]), if hasDb then box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"), newline] @@ -3467,7 +3476,7 @@ fun p_file env (ds, ps) = newline, newline, - box (ListUtil.mapi (fn (i, (_, x1, x2, e)) => + box (ListUtil.mapi (fn (i, (_, x1, x2, pe)) => box [string "static void uw_periodic", string (Int.toString i), string "(uw_context ctx) {", @@ -3478,7 +3487,7 @@ fun p_file env (ds, ps) = string x2, string "_1 = 0;", newline, - p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e, + pe, string ";", newline], string "}", @@ -3617,22 +3626,21 @@ fun p_file env (ds, ps) = box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) {", newline, - p_list_sep (box []) (fn (x1, x2, e) => box [string "({", - newline, - string "uw_Basis_client __uwr_", - string x1, - string "_0 = cli;", - newline, - string "uw_unit __uwr_", - string x2, - string "_1 = 0;", - newline, - p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan)) - x2 dummyt) e, - string ";", - newline, - string "});", - newline]) expungers, + p_list_sep (box []) (fn (x1, x2, pe) => box [string "({", + newline, + string "uw_Basis_client __uwr_", + string x1, + string "_0 = cli;", + newline, + string "uw_unit __uwr_", + string x2, + string "_1 = 0;", + newline, + pe, + string ";", + newline, + string "});", + newline]) expungers, if hasDb then box [p_enamed env (!expunge), @@ -3645,24 +3653,38 @@ fun p_file env (ds, ps) = newline, string "static void uw_initializer(uw_context ctx) {", newline, - box [string "uw_begin_initializing(ctx);", + box [(case Settings.getFileCache () of + NONE => box [] + | SOME dir => box [newline, + string "struct stat st = {0};", + newline, + newline, + string "if (stat(\"", + string (Prim.toCString dir), + string "\", &st) == -1)", + newline, + box [string "mkdir(\"", + string (Prim.toCString dir), + string "\", 0700);", + newline]]), + string "uw_begin_initializing(ctx);", newline, p_list_sep newline (fn x => x) (rev (!global_initializers)), string "uw_end_initializing(ctx);", newline, - p_list_sep (box []) (fn (x1, x2, e) => box [string "({", - newline, - string "uw_unit __uwr_", - string x1, - string "_0 = 0, __uwr_", - string x2, - string "_1 = 0;", - newline, - p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e, - string ";", - newline, - string "});", - newline]) initializers, + p_list_sep (box []) (fn (x1, x2, pe) => box [string "({", + newline, + string "uw_unit __uwr_", + string x1, + string "_0 = 0, __uwr_", + string x2, + string "_1 = 0;", + newline, + pe, + string ";", + newline, + string "});", + newline]) initializers, if hasDb then box [p_enamed env (!initialize), string "(ctx, 0);", @@ -3710,8 +3732,30 @@ fun p_file env (ds, ps) = newline] end +fun isText t = + case t of + String => true + | Nullable t => isText t + | _ => false + +fun declaresAsForeignKey xs s = + case String.tokens (fn ch => Char.isSpace ch orelse ch = #"," orelse ch = #"(" orelse ch = #")") s of + "FOREIGN" :: "KEY" :: rest => + let + fun consume rest = + case rest of + [] => false + | "REFERENCES" :: _ => false + | xs' :: rest' => xs' = xs orelse consume rest' + in + consume rest + end + | _ => false + fun p_sql env (ds, _) = let + val usesSimilar = ref false + val (pps, _) = ListUtil.foldlMap (fn (dAll as (d, _), env) => let @@ -3722,14 +3766,28 @@ fun p_sql env (ds, _) = string "(", p_list (fn (x, t) => let + val xs = Settings.mangleSql (CharVector.map Char.toLower x) val t = sql_type_in env t + + val ts = if #textKeysNeedLengths (Settings.currentDbms ()) andalso isText t + andalso (List.exists (declaresAsForeignKey xs o #2) csts + orelse List.exists (String.isSubstring (xs ^ "(255)")) (pk :: map #2 csts)) then + "varchar(255)" + else + #p_sql_type (Settings.currentDbms ()) t in - box [string (Settings.mangleSql (CharVector.map Char.toLower x)), + box [string xs, space, - string (#p_sql_type (Settings.currentDbms ()) t), + string ts, case t of Nullable _ => box [] - | _ => string " NOT NULL"] + | _ => string " NOT NULL", + case t of + Time => if #requiresTimestampDefaults (Settings.currentDbms ()) then + string " DEFAULT CURRENT_TIMESTAMP" + else + box [] + | _ => box []] end) xts, case (pk, csts) of ("", []) => box [] @@ -3737,7 +3795,12 @@ fun p_sql env (ds, _) = cut, case pk of "" => box [] - | _ => box [string "PRIMARY", + | _ => box [string "CONSTRAINT", + space, + string s, + string "_pkey", + space, + string "PRIMARY", space, string "KEY", space, @@ -3777,13 +3840,29 @@ fun p_sql env (ds, _) = string ";", newline, newline] + | DDatabase {usesSimilar = s, ...} => + (usesSimilar := s; + box []) | _ => box [] in (pp, E.declBinds env dAll) end) env ds in - box (string (#sqlPrefix (Settings.currentDbms ())) :: pps) + box ((case Settings.getFileCache () of + NONE => [] + | SOME _ => case #supportsSHA512 (Settings.currentDbms ()) of + NONE => (ErrorMsg.error "Using file cache with database that doesn't support SHA512"; + []) + | SOME r => [string (#InitializeDb r), newline, newline]) + @ (if !usesSimilar then + case #supportsSimilar (Settings.currentDbms ()) of + NONE => (ErrorMsg.error "Using SIMILAR with database that doesn't support it"; + []) + | SOME r => [string (#InitializeDb r), newline, newline] + else + []) + @ string (#sqlPrefix (Settings.currentDbms ())) :: pps) end end diff --git a/src/compiler.sig b/src/compiler.sig index bcf69fd4..6ed2f9a6 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -35,6 +35,7 @@ signature COMPILER = sig sources : string list, exe : string, sql : string option, + endpoints : string option, debug : bool, profile : bool, timeout : int, @@ -61,6 +62,7 @@ signature COMPILER = sig dbms : string option, sigFile : string option, fileCache : string option, + safeGetDefault : bool, safeGets : string list, onError : (string * string list * string) option, minHeap : int, @@ -115,6 +117,7 @@ signature COMPILER = sig val css : (Core.file, Css.report) phase val monoize : (Core.file, Mono.file) phase val mono_opt : (Mono.file, Mono.file) phase + val endpoints : (Mono.file, Mono.file) phase val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase @@ -163,12 +166,14 @@ signature COMPILER = sig val toUnpoly2 : (string, Core.file) transform val toShake4'' : (string, Core.file) transform val toEspecialize3 : (string, Core.file) transform + val toSpecialize3 : (string, Core.file) transform val toReduce2 : (string, Core.file) transform val toShake5 : (string, Core.file) transform val toMarshalcheck : (string, Core.file) transform val toEffectize : (string, Core.file) transform val toCss : (string, Css.report) transform val toMonoize : (string, Mono.file) transform + val toEndpoints : (string, Mono.file) transform val toMono_opt1 : (string, Mono.file) transform val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index f724bf56..9cbe9949 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -39,6 +39,7 @@ type job = { sources : string list, exe : string, sql : string option, + endpoints : string option, debug : bool, profile : bool, timeout : int, @@ -65,6 +66,7 @@ type job = { dbms : string option, sigFile : string option, fileCache : string option, + safeGetDefault : bool, safeGets : string list, onError : (string * string list * string) option, minHeap : int, @@ -274,7 +276,7 @@ val parseUr = { handle LrParser.ParseError => [], print = SourcePrint.p_file} -fun p_job ({prefix, database, exe, sql, sources, debug, profile, +fun p_job ({prefix, database, exe, sql, endpoints, sources, debug, profile, timeout, ffi, link, headers, scripts, clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) = let @@ -303,6 +305,10 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile, NONE => string "No SQL file." | SOME sql => string ("SQL fle: " ^ sql), newline, + case endpoints of + NONE => string "No endpoints file." + | SOME ep => string ("Endpoints fle: " ^ ep), + newline, string "Timeout: ", string (Int.toString timeout), newline, @@ -385,6 +391,7 @@ fun institutionalizeJob (job : job) = Settings.setMetaRules (#filterMeta job); Option.app Settings.setProtocol (#protocol job); Option.app Settings.setDbms (#dbms job); + Settings.setSafeGetDefault (#safeGetDefault job); Settings.setSafeGets (#safeGets job); Settings.setOnError (#onError job); Settings.setMinHeap (#minHeap job); @@ -441,6 +448,7 @@ fun parseUrp' accLibs fname = sources = [fname], exe = fname ^ ".exe", sql = NONE, + endpoints = Settings.getEndpoints (), debug = Settings.getDebug (), profile = false, timeout = 120, @@ -470,6 +478,7 @@ fun parseUrp' accLibs fname = dbms = NONE, sigFile = NONE, fileCache = NONE, + safeGetDefault = false, safeGets = [], onError = NONE, minHeap = 0, @@ -578,6 +587,7 @@ fun parseUrp' accLibs fname = val database = ref (Settings.getDbstring ()) val exe = ref (Settings.getExe ()) val sql = ref (Settings.getSql ()) + val endpoints = ref (Settings.getEndpoints ()) val debug = ref (Settings.getDebug ()) val profile = ref false val timeout = ref NONE @@ -605,6 +615,7 @@ fun parseUrp' accLibs fname = val dbms = ref NONE val sigFile = ref (Settings.getSigFile ()) val fileCache = ref (Settings.getFileCache ()) + val safeGetDefault = ref false val safeGets = ref [] val onError = ref NONE val minHeap = ref 0 @@ -618,6 +629,7 @@ fun parseUrp' accLibs fname = exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, ext = SOME "exe"}), sql = !sql, + endpoints = !endpoints, debug = !debug, profile = !profile, timeout = Option.getOpt (!timeout, 60), @@ -645,6 +657,7 @@ fun parseUrp' accLibs fname = dbms = !dbms, sigFile = !sigFile, fileCache = !fileCache, + safeGetDefault = !safeGetDefault, safeGets = rev (!safeGets), onError = !onError, minHeap = !minHeap, @@ -679,6 +692,7 @@ fun parseUrp' accLibs fname = database = mergeO (fn (old, _) => old) (#database old, #database new), exe = #exe old, sql = #sql old, + endpoints = #endpoints old, debug = #debug old orelse #debug new, profile = #profile old orelse #profile new, timeout = #timeout old, @@ -708,6 +722,7 @@ fun parseUrp' accLibs fname = dbms = mergeO #2 (#dbms old, #dbms new), sigFile = mergeO #2 (#sigFile old, #sigFile new), fileCache = mergeO #2 (#fileCache old, #fileCache new), + safeGetDefault = #safeGetDefault old orelse #safeGetDefault new, safeGets = #safeGets old @ #safeGets new, onError = mergeO #2 (#onError old, #onError new), minHeap = Int.max (#minHeap old, #minHeap new), @@ -730,7 +745,7 @@ fun parseUrp' accLibs fname = | "relation" => Settings.Relation | "cookie" => Settings.Cookie | "style" => Settings.Style - | _ => (ErrorMsg.error "Bad path kind spec"; + | _ => (ErrorMsg.error ("Bad path kind spec \"" ^ s ^ "\""); Settings.Any) fun parsePattern s = @@ -829,6 +844,7 @@ fun parseUrp' accLibs fname = | "include" => headers := relifyA arg :: !headers | "script" => scripts := arg :: !scripts | "clientToServer" => clientToServer := ffiS () :: !clientToServer + | "safeGetDefault" => safeGetDefault := true | "safeGet" => safeGets := arg :: !safeGets | "effectful" => effectful := ffiS () :: !effectful | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful @@ -937,7 +953,7 @@ fun parseUrp' accLibs fname = uri :: fname :: rest => (Settings.setFilePath thisPath; Settings.addFile {Uri = uri, - LoadFromFilename = fname, + LoadFromFilename = pathify fname, MimeType = case rest of [] => NONE | [ty] => SOME ty @@ -948,7 +964,7 @@ fun parseUrp' accLibs fname = | "jsFile" => (Settings.setFilePath thisPath; - Settings.addJsFile arg) + Settings.addJsFile (pathify arg)) | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () @@ -1184,6 +1200,7 @@ val parse = { else (); ErrorMsg.error ("Missing source file: " ^ fname); + anyErrors := true; (Source.DSequence "", ErrorMsg.dummySpan)) val dsFfi = map parseFfi ffi @@ -1266,7 +1283,7 @@ val elaborate = { in Elaborate.elabFile basis (OS.FileSys.modTime basisF) topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1) - ElabEnv.empty file + ElabEnv.empty (fn env => env) file end, print = ElabPrint.p_file ElabEnv.empty } @@ -1383,8 +1400,9 @@ val toUnpoly2 = transform unpoly "unpoly2" o toShake4' val toSpecialize2 = transform specialize "specialize2" o toUnpoly2 val toShake4'' = transform shake "shake4'" o toSpecialize2 val toEspecialize3 = transform especialize "especialize3" o toShake4'' +val toSpecialize3 = transform specialize "specialize3" o toEspecialize3 -val toReduce2 = transform reduce "reduce2" o toEspecialize3 +val toReduce2 = transform reduce "reduce2" o toSpecialize3 val toShake5 = transform shake "shake5" o toReduce2 @@ -1421,7 +1439,14 @@ val mono_opt = { print = MonoPrint.p_file MonoEnv.empty } -val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize +val endpoints = { + func = Endpoints.collect, + print = MonoPrint.p_file MonoEnv.empty +} + +val toEndpoints = transform endpoints "endpoints" o toMonoize + +val toMono_opt1 = transform mono_opt "mono_opt1" o toEndpoints val untangle = { func = Untangle.untangle, @@ -1585,9 +1610,13 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val proto = Settings.currentProtocol () val lib = if Settings.getBootLinking () then - !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ + !Settings.configLib ^ "/liburweb.a " ^ + !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata -licuio" else if Settings.getStaticLinking () then - " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" + " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic + proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ + !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata -licuio" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" @@ -1598,6 +1627,7 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val compile = (Settings.getCCompiler ()) ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " -Wimplicit -Werror -Wno-unused-value" ^ opt ^ " -I " ^ !Settings.configInclude + ^ " " ^ !Settings.configIcuIncludes ^ " " ^ #compile proto ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname @@ -1710,6 +1740,18 @@ fun compile job = TextIO.closeOut outf end; + case #endpoints job of + NONE => () + | SOME endpoints => + let + val report = Endpoints.summarize () + val outf = TextIO.openOut endpoints + val s = TextIOPP.openOut {dst = outf, wid = 80} + in + Print.fprint s (Endpoints.p_report report); + TextIO.closeOut outf + end; + compileC {cname = cname, oname = oname, ename = ename, libs = libs, profile = #profile job, debug = #debug job, linker = #linker job, link = #link job} diff --git a/src/config.sig b/src/config.sig index a3ad7d76..be72a8cc 100644 --- a/src/config.sig +++ b/src/config.sig @@ -20,4 +20,7 @@ signature CONFIG = sig val pthreadCflags : string val pthreadLibs : string + + val icuIncludes : string + val icuLibs : string end diff --git a/src/config.sml.in b/src/config.sml.in index ebcdb7b6..2d12e28d 100644 --- a/src/config.sml.in +++ b/src/config.sml.in @@ -28,6 +28,9 @@ val pgheader = "@PGHEADER@" val msheader = "@MSHEADER@" val sqheader = "@SQHEADER@" +val icuIncludes = "@ICU_INCLUDES@" +val icuLibs = "@ICU_LIBS@" + val versionNumber = "@VERSION@" val versionString = "The Ur/Web compiler, version " ^ versionNumber diff --git a/src/core_util.sig b/src/core_util.sig index 835577a3..8d295f1e 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -161,6 +161,12 @@ structure Decl : sig decl : (Core.decl', 'state, 'abort) Search.mapfolder} -> (Core.decl, 'state, 'abort) Search.mapfolder + val map : {kind : Core.kind' -> Core.kind', + con : Core.con' -> Core.con', + exp : Core.exp' -> Core.exp', + decl : Core.decl' -> Core.decl'} + -> Core.decl -> Core.decl + val fold : {kind : Core.kind' * 'state -> 'state, con : Core.con' * 'state -> 'state, exp : Core.exp' * 'state -> 'state, diff --git a/src/core_util.sml b/src/core_util.sml index 57ef16f7..d1d3d9c4 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -1029,6 +1029,22 @@ fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} = decl = fn () => fd, bind = fn ((), _) => ()} () +fun mapB {kind, con, exp, decl, bind} ctx d = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()), + exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()), + decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()), + bind = bind} ctx d () of + S.Continue (d, ()) => d + | S.Return _ => raise Fail "CoreUtil.Decl.mapB: Impossible" + +fun map {kind, con, exp, decl} d = + mapB {kind = fn () => kind, + con = fn () => con, + exp = fn () => exp, + decl = fn () => decl, + bind = fn _ => ()} () d + fun fold {kind, con, exp, decl} s d = case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)), con = fn c => fn s => S.Continue (c, con (c, s)), diff --git a/src/demo.sml b/src/demo.sml index 1e58e2f8..ef57e65b 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -98,6 +98,10 @@ fun make' {prefix, dirname, guided} = NONE => OS.Path.joinDirFile {dir = dirname, file = "demo.sql"} | SOME s => s), + endpoints = SOME (case Settings.getEndpoints () of + NONE => OS.Path.joinDirFile {dir = dirname, + file = "demo-endpoints.json"} + | SOME e => e), debug = Settings.getDebug (), timeout = Int.max (#timeout combined, #timeout urp), profile = false, @@ -124,6 +128,7 @@ fun make' {prefix, dirname, guided} = dbms = mergeWith #2 (#dbms combined, #dbms urp), sigFile = mergeWith #2 (#sigFile combined, #sigFile urp), fileCache = mergeWith #2 (#fileCache combined, #fileCache urp), + safeGetDefault = #safeGetDefault combined orelse #safeGetDefault urp, safeGets = #safeGets combined @ #safeGets urp, onError = NONE, minHeap = 0, diff --git a/src/elab_env.sig b/src/elab_env.sig index 47b31c08..4f994221 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -100,6 +100,10 @@ signature ELAB_ENV = sig val lookupStrNamed : env -> int -> string * Elab.sgn val lookupStr : env -> string -> (int * Elab.sgn) option + + val dumpCs: env -> (string * Elab.kind) list + val dumpEs: env -> (string * Elab.con) list + val dumpStrs: env -> (string * (int * Elab.sgn)) list val edeclBinds : env -> Elab.edecl -> env val declBinds : env -> Elab.decl -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index 0474bf7c..5fa32cd2 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -493,10 +493,11 @@ fun class_name_in (c, _) = case c of CNamed n => SOME (ClNamed n) | CModProj x => SOME (ClProj x) + | CAbs (_, _, c') => class_head_in c' | CUnif (_, _, _, _, ref (Known c)) => class_name_in c | _ => NONE -fun isClass (env : env) c = +and isClass (env : env) c = let fun find NONE = false | find (SOME c) = Option.isSome (CM.find (#classes env, c)) @@ -504,7 +505,7 @@ fun isClass (env : env) c = find (class_name_in c) end -fun class_head_in c = +and class_head_in c = case #1 c of CApp (f, _) => class_head_in f | CUnif (_, _, _, _, ref (Known c)) => class_head_in c @@ -985,6 +986,16 @@ fun lookupStrNamed (env : env) n = fun lookupStr (env : env) x = SM.find (#renameStr env, x) +fun dumpCs (env: env): (string * kind) list = + List.map (fn (name, value) => case value of + Rel' (_, x) => (name, x) + | Named' (_, x) => (name, x)) + (SM.listItemsi (#renameC env)) +(* TODO try again with #renameE *) +fun dumpEs (env: env): (string * con) list = + #relE env @ IM.listItems (#namedE env) +fun dumpStrs (env: env) = + SM.listItemsi (#renameStr env) fun sgiSeek (sgi, (sgns, strs, cons)) = case sgi of diff --git a/src/elab_err.sig b/src/elab_err.sig index acf137df..fc80fcac 100644 --- a/src/elab_err.sig +++ b/src/elab_err.sig @@ -29,6 +29,7 @@ signature ELAB_ERR = sig datatype kind_error = UnboundKind of ErrorMsg.span * string + | KDisallowedWildcard of ErrorMsg.span val kindError : ElabEnv.env -> kind_error -> unit @@ -47,6 +48,7 @@ signature ELAB_ERR = sig | DuplicateField of ErrorMsg.span * string | ProjBounds of Elab.con * int | ProjMismatch of Elab.con * Elab.kind + | CDisallowedWildcard of ErrorMsg.span val conError : ElabEnv.env -> con_error -> unit diff --git a/src/elab_err.sml b/src/elab_err.sml index 385caca3..834964ae 100644 --- a/src/elab_err.sml +++ b/src/elab_err.sml @@ -40,11 +40,14 @@ val p_kind = P.p_kind datatype kind_error = UnboundKind of ErrorMsg.span * string + | KDisallowedWildcard of ErrorMsg.span fun kindError env err = case err of UnboundKind (loc, s) => - ErrorMsg.errorAt loc ("Unbound kind variable " ^ s) + ErrorMsg.errorAt loc ("Unbound kind variable: " ^ s) + | KDisallowedWildcard loc => + ErrorMsg.errorAt loc "Wildcard not allowed in signature" datatype kunify_error = KOccursCheckFailed of kind * kind @@ -76,15 +79,16 @@ datatype con_error = | DuplicateField of ErrorMsg.span * string | ProjBounds of con * int | ProjMismatch of con * kind + | CDisallowedWildcard of ErrorMsg.span fun conError env err = case err of UnboundCon (loc, s) => - ErrorMsg.errorAt loc ("Unbound constructor variable " ^ s) + ErrorMsg.errorAt loc ("Unbound constructor variable: " ^ s) | UnboundDatatype (loc, s) => - ErrorMsg.errorAt loc ("Unbound datatype " ^ s) + ErrorMsg.errorAt loc ("Unbound datatype: " ^ s) | UnboundStrInCon (loc, s) => - ErrorMsg.errorAt loc ("Unbound structure " ^ s) + ErrorMsg.errorAt loc ("Unbound structure: " ^ s) | WrongKind (c, k1, k2, env', kerr) => (ErrorMsg.errorAt (#2 c) "Wrong kind"; eprefaces' [("Constructor", p_con env c), @@ -92,7 +96,7 @@ fun conError env err = ("Need kind", p_kind env k2)]; kunifyError env' kerr) | DuplicateField (loc, s) => - ErrorMsg.errorAt loc ("Duplicate record field " ^ s) + ErrorMsg.errorAt loc ("Duplicate record field: " ^ s) | ProjBounds (c, n) => (ErrorMsg.errorAt (#2 c) "Out of bounds constructor projection"; eprefaces' [("Constructor", p_con env c), @@ -101,6 +105,8 @@ fun conError env err = (ErrorMsg.errorAt (#2 c) "Projection from non-tuple constructor"; eprefaces' [("Constructor", p_con env c), ("Kind", p_kind env k)]) + | CDisallowedWildcard loc => + ErrorMsg.errorAt loc "Wildcard not allowed in signature" datatype cunify_error = CKind of kind * kind * E.env * kunify_error @@ -195,9 +201,9 @@ val p_pat = P.p_pat fun expError env err = case err of UnboundExp (loc, s) => - ErrorMsg.errorAt loc ("Unbound expression variable " ^ s) + ErrorMsg.errorAt loc ("Unbound expression variable: " ^ s) | UnboundStrInExp (loc, s) => - ErrorMsg.errorAt loc ("Unbound structure " ^ s) + ErrorMsg.errorAt loc ("Unbound structure: " ^ s) | Unify (e, c1, c2, env', uerr) => (ErrorMsg.errorAt (#2 e) "Unification failure"; eprefaces' [("Expression", p_exp env e), @@ -216,7 +222,7 @@ fun expError env err = eprefaces' [("Have", p_con env c1), ("Need", p_con env c2)]) | DuplicatePatternVariable (loc, s) => - ErrorMsg.errorAt loc ("Duplicate pattern variable " ^ s) + ErrorMsg.errorAt loc ("Duplicate pattern variable: " ^ s) | PatUnify (p, c1, c2, env', uerr) => (ErrorMsg.errorAt (#2 p) "Unification failure for pattern"; eprefaces' [("Pattern", p_pat env p), @@ -350,7 +356,7 @@ val p_sgn = P.p_sgn fun sgnError env err = case err of UnboundSgn (loc, s) => - ErrorMsg.errorAt loc ("Unbound signature variable " ^ s) + ErrorMsg.errorAt loc ("Unbound signature variable: " ^ s) | UnmatchedSgi (loc, sgi) => (ErrorMsg.errorAt loc "Unmatched signature item"; eprefaces' [("Item", p_sgn_item env sgi)]) diff --git a/src/elab_print.sig b/src/elab_print.sig index 1eb832b3..84715b9d 100644 --- a/src/elab_print.sig +++ b/src/elab_print.sig @@ -38,6 +38,7 @@ signature ELAB_PRINT = sig val p_sgn : ElabEnv.env -> Elab.sgn Print.printer val p_str : ElabEnv.env -> Elab.str Print.printer val p_file : ElabEnv.env -> Elab.file Print.printer + val debug : bool ref end diff --git a/src/elab_print.sml b/src/elab_print.sml index 8a6a651a..637164f4 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -546,7 +546,10 @@ fun p_datatype env (x, n, xs, cons) = val env = E.pushCNamedAs env x n k NONE val env = foldl (fn (x, env) => E.pushCRel env x k) env xs in - box [string x, + box [(if !debug then + string (x ^ "_" ^ Int.toString n) + else + string x), p_list_sep (box []) (fn x => box [space, string x]) xs, space, string "=", diff --git a/src/elab_util.sml b/src/elab_util.sml index 0cdb9cc1..aa5bc6a4 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -541,11 +541,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = and mfed ctx (dAll as (d, loc)) = case d of EDVal (p, t, e) => - S.bind2 (mfc ctx t, - fn t' => - S.map2 (mfe ctx e, - fn e' => - (EDVal (p, t', e'), loc))) + S.bind2 (mfp ctx p, + fn p' => + S.bind2 (mfc ctx t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (EDVal (p', t', e'), loc)))) | EDValRec vis => let val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis diff --git a/src/elab_util_pos.sig b/src/elab_util_pos.sig new file mode 100644 index 00000000..95d8b591 --- /dev/null +++ b/src/elab_util_pos.sig @@ -0,0 +1,66 @@ +(* Copyright (c) 2008-2010, 2012, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * 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 + * 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 + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* This is identical to ELAB_UTIL, but keeps source spans around *) +(* Maybe these modules can be unified? *) + +signature ELAB_UTIL_POS = sig + + val mliftConInCon : (int -> Elab.con -> Elab.con) ref + + structure Decl : sig + datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + + val fold : {kind : Elab.kind * 'state -> 'state, + con : Elab.con * 'state -> 'state, + exp : Elab.exp * 'state -> 'state, + sgn_item : Elab.sgn_item * 'state -> 'state, + sgn : Elab.sgn * 'state -> 'state, + str : Elab.str * 'state -> 'state, + decl : Elab.decl * 'state -> 'state} + -> 'state -> Elab.decl -> 'state + + val foldB : {kind : 'context * Elab.kind * 'state -> 'state, + con : 'context * Elab.con * 'state -> 'state, + exp : 'context * Elab.exp * 'state -> 'state, + sgn_item : 'context * Elab.sgn_item * 'state -> 'state, + sgn : 'context * Elab.sgn * 'state -> 'state, + str : 'context * Elab.str * 'state -> 'state, + decl : 'context * Elab.decl * 'state -> 'state, + bind: 'context * binder -> 'context + } + -> 'context -> 'state -> Elab.decl -> 'state + end + +end diff --git a/src/elab_util_pos.sml b/src/elab_util_pos.sml new file mode 100644 index 00000000..d8d1bfdd --- /dev/null +++ b/src/elab_util_pos.sml @@ -0,0 +1,910 @@ +(* Copyright (c) 2008-2010, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * 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 + * 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 + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure ElabUtilPos :> ELAB_UTIL_POS = struct + +open Elab + +structure S = Search + +structure Kind = struct + +fun mapfoldB {kind, bind} = + let + fun mfk ctx k acc = + S.bindPWithPos (mfk' ctx k acc, kind ctx) + + and mfk' ctx (kAll as (k, loc)) = + case k of + KType => S.return2 kAll + + | KArrow (k1, k2) => + S.bind2 (mfk ctx k1, + fn k1' => + S.map2 (mfk ctx k2, + fn k2' => + (KArrow (k1', k2'), loc))) + + | KName => S.return2 kAll + + | KRecord k => + S.map2 (mfk ctx k, + fn k' => + (KRecord k', loc)) + + | KUnit => S.return2 kAll + + | KTuple ks => + S.map2 (ListUtil.mapfold (mfk ctx) ks, + fn ks' => + (KTuple ks', loc)) + + | KError => S.return2 kAll + + | KUnif (_, _, ref (KKnown k)) => mfk' ctx k + | KUnif _ => S.return2 kAll + + | KTupleUnif (_, _, ref (KKnown k)) => mfk' ctx k + | KTupleUnif (loc, nks, r) => + S.map2 (ListUtil.mapfold (fn (n, k) => + S.map2 (mfk ctx k, + fn k' => + (n, k'))) nks, + fn nks' => + (KTupleUnif (loc, nks', r), loc)) + + + | KRel _ => S.return2 kAll + | KFun (x, k) => + S.map2 (mfk (bind (ctx, x)) k, + fn k' => + (KFun (x, k'), loc)) + in + mfk + end + +end + +val mliftConInCon = ref (fn n : int => fn c : con => (raise Fail "You didn't set ElabUtil.mliftConInCon!") : con) + +structure Con = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + +fun mapfoldB {kind = fk, con = fc, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, s) => bind (ctx, RelK s)} + + fun mfc ctx c acc = + S.bindPWithPos (mfc' ctx c acc, fc ctx) + + and mfc' ctx (cAll as (c, loc)) = + case c of + TFun (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (TFun (c1', c2'), loc))) + | TCFun (e, x, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc (bind (ctx, RelC (x, k))) c, + fn c' => + (TCFun (e, x, k', c'), loc))) + | TDisjoint (c1, c2, c3) => + S.bind2 (mfc ctx c1, + fn c1' => + S.bind2 (mfc ctx c2, + fn c2' => + S.map2 (mfc ctx c3, + fn c3' => + (TDisjoint (c1', c2', c3'), loc)))) + | TRecord c => + S.map2 (mfc ctx c, + fn c' => + (TRecord c', loc)) + + | CRel _ => S.return2 cAll + | CNamed _ => S.return2 cAll + | CModProj _ => S.return2 cAll + | CApp (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (CApp (c1', c2'), loc))) + | CAbs (x, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc (bind (ctx, RelC (x, k))) c, + fn c' => + (CAbs (x, k', c'), loc))) + + | CName _ => S.return2 cAll + + | CRecord (k, xcs) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (ListUtil.mapfold (fn (x, c) => + S.bind2 (mfc ctx x, + fn x' => + S.map2 (mfc ctx c, + fn c' => + (x', c')))) + xcs, + fn xcs' => + (CRecord (k', xcs'), loc))) + | CConcat (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (CConcat (c1', c2'), loc))) + | CMap (k1, k2) => + S.bind2 (mfk ctx k1, + fn k1' => + S.map2 (mfk ctx k2, + fn k2' => + (CMap (k1', k2'), loc))) + + | CUnit => S.return2 cAll + + | CTuple cs => + S.map2 (ListUtil.mapfold (mfc ctx) cs, + fn cs' => + (CTuple cs', loc)) + + | CProj (c, n) => + S.map2 (mfc ctx c, + fn c' => + (CProj (c', n), loc)) + + | CError => S.return2 cAll + | CUnif (nl, _, _, _, ref (Known c)) => mfc' ctx (!mliftConInCon nl c) + | CUnif _ => S.return2 cAll + + | CKAbs (x, c) => + S.map2 (mfc (bind (ctx, RelK x)) c, + fn c' => + (CKAbs (x, c'), loc)) + | CKApp (c, k) => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfk ctx k, + fn k' => + (CKApp (c', k'), loc))) + | TKFun (x, c) => + S.map2 (mfc (bind (ctx, RelK x)) c, + fn c' => + (TKFun (x, c'), loc)) + in + mfc + end + +end + +structure Exp = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + +fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val mfc = Con.mapfoldB {kind = fk, con = fc, bind = bind'} + + fun doVars ((p, _), ctx) = + case p of + PVar xt => bind (ctx, RelE xt) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => doVars (p, ctx) + | PRecord xpcs => + foldl (fn ((_, p, _), ctx) => doVars (p, ctx)) + ctx xpcs + + fun mfe ctx e acc = + S.bindPWithPos (mfe' ctx e acc, fe ctx) + + and mfe' ctx (eAll as (e, loc)) = + case e of + EPrim _ => S.return2 eAll + | ERel _ => S.return2 eAll + | ENamed _ => S.return2 eAll + | EModProj _ => S.return2 eAll + | EApp (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (EApp (e1', e2'), loc))) + | EAbs (x, dom, ran, e) => + S.bind2 (mfc ctx dom, + fn dom' => + S.bind2 (mfc ctx ran, + fn ran' => + S.map2 (mfe (bind (ctx, RelE (x, dom'))) e, + fn e' => + (EAbs (x, dom', ran', e'), loc)))) + + | ECApp (e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (ECApp (e', c'), loc))) + | ECAbs (expl, x, k, e) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfe (bind (ctx, RelC (x, k))) e, + fn e' => + (ECAbs (expl, x, k', e'), loc))) + + | ERecord xes => + S.map2 (ListUtil.mapfold (fn (x, e, t) => + S.bind2 (mfc ctx x, + fn x' => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx t, + fn t' => + (x', e', t'))))) + xes, + fn xes' => + (ERecord xes', loc)) + | EField (e, c, {field, rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfc ctx field, + fn field' => + S.map2 (mfc ctx rest, + fn rest' => + (EField (e', c', {field = field', rest = rest'}), loc))))) + | EConcat (e1, c1, e2, c2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.bind2 (mfc ctx c1, + fn c1' => + S.bind2 (mfe ctx e2, + fn e2' => + S.map2 (mfc ctx c2, + fn c2' => + (EConcat (e1', c1', e2', c2'), + loc))))) + | ECut (e, c, {field, rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfc ctx field, + fn field' => + S.map2 (mfc ctx rest, + fn rest' => + (ECut (e', c', {field = field', rest = rest'}), loc))))) + + | ECutMulti (e, c, {rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfc ctx rest, + fn rest' => + (ECutMulti (e', c', {rest = rest'}), loc)))) + + | ECase (e, pes, {disc, result}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (ListUtil.mapfold (fn (p, e) => + let + fun pb ((p, _), ctx) = + case p of + PVar (x, t) => bind (ctx, RelE (x, t)) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => pb (p, ctx) + | PRecord xps => foldl (fn ((_, p, _), ctx) => + pb (p, ctx)) ctx xps + in + S.bind2 (mfp ctx p, + fn p' => + S.map2 (mfe (pb (p', ctx)) e, + fn e' => (p', e'))) + end) pes, + fn pes' => + S.bind2 (mfc ctx disc, + fn disc' => + S.map2 (mfc ctx result, + fn result' => + (ECase (e', pes', {disc = disc', result = result'}), loc))))) + + | EError => S.return2 eAll + | EUnif (ref (SOME e)) => mfe ctx e + | EUnif _ => S.return2 eAll + + | ELet (des, e, t) => + let + val (des, ctx') = foldl (fn (ed, (des, ctx)) => + let + val ctx' = + case #1 ed of + EDVal (p, _, _) => doVars (p, ctx) + | EDValRec vis => + foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) + ctx vis + in + (S.bind2 (des, + fn des' => + S.map2 (mfed ctx ed, + fn ed' => ed' :: des')), + ctx') + end) + (S.return2 [], ctx) des + in + S.bind2 (des, + fn des' => + S.bind2 (mfe ctx' e, + fn e' => + S.map2 (mfc ctx t, + fn t' => + (ELet (rev des', e', t'), loc)))) + end + + | EKAbs (x, e) => + S.map2 (mfe (bind (ctx, RelK x)) e, + fn e' => + (EKAbs (x, e'), loc)) + | EKApp (e, k) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfk ctx k, + fn k' => + (EKApp (e', k'), loc))) + + and mfp ctx (pAll as (p, loc)) = + case p of + PVar (x, t) => + S.map2 (mfc ctx t, + fn t' => + (PVar (x, t'), loc)) + | PPrim _ => S.return2 pAll + | PCon (dk, pc, args, po) => + S.bind2 (ListUtil.mapfold (mfc ctx) args, + fn args' => + S.map2 ((case po of + NONE => S.return2 NONE + | SOME p => S.map2 (mfp ctx p, SOME)), + fn po' => + (PCon (dk, pc, args', po'), loc))) + | PRecord xps => + S.map2 (ListUtil.mapfold (fn (x, p, c) => + S.bind2 (mfp ctx p, + fn p' => + S.map2 (mfc ctx c, + fn c' => + (x, p', c')))) xps, + fn xps' => + (PRecord xps', loc)) + + and mfed ctx (dAll as (d, loc)) = + case d of + EDVal (p, t, e) => + S.bind2 (mfc ctx t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (EDVal (p, t', e'), loc))) + | EDValRec vis => + let + val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis + in + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (EDValRec vis', loc)) + end + + and mfvi ctx (x, c, e) = + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfe ctx e, + fn e' => + (x, c', e'))) + in + mfe + end + +end + +structure Sgn = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + +fun mapfoldB {kind, con, sgn_item, sgn, bind} = + let + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val con = Con.mapfoldB {kind = kind, con = con, bind = bind'} + + val kind = Kind.mapfoldB {kind = kind, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun sgi ctx si acc = + S.bindPWithPos (sgi' ctx si acc, sgn_item ctx) + + and sgi' ctx (siAll as (si, loc)) = + case si of + SgiConAbs (x, n, k) => + S.map2 (kind ctx k, + fn k' => + (SgiConAbs (x, n, k'), loc)) + | SgiCon (x, n, k, c) => + S.bind2 (kind ctx k, + fn k' => + S.map2 (con ctx c, + fn c' => + (SgiCon (x, n, k', c'), loc))) + | SgiDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (con ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => (x, n, xs, xncs'))) dts, + fn dts' => + (SgiDatatype dts', loc)) + | SgiDatatypeImp (x, n, m1, ms, s, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (con ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (SgiDatatypeImp (x, n, m1, ms, s, xs, xncs'), loc)) + | SgiVal (x, n, c) => + S.map2 (con ctx c, + fn c' => + (SgiVal (x, n, c'), loc)) + | SgiStr (im, x, n, s) => + S.map2 (sg ctx s, + fn s' => + (SgiStr (im, x, n, s'), loc)) + | SgiSgn (x, n, s) => + S.map2 (sg ctx s, + fn s' => + (SgiSgn (x, n, s'), loc)) + | SgiConstraint (c1, c2) => + S.bind2 (con ctx c1, + fn c1' => + S.map2 (con ctx c2, + fn c2' => + (SgiConstraint (c1', c2'), loc))) + | SgiClassAbs (x, n, k) => + S.map2 (kind ctx k, + fn k' => + (SgiClassAbs (x, n, k'), loc)) + | SgiClass (x, n, k, c) => + S.bind2 (kind ctx k, + fn k' => + S.map2 (con ctx c, + fn c' => + (SgiClass (x, n, k', c'), loc))) + + and sg ctx s acc = + S.bindPWithPos (sg' ctx s acc, sgn ctx) + + and sg' ctx (sAll as (s, loc)) = + case s of + SgnConst sgis => + S.map2 (ListUtil.mapfoldB (fn (ctx, si) => + (case #1 si of + SgiConAbs (x, n, k) => + bind (ctx, NamedC (x, n, k, NONE)) + | SgiCon (x, n, k, c) => + bind (ctx, NamedC (x, n, k, SOME c)) + | SgiDatatype dts => + foldl (fn ((x, n, ks, _), ctx) => + let + val k' = (KType, loc) + val k = foldl (fn (_, k) => (KArrow (k', k), loc)) + k' ks + in + bind (ctx, NamedC (x, n, k, NONE)) + end) ctx dts + | SgiDatatypeImp (x, n, m1, ms, s, _, _) => + bind (ctx, NamedC (x, n, (KType, loc), + SOME (CModProj (m1, ms, s), loc))) + | SgiVal _ => ctx + | SgiStr (_, x, n, sgn) => + bind (ctx, Str (x, n, sgn)) + | SgiSgn (x, n, sgn) => + bind (ctx, Sgn (x, n, sgn)) + | SgiConstraint _ => ctx + | SgiClassAbs (x, n, k) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc), NONE)) + | SgiClass (x, n, k, c) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc), SOME c)), + sgi ctx si)) ctx sgis, + fn sgis' => + (SgnConst sgis', loc)) + + | SgnVar _ => S.return2 sAll + | SgnFun (m, n, s1, s2) => + S.bind2 (sg ctx s1, + fn s1' => + S.map2 (sg (bind (ctx, Str (m, n, s1'))) s2, + fn s2' => + (SgnFun (m, n, s1', s2'), loc))) + | SgnProj _ => S.return2 sAll + | SgnWhere (sgn, ms, x, c) => + S.bind2 (sg ctx sgn, + fn sgn' => + S.map2 (con ctx c, + fn c' => + (SgnWhere (sgn', ms, x, c'), loc))) + | SgnError => S.return2 sAll + in + sg + end + +end + +structure Decl = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + +fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = fst, decl = fd, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val mfc = Con.mapfoldB {kind = fk, con = fc, bind = bind'} + + fun bind' (ctx, b) = + let + val b' = case b of + Exp.RelK x => RelK x + | Exp.RelC x => RelC x + | Exp.NamedC x => NamedC x + | Exp.RelE x => RelE x + | Exp.NamedE x => NamedE x + in + bind (ctx, b') + end + val mfe = Exp.mapfoldB {kind = fk, con = fc, exp = fe, bind = bind'} + + fun bind' (ctx, b) = + let + val b' = case b of + Sgn.RelK x => RelK x + | Sgn.RelC x => RelC x + | Sgn.NamedC x => NamedC x + | Sgn.Sgn x => Sgn x + | Sgn.Str x => Str x + in + bind (ctx, b') + end + val mfsg = Sgn.mapfoldB {kind = fk, con = fc, sgn_item = fsgi, sgn = fsg, bind = bind'} + + fun mfst ctx str acc = + S.bindPWithPos (mfst' ctx str acc, fst ctx) + + and mfst' ctx (strAll as (str, loc)) = + case str of + StrConst ds => + S.map2 (ListUtil.mapfoldB (fn (ctx, d) => + (case #1 d of + DCon (x, n, k, c) => + bind (ctx, NamedC (x, n, k, SOME c)) + | DDatatype dts => + let + fun doOne ((x, n, xs, xncs), ctx) = + let + val ctx = bind (ctx, NamedC (x, n, (KType, loc), NONE)) + in + foldl (fn ((x, _, co), ctx) => + let + val t = + case co of + NONE => CNamed n + | SOME t => TFun (t, (CNamed n, loc)) + + val k = (KType, loc) + val t = (t, loc) + val t = foldr (fn (x, t) => + (TCFun (Explicit, + x, + k, + t), loc)) + t xs + in + bind (ctx, NamedE (x, t)) + end) + ctx xncs + end + in + foldl doOne ctx dts + end + | DDatatypeImp (x, n, m, ms, x', _, _) => + bind (ctx, NamedC (x, n, (KType, loc), + SOME (CModProj (m, ms, x'), loc))) + | DVal (x, _, c, _) => + bind (ctx, NamedE (x, c)) + | DValRec vis => + foldl (fn ((x, _, c, _), ctx) => bind (ctx, NamedE (x, c))) ctx vis + | DSgn (x, n, sgn) => + bind (ctx, Sgn (x, n, sgn)) + | DStr (x, n, sgn, _) => + bind (ctx, Str (x, n, sgn)) + | DFfiStr (x, n, sgn) => + bind (ctx, Str (x, n, sgn)) + | DConstraint _ => ctx + | DExport _ => ctx + | DTable (tn, x, n, c, _, pc, _, cc) => + let + val ct = (CModProj (n, [], "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) + in + bind (ctx, NamedE (x, ct)) + end + | DSequence (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (n, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, ct)) + end + | DDatabase _ => ctx + | DCookie (tn, x, n, c) => + bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), + c), loc))) + | DStyle (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) + | DTask _ => ctx + | DPolicy _ => 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 + | StrProj (str, x) => + S.map2 (mfst ctx str, + fn str' => + (StrProj (str', x), loc)) + | StrFun (x, n, sgn1, sgn2, str) => + S.bind2 (mfsg ctx sgn1, + fn sgn1' => + S.bind2 (mfsg ctx sgn2, + fn sgn2' => + S.map2 (mfst ctx str, + fn str' => + (StrFun (x, n, sgn1', sgn2', str'), loc)))) + | StrApp (str1, str2) => + S.bind2 (mfst ctx str1, + fn str1' => + S.map2 (mfst ctx str2, + fn str2' => + (StrApp (str1', str2'), loc))) + | StrError => S.return2 strAll + + and mfd ctx d acc = + S.bindPWithPos (mfd' ctx d acc, fd ctx) + + and mfd' ctx (dAll as (d, loc)) = + case d of + DCon (x, n, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc ctx c, + fn c' => + (DCon (x, n, k', c'), loc))) + | DDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mfc ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (x, n, xs, xncs'))) dts, + fn dts' => + (DDatatype dts', loc)) + | DDatatypeImp (x, n, m1, ms, s, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mfc ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (DDatatypeImp (x, n, m1, ms, s, xs, xncs'), loc)) + | DVal vi => + S.map2 (mfvi ctx vi, + fn vi' => + (DVal vi', loc)) + | DValRec vis => + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (DValRec vis', loc)) + | DSgn (x, n, sgn) => + S.map2 (mfsg ctx sgn, + fn sgn' => + (DSgn (x, n, sgn'), loc)) + | DStr (x, n, sgn, str) => + S.bind2 (mfsg ctx sgn, + fn sgn' => + S.map2 (mfst ctx str, + fn str' => + (DStr (x, n, sgn', str'), loc))) + | DFfiStr (x, n, sgn) => + S.map2 (mfsg ctx sgn, + fn sgn' => + (DFfiStr (x, n, sgn'), loc)) + | DConstraint (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (DConstraint (c1', c2'), loc))) + | DExport (en, sgn, str) => + S.bind2 (mfsg ctx sgn, + fn sgn' => + S.map2 (mfst ctx str, + fn str' => + (DExport (en, sgn', str'), loc))) + + | DTable (tn, x, n, c, pe, pc, ce, cc) => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfe ctx pe, + fn pe' => + S.bind2 (mfc ctx pc, + fn pc' => + S.bind2 (mfe ctx ce, + fn ce' => + S.map2 (mfc ctx cc, + fn cc' => + (DTable (tn, x, n, c', pe', pc', ce', cc'), loc)))))) + | DSequence _ => S.return2 dAll + | DView (tn, x, n, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (tn, x, n, e', c'), loc))) + + | DDatabase _ => S.return2 dAll + + | DCookie (tn, x, n, c) => + S.map2 (mfc ctx c, + fn c' => + (DCookie (tn, x, n, c'), loc)) + | DStyle _ => S.return2 dAll + | DTask (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (DTask (e1', e2'), loc))) + | DPolicy e1 => + S.map2 (mfe ctx e1, + 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, + fn c' => + S.map2 (mfe ctx e, + fn e' => + (x, n, c', e'))) + in + mfd + end + + fun fold {kind, con, exp, sgn_item, sgn, str, decl} (st : 'a) d : 'a = + case mapfoldB {kind = fn () => fn k => fn st => S.Continue (#1 k, kind (k, st)), + con = fn () => fn c => fn st => S.Continue (#1 c, con (c, st)), + exp = fn () => fn e => fn st => S.Continue (#1 e, exp (e, st)), + sgn_item = fn () => fn sgi => fn st => S.Continue (#1 sgi, sgn_item (sgi, st)), + sgn = fn () => fn s => fn st => S.Continue (#1 s, sgn (s, st)), + str = fn () => fn str' => fn st => S.Continue (#1 str', str (str', st)), + decl = fn () => fn d => fn st => S.Continue (#1 d, decl (d, st)), + bind = fn ((), _) => () + } () d st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Decl.fold: Impossible" + + fun foldB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx (st : 'a) d : 'a = + case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (#1 k, kind (ctx, k, st)), + con = fn ctx => fn c => fn st => S.Continue (#1 c, con (ctx, c, st)), + exp = fn ctx => fn e => fn st => S.Continue (#1 e, exp (ctx, e, st)), + sgn_item = fn ctx => fn sgi => fn st => S.Continue (#1 sgi, sgn_item (ctx, sgi, st)), + sgn = fn ctx => fn s => fn st => S.Continue (#1 s, sgn (ctx, s, st)), + str = fn ctx => fn str' => fn st => S.Continue (#1 str', str (ctx, str', st)), + decl = fn ctx => fn d => fn st => S.Continue (#1 d, decl (ctx, d, st)), + bind = bind + } ctx d st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Decl.foldB: Impossible" + end +end diff --git a/src/elaborate.sig b/src/elaborate.sig index d60cff42..d6747241 100644 --- a/src/elaborate.sig +++ b/src/elaborate.sig @@ -29,7 +29,10 @@ signature ELABORATE = sig val elabFile : Source.sgn_item list -> Time.time -> Source.decl list -> Source.sgn_item list -> Time.time - -> ElabEnv.env -> Source.file -> Elab.file + -> ElabEnv.env + -> (ElabEnv.env -> ElabEnv.env) (* Adapt env after stdlib but before elaborate *) + -> Source.file + -> Elab.file val resolveClass : ElabEnv.env -> Elab.con -> Elab.exp option @@ -47,4 +50,24 @@ signature ELABORATE = sig val incremental : bool ref val verbose : bool ref + val dopen: ElabEnv.env + -> { str: int + , strs: string list + , sgn: Elab.sgn } + -> (Elab.decl list * ElabEnv.env) + + val elabSgn: (ElabEnv.env * Disjoint.env) + -> Source.sgn + -> (Elab.sgn * Disjoint.goal list) + + datatype constraint = + Disjoint of Disjoint.goal + | TypeClass of ElabEnv.env * Elab.con * Elab.exp option ref * ErrorMsg.span + + val elabStr: (ElabEnv.env * Disjoint.env) + -> Source.str + -> (Elab.str * Elab.sgn * constraint list) + + val subSgn: ElabEnv.env -> ErrorMsg.span -> Elab.sgn -> Elab.sgn -> unit + end diff --git a/src/elaborate.sml b/src/elaborate.sml index 51d00bd8..e975cabe 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -260,6 +260,21 @@ end + (* Wildcards are disallowed inside signatures. + * We use a flag to indicate when we are in a signature, + * with a helper function for entering this mode and properly backing out afterward. *) + val inSignature = ref false + fun enterSignature' b f = + let + val inS = !inSignature + in + inSignature := b; + (f () handle ex => (inSignature := inS; raise ex)) + before inSignature := inS + end + fun enterSignature f = enterSignature' true f + fun exitSignature f = enterSignature' false f + fun elabKind env (k, loc) = case k of L.KType => (L'.KType, loc) @@ -268,7 +283,7 @@ | L.KRecord k => (L'.KRecord (elabKind env k), loc) | L.KUnit => (L'.KUnit, loc) | L.KTuple ks => (L'.KTuple (map (elabKind env) ks), loc) - | L.KWild => kunif env loc + | L.KWild => if !inSignature then (kindError env (KDisallowedWildcard loc); kerror) else kunif env loc | L.KVar s => (case E.lookupK env s of NONE => @@ -531,11 +546,15 @@ end | L.CWild k => - let - val k' = elabKind env k - in - (cunif env (loc, k'), k', []) - end + if !inSignature then + (conError env (CDisallowedWildcard loc); + (cerror, kerror, [])) + else + let + val k' = elabKind env k + in + (cunif env (loc, k'), k', []) + end fun kunifsRemain k = case k of @@ -2560,7 +2579,10 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = let val k' = case ko of NONE => kunif env loc - | SOME k => elabKind env k + | SOME k => exitSignature (fn () => elabKind env k) + (* Waive wildcard restriction within translation + * of kind annotation. The kind of [c] will allow + * us to resolve it fully. *) val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushCNamed env x k' (SOME c') @@ -2712,7 +2734,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val ct = (L'.CApp (ct, c'), loc) val ct = (L'.CApp (ct, (L'.CConcat (pkey, uniques), loc)), loc) - val (pe', pet, gs'') = elabExp (env', denv) pe + val (pe', pet, gs'') = exitSignature (fn () => elabExp (env', denv) pe) val gs'' = List.mapPartial (fn Disjoint x => SOME x | _ => NONE) gs'' @@ -2720,7 +2742,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val pst = (L'.CApp (pst, c'), loc) val pst = (L'.CApp (pst, pkey), loc) - val (ce', cet, gs''') = elabExp (env', denv) ce + val (ce', cet, gs''') = exitSignature (fn () => elabExp (env', denv) ce) val gs''' = List.mapPartial (fn Disjoint x => SOME x | _ => NONE) gs''' @@ -2800,7 +2822,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiClass (x, n, k, c'), loc)], (env, denv, [])) end) -and elabSgn (env, denv) (sgn, loc) = +and elabSgn (env, denv) (sgn, loc): (L'.sgn * D.goal list) = case sgn of L.SgnConst sgis => let @@ -3284,12 +3306,33 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = SOME env end - val env = E.pushCNamedAs env x1 n1 k' NONE - val env = if n1 = n2 then - env - else - (cparts (n2, n1); - E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc))) + fun dt_pusher (dts1, dts2, env) = + case (dts1, dts2) of + ((x1, n1, xs1, _) :: dts1', (x2, n2, xs2, _) :: dts2') => + let + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs1 + + val env = E.pushCNamedAs env x1 n1 k' NONE + val env = if n1 = n2 then + env + else + (cparts (n2, n1); + E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc))) + in + dt_pusher (dts1', dts2', env) + end + | _ => env + val env = case #1 sgi1All of + L'.SgiDatatype dts1 => dt_pusher (dts1, dts2, env) + | _ => foldl (fn ((x2, n2, xs2, _), env) => + let + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs2 + in + E.pushCNamedAs env x2 n2 k' NONE + end) env dts2 + val env = foldl (fn (x, env) => E.pushCRel env x k) env xs1 fun xncBad ((x1, _, t1), (x2, _, t2)) = String.compare (x1, x2) <> EQUAL @@ -4131,7 +4174,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = | L.DSgn (x, sgn) => let - val (sgn', gs') = elabSgn (env, denv) sgn + val (sgn', gs') = enterSignature (fn () => elabSgn (env, denv) sgn) val (env', n) = E.pushSgnNamed env x sgn' in ([(L'.DSgn (x, n, sgn'), loc)], (env', denv, enD gs' @ gs)) @@ -4150,13 +4193,14 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = | NONE => let val () = if !verbose then TextIO.print ("CHECK: " ^ x ^ "\n") else () + val () = ErrorMsg.startElabStructure x val () = if x = "Basis" then raise Fail "Not allowed to redefine structure 'Basis'" else () - val formal = Option.map (elabSgn (env, denv)) sgno + val formal = enterSignature (fn () => Option.map (elabSgn (env, denv)) sgno) val (str', sgn', gs') = case formal of @@ -4191,7 +4235,10 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = L'.StrFun _ => () | _ => strError env (FunctorRebind loc)) | _ => (); - Option.map (fn tm => ModDb.insert (dNew, tm)) tmo; + Option.app (fn tm => ModDb.insert (dNew, + tm, + ErrorMsg.stopElabStructureAndGetErrored x + )) tmo; ([dNew], (env', denv', gs' @ gs)) end) @@ -4206,7 +4253,9 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = end | NONE => let - val (sgn', gs') = elabSgn (env, denv) sgn + val () = ErrorMsg.startElabStructure x + + val (sgn', gs') = enterSignature (fn () => elabSgn (env, denv) sgn) val (env', n) = E.pushStrNamed env x sgn' @@ -4224,7 +4273,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = epreface ("item", p_sgn_item env sgi))) | _ => raise Fail "FFI signature isn't SgnConst"; - Option.map (fn tm => ModDb.insert (dNew, tm)) tmo; + Option.map (fn tm => ModDb.insert (dNew, tm, ErrorMsg.stopElabStructureAndGetErrored x)) tmo; ([dNew], (env', denv, enD gs' @ gs)) end) @@ -4717,13 +4766,16 @@ and elabStr (env, denv) (str, loc) = fun resolveClass env = E.resolveClass (hnormCon env) (consEq env dummy) env -fun elabFile basis basis_tm topStr topSgn top_tm env file = +fun elabFile basis basis_tm topStr topSgn top_tm env changeEnv file = let val () = ModDb.snapshot () + val () = ErrorMsg.resetStructureTracker () + val () = mayDelay := true val () = delayedUnifs := [] val () = delayedExhaustives := [] + val () = inSignature := false val d = (L.DFfiStr ("Basis", (L.SgnConst basis, ErrorMsg.dummySpan), SOME basis_tm), ErrorMsg.dummySpan) val (basis_n, env', sgn) = @@ -4741,7 +4793,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (env', basis_n) = E.pushStrNamed env "Basis" sgn in - ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm); + ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm, false); (* TODO: also check for errors? *) (basis_n, env', sgn) end | SOME (d' as (L'.DFfiStr (_, basis_n, sgn), _)) => @@ -4800,7 +4852,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (env', top_n) = E.pushStrNamed env' "Top" topSgn in - ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm); + ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm, false); (* TODO: also check for errors? *) (top_n, env', topSgn, topStr) end | SOME (d' as (L'.DStr (_, top_n, topSgn, topStr), _)) => @@ -4811,6 +4863,8 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (ds', env') = dopen env' {str = top_n, strs = [], sgn = topSgn} + val env' = changeEnv env' + fun elabDecl' x = (resetKunif (); resetCunif (); @@ -5083,11 +5137,6 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = else (); - if ErrorMsg.anyErrors () then - ModDb.revert () - else - (); - (*Print.preface("File", ElabPrint.p_file env file);*) (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) diff --git a/src/elisp/urweb-flycheck.el b/src/elisp/urweb-flycheck.el new file mode 100644 index 00000000..31433fbc --- /dev/null +++ b/src/elisp/urweb-flycheck.el @@ -0,0 +1,100 @@ +;;; urweb-flycheck.el --- Flycheck: Ur/Web support -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Artyom Shalkhakov <artyom.shalkhakov@gmail.com> + +;; Author: +;; Artyom Shalkhakov <artyom.shalkhakov@gmail.com> +;; David Christiansen <david@davidchristiansen.dk> +;; +;; Keywords: tools, languages, convenience +;; Version: 0.2 +;; Package-Requires: ((emacs "24.1") (flycheck "0.22")) + +;; This file is not part of GNU Emacs, but it is distributed under the +;; same conditions. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; This Flycheck extension provides an 'urweb' syntax checker. +;; +;; # Setup +;; +;; Put the following into your 'init' file: +;; +;; (with-eval-after-load 'flycheck (urweb-flycheck-setup)) +;; +;; Ensure that the Ur/Web compiler is in your PATH +;; + +;;; Code: + +(require 'flycheck) + +(defun urweb-get-flycheck-project-file () + "Guess the location of the nearest urp file." + (let ((bn (buffer-file-name))) + (if bn + (let + ((x (file-name-sans-extension bn)) + (y (file-name-directory bn))) + (cond + ;; file with .urp extension exists? take it + ((file-exists-p (concat x ".urp")) x) + ;; lib.urp exists in this directory? take it + ((file-exists-p (concat y "/lib.urp")) (concat y "/lib")) + ;; fall back to the first .urp file in this directory + ;; or if that fails, use the current file name + (t (or (car (directory-files y nil "\\.urp$")) x))))))) + +(flycheck-define-checker urweb + "Ur/Web checker" + :command ("urweb" "-tc" + (eval (urweb-get-flycheck-project-file))) + ;; filename:1:0: (to 1:0) syntax error found at SYMBOL + ;; filename:1:0: (to 1:38) Some constructor unification variables are undetermined in declaration + ;; (look for them as "<UNIF:...>") + ;; Decl: + ;; val rec + ;; help : + ;; {} -> <UNIF:E::Type -> Type> (xml <UNIF:G::{Unit}> <UNIF:H::{Type}> ([])) = + ;; fn $x : {} => + ;; case $x of + ;; {} => + ;; return [<UNIF:E::Type -> Type>] + ;; [xml <UNIF:G::{Unit}> <UNIF:H::{Type}> ([])] _ + ;; (Basis.cdata [<UNIF:G::{Unit}>] [<UNIF:H::{Type}>] "Hello!") + + :error-patterns + ((error line-start (file-name) ":" line ":" column ":" + " (to " (1+ num) ?: (1+ num) ")" + ;; AS: indebted to David Christiansen for this rx expression! + (message (and (* nonl) (* "\n" (not (any "/" "~")) (* nonl)))))) + :predicate + (lambda () + (buffer-file-name)) + :modes (urweb-mode)) + +;;;###autoload +(defun urweb-flycheck-setup () + "Setup Flycheck Ur/Web. + +Add `urweb' to `flycheck-checkers'." + (interactive) + (add-to-list 'flycheck-checkers 'urweb)) + +(provide 'urweb-flycheck) +;;; urweb-flycheck.el ends here diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 69b0e23c..057761ac 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -925,6 +925,33 @@ Optional argument STYLE is currently ignored." (urweb-skip-siblings)) fullname))) +(defun urweb-get-proj-dir (bfn) + (locate-dominating-file + bfn + (lambda (dir) + (some (lambda (f) (s-suffix? ".urp" f)) + (if (f-dir? dir) + (directory-files dir) + (list '(dir))))))) + +(defun urweb-get-info () + (interactive) + (let* + ((row (line-number-at-pos)) + (col (evil-column)) + (bfn (buffer-file-name)) + (proj-dir (urweb-get-proj-dir bfn)) + (filename (file-relative-name bfn proj-dir)) + (loc (concat filename ":" (number-to-string row) ":" (number-to-string col))) + ) + (require 's) + (require 'f) + (require 'simple) + (message (let + ((default-directory proj-dir)) + (shell-command-to-string (concat "urweb -getInfo " loc))))) + ) + (provide 'urweb-mode) ;;; urweb-mode.el ends here diff --git a/src/endpoints.sig b/src/endpoints.sig new file mode 100644 index 00000000..89e72add --- /dev/null +++ b/src/endpoints.sig @@ -0,0 +1,44 @@ +(* Copyright (c) 2019, Artyom Shalkhakov + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * 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 + * 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 + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature ENDPOINTS = sig + + datatype method = GET | POST + val methodToString : method -> string + + type endpoint = {Method : method, Url : string, ContentType : string option, LastModified : Time.time option} + val p_endpoint : endpoint Print.printer + + type report = {Endpoints : endpoint list} + val p_report : report Print.printer + + val reset : unit -> unit + val collect : Mono.file -> Mono.file + val setJavaScript : string -> unit + val summarize : unit -> report + +end diff --git a/src/endpoints.sml b/src/endpoints.sml new file mode 100644 index 00000000..5699f319 --- /dev/null +++ b/src/endpoints.sml @@ -0,0 +1,117 @@ +(* Copyright (c) 2019 Artyom Shalkhakov + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * 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 + * 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 + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Endpoints :> ENDPOINTS = struct + +open Print.PD +open Print + +open Mono + +datatype method = GET | POST + +fun methodToString GET = "GET" + | methodToString POST = "POST" + +type endpoint = {Method : method, Url : string, ContentType : string option, LastModified : Time.time option} +type report = {Endpoints : endpoint list} + +fun p_endpoint {Method = m, Url = u, ContentType = oct, LastModified = olm} = + let + val rfcFmt = "%a, %d %b %Y %H:%M:%S GMT" + in + box [string "{", + string "\"method\": \"", string (methodToString m), string "\", ", + string "\"url\": \"", string u, string "\", ", + string "\"content-type\": ", (case oct of SOME ct => box [string "\"", string ct, string"\""] + | NONE => string "null"), + string "}"] + end + +fun p_report {Endpoints = el} = + box [string "{\"endpoints\":", + space, + string "[", + p_list_sep (box [string ",", newline]) p_endpoint el, + string "]}"] + +val endpoints = ref ([] : endpoint list) +val jsFile = ref (NONE : string option) + +fun setJavaScript x = jsFile := SOME x + +fun reset () = (endpoints := []; jsFile := NONE) + +fun collect file = + let + fun exportKindToMethod (Link _) = GET + | exportKindToMethod (Action _) = POST + | exportKindToMethod (Rpc _) = POST + | exportKindToMethod (Extern _) = POST + + fun decl ((d, _), st as endpoints) = + let + in + case d of + DExport (ek, id, i, tl, rt, f) => + {Method = exportKindToMethod ek, Url = id, LastModified = NONE, ContentType = NONE} :: st + | _ => st + end + + val () = reset () + + val (decls, _) = file + val ep = foldl decl [] decls + + fun binfile ({Uri = u, ContentType = ct, LastModified = lm, Bytes = _ }, st) = + {Method = GET, Url = u, LastModified = SOME lm, ContentType = ct} :: st + + val ep = foldl binfile ep (Settings.listFiles ()) + + fun jsfile ({Filename = f, Content = _}, st) = + {Method = GET, Url = f, LastModified = NONE, ContentType = SOME "text/javascript"} :: st + + val ep = foldl jsfile ep (Settings.listJsFiles ()) + in + endpoints := ep; + file + end + +fun summarize () = + let + val ep = !endpoints + val js = !jsFile + val ep = + case js of + NONE => ep + | SOME js => + {Method = GET, Url = js, LastModified = NONE, ContentType = SOME "text/javascript"} :: ep + in + {Endpoints = ep} + end + +end diff --git a/src/errormsg.sig b/src/errormsg.sig index 92425842..1fa4013c 100644 --- a/src/errormsg.sig +++ b/src/errormsg.sig @@ -48,9 +48,17 @@ signature ERROR_MSG = sig val posOf : int -> pos val spanOf : int * int -> span + (* To monitor in which modules the elaboration phase finds errors *) + val startElabStructure : string -> unit + val stopElabStructureAndGetErrored : string -> bool (* Did the module elab encounter errors? *) + + val resetStructureTracker: unit -> unit val resetErrors : unit -> unit val anyErrors : unit -> bool val error : string -> unit val errorAt : span -> string -> unit val errorAt' : int * int -> string -> unit + val readErrorLog: unit -> + { span: span + , message: string } list end diff --git a/src/errormsg.sml b/src/errormsg.sml index 8f3c93b1..d40789ed 100644 --- a/src/errormsg.sml +++ b/src/errormsg.sml @@ -88,12 +88,34 @@ fun spanOf (pos1, pos2) = {file = !file, val errors = ref false +val errorLog = ref ([]: { span: span + , message: string } list) +fun readErrorLog () = !errorLog +val structuresCurrentlyElaborating: ((string * bool) list) ref = ref nil + +fun startElabStructure s = + structuresCurrentlyElaborating := ((s, false) :: !structuresCurrentlyElaborating) +fun stopElabStructureAndGetErrored s = + let + val errored = + case List.find (fn x => #1 x = s) (!structuresCurrentlyElaborating) of + NONE => false + | SOME tup => #2 tup + val () = structuresCurrentlyElaborating := + (List.filter (fn x => #1 x <> s) (!structuresCurrentlyElaborating)) + in + errored + end +fun resetStructureTracker () = + structuresCurrentlyElaborating := [] -fun resetErrors () = errors := false +fun resetErrors () = (errors := false; errorLog := []) fun anyErrors () = !errors fun error s = (TextIO.output (TextIO.stdErr, s); TextIO.output1 (TextIO.stdErr, #"\n"); - errors := true) + errors := true; + structuresCurrentlyElaborating := + List.map (fn (s, e) => (s, true)) (!structuresCurrentlyElaborating)) fun errorAt (span : span) s = (TextIO.output (TextIO.stdErr, #file span); TextIO.output (TextIO.stdErr, ":"); @@ -101,6 +123,9 @@ fun errorAt (span : span) s = (TextIO.output (TextIO.stdErr, #file span); TextIO.output (TextIO.stdErr, ": (to "); TextIO.output (TextIO.stdErr, posToString (#last span)); TextIO.output (TextIO.stdErr, ") "); + errorLog := ({ span = span + , message = s + } :: !errorLog); error s) fun errorAt' span s = errorAt (spanOf span) s diff --git a/src/filecache.sml b/src/filecache.sml index e2291c10..a0da4b05 100644 --- a/src/filecache.sml +++ b/src/filecache.sml @@ -81,7 +81,10 @@ fun instrument file = fun wrapCol (name, t) = case #1 t of TFfi ("Basis", "blob") => - "DIGEST(" ^ name ^ ", 'sha512')" + (case #supportsSHA512 (Settings.currentDbms ()) of + NONE => (ErrorMsg.error "DBMS doesn't support SHA512."; + "ERROR") + | SOME r => #GenerateHash r name) | TOption t' => wrapCol (name, t') | _ => name diff --git a/src/fromjson.sig b/src/fromjson.sig new file mode 100644 index 00000000..3fdc1a89 --- /dev/null +++ b/src/fromjson.sig @@ -0,0 +1,8 @@ +signature FROMJSON = sig + val getO: string -> Json.json -> Json.json option + val get: string -> Json.json -> Json.json + val asInt: Json.json -> int + val asString: Json.json -> string + val asOptionalInt: Json.json -> int option + val asOptionalString: Json.json -> string option +end diff --git a/src/fromjson.sml b/src/fromjson.sml new file mode 100644 index 00000000..6a9bd71b --- /dev/null +++ b/src/fromjson.sml @@ -0,0 +1,35 @@ +structure FromJson :> FROMJSON = struct +fun getO (s: string) (l: Json.json): Json.json option = + case l of + Json.Obj pairs => + (case List.find (fn tup => #1 tup = s) pairs of + NONE => NONE + | SOME tup => SOME (#2 tup)) + | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) +fun get (s: string) (l: Json.json): Json.json = + (case getO s l of + NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) + | SOME a => a) + +fun asInt (j: Json.json): int = + case j of + Json.Int i => i + | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) + +fun asString (j: Json.json): string = + case j of + Json.String s => s + | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) + +fun asOptionalInt (j: Json.json): int option = + case j of + Json.Null => NONE + | Json.Int i => SOME i + | _ => raise Fail ("Expected JSON int or null, got: " ^ Json.print j) + +fun asOptionalString (j: Json.json): string option = + case j of + Json.Null => NONE + | Json.String s => SOME s + | _ => raise Fail ("Expected JSON string or null, got: " ^ Json.print j) +end diff --git a/src/getinfo.sig b/src/getinfo.sig new file mode 100644 index 00000000..63850ef2 --- /dev/null +++ b/src/getinfo.sig @@ -0,0 +1,50 @@ +(* Copyright (c) 2012, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * 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 + * 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 + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature GET_INFO = sig + + datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundKind of (string * Elab.kind) + | FoundCon of (string * Elab.con) + + val findStringInEnv: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + {line: int, char: int} -> + string (* query *) -> + (ElabEnv.env * string (* prefix *) * foundInEnv option) + + val matchStringInEnv: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + {line: int, char: int} -> + string (* query *) -> + (ElabEnv.env * string (* prefix *) * foundInEnv list) +end + diff --git a/src/getinfo.sml b/src/getinfo.sml new file mode 100644 index 00000000..2b27b8df --- /dev/null +++ b/src/getinfo.sml @@ -0,0 +1,304 @@ +(* Copyright (c) 2012, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * 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 + * 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 + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure GetInfo :> GET_INFO = struct + +structure U = ElabUtilPos +structure E = ElabEnv +structure L = Elab + +fun isPosIn (file: string) (line: int) (char: int) (span: ErrorMsg.span) = + let + val start = #first span + val end_ = #last span + in + OS.Path.base file = OS.Path.base (#file span) + andalso + (#line start < line orelse + #line start = line andalso #char start <= char) + andalso + (#line end_ > line orelse + #line end_ = line andalso #char end_ >= char) + end + +fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = + (#line (#first s1) > #line (#first s2) orelse + (#line (#first s1) = #line (#first s2) andalso (#char (#first s1) >= #char (#first s2)))) + andalso + (#line (#last s1) < #line (#last s2) orelse + (#line (#last s1) = #line (#last s2) andalso (#char (#last s1) <= #char (#last s2)))) + +datatype item = + Kind of L.kind + | Con of L.con + | Exp of L.exp + | Sgn_item of L.sgn_item + | Sgn of L.sgn + | Str of L.str + | Decl of L.decl + +fun getSpan (f: item) = + case f of + Kind k => #2 k + | Con c => #2 c + | Exp e => #2 e + | Sgn_item si => #2 si + | Sgn s => #2 s + | Str s => #2 s + | Decl d => #2 d + + +fun findInStr (f: ElabEnv.env -> item (* curr *) -> item (* prev *) -> bool) + (init: item) + env str fileName {line = line, char = char}: {item: item, env: ElabEnv.env} = + let + val () = U.mliftConInCon := E.mliftConInCon + val {env: ElabEnv.env, found: Elab.decl option} = + (case str of + L.StrConst decls => + List.foldl (fn (d, acc as {env, found}) => + if #line (#last (#2 d)) < line + then {env = E.declBinds env d, found = found} + else + if #line (#first (#2 d)) <= line andalso line <= #line (#last (#2 d)) + then {env = env, found = SOME d} + else {env = env, found = found}) + {env = env, found = NONE} decls + | _ => { env = env, found = NONE }) + val dummyResult = (init, env) + val result = + case found of + NONE => dummyResult + | SOME d => + U.Decl.foldB + { kind = fn (env, i, acc as (prev, env')) => if f env (Kind i) prev then (Kind i, env) else acc, + con = fn (env, i, acc as (prev, env')) => if f env (Con i) prev then (Con i, env) else acc, + exp = fn (env, i, acc as (prev, env')) => if f env (Exp i) prev then (Exp i, env) else acc, + sgn_item = fn (env, i, acc as (prev, env')) => if f env (Sgn_item i) prev then (Sgn_item i, env) else acc, + sgn = fn (env, i, acc as (prev, env')) => if f env (Sgn i) prev then (Sgn i, env) else acc, + str = fn (env, i, acc as (prev, env')) => if f env (Str i) prev then (Str i, env) else acc, + decl = fn (env, i, acc as (prev, env')) => if f env (Decl i) prev then (Decl i, env) else acc, + bind = fn (env, binder) => + case binder of + U.Decl.RelK x => E.pushKRel env x + | U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co + | U.Decl.RelE (x, c) => E.pushERel env x c + | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) + | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) + | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) + } + env dummyResult d + in + {item = #1 result, env = #2 result} + end + +fun findClosestSpan env str fileName {line = line, char = char} = + let + fun getDistance (i: item): int = + let + val {first, last, file} = getSpan i + in + Int.abs (#char first - char) + + Int.abs (#char last - char) + + Int.abs (#line first - line) * 25 + + Int.abs (#line last - line) * 25 + end + fun isCloser (env: ElabEnv.env) (curr: item) (prev: item) = + getDistance curr < getDistance prev + val init = Str (str, { file = fileName + , first = { line = 0, char = 0} + , last = { line = 0, char = 0} }) + in + findInStr isCloser init env str fileName {line = line, char = char} + end + +fun findFirstExpAfter env str fileName {line = line, char = char} = + let + fun currIsAfterPosAndBeforePrev (env: ElabEnv.env) (curr: item) (prev: item) = + (* curr is an exp *) + (case curr of Exp _ => true | _ => false) + andalso + (* curr is after input pos *) + ( line < #line (#first (getSpan curr)) + orelse ( line = #line (#first (getSpan curr)) + andalso char < #char (#first (getSpan curr)))) + andalso + (* curr is before prev *) + (#line (#first (getSpan curr)) < #line (#first (getSpan prev)) + orelse + (#line (#first (getSpan curr)) = #line (#first (getSpan prev)) + andalso #char (#first (getSpan curr)) < #char (#first (getSpan prev)))) + val init = Exp (Elab.EPrim (Prim.Int 0), + { file = fileName + , first = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} + , last = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} }) + in + findInStr currIsAfterPosAndBeforePrev init env str fileName {line = line, char = char} + end + + +datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundKind of (string * Elab.kind) + | FoundCon of (string * Elab.con) + +fun getNameOfFoundInEnv (f: foundInEnv) = + case f of + FoundStr (x, _) => x + | FoundKind (x, _) => x + | FoundCon (x, _) => x + +fun filterSgiItems (items: Elab.sgn_item list) : foundInEnv list = + let + fun processDatatype loc (dtx, i, ks, cs) = + let + val k' = (Elab.KType, loc) + val k = FoundKind (dtx, foldl (fn (_, k) => (Elab.KArrow (k', k), loc)) k' ks) + val foundCs = List.map (fn (x, j, co) => + let + val c = case co of + NONE => (Elab.CNamed i, loc) + | SOME c => (Elab.TFun (c, (Elab.CNamed i, loc)), loc) + in + FoundCon (x, c) + end) cs + in + k :: foundCs + end + fun mapF item = + case item of + (Elab.SgiVal (name, _, c), _) => [FoundCon (name, c)] + | (Elab.SgiCon (name, _, k, _), _) => [FoundKind (name, k)] + | (Elab.SgiDatatype ds, loc) => + List.concat (List.map (processDatatype loc) ds) + | (Elab.SgiDatatypeImp (dtx, i, _, ks, _, _, cs), loc) => processDatatype loc (dtx, i, ks, cs) + | (Elab.SgiStr (_, name, _, sgn), _) => + [FoundStr (name, sgn)] + | (Elab.SgiSgn (name, _, sgn), _) => [] + | _ => [] + in + List.concat (List.map mapF items) + end + +fun resolvePrefixes + (env: ElabEnv.env) + (prefixes: string list) + (items : foundInEnv list) + : foundInEnv list + = + case prefixes of + [] => items + | first :: rest => + (case List.find (fn item => getNameOfFoundInEnv item = first) items of + NONE => [] + | SOME (FoundStr (name, sgn)) => (case ElabEnv.hnormSgn env sgn of + (Elab.SgnConst sgis, _) => resolvePrefixes env rest (filterSgiItems sgis) + | _ => []) + | SOME (FoundCon (name, c)) => + let + val fields = case ElabOps.reduceCon env c of + (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_) => + fields + | ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") , l4_) + , ( Elab.CRecord (_, fields) , l3_))) + , l2_) + , _)) + , l1_) => fields + | _ => [] + val items = + List.mapPartial (fn (c1, c2) => case c1 of + (Elab.CName fieldName, _) => SOME (FoundCon (fieldName, c2)) + | _ => NONE) fields + in + resolvePrefixes env rest items + end + | SOME (FoundKind (_, _)) => []) + + +fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string (* prefix *) * foundInEnv option) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundKind (ElabEnv.dumpCs env) + @ List.map FoundCon (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.find (fn i => getNameOfFoundInEnv i = query) afterResolve) + end + +fun matchStringInEnv' (env: ElabEnv.env) (str: string): (string (* prefix *) * foundInEnv list) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundKind (ElabEnv.dumpCs env) + @ List.map FoundCon (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.filter (fn i => String.isPrefix query (getNameOfFoundInEnv i)) afterResolve) + end + +fun getDesc item = + case item of + Kind (_, s) => "Kind " ^ ErrorMsg.spanToString s + | Con (_, s) => "Con " ^ ErrorMsg.spanToString s + | Exp (_, s) => "Exp " ^ ErrorMsg.spanToString s + | Sgn_item (_, s) => "Sgn_item " ^ ErrorMsg.spanToString s + | Sgn (_, s) => "Sgn " ^ ErrorMsg.spanToString s + | Str (_, s) => "Str " ^ ErrorMsg.spanToString s + | Decl (_, s) => "Decl " ^ ErrorMsg.spanToString s + +fun matchStringInEnv env str fileName pos query: (ElabEnv.env * string (* prefix *) * foundInEnv list) = + let + val {item = _, env} = findClosestSpan env str fileName pos + val (prefix, matches) = matchStringInEnv' env query + in + (env, prefix, matches) + end + +fun findStringInEnv env str fileName pos (query: string): (ElabEnv.env * string (* prefix *) * foundInEnv option) = + let + val {item, env} = findClosestSpan env str fileName pos + val env = case item of + Exp (L.ECase _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.ELet _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.EAbs _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp e => env + | Con _ => #env (findFirstExpAfter env str fileName pos) + | _ => #env (findFirstExpAfter env str fileName pos) + val preferCon = case item of Con _ => true + | _ => false + val (prefix, found) = findStringInEnv' env preferCon query + in + (env, prefix, found) + end +end diff --git a/src/json.sig b/src/json.sig new file mode 100644 index 00000000..f92ef495 --- /dev/null +++ b/src/json.sig @@ -0,0 +1,13 @@ +signature JSON = sig + datatype json = + Array of json list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Obj of (string * json) list + + val parse: string -> json + val print: json -> string +end diff --git a/src/json.sml b/src/json.sml new file mode 100644 index 00000000..81d7b8b4 --- /dev/null +++ b/src/json.sml @@ -0,0 +1,293 @@ +(******************************************************************************* +* Standard ML JSON parser +* Copyright (C) 2010 Gian Perrone +* +* This program is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, either version 3 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program. If not, see <http://www.gnu.org/licenses/>. +******************************************************************************) + +signature JSON_CALLBACKS = +sig + type json_data + + val json_object : json_data list -> json_data + val json_pair : string * json_data -> json_data + val json_array : json_data list -> json_data + val json_value : json_data -> json_data + val json_string : string -> json_data + val json_int : int -> json_data + val json_real : real -> json_data + val json_bool : bool -> json_data + val json_null : unit -> json_data + + val error_handle : string * int * string -> json_data +end + +functor JSONParser (Callbacks : JSON_CALLBACKS) = +struct + type json_data = Callbacks.json_data + + exception JSONParseError of string * int + + val inputData = ref "" + val inputPosition = ref 0 + + fun isDigit () = Char.isDigit (String.sub (!inputData,0)) + + fun ws () = while (String.isPrefix " " (!inputData) orelse + String.isPrefix "\n" (!inputData) orelse + String.isPrefix "\t" (!inputData) orelse + String.isPrefix "\r" (!inputData)) + do (inputData := String.extract (!inputData, 1, NONE)) + + fun peek () = String.sub (!inputData,0) + fun take () = + String.sub (!inputData,0) before + inputData := String.extract (!inputData, 1, NONE) + + fun matches s = (ws(); String.isPrefix s (!inputData)) + fun consume s = + if matches s then + (inputData := String.extract (!inputData, size s, NONE); + inputPosition := !inputPosition + size s) + else + raise JSONParseError ("Expected '"^s^"'", !inputPosition) + + fun parseObject () = + if not (matches "{") then + raise JSONParseError ("Expected '{'", !inputPosition) + else + (consume "{"; ws (); + if matches "}" then Callbacks.json_object [] before consume "}" + else + (Callbacks.json_object (parseMembers ()) + before (ws (); consume "}"))) + + and parseMembers () = + parsePair () :: + (if matches "," then (consume ","; parseMembers ()) else []) + + and parsePair () = + Callbacks.json_pair (parseString (), + (ws(); consume ":"; ws(); parseValue ())) + + and parseArray () = + if not (matches "[") then + raise JSONParseError ("Expected '['", !inputPosition) + else + (consume "["; + if matches "]" then + Callbacks.json_array [] before consume "]" + else + Callbacks.json_array (parseElements ()) before (ws (); consume "]")) + + and parseElements () = + parseValue () :: + (if matches "," then (consume ","; parseElements ()) else []) + + and parseValue () = + Callbacks.json_value ( + if matches "\"" then Callbacks.json_string (parseString ()) else + if matches "-" orelse isDigit () then parseNumber () else + if matches "true" then Callbacks.json_bool true before consume "true" else + if matches "false" then Callbacks.json_bool false before consume "false" else + if matches "null" then Callbacks.json_null () before consume "null" else + if matches "[" then parseArray () else + if matches "{" then parseObject () else + raise JSONParseError ("Expected value", !inputPosition)) + + and parseString () = + (ws () ; + consume ("\"") ; + parseChars () before consume "\"") + + and parseChars () = + let + val escapedchars = ["n", "r", "b", "f", "t"] + fun pickChars s = + if peek () = #"\"" (* " = end of string *) + then s + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"\"" + then (consume "\\\""; pickChars (s ^ "\"")) + else + if peek () = #"\\" andalso String.sub (!inputData, 1) = #"\\" andalso String.sub (!inputData, 2) = #"n" + then (consume "\\\\n"; pickChars (s ^ "\\n")) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"n" + then (consume "\\n"; pickChars (s ^ "\n")) + else + if peek () = #"\\" andalso String.sub (!inputData, 1) = #"\\" andalso String.sub (!inputData, 2) = #"r" + then (consume "\\\\r"; pickChars (s ^ "\\r")) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"r" + then (consume "\\r"; pickChars (s ^ "\r")) + else pickChars (s ^ String.str (take ())) + in + pickChars "" + end + + and parseNumber () = + let + val i = parseInt () + in + if peek () = #"e" orelse peek () = #"E" then + Callbacks.json_int (valOf (Int.fromString (i^parseExp()))) + else if peek () = #"." then + let + val f = parseFrac() + + val f' = if peek() = #"e" orelse peek() = #"E" then + i ^ f ^ parseExp () + else i ^ f + in + Callbacks.json_real (valOf (Real.fromString f')) + end + else Callbacks.json_int (valOf (Int.fromString i)) + end + + and parseInt () = + let + val f = + if peek () = #"-" + then (take (); "~") + else String.str (take ()) + in + f ^ parseDigits () + end + + and parseDigits () = + let + val r = ref "" + in + (while Char.isDigit (peek ()) do + r := !r ^ String.str (take ()); + !r) + end + + and parseFrac () = + (consume "." ; + "." ^ parseDigits ()) + + and parseExp () = + let + val _ = + if peek () = #"e" orelse + peek () = #"E" then take () + else + raise JSONParseError ("Invalid number", !inputPosition) + + val f = if peek () = #"-" then (take (); "~") + else if peek () = #"+" then (take (); "") + else "" + in + "e" ^ f ^ parseDigits () + end + + fun parse s = + (inputData := s ; + inputPosition := 0 ; + parseObject ()) handle JSONParseError (m,p) => + Callbacks.error_handle (m,p,!inputData) +end + +structure JsonIntermAst = +struct +datatype ast = + Array of ast list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Pair of (string * ast) + | Obj of ast list +end + +structure Json :> JSON = struct +datatype json = + Array of json list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Obj of (string * json) list + +fun fromInterm (interm: JsonIntermAst.ast): json = + case interm of + JsonIntermAst.Array l => Array (List.map fromInterm l) + | JsonIntermAst.Null => Null + | JsonIntermAst.Float r => Float r + | JsonIntermAst.String s => String s + | JsonIntermAst.Bool b => Bool b + | JsonIntermAst.Int i => Int i + | JsonIntermAst.Pair (k,v) => + raise Fail ("JSON Parsing error. Pair of JSON found where it shouldn't. Key = " ^ k) + | JsonIntermAst.Obj l => + Obj + (List.foldl + (fn (a, acc) => + case a of + JsonIntermAst.Pair (k, v) => (k, fromInterm v) :: acc + | JsonIntermAst.Array _ => raise Fail ("JSON Parsing error. Found Array in object instead of key-value pair") + | JsonIntermAst.Null => raise Fail ("JSON Parsing error. Found Null in object instead of key-value pair") + | JsonIntermAst.Float _ => raise Fail ("JSON Parsing error. Found Float in object instead of key-value pair") + | JsonIntermAst.String _ => raise Fail ("JSON Parsing error. Found String in object instead of key-value pair") + | JsonIntermAst.Bool _ => raise Fail ("JSON Parsing error. Found Bool in object instead of key-value pair") + | JsonIntermAst.Int _ => raise Fail ("JSON Parsing error. Found Int in object instead of key-value pair") + | JsonIntermAst.Obj _ => raise Fail ("JSON Parsing error. Found Obj in object instead of key-value pair") + ) [] l) + +structure StandardJsonParserCallbacks = +struct + type json_data = JsonIntermAst.ast + fun json_object l = JsonIntermAst.Obj l + fun json_pair (k,v) = JsonIntermAst.Pair (k,v) + fun json_array l = JsonIntermAst.Array l + fun json_value x = x + fun json_string s = JsonIntermAst.String s + fun json_int i = JsonIntermAst.Int i + fun json_real r = JsonIntermAst.Float r + fun json_bool b = JsonIntermAst.Bool b + fun json_null () = JsonIntermAst.Null + fun error_handle (msg,pos,data) = + raise Fail ("Error: " ^ msg ^ " near " ^ Int.toString pos ^ " data: " ^ + data) +end + +structure MyJsonParser = JSONParser (StandardJsonParserCallbacks) + +fun parse (str: string): json = + fromInterm (MyJsonParser.parse str) +fun print (ast: json): string = + case ast of + Array l => "[" + ^ List.foldl (fn (a, acc) => acc ^ (if acc = "" then "" else ", ") ^ print a) "" l + ^ "]" + | Null => "null" + | Float r => Real.toString r + | String s => + "\"" ^ + String.translate + (fn c => if c = #"\"" then "\\\"" else Char.toString c) + s ^ + "\"" + | Bool b => if b then "true" else "false" + | Int i => if i >= 0 + then (Int.toString i) + else "-" ^ (Int.toString (Int.abs i)) (* default printing uses ~ instead of - *) + | Obj l => "{" + ^ List.foldl (fn ((k, v), acc) => acc ^ (if acc = "" then "" else ", ") ^ "\"" ^ k ^ "\": " ^ print v ) "" l + ^ "}" +end diff --git a/src/lsp.sig b/src/lsp.sig new file mode 100644 index 00000000..0dc95801 --- /dev/null +++ b/src/lsp.sig @@ -0,0 +1,3 @@ +signature LSP = sig + val startServer : unit -> unit +end diff --git a/src/lsp.sml b/src/lsp.sml new file mode 100644 index 00000000..c99a6f2e --- /dev/null +++ b/src/lsp.sml @@ -0,0 +1,514 @@ +structure Lsp :> LSP = struct + +structure C = Compiler +structure P = Print + +val debug = LspSpec.debug + +structure SK = struct + type ord_key = string + val compare = String.compare +end +structure SM = BinaryMapFn(SK) + +type fileState = + { envBeforeThisModule: ElabEnv.env + , decls: Elab.decl list + , text: string} +type state = + { urpPath : string + , fileStates : fileState SM.map + } + +(* Wrapping this in structure as an attempt to not get concurrency bugs *) +structure State : + sig + val init: state -> unit + val insertText: string -> string -> unit + val insertElabRes: string -> ElabEnv.env -> Elab.decl list -> unit + val removeFile: string -> unit + val withState: (state -> 'a) -> 'a + end = struct +val stateRef = ref (NONE: state option) +fun init (s: state) = + stateRef := SOME s +fun withState (f: state -> 'a): 'a = + case !stateRef of + NONE => raise LspSpec.LspError LspSpec.ServerNotInitialized + | SOME s => f s + +fun insertText (fileName: string) (text: string) = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = + case SM.find (#fileStates oldS, fileName) of + NONE => SM.insert ( #fileStates oldS + , fileName + , { text = text + , decls = [] + , envBeforeThisModule = ElabEnv.empty }) + | SOME oldfs => + SM.insert ( #fileStates oldS + , fileName + , { text = text + , decls = #decls oldfs + , envBeforeThisModule = #envBeforeThisModule oldfs }) + } + ) + +fun insertElabRes (fileName: string) (env: ElabEnv.env) decls = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = + case SM.find (#fileStates oldS, fileName) of + NONE => raise Fail ("No text found for file " ^ fileName) + | SOME oldfs => + SM.insert ( #fileStates oldS + , fileName + , { text = #text oldfs + , decls = decls + , envBeforeThisModule = env }) + } + ) + +fun removeFile (fileName: string) = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = #1 (SM.remove (#fileStates oldS, fileName)) + } + ) + +end + + + +fun scanDir (f: string -> bool) (path: string) = + let + val dir = OS.FileSys.openDir path + fun doScanDir acc = + case OS.FileSys.readDir dir of + NONE => (OS.FileSys.closeDir dir; acc) + | SOME fname => + (if f fname + then doScanDir (fname :: acc) + else doScanDir acc) + in + doScanDir [] + end + +(* Throws Fail if can't init *) +fun initState (initParams: LspSpec.initializeParams): state = + let + val rootPath = case #rootUri initParams of + NONE => raise Fail "No rootdir found" + | SOME a => #path a + val optsUrpFile = + (SOME (FromJson.asString (FromJson.get "urpfile" (FromJson.get "project" (FromJson.get "urweb" (#initializationOptions initParams)))))) + handle ex => NONE + val foundUrps = scanDir (fn fname => OS.Path.ext fname = SOME "urp") rootPath + in + { urpPath = case foundUrps of + [] => raise Fail ("No .urp files found in path " ^ rootPath) + | one :: [] => OS.Path.base (OS.Path.file one) + | many => case List.find (fn m => SOME (OS.Path.base (OS.Path.file m)) = optsUrpFile) many of + NONE => raise Fail ("Found multiple .urp files in path " ^ rootPath) + | SOME f => OS.Path.base (OS.Path.file f) + , fileStates = SM.empty + } + end + +fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string) (addUnprefixed: bool): ElabEnv.env = + let + val moduleName = C.moduleOf fileName + val (sgn, gs) = Elaborate.elabSgn (env, Disjoint.empty) (Source.SgnConst sgn, { file = fileName + , first = ErrorMsg.dummyPos + , last = ErrorMsg.dummyPos }) + val () = case gs of + [] => () + | _ => (app (fn (_, env, _, c1, c2) => + Print.prefaces "Unresolved" + [("c1", ElabPrint.p_con env c1), + ("c2", ElabPrint.p_con env c2)]) gs; + raise Fail ("Unresolved disjointness constraints in " ^ moduleName ^ " at " ^ fileName)) (* TODO Not sure if this is needed for all signatures or only for Basis *) + val (env', n) = ElabEnv.pushStrNamed env moduleName sgn + val (_, env') = if addUnprefixed + then Elaborate.dopen env' {str = n, strs = [], sgn = sgn} + else ([], env') + in + env' + end + +fun errorToDiagnostic (err: { span: ErrorMsg.span , message: string }): LspSpec.diagnostic = + { range = { start = { line = #line (#first (#span err)) - 1 + , character = #char (#first (#span err)) + } + , end_ = { line = #line (#last (#span err)) - 1 + , character = #char (#last (#span err)) + } + } + , severity = 1 + , source = "UrWeb" + , message = #message err + } + +(* TODO FFI modules ? Check compiler.sml -> parse -> parseFfi *) +(* TODO Optim: cache parsed urp file? *) +fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBeforeThisModule: ElabEnv.env} option * LspSpec.diagnostic list) = + let + val () = if (OS.Path.ext fileName = SOME "ur") + then () + else raise Fail ("Can only handle .ur files for now") + (* val () = Elaborate.unifyMore := true *) + (* To reuse Basis and Top *) + val () = Elaborate.incremental := true + (* Parsing .urp *) + val job = case C.run (C.transform C.parseUrp "parseUrp") (#urpPath state) of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Couldn't parse .urp file at " ^ (#urpPath state))) + | SOME a => a + val moduleSearchRes = + List.foldl + (fn (entry, acc) => if #2 acc + then acc + else + if entry ^ ".ur" = fileName + then (List.rev (#1 acc), true) + else (entry :: #1 acc, false)) + ([] (* modules before *), false (* module found *)) + (#ffi job @ #sources job) + val modulesBeforeThisFile = #1 moduleSearchRes + val () = if #2 moduleSearchRes + then () + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state))) + (* Parsing .urs files of previous modules *) + val parsedUrss = List.map (fn entry => + if OS.FileSys.access (entry ^ ".urs", []) + then case C.run (C.transform C.parseUrs "parseUrs") (entry ^ ".urs") of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse .urs file at " ^ entry)) + | SOME a => { fileName = entry ^ ".urs", parsed = a} + else + if OS.FileSys.access (entry ^ ".ur", []) + then case C.run (C.transform C.parseUrs "parseUrs") (entry ^ ".ur") of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("No .urs file found for " ^ entry ^ " and couldn't parse .ur as .urs file")) + | SOME a => { fileName = entry ^ ".ur" , parsed = a} + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find an .ur or .urs file for " ^ entry))) + modulesBeforeThisFile + (* Parsing Basis and Top *) + val basisF = Settings.libFile "basis.urs" + val topF = Settings.libFile "top.urs" + val topF' = Settings.libFile "top.ur" + + val tm1 = OS.FileSys.modTime topF + val tm2 = OS.FileSys.modTime topF' + + val parsedBasisUrs = + case C.run (C.transform C.parseUrs "parseUrs") basisF of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse basis.urs file at " ^ basisF)) + | SOME a => a + val parsedTopUrs = + case C.run (C.transform C.parseUrs "parseUrs") topF of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse top.urs file at " ^ topF)) + | SOME a => a + val parsedTopUr = + case C.run (C.transform C.parseUr "parseUr") topF' of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse top.ur file at " ^ topF')) + | SOME a => a + + (* Parsing .ur and .urs of current file *) + val (parsedUrs: Source.sgn option) = + (if OS.FileSys.access (fileName ^ "s", []) + then + case C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s") of + NONE => NONE + | SOME a => SOME ( Source.SgnConst a + , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) + else + NONE) handle ex => NONE + val () = ErrorMsg.resetErrors () + val (parsedUrO: (Source.decl list) option) = + C.run (C.transform C.parseUr "parseUr") fileName + in + case parsedUrO of + NONE => (* Parse error *) (NONE, List.map errorToDiagnostic (ErrorMsg.readErrorLog ())) + | SOME parsedUr => + (* Parsing of .ur succeeded *) + let + val loc = {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} + val envBeforeThisModule = ref ElabEnv.empty + val res = Elaborate.elabFile + parsedBasisUrs tm1 parsedTopUr parsedTopUrs tm2 ElabEnv.empty + (* Adding urs's of previous modules to env *) + (fn envB => + let + val newEnv = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss + in + (envBeforeThisModule := newEnv; newEnv) + end + ) + [( Source.DStr (C.moduleOf fileName, parsedUrs, NONE, (Source.StrConst parsedUr, loc), false) + , loc )] + (* report back errors (as Diagnostics) *) + val errors = ErrorMsg.readErrorLog () + val decls = case List.last res of + (Elab.DStr (_, _, _, (Elab.StrConst decls, _)), _) => decls + | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + in + (SOME { envBeforeThisModule = !envBeforeThisModule, decls = decls }, + List.map errorToDiagnostic errors) + end + end + +fun uniq (eq: 'b -> 'b -> bool) (bs: 'b list) = + case bs of + [] => [] + | (l as b :: bs') => b :: uniq eq (List.filter (fn a => not (eq a b)) bs') + +fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri): unit = + let + val fileName = #path documentUri + val res = elabFile state fileName + fun eq_diag (d1: LspSpec.diagnostic) (d2: LspSpec.diagnostic) = #range d1 = #range d2 andalso #message d1 = #message d2 + val diags = uniq eq_diag (#2 res) + in + (case #1 res of + NONE => () + | SOME fs => + (State.insertElabRes fileName (#envBeforeThisModule fs) (#decls fs)); + #publishDiagnostics toclient { uri = documentUri , diagnostics = diags}) + end + +fun scanDir (f: string -> bool) (path: string) = + let + val dir = OS.FileSys.openDir path + fun doScanDir acc = + case OS.FileSys.readDir dir of + NONE => (OS.FileSys.closeDir dir; acc) + | SOME fname => + (if f fname + then doScanDir (fname :: acc) + else doScanDir acc) + in + doScanDir [] + end + +fun readFile (fileName: string): string = + let + val stream = TextIO.openIn fileName + fun doReadFile acc = + case TextIO.inputLine stream of + NONE => acc + | SOME str => (if acc = "" + then doReadFile str + else doReadFile (acc ^ str)) + val res = doReadFile "" + in + (TextIO.closeIn stream; res) + end + + +(* TODO PERF BIG I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) +fun ppToString (pp: Print.PD.pp_desc) (width: int): string = + let + val tempfile = OS.FileSys.tmpName () + val outStr = TextIO.openOut tempfile + val outDev = TextIOPP.openOut {dst = outStr, wid = width} + val () = Print.fprint outDev pp + val res = readFile tempfile + val () = TextIO.closeOut outStr + in + res + end + +fun getStringAtCursor + (stopAtCursor: bool) + (text: string) + (pos: LspSpec.position) + : string + = + let + val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full text), #line pos) + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":", #"@" + , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] + val lineUntilCursor = Substring.slice (line, 0, SOME (#character pos)) + val beforeCursor = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilCursor) + val afterCursor = if stopAtCursor + then "" + else let + val lineAfterCursor = Substring.slice (line, #character pos, NONE) + in + Substring.string (Substring.takel (fn c => not (List.exists (fn c' => c = c') (#"." :: chars))) lineAfterCursor) + end + in + beforeCursor ^ afterCursor + end + +fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = + P.PD.hvBox (P.PD.PPS.Rel 0, [a, + P.PD.string ": ", + P.PD.break {nsp = 0, offset = 2}, + b]) + +fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success NONE + | SOME s => + let + val searchString = getStringAtCursor false (#text s) (#position p) + val env = #envBeforeThisModule s + val decls = #decls s + val loc = #position p + val (env, prefix, found) = GetInfo.findStringInEnv env (Elab.StrConst decls) fileName { line = #line loc + 1 + , char = #character loc + 1} searchString + in + case found of + NONE => LspSpec.Success NONE + | SOME f => + let + val desc = case f of + GetInfo.FoundStr (x, (_, sgn)) => formatTypeBox (P.PD.string (prefix ^ x), P.PD.string "module") + | GetInfo.FoundKind (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) + | GetInfo.FoundCon (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) + in + LspSpec.Success (SOME {contents = ppToString desc 50}) + end + end + end + +(* TODO IDEA can we use the real parser to figure out what we're typing (exp, con, field, etc) to predict better? *) +fun handleCompletion (state: state) (p: LspSpec.completionReq) = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success { isIncomplete = false, items = []} + | SOME s => + let + val pos = #position p + val searchStr = getStringAtCursor true (#text s) pos + val env = #envBeforeThisModule s + val decls = #decls s + val (env, prefix, foundItems) = GetInfo.matchStringInEnv env (Elab.StrConst decls) fileName { line = #line pos + 1, char = #character pos + 1} searchStr + val completions = List.map + (fn f => case f of + GetInfo.FoundStr (x, _) => {label = prefix ^ x, kind = LspSpec.Module, detail = ""} + | GetInfo.FoundKind (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} + | GetInfo.FoundCon (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} + ) + foundItems + in + LspSpec.Success { isIncomplete = false + , items = completions } + end + end + +fun applyContentChange ((c, s): LspSpec.contentChange * string): string = + case (#range c, #rangeLength c) of + (SOME range, SOME _) => + let + val lines = Substring.fields (fn c => c = #"\n") (Substring.full s) + val linesBefore = List.take (lines, #line (#start range)) + val linesAfter = List.drop (lines, #line (#end_ range) + 1) + val startLine = List.nth (lines, #line (#start range)) + val startText = Substring.slice (startLine, 0, SOME (#character (#start range))) + val endLine = List.nth (lines, #line (#end_ range)) + val endText = Substring.triml (#character (#end_ range)) endLine + in + Substring.concatWith "\n" (linesBefore + @ [Substring.full (Substring.concat [startText, Substring.full (#text c), endText])] + @ linesAfter) + end + | _ => + #text c + +fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspSpec.didChangeParams): unit = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => + (debug ("Got change event for file that isn't open: " ^ fileName); + (#showMessage toclient) ("Got change event for file that isn't open: " ^ fileName) 1) + | SOME s => + State.insertText fileName (List.foldl applyContentChange (#text s) (#contentChanges p)) + end + +fun runInBackground (toclient: LspSpec.toclient) (fileName: string) (f: unit -> unit): unit = + BgThread.queueBgTask + fileName + ((fn () => (f () + handle LspSpec.LspError (LspSpec.InternalError str) => (#showMessage toclient) str 1 + | LspSpec.LspError LspSpec.ServerNotInitialized => (#showMessage toclient) "Server not initialized" 1 + | ex => (#showMessage toclient) (General.exnMessage ex) 1 + ; (#showMessage toclient) ("Done running BG job for " ^ fileName) 3 + ))) + +fun handleRequest (requestMessage: LspSpec.message) = + case requestMessage of + LspSpec.Notification n => + LspSpec.matchNotification + n + { initialized = fn () => () + , textDocument_didOpen = + fn (p, toclient) => + (State.insertText (#path (#uri (#textDocument p))) (#text (#textDocument p)); + runInBackground + toclient + (#path (#uri (#textDocument p))) + (fn () => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p))))) + , textDocument_didChange = + fn (p, toclient) => + State.withState (fn state => handleDocumentDidChange state toclient p) + , textDocument_didSave = + fn (p, toclient) => + runInBackground + toclient + (#path (#uri (#textDocument p))) + (fn () => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p)))) + , textDocument_didClose = + fn (p, toclient) => + State.removeFile (#path (#uri (#textDocument p))) + } + | LspSpec.RequestMessage m => + (* TODO should error handling here be inside handleMessage? *) + LspSpec.matchMessage + m + { initialize = fn p => + (let val st = initState p + in + State.init st; + LspSpec.Success + { capabilities = + { hoverProvider = true + , completionProvider = SOME { triggerCharacters = ["."]} + , textDocumentSync = { openClose = true + , change = 2 + , save = SOME { includeText = false } + }} + } + end) + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn toclient => State.withState handleHover + , textDocument_completion = fn p => State.withState (fn s => handleCompletion s p) + } + +fun serverLoop () = + if not (Option.isSome (TextIO.canInput (TextIO.stdIn, 1))) andalso BgThread.hasBgTasks () + then + (* no input waiting -> give control to lower prio thread *) + BgThread.runBgTaskForABit () + else + let + val requestMessage = + LspSpec.readRequestFromStdIO () + handle ex => (debug ("Error in reading from stdIn: " ^ General.exnMessage ex) ; raise ex) + in + handleRequest requestMessage + end + +fun startServer () = while true do serverLoop () +end diff --git a/src/lspspec.sml b/src/lspspec.sml new file mode 100644 index 00000000..0d766056 --- /dev/null +++ b/src/lspspec.sml @@ -0,0 +1,450 @@ +structure LspSpec = struct + + datatype lspError = InternalError of string + | ServerNotInitialized + exception LspError of lspError + + fun debug (str: string): unit = + (TextIO.output (TextIO.stdErr, str ^ "\n\n"); TextIO.flushOut TextIO.stdErr) + + fun trim (s: substring): substring = + Substring.dropr Char.isSpace (Substring.dropl Char.isSpace s) + + fun readHeader (): (string * string) option = + let + val line = TextIO.inputLine TextIO.stdIn + in + case line of + NONE => OS.Process.exit OS.Process.success + | SOME str => + if Substring.isEmpty (trim (Substring.full str)) + then NONE + else + let + val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) + in + if Substring.isEmpty (trim value) + then raise Fail ("Failed to parse LSP header: Line is not empty but is also not a valid header: " ^ str) + else SOME ( Substring.string (trim key) + , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) + end + end + + fun readAllHeaders (): (string * string) list = + let + fun doReadAllHeaders (l: (string * string) list): (string * string) list = + case readHeader () of + NONE => l + | SOME tup => tup :: doReadAllHeaders l + + in + doReadAllHeaders [] + end + datatype message = + RequestMessage of { id: Json.json, method: string, params: Json.json} + | Notification of { method: string, params: Json.json} + fun parseMessage (j: Json.json): message = + let + val id = SOME (FromJson.get "id" j) + handle ex => NONE + val method = FromJson.asString (FromJson.get "method" j) + val params = FromJson.get "params" j + in + case id of + NONE => Notification {method = method, params = params} + | SOME id => RequestMessage {id = id, method = method, params = params} + end + + type documentUri = + { scheme: string + , authority: string + , path: string + , query: string + , fragment: string + } + fun parseDocumentUri (str: string): documentUri = + let + val str = Substring.full str + val (scheme, rest) = Substring.splitl (fn c => c <> #":") str + val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) + val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") rest + val (query, rest) = if Substring.first rest = SOME #"?" + then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) + else (Substring.full "", rest) + val fragment = if Substring.first rest = SOME #"#" + then (Substring.triml 1 rest (* # *)) + else Substring.full "" + + in + { scheme = Substring.string scheme + , authority = Substring.string authority + , path = Substring.string path + , query = Substring.string query + , fragment = Substring.string fragment + } + end + fun printDocumentUri (d: documentUri) = + (#scheme d) ^ "://" ^ + (#authority d) ^ + (#path d) ^ + (if #query d <> "" then "?" ^ #query d else "") ^ + (if #fragment d <> "" then "#" ^ #fragment d else "") + + type textDocumentIdentifier = { uri: documentUri} + fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j))} + + type versionedTextDocumentIdentifier = + { uri: documentUri + , version: int option + } + fun parseVersionedTextDocumentIdentifier (j: Json.json): versionedTextDocumentIdentifier = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) + , version = FromJson.asOptionalInt (FromJson.get "version" j) + } + + type textDocumentItem = { + uri: documentUri, + languageId: string, + version: int, (* The version number of this document (it will increase after each change, including undo/redo). *) + text: string + } + fun parseTextDocumentItem (j: Json.json) = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) + , languageId = FromJson.asString (FromJson.get "languageId" j) + , version = FromJson.asInt (FromJson.get "version" j) + , text = FromJson.asString (FromJson.get "text" j) + } + + type position = { line: int + , character: int + } + fun parsePosition (j: Json.json) = + { line = FromJson.asInt (FromJson.get "line" j) + , character = FromJson.asInt (FromJson.get "character" j) + } + fun printPosition (p: position): Json.json = Json.Obj [ ("line", Json.Int (#line p)) + , ("character", Json.Int (#character p))] + + type range = { start: position + , end_: position } + fun parseRange (j: Json.json): range = + { start = parsePosition (FromJson.get "start" j) + , end_ = parsePosition (FromJson.get "end" j) + } + fun printRange (r: range): Json.json = Json.Obj [ ("start", printPosition (#start r)) + , ("end", printPosition (#end_ r))] + + fun readRequestFromStdIO (): message = + let + val headers = readAllHeaders () + val lengthO = List.find (fn (k,v) => k = "Content-Length") headers + val request = case lengthO of + NONE => raise Fail "No header with Content-Length found" + | SOME (k, v) => + case Int.fromString v of + NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) + | SOME i => TextIO.inputN (TextIO.stdIn, i) + val parsed = Json.parse request + in + parseMessage parsed + end + + type hoverReq = { textDocument: textDocumentIdentifier , position: position } + type hoverResp = {contents: string} option + fun parseHoverReq (params: Json.json): hoverReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + , position = parsePosition (FromJson.get "position" params) + } + fun printHoverResponse (resp: hoverResp): Json.json = + case resp of + NONE => Json.Null + | SOME obj => Json.Obj [("contents", Json.String (#contents obj))] + + type didOpenParams = { textDocument: textDocumentItem } + fun parseDidOpenParams (params: Json.json): didOpenParams = + { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } + + type contentChange = { range: range option + , rangeLength: int option + , text: string } + type didChangeParams = + { textDocument: versionedTextDocumentIdentifier + , contentChanges: contentChange list + } + fun parseDidChangeParams (params: Json.json): didChangeParams = + { textDocument = parseVersionedTextDocumentIdentifier (FromJson.get "textDocument" params) + , contentChanges = case FromJson.get "contentChanges" params of + Json.Array js => + List.map (fn j => { range = Option.map parseRange (FromJson.getO "range" j) + , rangeLength = Option.map FromJson.asInt (FromJson.getO "rangeLength" j) + , text = FromJson.asString (FromJson.get "text" j) + } + ) js + | j => raise Fail ("Expected JSON array, got: " ^ Json.print j) + } + + type didSaveParams = { textDocument: textDocumentIdentifier } + fun parseDidSaveParams (params: Json.json): didSaveParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + (* , text = ... *) + } + type didCloseParams = { textDocument: textDocumentIdentifier } + fun parseDidCloseParams (params: Json.json): didCloseParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + } + type initializeParams = + { rootUri: documentUri option + , initializationOptions: Json.json } + fun parseInitializeParams (j: Json.json) = + { rootUri = + Option.map + parseDocumentUri + (FromJson.asOptionalString (FromJson.get "rootUri" j)) + , initializationOptions = FromJson.get "initializationOptions" j + } + type diagnostic = { range: range + (* code?: number | string *) + , severity: int (* 1 = error, 2 = warning, 3 = info, 4 = hint*) + , source: string + , message: string + (* relatedInformation?: DiagnosticRelatedInformation[]; *) + } + fun printDiagnostic (d: diagnostic): Json.json = + Json.Obj [ ("range", printRange (#range d)) + , ("severity", Json.Int (#severity d)) + , ("source", Json.String (#source d)) + , ("message", Json.String (#message d)) + ] + type publishDiagnosticsParams = { uri: documentUri + , diagnostics: diagnostic list + } + fun printPublishDiagnosticsParams (p: publishDiagnosticsParams): Json.json = + Json.Obj [ ("uri", Json.String (printDocumentUri (#uri p))) + , ("diagnostics", Json.Array (List.map printDiagnostic (#diagnostics p)))] + + type completionReq = + { textDocument: textDocumentIdentifier + , position: position + , context: { triggerCharacter: string option + , triggerKind: int (* 1 = Invoked = typing an identifier or manual invocation or API + 2 = TriggerCharacter + 3 = TriggerForIncompleteCompletions*)} option + } + fun parseCompletionReq (j: Json.json): completionReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" j) + , position = parsePosition (FromJson.get "position" j) + , context = case FromJson.getO "context" j of + NONE => NONE + | SOME ctx => SOME { triggerCharacter = Option.map FromJson.asString (FromJson.getO "triggerCharacter" ctx) + , triggerKind = FromJson.asInt (FromJson.get "triggerKind" ctx) + } + } + + datatype completionItemKind = Text | Method | Function | Constructor | Field | Variable | Class | Interface | Module | Property | Unit | Value | Enum | Keyword | Snippet | Color | File | Reference | Folder | EnumMember | Constant | Struct | Event | Operator | TypeParameter + fun completionItemKindToInt (a: completionItemKind) = + case a of + Text => 1 + | Method => 2 + | Function => 3 + | Constructor => 4 + | Field => 5 + | Variable => 6 + | Class => 7 + | Interface => 8 + | Module => 9 + | Property => 10 + | Unit => 11 + | Value => 12 + | Enum => 13 + | Keyword => 14 + | Snippet => 15 + | Color => 16 + | File => 17 + | Reference => 18 + | Folder => 19 + | EnumMember => 20 + | Constant => 21 + | Struct => 22 + | Event => 23 + | Operator => 24 + | TypeParameter => 25 + + type completionItem = { label: string + , kind: completionItemKind + , detail: string + } + type completionResp = { isIncomplete: bool + , items: completionItem list + } + + fun printCompletionItem (a: completionItem): Json.json = + Json.Obj [ ("label", Json.String (#label a)) + , ("kind", Json.Int (completionItemKindToInt (#kind a))) + , ("detail", Json.String (#detail a)) + ] + fun printCompletionResp (a: completionResp): Json.json = + Json.Obj [ ("isIncomplete", Json.Bool (#isIncomplete a)) + , (("items", Json.Array (List.map printCompletionItem (#items a))))] + + type initializeResponse = { capabilities: + { hoverProvider: bool + , completionProvider: {triggerCharacters: string list} option + , textDocumentSync: + { openClose: bool + , change: int (* 0 = None, 1 = Full, 2 = Incremental *) + , save: { includeText: bool } option + } + }} + fun printInitializeResponse (res: initializeResponse) = + Json.Obj [("capabilities", + let + val capabilities = #capabilities res + in + Json.Obj [ ("hoverProvider", Json.Bool (#hoverProvider capabilities)) + , ("completionProvider", case #completionProvider capabilities of + NONE => Json.Null + | SOME cp => Json.Obj [("triggerCharacters", Json.Array (List.map Json.String (#triggerCharacters cp)))] + ) + , ("textDocumentSync", + let + val textDocumentSync = #textDocumentSync capabilities + in + Json.Obj [ ("openClose", Json.Bool (#openClose textDocumentSync )) + , ("change", Json.Int (#change textDocumentSync)) + , ("save", case #save textDocumentSync of + NONE => Json.Null + | SOME save => Json.Obj [("includeText", Json.Bool (#includeText save) )])] + end + )] + end + )] + + datatype 'a result = + Success of 'a + | Error of (int * string) + + fun mapResult (f: 'a -> 'b) (a: 'a result): 'b result = + case a of + Success contents => Success (f contents) + | Error e => Error e + type toclient = { showMessage: string -> int -> unit + , publishDiagnostics: publishDiagnosticsParams -> unit } + type messageHandlers = + { initialize: initializeParams -> initializeResponse result + , shutdown: unit -> unit result + , textDocument_hover: toclient -> hoverReq -> hoverResp result + , textDocument_completion: completionReq -> completionResp result + } + + fun showMessage str typ = + let + val jsonToPrint = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") + , ("method", Json.String "window/showMessage") + , ("params", Json.Obj [ ("type", Json.Int typ) + , ("message", Json.String str)]) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + fun publishDiagnostics diags = + let + val jsonToPrint = Json.print ((Json.Obj [ ("jsonrpc", Json.String "2.0") + , ("method", Json.String "textDocument/publishDiagnostics") + , ("params", printPublishDiagnosticsParams diags) + ])) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} + + fun matchMessage + (requestMessage: {id: Json.json, method: string, params: Json.json}) + (handlers: messageHandlers) + : unit = + let + val result: Json.json result = + ((case #method requestMessage of + "initialize" => + mapResult + printInitializeResponse + ((#initialize handlers) + (parseInitializeParams (#params requestMessage))) + | "textDocument/hover" => + mapResult + printHoverResponse + ((#textDocument_hover handlers) + toclient + (parseHoverReq (#params requestMessage))) + | "textDocument/completion" => + mapResult + printCompletionResp + ((#textDocument_completion handlers) + (parseCompletionReq (#params requestMessage))) + | "shutdown" => + mapResult + (fn () => Json.Null) + ((#shutdown handlers) ()) + | "exit" => + OS.Process.exit OS.Process.success + | method => (debug ("Method not supported: " ^ method); + Error (~32601, "Method not supported: " ^ method))) + handle LspError (InternalError str) => Error (~32603, str) + | LspError ServerNotInitialized => Error (~32002, "Server not initialized") + | ex => Error (~32603, (General.exnMessage ex)) + ) + (* val () = (TextIO.output (TextIO.stdErr, "Got result: " ^ (case result of Success _ => "success\n" *) + (* | Error _ => "error\n")); TextIO.flushOut TextIO.stdErr) *) + in + case result of + Success j => + let + val jsonToPrint = + Json.print (Json.Obj [ ("id", #id requestMessage) + , ("jsonrpc", Json.String "2.0") + , ("result", j) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + | Error (i, err) => + let + val jsonToPrint = + Json.print (Json.Obj [ ("id", #id requestMessage) + , ("jsonrpc", Json.String "2.0") + , ("error", Json.Obj [ ("code", Json.Int i) + , ("message", Json.String err) + ]) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + end + + type notificationHandlers = + { initialized: unit -> unit + , textDocument_didOpen: (didOpenParams * toclient) -> unit + , textDocument_didChange: (didChangeParams * toclient) -> unit + , textDocument_didSave: (didSaveParams * toclient) -> unit + , textDocument_didClose: (didCloseParams * toclient) -> unit + } + fun matchNotification + (notification: {method: string, params: Json.json}) + (handlers: notificationHandlers) + = + (case #method notification of + "initialized" => (#initialized handlers) () + | "textDocument/didOpen" => (#textDocument_didOpen handlers) (parseDidOpenParams (#params notification), toclient) + | "textDocument/didChange" => (#textDocument_didChange handlers) (parseDidChangeParams (#params notification), toclient) + | "textDocument/didSave" => (#textDocument_didSave handlers) (parseDidSaveParams (#params notification), toclient) + | "textDocument/didClose" => (#textDocument_didClose handlers) (parseDidCloseParams (#params notification), toclient) + | m => debug ("Notification method not supported: " ^ m)) + handle LspError (InternalError str) => showMessage str 1 + | LspError ServerNotInitialized => showMessage "Server not initialized" 1 + | ex => showMessage (General.exnMessage ex) 1 + +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 1229d552..9042307a 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -43,14 +43,25 @@ fun parse_flags flag_info args = fn (flag1, _, _) => flag0 = flag1 end + fun normalizeArg arg = + case arg of + "-h" => "-help" + | "--h" => "-help" + | "--help" => "-help" + | _ => arg + fun loop [] : string list = [] | loop (arg :: args) = - if String.isPrefix "-" arg then - case List.find (search_pred arg) flag_info of - NONE => raise Fail ("Unknown flag "^arg^", see -help") - | SOME x => exec x args - else - arg :: loop args + let + val arg = normalizeArg arg + in + if String.isPrefix "-" arg then + case List.find (search_pred arg) flag_info of + NONE => raise Fail ("Unknown flag "^arg^", see -help") + | SOME x => exec x args + else + arg :: loop args + end and exec (_, ZERO f, _) args = (f (); loop args) @@ -96,6 +107,8 @@ fun usage flag_info = (* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *) +exception DaemonExit + fun oneRun args = let val timing = ref false @@ -156,7 +169,7 @@ fun oneRun args = ("print-cinclude", ZERO printCInclude, SOME "print directory of C headers and exit"), ("ccompiler", ONE ("<program>", Settings.setCCompiler), - SOME "set the C compiler to <program>"), + SOME "set the C compiler to <program>"), ("demo", ONE ("<prefix>", fn prefix => demo := SOME (prefix, false)), NONE), @@ -164,7 +177,7 @@ fun oneRun args = demo := SOME (prefix, true)), NONE), ("tutorial", set_true tutorial, - NONE), + SOME "render HTML tutorials from .ur source files"), ("protocol", ONE ("[http|cgi|fastcgi|static]", Settings.setProtocol), SOME "set server protocol"), @@ -175,7 +188,7 @@ fun oneRun args = ("dbms", ONE ("[sqlite|mysql|postgres]", Settings.setDbms), SOME "select database engine"), ("debug", call_true Settings.setDebug, - NONE), + SOME "save some intermediate C files"), ("verbose", ZERO (fn () => (Compiler.debug := true; Elaborate.verbose := true)), @@ -191,7 +204,8 @@ fun oneRun args = ("unifyMore", set_true Elaborate.unifyMore, SOME "continue unification before reporting type error"), ("dumpSource", set_true Compiler.dumpSource, - NONE), + SOME ("print source code of last intermediate program "^ + "if there is an error")), ("dumpVerboseSource", ZERO (fn () => (Compiler.dumpSource := true; ElabPrint.debug := true; @@ -205,22 +219,26 @@ fun oneRun args = SOME "serve JavaScript as <file>"), ("sql", ONE ("<file>", Settings.setSql o SOME), SOME "output sql script as <file>"), + ("endpoints", ONE ("<file>", Settings.setEndpoints o SOME), + SOME "output exposed URL endpoints in JSON as <file>"), ("static", call_true Settings.setStaticLinking, SOME "enable static linking"), ("stop", ONE ("<phase>", Compiler.setStop), SOME "stop compilation after <phase>"), ("path", TWO ("<name>", "<path>", Compiler.addPath), - NONE), + SOME ("set path variable <name> to <path> for use in "^ + ".urp files")), ("root", TWO ("<name>", "<path>", (fn (name, path) => Compiler.addModuleRoot (path, name))), - NONE), + SOME "prefix names of modules found in <path> with <name>"), ("boot", ZERO (fn () => (Compiler.enableBoot (); Settings.setBootLinking true)), - NONE), + SOME ("run from build tree and generate statically linked "^ + "executables ")), ("sigfile", ONE ("<file>", Settings.setSigFile o SOME), - NONE), + SOME "search for cryptographic signing keys in <file>"), ("iflow", set_true Compiler.doIflow, NONE), ("sqlcache", call_true Settings.setSqlcache, @@ -229,17 +247,19 @@ fun oneRun args = NONE), ("moduleOf", ONE ("<file>", printModuleOf), SOME "print module name of <file> and exit"), + ("startLspServer", ZERO Lsp.startServer, SOME "Start Language Server Protocol server"), ("noEmacs", set_true Demo.noEmacs, NONE), ("limit", TWO ("<class>", "<num>", add_class), - NONE), + SOME "set resource usage limit for <class> to <num>"), ("explainEmbed", set_true JsComp.explainEmbed, SOME ("explain errors about embedding of server-side "^ "values in client code")) ] val () = case args of - ["daemon", "stop"] => OS.Process.exit OS.Process.success + ["daemon", "stop"] => (OS.FileSys.remove socket handle OS.SysErr _ => (); + raise DaemonExit) | _ => () val sources = parse_flags (flag_info ()) args @@ -274,7 +294,7 @@ fun oneRun args = else OS.Process.failure | (_, _, true) => (Tutorial.make job; - OS.Process.success) + OS.Process.success) | _ => if !tc then (Compiler.check Compiler.toElaborate job; @@ -302,127 +322,138 @@ fun send (sock, s) = send (sock, String.extract (s, n, NONE)) end -val () = (Globals.setResetTime (); - case CommandLine.arguments () of - ["daemon", "start"] => - (case Posix.Process.fork () of - SOME _ => () - | NONE => - let - val () = Elaborate.incremental := true - val listen = UnixSock.Strm.socket () - - fun loop () = - let - val (sock, _) = Socket.accept listen - - fun loop' (buf, args) = - let - val s = if CharVector.exists (fn ch => ch = #"\n") buf then - "" - else - MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly (Socket.recvVec (sock, 1024)))) - val s = buf ^ s - val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s) - in - if Substring.isEmpty after then - loop' (s, args) - else - let - val cmd = Substring.string befor - val rest = Substring.string (Substring.slice (after, 1, NONE)) - in - case cmd of - "" => - (case args of - ["stop", "daemon"] => - (((Socket.close listen; - OS.FileSys.remove socket) handle OS.SysErr _ => ()); - OS.Process.exit OS.Process.success) - | _ => - let - val success = (oneRun (rev args)) - handle ex => (print "unhandled exception:\n"; - print (General.exnMessage ex ^ "\n"); - OS.Process.failure) - in - TextIO.flushOut TextIO.stdOut; - TextIO.flushOut TextIO.stdErr; - send (sock, if OS.Process.isSuccess success then - "\001" - else - "\002") - end) - | _ => loop' (rest, cmd :: args) - end - end handle OS.SysErr _ => () - - fun redirect old = - Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)), - new = old} - - val oldStdout = Posix.IO.dup Posix.FileSys.stdout - val oldStderr = Posix.IO.dup Posix.FileSys.stderr - in - (* Redirect the daemon's output to the socket. *) - redirect Posix.FileSys.stdout; - redirect Posix.FileSys.stderr; - - loop' ("", []); - Socket.close sock; - - Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout}; - Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr}; - Posix.IO.close oldStdout; - Posix.IO.close oldStderr; - - Settings.reset (); - MLton.GC.pack (); - loop () - end - in - OS.Process.atExit (fn () => OS.FileSys.remove socket); - Socket.bind (listen, UnixSock.toAddr socket); - Socket.listen (listen, 1); - loop () - end) - | args => +fun startDaemon () = + if OS.FileSys.access (socket, []) then + (print ("It looks like a daemon is already listening in this directory,\n" + ^ "though it's possible a daemon died without cleaning up its socket.\n"); + OS.Process.exit OS.Process.failure) + else case Posix.Process.fork () of + SOME _ => () + | NONE => let - val sock = UnixSock.Strm.socket () + val () = Elaborate.incremental := true + val listen = UnixSock.Strm.socket () - fun wait () = + fun loop () = let - val v = Socket.recvVec (sock, 1024) - in - if Word8Vector.length v = 0 then - OS.Process.failure - else + val (sock, _) = Socket.accept listen + + fun loop' (buf, args) = let - val s = MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly v)) - val last = Word8Vector.sub (v, Word8Vector.length v - 1) - val (rc, s) = if last = Word8.fromInt 1 then - (SOME OS.Process.success, String.substring (s, 0, size s - 1)) - else if last = Word8.fromInt 2 then - (SOME OS.Process.failure, String.substring (s, 0, size s - 1)) - else - (NONE, s) + val s = if CharVector.exists (fn ch => ch = #"\n") buf then + "" + else + MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly (Socket.recvVec (sock, 1024)))) + val s = buf ^ s + val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s) in - print s; - case rc of - NONE => wait () - | SOME rc => rc - end - end handle OS.SysErr _ => OS.Process.failure + if Substring.isEmpty after then + loop' (s, args) + else + let + val cmd = Substring.string befor + val rest = Substring.string (Substring.slice (after, 1, NONE)) + in + case cmd of + "" => + (case args of + ["stop", "daemon"] => + (((Socket.close listen; + OS.FileSys.remove socket) handle OS.SysErr _ => ()); + OS.Process.exit OS.Process.success) + | _ => + let + val success = (oneRun (rev args) handle DaemonExit => OS.Process.exit OS.Process.success) + handle ex => (print "unhandled exception:\n"; + print (General.exnMessage ex ^ "\n"); + OS.Process.failure) + in + TextIO.flushOut TextIO.stdOut; + TextIO.flushOut TextIO.stdErr; + send (sock, if OS.Process.isSuccess success then + "\001" + else + "\002") + end) + | _ => loop' (rest, cmd :: args) + end + end handle OS.SysErr _ => () + + fun redirect old = + Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)), + new = old} + + val oldStdout = Posix.IO.dup Posix.FileSys.stdout + val oldStderr = Posix.IO.dup Posix.FileSys.stderr + in + (* Redirect the daemon's output to the socket. *) + redirect Posix.FileSys.stdout; + redirect Posix.FileSys.stderr; + + loop' ("", []); + Socket.close sock; + + Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout}; + Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr}; + Posix.IO.close oldStdout; + Posix.IO.close oldStderr; + + Settings.reset (); + MLton.GC.pack (); + loop () + end in - if Socket.connectNB (sock, UnixSock.toAddr socket) - orelse not (List.null (#wrs (Socket.select {rds = [], - wrs = [Socket.sockDesc sock], - exs = [], - timeout = SOME (Time.fromSeconds 1)}))) then - (app (fn arg => send (sock, arg ^ "\n")) args; - send (sock, "\n"); - OS.Process.exit (wait ())) - else - (OS.FileSys.remove socket; - raise OS.SysErr ("", NONE)) - end handle OS.SysErr _ => OS.Process.exit (oneRun args)) + OS.Process.atExit (fn () => OS.FileSys.remove socket); + Socket.bind (listen, UnixSock.toAddr socket); + Socket.listen (listen, 1); + loop () + end + +fun oneCommandLine args = + let + val sock = UnixSock.Strm.socket () + + fun wait () = + let + val v = Socket.recvVec (sock, 1024) + in + if Word8Vector.length v = 0 then + OS.Process.failure + else + let + val s = MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly v)) + val last = Word8Vector.sub (v, Word8Vector.length v - 1) + val (rc, s) = if last = Word8.fromInt 1 then + (SOME OS.Process.success, String.substring (s, 0, size s - 1)) + else if last = Word8.fromInt 2 then + (SOME OS.Process.failure, String.substring (s, 0, size s - 1)) + else + (NONE, s) + in + print s; + case rc of + NONE => wait () + | SOME rc => rc + end + end handle OS.SysErr _ => OS.Process.failure + in + if Socket.connectNB (sock, UnixSock.toAddr socket) + orelse not (List.null (#wrs (Socket.select {rds = [], + wrs = [Socket.sockDesc sock], + exs = [], + timeout = SOME (Time.fromSeconds 1)}))) then + (app (fn arg => send (sock, arg ^ "\n")) args; + send (sock, "\n"); + wait ()) + else + (OS.FileSys.remove socket; + raise OS.SysErr ("", NONE)) + end handle OS.SysErr _ => oneRun args handle DaemonExit => OS.Process.success + +val () = (Globals.setResetTime (); + case CommandLine.arguments () of + ["daemon", "start"] => startDaemon () + | ["daemon", "restart"] => + (ignore (oneCommandLine ["daemon", "stop"]); + startDaemon ()) + | args => OS.Process.exit (oneCommandLine args)) diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml index 8d7edd15..122d3415 100644 --- a/src/marshalcheck.sml +++ b/src/marshalcheck.sml @@ -71,62 +71,87 @@ fun check file = | _ => st fun sins cmap = U.Con.fold {kind = kind, con = con cmap} PS.empty + + fun decl (d, (cmap, emap)) = + case d of + DCon (_, n, _, c) => (IM.insert (cmap, n, sins cmap c), emap) + | DDatatype dts => + (foldl (fn ((_, n, _, xncs), cmap) => + IM.insert (cmap, n, foldl (fn ((_, _, co), s) => + case co of + NONE => s + | SOME c => PS.union (s, sins cmap c)) + PS.empty xncs)) cmap dts, + emap) + + | DVal (_, n, t, _, tag) => (cmap, IM.insert (emap, n, (t, tag))) + | DValRec vis => (cmap, + foldl (fn ((_, n, t, _, tag), emap) => IM.insert (emap, n, (t, tag))) + emap vis) + + | DExport (_, n, _) => + (case IM.find (emap, n) of + NONE => raise Fail "MarshalCheck: Unknown export" + | SOME (t, tag) => + let + fun makeS (t, _) = + case t of + TFun (dom, ran) => + (case #1 dom of + CFfi ("Basis", "postBody") => makeS ran + | CApp ((CFfi ("Basis", "option"), _), (CFfi ("Basis", "queryString"), _)) => makeS ran + | _ => PS.union (sins cmap dom, makeS ran)) + | _ => PS.empty + val s = makeS t + in + if PS.isEmpty s then + () + else + E.error ("Input to exported function '" + ^ tag ^ "' involves one or more types that are disallowed for page handler inputs: " + ^ PS.toString s); + (cmap, emap) + end) + + | DCookie (_, _, t, tag) => + let + val s = sins cmap t + in + if PS.isEmpty s then + () + else + E.error ("Cookie '" ^ tag ^ "' includes one or more types that are disallowed for cookies: " + ^ PS.toString s); + (cmap, emap) + end + + | _ => (cmap, emap) + + fun checkSins (cmap, _) t = + let + val s = sins cmap t + in + if PS.isEmpty s then + () + else + E.error ("Not allowed to [de]serialize a value involving one or more disallowed types: " ^ PS.toString s) + end + + fun exp (e, s) = + case e of + ECApp ((EFfi ("Basis", "serialize"), _), t) => + (checkSins s t; s) + | ECApp ((EFfi ("Basis", "deserialize"), _), t) => + (checkSins s t; s) + | _ => s + + fun passthrough (_, s) = s in - ignore (foldl (fn ((d, _), (cmap, emap)) => - case d of - DCon (_, n, _, c) => (IM.insert (cmap, n, sins cmap c), emap) - | DDatatype dts => - (foldl (fn ((_, n, _, xncs), cmap) => - IM.insert (cmap, n, foldl (fn ((_, _, co), s) => - case co of - NONE => s - | SOME c => PS.union (s, sins cmap c)) - PS.empty xncs)) cmap dts, - emap) - - | DVal (_, n, t, _, tag) => (cmap, IM.insert (emap, n, (t, tag))) - | DValRec vis => (cmap, - foldl (fn ((_, n, t, _, tag), emap) => IM.insert (emap, n, (t, tag))) - emap vis) - - | DExport (_, n, _) => - (case IM.find (emap, n) of - NONE => raise Fail "MarshalCheck: Unknown export" - | SOME (t, tag) => - let - fun makeS (t, _) = - case t of - TFun (dom, ran) => - (case #1 dom of - CFfi ("Basis", "postBody") => makeS ran - | CApp ((CFfi ("Basis", "option"), _), (CFfi ("Basis", "queryString"), _)) => makeS ran - | _ => PS.union (sins cmap dom, makeS ran)) - | _ => PS.empty - val s = makeS t - in - if PS.isEmpty s then - () - else - E.error ("Input to exported function '" - ^ tag ^ "' involves one or more types that are disallowed for page handler inputs: " - ^ PS.toString s); - (cmap, emap) - end) - - | DCookie (_, _, t, tag) => - let - val s = sins cmap t - in - if PS.isEmpty s then - () - else - E.error ("Cookie '" ^ tag ^ "' includes one or more types that are disallowed for cookies: " - ^ PS.toString s); - (cmap, emap) - end - - | _ => (cmap, emap)) - (IM.empty, IM.empty) file) + ignore (U.File.fold {kind = passthrough, + con = passthrough, + exp = exp, + decl = decl} + (IM.empty, IM.empty) file) end end diff --git a/src/mod_db.sig b/src/mod_db.sig index 8f78f2c2..fb396603 100644 --- a/src/mod_db.sig +++ b/src/mod_db.sig @@ -30,12 +30,15 @@ signature MOD_DB = sig val reset : unit -> unit - val insert : Elab.decl * Time.time -> unit + val insert : Elab.decl * Time.time * bool (* hasErrors *) -> unit (* Here's a declaration, including the modification timestamp of the file it came from. * We might invalidate other declarations that depend on this one, if the timestamp has changed. *) val lookup : Source.decl -> Elab.decl option + val lookupModAndDepsIncludingErrored: + string -> (Elab.decl * Elab.decl list) option + (* Allow undoing to snapshots after failed compilations. *) val snapshot : unit -> unit val revert : unit -> unit diff --git a/src/mod_db.sml b/src/mod_db.sml index 2d6b285b..c821a0bb 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -42,7 +42,9 @@ structure IM = IntBinaryMap type oneMod = {Decl : decl, When : Time.time, - Deps : SS.set} + Deps : SS.set, + HasErrors: bool (* We're saving modules with errors so tooling can find them *) + } val byName = ref (SM.empty : oneMod SM.map) val byId = ref (IM.empty : string IM.map) @@ -50,7 +52,39 @@ val byId = ref (IM.empty : string IM.map) fun reset () = (byName := SM.empty; byId := IM.empty) -fun insert (d, tm) = +(* For debug purposes *) +fun printByName (bn: oneMod SM.map): unit = + (TextIO.print ("Contents of ModDb.byName: \n"); + List.app (fn tup => + let + val name = #1 tup + val m = #2 tup + val renderedDeps = + String.concatWith ", " (SS.listItems (#Deps m)) + val renderedMod = + " " ^ name + ^ ". Stored at : " ^ Time.toString (#When m) + ^", HasErrors: " ^ Bool.toString (#HasErrors m) + ^". Deps: " ^ renderedDeps ^"\n" + in + TextIO.print renderedMod + end) + (SM.listItemsi bn)) + +fun dContainsUndeterminedUnif d = + ElabUtil.Decl.exists + {kind = fn _ => false, + con = fn _ => false, + exp = fn e => case e of + EUnif (ref NONE) => true + | _ => false, + sgn_item = fn _ => false, + sgn = fn _ => false, + str = fn _ => false, + decl = fn _ => false} + d + +fun insert (d, tm, hasErrors) = let val xn = case #1 d of @@ -62,10 +96,16 @@ fun insert (d, tm) = NONE => () | SOME (x, n) => let + (* Keep module when it's file didn't change and it was OK before *) val skipIt = case SM.find (!byName, x) of NONE => false | SOME r => #When r = tm + andalso not (#HasErrors r) + (* We save results of error'd compiler passes *) + (* so modules that still have undetermined unif variables *) + (* should not be reused since those are unsuccessfully compiled *) + andalso not (dContainsUndeterminedUnif (#Decl r)) in if skipIt then () @@ -73,7 +113,19 @@ fun insert (d, tm) = let fun doMod (n', deps) = case IM.find (!byId, n') of - NONE => deps + NONE => + ( + (* TextIO.print ("MISSED_DEP: " ^ Int.toString n' ^"\n"); *) + deps) + (* raise Fail ("ModDb: Trying to make dep tree but couldn't find module " ^ Int.toString n') *) + (* I feel like this should throw, but the dependency searching algorithm *) + (* is not 100% precise. I encountered problems in json.urs: *) + (* datatype r = Rec of M.t r *) + (* M is the structure passed to the Recursive functor, so this is not an external dependency *) + (* I'm just not sure how to filter these out yet *) + (* I still think this should throw: *) + (* Trying to add a dep for a module but can't find the dep... *) + (* That will always cause a hole in the dependency tree and cause problems down the line *) | SOME x' => SS.union (deps, SS.add (case SM.find (!byName, x') of @@ -118,8 +170,11 @@ fun insert (d, tm) = x, {Decl = d, When = tm, - Deps = deps}); + Deps = deps, + HasErrors = hasErrors + }); byId := IM.insert (!byId, n, x) + (* printByName (!byName) *) end end end @@ -130,7 +185,7 @@ fun lookup (d : Source.decl) = (case SM.find (!byName, x) of NONE => NONE | SOME r => - if tm = #When r then + if tm = #When r andalso not (#HasErrors r) andalso not (dContainsUndeterminedUnif (#Decl r)) then SOME (#Decl r) else NONE) @@ -138,12 +193,26 @@ fun lookup (d : Source.decl) = (case SM.find (!byName, x) of NONE => NONE | SOME r => - if tm = #When r then + if tm = #When r andalso not (#HasErrors r) andalso not (dContainsUndeterminedUnif (#Decl r)) then SOME (#Decl r) else NONE) | _ => NONE +fun lookupModAndDepsIncludingErrored name = + case SM.find (!byName, name) of + NONE => NONE + | SOME m => + let + val deps = SS.listItems (#Deps m) + (* Clumsy way of adding Basis and Top without adding doubles *) + val deps = List.filter (fn x => x <> "Basis" andalso x <> "Top") deps + val deps = ["Basis", "Top"] @ deps + val foundDepModules = List.mapPartial (fn d => SM.find (!byName, d)) deps + in + SOME (#Decl m, List.map (fn a => #Decl a) foundDepModules) + end + val byNameBackup = ref (!byName) val byIdBackup = ref (!byId) diff --git a/src/mono.sml b/src/mono.sml index cdadded5..754fe283 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -142,7 +142,7 @@ datatype decl' = | DTable of string * (string * typ) list * exp * exp | DSequence of string | DView of string * (string * typ) list * exp - | DDatabase of {name : string, expunge : int, initialize : int} + | DDatabase of {name : string, expunge : int, initialize : int, usesSimilar : bool} | DJavaScript of string diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml index e64207cd..9cb14400 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -165,12 +165,12 @@ fun fooifyExpWithExceptions fk lookupENamed lookupDatatype = end | _ => case t of - TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "_")), loc), fm) | TFfi (m, x) => (if Settings.mayClientToServer (m, x) then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) else raise CantPass (fm, tAll)) - | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "_")), loc), fm) | TRecord ((x, t) :: xts) => let val (se, fm) = fooify fm ((EField (e, x), loc), t) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 40b865b0..7e737e44 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -66,9 +66,9 @@ val htmlifyString = String.translate (fn #"<" => "<" fun htmlifySpecialChar ch = "&#" ^ Int.toString (ord ch) ^ ";" -fun hexIt ch = +fun hexPad c = let - val s = Int.fmt StringCvt.HEX (ord ch) + val s = Int.fmt StringCvt.HEX c in case size s of 0 => "00" @@ -76,6 +76,54 @@ fun hexIt ch = | _ => s end +fun rsh a b = + Int.fromLarge (IntInf.~>>(IntInf.fromInt a, Word.fromInt b)) + +fun orb a b = + Int.fromLarge (IntInf.orb(IntInf.fromInt a, IntInf.fromInt b)) + +fun andb a b = + Int.fromLarge (IntInf.andb(IntInf.fromInt a, IntInf.fromInt b)) + + +fun hexIt ch = + let + val c = ord ch + in + if (c <= 0x7f) then + hexPad c + else + ((if (c <= 0x7fff) then + hexPad (orb (rsh c 6) 0xc0) + else + (if (c <= 0xffff) then + hexPad (orb (rsh c 12) 0xe0) + else + hexPad (orb (rsh c 18) 0xf0) + ^ hexPad (orb (andb (rsh c 12) 0x3f) 0x80) + ) + ^ hexPad (orb (andb (rsh c 6) 0x3f) 0x80)) + ) ^ hexPad (orb (andb c 0x3f) 0x80) + end + +fun urlifyCharAux ch = + case ch of + #" " => "+" + | _ => + if ord ch = 0 then + "_" + else + if Char.isAlphaNum ch then + str ch + else + "." ^ hexIt ch + +fun urlifyChar c = + case c of + #"_" => "_" ^ urlifyCharAux c + | _ => urlifyCharAux c + + fun urlifyString s = case s of "" => "_" @@ -84,11 +132,7 @@ fun urlifyString s = "_" else "") - ^ String.translate (fn #" " => "+" - | ch => if Char.isAlphaNum ch then - str ch - else - "." ^ hexIt ch) s + ^ String.translate urlifyCharAux s fun sqlifyInt n = #p_cast (Settings.currentDbms ()) (attrifyInt n, Settings.Int) @@ -117,7 +161,7 @@ fun unAs s = doChars (String.explode s, []) end -fun checkUrl s = CharVector.all Char.isGraph s andalso Settings.checkUrl s +fun checkUrl s = CharVector.all Char.isGraph s andalso (s = "#" orelse Settings.checkUrl s) val checkData = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #"-") @@ -349,6 +393,13 @@ fun exp e = | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) => EFfiApp ("Basis", "urlifyString_w", [e]) + | EFfiApp ("Basis", "urlifyChar", [((EPrim (Prim.Char c), _), _)]) => + EPrim (Prim.String (Prim.Normal, urlifyChar c)) + | EWrite (EFfiApp ("Basis", "urlifyChar", [((EPrim (Prim.Char c), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Normal, urlifyChar c)), loc) + | EWrite (EFfiApp ("Basis", "urlifyChar", [e]), _) => + EFfiApp ("Basis", "urlifyChar_w", [e]) + | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]) => EPrim (Prim.String (Prim.Normal, "1")) | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]) => diff --git a/src/mono_print.sml b/src/mono_print.sml index a3b55ec0..1114a4f0 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -509,16 +509,17 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_exp env e, string "*)"] - | DDatabase {name, expunge, initialize} => box [string "database", - space, - string name, - space, - string "(", - p_enamed env expunge, - string ",", - space, - p_enamed env initialize, - string ")"] + | DDatabase {name, expunge, initialize, ...} => + box [string "database", + space, + string name, + space, + string "(", + p_enamed env expunge, + string ",", + space, + p_enamed env initialize, + string ")"] | DJavaScript s => box [string "JavaScript(", string s, string ")"] diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 5bcb6f57..c3c9da98 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -597,8 +597,7 @@ fun reduce' (file : file) = ((*Print.prefaces "trySub" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*) case t of - (TFfi ("Basis", "string"), _) => doSub () - | (TSignal _, _) => e + (TSignal _, _) => e | _ => case e' of (ECase _, _) => e diff --git a/src/monoize.sml b/src/monoize.sml index 11c6ea31..22b4e0e7 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -50,6 +50,38 @@ structure RM = BinaryMapFn(struct (L'.TRecord r2, E.dummySpan)) end) +val uses_similar = ref false + +local + val url_prefixes = ref [] +in + +fun reset () = (url_prefixes := []; uses_similar := false) + +fun addPrefix prefix = + let + fun isPrefix s1 s2 = + String.isPrefix s1 s2 + andalso (size s1 = size s2 + orelse String.sub (s2, size s1) = #"/") + in + if List.exists (fn prefix' => + let + fun tryOne prefix' prefix = + isPrefix prefix' prefix + andalso (ErrorMsg.error ("Conflicting URL prefixes for page handlers: \"" ^ prefix' ^ "\" is a prefix of \"" ^ prefix ^ "\"."); + true) + in + tryOne prefix' prefix + orelse tryOne prefix prefix' + end) (!url_prefixes) then + () + else + url_prefixes := prefix :: !url_prefixes + end + +end + val nextPvar = MonoFooify.nextPvar val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) val pvarDefs = MonoFooify.pvarDefs @@ -325,6 +357,8 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_ufunc"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_bfunc"), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) => @@ -1339,7 +1373,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then - "(767)" + "(255)" else "")) unique)))), loc), @@ -1383,7 +1417,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then - "(767)" + "(255)" else "")) unique) ^ ")"), @@ -1540,17 +1574,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfiApp ("Basis", "dml", [(e, _)]) => let + val string = (L'.TFfi ("Basis", "string"), loc) val (e, fm) = monoExp (env, st, fm) e in - ((L'.EDml (e, L'.Error), loc), + ((L'.ECase (e, + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + (L'.ERecord [], loc)), + ((L'.PVar ("cmd", string), loc), + (L'.EDml ((L'.ERel 0, loc), L'.Error), loc))], + {disc = string, + result = (L'.TRecord [], loc)}), loc), fm) end | L.EFfiApp ("Basis", "tryDml", [(e, _)]) => let + val string = (L'.TFfi ("Basis", "string"), loc) val (e, fm) = monoExp (env, st, fm) e in - ((L'.EDml (e, L'.None), loc), + ((L'.ECase (e, + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + (L'.ERecord [], loc)), + ((L'.PVar ("cmd", string), loc), + (L'.EDml ((L'.ERel 0, loc), L'.None), loc))], + {disc = string, + result = (L'.TRecord [], loc)}), loc), fm) end @@ -1579,7 +1627,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) => (case monoType env (L.TRecord changed, loc) of - (L'.TRecord changed, _) => + (L'.TRecord [], _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val rt = (L'.TRecord [], loc) + in + ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("tab", s, (L'.TFun (s, s), loc), + (L'.EAbs ("e", s, s, + str ""), loc)), loc)), loc), + fm) + end + | (L'.TRecord changed, _) => let val s = (L'.TFfi ("Basis", "string"), loc) val changed = map (fn (x, _) => (x, s)) changed @@ -2638,6 +2697,40 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) => ((L'.EFfi ("Basis", "sql_known"), loc), fm) + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_bfunc"), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", s, (L'.TFun (s, s), loc), + (L'.EAbs ("x1", s, s, + (L'.EAbs ("x2", s, s, + strcat [(L'.ERel 2, loc), + str "(", + (L'.ERel 1, loc), + str ",", + (L'.ERel 0, loc), + str ")"]), loc)), loc)), loc), + fm) + end + | L.EFfi ("Basis", "sql_similarity") => + ((case #supportsSimilar (Settings.currentDbms ()) of + NONE => ErrorMsg.errorAt loc "The DBMS you've selected doesn't support SIMILAR." + | _ => ()); + uses_similar := true; + (str "similarity", fm)) + | (L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -3953,6 +4046,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc)), loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "unsafeSerializedToString"), _), _) => + let + val t = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("v", t, t, (L'.ERel 0, loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "unsafeSerializedFromString"), _), _) => + let + val t = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("v", t, t, (L'.ERel 0, loc)), loc), + fm) + end | L.EFfiApp ("Basis", "url", [(e, _)]) => let @@ -4194,6 +4301,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = | L.DExport (ek, n, b) => let val (_, t, _, s) = Env.lookupENamed env n + val () = addPrefix s fun unwind (t, args) = case #1 t of @@ -4353,6 +4461,7 @@ datatype expungable = Client | Channel fun monoize env file = let + val () = reset () val () = pvars := RM.empty (* Calculate which exported functions need cookie signature protection *) @@ -4522,7 +4631,8 @@ fun monoize env file = in (env, Fm.enter fm, (L'.DDatabase {name = s, expunge = nExp, - initialize = nIni}, loc) + initialize = nIni, + usesSimilar = false}, loc) :: (dExp, loc) :: (dIni, loc) :: ds) @@ -4546,6 +4656,12 @@ fun monoize env file = | _ => ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds))) (env, Fm.empty mname, []) file + val ds = map (fn (L'.DDatabase r, loc) => + (L'.DDatabase {name = #name r, + expunge = #expunge r, + initialize = #initialize r, + usesSimilar = !uses_similar}, loc) + | x => x) ds val monoFile = (rev ds, []) in pvars := RM.empty; diff --git a/src/mysql.sml b/src/mysql.sml index e7cad84e..74954c0f 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1602,14 +1602,17 @@ val () = addDbms {name = "mysql", textKeysNeedLengths = true, supportsNextval = false, supportsNestedPrepared = false, - sqlPrefix = "SET storage_engine=InnoDB;\n\n", + sqlPrefix = "", supportsOctetLength = true, trueString = "TRUE", falseString = "FALSE", onlyUnion = true, nestedRelops = false, windowFunctions = false, + requiresTimestampDefaults = true, supportsIsDistinctFrom = true, - supportsSHA512 = false} + supportsSHA512 = SOME {InitializeDb = "", + GenerateHash = fn name => "SHA2(" ^ name ^ ", 512)"}, + supportsSimilar = NONE} end diff --git a/src/postgres.sml b/src/postgres.sml index 2b6bee8c..3e53ed77 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -1153,8 +1153,11 @@ val () = addDbms {name = "postgres", onlyUnion = false, nestedRelops = true, windowFunctions = true, + requiresTimestampDefaults = false, supportsIsDistinctFrom = true, - supportsSHA512 = true} + supportsSHA512 = SOME {InitializeDb = "CREATE EXTENSION IF NOT EXISTS pgcrypto;", + GenerateHash = fn name => "DIGEST(" ^ name ^ ", 'sha512')"}, + supportsSimilar = SOME {InitializeDb = "CREATE EXTENSION IF NOT EXISTS pg_trgm;"}} val () = setDbms "postgres" diff --git a/src/prefix.cm b/src/prefix.cm index 2e71d073..eab0bf71 100644 --- a/src/prefix.cm +++ b/src/prefix.cm @@ -4,4 +4,6 @@ $/basis.cm $/smlnj-lib.cm $smlnj/ml-yacc/ml-yacc-lib.cm $/pp-lib.cm +$(SRC)/bg_thread.sig +$(SRC)/bg_thread.dummy.sml diff --git a/src/prefix.mlb b/src/prefix.mlb index 6a510481..13122fcf 100644 --- a/src/prefix.mlb +++ b/src/prefix.mlb @@ -3,5 +3,8 @@ local $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb $(SML_LIB)/smlnj-lib/PP/pp-lib.mlb + $(SML_LIB)/basis/mlton.mlb + $(SRC)/bg_thread.sig + $(SRC)/bg_thread.mlton.sml in diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 06f49fef..aee8e7a9 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -54,6 +54,14 @@ val deKnown = List.filter (fn Known _ => false | KnownC _ => false | _ => true) +fun p_env_item ei = + Print.PD.string (case ei of + Unknown => "?" + | Known _ => "K" + | UnknownC => "C?" + | KnownC _ => "CK" + | Lift _ => "^") + datatype result = Yes of env | No | Maybe fun match (env, p : pat, e : exp) = @@ -124,7 +132,8 @@ fun match (env, p : pat, e : exp) = end fun con env (all as (c, loc)) = - ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*) + ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all), + ("env", Print.p_list p_env_item env)];*) case c of TFun (c1, c2) => (TFun (con env c1, con env c2), loc) | TCFun (x, k, c2) => (TCFun (x, k, con (UnknownC :: env) c2), loc) @@ -139,7 +148,7 @@ fun con env (all as (c, loc)) = | Unknown :: rest => find (n', rest, nudge, liftC) | Known _ :: rest => find (n', rest, nudge, liftC) | Lift (liftC', _) :: rest => find (n', rest, nudge + liftC', - liftC + liftC') + liftC + liftC') | UnknownC :: rest => if n' = 0 then (CRel (n + nudge), loc) @@ -228,154 +237,156 @@ fun patCon pc = kind = kind} fun exp env (all as (e, loc)) = - case e of - EPrim _ => all - | ERel n => - let - fun find (n', env, nudge, liftC, liftE) = - case env of - [] => (ERel (n + nudge), loc) - | Lift (liftC', liftE') :: rest => find (n', rest, nudge + liftE', liftC + liftC', liftE + liftE') - | UnknownC :: rest => find (n', rest, nudge, liftC + 1, liftE) - | KnownC _ :: rest => find (n', rest, nudge, liftC, liftE) - | Unknown :: rest => - if n' = 0 then - (ERel (n + nudge), loc) - else - find (n' - 1, rest, nudge, liftC, liftE + 1) - | Known e :: rest => - if n' = 0 then - ((*print "SUBSTITUTING\n";*) - exp (Lift (liftC, liftE) :: rest) e) - else - find (n' - 1, rest, nudge - 1, liftC, liftE) - in - find (n, env, 0, 0, 0) - end - | ENamed _ => all - | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, map (con env) cs, Option.map (exp env) eo), loc) - | EFfi _ => all - | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc) - - | EApp (e1, e2) => - let - val e1 = exp env e1 - val e2 = exp env e2 - in - case #1 e1 of - EAbs (_, _, _, b) => exp (Known e2 :: deKnown env) b - | _ => (EApp (e1, e2), loc) - end - - | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (Unknown :: env) e), loc) - - | ECApp (e, c) => - let - val e = exp env e - val c = con env c - in - case #1 e of - ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b - | _ => (ECApp (e, c), loc) - end - - | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc) - - | EKApp (e, k) => (EKApp (exp env e, k), loc) - | EKAbs (x, e) => (EKAbs (x, exp env e), loc) - - | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc) - | EField (e, c, {field = f, rest = r}) => - let - val e = exp env e - val c = con env c - - fun default () = (EField (e, c, {field = con env f, rest = con env r}), loc) - in - case (#1 e, #1 c) of - (ERecord xcs, CName x) => - (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of - NONE => default () - | SOME (_, e, _) => e) - | _ => default () - end - - | EConcat (e1, c1, e2, c2) => (EConcat (exp env e1, con env c1, exp env e2, con env c2), loc) - | ECut (e, c, {field = f, rest = r}) => (ECut (exp env e, - con env c, - {field = con env f, rest = con env r}), loc) - | ECutMulti (e, c, {rest = r}) => (ECutMulti (exp env e, con env c, {rest = con env r}), loc) - - | ECase (e, pes, {disc = d, result = r}) => - let - val others = {disc = con env d, result = con env r} - - fun patBinds (p, _) = - case p of - PVar _ => 1 - | PPrim _ => 0 - | PCon (_, _, _, NONE) => 0 - | PCon (_, _, _, SOME p) => patBinds p - | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts - - fun pat (all as (p, loc)) = - case p of - PVar (x, t) => (PVar (x, con env t), loc) - | PPrim _ => all - | PCon (dk, pc, cs, po) => - (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) - | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc) - - fun push () = - (ECase (exp env e, - map (fn (p, e) => (pat p, - exp (List.tabulate (patBinds p, - fn _ => Unknown) @ env) e)) - pes, others), loc) - - fun search pes = - case pes of - [] => push () - | (p, body) :: pes => - case match (env, p, e) of - No => search pes - | Maybe => push () - | Yes env' => exp env' body - in - search pes - end - - | EWrite e => (EWrite (exp env e), loc) - | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) - - | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (Unknown :: env) e2), loc) - - | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc) + ((*Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all)];*) + case e of + EPrim _ => all + | ERel n => + let + fun find (n', env, nudge, liftC, liftE) = + case env of + [] => (ERel (n + nudge), loc) + | Lift (liftC', liftE') :: rest => find (n', rest, nudge + liftE', liftC + liftC', liftE + liftE') + | UnknownC :: rest => find (n', rest, nudge, liftC + 1, liftE) + | KnownC _ :: rest => find (n', rest, nudge, liftC, liftE) + | Unknown :: rest => + if n' = 0 then + (ERel (n + nudge), loc) + else + find (n' - 1, rest, nudge, liftC, liftE + 1) + | Known e :: rest => + if n' = 0 then + ((*print "SUBSTITUTING\n";*) + exp (Lift (liftC, liftE) :: rest) e) + else + find (n' - 1, rest, nudge - 1, liftC, liftE) + in + find (n, env, 0, 0, 0) + end + | ENamed _ => all + | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, map (con env) cs, Option.map (exp env) eo), loc) + | EFfi _ => all + | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc) + + | EApp (e1, e2) => + let + val e1 = exp env e1 + val e2 = exp env e2 + in + case #1 e1 of + EAbs (_, _, _, b) => exp (Known e2 :: deKnown env) b + | _ => (EApp (e1, e2), loc) + end + + | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (Unknown :: env) e), loc) + + | ECApp (e, c) => + let + val e = exp env e + val c = con env c + in + case #1 e of + ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b + | _ => (ECApp (e, c), loc) + end + + | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc) + + | EKApp (e, k) => (EKApp (exp env e, k), loc) + | EKAbs (x, e) => (EKAbs (x, exp env e), loc) + + | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc) + | EField (e, c, {field = f, rest = r}) => + let + val e = exp env e + val c = con env c + + fun default () = (EField (e, c, {field = con env f, rest = con env r}), loc) + in + case (#1 e, #1 c) of + (ERecord xcs, CName x) => + (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of + NONE => default () + | SOME (_, e, _) => e) + | _ => default () + end + + | EConcat (e1, c1, e2, c2) => (EConcat (exp env e1, con env c1, exp env e2, con env c2), loc) + | ECut (e, c, {field = f, rest = r}) => (ECut (exp env e, + con env c, + {field = con env f, rest = con env r}), loc) + | ECutMulti (e, c, {rest = r}) => (ECutMulti (exp env e, con env c, {rest = con env r}), loc) + + | ECase (e, pes, {disc = d, result = r}) => + let + val others = {disc = con env d, result = con env r} + + fun patBinds (p, _) = + case p of + PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, _, NONE) => 0 + | PCon (_, _, _, SOME p) => patBinds p + | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts + + fun pat (all as (p, loc)) = + case p of + PVar (x, t) => (PVar (x, con env t), loc) + | PPrim _ => all + | PCon (dk, pc, cs, po) => + (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) + | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc) + + fun push () = + (ECase (exp env e, + map (fn (p, e) => (pat p, + exp (List.tabulate (patBinds p, + fn _ => Unknown) @ env) e)) + pes, others), loc) + + fun search pes = + case pes of + [] => push () + | (p, body) :: pes => + case match (env, p, e) of + No => search pes + | Maybe => push () + | Yes env' => exp env' body + in + search pes + end + + | EWrite e => (EWrite (exp env e), loc) + | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) + + | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (Unknown :: env) e2), loc) + + | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc)) fun reduce file = let fun doDecl (d as (_, loc)) = - case #1 d of - DCon _ => d - | DDatatype _ => d - | DVal (x, n, t, e, s) => - let - val e = exp [] e - in - (DVal (x, n, t, e, s), loc) - end - | DValRec vis => - (DValRec (map (fn (x, n, t, e, s) => (x, n, t, exp [] e, s)) vis), loc) - | DExport _ => d - | DTable _ => d - | DSequence _ => d - | DView _ => d - | DDatabase _ => d - | DCookie _ => d - | DStyle _ => d - | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) - | DPolicy e1 => (DPolicy (exp [] e1), loc) - | DOnError _ => d + ((*Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)];*) + case #1 d of + DCon _ => d + | DDatatype _ => d + | DVal (x, n, t, e, s) => + let + val e = exp [] e + in + (DVal (x, n, t, e, s), loc) + end + | DValRec vis => + (DValRec (map (fn (x, n, t, e, s) => (x, n, t, exp [] e, s)) vis), loc) + | DExport _ => d + | DTable _ => d + | DSequence _ => d + | DView _ => d + | DDatabase _ => d + | DCookie _ => d + | DStyle _ => d + | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) + | DPolicy e1 => (DPolicy (exp [] e1), loc) + | DOnError _ => d) in map doDecl file end diff --git a/src/search.sig b/src/search.sig index ac867146..2de85425 100644 --- a/src/search.sig +++ b/src/search.sig @@ -59,4 +59,9 @@ signature SEARCH = sig * ('state11 -> 'state2 -> ('state11 * 'state2, 'abort) result) -> (('state11 * 'state12) * 'state2, 'abort) result + val bindPWithPos : + (('state11 * 'state12) * 'state2, 'abort) result + * (('state11 * 'state12) -> 'state2 -> ('state11 * 'state2, 'abort) result) + -> (('state11 * 'state12) * 'state2, 'abort) result + end diff --git a/src/search.sml b/src/search.sml index 563496fe..5e4e135f 100644 --- a/src/search.sml +++ b/src/search.sml @@ -70,4 +70,12 @@ fun bindP (r, f) = ((x', pos), acc')) | Return x => Return x +fun bindPWithPos (r, f) = + case r of + Continue ((x, pos), acc) => + map (f (x, pos) acc, + fn (x', acc') => + ((x', pos), acc')) + | Return x => Return x + end diff --git a/src/settings.sig b/src/settings.sig index 986d6ed7..6a409cdd 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -37,6 +37,8 @@ signature SETTINGS = sig val configSrcLib : string ref val configInclude : string ref val configSitelisp : string ref + val configIcuIncludes : string ref + val configIcuLibs : string ref val libUr : unit -> string val libC : unit -> string @@ -219,8 +221,14 @@ signature SETTINGS = sig onlyUnion : bool, nestedRelops : bool, windowFunctions : bool, + requiresTimestampDefaults : bool, supportsIsDistinctFrom : bool, - supportsSHA512 : bool + supportsSHA512 : {InitializeDb : string, + GenerateHash : string -> string} option, + (* If supported, give the SQL code to + * enable the feature in a particular + * database and to compute a hash of a value. *) + supportsSimilar : {InitializeDb : string} option } val addDbms : dbms -> unit @@ -236,6 +244,9 @@ signature SETTINGS = sig val setSql : string option -> unit val getSql : unit -> string option + val setEndpoints : string option -> unit + val getEndpoints : unit -> string option + val setCoreInline : int -> unit val getCoreInline : unit -> int @@ -258,6 +269,7 @@ signature SETTINGS = sig val getFileCache : unit -> string option (* Which GET-able functions should be allowed to have side effects? *) + val setSafeGetDefault : bool -> unit val setSafeGets : string list -> unit val isSafeGet : string -> bool diff --git a/src/settings.sml b/src/settings.sml index cfbe98a5..eeaf8145 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -32,7 +32,8 @@ val configLib = ref Config.lib val configSrcLib = ref Config.srclib val configInclude = ref Config.includ val configSitelisp = ref Config.sitelisp - +val configIcuIncludes = ref Config.icuIncludes +val configIcuLibs = ref Config.icuLibs val configCCompiler = ref Config.ccompiler fun getCCompiler () = !configCCompiler @@ -116,6 +117,7 @@ fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x) val clientToServerBase = basis ["int", "float", "string", + "char", "time", "file", "unit", @@ -156,6 +158,7 @@ fun isEffectful ("Sqlcache", _) = true fun addEffectful x = effectful := S.add (!effectful, x) val benignBase = basis ["get_cookie", + "getenv", "new_client_source", "get_client_source", "set_client_source", @@ -275,6 +278,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("urlifyFloat", "ts"), ("urlifyTime", "ts"), ("urlifyString", "uf"), + ("urlifyChar", "uf"), ("urlifyBool", "ub"), ("recv", "rv"), ("strcat", "cat"), @@ -321,8 +325,10 @@ val jsFuncsBase = basisM [("alert", "alert"), ("ord", "ord"), ("checkUrl", "checkUrl"), + ("anchorUrl", "anchorUrl"), ("bless", "bless"), ("blessData", "blessData"), + ("currentUrl", "currentUrl"), ("eq_time", "eq"), ("lt_time", "lt"), @@ -646,8 +652,10 @@ type dbms = { onlyUnion : bool, nestedRelops : bool, windowFunctions: bool, + requiresTimestampDefaults : bool, supportsIsDistinctFrom : bool, - supportsSHA512 : bool + supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option, + supportsSimilar : {InitializeDb : string} option } val dbmses = ref ([] : dbms list) @@ -680,8 +688,10 @@ val curDb = ref ({name = "", onlyUnion = false, nestedRelops = false, windowFunctions = false, + requiresTimestampDefaults = false, supportsIsDistinctFrom = false, - supportsSHA512 = false} : dbms) + supportsSHA512 = NONE, + supportsSimilar = NONE} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s = @@ -702,6 +712,10 @@ val sql = ref (NONE : string option) fun setSql so = sql := so fun getSql () = !sql +val endpoints = ref (NONE : string option) +fun setEndpoints so = endpoints := so +fun getEndpoints () = !endpoints + val coreInline = ref 5 fun setCoreInline n = coreInline := n fun getCoreInline () = !coreInline @@ -728,7 +742,8 @@ fun getSigFile () = !sigFile val fileCache = ref (NONE : string option) fun setFileCache v = - (if Option.isSome v andalso not (#supportsSHA512 (currentDbms ())) then + (if Option.isSome v andalso (case #supportsSHA512 (currentDbms ()) of NONE => true + | SOME _ => false) then ErrorMsg.error "The selected database engine is incompatible with file caching." else (); @@ -740,9 +755,11 @@ structure SS = BinarySetFn(struct val compare = String.compare end) +val safeGetDefault = ref false val safeGet = ref SS.empty +fun setSafeGetDefault b = safeGetDefault := b fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls) -fun isSafeGet x = SS.member (!safeGet, x) +fun isSafeGet x = !safeGetDefault orelse SS.member (!safeGet, x) val onError = ref (NONE : (string * string list * string) option) fun setOnError x = onError := x @@ -1003,6 +1020,7 @@ fun reset () = dbstring := NONE; exe := NONE; sql := NONE; + endpoints := NONE; coreInline := 5; monoInline := 5; staticLinking := false; diff --git a/src/sources b/src/sources index 5c0b2a84..74171365 100644 --- a/src/sources +++ b/src/sources @@ -69,6 +69,9 @@ $(SRC)/elab.sml $(SRC)/elab_util.sig $(SRC)/elab_util.sml +$(SRC)/elab_util_pos.sig +$(SRC)/elab_util_pos.sml + $(SRC)/elab_env.sig $(SRC)/elab_env.sml @@ -165,6 +168,9 @@ $(SRC)/css.sml $(SRC)/mono.sml +$(SRC)/endpoints.sig +$(SRC)/endpoints.sml + $(SRC)/mono_util.sig $(SRC)/mono_util.sml @@ -268,6 +274,20 @@ $(SRC)/checknest.sml $(SRC)/compiler.sig $(SRC)/compiler.sml +$(SRC)/getinfo.sig +$(SRC)/getinfo.sml + +$(SRC)/json.sig +$(SRC)/json.sml + +$(SRC)/fromjson.sig +$(SRC)/fromjson.sml + +$(SRC)/lspspec.sml + +$(SRC)/lsp.sig +$(SRC)/lsp.sml + $(SRC)/demo.sig $(SRC)/demo.sml diff --git a/src/specialize.sml b/src/specialize.sml index 33545250..70e646e3 100644 --- a/src/specialize.sml +++ b/src/specialize.sml @@ -44,6 +44,7 @@ end structure CM = BinaryMapFn(CK) structure IM = IntBinaryMap +structure IS = IntBinarySet type datatyp' = { name : int, @@ -61,7 +62,7 @@ type state = { count : int, datatypes : datatyp IM.map, constructors : int IM.map, - decls : (string * int * string list * (string * int * con option) list) list + decls : (string * int * string list * (string * int * con option) list) list } fun kind (k, st) = (k, st) @@ -72,6 +73,12 @@ val isOpen = U.Con.exists {kind = fn _ => false, CRel _ => true | _ => false} +fun findApp (c, args) = + case c of + CApp ((c', _), arg) => findApp (c', arg :: args) + | CNamed n => SOME (n, args) + | _ => NONE + fun considerSpecialization (st : state, n, args, dt : datatyp) = let val args = map ReduceLocal.reduceCon args @@ -132,31 +139,20 @@ fun considerSpecialization (st : state, n, args, dt : datatyp) = end and con (c, st : state) = - let - fun findApp (c, args) = - case c of - CApp ((c', _), arg) => findApp (c', arg :: args) - | CNamed n => SOME (n, args) - | _ => NONE - in - case findApp (c, []) of - SOME (n, args as (_ :: _)) => - if List.exists isOpen args then - (c, st) - else - (case IM.find (#datatypes st, n) of - NONE => (c, st) - | SOME dt => - if length args <> #params dt then - (c, st) - else - let - val (n, _, st) = considerSpecialization (st, n, args, dt) - in - (CNamed n, st) - end) - | _ => (c, st) - end + case findApp (c, []) of + SOME (n, args as ((_, loc) :: _)) => + (case IM.find (#datatypes st, n) of + NONE => (c, st) + | SOME dt => + if length args <> #params dt then + (c, st) + else + let + val (n, _, st) = considerSpecialization (st, n, args, dt) + in + (CNamed n, st) + end) + | _ => (c, st) and specCon st = U.Con.foldMap {kind = kind, con = con} st @@ -252,6 +248,48 @@ val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} fun specialize file = let + (*val () = CorePrint.debug := true + val () = print "SPECIALIZING\n"*) + + (* Let's run around a file, finding any polymorphic uses of a datatype. + * However, don't count polymorphism within a datatype's own definition! + * To that end, we run a silly transform on the file before traversing. *) + val file' = + map (fn d => + case #1 d of + DDatatype dts => + U.Decl.map {kind = fn x => x, + exp = fn x => x, + decl = fn x => x, + con = fn CNamed n => + if List.exists (fn (_, n', _, _) => n' = n) dts then + CUnit + else + CNamed n + | c => c} d + | _ => d) file + + val fancyDatatypes = U.File.fold {kind = fn (_, fd) => fd, + exp = fn (_, fd) => fd, + decl = fn (_, fd) => fd, + con = fn (c, fd) => + case c of + CApp (c1, c2) => + if isOpen c2 then + case findApp (c, []) of + SOME (n, _) => + ((*Print.preface ("Disqualifier", + CorePrint.p_con CoreEnv.empty (c, ErrorMsg.dummySpan));*) + IS.add (fd, n)) + | NONE => fd + else + fd + | _ => fd} + IS.empty file' + + (* Why did we find the polymorphism? + * It would be incoherent to specialize a datatype used polymorphically. *) + fun doDecl (d, st) = let (*val () = Print.preface ("decl:", CorePrint.p_decl CoreEnv.empty all)*) @@ -259,23 +297,27 @@ fun specialize file = in case #1 d of DDatatype dts => - ((case #decls st of - [] => [d] - | dts' => [(DDatatype (dts' @ dts), #2 d)]), - {count = #count st, - datatypes = foldl (fn ((x, n, xs, xnts), dts) => - IM.insert (dts, n, - {name = x, - params = length xs, - constructors = xnts, - specializations = CM.empty})) - (#datatypes st) dts, - constructors = foldl (fn ((x, n, xs, xnts), cs) => - foldl (fn ((_, n', _), constructors) => - IM.insert (constructors, n', n)) + if List.exists (fn (_, n, _, _) => IS.member (fancyDatatypes, n)) dts then + ((*Print.preface ("Skipping", CorePrint.p_decl CoreEnv.empty d);*) + ([d], st)) + else + ((case #decls st of + [] => [d] + | dts' => [(DDatatype (dts' @ dts), #2 d)]), + {count = #count st, + datatypes = foldl (fn ((x, n, xs, xnts), dts) => + IM.insert (dts, n, + {name = x, + params = length xs, + constructors = xnts, + specializations = CM.empty})) + (#datatypes st) dts, + constructors = foldl (fn ((x, n, xs, xnts), cs) => + foldl (fn ((_, n', _), constructors) => + IM.insert (constructors, n', n)) cs xnts) - (#constructors st) dts, - decls = []}) + (#constructors st) dts, + decls = []}) | _ => (case #decls st of [] => [d] @@ -287,10 +329,10 @@ fun specialize file = end val (ds, _) = ListUtil.foldlMapConcat doDecl - {count = U.File.maxName file + 1, - datatypes = IM.empty, - constructors = IM.empty, - decls = []} file + {count = U.File.maxName file + 1, + datatypes = IM.empty, + constructors = IM.empty, + decls = []} file in ds end diff --git a/src/sqlite.sml b/src/sqlite.sml index db7052d1..0e97bf69 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -855,7 +855,9 @@ val () = addDbms {name = "sqlite", onlyUnion = false, nestedRelops = false, windowFunctions = false, + requiresTimestampDefaults = false, supportsIsDistinctFrom = false, - supportsSHA512 = false} + supportsSHA512 = NONE, + supportsSimilar = NONE} end diff --git a/src/tag.sml b/src/tag.sml index 94e5d44f..3040c36c 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -124,7 +124,7 @@ fun exp uf env (e, s) = () else ErrorMsg.errorAt loc - ("Duplicate HTTP tag " + ("Duplicate URL prefix " ^ s); if ek = ek' then () diff --git a/src/urweb.grm b/src/urweb.grm index afebff0a..dea7bdf5 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -2276,6 +2276,15 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In val e = (EApp (e, fname), loc) in (EApp (e, sqlexp), loc) + end) + | fname LPAREN sqlexp COMMA sqlexp RPAREN (let + val loc = s (fnameleft, RPARENright) + + val e = (EVar (["Basis"], "sql_bfunc", Infer), loc) + val e = (EApp (e, fname), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) end) | LPAREN query RPAREN (let val loc = s (LPARENleft, RPARENright) diff --git a/src/urweb.lex b/src/urweb.lex index 368b9f1b..23c32ea1 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -174,7 +174,7 @@ fun unescape loc s = %% %header (functor UrwebLexFn(structure Tokens : Urweb_TOKENS)); %full -%s COMMENT STRING CHAR XML XMLTAG; +%s COMMENT XMLCOMMENT STRING CHAR XML XMLTAG; id = [a-z_][A-Za-z0-9_']*; xmlid = [A-Za-z][A-Za-z0-9_-]*; @@ -184,13 +184,12 @@ intconst = [0-9]+; realconst = [0-9]+\.[0-9]*; hexconst = 0x[0-9A-F]+; notags = ([^<{\n(]|(\([^\*<{\n]))+; -xcom = ([^\-]|(-[^\-]))+; oint = [0-9][0-9][0-9]; xint = x[0-9a-fA-F][0-9a-fA-F]; %% -<INITIAL,COMMENT,XMLTAG> +<INITIAL,COMMENT,XMLTAG,XMLCOMMENT> \n => (newline yypos; continue ()); <XML> \n => (newline yypos; @@ -219,7 +218,9 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; <COMMENT> "*)" => (exitComment (); continue ()); -<XML> "<!--" {xcom} "-->" => (continue ()); +<XML> "<!--" => (YYBEGIN XMLCOMMENT; continue ()); +<XMLCOMMENT> "-->" => (YYBEGIN XML; continue ()); +<XMLCOMMENT> . => (continue ()); <STRING,CHAR> "\\\"" => (str := #"\"" :: !str; continue()); <STRING,CHAR> "\\'" => (str := #"'" :: !str; continue()); diff --git a/tests/Makefile b/tests/Makefile index ecf5557b..8df59518 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -7,6 +7,7 @@ test.o: test.c simple:: ./driver.sh aborter2 ./driver.sh aborter + ./driver.sh a_case_of_the_splits ./driver.sh activeBlock ./driver.sh activeFocus ./driver.sh active @@ -22,9 +23,21 @@ simple:: ./driver.sh autocomp ./driver.sh babySpawn ./driver.sh bindpat + ./driver.sh bodyClick + ./driver.sh bool + ./driver.sh both + ./driver.sh both2 + ./driver.sh button + ./driver.sh case + ./driver.sh caseMod + ./driver.sh ccheckbox + ./driver.sh cdataF + ./driver.sh cdataL + ./cffi.sh ./driver.sh DynChannel ./driver.sh jsonTest ./driver.sh entities ./driver.sh fact ./driver.sh filter ./driver.sh jsbspace + ./driver.sh utf8 diff --git a/tests/a_case_of_the_splits.py b/tests/a_case_of_the_splits.py new file mode 100644 index 00000000..9a78e2fb --- /dev/null +++ b/tests/a_case_of_the_splits.py @@ -0,0 +1,15 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + reg = self.xpath('button') + # click a couple of times + reg.click() + reg.click() + # we should get HTML spliced into HTML as-is (properly escaped even!) + span = self.xpath('span') + txt = span.text + self.assertRegex(txt, ".*\\(0\\).* :: .*\\(1\\).* :: \\[\\]") diff --git a/tests/a_case_of_the_splits.ur b/tests/a_case_of_the_splits.ur new file mode 100644 index 00000000..2029729e --- /dev/null +++ b/tests/a_case_of_the_splits.ur @@ -0,0 +1,17 @@ +fun newCounter () : transaction xbody = + x <- source 0; + return <xml> + <dyn signal={n <- signal x; return <xml>{[n]}</xml>}/> + </xml> + +fun main () : transaction page = + ls <- source ([] : list xbody); + return <xml> + <body> + <button value="Add" onclick={fn _ => + l <- get ls; + c <- newCounter (); + set ls (c :: l)}/> + <dyn signal={l <- signal ls; return <xml>{[l]}</xml>}/> + </body> + </xml> diff --git a/tests/a_case_of_the_splits.urp b/tests/a_case_of_the_splits.urp new file mode 100644 index 00000000..b8238bf4 --- /dev/null +++ b/tests/a_case_of_the_splits.urp @@ -0,0 +1,4 @@ +rewrite all A_case_of_the_splits/* + +$/list +a_case_of_the_splits diff --git a/tests/badkind.ur b/tests/badkind.ur new file mode 100644 index 00000000..600f7a35 --- /dev/null +++ b/tests/badkind.ur @@ -0,0 +1 @@ +fun main () : transaction page = <xml>ahoy!</xml> diff --git a/tests/badkind.urp b/tests/badkind.urp new file mode 100644 index 00000000..934e4928 --- /dev/null +++ b/tests/badkind.urp @@ -0,0 +1,3 @@ +rewrite Badkind/main / + +badkind diff --git a/tests/bodyClick.py b/tests/bodyClick.py new file mode 100644 index 00000000..0c10d632 --- /dev/null +++ b/tests/bodyClick.py @@ -0,0 +1,18 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + bd = self.driver.find_element_by_xpath('/html/body') + + bd.click() + alert = self.driver.switch_to.alert + self.assertEqual("You clicked the body.", alert.text) + alert.accept() + + bd.send_keys('h') + alert = self.driver.switch_to.alert + self.assertEqual("Key", alert.text) + alert.accept() diff --git a/tests/bool.py b/tests/bool.py new file mode 100644 index 00000000..e5fedf19 --- /dev/null +++ b/tests/bool.py @@ -0,0 +1,17 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + l = self.xpath('li[1]/a') + l.click() + self.assertEqual("Yes!", self.body_text()) + + def test_2(self): + """Test case 2""" + self.start('main') + l = self.xpath('li[2]/a') + l.click() + self.assertEqual("No!", self.body_text()) diff --git a/tests/bool.ur b/tests/bool.ur index b7e57dca..b8edbba6 100644 --- a/tests/bool.ur +++ b/tests/bool.ur @@ -1,8 +1,8 @@ -val page = fn b => <html><body> +val page = fn b => return <xml><body> {cdata (case b of False => "No!" | True => "Yes!")} -</body></html> +</body></xml> -val main : unit -> page = fn () => <html><body> +val main : unit -> transaction page = fn () => return <xml><body> <li><a link={page True}>True</a></li> <li><a link={page False}>False</a></li> -</body></html> +</body></xml> diff --git a/tests/both.py b/tests/both.py new file mode 100644 index 00000000..c3a8e8ee --- /dev/null +++ b/tests/both.py @@ -0,0 +1,12 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('Both/main') + t = self.xpath('form/input[@type=\'text\']') + t.send_keys('hello') + l = self.xpath('form/input[@type=\'submit\']') + l.click() + self.assertEqual("", self.body_text()) diff --git a/tests/both.ur b/tests/both.ur index d1c9f40e..b0f2a493 100644 --- a/tests/both.ur +++ b/tests/both.ur @@ -1,9 +1,10 @@ fun main () : transaction page = return <xml> <body> <form> - <textbox{#Text}/><submit action={submit}/> + <textbox{#Text}/> + <submit action={handler}/> </form> </body> </xml> -and submit r = return <xml/> +and handler r = return <xml/> diff --git a/tests/both.urs b/tests/both.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/both.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/tests/both2.py b/tests/both2.py new file mode 100644 index 00000000..b5b3c0fc --- /dev/null +++ b/tests/both2.py @@ -0,0 +1,12 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('Both2/main') + t = self.xpath('form/input[@type=\'text\']') + t.send_keys('hello') + l = self.xpath('form/input[@type=\'submit\']') + l.click() + self.assertEqual("", self.body_text()) diff --git a/tests/both2.ur b/tests/both2.ur index c3f25cc9..3190def8 100644 --- a/tests/both2.ur +++ b/tests/both2.ur @@ -1,14 +1,12 @@ fun main () : transaction page = let - fun submit r = return <xml/> + fun handler r = return <xml/> in return <xml> <body> <form> - <textbox{#Text}/><submit action={submit}/> + <textbox{#Text}/><submit action={handler}/> </form> </body> </xml> end - - diff --git a/tests/button.py b/tests/button.py new file mode 100644 index 00000000..14159fec --- /dev/null +++ b/tests/button.py @@ -0,0 +1,13 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + b = self.xpath('button') + + b.click() + alert = self.driver.switch_to.alert + self.assertEqual("AHOY", alert.text) + alert.accept() diff --git a/tests/case.py b/tests/case.py new file mode 100644 index 00000000..611273e2 --- /dev/null +++ b/tests/case.py @@ -0,0 +1,15 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + d = self.xpath('div') + txt = "zero is two: B\none is two: B\ntwo is two: A" + self.assertEqual(txt, d.text) + + b = self.xpath('button') + b.click() + alert = self.driver.switch_to.alert + self.assertEqual(txt, alert.text) diff --git a/tests/case.ur b/tests/case.ur index b131b27b..a6f4c700 100644 --- a/tests/case.ur +++ b/tests/case.ur @@ -11,6 +11,22 @@ datatype nat = O | S of nat val is_two = fn x : nat => case x of S (S O) => A | _ => B -val zero_is_two = is_two O -val one_is_two = is_two (S O) -val two_is_two = is_two (S (S O)) +val shw = fn x : t => + case x of A => "A" | B => "B" + +fun main (): transaction page = return <xml><body> + <div> + <p>zero is two: {[shw (is_two O)]}</p> + <p>one is two: {[shw (is_two (S O))]}</p> + <p>two is two: {[shw (is_two (S (S O)))]}</p> + </div> + + <button onclick={fn _ => let + val m = + "zero is two: " ^ shw (is_two O) ^ "\n" ^ + "one is two: " ^ shw (is_two (S O)) ^ "\n" ^ + "two is two: " ^ shw (is_two (S (S O))) + in + alert m + end}>click me</button> +</body></xml> diff --git a/tests/caseMod.py b/tests/caseMod.py new file mode 100644 index 00000000..16e49a5b --- /dev/null +++ b/tests/caseMod.py @@ -0,0 +1,25 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + l1 = self.xpath('li[1]/a') + l1.click() + + self.assertEqual("C A\n\nAgain!", self.body_text()) + def test_2(self): + """Test case 2""" + self.start('main') + l1 = self.xpath('li[2]/a') + l1.click() + + self.assertEqual("C B\n\nAgain!", self.body_text()) + def test_3(self): + """Test case 3""" + self.start('main') + l1 = self.xpath('li[3]/a') + l1.click() + + self.assertEqual("D\n\nAgain!", self.body_text()) diff --git a/tests/caseMod.ur b/tests/caseMod.ur index 0a870160..15a7e07a 100644 --- a/tests/caseMod.ur +++ b/tests/caseMod.ur @@ -24,15 +24,15 @@ val toString = fn x => | C B => "C B" | D => "D" -val rec page = fn x => <html><body> +val rec page = fn x => return <xml><body> {cdata (toString x)}<br/> <br/> <a link={page x}>Again!</a> -</body></html> +</body></xml> -val main : unit -> page = fn () => <html><body> +val main : unit -> transaction page = fn () => return <xml><body> <li> <a link={page (C A)}>C A</a></li> <li> <a link={page (C B)}>C B</a></li> <li> <a link={page D}>D</a></li> -</body></html> +</body></xml> diff --git a/tests/ccheckbox.py b/tests/ccheckbox.py new file mode 100644 index 00000000..f2390368 --- /dev/null +++ b/tests/ccheckbox.py @@ -0,0 +1,15 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + d = self.xpath('input') + p = self.xpath('span') + self.assertEqual("True 1", p.text) + d.click() + # the elements gets re-created from scratch + # so we must refresh our reference + p = self.xpath('span') + self.assertEqual("False 3", p.text) diff --git a/tests/ccheckbox.ur b/tests/ccheckbox.ur index 09a8ece9..d70c24a5 100644 --- a/tests/ccheckbox.ur +++ b/tests/ccheckbox.ur @@ -1,7 +1,7 @@ fun main () : transaction page = s <- source True; t <- source 1; - return <xml><body><ccheckbox source={s} onclick={set t 3}/> + return <xml><body><ccheckbox source={s} onclick={fn _ => set t 3}/> <dyn signal={s <- signal s; t <- signal t; return <xml>{[s]} {[t]}</xml>}/> diff --git a/tests/cdataF.py b/tests/cdataF.py new file mode 100644 index 00000000..8f43176f --- /dev/null +++ b/tests/cdataF.py @@ -0,0 +1,8 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + self.assertEqual("<Hi.\nBye.", self.body_text()) diff --git a/tests/cdataF.ur b/tests/cdataF.ur index 3f8da45b..698dead7 100644 --- a/tests/cdataF.ur +++ b/tests/cdataF.ur @@ -1,8 +1,8 @@ -val snippet = fn s => <body> +val snippet = fn s => <xml> <h1>{cdata s}</h1> -</body> +</xml> -val main = fn () => <html><body> +val main : unit -> transaction page = fn () => return <xml><body> {snippet "<Hi."} {snippet "Bye."} -</body></html> +</body></xml> diff --git a/tests/cdataL.py b/tests/cdataL.py new file mode 100644 index 00000000..67ccd75e --- /dev/null +++ b/tests/cdataL.py @@ -0,0 +1,18 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + l1 = self.xpath('li[1]/a') + l1.click() + + self.assertEqual("<Hi.", self.body_text()) + def test_2(self): + """Test case 2""" + self.start('main') + l1 = self.xpath('li[2]/a') + l1.click() + + self.assertEqual("Bye.", self.body_text()) diff --git a/tests/cdataL.ur b/tests/cdataL.ur index 3aa3bef6..42122b20 100644 --- a/tests/cdataL.ur +++ b/tests/cdataL.ur @@ -1,8 +1,8 @@ -val subpage = fn s => <html><body> +val subpage : string -> transaction page = fn s => return <xml><body> <h1>{cdata s}</h1> -</body></html> +</body></xml> -val main = fn () => <html><body> +val main : unit -> transaction page = fn () => return <xml><body> <li> <a link={subpage "<Hi."}>Door #1</a></li> <li> <a link={subpage "Bye."}>Door #2</a></li> -</body></html> +</body></xml> diff --git a/tests/cffi.py b/tests/cffi.py new file mode 100644 index 00000000..34b31b8c --- /dev/null +++ b/tests/cffi.py @@ -0,0 +1,37 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('Cffi/main') + l1 = self.xpath('form[1]/input') + l1.click() + + b1 = self.xpath('button[1]') + b1.click() # TODO: check server output somehow + + b2 = self.xpath('button[2]') + b2.click() + alert = self.driver.switch_to.alert + self.assertEqual("<<Hoho>>", alert.text) + alert.accept() + + b3 = self.xpath('button[3]') + b3.click() + alert = self.driver.switch_to.alert + self.assertEqual("Hi there!", alert.text) + def test_2(self): + """Test case 2""" + self.start('Cffi/main') + l1 = self.xpath('form[2]/input') + l1.click() + + self.assertEqual("All good.", self.body_text()) + def test_3(self): + """Test case 3""" + self.start('Cffi/main') + l1 = self.xpath('form[3]/input') + l1.click() + + self.assertRegex(self.body_text(), "^Fatal error: .*$") diff --git a/tests/cffi.sh b/tests/cffi.sh new file mode 100755 index 00000000..1267c3e3 --- /dev/null +++ b/tests/cffi.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +CCOMP=gcc + +$CCOMP -pthread -Wimplicit -Werror -Wno-unused-value -I ..include/urweb -c "test.c" -o "test.o" -g +./driver.sh cffi diff --git a/tests/cffi.ur b/tests/cffi.ur index bcb9944c..89dc9906 100644 --- a/tests/cffi.ur +++ b/tests/cffi.ur @@ -3,9 +3,9 @@ fun printer () = Test.foo fun effect () = Test.print; return <xml><body> - <button value="Remote" onclick={printer ()}/> - <button value="Local" onclick={Test.bar "Hoho"}/> - <button value="Either" onclick={Test.print}/> + <button value="Remote" onclick={fn _ => rpc (printer ())}/> + <button value="Local" onclick={fn _ => Test.bar "Hoho"}/> + <button value="Either" onclick={fn _ => Test.print}/> </body></xml> fun xact () = diff --git a/tests/classAndDynClass.ur b/tests/classAndDynClass.ur new file mode 100644 index 00000000..ba01962d --- /dev/null +++ b/tests/classAndDynClass.ur @@ -0,0 +1,9 @@ +style style1 +style style2 + +fun main () : transaction page = return <xml><body> + <div class="style1" dynClass={return (CLASS "style2")}>Text</div> + <div dynClass={return (CLASS "style2")}>Text</div> + <div style="font-weight: bold" dynStyle={return (STYLE "font-variant: small-caps")}>Text</div> + <div dynStyle={return (STYLE "font-variant: small-caps")}>Text</div> +</body></xml> diff --git a/tests/clib.urp b/tests/clib.urp index de89d03a..9ac0f144 100644 --- a/tests/clib.urp +++ b/tests/clib.urp @@ -1,6 +1,6 @@ ffi test include test.h -script http://localhost/test/test.js +jsFile test.js link test.o effectful Test.print serverOnly Test.foo diff --git a/tests/driver.sh b/tests/driver.sh index 879c093d..d20809d0 100755 --- a/tests/driver.sh +++ b/tests/driver.sh @@ -21,5 +21,9 @@ fi $TESTSRV -q -a 127.0.0.1 & echo $! >> $TESTPID sleep 1 -python3 -m unittest $1.py +if [[ $# -eq 1 ]] ; then + python3 -m unittest $1.py +else + python3 -m unittest $1.Suite.$2 +fi kill `cat $TESTPID` diff --git a/tests/dupTag.ur b/tests/dupTag.ur new file mode 100644 index 00000000..cee35df1 --- /dev/null +++ b/tests/dupTag.ur @@ -0,0 +1,21 @@ +structure S = struct + fun one () = + let + fun save r = return <xml/> + in + return <xml><body><form><submit action={save}/></form></body></xml> + end + fun two () = + let + fun save r = return <xml/> + in + return <xml><body><form><submit action={save}/></form></body></xml> + end +end + +fun main () : transaction page = return <xml> + <body> + <a link={S.one()}>one</a> + <a link={S.two()}>two</a> + </body> + </xml> diff --git a/tests/emptyUpdate.ur b/tests/emptyUpdate.ur new file mode 100644 index 00000000..0402d78a --- /dev/null +++ b/tests/emptyUpdate.ur @@ -0,0 +1,6 @@ +table a : { B : int } + +fun main () : transaction page = + dml (update [[]] {} a (WHERE TRUE)); + return <xml></xml> + diff --git a/tests/emptyUpdate.urp b/tests/emptyUpdate.urp new file mode 100644 index 00000000..42cc98e2 --- /dev/null +++ b/tests/emptyUpdate.urp @@ -0,0 +1,4 @@ +database dbname=test +safeGet EmptyUpdate/main + +emptyUpdate diff --git a/tests/endpoints.py b/tests/endpoints.py new file mode 100755 index 00000000..8dc5abef --- /dev/null +++ b/tests/endpoints.py @@ -0,0 +1,30 @@ +#!/usr/bin/python3 + +import sys +import json +import time +import subprocess +import urllib.request +import urllib.parse +import os + +def main(): + prefix = 'http://localhost:8080/' + + with open('/tmp/endpoints.json') as json_data: + data = json.load(json_data) + endpoints = data['endpoints'] + for ep in endpoints: + path = ep['url'] + src = urllib.parse.urljoin(prefix, path) + if ep['method'] == 'GET': + contents = urllib.request.urlopen(src).read() + # it's okay that we can retrieve it, enough for us right now + else: + # TODO: add support for parameters? + post_fields = {'Nam': 'X', 'Msg': 'message', 'Sameday': 'on'} # Set POST fields here + request = urllib.request.Request(src, urllib.parse.urlencode(post_fields).encode()) + contents = urllib.request.urlopen(request).read().decode() + +if __name__ == '__main__': + main() diff --git a/tests/endpoints.sh b/tests/endpoints.sh new file mode 100755 index 00000000..1d3289a5 --- /dev/null +++ b/tests/endpoints.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +TEST=endpoints +TESTPID=/tmp/$TEST.pid +TESTENDPOINTS=/tmp/$TEST.json +TESTSRV=./$TEST.exe + +rm -f $TESTENDPOINTS $TESTPID $TESTSRV +../bin/urweb -debug -boot -noEmacs -endpoints $TESTENDPOINTS "$TEST" || exit 1 + +$TESTSRV -q -a 127.0.0.1 & +echo $! >> $TESTPID +sleep 1 +python3 $TEST.py +kill `cat $TESTPID` diff --git a/tests/endpoints.ur b/tests/endpoints.ur new file mode 100644 index 00000000..ddb91faa --- /dev/null +++ b/tests/endpoints.ur @@ -0,0 +1,40 @@ +fun formbased (): transaction page = + return <xml> + <body> + <form> + <label>Your name: <textbox{#Nam}/></label> + <label>Your message: <textarea{#Msg}/></label> + <label>Delivered on the same day <checkbox{#Sameday}/></label> + <submit value="Send" action={formbased_handler}/> + </form> + </body> + </xml> + +and formbased_handler (r : {Nam : string, Msg : string, Sameday : bool}) : transaction page = + return <xml> + <body> + <p>Oh hello {[r.Nam]}! Great to see you here again!</p> + <p>Your message was:</p> + <p>{[r.Msg]}</p> + <p>Sameday delivery was:</p> + <p>{[if r.Sameday then "set" else "unset"]}</p> + </body> + </xml> + +fun say_hi_to (s : string) : transaction page = +return <xml> + <body> + <p>It's {[s]} birthday!</p> + </body> +</xml> + +fun optimized_out (): transaction page = + return <xml>this one is optimized away since it's not referenced in the declarations</xml> + +fun main (): transaction page = + return <xml> + <body> + <p>hello</p> + <p>Say hi to <a link={say_hi_to "JC"}>JC</a></p> + </body> +</xml> diff --git a/tests/endpoints.urp b/tests/endpoints.urp new file mode 100644 index 00000000..faf855bd --- /dev/null +++ b/tests/endpoints.urp @@ -0,0 +1,4 @@ +rewrite url Endpoints/main index.html +rewrite url Endpoints/formbased greet.html + +endpoints diff --git a/tests/endpoints.urs b/tests/endpoints.urs new file mode 100644 index 00000000..fba42a2b --- /dev/null +++ b/tests/endpoints.urs @@ -0,0 +1,3 @@ +val main : unit -> transaction page +val say_hi_to : string -> transaction page +val formbased : unit -> transaction page diff --git a/tests/filter.urp b/tests/filter.urp index 102a1871..ddf1a3df 100644 --- a/tests/filter.urp +++ b/tests/filter.urp @@ -1,4 +1,5 @@ debug database dbname=filter +sql filter.sql filter diff --git a/tests/foreign_text.ur b/tests/foreign_text.ur new file mode 100644 index 00000000..8f404349 --- /dev/null +++ b/tests/foreign_text.ur @@ -0,0 +1,4 @@ +table t : { A : string } PRIMARY KEY A +table u : { A : string } CONSTRAINT A FOREIGN KEY A REFERENCES t(A) + +val main : transaction page = return <xml></xml> diff --git a/tests/foreign_text.urp b/tests/foreign_text.urp new file mode 100644 index 00000000..f0777eb6 --- /dev/null +++ b/tests/foreign_text.urp @@ -0,0 +1,5 @@ +dbms mysql +database dbname=foreign_text +sql foreign_text.sql + +foreign_text diff --git a/tests/html5_cforms.ur b/tests/html5_cforms.ur index be07d07e..317a0638 100644 --- a/tests/html5_cforms.ur +++ b/tests/html5_cforms.ur @@ -9,8 +9,8 @@ fun main () : transaction page = d <- source ""; e <- source ""; f <- source ""; - g <- source 1.0; - h <- source 1.0; + g <- source (Some 1.0); + h <- source (Some 1.0); i <- source "#CCCCCC"; j <- source "2014/11/16"; k <- source "2014/11/16 12:30:45"; diff --git a/tests/mouseEvent.ur b/tests/mouseEvent.ur index 2192e0b0..32a67806 100644 --- a/tests/mouseEvent.ur +++ b/tests/mouseEvent.ur @@ -8,6 +8,8 @@ fun main () : transaction page = return <xml><body> ^ "\nScreenY = " ^ show ev.ScreenY ^ "\nClientX = " ^ show ev.ClientX ^ "\nClientY = " ^ show ev.ClientY + ^ "\nOffsetX = " ^ show ev.OffsetX + ^ "\nOffsetY = " ^ show ev.OffsetY ^ "\nCtrlKey = " ^ show ev.CtrlKey ^ "\nShiftKey = " ^ show ev.ShiftKey ^ "\nAltKey = " ^ show ev.AltKey diff --git a/tests/prefixClash.ur b/tests/prefixClash.ur new file mode 100644 index 00000000..a2325077 --- /dev/null +++ b/tests/prefixClash.ur @@ -0,0 +1,3 @@ +val index = return <xml></xml> +val other = return <xml></xml> +val ather = return <xml></xml> diff --git a/tests/prefixClash.urp b/tests/prefixClash.urp new file mode 100644 index 00000000..cf4545d0 --- /dev/null +++ b/tests/prefixClash.urp @@ -0,0 +1,4 @@ +rewrite url PrefixClash/index foo +rewrite url PrefixClash/* foo/ [-] + +prefixClash diff --git a/tests/prefixClash.urs b/tests/prefixClash.urs new file mode 100644 index 00000000..e5e58c0a --- /dev/null +++ b/tests/prefixClash.urs @@ -0,0 +1,3 @@ +val index : transaction page +val other : transaction page +val ather : transaction page diff --git a/tests/rpc_unit.ur b/tests/rpc_unit.ur new file mode 100644 index 00000000..befd6045 --- /dev/null +++ b/tests/rpc_unit.ur @@ -0,0 +1,8 @@ +val callme = return ((), (), "A", (), ()) + +val main : transaction page = return <xml><body> + <button value="CLICK ME" + onclick={fn _ => + (_, _, s, _, _) <- rpc callme; + alert s}/> +</body></xml> diff --git a/tests/serializingXml.ur b/tests/serializingXml.ur new file mode 100644 index 00000000..34eb3436 --- /dev/null +++ b/tests/serializingXml.ur @@ -0,0 +1,14 @@ +fun alerts n = + if n <= 0 then + return () + else + (alert ("Alert #" ^ show n); + alerts (n - 1)) + +cookie uhoh : serialized xbody + +fun main () : transaction page = + setCookie uhoh {Value = serialize <xml><active code={alerts 3; return <xml>Yay!</xml>}/></xml>, + Expires = None, + Secure = False}; + return <xml></xml> diff --git a/tests/task_cookie.ur b/tests/task_cookie.ur new file mode 100644 index 00000000..39f49b0a --- /dev/null +++ b/tests/task_cookie.ur @@ -0,0 +1,9 @@ +cookie myCookie: {Value: string} + +fun main (): transaction page = return <xml></xml> + +task initialize = fn () => + c <- getCookie myCookie; + case c of + None => debug "No cookie" + | Some {Value = v} => debug ("Cookie value: " ^ v) diff --git a/tests/test.c b/tests/test.c index ef8558d7..24071aa6 100644 --- a/tests/test.c +++ b/tests/test.c @@ -1,6 +1,6 @@ #include <stdio.h> -#include "../include/urweb.h" +#include "urweb/urweb.h" typedef uw_Basis_string uw_Test_t; @@ -27,16 +27,16 @@ uw_Basis_unit uw_Test_foo(uw_context ctx) { } static void commit(void *data) { - printf("Commit: %s\n", data); + printf("Commit: %s\n", (char*)data); } static void rollback(void *data) { - printf("Rollback: %s\n", data); + printf("Rollback: %s\n", (char*)data); } -static void free(void *data) { - printf("Free: %s\n", data); +static void ffree(void *data, int will_retry) { + printf("Free: %s, %d\n", (char*)data, will_retry); } uw_Basis_unit uw_Test_transactional(uw_context ctx) { - uw_register_transactional(ctx, "Beppo", commit, rollback, free); + uw_register_transactional(ctx, "Beppo", commit, rollback, ffree); return uw_unit_v; } diff --git a/tests/test.h b/tests/test.h index c0dec379..43a7746e 100644 --- a/tests/test.h +++ b/tests/test.h @@ -1,4 +1,4 @@ -#include "../include/urweb.h" +#include "urweb/urweb.h" typedef uw_Basis_string uw_Test_t; diff --git a/tests/tooEager.ur b/tests/tooEager.ur new file mode 100644 index 00000000..c84a6d6c --- /dev/null +++ b/tests/tooEager.ur @@ -0,0 +1,18 @@ +fun test (i: list int) : transaction unit = + a <- return (Some "abc"); + c <- (case a of + None => return "1" + | Some b => + debug "not happening :("; + return "2" + ); + (case i of + [] => return () + | first :: _ => debug c) + +fun main (): transaction page = + return <xml> + <body> + <button onclick={fn _ => rpc (test [])}>click</button> + </body> + </xml> diff --git a/tests/trgm.ur b/tests/trgm.ur new file mode 100644 index 00000000..45783366 --- /dev/null +++ b/tests/trgm.ur @@ -0,0 +1,25 @@ +table turtles : { Nam : string } + +fun add name = + dml (INSERT INTO turtles(Nam) + VALUES ({[name]})) + +fun closest name = + List.mapQuery (SELECT * + FROM turtles + ORDER BY similarity(turtles.Nam, {[name]}) DESC + LIMIT 5) + (fn r => r.Turtles.Nam) + +val main = + name <- source ""; + results <- source []; + return <xml><body> + Name: <ctextbox source={name}/><br/> + <button value="Add" onclick={fn _ => n <- get name; rpc (add n)}/><br/> + <button value="Search" onclick={fn _ => n <- get name; ls <- rpc (closest n); set results ls}/><br/> + <dyn signal={rs <- signal results; + return <xml><ol> + {List.mapX (fn n => <xml><li>{[n]}</li></xml>) rs} + </ol></xml>}/> + </body></xml> diff --git a/tests/trgm.urp b/tests/trgm.urp new file mode 100644 index 00000000..326151e7 --- /dev/null +++ b/tests/trgm.urp @@ -0,0 +1,6 @@ +database dbname=trgm +sql trgm.sql +rewrite all Trgm/* + +$/list +trgm diff --git a/tests/trgm.urs b/tests/trgm.urs new file mode 100644 index 00000000..61778b87 --- /dev/null +++ b/tests/trgm.urs @@ -0,0 +1 @@ +val main : transaction page diff --git a/tests/utf8.py b/tests/utf8.py new file mode 100644 index 00000000..6036fa12 --- /dev/null +++ b/tests/utf8.py @@ -0,0 +1,174 @@ +import unittest +import base + +class Suite(base.Base): + + def no_falses(self, name): + self.start('Utf8/' + name) + + elems = self.driver.find_elements_by_xpath('//pre') + + self.assertNotEqual(0, len(elems)) + for e in elems: + self.assertEqual("True", e.text) + + def test_1(self): + """Test case: substring (1)""" + self.no_falses('substrings') + + def test_2(self): + """Test case: strlen (2)""" + self.no_falses('strlens') + + def test_3(self): + """Test case: strlenGe (3)""" + self.no_falses('strlenGens') + + def test_4(self): + """Test case: strcat (4)""" + self.no_falses('strcats') + + def test_5(self): + """Test case: strsub (5)""" + self.no_falses('strsubs') + + def test_6(self): + """Test case: strsuffix (6)""" + self.no_falses('strsuffixs') + + def test_7(self): + """Test case: strchr (7)""" + self.no_falses('strchrs') + + def test_8(self): + """Test case: strindex (8)""" + self.no_falses('strindexs') + + def test_9(self): + """Test case: strindex (9)""" + self.no_falses('strsindexs') + + def test_10(self): + """Test case: strcspn (10)""" + self.no_falses('strcspns') + + def test_11(self): + """Test case: str1 (11)""" + self.no_falses('str1s') + + def test_12(self): + """Test case: isalnum (12)""" + self.no_falses('isalnums') + + def test_13(self): + """Test case: isalpha (13)""" + self.no_falses('isalphas') + + def test_14(self): + """Test case: isblank (14)""" + self.no_falses('isblanks') + + def test_15(self): + """Test case: iscntrl (15)""" + self.no_falses('iscntrls') + + def test_16(self): + """Test case: isdigit (16)""" + self.no_falses('isdigits') + + def test_17(self): + """Test case: isgraph (17)""" + self.no_falses('isgraphs') + + def test_18(self): + """Test case: islower (18)""" + self.no_falses('islowers') + + def test_19(self): + """Test case: isprint (19)""" + self.no_falses('isprints') + + def test_20(self): + """Test case: ispunct (20)""" + self.no_falses('ispuncts') + + def test_21(self): + """Test case: isspace (21)""" + self.no_falses('isspaces') + + def test_22(self): + """Test case: isupper (22)""" + self.no_falses('isuppers') + + def test_23(self): + """Test case: isxdigit (23)""" + self.no_falses('isxdigits') + + def test_24(self): + """Test case: toupper (24)""" + self.no_falses('touppers') + + def test_25(self): + """Test case: ord (25)""" + self.no_falses('ord_and_chrs') + + def test_26 (self): + """Test case: test_db (26) """ + self.no_falses('test_db') + + def full_test (self, name): + + gap = 1000 + i = 0 + while (i + gap < 130000): + self.start('Utf8/' + name + '/' + str(i) + '/' + str(i + gap)) + errors = self.body_text() + self.assertEqual("", errors, errors) + i = i + gap + + + def test_89 (self): + """Test case: ftTolower """ + self.full_test("ftTolower") + + def test_90 (self): + """Test case: ftToupper """ + self.full_test("ftToupper") + + def test_91 (self): + """Test case: ftIsalpha """ + self.full_test("ftIsalpha") + + def test_92 (self): + """Test case: ftIsdigit """ + self.full_test("ftIsdigit") + + def test_93 (self): + """Test case: ftIsalnum """ + self.full_test("ftIsalnum") + + def test_94 (self): + """Test case: ftIsspace """ + self.full_test("ftIsspace") + + def test_95 (self): + """Test case: ftIsblank """ + self.full_test("ftIsblank") + + def test_96 (self): + """Test case: ftIsprint """ + self.full_test("ftIsprint") + + def test_97 (self): + """Test case: ftIsxdigit """ + self.full_test("ftIsxdigit") + + def test_98 (self): + """Test case: ftIsupper """ + self.full_test("ftIsupper") + + def test_99 (self): + """Test case: ftIslower """ + self.full_test("ftIslower") + ''' + ''' diff --git a/tests/utf8.ur b/tests/utf8.ur new file mode 100644 index 00000000..2150fde6 --- /dev/null +++ b/tests/utf8.ur @@ -0,0 +1,1704 @@ + +fun from_m_upto_n f m n = + if m < n then + <xml> + { f m } + { from_m_upto_n f (m + 1) n } + </xml> + else + <xml></xml> + +fun from_m_upto_n2 (f : int -> transaction xbody) (m : int) (n : int) : transaction xbody = + if m < n then + h <- f m; + t <- from_m_upto_n2 f (m + 1) n; + return <xml> + { h } + { t } + </xml> + else + return <xml></xml> + +fun test_fn_both_sides [a ::: Type] (_ : eq a) (_ : show a) (f : unit -> a) (expected : a) (testname : string) : xbody = +<xml> + <p>Server side test: {[testname]}</p> + <pre>{[show (f () = expected)]}</pre> + <active code={return <xml><p>Client side test: {[testname]}</p><pre>{[show (f () = expected)]}</pre></xml>}> +</active> + </xml> + +fun test_fn_both_sides2 [a ::: Type] (_ : eq a) (_ : show a) (f : unit -> a) (serverexp : a) (expected : a) (testname : string) : xbody = +<xml> + <p>Test: {[testname]}</p> + <active code={ + let + val stest = (serverexp = expected) + in + return <xml> + <p>Server side test: {[testname]}</p> + <pre>{[show stest]}</pre> + {if stest then + <xml></xml> + else + <xml> + <p>S: {[serverexp]}</p> + <p>E: {[expected]}</p> + </xml>} + </xml> + end}> +</active> + <active code={return <xml><p>Client side test: {[testname]}</p><pre>{[show (f () = expected)]}</pre></xml>}> +</active> +</xml> + +fun test_fn_sside [a ::: Type] (_ : eq a) (_ : show a) (f : unit -> a) (expected : a) (testname : string) : xbody = + <xml> + <p>Server side test: {[testname]}</p> + <pre>{[show (f () = expected)]}</pre> + </xml> + + fun test_fn_cside [a ::: Type] (_ : eq a) (_ : show a) (f : unit -> a) (expected : a) (testname : string) : xbody = + let + val r = f () + val v = r = expected + in + <xml> + <active code={return <xml><p>Client side test: {[testname]}</p><pre>{[show v]}</pre> + {if v then + <xml></xml> + else + <xml>Expected '{[show expected]}', is '{[show r]}'</xml>} + </xml>}> +</active> + </xml> + end + +fun test_fn_cside_int (f : unit -> int) (expected : int) (testname : string) : xbody = + <xml> + <active code={let + val computed = f () + in + if computed = expected then + return <xml><p>{[testname]}</p><pre>True</pre></xml> + else + return <xml><p>{[testname]}</p><pre>False</pre></xml> + end}> +</active> + </xml> + +fun test_fn_cside_ch (f : unit -> char) (expected : char) (testname : string) : xbody = + <xml> + <active code={let + val computed = f () + val msgErr = "Expected (S) " ^ (show expected) ^ " [" ^ (show (ord expected)) ^ "] but is (C) " ^ + (show computed) ^ "[" ^ (show (ord computed)) ^ "]." + in + if computed = expected then + return <xml></xml> + else + return <xml><p>ERROR {[testname]}: {[msgErr]}</p></xml> + end}> + </active> + </xml> + +fun test_fn_cside_b (f : unit -> bool) (expected : bool) (testname : string) : xbody = + <xml> + <active code={let + val computed = f () + val msgErr = "Expected (S) " ^ (show expected) ^ " but is (C) " ^ + (show computed) ^ "." + in + if computed = expected then + return <xml></xml> + else + return <xml><p>ERROR {[testname]}: {[msgErr]}</p></xml> + end}> + </active> + </xml> + +fun generateTests _ = + return { SL1 = (strlen "𝌆𝌇𝌈𝌉"), + SL2 = (strlen "𝌇𝌈𝌉"), + SL3 = (strlen "𝌈𝌉"), + SL4 = (strlen "𝌉"), + SS1 = (substring "𝌆𝌇𝌈𝌉" 1 3), + SS2 = (substring "𝌆𝌇𝌈𝌉" 2 2), + SS3 = (substring "𝌆𝌇𝌈𝌉" 3 1) , + SLSS1 = (strlen (substring "𝌆𝌇𝌈𝌉" 1 3)), + SLSS2 = (strlen (substring "𝌆𝌇𝌈𝌉" 2 2)), + SLSS3 = (strlen (substring "𝌆𝌇𝌈𝌉" 3 1)), + + SSB1 = (strsub "𝌆𝌇𝌈𝌉" 0), + SSB2 = (strsub "𝌆𝌇𝌈𝌉" 1), + SSB3 = (strsub "𝌆𝌇𝌈𝌉" 2), + SSB4 = (strsub "𝌆𝌇𝌈𝌉" 3), + + SSF1 = (strsuffix "𝌆𝌇𝌈𝌉" 0), + SSF2 = (strsuffix "𝌆𝌇𝌈𝌉" 1), + SSF3 = (strsuffix "𝌆𝌇𝌈𝌉" 2), + SSF4 = (strsuffix "𝌆𝌇𝌈𝌉" 3), + + SC1 = (strchr "𝌆𝌇𝌈𝌉" #"c"), + SC2 = (strchr "𝌆𝌇𝌈𝌉" (strsub "𝌆" 0)), + SC3 = (strchr "𝌆𝌇𝌈𝌉" (strsub "𝌇" 0)), + SC4 = (strchr "𝌆𝌇𝌈𝌉" (strsub "𝌈" 0)), + SC5 = (strchr "𝌆𝌇𝌈𝌉" (strsub "𝌉" 0)), + + SI1 = (strindex "𝌆𝌇𝌈𝌉" #"c"), + SI2 = (strindex "𝌆𝌇𝌈𝌉" (strsub "𝌆" 0)), + SI3 = (strindex "𝌆𝌇𝌈𝌉" (strsub "𝌇" 0)), + SI4 = (strindex "𝌆𝌇𝌈𝌉" (strsub "𝌈" 0)), + SI5 = (strindex "𝌆𝌇𝌈𝌉" (strsub "𝌉" 0)), + + SSI1 = (strsindex "𝌆𝌇𝌈𝌉" ""), + SSI2 = (strsindex "𝌆𝌇𝌈𝌉" "𝌆𝌇𝌈𝌉"), + SSI3 = (strsindex "𝌆𝌇𝌈𝌉" "𝌆𝌇𝌈c"), + SSI4 = (strsindex "𝌆𝌇𝌈𝌉" "𝌇𝌈𝌉"), + SSI5 = (strsindex "𝌆𝌇𝌈𝌉" "𝌇𝌈c"), + SSI6 = (strsindex "𝌆𝌇𝌈𝌉" "𝌈𝌉"), + SSI7 = (strsindex "𝌆𝌇𝌈𝌉" "𝌈c"), + SSI8 = (strsindex "𝌆𝌇𝌈𝌉" "𝌉"), + SSI9 = (strsindex "𝌆𝌇𝌈𝌉" "c"), + + SCSP1 = (strcspn "𝌆𝌇𝌈𝌉" ""), + SCSP2 = (strcspn "𝌆𝌇𝌈𝌉" "𝌆𝌇𝌈𝌉"), + SCSP3 = (strcspn "𝌆𝌇𝌈𝌉" "𝌆"), + SCSP4 = (strcspn "𝌆𝌇𝌈𝌉" "𝌇𝌈𝌉"), + SCSP5 = (strcspn "𝌆𝌇𝌈𝌉" "𝌈𝌉"), + SCSP6 = (strcspn "𝌆𝌇𝌈𝌉" "𝌉"), + + OSS1 = (ord (strsub "𝌆𝌇𝌈𝌉" 0)), + OSS2 = (ord (strsub "𝌆𝌇𝌈𝌉" 1)), + OSS3 = (ord (strsub "𝌆𝌇𝌈𝌉" 2)), + OSS4 = (ord (strsub "𝌆𝌇𝌈𝌉" 3)), + + SSS1 = (show (strsub "𝌆𝌇𝌈𝌉" 0)), + SSS2 = (show (strsub "𝌆𝌇𝌈𝌉" 1)), + SSS3 = (show (strsub "𝌆𝌇𝌈𝌉" 2)), + SSS4 = (show (strsub "𝌆𝌇𝌈𝌉" 3)) + } + +fun highencode () : transaction page = + t <- source None; + return <xml> + <body onload={tests <- rpc (generateTests ()); set t (Some tests); return ()}> + + <dyn signal={tests' <- signal t; + case tests' of + None => return <xml></xml> + | Some tests => return <xml> + + {test_fn_cside (fn _ => strlen "𝌆𝌇𝌈𝌉") tests.SL1 "high encode - strlen 1"} + {test_fn_cside (fn _ => strlen "𝌇𝌈𝌉") tests.SL2 "high encode - strlen 2"} + {test_fn_cside (fn _ => strlen "𝌈𝌉") tests.SL3 "high encode - strlen 3"} + {test_fn_cside (fn _ => strlen "𝌉") tests.SL4 "high encode - strlen 4"} + + {test_fn_cside (fn _ => substring "𝌆𝌇𝌈𝌉" 1 3) tests.SS1 "high encode - substring 1"} + {test_fn_cside (fn _ => substring "𝌆𝌇𝌈𝌉" 2 2) tests.SS2 "high encode - substring 2"} + {test_fn_cside (fn _ => substring "𝌆𝌇𝌈𝌉" 3 1) tests.SS3 "high encode - substring 3"} + + {test_fn_cside (fn _ => strlen (substring "𝌆𝌇𝌈𝌉" 1 3)) tests.SLSS1 "high encode - strlen of substring 1"} + {test_fn_cside (fn _ => strlen (substring "𝌆𝌇𝌈𝌉" 2 2)) tests.SLSS2 "high encode - strlen of substring 2"} + {test_fn_cside (fn _ => strlen (substring "𝌆𝌇𝌈𝌉" 3 1)) tests.SLSS3 "high encode - strlen of substring 3"} + + {test_fn_cside (fn _ => strsub "𝌆𝌇𝌈𝌉" 0) tests.SSB1 "high encode - strsub 1"} + {test_fn_cside (fn _ => strsub "𝌆𝌇𝌈𝌉" 1) tests.SSB2 "high encode - strsub 2"} + {test_fn_cside (fn _ => strsub "𝌆𝌇𝌈𝌉" 2) tests.SSB3 "high encode - strsub 3"} + {test_fn_cside (fn _ => strsub "𝌆𝌇𝌈𝌉" 3) tests.SSB4 "high encode - strsub 4"} + + {test_fn_cside (fn _ => strsuffix "𝌆𝌇𝌈𝌉" 0) tests.SSF1 "high encode - strsuffix 1"} + {test_fn_cside (fn _ => strsuffix "𝌆𝌇𝌈𝌉" 1) tests.SSF2 "high encode - strsuffix 2"} + {test_fn_cside (fn _ => strsuffix "𝌆𝌇𝌈𝌉" 2) tests.SSF3 "high encode - strsuffix 3"} + {test_fn_cside (fn _ => strsuffix "𝌆𝌇𝌈𝌉" 3) tests.SSF4 "high encode - strsuffix 4"} + + {test_fn_cside (fn _ => strchr "𝌆𝌇𝌈𝌉" #"c") tests.SC1 "high encode - strchr 1"} + {test_fn_cside (fn _ => strchr "𝌆𝌇𝌈𝌉" (strsub "𝌆" 0)) tests.SC2 "high encode - strchr 2"} + {test_fn_cside (fn _ => strchr "𝌆𝌇𝌈𝌉" (strsub "𝌇" 0)) tests.SC3 "high encode - strchr 3"} + {test_fn_cside (fn _ => strchr "𝌆𝌇𝌈𝌉" (strsub "𝌈" 0)) tests.SC4 "high encode - strchr 4"} + {test_fn_cside (fn _ => strchr "𝌆𝌇𝌈𝌉" (strsub "𝌉" 0)) tests.SC5 "high encode - strchr 5"} + + {test_fn_cside (fn _ => strindex "𝌆𝌇𝌈𝌉" #"c") tests.SI1 "high encode - strindex 1"} + {test_fn_cside (fn _ => strindex "𝌆𝌇𝌈𝌉" (strsub "𝌆" 0)) tests.SI2 "high encode - strindex 2"} + {test_fn_cside (fn _ => strindex "𝌆𝌇𝌈𝌉" (strsub "𝌇" 0)) tests.SI3 "high encode - strindex 3"} + {test_fn_cside (fn _ => strindex "𝌆𝌇𝌈𝌉" (strsub "𝌈" 0)) tests.SI4 "high encode - strindex 4"} + {test_fn_cside (fn _ => strindex "𝌆𝌇𝌈𝌉" (strsub "𝌉" 0)) tests.SI5 "high encode - strindex 5"} + + {test_fn_cside (fn _ => strsindex "𝌆𝌇𝌈𝌉" "") tests.SSI1 "high encode - strsindex 1"} + {test_fn_cside (fn _ => strsindex "𝌆𝌇𝌈𝌉" "𝌆𝌇𝌈𝌉") tests.SSI2 "high encode - strsindex 2"} + {test_fn_cside (fn _ => strsindex "𝌆𝌇𝌈𝌉" "𝌆𝌇𝌈c") tests.SSI3 "high encode - strsindex 3"} + {test_fn_cside (fn _ => strsindex "𝌆𝌇𝌈𝌉" "𝌇𝌈𝌉") tests.SSI4 "high encode - strsindex 4"} + {test_fn_cside (fn _ => strsindex "𝌆𝌇𝌈𝌉" "𝌇𝌈c") tests.SSI5 "high encode - strsindex 5"} + {test_fn_cside (fn _ => strsindex "𝌆𝌇𝌈𝌉" "𝌈𝌉") tests.SSI6 "high encode - strsindex 6"} + {test_fn_cside (fn _ => strsindex "𝌆𝌇𝌈𝌉" "𝌈c") tests.SSI7 "high encode - strsindex 7"} + {test_fn_cside (fn _ => strsindex "𝌆𝌇𝌈𝌉" "𝌉") tests.SSI8 "high encode - strsindex 8"} + {test_fn_cside (fn _ => strsindex "𝌆𝌇𝌈𝌉" "c") tests.SSI9 "high encode - strsindex 9"} + + {test_fn_cside (fn _ => strcspn "𝌆𝌇𝌈𝌉" "") tests.SCSP1 "high encode - strcspn 1"} + {test_fn_cside (fn _ => strcspn "𝌆𝌇𝌈𝌉" "𝌆𝌇𝌈𝌉") tests.SCSP2 "high encode - strcspn 2"} + {test_fn_cside (fn _ => strcspn "𝌆𝌇𝌈𝌉" "𝌆") tests.SCSP3 "high encode - strcspn 3"} + {test_fn_cside (fn _ => strcspn "𝌆𝌇𝌈𝌉" "𝌇𝌈𝌉") tests.SCSP4 "high encode - strcspn 4"} + {test_fn_cside (fn _ => strcspn "𝌆𝌇𝌈𝌉" "𝌈𝌉") tests.SCSP5 "high encode - strcspn 5"} + {test_fn_cside (fn _ => strcspn "𝌆𝌇𝌈𝌉" "𝌉") tests.SCSP6 "high encode - strcspn 6"} + + {test_fn_cside (fn _ => ord (strsub "𝌆𝌇𝌈𝌉" 0)) tests.OSS1 "high encode - ord 1"} + {test_fn_cside (fn _ => ord (strsub "𝌆𝌇𝌈𝌉" 1)) tests.OSS2 "high encode - ord 2"} + {test_fn_cside (fn _ => ord (strsub "𝌆𝌇𝌈𝌉" 2)) tests.OSS3 "high encode - ord 3"} + {test_fn_cside (fn _ => ord (strsub "𝌆𝌇𝌈𝌉" 3)) tests.OSS4 "high encode - ord 4"} + + {test_fn_cside (fn _ => show (strsub "𝌆𝌇𝌈𝌉" 0)) tests.SSS1 "high encode - show 1"} + {test_fn_cside (fn _ => show (strsub "𝌆𝌇𝌈𝌉" 1)) tests.SSS2 "high encode - show 2"} + {test_fn_cside (fn _ => show (strsub "𝌆𝌇𝌈𝌉" 2)) tests.SSS3 "high encode - show 3"} + {test_fn_cside (fn _ => show (strsub "𝌆𝌇𝌈𝌉" 3)) tests.SSS4 "high encode - show 4"} + + </xml> } /> + + </body> + </xml> + +(* substrings *) +fun substring1 _ = substring "abc" 0 3 +fun substring2 _ = substring "abc" 1 2 +fun substring3 _ = substring "abc" 2 1 +fun substring4 _ = substring "ábó" 0 3 +fun substring5 _ = substring "ábó" 1 2 +fun substring6 _ = substring "ábó" 2 1 +fun substring7 _ = substring "ábó" 0 2 +fun substring8 _ = substring "ábó" 0 1 +fun substring9 _ = substring "" 0 0 + +fun substringsserver _ = + return { + T1 = substring1 (), + T2 = substring2 (), + T3 = substring3 (), + T4 = substring4 (), + T5 = substring5 (), + T6 = substring6 (), + T7 = substring7 (), + T8 = substring8 (), + T9 = substring9 () + } + +fun substrings () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (substringsserver ()); + set t (Some r); + return () }> + + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => + return <xml> + {test_fn_both_sides2 substring1 t'.T1 "abc" "substrings 1"} + {test_fn_both_sides2 substring2 t'.T2 "bc" "substrings 2"} + {test_fn_both_sides2 substring3 t'.T3 "c" "substrings 3"} + {test_fn_both_sides2 substring4 t'.T4 "ábó" "substrings 4"} + {test_fn_both_sides2 substring5 t'.T5 "bó" "substrings 5"} + {test_fn_both_sides2 substring6 t'.T6 "ó" "substrings 6"} + {test_fn_both_sides2 substring7 t'.T7 "áb" "substrings 7"} + {test_fn_both_sides2 substring8 t'.T8 "á" "substrings 8"} + {test_fn_both_sides2 substring9 t'.T9 "" "substrings 9"} + </xml> + } /> + </body> + </xml> + +(* strlen *) +fun strlen1 _ = strlen "abc" +fun strlen2 _ = strlen "çbc" +fun strlen3 _ = strlen "çãc" +fun strlen4 _ = strlen "çãó" +fun strlen5 _ = strlen "ç" +fun strlen6 _ = strlen "c" +fun strlen7 _ = strlen "" +fun strlen8 _ = strlen "が" +fun strlen9 _ = strlen "漢" +fun strlen10 _ = strlen "カ" +fun strlen11 _ = strlen "وظيفية" +fun strlen12 _ = strlen "函數" +fun strlen13 _ = strlen "Функциональное" + +fun strlensserver _ = + return { + T1 = strlen1 (), + T2 = strlen2 (), + T3 = strlen3 (), + T4 = strlen4 (), + T5 = strlen5 (), + T6 = strlen6 (), + T7 = strlen7 (), + T8 = strlen8 (), + T9 = strlen9 (), + T10 = strlen10 (), + T11 = strlen11 (), + T12 = strlen12 (), + T13 = strlen13 () + } + +fun strlens () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (strlensserver()); + set t (Some r); + return ()}> + + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => + return <xml> + {test_fn_both_sides2 strlen1 t'.T1 3 "strlen 1"} + {test_fn_both_sides2 strlen2 t'.T2 3 "strlen 2"} + {test_fn_both_sides2 strlen3 t'.T3 3 "strlen 3"} + {test_fn_both_sides2 strlen4 t'.T4 3 "strlen 4"} + {test_fn_both_sides2 strlen5 t'.T5 1 "strlen 5"} + {test_fn_both_sides2 strlen6 t'.T6 1 "strlen 6"} + {test_fn_both_sides2 strlen7 t'.T7 0 "strlen 7"} + {test_fn_both_sides2 strlen8 t'.T8 1 "strlen 8"} + {test_fn_both_sides2 strlen9 t'.T9 1 "strlen 9"} + {test_fn_both_sides2 strlen10 t'.T10 1 "strlen 10"} + {test_fn_both_sides2 strlen11 t'.T11 6 "strlen 11"} + {test_fn_both_sides2 strlen12 t'.T12 2 "strlen 12"} + {test_fn_both_sides2 strlen13 t'.T13 14 "strlen 13"} + </xml>} /> + + </body> + </xml> + +(* strlenGe *) +fun strlenGe1 _ = strlenGe "" 1 +fun strlenGe2 _ = strlenGe "" 0 +fun strlenGe3 _ = strlenGe "aba" 4 +fun strlenGe4 _ = strlenGe "aba" 3 +fun strlenGe5 _ = strlenGe "aba" 2 +fun strlenGe6 _ = strlenGe "àçá" 4 +fun strlenGe7 _ = strlenGe "àçá" 3 +fun strlenGe8 _ = strlenGe "àçá" 2 + +fun strleGesserver _ = return { + T1 = strlenGe1 (), + T2 = strlenGe2 (), + T3 = strlenGe3 (), + T4 = strlenGe4 (), + T5 = strlenGe5 (), + T6 = strlenGe6 (), + T7 = strlenGe7 (), + T8 = strlenGe8 () + } + +fun strlenGens () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (strleGesserver()); + set t (Some r); + return ()}> + + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => + return <xml> + {test_fn_both_sides2 strlenGe1 t'.T1 False "strlenGe 1"} + {test_fn_both_sides2 strlenGe2 t'.T2 True "strlenGe 2"} + {test_fn_both_sides2 strlenGe3 t'.T3 False "strlenGe 3"} + {test_fn_both_sides2 strlenGe4 t'.T4 True "strlenGe 4"} + {test_fn_both_sides2 strlenGe5 t'.T5 True "strlenGe 5"} + {test_fn_both_sides2 strlenGe6 t'.T6 False "strlenGe 6"} + {test_fn_both_sides2 strlenGe7 t'.T7 True "strlenGe 7"} + {test_fn_both_sides2 strlenGe8 t'.T8 True "strlenGe 8"} + </xml>} /> + </body> + </xml> + +type clen = { S : string, L : int } + +val clen_eq : eq clen = mkEq (fn a b => + a.S = b.S && a.L = b.L) + +val clen_show : show clen = mkShow (fn a => + "{S = " ^ a.S ^ ", L = " ^ (show a.L) ^ "}") +(* strcat *) + +fun teststrcat a b = let val c = strcat a b in {S = c, L = strlen c} end +fun teststrcat1 _ = teststrcat "" "" +fun teststrcat2 _ = teststrcat "aa" "bb" +fun teststrcat3 _ = teststrcat "" "bb" +fun teststrcat4 _ = teststrcat "aa" "" +fun teststrcat5 _ = teststrcat "àà" "áá" +fun teststrcat6 _ = teststrcat "" "áá" +fun teststrcat7 _ = teststrcat "àà" "" +fun teststrcat8 _ = teststrcat "函數" "ãã" +fun teststrcat9 _ = teststrcat "ç" "ã" +fun teststrcat10 _ = teststrcat (show (strsub "ç" 0)) (show (strsub "ã" 0)) +fun teststrcat11 _ = teststrcat (show (chr 231)) (show (chr 227)) + +fun strcatsserver () = + return { + T1 = teststrcat1 (), + T2 = teststrcat2 (), + T3 = teststrcat3 (), + T4 = teststrcat4 (), + T5 = teststrcat5 (), + T6 = teststrcat6 (), + T7 = teststrcat7 (), + T8 = teststrcat8 (), + T9 = teststrcat9 (), + T10 = teststrcat10 (), + T11 = teststrcat11 () + } + +fun strcats () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (strcatsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 teststrcat1 t'.T1 {S="",L=0} "strcat 1" } + {test_fn_both_sides2 teststrcat2 t'.T2 {S="aabb",L=4} "strcat 2" } + {test_fn_both_sides2 teststrcat3 t'.T3 {S="bb",L=2} "strcat 3" } + {test_fn_both_sides2 teststrcat4 t'.T4 {S="aa",L=2} "strcat 4" } + {test_fn_both_sides2 teststrcat5 t'.T5 {S="ààáá",L=4} "strcat 5" } + {test_fn_both_sides2 teststrcat6 t'.T6 {S="áá",L=2} "strcat 6" } + {test_fn_both_sides2 teststrcat7 t'.T7 {S="àà",L=2} "strcat 7" } + {test_fn_both_sides2 teststrcat8 t'.T8 {S="函數ãã",L=4} "strcat 8" } + {test_fn_both_sides2 teststrcat9 t'.T9 {S="çã",L=2} "strcat 9" } + {test_fn_both_sides2 teststrcat10 t'.T10 {S="çã",L=2} "strcat 10" } + {test_fn_both_sides2 teststrcat11 t'.T11 {S="çã",L=2} "strcat 11" } + </xml>} /> + </body> + </xml> + +(* strsubs *) + +fun strsub1 _ = strsub "abàç" 0 +fun strsub2 _ = strsub "abàç" 1 +fun strsub3 _ = strsub "àb" 0 +fun strsub4 _ = strsub "abàç" 2 +fun strsub5 _ = strsub "abàç" 3 + +fun strsubsserver _ = return { + T1 = strsub1 (), + T2 = strsub2 (), + T3 = strsub3 (), + T4 = strsub4 (), + T5 = strsub5 () + } + +fun strsubs () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (strsubsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 strsub1 t'.T1 #"a" "strsub 1"} + {test_fn_both_sides2 strsub2 t'.T2 #"b" "strsub 2"} + {test_fn_both_sides2 strsub3 t'.T3 (strsub "à" 0) "strsub 3"} + {test_fn_both_sides2 strsub4 t'.T4 (strsub "à" 0) "strsub 4"} + {test_fn_both_sides2 strsub5 t'.T5 (strsub "ç" 0) "strsub 5"} + </xml> + } /> + + </body> + </xml> + +(* strsuffixs *) +fun strsuffix1 _ = strsuffix "abàç" 0 +fun strsuffix2 _ = strsuffix "abàç" 1 +fun strsuffix3 _ = strsuffix "abàç" 2 +fun strsuffix4 _ = strsuffix "abàç" 3 + +fun strsuffixsserver _ = + return { + T1 = strsuffix1 (), + T2 = strsuffix2 (), + T3 = strsuffix3 (), + T4 = strsuffix4 () + } + +fun strsuffixs () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (strsuffixsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 strsuffix1 t'.T1 "abàç" "strsuffix 1"} + {test_fn_both_sides2 strsuffix2 t'.T2 "bàç" "strsuffix 2"} + {test_fn_both_sides2 strsuffix3 t'.T3 "àç" "strsuffix 3"} + {test_fn_both_sides2 strsuffix4 t'.T4 "ç" "strsuffix 4"} + </xml> + } /> + + </body> + </xml> + +(* strchrs *) + +fun strchr1 _ = strchr "abàç" #"c" +fun strchr2 _ = strchr "abàç" #"a" +fun strchr3 _ = strchr "abàç" #"b" +fun strchr4 _ = strchr "abàç" (strsub "à" 0) +fun strchr5 _ = strchr "abàç" (strsub "ç" 0) + +fun strchrssserver _ = + return { + T1 = strchr1 (), + T2 = strchr2 (), + T3 = strchr3 (), + T4 = strchr4 (), + T5 = strchr5 () + } + +fun strchrs () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (strchrssserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 strchr1 t'.T1 None "strchr 1"} + {test_fn_both_sides2 strchr2 t'.T2 (Some "abàç") "strchr 2"} + {test_fn_both_sides2 strchr3 t'.T3 (Some "bàç") "strchr 3"} + {test_fn_both_sides2 strchr4 t'.T4 (Some "àç") "strchr 4"} + {test_fn_both_sides2 strchr5 t'.T5 (Some "ç") "strchr 5"} + </xml> + } /> + + </body> + </xml> + +(* strindexs *) +fun strindex1 _ = strindex "abàç" #"c" +fun strindex2 _ = strindex "abàç" #"a" +fun strindex3 _ = strindex "abàç" #"b" +fun strindex4 _ = strindex "abàç" (strsub "à" 0) +fun strindex5 _ = strindex "abàç" (strsub "ç" 0) + +fun strindexsserver _ = + return { + T1 = strindex1 (), + T2 = strindex2 (), + T3 = strindex3 (), + T4 = strindex4 (), + T5 = strindex5 () + } + +fun strindexs () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (strindexsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 strindex1 t'.T1 None "strindex 1"} + {test_fn_both_sides2 strindex2 t'.T2 (Some 0) "strindex 2"} + {test_fn_both_sides2 strindex3 t'.T3 (Some 1) "strindex 3"} + {test_fn_both_sides2 strindex4 t'.T4 (Some 2) "strindex 4"} + {test_fn_both_sides2 strindex5 t'.T5 (Some 3) "strindex 5"} + </xml> + } /> + + </body> + </xml> + +(*strsindexs*) +fun strsindex1 _ = strsindex "abàç" "" +fun strsindex2 _ = strsindex "abàç" "abàç" +fun strsindex3 _ = strsindex "abàç" "abàc" +fun strsindex4 _ = strsindex "abàç" "bàç" +fun strsindex5 _ = strsindex "abàç" "bàc" +fun strsindex6 _ = strsindex "abàç" "àç" +fun strsindex7 _ = strsindex "abàç" "àc" +fun strsindex8 _ = strsindex "abàç" "ç" +fun strsindex9 _ = strsindex "abàç" "c" + +fun strsindexsserver _ = + return { + T1 = strsindex1 (), + T2 = strsindex2 (), + T3 = strsindex3 (), + T4 = strsindex4 (), + T5 = strsindex5 (), + T6 = strsindex6 (), + T7 = strsindex7 (), + T8 = strsindex8 (), + T9 = strsindex9 () + } + +fun strsindexs () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (strsindexsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 strsindex1 t'.T1 (Some 0) "strsindex 1"} + {test_fn_both_sides2 strsindex2 t'.T2 (Some 0) "strsindex 2"} + {test_fn_both_sides2 strsindex3 t'.T3 None "strsindex 3"} + {test_fn_both_sides2 strsindex4 t'.T4 (Some 1) "strsindex 4"} + {test_fn_both_sides2 strsindex5 t'.T5 None "strsindex 5"} + {test_fn_both_sides2 strsindex6 t'.T6 (Some 2) "strsindex 6"} + {test_fn_both_sides2 strsindex7 t'.T7 None "strsindex 7"} + {test_fn_both_sides2 strsindex8 t'.T8 (Some 3) "strsindex 8"} + {test_fn_both_sides2 strsindex9 t'.T9 None "strsindex 9"} + </xml> + } /> + + </body> + </xml> + +(*strcspns*) +fun strcspn1 _ = strcspn "abàç" "" +fun strcspn2 _ = strcspn "abàç" "abàç" +fun strcspn3 _ = strcspn "abàç" "a" +fun strcspn4 _ = strcspn "abàç" "bà" +fun strcspn5 _ = strcspn "abàç" "àç" +fun strcspn6 _ = strcspn "abàç" "ç" + +fun strcspnsserver _ = + return { + T1 = strcspn1 (), + T2 = strcspn2 (), + T3 = strcspn3 (), + T4 = strcspn4 (), + T5 = strcspn5 (), + T6 = strcspn6 () + } + +fun strcspns () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (strcspnsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 strcspn1 t'.T1 4 "strcspn 1"} + {test_fn_both_sides2 strcspn2 t'.T2 0 "strcspn 2"} + {test_fn_both_sides2 strcspn3 t'.T3 0 "strcspn 3"} + {test_fn_both_sides2 strcspn4 t'.T4 1 "strcspn 4"} + {test_fn_both_sides2 strcspn5 t'.T5 2 "strcspn 5"} + {test_fn_both_sides2 strcspn6 t'.T6 3 "strcspn 6"} + </xml> + } /> + + </body> + </xml> + +(* str1 *) +fun str11 _ = str1 #"a" +fun str12 _ = str1 (strsub "à" 0) +fun str13 _ = str1 (strsub "aá" 1) + +fun str1server _ = + return { + T1 = str11 (), + T2 = str12 (), + T3 = str13 () + } + +fun str1s () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (str1server ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 str11 t'.T1 "a" "str1 1"} + {test_fn_both_sides2 str12 t'.T2 "à" "str1 2"} + {test_fn_both_sides2 str13 t'.T3 "á" "str1 3"} + </xml> + } /> + + </body> + </xml> + +(* isalnum *) + +fun isalnum1 _ = isalnum #"a" +fun isalnum2 _ = isalnum #"a" +fun isalnum3 _ = isalnum (strsub "à" 0) +fun isalnum4 _ = isalnum #"A" +fun isalnum5 _ = isalnum (strsub "À" 0) +fun isalnum6 _ = isalnum #"1" +fun isalnum7 _ = not (isalnum #"!") +fun isalnum8 _ = not (isalnum #"#") +fun isalnum9 _ = not (isalnum #" ") + +fun isalnumsserver _ = return { + T1 = isalnum1 (), + T2 = isalnum2 (), + T3 = isalnum3 (), + T4 = isalnum4 (), + T5 = isalnum5 (), + T6 = isalnum6 (), + T7 = isalnum7 (), + T8 = isalnum8 (), + T9 = isalnum9 () + } + +fun isalnums () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (isalnumsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 isalnum1 t'.T1 True "isalnum 1"} + {test_fn_both_sides2 isalnum2 t'.T2 True "isalnum 2"} + {test_fn_both_sides2 isalnum3 t'.T3 True "isalnum 3"} + {test_fn_both_sides2 isalnum4 t'.T4 True "isalnum 4"} + {test_fn_both_sides2 isalnum5 t'.T5 True "isalnum 5"} + {test_fn_both_sides2 isalnum6 t'.T6 True "isalnum 6"} + {test_fn_both_sides2 isalnum7 t'.T7 True "isalnum 7"} + {test_fn_both_sides2 isalnum8 t'.T8 True "isalnum 8"} + {test_fn_both_sides2 isalnum9 t'.T9 True "isalnum 9"} + </xml> + } /> + + </body> + </xml> + +(* isalpha *) +fun isalpha1 _ = isalpha #"a" +fun isalpha2 _ = isalpha (strsub "à" 0) +fun isalpha3 _ = isalpha #"A" +fun isalpha4 _ = isalpha (strsub "À" 0) +fun isalpha5 _ = not (isalpha #"1") +fun isalpha6 _ = not (isalpha #"!") +fun isalpha7 _ = not (isalpha #"#") +fun isalpha8 _ = not (isalpha #" ") + +fun isalphasserver () = + return { + T1 = isalpha1 (), + T2 = isalpha2 (), + T3 = isalpha3 (), + T4 = isalpha4 (), + T5 = isalpha5 (), + T6 = isalpha6 (), + T7 = isalpha7 (), + T8 = isalpha8 () + } + +fun isalphas () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (isalphasserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 isalpha1 t'.T1 True "isalpha 1"} + {test_fn_both_sides2 isalpha2 t'.T2 True "isalpha 2"} + {test_fn_both_sides2 isalpha3 t'.T3 True "isalpha 3"} + {test_fn_both_sides2 isalpha4 t'.T4 True "isalpha 4"} + {test_fn_both_sides2 isalpha5 t'.T5 True "isalpha 5"} + {test_fn_both_sides2 isalpha6 t'.T6 True "isalpha 6"} + {test_fn_both_sides2 isalpha7 t'.T7 True "isalpha 7"} + {test_fn_both_sides2 isalpha8 t'.T8 True "isalpha 8"} + </xml> + } /> + + </body> +</xml> + +(* isblanks *) +fun isblank1 _ = not (isblank #"a") +fun isblank2 _ = not (isblank (strsub "à" 0)) +fun isblank3 _ = not (isblank #"A") +fun isblank4 _ = not (isblank (strsub "À" 0)) +fun isblank5 _ = not (isblank #"1") +fun isblank6 _ = not (isblank #"!") +fun isblank7 _ = not (isblank #"#") +fun isblank8 _ = isblank #" " +fun isblank9 _ = isblank #"\t" +fun isblank10 _ = not (isblank #"\n") + +fun isblanksserver _ = + return { + T1 = isblank1 (), + T2 = isblank2 (), + T3 = isblank3 (), + T4 = isblank4 (), + T5 = isblank5 (), + T6 = isblank6 (), + T7 = isblank7 (), + T8 = isblank8 (), + T9 = isblank9 (), + T10 = isblank10 () + } + +fun isblanks () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (isblanksserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 isblank1 t'.T1 True "isblank 1"} + {test_fn_both_sides2 isblank2 t'.T2 True "isblank 2"} + {test_fn_both_sides2 isblank3 t'.T3 True "isblank 3"} + {test_fn_both_sides2 isblank4 t'.T4 True "isblank 4"} + {test_fn_both_sides2 isblank5 t'.T5 True "isblank 5"} + {test_fn_both_sides2 isblank6 t'.T6 True "isblank 6"} + {test_fn_both_sides2 isblank7 t'.T7 True "isblank 7"} + {test_fn_both_sides2 isblank8 t'.T8 True "isblank 8"} + {test_fn_both_sides2 isblank9 t'.T9 True "isblank 9"} + {test_fn_both_sides2 isblank10 t'.T10 True "isblank 10"} + </xml> + } /> + + </body> + </xml> + +(* iscntrls *) +fun iscntrl1 _ = not (iscntrl #"a") +fun iscntrl2 _ = not (iscntrl (strsub "à" 0)) +fun iscntrl3 _ = not (iscntrl #"A") +fun iscntrl4 _ = not (iscntrl (strsub "À" 0)) +fun iscntrl5 _ = not (iscntrl #"1") +fun iscntrl6 _ = not (iscntrl #"!") +fun iscntrl7 _ = not (iscntrl #"#") +fun iscntrl8 _ = not (iscntrl #" ") +fun iscntrl9 _ = iscntrl #"\t" +fun iscntrl10 _ = iscntrl #"\n" + +fun iscntrls () : transaction page = + return <xml> + <body> + {test_fn_sside iscntrl1 True "iscntrl 1"} + {test_fn_sside iscntrl2 True "iscntrl 2"} + {test_fn_sside iscntrl3 True "iscntrl 3"} + {test_fn_sside iscntrl4 True "iscntrl 4"} + {test_fn_sside iscntrl5 True "iscntrl 5"} + {test_fn_sside iscntrl6 True "iscntrl 6"} + {test_fn_sside iscntrl7 True "iscntrl 7"} + {test_fn_sside iscntrl8 True "iscntrl 8"} + {test_fn_sside iscntrl9 True "iscntrl 9"} + {test_fn_sside iscntrl10 True "iscntrl 10"} + </body> + </xml> + +(* isdigits *) +fun isdigit1 _ = not (isdigit #"a") +fun isdigit2 _ = not (isdigit (strsub "à" 0)) +fun isdigit3 _ = not (isdigit #"A") +fun isdigit4 _ = not (isdigit (strsub "À" 0)) +fun isdigit5 _ = isdigit #"1" +fun isdigit6 _ = not (isdigit #"!") +fun isdigit7 _ = not (isdigit #"#") +fun isdigit8 _ = not (isdigit #" ") +fun isdigit9 _ = not (isdigit #"\t") +fun isdigit10 _ = not (isdigit #"\n") + +fun isdigitsserver _ = + return { + T1 = isdigit1 (), + T2 = isdigit2 (), + T3 = isdigit3 (), + T4 = isdigit4 (), + T5 = isdigit5 (), + T6 = isdigit6 (), + T7 = isdigit7 (), + T8 = isdigit8 (), + T9 = isdigit9 (), + T10 = isdigit10 () + } + +fun isdigits () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (isdigitsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 isdigit1 t'.T1 True "isdigit 1"} + {test_fn_both_sides2 isdigit2 t'.T2 True "isdigit 2"} + {test_fn_both_sides2 isdigit3 t'.T3 True "isdigit 3"} + {test_fn_both_sides2 isdigit4 t'.T4 True "isdigit 4"} + {test_fn_both_sides2 isdigit5 t'.T5 True "isdigit 5"} + {test_fn_both_sides2 isdigit6 t'.T6 True "isdigit 6"} + {test_fn_both_sides2 isdigit7 t'.T7 True "isdigit 7"} + {test_fn_both_sides2 isdigit8 t'.T8 True "isdigit 8"} + {test_fn_both_sides2 isdigit9 t'.T9 True "isdigit 9"} + {test_fn_both_sides2 isdigit10 t'.T10 True "isdigit 10"} + </xml> + } /> + + + </body> + </xml> + +fun isgraphs () : transaction page = + return <xml> + <body> + {test_fn_sside (fn _ => isgraph #"a") True "isgraph 1"} + {test_fn_sside (fn _ => isgraph (strsub "à" 0)) True "isgraph 2"} + {test_fn_sside (fn _ => isgraph #"A") True "isgraph 3"} + {test_fn_sside (fn _ => isgraph (strsub "À" 0)) True "isgraph 4"} + {test_fn_sside (fn _ => isgraph #"1") True "isgraph 5"} + {test_fn_sside (fn _ => isgraph #"!") True "isgraph 6"} + {test_fn_sside (fn _ => isgraph #"#") True "isgraph 7"} + {test_fn_sside (fn _ => not (isgraph #" ")) True "isgraph 8"} + {test_fn_sside (fn _ => not (isgraph #"\t")) True "isgraph 9"} + {test_fn_sside (fn _ => not (isdigit #"\n")) True "isgraph 10"} + </body> + </xml> + +(* islowers *) +fun islower1 _ = islower #"a" +fun islower2 _ = islower (strsub "à" 0) +fun islower3 _ = not (islower #"A") +fun islower4 _ = not (islower (strsub "À" 0)) +fun islower5 _ = not (islower #"1") +fun islower6 _ = not (islower #"!") +fun islower7 _ = not (islower #"#") +fun islower8 _ = not (islower #" ") +fun islower9 _ = not (islower #"\t") +fun islower10 _ = not (islower #"\n") + +fun islowersserver _ = + return { + T1 = islower1 (), + T2 = islower2 (), + T3 = islower3 (), + T4 = islower4 (), + T5 = islower5 (), + T6 = islower6 (), + T7 = islower7 (), + T8 = islower8 (), + T9 = islower9 (), + T10 = islower10 () + } + +fun islowers () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (islowersserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 islower1 t'.T1 True "islower 1"} + {test_fn_both_sides2 islower2 t'.T2 True "islower 2"} + {test_fn_both_sides2 islower3 t'.T3 True "islower 3"} + {test_fn_both_sides2 islower4 t'.T4 True "islower 4"} + {test_fn_both_sides2 islower5 t'.T5 True "islower 5"} + {test_fn_both_sides2 islower6 t'.T6 True "islower 6"} + {test_fn_both_sides2 islower7 t'.T7 True "islower 7"} + {test_fn_both_sides2 islower8 t'.T8 True "islower 8"} + {test_fn_both_sides2 islower9 t'.T9 True "islower 9"} + {test_fn_both_sides2 islower10 t'.T10 True "islower 10"} + </xml> + } /> + </body> + </xml> + +(* isprint *) +fun isprint1 _ = isprint #"a" +fun isprint2 _ = isprint (strsub "à" 0) +fun isprint3 _ = isprint #"A" +fun isprint4 _ = isprint (strsub "À" 0) +fun isprint5 _ = isprint #"1" +fun isprint6 _ = isprint #"!" +fun isprint7 _ = isprint #"#" +fun isprint8 _ = isprint #" " +fun isprint9 _ = not (isprint #"\t") +fun isprint10 _ = not (isprint #"\n") + +fun isprintsserver _ = return { + T1 = isprint1 (), + T2 = isprint2 (), + T3 = isprint3 (), + T4 = isprint4 (), + T5 = isprint5 (), + T6 = isprint6 (), + T7 = isprint7 (), + T8 = isprint8 (), + T9 = isprint9 (), + T10 = isprint10 () + } + +fun isprints () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (isprintsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 isprint1 t'.T1 True "isprint 1"} + {test_fn_both_sides2 isprint2 t'.T2 True "isprint 2"} + {test_fn_both_sides2 isprint3 t'.T3 True "isprint 3"} + {test_fn_both_sides2 isprint4 t'.T4 True "isprint 4"} + {test_fn_both_sides2 isprint5 t'.T5 True "isprint 5"} + {test_fn_both_sides2 isprint6 t'.T6 True "isprint 6"} + {test_fn_both_sides2 isprint7 t'.T7 True "isprint 7"} + {test_fn_both_sides2 isprint8 t'.T8 True "isprint 8"} + {test_fn_both_sides2 isprint9 t'.T9 True "isprint 9"} + {test_fn_both_sides2 isprint10 t'.T10 True "isprint 10"} + </xml> + } /> + </body> + </xml> + +(* ispunct *) +fun ispunct1 _ = not (ispunct #"a") +fun ispunct2 _ = not (ispunct (strsub "à" 0)) +fun ispunct3 _ = not (ispunct #"A") +fun ispunct4 _ = not (ispunct (strsub "À" 0)) +fun ispunct5 _ = not (ispunct #"1") +fun ispunct6 _ = ispunct #"!" +fun ispunct7 _ = ispunct #"#" +fun ispunct8 _ = not (ispunct #" ") +fun ispunct9 _ = not (ispunct #"\t") +fun ispunct10 _ = not (ispunct #"\n") + +fun ispuncts () : transaction page = + return <xml> + <body> + {test_fn_sside ispunct1 True "ispunct 1"} + {test_fn_sside ispunct2 True "ispunct 2"} + {test_fn_sside ispunct3 True "ispunct 3"} + {test_fn_sside ispunct4 True "ispunct 4"} + {test_fn_sside ispunct5 True "ispunct 5"} + {test_fn_sside ispunct6 True "ispunct 6"} + {test_fn_sside ispunct7 True "ispunct 7"} + {test_fn_sside ispunct8 True "ispunct 8"} + {test_fn_sside ispunct9 True "ispunct 9"} + {test_fn_sside ispunct10 True "ispunct 10"} + </body> + </xml> + +(* isspace *) +fun isspace1 _ = not (isspace #"a") +fun isspace2 _ = not (isspace (strsub "à" 0)) +fun isspace3 _ = not (isspace #"A") +fun isspace4 _ = not (isspace (strsub "À" 0)) +fun isspace5 _ = not (isspace #"1") +fun isspace6 _ = not (isspace #"!") +fun isspace7 _ = not (isspace #"#") +fun isspace8 _ = isspace #" " +fun isspace9 _ = isspace #"\t" +fun isspace10 _ = isspace #"\n" + +fun isspacesserver _ = + return { + T1 = isspace1 (), + T2 = isspace2 (), + T3 = isspace3 (), + T4 = isspace4 (), + T5 = isspace5 (), + T6 = isspace6 (), + T7 = isspace7 (), + T8 = isspace8 (), + T9 = isspace9 (), + T10 = isspace10 () + } + +fun isspaces () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (isspacesserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 isspace1 t'.T1 True "isspace 1"} + {test_fn_both_sides2 isspace2 t'.T2 True "isspace 2"} + {test_fn_both_sides2 isspace3 t'.T3 True "isspace 3"} + {test_fn_both_sides2 isspace4 t'.T4 True "isspace 4"} + {test_fn_both_sides2 isspace5 t'.T5 True "isspace 5"} + {test_fn_both_sides2 isspace6 t'.T6 True "isspace 6"} + {test_fn_both_sides2 isspace7 t'.T7 True "isspace 7"} + {test_fn_both_sides2 isspace8 t'.T8 True "isspace 8"} + {test_fn_both_sides2 isspace9 t'.T9 True "isspace 9"} + {test_fn_both_sides2 isspace10 t'.T10 True "isspace 10"} + </xml> + } /> + + </body> + </xml> + +(* isupper *) +fun isupper1 _ = not (isupper #"a") +fun isupper2 _ = not (isupper (strsub "à" 0)) +fun isupper3 _ = isupper #"A" +fun isupper4 _ = isupper (strsub "À" 0) +fun isupper5 _ = not (isupper #"1") +fun isupper6 _ = not (isupper #"!") +fun isupper7 _ = not (isupper #"#") +fun isupper8 _ = not (isupper #" ") +fun isupper9 _ = not (isupper #"\t") +fun isupper10 _ = not (isupper #"\n") + +fun isuppersserver _ = + return { + T1 = isupper1 (), + T2 = isupper2 (), + T3 = isupper3 (), + T4 = isupper4 (), + T5 = isupper5 (), + T6 = isupper6 (), + T7 = isupper7 (), + T8 = isupper8 (), + T9 = isupper9 (), + T10 = isupper10 () + } + +fun isuppers () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (isuppersserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 isupper1 t'.T1 True "isupper 1"} + {test_fn_both_sides2 isupper2 t'.T2 True "isupper 2"} + {test_fn_both_sides2 isupper3 t'.T3 True "isupper 3"} + {test_fn_both_sides2 isupper4 t'.T4 True "isupper 4"} + {test_fn_both_sides2 isupper5 t'.T5 True "isupper 5"} + {test_fn_both_sides2 isupper6 t'.T6 True "isupper 6"} + {test_fn_both_sides2 isupper7 t'.T7 True "isupper 7"} + {test_fn_both_sides2 isupper8 t'.T8 True "isupper 8"} + {test_fn_both_sides2 isupper9 t'.T9 True "isupper 9"} + {test_fn_both_sides2 isupper10 t'.T10 True "isupper 10"} + </xml> + } /> + + </body> + </xml> + +(* isxdigit *) +fun isxdigit1 _ = isxdigit #"a" +fun isxdigit2 _ = not (isxdigit (strsub "à" 0)) +fun isxdigit3 _ = isxdigit #"A" +fun isxdigit4 _ = not (isxdigit (strsub "À" 0)) +fun isxdigit5 _ = isxdigit #"1" +fun isxdigit6 _ = not (isxdigit #"!") +fun isxdigit7 _ = not (isxdigit #"#") +fun isxdigit8 _ = not (isxdigit #" ") +fun isxdigit9 _ = not (isxdigit #"\t") +fun isxdigit10 _ = not (isxdigit #"\n") + +fun isxdigitsserver _ = + return { + T1 = isxdigit1 (), + T2 = isxdigit2 (), + T3 = isxdigit3 (), + T4 = isxdigit4 (), + T5 = isxdigit5 (), + T6 = isxdigit6 (), + T7 = isxdigit7 (), + T8 = isxdigit8 (), + T9 = isxdigit9 (), + T10 = isxdigit10 () + } + +fun isxdigits () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (isxdigitsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 isxdigit1 t'.T1 True "isxdigit 1"} + {test_fn_both_sides2 isxdigit2 t'.T2 True "isxdigit 2"} + {test_fn_both_sides2 isxdigit3 t'.T3 True "isxdigit 3"} + {test_fn_both_sides2 isxdigit4 t'.T4 True "isxdigit 4"} + {test_fn_both_sides2 isxdigit5 t'.T5 True "isxdigit 5"} + {test_fn_both_sides2 isxdigit6 t'.T6 True "isxdigit 6"} + {test_fn_both_sides2 isxdigit7 t'.T7 True "isxdigit 7"} + {test_fn_both_sides2 isxdigit8 t'.T8 True "isxdigit 8"} + {test_fn_both_sides2 isxdigit9 t'.T9 True "isxdigit 9"} + {test_fn_both_sides2 isxdigit10 t'.T10 True "isxdigit 10"} + </xml> + } /> + + </body> + </xml> + +(* tolower *) + +fun tolower1 _ = tolower #"A" +fun tolower2 _ = tolower #"a" +fun tolower3 _ = tolower (strsub "á" 0) +fun tolower4 _ = tolower (strsub "Á" 0) +fun tolower5 _ = tolower #"1" +fun tolower6 _ = tolower (strsub "ß" 0) + +fun tolowersserver _ = + return { + T1 = tolower1 (), + T2 = tolower2 (), + T3 = tolower3 (), + T4 = tolower4 (), + T5 = tolower5 (), + T6 = tolower6 () + } + +fun tolowers () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (tolowersserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 tolower1 t'.T1 #"a" "tolower 1"} + {test_fn_both_sides2 tolower2 t'.T2 #"a" "tolower 2"} + {test_fn_both_sides2 tolower3 t'.T3 (strsub "á" 0) "tolower 3"} + {test_fn_both_sides2 tolower4 t'.T4 (strsub "á" 0) "tolower 4"} + {test_fn_both_sides2 tolower5 t'.T5 #"1" "tolower 5"} + {test_fn_both_sides2 tolower6 t'.T6 (strsub "ß" 0) "tolower 6"} + + </xml> + } /> + + </body> + </xml> + +(* toupper *) +fun toupper1 _ = toupper #"A" +fun toupper2 _ = toupper #"a" +fun toupper3 _ = toupper (strsub "á" 0) +fun toupper4 _ = toupper (strsub "Á" 0) +fun toupper5 _ = toupper #"1" +fun toupper6 _ = toupper (strsub "ß" 0) + +fun touppersserver _ = + return { + T1 = toupper1 (), + T2 = toupper2 (), + T3 = toupper3 (), + T4 = toupper4 (), + T5 = toupper5 (), + T6 = toupper6 () + } + +fun touppers () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (touppersserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_both_sides2 toupper1 t'.T1 #"A" "toupper 1"} + {test_fn_both_sides2 toupper2 t'.T2 #"A" "toupper 2"} + {test_fn_both_sides2 toupper3 t'.T3 (strsub "Á" 0) "toupper 3"} + {test_fn_both_sides2 toupper4 t'.T4 (strsub "Á" 0) "toupper 4"} + {test_fn_both_sides2 toupper5 t'.T5 #"1" "toupper 5"} + {test_fn_both_sides2 toupper6 t'.T6 (strsub "ß" 0) "toupper 6"} + + </xml> + } /> + + </body> + </xml> + +(* ord and chr*) +fun ordchr1 _ = chr (ord #"A") +fun ordchr2 _ = chr (ord #"a") +fun ordchr3 _ = chr (ord (strsub "á" 0)) +fun ordchr4 _ = chr (ord (strsub "Á" 0)) +fun ordchr5 _ = chr (ord #"1") +fun ordchr6 _ = chr (ord #"\n") +fun ordchr7 _ = chr (ord (strsub "が" 0)) +fun ordchr8 _ = chr (ord (strsub "漢" 0)) +fun ordchr9 _ = chr (ord (strsub "カ" 0)) + +fun ordchrsserver _ = return { + T1 = ordchr1 (), + T2 = ordchr2 (), + T3 = ordchr3 (), + T4 = ordchr4 (), + T5 = ordchr5 (), + T6 = ordchr6 (), + T7 = ordchr7 (), + T8 = ordchr8 (), + T9 = ordchr9 () + } + +fun ord_and_chrs () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (ordchrsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + + {test_fn_both_sides2 ordchr1 t'.T1 #"A" "ord => chr 1"} + {test_fn_both_sides2 ordchr2 t'.T2 #"a" "ord => chr 2"} + {test_fn_both_sides2 ordchr3 t'.T3 (strsub "á" 0) "ord => chr 3"} + {test_fn_both_sides2 ordchr4 t'.T4 (strsub "Á" 0) "ord => chr 4"} + {test_fn_both_sides2 ordchr5 t'.T5 #"1" "ord => chr 5"} + {test_fn_both_sides2 ordchr6 t'.T6 #"\n" "ord => chr 6"} + {test_fn_both_sides2 ordchr7 t'.T7 (strsub "が" 0) "ord => chr 7"} + {test_fn_both_sides2 ordchr8 t'.T8 (strsub "漢" 0) "ord => chr 8"} + {test_fn_both_sides2 ordchr9 t'.T9 (strsub "カ" 0) "ord => chr 9"} + </xml> + } /> + </body> + </xml> + +(* ord *) +fun ord1 _ = ord #"a" +fun ord2 _ = ord (strsub "á" 0) +fun ord3 _ = ord #"5" +fun ord4 _ = ord (strsub "が" 0) +fun ord5 _ = ord (strsub "漢" 0) +fun ord6 _ = ord (strsub "カ" 0) + +fun ordsserver _ = + return { + T1 = ord1 (), + T2 = ord2 (), + T3 = ord3 (), + T4 = ord4 (), + T5 = ord5 (), + T6 = ord6 () + } + +fun test_ords () : transaction page = + t <- source None; + return <xml> + <body onload={r <- rpc (ordsserver ()); + set t (Some r); + return ()}> + <dyn signal={r <- signal t; case r of None => return <xml></xml> + | Some t' => return <xml> + {test_fn_cside ord1 t'.T1 "test ord 1"} + {test_fn_cside ord2 t'.T2 "test ord 2"} + {test_fn_cside ord3 t'.T3 "test ord 3"} + {test_fn_cside ord4 t'.T4 "test ord 4"} + {test_fn_cside ord5 t'.T5 "test ord 5"} + {test_fn_cside ord6 t'.T6 "test ord 6"} + </xml> + } /> + </body> + </xml> + + + +and test_post () : transaction page = + let + fun test_post_cb r = + return <xml> + <body> + <pre> + {[r.T1]} + </pre> + <pre> + {[r.T2]} + </pre> + <pre> + {[r.T3]} + </pre> + <pre> + {[r.T4]} + </pre> + <pre> + {[r.T5]} + </pre> + <pre> + {[r.T6]} + </pre> + <pre> + {[r.T7]} + </pre> + </body> + </xml> + + in + t1 <- source ""; + t2 <- source "aco"; + t3 <- source "áçõ"; + t4 <- source "が"; + t5 <- source "𝌆𝌇𝌈𝌉"; + t6 <- source "Функциональное"; + t7 <- source "وظيفية"; + return <xml> + <body> + <form> + <textbox{#T1} source={t1} /> + <textbox{#T2} source={t2} /> + <textbox{#T3} source={t3} /> + <textbox{#T4} source={t4} /> + <textbox{#T5} source={t5} /> + <textbox{#T6} source={t6} /> + <textbox{#T7} source={t7} /> + <submit action={test_post_cb} value="submit" /> + </form> + </body> + </xml> + end + +table t : { Id : int, Text : string } + +fun test_db () : transaction page = + let + val s1 = "abc" + val s2 = "çãó" + val s3 = "が" + val s4 = "漢" + val s5 = "カ" + val s6 = "وظيفية" + + fun test_str_and_len n c expS expL = + test_fn_both_sides (fn _ => {S = c, L = strlen c}) {S=expS, L=expL} ("test_db " ^ (show n)) + + in + dml (INSERT INTO t (Id, Text) VALUES({[1]}, {[s1]})); + t1 <- oneRow (SELECT t.Text FROM t WHERE t.Id = 1); + + dml (INSERT INTO t (Id, Text) VALUES({[2]}, {[s2]})); + t2 <- oneRow (SELECT t.Text FROM t WHERE t.Id = 2); + + dml (INSERT INTO t (Id, Text) VALUES({[3]}, {[s3]})); + t3 <- oneRow (SELECT t.Text FROM t WHERE t.Id = 3); + + dml (INSERT INTO t (Id, Text) VALUES({[4]}, {[s4]})); + t4 <- oneRow (SELECT t.Text FROM t WHERE t.Id = 4); + + dml (INSERT INTO t (Id, Text) VALUES({[5]}, {[s5]})); + t5 <- oneRow (SELECT t.Text FROM t WHERE t.Id = 5); + + dml (INSERT INTO t (Id, Text) VALUES({[6]}, {[s6]})); + t6 <- oneRow (SELECT t.Text FROM t WHERE t.Id = 6); + + return <xml> + <body> + {test_str_and_len 1 t1.T.Text s1 (strlen s1)} + {test_str_and_len 2 t2.T.Text s2 (strlen s2)} + {test_str_and_len 3 t3.T.Text s3 (strlen s3)} + {test_str_and_len 4 t4.T.Text s4 (strlen s4)} + {test_str_and_len 5 t5.T.Text s5 (strlen s5)} + {test_str_and_len 6 t6.T.Text s6 (strlen s6)} + </body> + </xml> + end + +and ftTolower (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_ch (fn _ => tolower (chr n)) (tolower (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +and ftToupper (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_ch (fn _ => toupper (chr n)) (toupper (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +and ftIsalpha (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isalpha (chr n)) (isalpha (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +and ftIsdigit (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isdigit (chr n)) (isdigit (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +and ftIsalnum (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isalnum (chr n)) (isalnum (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +and ftIsspace (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isspace (chr n)) (isspace (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +and ftIsblank (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isblank (chr n)) (isblank (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +and ftIsprint (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isprint (chr n)) (isprint (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +and ftIsxdigit (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isxdigit (chr n)) (isxdigit (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +and ftIsupper (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isupper (chr n)) (isupper (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +and ftIslower (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => islower (chr n)) (islower (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + <xml></xml> + in + return <xml> + <body> + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + </body> + </xml> + end + +fun index () : transaction page = + return <xml> + <body> + <a link={substrings ()}>substrings</a> + <a link={strlens ()}>strlens</a> + <a link={strlenGens ()}>strlenGens</a> + <a link={strcats ()}>strcats</a> + <a link={strsubs ()}>strsubs</a> + <a link={strsuffixs ()}>strsuffixs</a> + <a link={strchrs ()}>strchrs</a> + <a link={strindexs ()}>strindexs</a> + <a link={strsindexs ()}>strsindexs</a> + <a link={strcspns ()}>strcspns</a> + <a link={str1s ()}>str1s</a> + <a link={isalnums ()}>isalnums</a> + <a link={isalphas ()}>isalphas</a> + <a link={isblanks ()}>isblanks</a> + <a link={iscntrls ()}>iscntrls</a> + <a link={isdigits ()}>isdigits</a> + <a link={isgraphs ()}>isgraphs</a> + <a link={islowers ()}>islowers</a> + <a link={isprints ()}>isprints</a> + <a link={ispuncts ()}>ispuncts</a> + <a link={isspaces ()}>isspaces</a> + <a link={isuppers ()}>isuppers</a> + <a link={isxdigits ()}>isxdigits</a> + <a link={tolowers ()}>tolowers</a> + <a link={touppers ()}>touppers</a> + <a link={ord_and_chrs ()}>ord_and_chrs</a> + <a link={test_ords ()}>test ord</a> + <a link={highencode ()}>highencode</a> + <a link={test_db ()}>test_db</a> + <a link={test_post ()}>test_post</a> + </body> + </xml> diff --git a/tests/utf8.urp b/tests/utf8.urp new file mode 100644 index 00000000..74fcb1c2 --- /dev/null +++ b/tests/utf8.urp @@ -0,0 +1,7 @@ +database dbname=utf8 +sql utf8.sql +safeGet Utf8/test_db +serverOnly Utf8.generateTests + +$/option +utf8
\ No newline at end of file diff --git a/tests/wildsig.ur b/tests/wildsig.ur new file mode 100644 index 00000000..336772a7 --- /dev/null +++ b/tests/wildsig.ur @@ -0,0 +1,7 @@ +signature S = sig + val x : _ +end + +structure M : S = struct + val x = 7 +end |