for empty content.
- New HTML tag:
- Bug fixes and improvements to type inference, optimizations, and documentation
========
20131231
========
- Performance optimizations for Ur/Web's standalone HTTP servers
- New command-line options for those servers: '-k' and '-q'
- New HTML pseudo-tag: }.
\subsubsection{Node IDs}
There is an abstract type of node IDs that may be assigned to \cd{id} attributes of most HTML tags.
$$\begin{array}{l}
\mt{type} \; \mt{id} \\
\mt{val} \; \mt{fresh} : \mt{transaction} \; \mt{id}
\end{array}$$
The \cd{fresh} function is allowed on both server and client, but there is no other way to create IDs, which includes lack of a way to force an ID to match a particular string. The main semantic importance of IDs within Ur/Web is in uses of the HTML \cd{} tag. IDs play a much more central role in mainstream JavaScript programming, but Ur/Web uses a very different model to enable changes to particular nodes of a page tree, as the next manual subsection explains. IDs may still be useful in interfacing with JavaScript code (for instance, through Ur/Web's FFI).
One further use of IDs is as handles for requesting that \emph{focus} be given to specific tags.
$$\begin{array}{l}
\mt{val} \; \mt{giveFocus} : \mt{id} \to \mt{transaction} \; \mt{unit}
\end{array}$$
\subsubsection{\label{signals}Functional-Reactive Page Generation}
Most approaches to ``AJAX''-style coding involve imperative manipulation of the DOM tree representing an HTML document's structure. Ur/Web follows the \emph{functional-reactive} approach instead. Programs may allocate mutable \emph{sources} of arbitrary types, and an HTML page is effectively a pure function over the latest values of the sources. The page is not mutated directly, but rather it changes automatically as the sources are mutated.
More operationally, you can think of a source as a mutable cell with facilities for subscription to change notifications. That level of detail is hidden behind a monadic facility to be described below. First, there are three primitive operations for working with sources just as if they were ML \cd{ref} cells, corresponding to ML's \cd{ref}, \cd{:=}, and \cd{!} operations.
$$\begin{array}{l}
\mt{con} \; \mt{source} :: \mt{Type} \to \mt{Type} \\
\mt{val} \; \mt{source} : \mt{t} ::: \mt{Type} \to \mt{t} \to \mt{transaction} \; (\mt{source} \; \mt{t}) \\
\mt{val} \; \mt{set} : \mt{t} ::: \mt{Type} \to \mt{source} \; \mt{t} \to \mt{t} \to \mt{transaction} \; \mt{unit} \\
\mt{val} \; \mt{get} : \mt{t} ::: \mt{Type} \to \mt{source} \; \mt{t} \to \mt{transaction} \; \mt{t}
\end{array}$$
Only source creation and setting are supported server-side, as a convenience to help in setting up a page, where you may wish to allocate many sources that will be referenced through the page. All server-side storage of values inside sources uses string serializations of values, while client-side storage uses normal JavaScript values.
Pure functions over arbitrary numbers of sources are represented in a monad of \emph{signals}, which may only be used in client-side code. This is presented to the programmer in the form of a monad $\mt{signal}$, each of whose values represents (conceptually) some pure function over all sources that may be allocated in the course of program execution. A monad operation $\mt{signal}$ denotes the identity function over a particular source. By using $\mt{signal}$ on a source, you implicitly subscribe to change notifications for that source. That is, your signal will automatically be recomputed as that source changes. The usual monad operators make it possible to build up complex signals that depend on multiple sources; automatic updating upon source-value changes still happens automatically. There is also an operator for computing a signal's current value within a transaction.
$$\begin{array}{l}
\mt{con} \; \mt{signal} :: \mt{Type} \to \mt{Type} \\
\mt{val} \; \mt{signal\_monad} : \mt{monad} \; \mt{signal} \\
\mt{val} \; \mt{signal} : \mt{t} ::: \mt{Type} \to \mt{source} \; \mt{t} \to \mt{signal} \; \mt{t} \\
\mt{val} \; \mt{current} : \mt{t} ::: \mt{Type} \to \mt{signal} \; \mt{t} \to \mt{transaction} \; \mt{t}
\end{array}$$
A reactive portion of an HTML page is injected with a $\mt{dyn}$ tag, which has a signal-valued attribute $\mt{Signal}$.
$$\begin{array}{l}
\mt{val} \; \mt{dyn} : \mt{ctx} ::: \{\mt{Unit}\} \to \mt{use} ::: \{\mt{Type}\} \to \mt{bind} ::: \{\mt{Type}\} \to [\mt{ctx} \sim [\mt{Dyn}]] \Rightarrow \mt{unit} \\
\hspace{.1in} \to \mt{tag} \; [\mt{Signal} = \mt{signal} \; (\mt{xml} \; ([\mt{Dyn}] \rc \mt{ctx}) \; \mt{use} \; \mt{bind})] \; ([\mt{Dyn}] \rc \mt{ctx}) \; [] \; \mt{use} \; \mt{bind}
\end{array}$$
The semantics of \cd{} tags is somewhat subtle. When the signal associated with such a tag changes value, the associated subtree of the HTML page is recreated. Some properties of the subtree, such as attributes and client-side widget values, are specified explicitly in the signal value, so these may be counted on to remain the same after recreation. Other properties, like focus and cursor position within textboxes, are \emph{not} specified by signal values, and these properties will be \emph{reset} upon subtree regeneration. Furthermore, user interaction with widgets may not work properly during regeneration. For instance, clicking a button while it is being regenerated may not trigger its \cd{onclick} event code.
Currently, the only way to avoid undesired resets is to avoid regeneration of containing subtrees. There are two main strategies for achieving that goal. First, when changes to a subtree can be confined to CSS classes of tags, the \texttt{dynClass} pseudo-attribute may be used instead (see Section \ref{xml}), as it does not regenerate subtrees. Second, a single \cd{} tag may be broken into multiple tags, in a way that makes finer-grained dependency structure explicit. This latter strategy can avoid ``spurious'' regenerations that are not actually required to achieve the intended semantics.
Transactions can be run on the client by including them in attributes like the $\mt{Onclick}$ attribute of $\mt{button}$, and GUI widgets like $\mt{ctextbox}$ have $\mt{Source}$ attributes that can be used to connect them to sources, so that their values can be read by code running because of, e.g., an $\mt{Onclick}$ event. It is also possible to create an ``active'' HTML fragment that runs a $\mt{transaction}$ to determine its content, possibly allocating some sources in the process:
$$\begin{array}{l}
\mt{val} \; \mt{active} : \mt{unit} \to \mt{tag} \; [\mt{Code} = \mt{transaction} \; \mt{xbody}] \; \mt{body} \; [] \; [] \; []
\end{array}$$
\subsubsection{Remote Procedure Calls}
Any function call may be made a client-to-server ``remote procedure call'' if the function being called needs no features that are only available to client code. To make a function call an RPC, pass that function call as the argument to $\mt{Basis.rpc}$:
$$\begin{array}{l}
\mt{val} \; \mt{rpc} : \mt{t} ::: \mt{Type} \to \mt{transaction} \; \mt{t} \to \mt{transaction} \; \mt{t}
\end{array}$$
There is an alternate form that uses $\mt{None}$ to indicate that an error occurred during RPC processing, rather than raising an exception to abort this branch of control flow.
$$\begin{array}{l}
\mt{val} \; \mt{tryRpc} : \mt{t} ::: \mt{Type} \to \mt{transaction} \; \mt{t} \to \mt{transaction} \; (\mt{option} \; \mt{t})
\end{array}$$
\subsubsection{Asynchronous Message-Passing}
To support asynchronous, ``server push'' delivery of messages to clients, any client that might need to receive an asynchronous message is assigned a unique ID. These IDs may be retrieved both on the client and on the server, during execution of code related to a client.
$$\begin{array}{l}
\mt{type} \; \mt{client} \\
\mt{val} \; \mt{self} : \mt{transaction} \; \mt{client}
\end{array}$$
\emph{Channels} are the means of message-passing. Each channel is created in the context of a client and belongs to that client; no other client may receive the channel's messages. Note that here \emph{client} has a technical Ur/Web meaning so that it describes only \emph{single page views}, so a user following a traditional link within an application will remove the ability for \emph{any} code to receive messages on the channels associated with the previous client. Each channel type includes the type of values that may be sent over the channel. Sending and receiving are asynchronous, in the sense that a client need not be ready to receive a message right away. Rather, sent messages may queue up, waiting to be processed.
$$\begin{array}{l}
\mt{con} \; \mt{channel} :: \mt{Type} \to \mt{Type} \\
\mt{val} \; \mt{channel} : \mt{t} ::: \mt{Type} \to \mt{transaction} \; (\mt{channel} \; \mt{t}) \\
\mt{val} \; \mt{send} : \mt{t} ::: \mt{Type} \to \mt{channel} \; \mt{t} \to \mt{t} \to \mt{transaction} \; \mt{unit} \\
\mt{val} \; \mt{recv} : \mt{t} ::: \mt{Type} \to \mt{channel} \; \mt{t} \to \mt{transaction} \; \mt{t}
\end{array}$$
The $\mt{channel}$ and $\mt{send}$ operations may only be executed on the server, and $\mt{recv}$ may only be executed on a client. Neither clients nor channels may be passed as arguments from clients to server-side functions, so persistent channels can only be maintained by storing them in the database and looking them up using the current client ID or some application-specific value as a key.
Clients and channels live only as long as the web browser page views that they are associated with. When a user surfs away, his client and its channels will be garbage-collected, after that user is not heard from for the timeout period. Garbage collection deletes any database row that contains a client or channel directly. Any reference to one of these types inside an $\mt{option}$ is set to $\mt{None}$ instead. Both kinds of handling have the flavor of weak pointers, and that is a useful way to think about clients and channels in the database.
\emph{Note}: Currently, there are known concurrency issues with multi-threaded applications that employ message-passing on top of database engines that don't support true serializable transactions. Postgres 9.1 is the only supported engine that does this properly.
\section{Ur/Web Syntax Extensions}
Ur/Web features some syntactic shorthands for building values using the functions from the last section. This section sketches the grammar of those extensions. We write spans of syntax inside brackets to indicate that they are optional.
\subsection{SQL}
\subsubsection{\label{tables}Table Declarations}
$\mt{table}$ declarations may include constraints, via these grammar rules.
$$\begin{array}{rrcll}
\textrm{Declarations} & d &::=& \mt{table} \; x : c \; [pk[,]] \; cts \mid \mt{view} \; x = V \\
\textrm{Primary key constraints} & pk &::=& \mt{PRIMARY} \; \mt{KEY} \; K \\
\textrm{Keys} & K &::=& f \mid (f, (f,)^+) \mid \{\{e\}\} \\
\textrm{Constraint sets} & cts &::=& \mt{CONSTRAINT} f \; ct \mid cts, cts \mid \{\{e\}\} \\
\textrm{Constraints} & ct &::=& \mt{UNIQUE} \; K \mid \mt{CHECK} \; E \\
&&& \mid \mt{FOREIGN} \; \mt{KEY} \; K \; \mt{REFERENCES} \; F \; (K) \; [\mt{ON} \; \mt{DELETE} \; pr] \; [\mt{ON} \; \mt{UPDATE} \; pr] \\
\textrm{Foreign tables} & F &::=& x \mid \{\{e\}\} \\
\textrm{Propagation modes} & pr &::=& \mt{NO} \; \mt{ACTION} \mid \mt{RESTRICT} \mid \mt{CASCADE} \mid \mt{SET} \; \mt{NULL} \\
\textrm{View expressions} & V &::=& Q \mid \{e\}
\end{array}$$
A signature item $\mt{table} \; \mt{x} : \mt{c}$ is actually elaborated into two signature items: $\mt{con} \; \mt{x\_hidden\_constraints} :: \{\{\mt{Unit}\}\}$ and $\mt{val} \; \mt{x} : \mt{sql\_table} \; \mt{c} \; \mt{x\_hidden\_constraints}$. This is appropriate for common cases where client code doesn't care which keys a table has. It's also possible to include constraints after a $\mt{table}$ signature item, with the same syntax as for $\mt{table}$ declarations. This may look like dependent typing, but it's just a convenience. The constraints are type-checked to determine a constructor $u$ to include in $\mt{val} \; \mt{x} : \mt{sql\_table} \; \mt{c} \; (u \rc \mt{x\_hidden\_constraints})$, and then the expressions are thrown away. Nonetheless, it can be useful for documentation purposes to include table constraint details in signatures. Note that the automatic generation of $\mt{x\_hidden\_constraints}$ leads to a kind of free subtyping with respect to which constraints are defined.
\subsubsection{Queries}
Queries $Q$ are added to the rules for expressions $e$.
$$\begin{array}{rrcll}
\textrm{Queries} & Q &::=& (q \; [\mt{ORDER} \; \mt{BY} \; O] \; [\mt{LIMIT} \; N] \; [\mt{OFFSET} \; N]) \\
\textrm{Pre-queries} & q &::=& \mt{SELECT} \; [\mt{DISTINCT}] \; P \; \mt{FROM} \; F,^+ \; [\mt{WHERE} \; E] \; [\mt{GROUP} \; \mt{BY} \; p,^+] \; [\mt{HAVING} \; E] \\
&&& \mid q \; R \; q \mid \{\{\{e\}\}\} \\
\textrm{Relational operators} & R &::=& \mt{UNION} \mid \mt{INTERSECT} \mid \mt{EXCEPT} \\
\textrm{$\mt{ORDER \; BY}$ items} & O &::=& \mt{RANDOM} [()] \mid \hat{E} \; [o] \mid \hat{E} \; [o], O \mid \{\{\{e\}\}\}
\end{array}$$
$$\begin{array}{rrcll}
\textrm{Projections} & P &::=& \ast & \textrm{all columns} \\
&&& p,^+ & \textrm{particular columns} \\
\textrm{Pre-projections} & p &::=& t.f & \textrm{one column from a table} \\
&&& t.\{\{c\}\} & \textrm{a record of columns from a table (of kind $\{\mt{Type}\}$)} \\
&&& t.* & \textrm{all columns from a table} \\
&&& \hat{E} \; [\mt{AS} \; f] & \textrm{expression column} \\
\textrm{Table names} & t &::=& x & \textrm{constant table name (automatically capitalized)} \\
&&& X & \textrm{constant table name} \\
&&& \{\{c\}\} & \textrm{computed table name (of kind $\mt{Name}$)} \\
\textrm{Column names} & f &::=& X & \textrm{constant column name} \\
&&& \{c\} & \textrm{computed column name (of kind $\mt{Name}$)} \\
\textrm{Tables} & T &::=& x & \textrm{table variable, named locally by its own capitalization} \\
&&& x \; \mt{AS} \; X & \textrm{table variable, with local name} \\
&&& x \; \mt{AS} \; \{c\} & \textrm{table variable, with computed local name} \\
&&& \{\{e\}\} \; \mt{AS} \; X & \textrm{computed table expression, with local name} \\
&&& \{\{e\}\} \; \mt{AS} \; \{c\} & \textrm{computed table expression, with computed local name} \\
\textrm{$\mt{FROM}$ items} & F &::=& T \mid \{\{e\}\} \mid F \; J \; \mt{JOIN} \; F \; \mt{ON} \; E \\
&&& \mid F \; \mt{CROSS} \; \mt{JOIN} \ F \\
&&& \mid (Q) \; \mt{AS} \; X \mid (Q) \; \mt{AS} \; \{c\} \\
&&& \mid (\{\{e\}\}) \; \mt{AS} \; t \\
\textrm{Joins} & J &::=& [\mt{INNER}] \\
&&& \mid [\mt{LEFT} \mid \mt{RIGHT} \mid \mt{FULL}] \; [\mt{OUTER}] \\
\textrm{SQL expressions} & E &::=& t.f & \textrm{column references} \\
&&& X & \textrm{named expression references} \\
&&& \{[e]\} & \textrm{injected native Ur expressions} \\
&&& \{e\} & \textrm{computed expressions, probably using $\mt{sql\_exp}$ directly} \\
&&& \mt{TRUE} \mid \mt{FALSE} & \textrm{boolean constants} \\
&&& \ell & \textrm{primitive type literals} \\
&&& \mt{NULL} & \textrm{null value (injection of $\mt{None}$)} \\
&&& E \; \mt{IS} \; \mt{NULL} & \textrm{nullness test} \\
&&& \mt{COALESCE}(E, E) & \textrm{take first non-null value} \\
&&& n & \textrm{nullary operators} \\
&&& u \; E & \textrm{unary operators} \\
&&& E \; b \; E & \textrm{binary operators} \\
&&& \mt{COUNT}(\ast) & \textrm{count number of rows} \\
&&& a(E) & \textrm{other aggregate function} \\
&&& \mt{IF} \; E \; \mt{THEN} \; E \; \mt{ELSE} \; E & \textrm{conditional} \\
&&& (Q) & \textrm{subquery (must return a single expression column)} \\
&&& (E) & \textrm{explicit precedence} \\
\textrm{Nullary operators} & n &::=& \mt{CURRENT\_TIMESTAMP} \\
\textrm{Unary operators} & u &::=& \mt{NOT} \\
\textrm{Binary operators} & b &::=& \mt{AND} \mid \mt{OR} \mid = \mid \neq \mid < \mid \leq \mid > \mid \geq \mid \mt{LIKE} \\
\textrm{Aggregate functions} & a &::=& \mt{COUNT} \mid \mt{AVG} \mid \mt{SUM} \mid \mt{MIN} \mid \mt{MAX} \\
\textrm{Directions} & o &::=& \mt{ASC} \mid \mt{DESC} \mid \{e\} \\
\textrm{SQL integer} & N &::=& n \mid \{e\} \\
\textrm{Windowable expressions} & \hat{E} &::=& E \\
&&& w \; [\mt{OVER} \; ( & \textrm{(Postgres only)} \\
&&& \hspace{.1in} [\mt{PARTITION} \; \mt{BY} \; E] \\
&&& \hspace{.1in} [\mt{ORDER} \; \mt{BY} \; O])] \\
\textrm{Window function} & w &::=& \mt{RANK}() \\
&&& \mt{COUNT}(*) \\
&&& a(E)
\end{array}$$
Additionally, an SQL expression may be inserted into normal Ur code with the syntax $(\mt{SQL} \; E)$ or $(\mt{WHERE} \; E)$. Similar shorthands exist for other nonterminals, with the prefix $\mt{FROM}$ for $\mt{FROM}$ items and $\mt{SELECT1}$ for pre-queries.
Unnamed expression columns in $\mt{SELECT}$ clauses are assigned consecutive natural numbers, starting with 1. Any expression in a $p$ position that is enclosed in parentheses is treated as an expression column, rather than a column pulled directly out of a table, even if it is only a field projection. (This distinction affects the record type used to describe query results.)
\subsubsection{DML}
DML commands $D$ are added to the rules for expressions $e$.
$$\begin{array}{rrcll}
\textrm{Commands} & D &::=& (\mt{INSERT} \; \mt{INTO} \; T^E \; (f,^+) \; \mt{VALUES} \; (E,^+)) \\
&&& (\mt{UPDATE} \; T^E \; \mt{SET} \; (f = E,)^+ \; \mt{WHERE} \; E) \\
&&& (\mt{DELETE} \; \mt{FROM} \; T^E \; \mt{WHERE} \; E) \\
\textrm{Table expressions} & T^E &::=& x \mid \{\{e\}\}
\end{array}$$
Inside $\mt{UPDATE}$ and $\mt{DELETE}$ commands, lone variables $X$ are interpreted as references to columns of the implicit table $\mt{T}$, rather than to named expressions.
\subsection{XML}
XML fragments $L$ are added to the rules for expressions $e$.
$$\begin{array}{rrcll}
\textrm{XML fragments} & L &::=& \texttt{ } \mid \texttt{}l^*\texttt{ } \\
\textrm{XML pieces} & l &::=& \textrm{text} & \textrm{cdata} \\
&&& \texttt{<}g\texttt{/>} & \textrm{tag with no children} \\
&&& \texttt{<}g\texttt{>}l^*\texttt{}x\texttt{>} & \textrm{tag with children} \\
&&& \{e\} & \textrm{computed XML fragment} \\
&&& \{[e]\} & \textrm{injection of an Ur expression, via the $\mt{Top}.\mt{txt}$ function} \\
\textrm{Tag} & g &::=& h \; (x [= v])^* \\
\textrm{Tag head} & h &::=& x & \textrm{tag name} \\
&&& h\{c\} & \textrm{constructor parameter} \\
\textrm{Attribute value} & v &::=& \ell & \textrm{literal value} \\
&&& \{e\} & \textrm{computed value} \\
\end{array}$$
When the optional $= v$ is omitted in an XML attribute, the attribute is assigned value $\mt{True}$ in Ur/Web, and it is rendered to HTML merely as including the attribute name without a value. If such a Boolean attribute is manually set to value $\mt{False}$, then it is omitted altogether in generating HTML.
Further, there is a special convenience and compatibility form for setting CSS classes of tags. If a \cd{class} attribute has a value that is a string literal, the literal is parsed in the usual HTML way and replaced with calls to appropriate Ur/Web combinators. Any dashes in the text are replaced with underscores to determine Ur identifiers. The same desugaring can be accessed in a normal expression context by calling the pseudo-function \cd{CLASS} on a string literal.
Similar support is provided for \cd{style} attributes. Normal CSS syntax may be used in string literals that are \cd{style} attribute values, and the desugaring may be accessed elsewhere with the pseudo-function \cd{STYLE}.
\section{\label{structure}The Structure of Web Applications}
A web application is built from a series of modules, with one module, the last one appearing in the \texttt{.urp} file, designated as the main module. The signature of the main module determines the URL entry points to the application. Such an entry point should have type $\mt{t1} \to \ldots \to \mt{tn} \to \mt{transaction} \; \mt{page}$, for any integer $n \geq 0$, where $\mt{page}$ is a type synonym for top-level HTML pages, defined in $\mt{Basis}$. If such a function is at the top level of main module $M$, with $n = 0$, it will be accessible at URI \texttt{/M/f}, and so on for more deeply nested functions, as described in Section \ref{tag} below. See Section \ref{cl} for information on the \texttt{prefix} and \texttt{rewrite url} directives, which can be used to rewrite the default URIs of different entry point functions. The final URL of a function is its default module-based URI, with \texttt{rewrite url} rules applied, and with the \texttt{prefix} prepended. Arguments to an entry-point function are deserialized from the part of the URI following \texttt{f}.
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.
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.
When the standalone web server receives a request for a known page, it calls the function for that page, ``running'' the resulting transaction to produce the page to return to the client. Pages link to other pages with the \texttt{link} attribute of the \texttt{a} HTML tag. A link has type $\mt{transaction} \; \mt{page}$, and the semantics of a link are that this transaction should be run to compute the result page, when the link is followed. Link targets are assigned URL names in the same way as top-level entry points.
HTML forms are handled in a similar way. The $\mt{action}$ attribute of a $\mt{submit}$ form tag takes a value of type $\$\mt{use} \to \mt{transaction} \; \mt{page}$, where $\mt{use}$ is a kind-$\{\mt{Type}\}$ record of the form fields used by this action handler. Action handlers are assigned URL patterns in the same way as above.
For both links and actions, direct arguments and local variables mentioned implicitly via closures are automatically included in serialized form in URLs, in the order in which they appear in the source code. Such serialized values may only be drawn from a limited set of types, and programs will fail to compile when the (implicit or explicit) arguments of page handler functions involve disallowed types. (Keep in mind that every free variable of a function is an implicit argument if it was not defined at the top level of a module.) For instance:
\begin{itemize}
\item Functions are disallowed, since there is no obvious way to serialize them safely.
\item XML fragments are disallowed, since it is unclear how to check client-provided XML to be sure it doesn't break the HTML invariants of the application (for instance, by mutating the DOM in the conventional way, interfering with Ur/Web's functional-reactive regime).
\item Blobs (``files'') are disallowed, since they can easily have very large serializations that could not fit within most web servers' URL size limits. (And you probably don't want to be serializing, e.g., image files in URLs, anyway.)
\end{itemize}
Ur/Web programs generally mix server- and client-side code in a fairly transparent way. The one important restriction is that mixed client-server code must encapsulate all server-side pieces within named functions. This is because execution of such pieces will be implemented by explicit calls to the remote web server, and it is useful to get the programmer's help in designing the interface to be used. For example, this makes it easier to allow a client running an old version of an application to continue interacting with a server that has been upgraded to a new version, if the programmer took care to keep the interfaces of all of the old remote calls the same. The functions implementing these services are assigned names in the same way as normal web entry points, by using module structure.
\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{} 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.
\subsection{Tasks}
In many web applications, it's useful to run code at points other than requests from browsers. Ur/Web's \emph{task} mechanism facilitates this. A type family of \emph{task kinds} is in the standard library:
$$\begin{array}{l}
\mt{con} \; \mt{task\_kind} :: \mt{Type} \to \mt{Type} \\
\mt{val} \; \mt{initialize} : \mt{task\_kind} \; \mt{unit} \\
\mt{val} \; \mt{clientLeaves} : \mt{task\_kind} \; \mt{client} \\
\mt{val} \; \mt{periodic} : \mt{int} \to \mt{task\_kind} \; \mt{unit}
\end{array}$$
A task kind names a particular extension point of generated applications, where the type parameter of a task kind describes which extra input data is available at that extension point. Add task code with the special declaration form $\mt{task} \; e_1 = e_2$, where $e_1$ is a task kind with data $\tau$, and $e_2$ is a function from $\tau$ to $\mt{transaction} \; \mt{unit}$.
The currently supported task kinds are:
\begin{itemize}
\item $\mt{initialize}$: Code that is run when the application starts up.
\item $\mt{clientLeaves}$: Code that is run for each client that the runtime system decides has surfed away. When a request that generates a new client handle is aborted, that handle will still eventually be passed to $\mt{clientLeaves}$ task code, even though the corresponding browser was never informed of the client handle's existence. In other words, in general, $\mt{clientLeaves}$ handlers will be called more times than there are actual clients.
\item $\mt{periodic} \; n$: Code that is run when the application starts up and then every $n$ seconds thereafter.
\end{itemize}
\section{\label{ffi}The Foreign Function Interface}
It is possible to call your own C and JavaScript code from Ur/Web applications, via the foreign function interface (FFI). The starting point for a new binding is a \texttt{.urs} signature file that presents your external library as a single Ur/Web module (with no nested modules). Compilation conventions map the types and values that you use into C and/or JavaScript types and values.
It is most convenient to encapsulate an FFI binding with a new \texttt{.urp} file, which applications can include with the \texttt{library} directive in their own \texttt{.urp} files. A number of directives are likely to show up in the library's project file.
\begin{itemize}
\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{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.
\item \texttt{link FILE} requests that \texttt{FILE} be linked into applications. It should be a C object or library archive file, and you are responsible for generating it with your own build process.
\item \texttt{script URL} requests inclusion of a JavaScript source file within application HTML.
\item \texttt{serverOnly Module.ident} registers a value as being allowed only in server-side code.
\end{itemize}
\subsection{Writing C FFI Code}
C source files connecting to the Ur/Web FFI should include \texttt{urweb.h}, and C++ source files should include \texttt{urweb\_cpp.h}.
A server-side FFI type or value \texttt{Module.ident} must have a corresponding type or value definition \texttt{uw\_Module\_ident} in C code. With the current Ur/Web version, it's not generally possible to work with Ur records or complex datatypes in C code, but most other kinds of types are fair game.
\begin{itemize}
\item Primitive types defined in \texttt{Basis} are themselves using the standard FFI interface, so you may refer to them like \texttt{uw\_Basis\_t}. See \texttt{include/urweb/types.h} for their definitions.
\item Enumeration datatypes, which have only constructors that take no arguments, should be defined using C \texttt{enum}s. The type is named as for any other type identifier, and each constructor \texttt{c} gets an enumeration constant named \texttt{uw\_Module\_c}.
\item A datatype \texttt{dt} (such as \texttt{Basis.option}) that has one non-value-carrying constructor \texttt{NC} and one value-carrying constructor \texttt{C} gets special treatment. Where \texttt{T} is the type of \texttt{C}'s argument, and where we represent \texttt{T} as \texttt{t} in C, we represent \texttt{NC} with \texttt{NULL}. The representation of \texttt{C} depends on whether we're sure that we don't need to use \texttt{NULL} to represent \texttt{t} values; this condition holds only for strings and complex datatypes. For such types, \texttt{C v} is represented with the C encoding of \texttt{v}, such that the translation of \texttt{dt} is \texttt{t}. For other types, \texttt{C v} is represented with a pointer to the C encoding of v, such that the translation of \texttt{dt} is \texttt{t*}.
\item Ur/Web involves many types of program syntax, such as for HTML and SQL code. All of these types are implemented with normal C strings, and you may take advantage of that encoding to manipulate code as strings in C FFI code. Be mindful that, in writing such code, it is your responsibility to maintain the appropriate code invariants, or you may reintroduce the code injection vulnerabilities that Ur/Web rules out. The most convenient way to extend Ur/Web with functions that, e.g., use natively unsupported HTML tags is to generate the HTML code with the FFI.
\end{itemize}
The C FFI version of a Ur function with type \texttt{T1 -> ... -> TN -> R} or \texttt{T1 -> ... -> TN -> transaction R} has a C prototype like \texttt{R uw\_Module\_ident(uw\_context, T1, ..., TN)}. Only functions with types of the second form may have side effects. \texttt{uw\_context} is the type of state that persists across handling a client request. Many functions that operate on contexts are prototyped in \texttt{include/urweb/urweb\_cpp.h}. Most should only be used internally by the compiler. A few are useful in general FFI implementation:
\begin{itemize}
\item \begin{verbatim}
void uw_error(uw_context, failure_kind, const char *fmt, ...);
\end{verbatim}
Abort the current request processing, giving a \texttt{printf}-style format string and arguments for generating an error message. The \texttt{failure\_kind} argument can be \texttt{FATAL}, to abort the whole execution; \texttt{BOUNDED\_RETRY}, to try processing the request again from the beginning, but failing if this happens too many times; or \texttt{UNLIMITED\_RETRY}, to repeat processing, with no cap on how many times this can recur.
All pointers to the context-local heap (see description below of \texttt{uw\_malloc()}) become invalid at the start and end of any execution of a main entry point function of an application. For example, if the request handler is restarted because of a \texttt{uw\_error()} call with \texttt{BOUNDED\_RETRY} or for any other reason, it is unsafe to access any local heap pointers that may have been stashed somewhere beforehand.
\item \begin{verbatim}
void uw_set_error_message(uw_context, const char *fmt, ...);
\end{verbatim}
This simpler form of \texttt{uw\_error()} saves an error message without immediately aborting execution.
\item \begin{verbatim}
void uw_push_cleanup(uw_context, void (*func)(void *), void *arg);
void uw_pop_cleanup(uw_context);
\end{verbatim}
Manipulate a stack of actions that should be taken if any kind of error condition arises. Calling the ``pop'' function both removes an action from the stack and executes it. It is a bug to let a page request handler finish successfully with unpopped cleanup actions.
Pending cleanup actions aren't intended to have any complex relationship amongst themselves, so, upon request handler abort, pending actions are executed in first-in-first-out order.
\item \begin{verbatim}
void *uw_malloc(uw_context, size_t);
\end{verbatim}
A version of \texttt{malloc()} that allocates memory inside a context's heap, which is managed with region allocation. Thus, there is no \texttt{uw\_free()}, but you need to be careful not to keep ad-hoc C pointers to this area of memory. In general, \texttt{uw\_malloc()}ed memory should only be used in ways compatible with the computation model of pure Ur. This means it is fine to allocate and return a value that could just as well have been built with core Ur code. In contrast, it is almost never safe to store \texttt{uw\_malloc()}ed pointers in global variables, including when the storage happens implicitly by registering a callback that would take the pointer as an argument.
For performance and correctness reasons, it is usually preferable to use \texttt{uw\_malloc()} instead of \texttt{malloc()}. The former manipulates a local heap that can be kept allocated across page requests, while the latter uses global data structures that may face contention during concurrent execution. However, we emphasize again that \texttt{uw\_malloc()} should never be used to implement some logic that couldn't be implemented trivially by a constant-valued expression in Ur.
\item \begin{verbatim}
typedef void (*uw_callback)(void *);
typedef void (*uw_callback_with_retry)(void *, int will_retry);
int uw_register_transactional(uw_context, void *data, uw_callback commit,
uw_callback rollback, uw_callback_with_retry free);
\end{verbatim}
All side effects in Ur/Web programs need to be compatible with transactions, such that any set of actions can be undone at any time. Thus, you should not perform actions with non-local side effects directly; instead, register handlers to be called when the current transaction is committed or rolled back. The arguments here give an arbitary piece of data to be passed to callbacks, a function to call on commit, a function to call on rollback, and a function to call afterward in either case to clean up any allocated resources. A rollback handler may be called after the associated commit handler has already been called, if some later part of the commit process fails. A free handler is told whether the runtime system expects to retry the current page request after rollback finishes. The return value of \texttt{uw\_register\_transactional()} is 0 on success and nonzero on failure (where failure currently only happens when exceeding configured limits on number of transactionals).
Any of the callbacks may be \texttt{NULL}. To accommodate some stubbornly non-transactional real-world actions like sending an e-mail message, Ur/Web treats \texttt{NULL} \texttt{rollback} callbacks specially. When a transaction commits, all \texttt{commit} actions that have non-\texttt{NULL} rollback actions are tried before any \texttt{commit} actions that have \texttt{NULL} rollback actions. Furthermore, an SQL \texttt{COMMIT} is also attempted in between the two phases, so the nicely transactional actions have a chance to influence whether data are committed to the database, while \texttt{NULL}-rollback actions only get run in the first place after committing data. The reason for all this is that it is \emph{expected} that concurrency interactions will cause database commits to fail in benign ways that call for transaction restart. A truly non-undoable action should only be run after we are sure the database transaction will commit.
When a request handler ends with multiple pending transactional actions, their handlers are run in a first-in-last-out stack-like order, wherever the order would otherwise be ambiguous.
It is not safe for any of these handlers to access a context-local heap through a pointer returned previously by \texttt{uw\_malloc()}, nor should any new calls to that function be made. Think of the context-local heap as meant for use by the Ur/Web code itself, while transactional handlers execute after the Ur/Web code has finished.
A handler may signal an error by calling \texttt{uw\_set\_error\_message()}, but it is not safe to call \texttt{uw\_error()} from a handler. Signaling an error in a commit handler will cause the runtime system to switch to aborting the transaction, immediately after the current commit handler returns.
\item \begin{verbatim}
void *uw_get_global(uw_context, char *name);
void uw_set_global(uw_context, char *name, void *data, uw_callback free);
\end{verbatim}
Different FFI-based extensions may want to associate their own pieces of data with contexts. The global interface provides a way of doing that, where each extension must come up with its own unique key. The \texttt{free} argument to \texttt{uw\_set\_global()} explains how to deallocate the saved data. It is never safe to store \texttt{uw\_malloc()}ed pointers in global variable slots.
\end{itemize}
\subsection{Writing JavaScript FFI Code}
JavaScript is dynamically typed, so Ur/Web type definitions imply no JavaScript code. The JavaScript identifier for each FFI function is set with the \texttt{jsFunc} directive. Each identifier can be defined in any JavaScript file that you ask to include with the \texttt{script} directive, and one easy way to get code included is with the \texttt{jsFile} directive.
In contrast to C FFI code, JavaScript FFI functions take no extra context argument. Their argument lists are as you would expect from their Ur types. Only functions whose ranges take the form \texttt{transaction T} should have side effects; the JavaScript ``return type'' of such a function is \texttt{T}. Here are the conventions for representing Ur values in JavaScript.
\begin{itemize}
\item Integers, floats, strings, characters, and booleans are represented in the usual JavaScript way.
\item Ur functions are represented in an unspecified way. This means that you should not rely on any details of function representation. Named FFI functions are represented as JavaScript functions with as many arguments as their Ur types specify. To call a non-FFI function \texttt{f} on argument \texttt{x}, run \texttt{execF(f, x)}. A normal JavaScript function may also be used in a position where the Ur/Web runtime system expects an Ur/Web function.
\item An Ur record is represented with a JavaScript record, where Ur field name \texttt{N} translates to JavaScript field name \texttt{\_N}. An exception to this rule is that the empty record is encoded as \texttt{null}.
\item \texttt{option}-like types receive special handling similar to their handling in C. The ``\texttt{None}'' constructor is \texttt{null}, and a use of the ``\texttt{Some}'' constructor on a value \texttt{v} is either \texttt{v}, if the underlying type doesn't need to use \texttt{null}; or \texttt{\{v:v\}} otherwise.
\item Any other datatypes represent a non-value-carrying constructor \texttt{C} as \texttt{"C"} and an application of a constructor \texttt{C} to value \texttt{v} as \texttt{\{n:"C", v:v\}}. This rule only applies to datatypes defined in FFI module signatures; the compiler is free to optimize the representations of other, non-\texttt{option}-like datatypes in arbitrary ways.
\item As in the C FFI, all abstract types of program syntax are implemented with strings in JavaScript.
\item A value of Ur type \texttt{transaction t} is represented in the same way as for \texttt{unit -> t}. (Note that FFI functions skip this extra level of function encoding, which only applies to functions defined in Ur/Web.)
\end{itemize}
It is possible to write JavaScript FFI code that interacts with the functional-reactive structure of a document. Here is a quick summary of some of the simpler functions to use; descriptions of fancier stuff may be added later on request (and such stuff should be considered ``undocumented features'' until then).
\begin{itemize}
\item Sources should be treated as an abstract type, manipulated via:
\begin{itemize}
\item \cd{sc(v)}, to create a source initialized to \cd{v}
\item \cd{sg(s)}, to retrieve the current value of source \cd{s}
\item \cd{sv(s, v)}, to set source \cd{s} to value \cd{v}
\end{itemize}
\item Signals should be treated as an abstract type, manipulated via:
\begin{itemize}
\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}
\end{itemize}
\item The behavior of the \cd{} 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{";
var scripts = span.getElementsByTagName("script");
return scripts.length == 0;
}
var dynPrefix = needsDynPrefix() ? "A " : "";
// Function versions of operators
function not(x) { return !x; }
function neg(x) { return -x; }
function eq(x, y) { return x == y; }
function plus(x, y) { return x + y; }
function minus(x, y) { return x - y; }
function times(x, y) { return x * y; }
function div(x, y) { return x / y; }
function divInt(x, y) { if (y == 0) er("Division by zero"); var n = x / y; return n < 0 ? Math.ceil(n) : Math.floor(n); }
function mod(x, y) { return x % y; }
function modInt(x, y) { if (y == 0) er("Division by zero"); var n = x % y; return n < 0 ? Math.ceil(n) : Math.floor(n); }
function lt(x, y) { return x < y; }
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 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(); }
// Lists
function cons(v, ls) {
return { next : ls, data : v };
}
function rev(ls) {
var acc = null;
for (; ls; ls = ls.next)
acc = cons(ls.data, acc);
return acc;
}
function concat(ls1, ls2) {
var acc = ls2;
ls1 = rev(ls1);
for (; ls1; ls1 = ls1.next)
acc = cons(ls1.data, acc);
return acc;
}
function member(x, ls) {
for (; ls; ls = ls.next)
if (ls.data == x)
return true;
return false;
}
function remove(x, ls) {
var acc = null;
for (; ls; ls = ls.next)
if (ls.data == x)
return concat(acc, ls.next);
else
acc = cons(ls.data, acc);
return ls;
}
function union(ls1, ls2) {
var acc = ls2;
for (; ls1; ls1 = ls1.next)
if (!member(ls1.data, ls2))
acc = cons(ls1.data, acc);
return acc;
}
function length(ls) {
var acc = 0;
for (; ls; ls = ls.next)
++acc;
return acc;
}
// Floats
function float(n) {
return n;
}
function trunc(n) {
return ~~n;
}
function ceil(n) {
return Math.ceil(n);
}
function round(n) {
return Math.round(n);
}
function pow(n, m) {
return Math.pow(n, m);
}
// Time, represented as counts of microseconds since the epoch
var time_format = "%c";
function showTime(tm) {
return strftime(time_format, tm);
}
function showTimeHtml(tm) {
return eh(showTime(tm));
}
function now() {
return (new Date()).getTime() * 1000;
}
function diffInSeconds(tm1, tm2) {
return Math.round((tm2 - tm1) / 1000000);
}
function diffInMilliseconds(tm1, tm2) {
return Math.round((tm2 - tm1) / 1000);
}
function toSeconds(tm) {
return Math.round(tm / 1000000);
}
function toMilliseconds(tm) {
return Math.round(tm / 1000);
}
function fromMilliseconds(tm) {
return tm * 1000;
}
function addSeconds(tm, n) {
return tm + n * 1000000;
}
function stringToTime_error(string) {
var t = Date.parse(string);
if (isNaN(t))
er("Invalid date string: " + string);
else
return t * 1000;
}
function stringToTime(string) {
try {
var t = Date.parse(string);
if (isNaN(t))
return null;
else
return t * 1000;
} catch (e) {
return null;
}
}
/*
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)
{
if(typeof r === "undefined")
{
r=10;
}
pad = pad.toString();
for( ; parseInt(x, 10)1; r/=10) {
x = pad + x;
}
return x.toString();
};
var YDateEn = {
a: ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"],
A: ["Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"],
b: ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"],
B: ["January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December"],
c: "%a %d %b %Y %T %Z",
p: ["AM", "PM"],
P: ["am", "pm"],
r: "%I:%M:%S %p",
x: "%d/%m/%y",
X: "%T"
};
var Dt = {
formats: {
a: function (d, l) { return l.a[d.getDay()]; },
A: function (d, l) { return l.A[d.getDay()]; },
b: function (d, l) { return l.b[d.getMonth()]; },
B: function (d, l) { return l.B[d.getMonth()]; },
C: function (d) { return xPad(parseInt(d.getFullYear()/100, 10), 0); },
d: ["getDate", "0"],
e: ["getDate", " "],
g: function (d) { return xPad(parseInt(Dt.formats.G(d)%100, 10), 0); },
G: function (d) {
var y = d.getFullYear();
var V = parseInt(Dt.formats.V(d), 10);
var W = parseInt(Dt.formats.W(d), 10);
if(W > V) {
y++;
} else if(W===0 && V>=52) {
y--;
}
return y;
},
H: ["getHours", "0"],
I: function (d) { var I=d.getHours()%12; return xPad(I===0?12:I, 0); },
j: function (d) {
var gmd_1 = new Date("" + d.getFullYear() + "/1/1 GMT");
var gmdate = new Date("" + d.getFullYear() + "/" + (d.getMonth()+1) + "/" + d.getDate() + " GMT");
var ms = gmdate - gmd_1;
var doy = parseInt(ms/60000/60/24, 10)+1;
return xPad(doy, 0, 100);
},
k: ["getHours", " "],
l: function (d) { var I=d.getHours()%12; return xPad(I===0?12:I, " "); },
m: function (d) { return xPad(d.getMonth()+1, 0); },
M: ["getMinutes", "0"],
p: function (d, l) { return l.p[d.getHours() >= 12 ? 1 : 0 ]; },
P: function (d, l) { return l.P[d.getHours() >= 12 ? 1 : 0 ]; },
s: function (d, l) { return parseInt(d.getTime()/1000, 10); },
S: ["getSeconds", "0"],
u: function (d) { var dow = d.getDay(); return dow===0?7:dow; },
U: function (d) {
var doy = parseInt(Dt.formats.j(d), 10);
var rdow = 6-d.getDay();
var woy = parseInt((doy+rdow)/7, 10);
return xPad(woy, 0);
},
V: function (d) {
var woy = parseInt(Dt.formats.W(d), 10);
var dow1_1 = (new Date("" + d.getFullYear() + "/1/1")).getDay();
var idow = woy + (dow1_1 > 4 || dow1_1 <= 1 ? 0 : 1);
if(idow === 53 && (new Date("" + d.getFullYear() + "/12/31")).getDay() < 4)
{
idow = 1;
}
else if(idow === 0)
{
idow = Dt.formats.V(new Date("" + (d.getFullYear()-1) + "/12/31"));
}
return xPad(idow, 0);
},
w: "getDay",
W: function (d) {
var doy = parseInt(Dt.formats.j(d), 10);
var rdow = 7-Dt.formats.u(d);
var woy = parseInt((doy+rdow)/7, 10);
return xPad(woy, 0, 10);
},
y: function (d) { return xPad(d.getFullYear()%100, 0); },
Y: "getFullYear",
z: function (d) {
var o = d.getTimezoneOffset();
var H = xPad(parseInt(Math.abs(o/60), 10), 0);
var M = xPad(Math.abs(o%60), 0);
return (o>0?"-":"+") + H + M;
},
Z: function (d) {
var tz = d.toString().replace(/^.*:\d\d( GMT[+-]\d+)? \(?([A-Za-z ]+)\)?\d*$/, "$2").replace(/[a-z ]/g, "");
if(tz.length > 4) {
tz = Dt.formats.z(d);
}
return tz;
},
"%": function (d) { return "%"; }
},
aggregates: {
c: "locale",
D: "%m/%d/%y",
F: "%Y-%m-%d",
h: "%b",
n: "\n",
r: "%I:%M:%S %p",
R: "%H:%M",
t: "\t",
T: "%H:%M:%S",
x: "locale",
X: "locale"
},
format : function (oDate, format) {
var replace_aggs = function (m0, m1) {
var f = Dt.aggregates[m1];
return (f === "locale" ? YDateEn[m1] : f);
};
var replace_formats = function (m0, m1) {
var f = Dt.formats[m1];
switch(typeof f) {
case "string":
return oDate[f]();
case "function":
return f.call(oDate, oDate, YDateEn);
case "array":
case "object":
if(typeof(f[0]) === "string")
return xPad(oDate[f[0]](), f[1]);
default:
return m1;
}
};
while(format.match(/%[cDFhnrRtTxX]/)) {
format = format.replace(/%([cDFhnrRtTxX])/g, replace_aggs);
}
var str = format.replace(/%([aAbBCdegGHIjklmMpPsSuUVwWyYzZ%])/g, replace_formats);
replace_aggs = replace_formats = undefined;
return str;
}
};
// End of YUI code
function strftime(fmt, thisTime)
{
var thisDate = new Date();
thisDate.setTime(Math.floor(thisTime / 1000));
return Dt.format(thisDate, fmt);
};
function fromDatetime(year, month, date, hour, minute, second) {
return (new Date(year, month, date, hour, minute, second)).getTime() * 1000;
};
function datetimeYear(t) {
return (new Date(t / 1000)).getYear() + 1900;
};
function datetimeMonth(t) {
return (new Date(t / 1000)).getMonth();
};
function datetimeDay(t) {
return (new Date(t / 1000)).getDate();
};
function datetimeHour(t) {
return (new Date(t / 1000)).getHours();
};
function datetimeMinute(t) {
return (new Date(t / 1000)).getMinutes();
};
function datetimeSecond(t) {
return (new Date(t / 1000)).getSeconds();
};
function datetimeDayOfWeek(t) {
return (new Date(t / 1000)).getDay();
};
// Error handling
function uw_debug(msg) {
try {
console.debug(msg);
} catch (e) {
alert("DEBUG: " + msg);
}
return 0;
}
function whine(msg) {
alert(msg);
throw msg;
}
function pf(loc) {
throw ("Pattern match failure (" + loc + ")");
}
var lameDuck = false;
function runHandlers(kind, ls, arg) {
if (!lameDuck) {
if (ls == null)
alert(kind + ": " + arg);
for (; ls; ls = ls.next)
try {
exec({c:"a", f:{c:"a", f:ls.data, x:{c:"c", v:arg}}, x:{c:"c", v:null}});
} catch (v) { }
}
}
var errorHandlers = null;
function flift0(v) {
return {c:"c", v:v};
}
function onError(f) {
errorHandlers = cons(flift0(f), errorHandlers);
}
function er(s) {
runHandlers("Error", errorHandlers, s);
throw {uw_error: s};
}
var failHandlers = null;
function onFail(f) {
failHandlers = cons(flift0(f), failHandlers);
}
function doExn(v) {
if (v == null || v.uw_error == null) {
var s = (v == null ? "null" : v.message ? v.message : v.toString());
if (v != null && v.fileName && v.lineNumber)
s += " (" + v.fileName + ":" + v.lineNumber + ")";
runHandlers("Fail", failHandlers, s);
}
}
var disconnectHandlers = null;
function flift(f) {
return {c: "c", v:{env:cons(f,null), body:{c:"v", n:1}}};
}
function onDisconnect(f) {
disconnectHandlers = cons(flift(f), disconnectHandlers);
}
function discon() {
runHandlers("Disconnect", disconnectHandlers, null);
}
var connectHandlers = null;
function onConnectFail(f) {
connectHandlers = cons(flift(f), connectHandlers);
}
function conn(msg) {
var rx = /(.*)((.|\n|\r)*)<\/body>(.*)/g;
var arr = rx.exec(msg);
msg = (arr && arr.length >= 3) ? arr[2] : msg;
runHandlers("RPC failure", connectHandlers, msg);
}
var serverHandlers = null;
function onServerError(f) {
serverHandlers = cons(flift0(f), serverHandlers);
}
function servErr(s) {
window.setTimeout(function () { runHandlers("Server", serverHandlers, s); }, 0);
}
// Key and mouse events
var uw_event = null;
function uw_getEvent() {
return window.event ? window.event : uw_event;
}
function firstGood(x, y) {
if (x == undefined || x == 0)
return y;
else
return x;
}
function uw_mouseEvent() {
var ev = uw_getEvent();
return {_ScreenX : firstGood(ev.screenX, 0),
_ScreenY : firstGood(ev.screenY, 0),
_ClientX : firstGood(ev.clientX, 0),
_ClientY : firstGood(ev.clientY, 0),
_CtrlKey : firstGood(ev.ctrlKey, false),
_ShiftKey : firstGood(ev.shiftKey, false),
_AltKey : firstGood(ev.altKey, false),
_MetaKey : firstGood(ev.metaKey, false),
_Button : ev.button == 2 ? "Right" : ev.button == 1 ? "Middle" : "Left"};
}
function uw_keyEvent() {
var ev = uw_getEvent();
return {_KeyCode : firstGood(ev.keyCode, ev.which),
_CtrlKey : firstGood(ev.ctrlKey, false),
_ShiftKey : firstGood(ev.shiftKey, false),
_AltKey : firstGood(ev.altKey, false),
_MetaKey : firstGood(ev.metaKey, false)};
}
// Document events
function uw_handler(name, f) {
var old = document[name];
if (old == undefined)
document[name] = function(event) { uw_event = event; execF(execF(f, uw_mouseEvent())); };
else
document[name] = function(event) { uw_event = event; old(); execF(execF(f, uw_mouseEvent())); };
}
function uw_onClick(f) {
uw_handler("onclick", f);
}
function uw_onContextmenu(f) {
uw_handler("oncontextmenu", f);
}
function uw_onDblclick(f) {
uw_handler("ondblclick", f);
}
function uw_onMousedown(f) {
uw_handler("onmousedown", f);
}
function uw_onMouseenter(f) {
uw_handler("onmouseenter", f);
}
function uw_onMouseleave(f) {
uw_handler("onmouseleave", f);
}
function uw_onMousemove(f) {
uw_handler("onmousemove", f);
}
function uw_onMouseout(f) {
uw_handler("onmouseout", f);
}
function uw_onMouseover(f) {
uw_handler("onmouseover", f);
}
function uw_onMouseup(f) {
uw_handler("onmouseup", f);
}
function uw_keyHandler(name, f) {
var old = document[name];
if (old == undefined)
document[name] = function(event) { uw_event = event; execF(execF(f, uw_keyEvent())); };
else
document[name] = function(event) { uw_event = event; old(); execF(execF(f, uw_keyEvent())); };
}
function uw_onKeydown(f) {
uw_keyHandler("onkeydown", f);
}
function uw_onKeypress(f) {
uw_keyHandler("onkeypress", f);
}
function uw_onKeyup(f) {
uw_keyHandler("onkeyup", f);
}
// Cancelling of further event processing
function uw_preventDefault() {
var e = window.event ? window.event : uw_event;
e.returnValue = false;
if (e.preventDefault) e.preventDefault();
}
function uw_stopPropagation() {
var e = window.event ? window.event : uw_event;
e.cancelBubble = true;
if (e.stopPropagation) e.stopPropagation();
}
// Embedding closures in XML strings
function cs(f) {
return {closure: f};
}
function isWeird(v) {
return v.closure != null || v.cat1 != null;
}
function cat(s1, s2) {
if (isWeird(s1) || isWeird(s2))
return {cat1: s1, cat2: s2};
else
return s1 + s2;
}
var closures = [];
var freeClosures = null;
function newClosure(f) {
var n;
if (freeClosures == null) {
n = closures.length;
} else {
n = freeClosures.data;
freeClosures = freeClosures.next;
}
closures[n] = f;
return n;
}
function freeClosure(n) {
closures[n] = null;
freeClosures = cons(n, freeClosures);
}
function cr(n) {
return closures[n];
}
function flattenAcc(a, cls, trs) {
while (trs) {
var tr = trs.data;
trs = trs.next;
if (tr.cat1 != null) {
trs = cons(tr.cat1, cons(tr.cat2, trs));
} else if (tr.closure != null) {
var cl = newClosure(tr.closure);
cls.v = cons(cl, cls.v);
a.push("cr(", cl.toString(), ")");
} else
a.push(tr);
}
}
function flatten(cls, tr) {
var a = [];
flattenAcc(a, cls, cons(tr, null));
return a.join("");
}
function flattenLocal(s) {
var cls = {v : null};
var r = flatten(cls, s);
for (cl = cls.v; cl != null; cl = cl.next)
freeClosure(cl.data);
return r;
}
// Dynamic tree management
function populate(node) {
var s = node.signal;
var oldSources = node.sources;
try {
var sr = execF(s, null);
var newSources = sr._sources;
for (var sp = oldSources; sp; sp = sp.next)
if (!member(sp.data, newSources))
sp.data.dyns = remove(node, sp.data.dyns);
for (var sp = newSources; sp; sp = sp.next)
if (!member(sp.data, oldSources))
sp.data.dyns = cons(node, sp.data.dyns);
node.sources = newSources;
node.recreate(sr._data);
} catch (v) {
doExn(v);
}
}
function sc(v) {
return {data : v, dyns : null};
}
function sv(s, v) {
if (s.data != v) {
s.data = v;
for (var ls = s.dyns; ls; ls = ls.next)
if (!ls.dead)
populate(ls.data);
}
}
function sg(s) {
return s.data;
}
function ss(s) {
return {env:cons(s, null), body:{c:"r", l:
cons({n:"sources", v:{c:"c", v:cons(s, null)}},
cons({n:"data", v:{c:"f", f:sg, a:cons({c:"v", n:1}, null)}}, null))}};
}
function sr(v) {
return {env:null, body:{c:"c", v:{_sources : null, _data : v}}};
}
function sb(x,y) {
return {env:cons(y,cons(x,null)),
body:{c:"=",
e1:{c:"a", f:{c:"v", n:2}, x:{c:"c", v:null}},
e2:{c:"=",
e1:{c:"a",
f:{c:"a", f:{c:"v", n:2}, x:{c:".", r:{c:"v", n:0}, f:"data"}},
x:{c:"c", v:null}},
e2:{c:"r", l:cons(
{n:"sources", v:{c:"f", f:union, a:cons({c:".", r:{c:"v", n:1}, f:"sources"},
cons({c:".", r:{c:"v", n:0}, f:"sources"}, null))}},
cons({n:"data", v:{c:".", r:{c:"v", n:0}, f:"data"}}, null))}}}};
}
function scur(s) {
return execF(s, null)._data;
}
function lastParent() {
var pos = document.body;
while (pos.lastChild && pos.lastChild.nodeType == 1)
pos = pos.lastChild;
pos = pos.parentNode;
return pos;
}
var thisScript = null;
function addNode(node) {
if (thisScript) {
if (thisScript.parentNode)
thisScript.parentNode.replaceChild(node, thisScript);
} else
lastParent().appendChild(node);
}
function runScripts(node) {
if (node.tagName == "SCRIPT") {
var savedScript = thisScript;
thisScript = node;
try {
eval(thisScript.text);
} catch (v) {
doExn(v);
}
if (thisScript.parentNode)
thisScript.parentNode.removeChild(thisScript);
thisScript = savedScript;
} else if (node.getElementsByTagName) {
var savedScript = thisScript;
var scripts = node.getElementsByTagName("script"), scriptsCopy = [];
var len = scripts.length;
for (var i = 0; i < len; ++i)
scriptsCopy[i] = scripts[i];
for (var i = 0; i < len; ++i) {
thisScript = scriptsCopy[i];
try {
eval(thisScript.text);
} catch (v) {
doExn(v);
}
if (thisScript.parentNode)
thisScript.parentNode.removeChild(thisScript);
}
thisScript = savedScript;
}
}
// Dynamic tree entry points
function killScript(scr) {
scr.dead = true;
for (var ls = scr.sources; ls; ls = ls.next)
ls.data.dyns = remove(scr, ls.data.dyns);
for (var ls = scr.closures; ls; ls = ls.next)
freeClosure(ls.data);
}
// Sometimes we wind up with tables that contain ", 9);
} else {
size_t lenH = strlen(ctx->script_header);
char *start = s + 6, *oldPage = ctx->page.start;
ctx_uw_buffer_check(ctx, "page", &ctx->page, uw_buffer_used(&ctx->page) + lenH);
start += ctx->page.start - oldPage;
memmove(start + lenH, start, uw_buffer_used(&ctx->page) - (start - ctx->page.start) + 1);
ctx->page.front += lenH;
memcpy(start, ctx->script_header, lenH);
}
} else {
// No . At this point, add it, with ", 16);
} else {
size_t lenH = strlen(ctx->script_header);
size_t lenP = lenH + 13;
char *start = s, *oldPage = ctx->page.start;
ctx_uw_buffer_check(ctx, "page", &ctx->page, uw_buffer_used(&ctx->page) + lenP);
start += ctx->page.start - oldPage;
memmove(start + lenP, start, uw_buffer_used(&ctx->page) - (start - ctx->page.start) + 1);
ctx->page.front += lenP;
memcpy(start, "", 6);
memcpy(start + 6, ctx->script_header, lenH);
memcpy(start + 6 + lenH, "", 7);
}
}
}
if (ctx->needsResig) {
sig = find_sig(ctx->page.start);
if (sig) {
char *realsig = ctx->app->cookie_sig(ctx);
do {
memcpy(sig, realsig, 2*uw_hash_blocksize);
sig = find_sig(sig);
} while (sig);
}
}
return 0;
}
size_t uw_transactionals_max = SIZE_MAX;
int uw_register_transactional(uw_context ctx, void *data, uw_callback commit, uw_callback rollback,
uw_callback_with_retry free) {
if (ctx->used_transactionals >= ctx->n_transactionals) {
if (ctx->used_transactionals+1 > uw_transactionals_max)
// Exceeded limit on number of transactionals.
return -1;
ctx->transactionals = realloc(ctx->transactionals, sizeof(transactional) * (ctx->used_transactionals+1));
++ctx->n_transactionals;
}
ctx->transactionals[ctx->used_transactionals].data = data;
ctx->transactionals[ctx->used_transactionals].commit = commit;
ctx->transactionals[ctx->used_transactionals].rollback = rollback;
ctx->transactionals[ctx->used_transactionals++].free = free;
return 0;
}
// "Garbage collection"
void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data);
void uw_post_expunge(uw_context ctx, void *data);
static failure_kind uw_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
int r = setjmp(ctx->jmp_buf);
if (r == 0)
uw_do_expunge(ctx, cli, data);
else
ctx->app->db_rollback(ctx);
uw_post_expunge(ctx, data);
return r;
}
void uw_prune_clients(uw_context ctx) {
client *c, *next, *prev = NULL;
time_t cutoff;
cutoff = time(NULL) - ctx->app->timeout;
pthread_mutex_lock(&clients_mutex);
pruning_thread = pthread_self();
pruning_thread_initialized = 1;
for (c = clients_used; c; c = next) {
next = c->next;
pthread_mutex_lock(&c->lock);
if (c->last_contact < cutoff && c->refcount == 0) {
failure_kind fk = UNLIMITED_RETRY;
if (prev)
prev->next = next;
else
clients_used = next;
while (fk == UNLIMITED_RETRY) {
uw_reset(ctx);
fk = uw_expunge(ctx, c->id, c->data);
if (fk == UNLIMITED_RETRY)
printf("Unlimited retry during expunge: %s\n", uw_error_message(ctx));
}
if (fk == SUCCESS)
free_client(c);
else
fprintf(stderr, "Expunge blocked by error: %s\n", uw_error_message(ctx));
}
else
prev = c;
pthread_mutex_unlock(&c->lock);
}
pthread_mutex_unlock(&clients_mutex);
}
failure_kind uw_initialize(uw_context ctx) {
int r = setjmp(ctx->jmp_buf);
if (r == 0) {
uw_ensure_transaction(ctx);
ctx->app->initializer(ctx);
if (uw_commit(ctx))
uw_error(ctx, FATAL, "Error running SQL COMMIT");
}
return r;
}
static int url_bad(uw_Basis_string s) {
for (; *s; ++s)
if (!isgraph((int)*s))
return 1;
return 0;
}
uw_Basis_string uw_Basis_bless(uw_context ctx, uw_Basis_string s) {
if (url_bad(s))
uw_error(ctx, FATAL, "Invalid URL %s", uw_Basis_htmlifyString(ctx, s));
if (ctx->app->check_url(s))
return s;
else
uw_error(ctx, FATAL, "Disallowed URL %s", uw_Basis_htmlifyString(ctx, s));
}
uw_Basis_string uw_Basis_checkUrl(uw_context ctx, uw_Basis_string s) {
if (url_bad(s))
return NULL;
if (ctx->app->check_url(s))
return s;
else
return NULL;
}
static int mime_format(const char *s) {
for (; *s; ++s)
if (!isalnum((int)*s) && *s != '/' && *s != '-' && *s != '.' && *s != '+')
return 0;
return 1;
}
uw_Basis_string uw_Basis_blessMime(uw_context ctx, uw_Basis_string s) {
if (!mime_format(s))
uw_error(ctx, FATAL, "MIME type \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s));
if (ctx->app->check_mime(s))
return s;
else
uw_error(ctx, FATAL, "Disallowed MIME type %s", uw_Basis_htmlifyString(ctx, s));
}
uw_Basis_string uw_Basis_checkMime(uw_context ctx, uw_Basis_string s) {
if (!mime_format(s))
return NULL;
if (ctx->app->check_mime(s))
return s;
else
return NULL;
}
uw_Basis_string uw_Basis_blessRequestHeader(uw_context ctx, uw_Basis_string s) {
if (!mime_format(s))
uw_error(ctx, FATAL, "Request header \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s));
if (ctx->app->check_requestHeader(s))
return s;
else
uw_error(ctx, FATAL, "Disallowed request header %s", uw_Basis_htmlifyString(ctx, s));
}
uw_Basis_string uw_Basis_checkRequestHeader(uw_context ctx, uw_Basis_string s) {
if (!mime_format(s))
return NULL;
if (ctx->app->check_requestHeader(s))
return s;
else
return NULL;
}
uw_Basis_string uw_Basis_blessResponseHeader(uw_context ctx, uw_Basis_string s) {
if (!mime_format(s))
uw_error(ctx, FATAL, "Response header \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s));
if (ctx->app->check_responseHeader(s))
return s;
else
uw_error(ctx, FATAL, "Disallowed response header %s", uw_Basis_htmlifyString(ctx, s));
}
static int envVar_format(const char *s) {
for (; *s; ++s)
if (!isalnum((int)*s) && *s != '_' && *s != '.')
return 0;
return 1;
}
uw_Basis_string uw_Basis_checkResponseHeader(uw_context ctx, uw_Basis_string s) {
if (!envVar_format(s))
return NULL;
if (ctx->app->check_responseHeader(s))
return s;
else
return NULL;
}
uw_Basis_string uw_Basis_blessEnvVar(uw_context ctx, uw_Basis_string s) {
if (!envVar_format(s))
uw_error(ctx, FATAL, "Environment variable \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s));
if (ctx->app->check_envVar(s))
return s;
else
uw_error(ctx, FATAL, "Disallowed environment variable %s", uw_Basis_htmlifyString(ctx, s));
}
uw_Basis_string uw_Basis_checkEnvVar(uw_context ctx, uw_Basis_string s) {
if (!mime_format(s))
return NULL;
if (ctx->app->check_envVar(s))
return s;
else
return NULL;
}
uw_Basis_string uw_Basis_getHeader(uw_context ctx, uw_Basis_string name) {
return uw_Basis_requestHeader(ctx, name);
}
static int mime_value_format(const char *s) {
for (; *s; ++s)
if (*s == '\r' || *s == '\n')
return 0;
return 1;
}
uw_unit uw_Basis_setHeader(uw_context ctx, uw_Basis_string name, uw_Basis_string value) {
if (!mime_value_format(value))
uw_error(ctx, FATAL, "Invalid value for HTTP response header");
uw_write_header(ctx, name);
uw_write_header(ctx, ": ");
uw_write_header(ctx, value);
uw_write_header(ctx, "\r\n");
return uw_unit_v;
}
uw_Basis_string uw_Basis_getenv(uw_context ctx, uw_Basis_string name) {
if (ctx->get_env)
return ctx->get_env(ctx->get_env_data, name);
else
return getenv(name);
}
uw_Basis_string uw_unnull(uw_Basis_string s) {
return s ? s : "";
}
uw_Basis_string uw_Basis_makeSigString(uw_context ctx, uw_Basis_string sig) {
uw_Basis_string r = uw_malloc(ctx, 2 * uw_hash_blocksize + 1);
int i;
for (i = 0; i < uw_hash_blocksize; ++i)
sprintf(&r[2*i], "%.02X", ((unsigned char *)sig)[i]);
return r;
}
/* This bit of crafty code is intended to prevent GCC from performing
* optimizations that would enable timing attacks. See:
* http://www.impredicative.com/pipermail/ur/2011-July/000659.html
*/
int uw_streq(uw_Basis_string s1, uw_Basis_string s2) {
int i, x = 0, len1 = strlen(s1);
if (len1 != strlen(s2)) return 0;
for (i = 0; i < len1; ++i) {
__asm__ __volatile__ ("");
x |= s1[i] ^ s2[i];
}
return x == 0;
}
uw_Basis_string uw_Basis_sigString(uw_context ctx, uw_unit u) {
ctx->usedSig = 1;
return ctx->app->cookie_sig(ctx);
}
uw_Basis_string uw_Basis_fileName(uw_context ctx, uw_Basis_file f) {
return f.name;
}
uw_Basis_string uw_Basis_fileMimeType(uw_context ctx, uw_Basis_file f) {
return f.type;
}
uw_Basis_int uw_Basis_blobSize(uw_context ctx, uw_Basis_blob b) {
return b.size;
}
uw_Basis_blob uw_Basis_textBlob(uw_context ctx, uw_Basis_string s) {
uw_Basis_blob b = {strlen(s), s};
return b;
}
uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) {
return f.data;
}
uw_Basis_string uw_Basis_postType(uw_context ctx, uw_Basis_postBody pb) {
return pb.type;
}
uw_Basis_string uw_Basis_postData(uw_context ctx, uw_Basis_postBody pb) {
return pb.data;
}
static char *old_headers(uw_context ctx) {
if (uw_buffer_used(&ctx->outHeaders) == 0)
return NULL;
else {
char *s = strchr(ctx->outHeaders.start, '\n');
if (s == NULL || strncasecmp(s+1, "Content-type: ", 14))
return NULL;
else {
s = strchr(s+15, '\n');
if (s == NULL)
return NULL;
else
return uw_strdup(ctx, s+1);
}
}
}
__attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, uw_Basis_string mimeType) {
cleanup *cl;
int len;
char *oldh;
if (!ctx->allowed_to_return_indirectly)
uw_error(ctx, FATAL, "Tried to return a blob from an RPC");
ctx->returning_indirectly = 1;
oldh = old_headers(ctx);
uw_buffer_reset(&ctx->outHeaders);
uw_buffer_reset(&ctx->page);
uw_write_header(ctx, on_success);
uw_write_header(ctx, "Content-Type: ");
uw_write_header(ctx, mimeType);
uw_write_header(ctx, "\r\nContent-length: ");
ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX);
sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)b.size, &len);
ctx->outHeaders.front += len;
uw_write_header(ctx, "\r\n");
if (oldh) uw_write_header(ctx, oldh);
ctx_uw_buffer_append(ctx, "page", &ctx->page, b.data, b.size);
for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl)
cl->func(cl->arg);
ctx->cleanup_front = ctx->cleanup;
longjmp(ctx->jmp_buf, RETURN_INDIRECTLY);
}
void uw_replace_page(uw_context ctx, const char *data, size_t size) {
uw_buffer_reset(&ctx->page);
ctx_uw_buffer_append(ctx, "page", &ctx->page, data, size);
}
__attribute__((noreturn)) void uw_return_blob_from_page(uw_context ctx, uw_Basis_string mimeType) {
cleanup *cl;
int len;
char *oldh;
if (!ctx->allowed_to_return_indirectly)
uw_error(ctx, FATAL, "Tried to return a blob from an RPC");
ctx->returning_indirectly = 1;
oldh = old_headers(ctx);
uw_buffer_reset(&ctx->outHeaders);
uw_write_header(ctx, on_success);
uw_write_header(ctx, "Content-Type: ");
uw_write_header(ctx, mimeType);
uw_write_header(ctx, "\r\nContent-length: ");
ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX);
sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)uw_buffer_used(&ctx->page), &len);
ctx->outHeaders.front += len;
uw_write_header(ctx, "\r\n");
if (oldh) uw_write_header(ctx, oldh);
for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl)
cl->func(cl->arg);
ctx->cleanup_front = ctx->cleanup;
longjmp(ctx->jmp_buf, RETURN_INDIRECTLY);
}
__attribute__((noreturn)) void uw_redirect(uw_context ctx, uw_Basis_string url) {
cleanup *cl;
char *s;
char *oldh;
if (!ctx->allowed_to_return_indirectly)
uw_error(ctx, FATAL, "Tried to redirect from an RPC");
ctx->returning_indirectly = 1;
oldh = old_headers(ctx);
uw_buffer_reset(&ctx->page);
ctx_uw_buffer_check(ctx, "page", &ctx->page, uw_buffer_used(&ctx->outHeaders)+1);
memcpy(ctx->page.start, ctx->outHeaders.start, uw_buffer_used(&ctx->outHeaders));
ctx->page.start[uw_buffer_used(&ctx->outHeaders)] = 0;
uw_buffer_reset(&ctx->outHeaders);
if (on_success[0])
uw_write_header(ctx, on_redirect);
else
uw_write_header(ctx, "Status: 303 See Other\r\n");
s = on_success[0] ? strchr(ctx->page.start, '\n') : ctx->page.start;
if (s) {
char *s2;
if (s[0] == '\n') ++s;
for (; (s2 = strchr(s, '\n')); s = s2+1) {
*s2 = 0;
if (!strncmp(s, "Set-Cookie: ", 12)) {
uw_write_header(ctx, s);
uw_write_header(ctx, "\n");
}
}
}
uw_write_header(ctx, "Location: ");
uw_write_header(ctx, url);
uw_write_header(ctx, "\r\n\r\n");
if (oldh) uw_write_header(ctx, oldh);
for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl)
cl->func(cl->arg);
ctx->cleanup_front = ctx->cleanup;
longjmp(ctx->jmp_buf, RETURN_INDIRECTLY);
}
uw_Basis_string uw_Basis_unAs(uw_context ctx, uw_Basis_string s) {
uw_Basis_string ret = uw_malloc(ctx, strlen(s) + 1), r = ret;
for (; *s; ++s) {
if (s[0] == '\'') {
*r++ = '\'';
for (++s; *s; ++s) {
if (s[0] == '\'') {
*r++ = '\'';
break;
} else if (s[0] == '\\') {
*r++ = '\\';
*r++ = s[1];
++s;
} else
*r++ = s[0];
}
if (*s == 0) break;
} else if (s[0] == 'T' && s[1] == '_' && s[2] == 'T' && s[3] == '.')
s += 3;
else
*r++ = s[0];
}
*r = 0;
return ret;
}
uw_Basis_string uw_Basis_mstrcat(uw_context ctx, ...) {
va_list ap;
size_t len = 1;
char *s, *r, *s2;
va_start(ap, ctx);
for (s = va_arg(ap, char*); s; s = va_arg(ap, char*))
len += strlen(s);
va_end(ap);
r = uw_malloc(ctx, len);
va_start(ap, ctx);
for (s2 = r, s = va_arg(ap, char*); s; s = va_arg(ap, char*))
while (*s)
*s2++ = *s++;
va_end(ap);
*s2 = 0;
return r;
}
const uw_Basis_time uw_Basis_minTime = {};
uw_Basis_time uw_Basis_now(uw_context ctx) {
uw_Basis_time r = { time(NULL) };
return r;
}
uw_Basis_time uw_Basis_addSeconds(uw_context ctx, uw_Basis_time tm, uw_Basis_int n) {
tm.seconds += n;
return tm;
}
uw_Basis_int uw_Basis_diffInSeconds(uw_context ctx, uw_Basis_time tm1, uw_Basis_time tm2) {
return difftime(tm2.seconds, tm1.seconds);
}
uw_Basis_int uw_Basis_toMilliseconds(uw_context ctx, uw_Basis_time tm) {
return tm.seconds * 1000 + tm.microseconds / 1000;
}
uw_Basis_time uw_Basis_fromMilliseconds(uw_context ctx, uw_Basis_int n) {
uw_Basis_time tm = {n / 1000, n % 1000 * 1000};
return tm;
}
uw_Basis_int uw_Basis_diffInMilliseconds(uw_context ctx, uw_Basis_time tm1, uw_Basis_time tm2) {
return uw_Basis_toMilliseconds(ctx, tm2) - uw_Basis_toMilliseconds(ctx, tm1);
}
uw_Basis_int uw_Basis_toSeconds(uw_context ctx, uw_Basis_time tm) {
return tm.seconds;
}
uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_int month, uw_Basis_int day, uw_Basis_int hour, uw_Basis_int minute, uw_Basis_int second) {
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) };
return r;
}
uw_Basis_int uw_Basis_datetimeYear(uw_context ctx, uw_Basis_time time) {
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_year + 1900;
}
uw_Basis_int uw_Basis_datetimeMonth(uw_context ctx, uw_Basis_time time) {
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_mon;
}
uw_Basis_int uw_Basis_datetimeDay(uw_context ctx, uw_Basis_time time) {
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_mday;
}
uw_Basis_int uw_Basis_datetimeHour(uw_context ctx, uw_Basis_time time) {
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_hour;
}
uw_Basis_int uw_Basis_datetimeMinute(uw_context ctx, uw_Basis_time time) {
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_min;
}
uw_Basis_int uw_Basis_datetimeSecond(uw_context ctx, uw_Basis_time time) {
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_sec;
}
uw_Basis_int uw_Basis_datetimeDayOfWeek(uw_context ctx, uw_Basis_time time) {
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_wday;
}
void *uw_get_global(uw_context ctx, char *name) {
int i;
for (i = 0; i < ctx->n_globals; ++i)
if (!strcmp(name, ctx->globals[i].name))
return ctx->globals[i].data;
return NULL;
}
size_t uw_globals_max = SIZE_MAX;
void uw_set_global(uw_context ctx, char *name, void *data, void (*free)(void*)) {
int i;
for (i = 0; i < ctx->n_globals; ++i)
if (!strcmp(name, ctx->globals[i].name)) {
if (ctx->globals[i].free)
ctx->globals[i].free(ctx->globals[i].data);
ctx->globals[i].data = data;
ctx->globals[i].free = free;
return;
}
if (ctx->n_globals+1 > uw_globals_max)
uw_error(ctx, FATAL, "Exceeded limit on number of globals");
++ctx->n_globals;
ctx->globals = realloc(ctx->globals, ctx->n_globals * sizeof(global));
ctx->globals[ctx->n_globals-1].name = name;
ctx->globals[ctx->n_globals-1].data = data;
ctx->globals[ctx->n_globals-1].free = free;
}
uw_Basis_bool uw_Basis_isalnum(uw_context ctx, uw_Basis_char c) {
return !!isalnum((int)c);
}
uw_Basis_bool uw_Basis_isalpha(uw_context ctx, uw_Basis_char c) {
return !!isalpha((int)c);
}
uw_Basis_bool uw_Basis_isblank(uw_context ctx, uw_Basis_char c) {
return !!isblank((int)c);
}
uw_Basis_bool uw_Basis_iscntrl(uw_context ctx, uw_Basis_char c) {
return !!iscntrl((int)c);
}
uw_Basis_bool uw_Basis_isdigit(uw_context ctx, uw_Basis_char c) {
return !!isdigit((int)c);
}
uw_Basis_bool uw_Basis_isgraph(uw_context ctx, uw_Basis_char c) {
return !!isgraph((int)c);
}
uw_Basis_bool uw_Basis_islower(uw_context ctx, uw_Basis_char c) {
return !!islower((int)c);
}
uw_Basis_bool uw_Basis_isprint(uw_context ctx, uw_Basis_char c) {
return !!isprint((int)c);
}
uw_Basis_bool uw_Basis_ispunct(uw_context ctx, uw_Basis_char c) {
return !!ispunct((int)c);
}
uw_Basis_bool uw_Basis_isspace(uw_context ctx, uw_Basis_char c) {
return !!isspace((int)c);
}
uw_Basis_bool uw_Basis_isupper(uw_context ctx, uw_Basis_char c) {
return !!isupper((int)c);
}
uw_Basis_bool uw_Basis_isxdigit(uw_context ctx, uw_Basis_char c) {
return !!isxdigit((int)c);
}
uw_Basis_char uw_Basis_tolower(uw_context ctx, uw_Basis_char c) {
return tolower((int)c);
}
uw_Basis_char uw_Basis_toupper(uw_context ctx, uw_Basis_char c) {
return toupper((int)c);
}
uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c) {
return (unsigned char)c;
}
uw_Basis_char uw_Basis_chr(uw_context ctx, uw_Basis_int n) {
return n;
}
uw_Basis_string uw_Basis_currentUrl(uw_context ctx) {
return ctx->current_url;
}
void uw_set_currentUrl(uw_context ctx, char *s) {
ctx->current_url = s;
}
void uw_set_deadline(uw_context ctx, int n) {
ctx->deadline = n;
}
void uw_check_deadline(uw_context ctx) {
if (uw_time > ctx->deadline)
uw_error(ctx, FATAL, "Maximum running time exceeded");
}
size_t uw_database_max = SIZE_MAX;
uw_Basis_int uw_Basis_naughtyDebug(uw_context ctx, uw_Basis_string s) {
if (ctx->loggers->log_debug)
ctx->loggers->log_debug(ctx->loggers->logger_data, "%s\n", s);
else
fprintf(stderr, "%s\n", s);
return 0;
}
uw_Basis_unit uw_Basis_debug(uw_context ctx, uw_Basis_string s) {
if (ctx->loggers->log_debug)
ctx->loggers->log_debug(ctx->loggers->logger_data, "%s\n", s);
else
fprintf(stderr, "%s\n", s);
return uw_unit_v;
}
uw_Basis_int uw_Basis_rand(uw_context ctx) {
int r = my_rand();
if (r >= 0)
return r;
else
uw_error(ctx, FATAL, "Random number generation failed");
}
void uw_noPostBody(uw_context ctx) {
ctx->hasPostBody = 0;
}
void uw_postBody(uw_context ctx, uw_Basis_postBody pb) {
ctx->hasPostBody = 1;
ctx->postBody = pb;
}
int uw_hasPostBody(uw_context ctx) {
return ctx->hasPostBody;
}
void uw_isPost(uw_context ctx) {
ctx->isPost = 1;
}
uw_Basis_bool uw_Basis_currentUrlHasPost(uw_context ctx) {
return ctx->isPost;
}
uw_Basis_bool uw_Basis_currentUrlHasQueryString(uw_context ctx) {
return ctx->queryString != NULL && ctx->queryString[0] != 0;
}
void uw_setQueryString(uw_context ctx, uw_Basis_string s) {
ctx->queryString = s;
}
uw_Basis_string uw_queryString(uw_context ctx) {
return ctx->queryString;
}
uw_Basis_postBody uw_getPostBody(uw_context ctx) {
if (ctx->hasPostBody)
return ctx->postBody;
else
uw_error(ctx, FATAL, "Asked for POST body when none exists");
}
failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) {
int r = setjmp(ctx->jmp_buf);
if (r == 0) {
uw_ensure_transaction(ctx);
callback(ctx);
}
return r;
}
uw_Basis_string uw_Basis_crypt(uw_context ctx, uw_Basis_string key, uw_Basis_string salt) {
char buf[14];
return uw_strdup(ctx, DES_fcrypt(key, salt, buf));
}
uw_Basis_bool uw_Basis_eq_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) {
return !!(t1.seconds == t2.seconds && t1.microseconds == t2.microseconds);
}
uw_Basis_bool uw_Basis_lt_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) {
return !!(t1.seconds < t2.seconds || (t1.seconds == t2.seconds && t1.microseconds < t2.microseconds));
}
uw_Basis_bool uw_Basis_le_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) {
return !!(uw_Basis_eq_time(ctx, t1, t2) || uw_Basis_lt_time(ctx, t1, t2));
}
uw_Basis_time *uw_Basis_readUtc(uw_context ctx, uw_Basis_string s) {
struct tm stm = {};
char *end = strchr(s, 0);
stm.tm_isdst = -1;
if (strptime(s, TIME_FMT_PG, &stm) == end || strptime(s, TIME_FMT, &stm) == end || strptime(s, TIME_FMT_JS, &stm) == end) {
uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time));
r->seconds = timegm(&stm);
r->microseconds = 0;
return r;
}
else
return NULL;
}
failure_kind uw_begin_onError(uw_context ctx, char *msg) {
int r = setjmp(ctx->jmp_buf);
if (ctx->app->on_error) {
if (r == 0) {
uw_ensure_transaction(ctx);
uw_buffer_reset(&ctx->outHeaders);
if (on_success[0])
uw_write_header(ctx, "HTTP/1.1 ");
else
uw_write_header(ctx, "Status: ");
uw_write_header(ctx, "500 Internal Server Error\r\n");
uw_write_header(ctx, "Content-type: text/html\r\n");
uw_write(ctx, ctx->app->is_html5 ? uw_begin_html5 : uw_begin_xhtml);
ctx->app->on_error(ctx, msg);
uw_write(ctx, "");
}
return r;
} else
uw_error(ctx, FATAL, "Tried to run nonexistent onError handler");
}
void uw_mayReturnIndirectly(uw_context ctx) {
ctx->allowed_to_return_indirectly = 1;
}
uw_Basis_string uw_Basis_fresh(uw_context ctx) {
int len;
char *r;
uw_check_heap(ctx, 2+INTS_MAX);
r = ctx->heap.front;
sprintf(r, "uw%u%n", ctx->nextId++, &len);
ctx->heap.front += len+1;
return r;
}
uw_Basis_float uw_Basis_floatFromInt(uw_context ctx, uw_Basis_int n) {
return n;
}
uw_Basis_int uw_Basis_ceil(uw_context ctx, uw_Basis_float n) {
return ceil(n);
}
uw_Basis_int uw_Basis_trunc(uw_context ctx, uw_Basis_float n) {
return trunc(n);
}
uw_Basis_int uw_Basis_round(uw_context ctx, uw_Basis_float n) {
return round(n);
}
uw_Basis_string uw_Basis_atom(uw_context ctx, uw_Basis_string s) {
char *p;
for (p = s; *p; ++p) {
char c = *p;
if (!isalnum((int)c) && c != '+' && c != '-' && c != '.' && c != '%' && c != '#')
uw_error(ctx, FATAL, "Disallowed character in CSS atom");
}
return s;
}
uw_Basis_string uw_Basis_css_url(uw_context ctx, uw_Basis_string s) {
char *p;
for (p = s; *p; ++p) {
char c = *p;
if (!isalnum((int)c) && c != ':' && c != '/' && c != '.' && c != '_' && c != '+'
&& c != '-' && c != '%' && c != '?' && c != '&' && c != '=' && c != '#')
uw_error(ctx, FATAL, "Disallowed character in CSS URL");
}
return s;
}
uw_Basis_string uw_Basis_property(uw_context ctx, uw_Basis_string s) {
char *p;
if (!*s)
uw_error(ctx, FATAL, "Empty CSS property");
if (!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 != '-')
uw_error(ctx, FATAL, "Disallowed character in CSS property");
}
return s;
}
uw_Basis_string uw_Basis_fieldName(uw_context ctx, uw_Basis_postField f) {
return f.name;
}
uw_Basis_string uw_Basis_fieldValue(uw_context ctx, uw_Basis_postField f) {
return f.value;
}
uw_Basis_string uw_Basis_remainingFields(uw_context ctx, uw_Basis_postField f) {
return f.remaining;
}
uw_Basis_postField *uw_Basis_firstFormField(uw_context ctx, uw_Basis_string s) {
char *unurl;
uw_Basis_postField *f;
if (!ctx->hasPostBody)
uw_error(ctx, FATAL, "firstFormField called when there is no POST body");
if (s < ctx->postBody.data || s >= ctx->postBody.data + ctx->postBody.len)
return NULL;
f = uw_malloc(ctx, sizeof(uw_Basis_postField));
unurl = s;
f->name = uw_Basis_unurlifyString(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);
s = strchr(s, 0);
if (!s)
uw_error(ctx, FATAL, "firstFormField: Missing null terminator");
f->remaining = s+1;
return f;
}
uw_Basis_string uw_Basis_blessData(uw_context ctx, uw_Basis_string s) {
char *p = s;
for (; *p; ++p)
if (!isalnum(*p) && *p != '-' && *p != '_')
uw_error(ctx, FATAL, "Illegal HTML5 data-* attribute: %s", s);
return s;
}
int uw_remoteSock(uw_context ctx) {
return ctx->remoteSock;
}
void uw_set_remoteSock(uw_context ctx, int sock) {
ctx->remoteSock = sock;
}
// Sqlcache
static void uw_Sqlcache_freeValue(uw_Sqlcache_Value *value) {
if (value) {
free(value->result);
free(value->output);
free(value);
}
}
static void uw_Sqlcache_freeEntry(uw_Sqlcache_Entry* entry) {
if (entry) {
free(entry->key);
uw_Sqlcache_freeValue(entry->value);
free(entry);
}
}
// TODO: pick a number.
static unsigned int uw_Sqlcache_maxSize = 1234567890;
static void uw_Sqlcache_delete(uw_Sqlcache_Cache *cache, uw_Sqlcache_Entry *entry) {
if (entry) {
HASH_DEL(cache->table, entry);
uw_Sqlcache_freeEntry(entry);
}
}
static uw_Sqlcache_Entry *uw_Sqlcache_find(uw_Sqlcache_Cache *cache, char *key, size_t len, int bump) {
uw_Sqlcache_Entry *entry = NULL;
HASH_FIND(hh, cache->table, key, len, entry);
if (entry && bump) {
// Bump for LRU purposes.
HASH_DEL(cache->table, entry);
// Important that we use [entry->key], because [key] might be ephemeral.
HASH_ADD_KEYPTR(hh, cache->table, entry->key, len, entry);
}
return entry;
}
static void uw_Sqlcache_add(uw_Sqlcache_Cache *cache, uw_Sqlcache_Entry *entry, size_t len) {
HASH_ADD_KEYPTR(hh, cache->table, entry->key, len, entry);
if (HASH_COUNT(cache->table) > uw_Sqlcache_maxSize) {
// Deletes the first element of the cache.
uw_Sqlcache_delete(cache, cache->table);
}
}
static unsigned long uw_Sqlcache_getTimeNow(uw_Sqlcache_Cache *cache) {
// TODO: verify that this makes time comparisons do the Right Thing.
return cache->timeNow++;
}
static unsigned long uw_Sqlcache_timeMax(unsigned long x, unsigned long y) {
return x > y ? x : y;
}
static char uw_Sqlcache_keySep = '_';
static char *uw_Sqlcache_allocKeyBuffer(char **keys, size_t numKeys) {
size_t len = 0;
while (numKeys-- > 0) {
char* k = keys[numKeys];
if (!k) {
// Can only happen when flushing, in which case we don't need anything past the null key.
break;
}
// Leave room for separator.
len += 1 + strlen(k);
}
char *buf = malloc(len+1);
// If nothing is copied into the buffer, it should look like it has length 0.
buf[0] = 0;
return buf;
}
static char *uw_Sqlcache_keyCopy(char *buf, char *key) {
*buf++ = uw_Sqlcache_keySep;
return stpcpy(buf, key);
}
// The NUL-terminated prefix of [key] below always looks something like "_k1_k2_k3..._kn".
uw_Sqlcache_Value *uw_Sqlcache_check(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys) {
int doBump = random() % 1024 == 0;
if (doBump) {
pthread_rwlock_wrlock(&cache->lockIn);
} else {
pthread_rwlock_rdlock(&cache->lockIn);
}
size_t numKeys = cache->numKeys;
char *key = uw_Sqlcache_allocKeyBuffer(keys, numKeys);
char *buf = key;
time_t timeInvalid = cache->timeInvalid;
uw_Sqlcache_Entry *entry;
if (numKeys == 0) {
entry = cache->table;
if (!entry) {
free(key);
pthread_rwlock_unlock(&cache->lockIn);
return NULL;
}
} else {
while (numKeys-- > 0) {
buf = uw_Sqlcache_keyCopy(buf, keys[numKeys]);
size_t len = buf - key;
entry = uw_Sqlcache_find(cache, key, len, doBump);
if (!entry) {
free(key);
pthread_rwlock_unlock(&cache->lockIn);
return NULL;
}
timeInvalid = uw_Sqlcache_timeMax(timeInvalid, entry->timeInvalid);
}
free(key);
}
uw_Sqlcache_Value *value = entry->value;
pthread_rwlock_unlock(&cache->lockIn);
// ASK: though the argument isn't trivial, this is safe, right?
// Returning outside the lock is safe because updates happen at commit time.
// Those are the only times the returned value or its strings can get freed.
// Handler output is a new string, so it's safe to free this at commit time.
return value && timeInvalid < value->timeValid ? value : NULL;
}
static void uw_Sqlcache_storeCommitOne(uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcache_Value *value) {
pthread_rwlock_wrlock(&cache->lockIn);
size_t numKeys = cache->numKeys;
time_t timeNow = uw_Sqlcache_getTimeNow(cache);
uw_Sqlcache_Entry *entry;
if (numKeys == 0) {
entry = cache->table;
if (!entry) {
entry = calloc(1, sizeof(uw_Sqlcache_Entry));
entry->key = NULL;
entry->value = NULL;
entry->timeInvalid = 0;
cache->table = entry;
}
} else {
char *key = uw_Sqlcache_allocKeyBuffer(keys, numKeys);
char *buf = key;
while (numKeys-- > 0) {
buf = uw_Sqlcache_keyCopy(buf, keys[numKeys]);
size_t len = buf - key;
entry = uw_Sqlcache_find(cache, key, len, 1);
if (!entry) {
entry = calloc(1, sizeof(uw_Sqlcache_Entry));
entry->key = strdup(key);
entry->value = NULL;
entry->timeInvalid = 0;
uw_Sqlcache_add(cache, entry, len);
}
}
free(key);
}
if (!entry->value || entry->value->timeValid < value->timeValid) {
uw_Sqlcache_freeValue(entry->value);
entry->value = value;
entry->value->timeValid = timeNow;
}
pthread_rwlock_unlock(&cache->lockIn);
}
static void uw_Sqlcache_flushCommitOne(uw_Sqlcache_Cache *cache, char **keys) {
}
static void uw_Sqlcache_commit(void *data) {
uw_context ctx = (uw_context)data;
uw_Sqlcache_Update *update = ctx->cacheUpdate;
while (update) {
uw_Sqlcache_Cache *cache = update->cache;
char **keys = update->keys;
if (update->value) {
uw_Sqlcache_storeCommitOne(cache, keys, update->value);
} else {
uw_Sqlcache_flushCommitOne(cache, keys);
}
update = update->next;
}
}
static void uw_Sqlcache_free(void *data, int dontCare) {
uw_context ctx = (uw_context)data;
uw_Sqlcache_Update *update = ctx->cacheUpdate;
while (update) {
char** keys = update->keys;
size_t numKeys = update->cache->numKeys;
while (numKeys-- > 0) {
free(keys[numKeys]);
}
free(keys);
// Don't free [update->value]: it's in the cache now!
uw_Sqlcache_Update *nextUpdate = update->next;
free(update);
update = nextUpdate;
}
ctx->cacheUpdate = NULL;
ctx->cacheUpdateTail = NULL;
uw_Sqlcache_Unlock *unlock = ctx->cacheUnlock;
while (unlock) {
pthread_rwlock_unlock(unlock->lock);
uw_Sqlcache_Unlock *nextUnlock = unlock->next;
free(unlock);
unlock = nextUnlock;
}
ctx->cacheUnlock = NULL;
}
static void uw_Sqlcache_pushUnlock(uw_context ctx, pthread_rwlock_t *lock) {
if (!ctx->cacheUnlock) {
// Just need one registered commit for both updating and unlocking.
uw_register_transactional(ctx, ctx, uw_Sqlcache_commit, NULL, uw_Sqlcache_free);
}
uw_Sqlcache_Unlock *unlock = malloc(sizeof(uw_Sqlcache_Unlock));
unlock->lock = lock;
unlock->next = ctx->cacheUnlock;
ctx->cacheUnlock = unlock;
}
void uw_Sqlcache_rlock(uw_context ctx, uw_Sqlcache_Cache *cache) {
pthread_rwlock_rdlock(&cache->lockOut);
uw_Sqlcache_pushUnlock(ctx, &cache->lockOut);
}
void uw_Sqlcache_wlock(uw_context ctx, uw_Sqlcache_Cache *cache) {
pthread_rwlock_wrlock(&cache->lockOut);
uw_Sqlcache_pushUnlock(ctx, &cache->lockOut);
}
static char **uw_Sqlcache_copyKeys(char **keys, size_t numKeys) {
char **copy = malloc(sizeof(char *) * numKeys);
while (numKeys-- > 0) {
char *k = keys[numKeys];
copy[numKeys] = k ? strdup(k) : NULL;
}
return copy;
}
void uw_Sqlcache_store(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcache_Value *value) {
uw_Sqlcache_Update *update = malloc(sizeof(uw_Sqlcache_Update));
update->cache = cache;
update->keys = uw_Sqlcache_copyKeys(keys, cache->numKeys);
update->value = value;
update->next = NULL;
// Can't use [uw_Sqlcache_getTimeNow] because it modifies state and we don't have the lock.
pthread_rwlock_rdlock(&cache->lockIn);
value->timeValid = cache->timeNow;
pthread_rwlock_unlock(&cache->lockIn);
if (ctx->cacheUpdateTail) {
ctx->cacheUpdateTail->next = update;
} else {
ctx->cacheUpdate = update;
}
ctx->cacheUpdateTail = update;
}
void uw_Sqlcache_flush(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys) {
// A flush has to happen immediately so that subsequent stores in the same transaction fail.
// This is safe to do because we will always call [uw_Sqlcache_wlock] earlier.
// If the transaction fails, the only harm done is a few extra cache misses.
pthread_rwlock_wrlock(&cache->lockIn);
size_t numKeys = cache->numKeys;
if (numKeys == 0) {
uw_Sqlcache_Entry *entry = cache->table;
if (entry) {
uw_Sqlcache_freeValue(entry->value);
entry->value = NULL;
}
} else {
char *key = uw_Sqlcache_allocKeyBuffer(keys, numKeys);
char *buf = key;
time_t timeNow = uw_Sqlcache_getTimeNow(cache);
while (numKeys-- > 0) {
char *k = keys[numKeys];
if (!k) {
size_t len = buf - key;
if (len == 0) {
// The first key was null.
cache->timeInvalid = timeNow;
} else {
uw_Sqlcache_Entry *entry = uw_Sqlcache_find(cache, key, len, 0);
if (entry) {
entry->timeInvalid = timeNow;
}
}
free(key);
pthread_rwlock_unlock(&cache->lockIn);
return;
}
buf = uw_Sqlcache_keyCopy(buf, k);
}
// All the keys were non-null, so we delete the pointed-to entry.
size_t len = buf - key;
uw_Sqlcache_Entry *entry = uw_Sqlcache_find(cache, key, len, 0);
free(key);
uw_Sqlcache_delete(cache, entry);
}
pthread_rwlock_unlock(&cache->lockIn);
}
urweb-20160213+dfsg/src/cache.sml 0000664 0000000 0000000 00000001372 12657647235 0016410 0 ustar 00root root 0000000 0000000 structure Cache = struct
type cache =
{(* Takes a query ID and parameters (and, for store, the value to
store) and gives an FFI call that checks, stores, or flushes the
relevant entry. The parameters are strings for check and store and
optional strings for flush because some parameters might not be
fixed. *)
check : int * Mono.exp list -> Mono.exp',
store : int * Mono.exp list * Mono.exp -> Mono.exp',
flush : int * Mono.exp list -> Mono.exp',
lock : int * bool (* true = write, false = read *) -> Mono.exp',
(* Generates C needed for FFI calls in check, store, and flush. *)
setupGlobal : Print.PD.pp_desc,
setupQuery : {index : int, params : int} -> Print.PD.pp_desc}
end
urweb-20160213+dfsg/src/cgi.sig 0000664 0000000 0000000 00000003015 12657647235 0016072 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2009, 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 CGI = sig
end
urweb-20160213+dfsg/src/cgi.sml 0000664 0000000 0000000 00000005260 12657647235 0016107 0 ustar 00root root 0000000 0000000 (* 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 Cgi :> CGI = struct
open Settings
open Print.PD Print
val () = addProtocol {name = "cgi",
compile = "",
linkStatic = "liburweb_cgi.a",
linkDynamic = "-lurweb_cgi",
persistent = false,
code = fn () => box [string "void uw_global_custom() {",
case getSigFile () of
NONE => box []
| SOME sf => box [string "extern char *uw_sig_file;",
newline,
string "uw_sig_file = \"",
string sf,
string "\";",
newline],
string "uw_setup_limits();",
newline,
string "}",
newline]}
end
urweb-20160213+dfsg/src/checknest.sig 0000664 0000000 0000000 00000003067 12657647235 0017306 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009, 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 CHECKNEST = sig
val annotate : Cjr.file -> Cjr.file
end
urweb-20160213+dfsg/src/checknest.sml 0000664 0000000 0000000 00000017351 12657647235 0017320 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009, 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 Checknest :> CHECKNEST = struct
open Cjr
structure IS = IntBinarySet
structure IM = IntBinaryMap
fun expUses globals =
let
fun eu (e, _) =
case e of
EPrim _ => IS.empty
| ERel _ => IS.empty
| ENamed n => Option.getOpt (IM.find (globals, n), IS.empty)
| ECon (_, _, NONE) => IS.empty
| ECon (_, _, SOME e) => eu e
| ENone _ => IS.empty
| ESome (_, e) => eu e
| EFfi _ => IS.empty
| EFfiApp (_, _, es) => foldl IS.union IS.empty (map (eu o #1) es)
| EApp (e, es) => foldl IS.union (eu e) (map eu es)
| EUnop (_, e) => eu e
| EBinop (_, e1, e2) => IS.union (eu e1, eu e2)
| ERecord (_, xes) => foldl (fn ((_, e), s) => IS.union (eu e, s)) IS.empty xes
| EField (e, _) => eu e
| ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes
| EError (e, _) => eu e
| EReturnBlob {blob = NONE, mimeType, ...} => eu mimeType
| EReturnBlob {blob = SOME blob, mimeType, ...} => IS.union (eu blob, eu mimeType)
| ERedirect (e, _) => eu e
| EWrite e => eu e
| ESeq (e1, e2) => IS.union (eu e1, eu e2)
| ELet (_, _, e1, e2) => IS.union (eu e1, eu e2)
| EQuery {query, body, initial, prepared, ...} =>
let
val s = IS.union (eu query, IS.union (eu body, eu initial))
in
case prepared of
SOME {id, ...} => IS.add (s, id)
| _ => s
end
| EDml {dml, prepared, ...} =>
let
val s = eu dml
in
case prepared of
SOME {id, ...} => IS.add (s, id)
| _ => s
end
| ENextval {seq, prepared, ...} =>
let
val s = eu seq
in
case prepared of
SOME {id, ...} => IS.add (s, id)
| _ => s
end
| ESetval {seq, count} => IS.union (eu seq, eu count)
| EUnurlify (e, _, _) => eu e
in
eu
end
fun annotateExp globals =
let
fun ae (e as (_, loc)) =
case #1 e of
EPrim _ => e
| ERel _ => e
| ENamed n => e
| ECon (_, _, NONE) => e
| ECon (dk, pc, SOME e) => (ECon (dk, pc, SOME (ae e)), loc)
| ENone _ => e
| ESome (t, e) => (ESome (t, ae e), loc)
| EFfi _ => e
| EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (ae e, t)) es), loc)
| EApp (e, es) => (EApp (ae e, map ae es), loc)
| EUnop (uo, e) => (EUnop (uo, ae e), loc)
| EBinop (bo, e1, e2) => (EBinop (bo, ae e1, ae e2), loc)
| ERecord (n, xes) => (ERecord (n, map (fn (x, e) => (x, ae e)) xes), loc)
| EField (e, f) => (EField (ae e, f), loc)
| ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc)
| EError (e, t) => (EError (ae e, t), loc)
| EReturnBlob {blob = NONE, mimeType, t} => (EReturnBlob {blob = NONE, mimeType = ae mimeType, t = t}, loc)
| EReturnBlob {blob = SOME blob, mimeType, t} => (EReturnBlob {blob = SOME (ae blob), mimeType = ae mimeType, t = t}, loc)
| ERedirect (e, t) => (ERedirect (ae e, t), loc)
| EWrite e => (EWrite (ae e), loc)
| ESeq (e1, e2) => (ESeq (ae e1, ae e2), loc)
| ELet (x, t, e1, e2) => (ELet (x, t, ae e1, ae e2), loc)
| EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
(EQuery {exps = exps,
tables = tables,
rnum = rnum,
state = state,
query = ae query,
body = ae body,
initial = ae initial,
prepared = case prepared of
NONE => NONE
| SOME {id, query, ...} => SOME {id = id, query = query,
nested = IS.member (expUses globals body, id)}},
loc)
| EDml {dml, prepared, mode} =>
(EDml {dml = ae dml,
prepared = prepared,
mode = mode}, loc)
| ENextval {seq, prepared} =>
(ENextval {seq = ae seq,
prepared = prepared}, loc)
| ESetval {seq, count} =>
(ESetval {seq = ae seq,
count = ae count}, loc)
| EUnurlify (e, t, b) => (EUnurlify (ae e, t, b), loc)
in
ae
end
fun annotate (ds, syms) =
let
val globals =
foldl (fn ((d, _), globals) =>
case d of
DVal (_, n, _, e) => IM.insert (globals, n, expUses globals e)
| DFun (_, n, _, _, e) => IM.insert (globals, n, expUses globals e)
| DFunRec fs =>
let
val s = foldl (fn ((_, _, _, _, e), s) => IS.union (expUses globals e, s)) IS.empty fs
in
foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, s)) globals fs
end
| _ => globals) IM.empty ds
val ds =
map (fn d as (_, loc) =>
case #1 d of
DVal (x, n, t, e) => (DVal (x, n, t, annotateExp globals e), loc)
| DFun (x, n, ts, t, e) => (DFun (x, n, ts, t, annotateExp globals e), loc)
| DFunRec fs => (DFunRec
(map (fn (x, n, ts, t, e) => (x, n, ts, t, annotateExp globals e)) fs), loc)
| _ => d) ds
in
(ds, syms)
end
end
urweb-20160213+dfsg/src/cjr.sml 0000664 0000000 0000000 00000011714 12657647235 0016124 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 Cjr = struct
type 'a located = 'a ErrorMsg.located
datatype datatype_kind = datatype DatatypeKind.datatype_kind
datatype typ' =
TFun of typ * typ
| TRecord of int
| TDatatype of datatype_kind * int * (string * int * typ option) list ref
| TFfi of string * string
| TOption of typ
| TList of typ * int
withtype typ = typ' located
datatype patCon =
PConVar of int
| PConFfi of {mod : string, datatyp : string, con : string, arg : typ option}
datatype pat' =
PVar of string * typ
| PPrim of Prim.t
| PCon of datatype_kind * patCon * pat option
| PRecord of (string * pat * typ) list
| PNone of typ
| PSome of typ * pat
withtype pat = pat' located
datatype failure_mode = datatype Settings.failure_mode
datatype exp' =
EPrim of Prim.t
| ERel of int
| ENamed of int
| ECon of datatype_kind * patCon * exp option
| ENone of typ
| ESome of typ * exp
| EFfi of string * string
| EFfiApp of string * string * (exp * typ) list
| EApp of exp * exp list
| EUnop of string * exp
| EBinop of string * exp * exp
| ERecord of int * (string * exp) list
| EField of exp * string
| ECase of exp * (pat * exp) list * { disc : typ, result : typ }
| EError of exp * typ
| EReturnBlob of {blob : exp option, mimeType : exp, t : typ}
| ERedirect of exp * typ
| EWrite of exp
| ESeq of exp * exp
| ELet of string * typ * exp * exp
| EQuery of { exps : (string * typ) list,
tables : (string * (string * typ) list) list,
rnum : int,
state : typ,
query : exp,
body : exp,
initial : exp,
prepared : {id : int, query : string, nested : bool} option }
| EDml of { dml : exp,
prepared : {id : int, dml : string} option,
mode : failure_mode }
| ENextval of { seq : exp,
prepared : {id : int, query : string} option }
| ESetval of { seq : exp, count : exp }
| EUnurlify of exp * typ * bool
withtype exp = exp' located
datatype task = Initialize | ClientLeaves | Periodic of Int64.int
datatype decl' =
DStruct of int * (string * typ) list
| DDatatype of (datatype_kind * string * int * (string * int * typ option) list) list
| DDatatypeForward of datatype_kind * string * int
| DVal of string * int * typ * exp
| DFun of string * int * (string * typ) list * typ * exp
| DFunRec of (string * int * (string * typ) list * typ * exp) list
| 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}
| DPreparedStatements of (string * int) list
| DJavaScript of string
| DCookie of string
| DStyle of string
| DTask of task * string (* first arg name *) * string * exp
| DOnError of int
withtype decl = decl' located
datatype sidedness = datatype Mono.sidedness
datatype dbmode = datatype Mono.dbmode
datatype effect = datatype Export.effect
datatype export_kind = datatype Export.export_kind
type file = decl list * (export_kind * string * int * typ list * typ * sidedness * dbmode * bool) list
end
urweb-20160213+dfsg/src/cjr_env.sig 0000664 0000000 0000000 00000005016 12657647235 0016761 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 CJR_ENV = sig
type env
val empty : env
exception UnboundRel of int
exception UnboundNamed of int
exception UnboundF of int
exception UnboundStruct of int
val pushDatatype : env -> string -> int -> (string * int * Cjr.typ option) list -> env
val lookupDatatype : env -> int -> string * (string * int * Cjr.typ option) list
val lookupConstructor : env -> int -> string * Cjr.typ option * int
val pushERel : env -> string -> Cjr.typ -> env
val lookupERel : env -> int -> string * Cjr.typ
val listERels : env -> (string * Cjr.typ) list
val countERels : env -> int
val pushENamed : env -> string -> int -> Cjr.typ -> env
val lookupENamed : env -> int -> string * Cjr.typ
val pushStruct : env -> int -> (string * Cjr.typ) list -> env
val lookupStruct : env -> int -> (string * Cjr.typ) list
val declBinds : env -> Cjr.decl -> env
val classifyDatatype : (string * int * Cjr.typ option) list -> Cjr.datatype_kind
end
urweb-20160213+dfsg/src/cjr_env.sml 0000664 0000000 0000000 00000012667 12657647235 0017004 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 CjrEnv :> CJR_ENV = struct
open Cjr
structure IM = IntBinaryMap
exception UnboundRel of int
exception UnboundNamed of int
exception UnboundF of int
exception UnboundStruct of int
type env = {
datatypes : (string * (string * int * typ option) list) IM.map,
constructors : (string * typ option * int) IM.map,
numRelE : int,
relE : (string * typ) list,
namedE : (string * typ) IM.map,
structs : (string * typ) list IM.map
}
val empty : env = {
datatypes = IM.empty,
constructors = IM.empty,
numRelE = 0,
relE = [],
namedE = IM.empty,
structs = IM.insert (IM.empty, 0, [])
}
fun pushDatatype (env : env) x n xncs =
{datatypes = IM.insert (#datatypes env, n, (x, xncs)),
constructors = foldl (fn ((x, n', to), constructors) =>
IM.insert (constructors, n', (x, to, n)))
(#constructors env) xncs,
numRelE = #numRelE env,
relE = #relE env,
namedE = #namedE env,
structs = #structs env}
fun lookupDatatype (env : env) n =
case IM.find (#datatypes env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun lookupConstructor (env : env) n =
case IM.find (#constructors env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun pushERel (env : env) x t =
{datatypes = #datatypes env,
constructors = #constructors env,
numRelE = #numRelE env + 1,
relE = (x, t) :: #relE env,
namedE = #namedE env,
structs = #structs env}
fun lookupERel (env : env) n =
(List.nth (#relE env, n))
handle Subscript => raise UnboundRel n
fun countERels (env : env) = #numRelE env
fun listERels (env : env) = #relE env
fun pushENamed (env : env) x n t =
{datatypes = #datatypes env,
constructors = #constructors env,
numRelE = #numRelE env,
relE = #relE env,
namedE = IM.insert (#namedE env, n, (x, t)),
structs = #structs env}
fun lookupENamed (env : env) n =
case IM.find (#namedE env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun pushStruct (env : env) n xts =
{datatypes = #datatypes env,
constructors = #constructors env,
numRelE = #numRelE env,
relE = #relE env,
namedE = #namedE env,
structs = IM.insert (#structs env, n, xts)}
fun lookupStruct (env : env) n =
case IM.find (#structs env, n) of
NONE => raise UnboundStruct n
| SOME x => x
fun classifyDatatype xncs =
if List.all (fn (_, _, NONE) => true | _ => false) xncs then
Enum
else
Default
fun declBinds env (d, loc) =
case d of
DDatatype dts =>
foldl (fn ((_, x, n, xncs), env) =>
let
val env = pushDatatype env x n xncs
val dt = (TDatatype (classifyDatatype xncs, n, ref xncs), loc)
in
foldl (fn ((x', n', NONE), env) => pushENamed env x' n' dt
| ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, dt), loc))
env xncs
end) env dts
| DDatatypeForward (_, x, n) => pushDatatype env x n []
| DStruct (n, xts) => pushStruct env n xts
| DVal (x, n, t, _) => pushENamed env x n t
| DFun (fx, n, args, ran, _) =>
let
val t = foldl (fn ((_, arg), t) => (TFun (arg, t), loc)) ran args
in
pushENamed env fx n t
end
| DFunRec vis =>
foldl (fn ((fx, n, args, ran, _), env) =>
let
val t = foldl (fn ((_, arg), t) => (TFun (arg, t), loc)) ran args
in
pushENamed env fx n t
end) env vis
| DTable _ => env
| DSequence _ => env
| DView _ => env
| DDatabase _ => env
| DPreparedStatements _ => env
| DJavaScript _ => env
| DCookie _ => env
| DStyle _ => env
| DTask _ => env
| DOnError _ => env
end
urweb-20160213+dfsg/src/cjr_print.sig 0000664 0000000 0000000 00000003536 12657647235 0017332 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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.
*)
(* Pretty-printing Ur/Web C jr. language *)
signature CJR_PRINT = sig
val p_typ : CjrEnv.env -> Cjr.typ Print.printer
val p_exp : CjrEnv.env -> Cjr.exp Print.printer
val p_decl : CjrEnv.env -> Cjr.decl Print.printer
val p_file : CjrEnv.env -> Cjr.file Print.printer
val p_sql : CjrEnv.env -> Cjr.file Print.printer
val debug : bool ref
end
urweb-20160213+dfsg/src/cjr_print.sml 0000664 0000000 0000000 00000524413 12657647235 0017345 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2014, 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.
*)
(* Pretty-printing C jr. *)
structure CjrPrint :> CJR_PRINT = struct
open Print.PD
open Print
open Cjr
val dummyt = (TRecord 0, ErrorMsg.dummySpan)
structure E = CjrEnv
structure EM = ErrorMsg
structure SK = struct
type ord_key = string
val compare = String.compare
end
structure SS = BinarySetFn(SK)
structure SM = BinaryMapFn(SK)
structure IS = IntBinarySet
structure CM = BinaryMapFn(struct
type ord_key = char
val compare = Char.compare
end)
val debug = ref false
val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan)
val ident = String.translate (fn #"'" => "PRIME"
| ch => str ch)
val p_ident = string o ident
fun isUnboxable (t : typ) =
case #1 t of
TDatatype (Default, _, _) => true
| TFfi ("Basis", "string") => true
| TFfi ("Basis", "queryString") => true
| _ => false
fun p_typ' par env (t, loc) =
case t of
TFun (t1, t2) => (EM.errorAt loc "Function type remains";
string "")
| TRecord 0 => string "uw_unit"
| TRecord i => box [string "struct",
space,
string "__uws_",
string (Int.toString i)]
| TDatatype (Enum, n, _) =>
(box [string "enum",
space,
string ("__uwe_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n)]
handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
| TDatatype (Option, n, xncs) =>
(case ListUtil.search #3 (!xncs) of
NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument"
| SOME t =>
if isUnboxable t then
p_typ' par env t
else
box [p_typ' par env t,
string "*"])
| TDatatype (Default, n, _) =>
(box [string "struct",
space,
string ("__uwd_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n ^ "*")]
handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
| TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
| TOption t =>
if isUnboxable t then
p_typ' par env t
else
box [p_typ' par env t,
string "*"]
| TList (_, i) => box [string "struct",
space,
string "__uws_",
string (Int.toString i),
string "*"]
and p_typ env = p_typ' false env
fun p_htyp' par env (t, loc) =
case t of
TFun (t1, t2) => parenIf par (box [p_htyp' true env t1,
space,
string "->",
space,
p_htyp' true env t2])
| TRecord i =>
let
val xts = E.lookupStruct env i
in
box [string "{",
p_list (fn (x, t) =>
box [string x,
space,
string ":",
space,
p_htyp env t]) xts,
string "}"]
end
| TDatatype (_, n, _) =>
let
val (name, _) = E.lookupDatatype env n
in
string name
end
| TFfi (m, x) => string (m ^ "." ^ x)
| TOption t => parenIf par (box [string "option",
space,
p_htyp' true env t])
| TList (t, _) => parenIf par (box [string "list",
space,
p_htyp' true env t])
and p_htyp env = p_htyp' false env
fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1))
handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
fun p_enamed' env n =
"__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n
handle CjrEnv.UnboundNamed _ => "__uwn_UNBOUND_" ^ Int.toString n
fun p_enamed env n = string (p_enamed' env n)
fun p_con_named env n =
string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n)
handle CjrEnv.UnboundNamed _ => string ("__uwc_UNBOUND_" ^ Int.toString n)
fun p_pat_preamble env (p, _) =
case p of
PVar (x, t) => (box [p_typ env t,
space,
string "__uwr_",
p_ident x,
string "_",
string (Int.toString (E.countERels env)),
string ";",
newline],
E.pushERel env x t)
| PPrim _ => (box [], env)
| PCon (_, _, NONE) => (box [], env)
| PCon (_, _, SOME p) => p_pat_preamble env p
| PRecord xps =>
foldl (fn ((_, p, _), (pp, env)) =>
let
val (pp', env) = p_pat_preamble env p
in
(box [pp', pp], env)
end) (box [], env) xps
| PNone _ => (box [], env)
| PSome (_, p) => p_pat_preamble env p
fun p_patCon env pc =
case pc of
PConVar n => p_con_named env n
| PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con)
fun p_patMatch (env, disc) (p, loc) =
case p of
PVar _ => string "1"
| PPrim (Prim.Int n) => box [string ("(" ^ disc),
space,
string "==",
space,
Prim.p_t_GCC (Prim.Int n),
string ")"]
| PPrim (Prim.String s) => box [string ("!strcmp(" ^ disc),
string ",",
space,
Prim.p_t_GCC (Prim.String s),
string ")"]
| PPrim (Prim.Char ch) => box [string ("(" ^ disc),
space,
string "==",
space,
Prim.p_t_GCC (Prim.Char ch),
string ")"]
| PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
| PCon (dk, pc, po) =>
let
val p =
case po of
NONE => box []
| SOME p =>
let
val (x, to) = case pc of
PConVar n =>
let
val (x, to, _) = E.lookupConstructor env n
in
("uw_" ^ ident x, to)
end
| PConFfi {mod = m, con, arg, ...} =>
("uw_" ^ ident m ^ "_" ^ ident con, arg)
val t = case to of
NONE => raise Fail "CjrPrint: Constructor mismatch"
| SOME t => t
val x = case pc of
PConVar n =>
let
val (x, _, _) = E.lookupConstructor env n
in
"uw_" ^ ident x
end
| PConFfi {mod = m, con, ...} =>
"uw_" ^ ident m ^ "_" ^ ident con
val disc' = case dk of
Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
| Default => disc ^ "->data." ^ x
| Option =>
if isUnboxable t then
disc
else
"(*" ^ disc ^ ")"
val p = p_patMatch (env, disc') p
in
box [space,
string "&&",
space,
p]
end
in
box [string disc,
case (dk, po) of
(Enum, _) => box [space,
string "==",
space,
p_patCon env pc]
| (Default, _) => box [string "->tag",
space,
string "==",
space,
p_patCon env pc]
| (Option, NONE) => box [space,
string "==",
space,
string "NULL"]
| (Option, SOME _) => box [space,
string "!=",
space,
string "NULL"],
p]
end
| PRecord [] => string "1"
| PRecord xps =>
p_list_sep (box [space, string "&&", space]) (fn (x, p, _) => p_patMatch (env, disc ^ ".__uwf_" ^ ident x) p) xps
| PNone _ =>
box [string disc,
space,
string "==",
space,
string "NULL"]
| PSome (t, p) =>
let
val disc' = if isUnboxable t then
disc
else
"(*" ^ disc ^ ")"
val p = p_patMatch (env, disc') p
in
box [string disc,
space,
string "!=",
space,
string "NULL",
space,
string "&&",
space,
p]
end
fun p_patBind (env, disc) (p, loc) =
case p of
PVar (x, t) =>
(box [p_typ env t,
space,
string "__uwr_",
p_ident x,
string "_",
string (Int.toString (E.countERels env)),
space,
string "=",
space,
string disc,
string ";",
newline],
E.pushERel env x t)
| PPrim _ => (box [], env)
| PCon (_, _, NONE) => (box [], env)
| PCon (dk, pc, SOME p) =>
let
val (x, to) = case pc of
PConVar n =>
let
val (x, to, _) = E.lookupConstructor env n
in
("uw_" ^ ident x, to)
end
| PConFfi {mod = m, con, arg, ...} =>
("uw_" ^ ident m ^ "_" ^ ident con, arg)
val t = case to of
NONE => raise Fail "CjrPrint: Constructor mismatch"
| SOME t => t
val disc' = case dk of
Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
| Default => disc ^ "->data." ^ x
| Option =>
if isUnboxable t then
disc
else
"(*" ^ disc ^ ")"
in
p_patBind (env, disc') p
end
| PRecord xps =>
let
val (xps, env) =
ListUtil.foldlMap (fn ((x, p, t), env) => p_patBind (env, disc ^ ".__uwf_" ^ ident x) p)
env xps
in
(p_list_sep (box []) (fn x => x) xps,
env)
end
| PNone _ => (box [], env)
| PSome (t, p) =>
let
val disc' = if isUnboxable t then
disc
else
"(*" ^ disc ^ ")"
in
p_patBind (env, disc') p
end
fun patConInfo env pc =
case pc of
PConVar n =>
let
val (x, _, dn) = E.lookupConstructor env n
val (dx, _) = E.lookupDatatype env dn
in
("__uwd_" ^ ident dx ^ "_" ^ Int.toString dn,
"__uwc_" ^ ident x ^ "_" ^ Int.toString n,
"uw_" ^ ident x)
end
| PConFfi {mod = m, datatyp, con, ...} =>
("uw_" ^ ident m ^ "_" ^ ident datatyp,
"uw_" ^ ident m ^ "_" ^ ident con,
"uw_" ^ ident con)
fun p_unsql wontLeakStrings env (tAll as (t, loc)) e eLen =
case t of
TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
| TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
| TFfi ("Basis", "string") =>
if wontLeakStrings then
e
else
box [string "uw_strdup(ctx, ", e, string ")"]
| TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
| TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
| TFfi ("Basis", "blob") => box [string "uw_Basis_stringToBlob_error(ctx, ",
e,
string ", ",
eLen,
string ")"]
| TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
| TFfi ("Basis", "client") => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"]
| _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
Print.eprefaces' [("Type", p_htyp env tAll)];
string "ERROR")
fun p_getcol wontLeakStrings env (tAll as (t, loc)) i =
case t of
TOption t =>
box [string "(PQgetisnull(res, i, ",
string (Int.toString i),
string ") ? NULL : ",
case t of
(TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i
| _ => box [string "({",
newline,
p_typ env t,
space,
string "*tmp = uw_malloc(ctx, sizeof(",
p_typ env t,
string "));",
newline,
string "*tmp = ",
p_getcol wontLeakStrings env t i,
string ";",
newline,
string "tmp;",
newline,
string "})"],
string ")"]
| _ =>
box [string "(PQgetisnull(res, i, ",
string (Int.toString i),
string ") ? ",
box [string "({",
p_typ env tAll,
space,
string "tmp;",
newline,
string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #",
string (Int.toString i),
string "\");",
newline,
string "tmp;",
newline,
string "})"],
string " : ",
p_unsql wontLeakStrings env tAll
(box [string "PQgetvalue(res, i, ",
string (Int.toString i),
string ")"])
(box [string "PQgetlength(res, i, ",
string (Int.toString i),
string ")"]),
string ")"]
datatype sql_type = datatype Settings.sql_type
val isBlob = Settings.isBlob
fun isFile (t : typ) =
case #1 t of
TFfi ("Basis", "file") => true
| _ => false
fun p_sql_type t = string (Settings.p_sql_ctype t)
fun getPargs (e, _) =
case e of
EPrim (Prim.String _) => []
| EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => getPargs e1 @ getPargs e2
| EFfiApp ("Basis", "sqlifyInt", [(e, _)]) => [(e, Int)]
| EFfiApp ("Basis", "sqlifyFloat", [(e, _)]) => [(e, Float)]
| EFfiApp ("Basis", "sqlifyString", [(e, _)]) => [(e, String)]
| EFfiApp ("Basis", "sqlifyBool", [(e, _)]) => [(e, Bool)]
| EFfiApp ("Basis", "sqlifyTime", [(e, _)]) => [(e, Time)]
| EFfiApp ("Basis", "sqlifyBlob", [(e, _)]) => [(e, Blob)]
| EFfiApp ("Basis", "sqlifyChannel", [(e, _)]) => [(e, Channel)]
| EFfiApp ("Basis", "sqlifyClient", [(e, _)]) => [(e, Client)]
| ECase (e,
[((PNone _, _),
(EPrim (Prim.String (_, "NULL")), _)),
((PSome (_, (PVar _, _)), _),
(EFfiApp (m, x, [((ERel 0, _), _)]), _))],
{disc = t, ...}) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [(e, t)]), #2 e))
| ECase (e,
[((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
(EPrim (Prim.String (_, "TRUE")), _)),
((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
(EPrim (Prim.String (_, "FALSE")), _))],
_) => [(e, Bool)]
| _ => raise Fail "CjrPrint: getPargs"
val notLeakies = SS.fromList ["int", "float", "char", "time", "bool", "unit", "client", "channel",
"xhtml", "page", "xbody", "css_class"]
val notLeakies' = SS.fromList ["blob"]
fun notLeaky env allowHeapAllocated =
let
fun nl ok (t, _) =
case t of
TFun _ => false
| TRecord n =>
let
val xts = E.lookupStruct env n
in
List.all (fn (_, t) => nl ok t) xts
end
| TDatatype (dk, n, ref cons) =>
IS.member (ok, n)
orelse
((allowHeapAllocated orelse dk = Enum)
andalso
let
val ok' = IS.add (ok, n)
in
List.all (fn (_, _, to) => case to of
NONE => true
| SOME t => nl ok' t) cons
end)
| TFfi ("Basis", t) => SS.member (notLeakies, t)
orelse (allowHeapAllocated andalso SS.member (notLeakies', t))
| TFfi _ => false
| TOption t => allowHeapAllocated andalso nl ok t
| TList (t, _) => allowHeapAllocated andalso nl ok t
in
nl IS.empty
end
fun capitalize s =
if s = "" then
""
else
str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
local
val urlHandlers = ref ([] : (pp_desc * pp_desc) list)
in
fun addUrlHandler v = urlHandlers := v :: !urlHandlers
fun latestUrlHandlers () =
!urlHandlers
before urlHandlers := []
fun clearUrlHandlers () = urlHandlers := []
end
val unurlifies = ref IS.empty
fun unurlify fromClient env (t, loc) =
let
fun deStar request =
case request of
"(*request)" => "request"
| _ => "&" ^ request
fun unurlify' request t =
case t of
TFfi ("Basis", "unit") => string ("uw_Basis_unurlifyUnit(ctx, " ^ deStar request ^ ")")
| TFfi ("Basis", "string") => string (if fromClient then
"uw_Basis_unurlifyString_fromClient(ctx, " ^ deStar request ^ ")"
else
"uw_Basis_unurlifyString(ctx, " ^ deStar request ^ ")")
| TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, " ^ deStar request ^ ")")
| TRecord 0 => string ("uw_Basis_unurlifyUnit(ctx, " ^ deStar request ^ ")")
| TRecord i =>
let
val xts = E.lookupStruct env i
in
box [string "({",
newline,
box (map (fn (x, t) =>
box [p_typ env t,
space,
string "uwr_",
string x,
space,
string "=",
space,
unurlify' request (#1 t),
string ";",
newline]) xts),
string "struct",
space,
string "__uws_",
string (Int.toString i),
space,
string "tmp",
space,
string "=",
space,
string "{",
space,
p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_",
string x]) xts,
space,
string "};",
newline,
string "tmp;",
newline,
string "})"]
end
| TDatatype (Enum, i, _) =>
let
val (x, xncs) = E.lookupDatatype env i
fun doEm xncs =
case xncs of
[] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
^ x ^ "\"), (enum __uwe_"
^ x ^ "_" ^ Int.toString i ^ ")0)")
| (x', n, to) :: rest =>
box [string ("((!strncmp(" ^ request ^ ", \""),
string x',
string "\", ",
string (Int.toString (size x')),
string (") && (" ^ request ^ "["),
string (Int.toString (size x')),
string ("] == 0 || " ^ request ^ "["),
string (Int.toString (size x')),
string ("] == '/')) ? (" ^ request ^ " += "),
string (Int.toString (size x')),
string (", (" ^ request ^ "[0] == '/' ? ++" ^ request ^ " : NULL), __uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ")"),
space,
string ":",
space,
doEm rest,
string ")"]
in
doEm xncs
end
| TDatatype (Option, i, xncs) =>
if IS.member (!unurlifies, i) then
box [string "unurlify_",
string (Int.toString i),
string ("(ctx, " ^ deStar request ^ ")")]
else
let
val (x, _) = E.lookupDatatype env i
val (no_arg, has_arg, t) =
case !xncs of
[(no_arg, _, NONE), (has_arg, _, SOME t)] =>
(no_arg, has_arg, t)
| [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
(no_arg, has_arg, t)
| _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
val unboxable = isUnboxable t
in
unurlifies := IS.add (!unurlifies, i);
addUrlHandler (box [string "static",
space,
p_typ env t,
space,
if unboxable then
box []
else
string "*",
string "unurlify_",
string (Int.toString i),
string "(uw_context, char **);",
newline],
box [string "static",
space,
p_typ env t,
space,
if unboxable then
box []
else
string "*",
string "unurlify_",
string (Int.toString i),
string "(uw_context ctx, char **request) {",
newline,
box [string "return ((*request)[0] == '/' ? ++*request : *request,",
newline,
string "((!strncmp(*request, \"",
string no_arg,
string "\", ",
string (Int.toString (size no_arg)),
string ") && ((*request)[",
string (Int.toString (size no_arg)),
string "] == 0 || (*request)[",
string (Int.toString (size no_arg)),
string "] == '/')) ? (*request",
space,
string "+=",
space,
string (Int.toString (size no_arg)),
string ", NULL) : ((!strncmp(*request, \"",
string has_arg,
string "\", ",
string (Int.toString (size has_arg)),
string ") && ((*request)[",
string (Int.toString (size has_arg)),
string "] == 0 || (*request)[",
string (Int.toString (size has_arg)),
string "] == '/')) ? (*request",
space,
string "+=",
space,
string (Int.toString (size has_arg)),
string ", ((*request)[0] == '/' ? ++*request : NULL), ",
newline,
if unboxable then
unurlify' "(*request)" (#1 t)
else
box [string "({",
newline,
p_typ env t,
space,
string "*tmp",
space,
string "=",
space,
string "uw_malloc(ctx, sizeof(",
p_typ env t,
string "));",
newline,
string "*tmp",
space,
string "=",
space,
unurlify' "(*request)" (#1 t),
string ";",
newline,
string "tmp;",
newline,
string "})"],
string ")",
newline,
string ":",
space,
string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x
^ "\"), NULL))));"),
newline],
string "}",
newline,
newline]);
box [string "unurlify_",
string (Int.toString i),
string ("(ctx, &" ^ request ^ ")")]
end
| TDatatype (Default, i, _) =>
if IS.member (!unurlifies, i) then
box [string "unurlify_",
string (Int.toString i),
string ("(ctx, " ^ deStar request ^ ")")]
else
let
val (x, xncs) = E.lookupDatatype env i
val () = unurlifies := IS.add (!unurlifies, i)
fun doEm xncs =
case xncs of
[] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
^ x ^ "\"), NULL)")
| (x', n, to) :: rest =>
box [string "((!strncmp(*request, \"",
string x',
string "\", ",
string (Int.toString (size x')),
string ") && ((*request)[",
string (Int.toString (size x')),
string "] == 0 || (*request)[",
string (Int.toString (size x')),
string "] == '/')) ? ({",
newline,
string "struct",
space,
string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
space,
string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
string x,
string "_",
string (Int.toString i),
string "));",
newline,
string "tmp->tag",
space,
string "=",
space,
string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
string ";",
newline,
string "*request",
space,
string "+=",
space,
string (Int.toString (size x')),
string ";",
newline,
string "if ((*request)[0] == '/') ++*request;",
newline,
case to of
NONE => box []
| SOME (t, _) => box [string "tmp->data.uw_",
p_ident x',
space,
string "=",
space,
unurlify' "(*request)" t,
string ";",
newline],
string "tmp;",
newline,
string "})",
space,
string ":",
space,
doEm rest,
string ")"]
in
addUrlHandler (box [string "static",
space,
p_typ env (t, ErrorMsg.dummySpan),
space,
string "unurlify_",
string (Int.toString i),
string "(uw_context, char **);",
newline],
box [string "static",
space,
p_typ env (t, ErrorMsg.dummySpan),
space,
string "unurlify_",
string (Int.toString i),
string "(uw_context ctx, char **request) {",
newline,
box [string "return",
space,
doEm xncs,
string ";",
newline],
string "}",
newline,
newline]);
box [string "unurlify_",
string (Int.toString i),
string ("(ctx, " ^ deStar request ^ ")")]
end
| TList (t', i) =>
if IS.member (!unurlifies, i) then
box [string "unurlify_list_",
string (Int.toString i),
string ("(ctx, " ^ deStar request ^ ")")]
else
(unurlifies := IS.add (!unurlifies, i);
addUrlHandler (box [string "static",
space,
p_typ env (t, loc),
space,
string "unurlify_list_",
string (Int.toString i),
string "(uw_context, char **);",
newline],
box [string "static",
space,
p_typ env (t, loc),
space,
string "unurlify_list_",
string (Int.toString i),
string "(uw_context ctx, char **request) {",
newline,
box [string "return ((*request)[0] == '/' ? ++*request : *request,",
newline,
string "((!strncmp(*request, \"Nil\", 3) && ((*request)[3] == 0 ",
string "|| (*request)[3] == '/')) ? (*request",
space,
string "+=",
space,
string "3, ((*request)[0] == '/' ? ((*request)[0] = 0, ++*request) : NULL), NULL) : ((!strncmp(*request, \"Cons\", 4) && ((*request)[4] == 0 ",
string "|| (*request)[4] == '/')) ? (*request",
space,
string "+=",
space,
string "4, ((*request)[0] == '/' ? ++*request : NULL), ",
newline,
string "({",
newline,
p_typ env (t, loc),
space,
string "tmp",
space,
string "=",
space,
string "uw_malloc(ctx, sizeof(struct __uws_",
string (Int.toString i),
string "));",
newline,
string "*tmp",
space,
string "=",
space,
unurlify' "(*request)" (TRecord i),
string ";",
newline,
string "tmp;",
newline,
string "})",
string ")",
newline,
string ":",
space,
string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", request), NULL))));"),
newline],
string "}",
newline,
newline]);
box [string "unurlify_list_",
string (Int.toString i),
string ("(ctx, " ^ deStar request ^ ")")])
| TOption t =>
box [string ("(" ^ request ^ "[0] == '/' ? ++" ^ request ^ " : " ^ request ^ ", "),
string ("((!strncmp(" ^ request ^ ", \"None\", 4) "),
string ("&& (" ^ request ^ "[4] == 0 || " ^ request ^ "[4] == '/')) "),
string ("? (" ^ request ^ " += (" ^ request ^ "[4] == 0 ? 4 : 5), NULL) "),
string (": ((!strncmp(" ^ request ^ ", \"Some\", 4) "),
string ("&& " ^ request ^ "[4] == '/') "),
string ("? (" ^ request ^ " += 5, "),
if isUnboxable t then
unurlify' request (#1 t)
else
box [string "({",
newline,
p_typ env t,
space,
string "*tmp",
space,
string "=",
space,
string "uw_malloc(ctx, sizeof(",
p_typ env t,
string "));",
newline,
string "*tmp",
space,
string "=",
space,
unurlify' request (#1 t),
string ";",
newline,
string "tmp;",
newline,
string "})"],
string ") :",
space,
string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"]
| _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
space)
in
unurlify' "request" t
end
val urlify1 = ref 0
val urlifies = ref IS.empty
val urlifiesL = ref IS.empty
fun urlify env t =
let
fun urlify' level (t as (_, loc)) =
case #1 t of
TFfi ("Basis", "unit") => box []
| TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t
^ "_w(ctx, it" ^ Int.toString level ^ ");"),
newline]
| TRecord 0 => box []
| 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)
([], false) xts
in
box (rev blocks)
end
| TDatatype (Enum, i, _) =>
let
val (x, xncs) = E.lookupDatatype env i
fun doEm xncs =
case xncs of
[] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype "
^ x ^ "\");"),
newline]
| (x', n, to) :: rest =>
box [string ("if (it" ^ Int.toString level
^ "==__uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ") {"),
newline,
box [string ("uw_write(ctx, \"" ^ x' ^ "\");"),
newline],
string "} else {",
newline,
box [doEm rest,
newline],
string "}"]
in
doEm xncs
end
| TDatatype (Option, i, xncs) =>
if IS.member (!urlifies, i) then
box [string "urlify_",
string (Int.toString i),
string "(ctx,",
space,
string "it",
string (Int.toString level),
string ");",
newline]
else
let
val (x, _) = E.lookupDatatype env i
val (no_arg, has_arg, t) =
case !xncs of
[(no_arg, _, NONE), (has_arg, _, SOME t)] =>
(no_arg, has_arg, t)
| [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
(no_arg, has_arg, t)
| _ => raise Fail "CjrPrint: urlify misclassified Option datatype"
in
urlifies := IS.add (!urlifies, i);
addUrlHandler (box [string "static",
space,
string "void",
space,
string "urlify_",
string (Int.toString i),
string "(uw_context,",
space,
p_typ env t,
space,
if isUnboxable t then
box []
else
string "*",
string ");",
newline],
box [string "static",
space,
string "void",
space,
string "urlify_",
string (Int.toString i),
string "(uw_context ctx,",
space,
p_typ env t,
space,
if isUnboxable t then
box []
else
string "*",
string "it0) {",
newline,
box [string "if (it0) {",
newline,
if isUnboxable t then
box [string "uw_write(ctx, \"",
string has_arg,
string "/\");",
newline,
urlify' 0 t,
string ";",
newline]
else
box [p_typ env t,
space,
string "it1",
space,
string "=",
space,
string "*it0;",
newline,
string "uw_write(ctx, \"",
string has_arg,
string "/\");",
newline,
urlify' 1 t,
string ";",
newline],
string "} else {",
box [newline,
string "uw_write(ctx, \"",
string no_arg,
string "\");",
newline],
string "}",
newline],
string "}",
newline,
newline]);
box [string "urlify_",
string (Int.toString i),
string "(ctx,",
space,
string "it",
string (Int.toString level),
string ");",
newline]
end
| TDatatype (Default, i, _) =>
if IS.member (!urlifies, i) then
box [string "urlify_",
string (Int.toString i),
string "(ctx,",
space,
string "it",
string (Int.toString level),
string ");",
newline]
else
let
val (x, xncs) = E.lookupDatatype env i
val () = urlifies := IS.add (!urlifies, i)
fun doEm xncs =
case xncs of
[] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype "
^ x ^ " (%d)\", it0->data);"),
newline]
| (x', n, to) :: rest =>
box [string "if",
space,
string "(it0->tag==__uwc_",
string (ident x'),
string "_",
string (Int.toString n),
string ") {",
newline,
case to of
NONE => box [string "uw_write(ctx, \"",
string x',
string "\");",
newline]
| SOME t => box [string "uw_write(ctx, \"",
string x',
string "/\");",
newline,
p_typ env t,
space,
string "it1",
space,
string "=",
space,
string "it0->data.uw_",
string x',
string ";",
newline,
urlify' 1 t,
newline],
string "} else {",
newline,
box [doEm rest,
newline],
string "}",
newline]
in
addUrlHandler (box [string "static",
space,
string "void",
space,
string "urlify_",
string (Int.toString i),
string "(uw_context,",
space,
p_typ env t,
string ");",
newline],
box [string "static",
space,
string "void",
space,
string "urlify_",
string (Int.toString i),
string "(uw_context ctx,",
space,
p_typ env t,
space,
string "it0) {",
newline,
box [doEm xncs,
newline],
newline,
string "}",
newline,
newline]);
box [string "urlify_",
string (Int.toString i),
string "(ctx,",
space,
string "it",
string (Int.toString level),
string ");",
newline]
end
| TOption t =>
box [string "if (it",
string (Int.toString level),
string ") {",
if isUnboxable t then
box [string "uw_write(ctx, \"Some/\");",
newline,
urlify' level t]
else
box [p_typ env t,
space,
string "it",
string (Int.toString (level + 1)),
space,
string "=",
space,
string "*it",
string (Int.toString level),
string ";",
newline,
string "uw_write(ctx, \"Some/\");",
newline,
urlify' (level + 1) t,
string ";",
newline],
string "} else {",
box [newline,
string "uw_write(ctx, \"None\");",
newline],
string "}",
newline]
| TList (t, i) =>
if IS.member (!urlifiesL, i) then
box [string "urlifyl_",
string (Int.toString i),
string "(ctx,",
space,
string "it",
string (Int.toString level),
string ");",
newline]
else
(urlifiesL := IS.add (!urlifiesL, i);
addUrlHandler (box [string "static",
space,
string "void",
space,
string "urlifyl_",
string (Int.toString i),
string "(uw_context,",
space,
string "struct __uws_",
string (Int.toString i),
space,
string "*);",
newline],
box [string "static",
space,
string "void",
space,
string "urlifyl_",
string (Int.toString i),
string "(uw_context ctx,",
space,
string "struct __uws_",
string (Int.toString i),
space,
string "*it0) {",
newline,
box [string "if (it0) {",
newline,
p_typ env t,
space,
string "it1",
space,
string "=",
space,
string "it0->__uwf_1;",
newline,
string "uw_write(ctx, \"Cons/\");",
newline,
urlify' 1 t,
string ";",
newline,
string "uw_write(ctx, \"/\");",
newline,
string "urlifyl_",
string (Int.toString i),
string "(ctx, it0->__uwf_2);",
newline,
string "} else {",
newline,
box [string "uw_write(ctx, \"Nil\");",
newline],
string "}",
newline],
string "}",
newline,
newline]);
box [string "urlifyl_",
string (Int.toString i),
string "(ctx,",
space,
string "it",
string (Int.toString level),
string ");",
newline])
| _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function";
space)
in
urlify' 0 t
end
fun sql_type_in env (tAll as (t, loc)) =
case t of
TFfi ("Basis", "int") => Int
| TFfi ("Basis", "float") => Float
| TFfi ("Basis", "string") => String
| TFfi ("Basis", "char") => Char
| TFfi ("Basis", "bool") => Bool
| TFfi ("Basis", "time") => Time
| TFfi ("Basis", "blob") => Blob
| TFfi ("Basis", "channel") => Channel
| TFfi ("Basis", "client") => Client
| TOption t' => Nullable (sql_type_in env t')
| _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
Print.eprefaces' [("Type", p_htyp env tAll)];
Int)
fun potentiallyFancy (e, _) =
case e of
EPrim _ => false
| ERel _ => false
| ENamed _ => false
| ECon (_, _, NONE) => false
| ECon (_, _, SOME e) => potentiallyFancy e
| ENone _ => false
| ESome (_, e) => potentiallyFancy e
| EFfi _ => false
| EFfiApp _ => true
| EApp _ => true
| EUnop (_, e) => potentiallyFancy e
| EBinop (_, e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2
| ERecord (_, xes) => List.exists (potentiallyFancy o #2) xes
| EField (e, _) => potentiallyFancy e
| ECase (e, pes, _) => potentiallyFancy e orelse List.exists (potentiallyFancy o #2) pes
| EError _ => false
| EReturnBlob _ => false
| ERedirect _ => false
| EWrite e => potentiallyFancy e
| ESeq (e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2
| ELet (_, _, e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2
| EQuery _ => true
| EDml {dml = e, ...} => potentiallyFancy e
| ENextval {seq = e, ...} => potentiallyFancy e
| ESetval {seq = e1, count = e2} => potentiallyFancy e1 orelse potentiallyFancy e2
| EUnurlify _ => true
val self = ref (NONE : int option)
(* The crucial thing to do here is assign arguments to local variables, to enforce order of evaluation.
* Otherwise, we are at the mercy of C's undefined order of function argument evaluation. *)
fun pFuncall env (m, x, es, extra) =
case es of
[] => box [string "uw_",
p_ident m,
string "_",
p_ident x,
string "(ctx",
case extra of
NONE => box []
| SOME extra => box [string ",",
space,
string extra],
string ")"]
| [(e, _)] => box [string "uw_",
p_ident m,
string "_",
p_ident x,
string "(ctx,",
space,
p_exp' false false env e,
case extra of
NONE => box []
| SOME extra => box [string ",",
space,
string extra],
string ")"]
| _ => box [string "({",
newline,
p_list_sepi (box []) (fn i => fn (e, t) =>
box [p_typ env t,
space,
string "arg",
string (Int.toString i),
space,
string "=",
space,
p_exp' false false env e,
string ";",
newline]) es,
string "uw_",
p_ident m,
string "_",
p_ident x,
string "(ctx, ",
p_list_sepi (box [string ",", space]) (fn i => fn _ => box [string "arg", string (Int.toString i)]) es,
case extra of
NONE => box []
| SOME extra => box [string ",",
space,
string extra],
string ");",
newline,
string "})"]
and p_exp' par tail env (e, loc) =
case e of
EPrim p => Prim.p_t_GCC p
| ERel n => p_rel env n
| ENamed n => p_enamed env n
| ECon (Enum, pc, _) => p_patCon env pc
| ECon (Option, pc, NONE) => string "NULL"
| ECon (Option, pc, SOME e) =>
let
val to = case pc of
PConVar n => #2 (E.lookupConstructor env n)
| PConFfi {arg, ...} => arg
val t = case to of
NONE => raise Fail "CjrPrint: ECon argument status mismatch"
| SOME t => t
in
if isUnboxable t then
p_exp' par tail env e
else
box [string "({",
newline,
p_typ env t,
space,
string "*tmp",
space,
string "=",
space,
string "uw_malloc(ctx, sizeof(",
p_typ env t,
string "));",
newline,
string "*tmp",
space,
string "=",
space,
p_exp' par false env e,
string ";",
newline,
string "tmp;",
newline,
string "})"]
end
| ECon (Default, pc, eo) =>
let
val (xd, xc, xn) = patConInfo env pc
in
box [string "({",
newline,
string "struct",
space,
string xd,
space,
string "*tmp",
space,
string "=",
space,
string "uw_malloc(ctx, sizeof(struct ",
string xd,
string "));",
newline,
string "tmp->tag",
space,
string "=",
space,
string xc,
string ";",
newline,
case eo of
NONE => box []
| SOME e => box [string "tmp->data.",
string xn,
space,
string "=",
space,
p_exp' false false env e,
string ";",
newline],
string "tmp;",
newline,
string "})"]
end
| ENone _ => string "NULL"
| ESome (t, e) =>
if isUnboxable t then
p_exp' par tail env e
else
box [string "({",
newline,
p_typ env t,
space,
string "*tmp",
space,
string "=",
space,
string "uw_malloc(ctx, sizeof(",
p_typ env t,
string "));",
newline,
string "*tmp",
space,
string "=",
space,
p_exp' par false env e,
string ";",
newline,
string "tmp;",
newline,
string "})"]
| EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
| EError (e, t) =>
box [string "({",
newline,
p_typ env t,
space,
string "tmp;",
newline,
string "uw_error(ctx, FATAL, \"",
string (if Settings.getDebug () then
ErrorMsg.spanToString loc ^ ": "
else
""),
string "%s\", ",
p_exp' false false env e,
string ");",
newline,
string "tmp;",
newline,
string "})"]
| EReturnBlob {blob = SOME blob, mimeType, t} =>
box [string "({",
newline,
string "uw_Basis_blob",
space,
string "blob",
space,
string "=",
space,
p_exp' false false env blob,
string ";",
newline,
string "uw_Basis_string",
space,
string "mimeType",
space,
string "=",
space,
p_exp' false false env mimeType,
string ";",
newline,
p_typ env t,
space,
string "tmp;",
newline,
string "uw_return_blob(ctx, blob, mimeType);",
newline,
string "tmp;",
newline,
string "})"]
| EReturnBlob {blob = NONE, mimeType, t} =>
box [string "({",
newline,
string "uw_Basis_string",
space,
string "mimeType",
space,
string "=",
space,
p_exp' false false env mimeType,
string ";",
newline,
p_typ env t,
space,
string "tmp;",
newline,
string "uw_return_blob_from_page(ctx, mimeType);",
newline,
string "tmp;",
newline,
string "})"]
| ERedirect (e, t) =>
box [string "({",
newline,
p_typ env t,
space,
string "tmp;",
newline,
string "uw_redirect(ctx, ",
p_exp' false false env e,
string ");",
newline,
string "tmp;",
newline,
string "})"]
| EApp ((EError (e, (TFun (_, ran), _)), loc), _) =>
p_exp' false false env (EError (e, ran), loc)
| EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) =>
p_exp' false false env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
| EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) =>
let
fun flatten e =
case #1 e of
EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => flatten e1 @ flatten e2
| _ => [e]
val es = flatten e1 @ flatten e2
val t = (TFfi ("Basis", "string"), loc)
val es = map (fn e => (e, t)) es
in
case es of
[_, _] => pFuncall env ("Basis", "strcat", es, NONE)
| _ => pFuncall env ("Basis", "mstrcat", es, SOME "NULL")
end
| EFfiApp (m, x, es) => pFuncall env (m, x, es, NONE)
| EApp (f, args) =>
let
fun getSig n =
let
val (_, t) = E.lookupENamed env n
fun getSig (t, args) =
case #1 t of
TFun (dom, t) => getSig (t, dom :: args)
| _ => (args, t)
in
getSig (t, [])
end
fun default () =
case (#1 f, args) of
(ENamed n, _ :: _ :: _) =>
let
val (args', ret) = getSig n
val args = ListPair.zip (args, args')
in
parenIf par (box [string "({",
newline,
p_list_sepi newline
(fn i => fn (e, t) =>
box [p_typ env t,
space,
string ("arg" ^ Int.toString i),
space,
string "=",
space,
p_exp' false false env e,
string ";"])
args,
newline,
p_exp' false false env f,
string "(ctx,",
space,
p_list_sepi (box [string ",", space])
(fn i => fn _ =>
string ("arg" ^ Int.toString i)) args,
string ");",
newline,
string "})"])
end
| _ =>
parenIf par (box [p_exp' true false env f,
string "(ctx,",
space,
p_list_sep (box [string ",", space]) (p_exp' false false env) args,
string ")"])
fun isSelf n =
let
val (argts, ret) = getSig n
in
parenIf par (box [string "({",
newline,
p_list_sepi newline
(fn i => fn (e, t) =>
box [p_typ env t,
space,
string ("rearg" ^ Int.toString i),
space,
string "=",
space,
p_exp' false false env e,
string ";"])
(ListPair.zip (args, argts)),
newline,
p_typ env ret,
space,
string "tmp;",
newline,
p_list_sepi newline
(fn i => fn _ =>
box [p_rel env (E.countERels env - 1 - i),
space,
string "=",
space,
string ("rearg" ^ Int.toString i ^ ";")]) args,
newline,
string "goto restart;",
newline,
string "tmp;",
newline,
string "})"])
end
in
case #1 f of
ENamed n => if SOME n = !self andalso tail then
isSelf n
else
default ()
| _ => default ()
end
| EUnop (s, e1) =>
parenIf par (box [string s,
space,
p_exp' true false env e1])
| EBinop (s, e1, e2) =>
if s <> "fdiv" andalso Char.isAlpha (String.sub (s, size s - 1)) then
box [string s,
string "(",
p_exp' false false env e1,
string ",",
space,
p_exp' false false env e2,
string ")"]
else if s = "/" orelse s = "%" then
box [string "({",
newline,
string "uw_Basis_int",
space,
string "dividend",
space,
string "=",
space,
p_exp env e1,
string ",",
space,
string "divisor",
space,
string "=",
space,
p_exp env e2,
string ";",
newline,
string "if",
space,
string "(divisor",
space,
string "==",
space,
string "0)",
newline,
box [string "uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": division by zero\");",
newline],
string "dividend",
space,
string s,
space,
string "divisor;",
newline,
string "})"]
else
parenIf par (box [p_exp' true false env e1,
space,
string (if s = "fdiv" then "/" else s),
space,
p_exp' true false env e2])
| ERecord (0, _) => string "0"
| ERecord (i, xes) => box [string "({",
space,
string "struct",
space,
string ("__uws_" ^ Int.toString i),
space,
string "tmp",
space,
string "=",
space,
string "{",
p_list (fn (_, e) =>
p_exp' false false env e) xes,
string "};",
space,
string "tmp;",
space,
string "})" ]
| EField (e, x) =>
box [p_exp' true false env e,
string ".__uwf_",
p_ident x]
| ECase (e, pes, {disc, result}) =>
box [string "({",
newline,
p_typ env disc,
space,
string "disc",
space,
string "=",
space,
p_exp' false false env e,
string ";",
newline,
newline,
foldr (fn ((p, e), body) =>
let
val pm = p_patMatch (env, "disc") p
val (pb, env') = p_patBind (env, "disc") p
in
box [pm,
space,
string "?",
space,
if E.countERels env' = E.countERels env then
p_exp' false tail env e
else
box [string "({",
pb,
p_exp' false tail env' e,
string ";",
newline,
string "})"],
newline,
space,
string ":",
space,
body]
end) (box [string "({",
newline,
p_typ env result,
space,
string "tmp;",
newline,
string "uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": pattern match failure\");",
newline,
string "tmp;",
newline,
string "})"]) pes,
string ";",
newline,
string "})"]
| EWrite e => box [string "(uw_write(ctx, ",
p_exp' false false env e,
string "), 0)"]
| ESeq (e1, e2) =>
let
val useRegion = potentiallyFancy e1
in
box [string "(",
if useRegion then
box [string "uw_begin_region(ctx),",
space]
else
box [],
p_exp' false false env e1,
string ",",
space,
if useRegion then
box [string "uw_end_region(ctx),",
space]
else
box [],
p_exp' false tail env e2,
string ")"]
end
| ELet (x, t, e1, e2) =>
let
val useRegion = notLeaky env false t andalso potentiallyFancy e1
in
box [string "({",
newline,
p_typ env t,
space,
string "__uwr_",
p_ident x,
string "_",
string (Int.toString (E.countERels env)),
space,
string "=",
space,
if useRegion then
box [string "(uw_begin_region(ctx),",
space]
else
box [],
p_exp' false false env e1,
if useRegion then
string ")"
else
box [],
string ";",
newline,
if useRegion then
box [string "uw_end_region(ctx);",
newline]
else
box [],
p_exp' false tail (E.pushERel env x t) e2,
string ";",
newline,
string "})"]
end
| EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
let
val exps = map (fn (x, t) => ("__uwf_" ^ ident x, t)) exps
val tables = ListUtil.mapConcat (fn (x, xts) =>
map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts)
tables
val sort = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER)
val outputs = sort exps @ sort tables
val wontLeakStrings = notLeaky env true state
val wontLeakAnything = notLeaky env false state
val inputs =
case prepared of
NONE => []
| SOME _ => getPargs query
fun doCols p_getcol =
box [string "struct __uws_",
string (Int.toString rnum),
string " __uwr_r_",
string (Int.toString (E.countERels env)),
string ";",
newline,
p_typ env state,
space,
string "__uwr_acc_",
string (Int.toString (E.countERels env + 1)),
space,
string "=",
space,
string "acc;",
newline,
newline,
if Settings.getDeadlines () then
box [string "uw_check_deadline(ctx);",
newline]
else
box [],
p_list_sepi (box []) (fn i =>
fn (proj, t) =>
box [string "__uwr_r_",
string (Int.toString (E.countERels env)),
string ".",
string proj,
space,
string "=",
space,
p_getcol {loc = loc,
wontLeakStrings = wontLeakStrings,
col = i,
typ = sql_type_in env t},
string ";",
newline]) outputs,
newline,
newline,
string "acc",
space,
string "=",
space,
p_exp' false false (E.pushERel
(E.pushERel env "r" (TRecord rnum, loc))
"acc" state)
body,
string ";",
newline]
in
box [if wontLeakAnything then
string "(uw_begin_region(ctx), "
else
box [],
string "({",
newline,
p_typ env state,
space,
string "acc",
space,
string "=",
space,
p_exp' false false env initial,
string ";",
newline,
string "int dummy = (uw_begin_region(ctx), 0);",
newline,
string "uw_ensure_transaction(ctx);",
newline,
case prepared of
NONE =>
box [string "char *query = ",
p_exp' false false env query,
string ";",
newline,
newline,
#query (Settings.currentDbms ())
{loc = loc,
cols = map (fn (_, t) => sql_type_in env t) outputs,
doCols = doCols}]
| SOME {id, query, nested} =>
box [p_list_sepi newline
(fn i => fn (e, t) =>
box [p_sql_type t,
space,
string "arg",
string (Int.toString (i + 1)),
space,
string "=",
space,
p_exp' false false env e,
string ";"])
inputs,
newline,
newline,
#queryPrepared (Settings.currentDbms ())
{loc = loc,
id = id,
query = query,
inputs = map #2 inputs,
cols = map (fn (_, t) => sql_type_in env t) outputs,
doCols = doCols,
nested = nested}],
newline,
if wontLeakAnything then
box [string "uw_end_region(ctx);",
newline]
else
box [],
string "acc;",
newline,
string "})",
if wontLeakAnything then
string ")"
else
box []]
end
| EDml {dml, prepared, mode} =>
box [string "(uw_begin_region(ctx), ({",
newline,
case prepared of
NONE => box [string "char *dml = ",
p_exp' false false env dml,
string ";",
newline,
string "uw_ensure_transaction(ctx);",
newline,
newline,
#dml (Settings.currentDbms ()) (loc, mode)]
| SOME {id, dml = dml'} =>
let
val inputs = getPargs dml
in
box [p_list_sepi newline
(fn i => fn (e, t) =>
box [p_sql_type t,
space,
string "arg",
string (Int.toString (i + 1)),
space,
string "=",
space,
p_exp' false false env e,
string ";"])
inputs,
newline,
string "uw_ensure_transaction(ctx);",
newline,
newline,
#dmlPrepared (Settings.currentDbms ()) {loc = loc,
id = id,
dml = dml',
inputs = map #2 inputs,
mode = mode}]
end,
newline,
newline,
string "uw_end_region(ctx);",
newline,
case mode of
Settings.Error => string "0;"
| Settings.None => string "uw_dup_and_clear_error_message(ctx);",
newline,
string "}))"]
| ENextval {seq, prepared} =>
box [string "({",
newline,
string "uw_Basis_int n;",
newline,
string "uw_ensure_transaction(ctx);",
newline,
case prepared of
NONE => #nextval (Settings.currentDbms ()) {loc = loc,
seqE = p_exp' false false env seq,
seqName = case #1 seq of
EPrim (Prim.String (_, s)) => SOME s
| _ => NONE}
| SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc,
id = id,
query = query},
newline,
newline,
string "n;",
newline,
string "})"]
| ESetval {seq, count} =>
box [string "({",
newline,
string "uw_ensure_transaction(ctx);",
newline,
#setval (Settings.currentDbms ()) {loc = loc,
seqE = p_exp' false false env seq,
count = p_exp' false false env count},
newline,
newline,
string "0;",
newline,
string "})"]
| EUnurlify (e, t, true) =>
let
fun getIt () =
if isUnboxable t then
unurlify false env t
else
box [string "({",
newline,
p_typ env t,
string " *tmp = uw_malloc(ctx, sizeof(",
p_typ env t,
string "));",
newline,
string "*tmp = ",
unurlify false env t,
string ";",
newline,
string "tmp;",
newline,
string "})"]
in
box [string "({",
newline,
string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
p_exp' false false env e,
string ");",
newline,
newline,
string "(request ? ",
getIt (),
string " : NULL);",
newline,
string "})"]
end
| EUnurlify (e, t, false) =>
let
fun getIt () =
if isUnboxable t then
unurlify false env t
else
box [string "({",
newline,
p_typ env t,
string " *tmp = uw_malloc(ctx, sizeof(",
p_typ env t,
string "));",
newline,
string "*tmp = ",
unurlify false env t,
string ";",
newline,
string "tmp;",
newline,
string "})"]
in
box [string "({",
newline,
string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
p_exp' false false env e,
string ");",
newline,
newline,
unurlify false env t,
string ";",
newline,
string "})"]
end
and p_exp env = p_exp' false true env
fun p_fun isRec env (fx, n, args, ran, e) =
let
val nargs = length args
val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
in
box [string "static",
space,
p_typ env ran,
space,
string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
string "(",
p_list_sep (box [string ",", space]) (fn x => x)
(string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
box [p_typ env dom,
space,
p_rel env' (nargs - i - 1)]) args),
string ")",
space,
string "{",
if isRec then
box [string "restart:",
newline]
else
box [],
newline,
if isRec andalso Settings.getDeadlines () then
box [string "uw_check_deadline(ctx);",
newline]
else
box [],
box [string "return(",
p_exp env' e,
string ");"],
newline,
string "}"]
end
val global_initializers : Print.PD.pp_desc list ref = ref []
fun p_decl env (dAll as (d, loc) : decl) =
case d of
DStruct (n, xts) =>
let
val env = E.declBinds env dAll
in
box [string "struct",
space,
string ("__uws_" ^ Int.toString n),
space,
string "{",
newline,
p_list_sep (box []) (fn (x, t) => box [p_typ env t,
space,
string "__uwf_",
p_ident x,
string ";",
newline]) xts,
string "};"]
end
| DDatatype dts =>
let
fun p_one (Enum, x, n, xncs) =
box [string "enum",
space,
string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
space,
string "{",
space,
case xncs of
[] => string ("__uwec_" ^ ident x ^ "_" ^ Int.toString n)
| _ =>
p_list_sep (box [string ",", space]) (fn (x, n, _) =>
string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs,
space,
string "};"]
| p_one (Option, _, _, _) = box []
| p_one (Default, x, n, xncs) =
let
val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
| (x, n, SOME t) => SOME (x, n, t)) xncs
in
box [string "enum",
space,
string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
space,
string "{",
space,
p_list_sep (box [string ",", space]) (fn (x, n, _) =>
string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n))
xncs,
space,
string "};",
newline,
newline,
string "struct",
space,
string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n),
space,
string "{",
newline,
string "enum",
space,
string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
space,
string "tag;",
newline,
box (case xncsArgs of
[] => []
| _ => [string "union",
space,
string "{",
newline,
p_list_sep newline (fn (x, n, t) => box [p_typ env t,
space,
string ("uw_" ^ ident x),
string ";"]) xncsArgs,
newline,
string "}",
space,
string "data;",
newline]),
string "};"]
end
in
p_list_sep (box []) p_one dts
end
| DDatatypeForward _ => box []
| DVal (x, n, t, e) =>
(global_initializers := box [string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n),
space,
string "=",
space,
p_exp env e,
string ";"] :: !global_initializers;
box [p_typ env t,
space,
string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n ^ ";")])
| DFun vi => p_fun false env vi
| DFunRec vis =>
let
val env = E.declBinds env dAll
in
box [p_list_sep newline (fn (fx, n, args, ran, _) =>
box [string "static",
space,
p_typ env ran,
space,
string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
string "(uw_context,",
space,
p_list_sep (box [string ",", space])
(fn (_, dom) => p_typ env dom) args,
string ");"]) vis,
newline,
p_list_sep newline (fn vi as (_, n, _, _, _) =>
(self := SOME n;
p_fun true env vi
before self := NONE)) vis,
newline]
end
| DTable (x, _, pk, csts) => box [string "/* SQL table ",
string x,
space,
case pk of
"" => box []
| _ => box [string "keys",
space,
string pk,
space],
string "constraints",
space,
p_list (fn (x, v) => box [string x,
space,
string ":",
space,
string v]) csts,
space,
string " */",
newline]
| DSequence x => box [string "/* SQL sequence ",
string x,
string " */",
newline]
| DView (x, _, s) => box [string "/* SQL view ",
string x,
space,
string "AS",
space,
string s,
space,
string " */",
newline]
| DDatabase _ => box []
| DPreparedStatements _ => box []
| DJavaScript s => box [string "static char jslib[] = \"",
string (Prim.toCString s),
string "\";"]
| DCookie s => box [string "/*",
space,
string "cookie",
space,
string s,
space,
string "*/"]
| DStyle s => box [string "/*",
space,
string "style",
space,
string s,
space,
string "*/"]
| DTask _ => box []
| DOnError _ => box []
datatype 'a search =
Found of 'a
| NotFound
| Error
fun p_sqltype'' env (tAll as (t, loc)) =
case t of
TFfi ("Basis", "int") => "int8"
| TFfi ("Basis", "float") => "float8"
| TFfi ("Basis", "string") => "text"
| TFfi ("Basis", "bool") => "bool"
| TFfi ("Basis", "time") => "timestamp"
| TFfi ("Basis", "blob") => "bytea"
| TFfi ("Basis", "channel") => "int8"
| TFfi ("Basis", "client") => "int4"
| _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
Print.eprefaces' [("Type", p_htyp env tAll)];
"ERROR")
fun p_sqltype' env (tAll as (t, loc)) =
case t of
(TOption t, _) => p_sqltype'' env t
| _ => p_sqltype'' env t ^ " NOT NULL"
fun p_sqltype env t = string (p_sqltype' env t)
fun p_sqltype_base' env t =
case t of
(TOption t, _) => p_sqltype'' env t
| _ => p_sqltype'' env t
fun p_sqltype_base env t = string (p_sqltype_base' env t)
fun is_not_null t =
case t of
(TOption _, _) => false
| _ => true
fun sigName fields =
let
fun inFields s = List.exists (fn (s', _) => s' = s) fields
fun getSigName n =
let
val s = "Sig" ^ Int.toString n
in
if inFields s then
getSigName (n + 1)
else
s
end
in
if inFields "Sig" then
getSigName 0
else
"Sig"
end
fun p_file env (ds, ps) =
let
val () = (clearUrlHandlers ();
unurlifies := IS.empty;
urlifies := IS.empty;
urlifiesL := IS.empty;
self := NONE;
global_initializers := [])
(* First, pull out all of the enumerated types, to be declared first. *)
val (ds, enums) = ListUtil.foldlMapPartial (fn (d, enums) =>
case #1 d of
DDatatype dts =>
let
val (enum, other) = List.partition (fn (Enum, _, _, _) => true
| _ => false) dts
in
(SOME (DDatatype other, #2 d),
List.revAppend (enum, enums))
end
| DDatatypeForward (Enum, _, _) => (NONE, enums)
| _ => (SOME d, enums))
[] ds
val ds = (DDatatype enums, ErrorMsg.dummySpan) :: ds
val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
let
val d' = p_decl env d
val hs = latestUrlHandlers ()
val (protos, defs) = ListPair.unzip hs
in
(box (List.revAppend (protos, (List.revAppend (defs, [d'])))),
E.declBinds env d)
end)
env ds
fun flatFields always (t : typ) =
case #1 t of
TRecord i =>
let
val xts = E.lookupStruct env i
in
SOME ((always @ map #1 xts) :: List.concat (List.mapPartial (flatFields [] o #2) xts))
end
| TList (_, i) =>
let
val ts = E.lookupStruct env i
in
case ts of
[("1", t'), ("2", _)] => flatFields [] t'
| _ => raise Fail "CjrPrint: Bad struct for TList"
end
| _ => NONE
val fields = foldl (fn ((ek, _, _, ts, _, _, _, _), fields) =>
case ek of
Action eff =>
(case List.nth (ts, length ts - 2) of
(TRecord i, loc) =>
let
val xts = E.lookupStruct env i
val extra = case eff of
ReadCookieWrite => [sigName xts]
| _ => []
in
case flatFields extra (TRecord i, loc) of
NONE => raise Fail "CjrPrint: flatFields impossible"
| SOME fields' => List.revAppend (fields', fields)
end
| _ => raise Fail "CjrPrint: Last argument of action isn't record")
| _ => fields)
[] ps
val fields = foldl (fn (xts, fields) =>
let
val xtsSet = SS.addList (SS.empty, xts)
in
foldl (fn (x, fields) =>
let
val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
in
SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
xtsSet'))
end) fields xts
end)
SM.empty fields
val fnums = SM.foldli (fn (x, xs, fnums) =>
let
val unusable = SS.foldl (fn (x', unusable) =>
case SM.find (fnums, x') of
NONE => unusable
| SOME n => IS.add (unusable, n))
IS.empty xs
fun findAvailable n =
if IS.member (unusable, n) then
findAvailable (n + 1)
else
n
in
SM.insert (fnums, x, findAvailable 0)
end)
SM.empty fields
val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
fun makeSwitch (fnums, i) =
case SM.foldl (fn (n, NotFound) => Found n
| (n, Error) => Error
| (n, Found n') => if n = n' then
Found n'
else
Error) NotFound fnums of
NotFound => box [string "return",
space,
string "-1;"]
| Found n => box [string "return",
space,
string (Int.toString n),
string ";"]
| Error =>
let
val cmap = SM.foldli (fn (x, n, cmap) =>
let
val ch = if i < size x then
String.sub (x, i)
else
chr 0
val fnums = case CM.find (cmap, ch) of
NONE => SM.empty
| SOME fnums => fnums
val fnums = SM.insert (fnums, x, n)
in
CM.insert (cmap, ch, fnums)
end)
CM.empty fnums
val cmap = CM.listItemsi cmap
in
case cmap of
[(_, fnums)] =>
box [string "if",
space,
string "(name[",
string (Int.toString i),
string "]",
space,
string "==",
space,
string "0)",
space,
string "return",
space,
string "-1;",
newline,
makeSwitch (fnums, i+1)]
| _ =>
box [string "switch",
space,
string "(name[",
string (Int.toString i),
string "])",
space,
string "{",
newline,
box (map (fn (ch, fnums) =>
box [string "case",
space,
if ch = chr 0 then
string "0:"
else
box [string "'",
string (Char.toString ch),
string "':"],
newline,
makeSwitch (fnums, i+1),
newline]) cmap),
string "default:",
newline,
string "return",
space,
string "-1;",
newline,
string "}"]
end
fun getInput (x, t) =
let
val n = case SM.find (fnums, x) of
NONE => raise Fail ("CjrPrint: Can't find " ^ x ^ " in fnums")
| SOME n => n
val f = case t of
(TFfi ("Basis", "bool"), _) => "optional_"
| _ => ""
in
if isFile t then
box [string "uw_input_",
p_ident x,
space,
string "=",
space,
string "uw_get_file_input(ctx, ",
string (Int.toString n),
string ");",
newline]
else case #1 t of
TRecord i =>
let
val xts = E.lookupStruct env i
in
box [string "uw_enter_subform(ctx, ",
string (Int.toString n),
string ");",
newline,
string "uw_input_",
p_ident x,
space,
string "=",
space,
string "({",
box [p_typ env t,
space,
string "result;",
newline,
p_list_sep (box [])
(fn (x, t) =>
box [p_typ env t,
space,
string "uw_input_",
string x,
string ";",
newline])
xts,
newline,
p_list_sep (box []) (fn (x, t) =>
box [getInput (x, t),
string "result.__uwf_",
string x,
space,
string "=",
space,
string "uw_input_",
string x,
string ";",
newline])
xts,
newline,
string "result;",
newline],
string "});",
newline,
string "uw_leave_subform(ctx);"]
end
| TList (t', i) =>
let
val xts = E.lookupStruct env i
val i' = case xts of
[("1", (TRecord i', loc)), ("2", _)] => i'
| _ => raise Fail "CjrPrint: Bad TList record [2]"
val xts = E.lookupStruct env i'
in
box [string "{",
newline,
string "int status;",
newline,
string "uw_input_",
p_ident x,
space,
string "=",
space,
string "NULL;",
newline,
string "for (status = uw_enter_subforms(ctx, ",
string (Int.toString n),
string "); status; status = uw_next_entry(ctx)) {",
newline,
box [p_typ env t,
space,
string "result",
space,
string "=",
space,
string "uw_malloc(ctx, sizeof(struct __uws_",
string (Int.toString i),
string "));",
newline,
box [string "{",
p_list_sep (box [])
(fn (x, t) =>
box [p_typ env t,
space,
string "uw_input_",
string x,
string ";",
newline])
xts,
newline,
p_list_sep (box []) (fn (x, t) =>
box [getInput (x, t),
string "result->__uwf_1.__uwf_",
string x,
space,
string "=",
space,
string "uw_input_",
string x,
string ";",
newline])
xts,
string "}",
newline],
newline,
string "result->__uwf_2 = uw_input_",
p_ident x,
string ";",
newline,
string "uw_input_",
p_ident x,
string " = result;",
newline],
string "}}",
newline]
end
| TOption _ =>
box [string "uw_input_",
p_ident x,
space,
string "=",
space,
string "uw_get_input(ctx, ",
string (Int.toString n),
string ");",
newline]
| _ =>
box [string "request = uw_get_",
string f,
string "input(ctx, ",
string (Int.toString n),
string ");",
newline,
string "if (request == NULL)",
newline,
box [string "uw_error(ctx, FATAL, \"Missing input ",
string x,
string "\");"],
newline,
string "uw_input_",
p_ident x,
space,
string "=",
space,
unurlify true env t,
string ";",
newline]
end
val timestamp = LargeInt.toString (Time.toMilliseconds (Time.now ()))
val app_js = OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
file = "app." ^ timestamp ^ ".js"}
val allScripts =
foldl (fn (x, scripts) =>
scripts
^ "\\n")
"" (Settings.getScripts () @ [app_js])
fun p_page (ek, s, n, ts, ran, side, dbmode, tellSig) =
let
val (ts, defInputs, inputsVar, fields) =
case ek of
Core.Action _ =>
(case List.nth (ts, length ts - 2) of
(TRecord i, _) =>
let
val xts = E.lookupStruct env i
in
(List.take (ts, length ts - 2),
box [box (map (fn (x, t) => box [p_typ env t,
space,
string "uw_input_",
p_ident x,
string ";",
newline]) xts),
newline,
box (map getInput xts),
case i of
0 => string "uw_unit uw_inputs;"
| _ => box [string "struct __uws_",
string (Int.toString i),
space,
string "uw_inputs",
space,
string "= {",
newline,
box (map (fn (x, _) => box [string "uw_input_",
p_ident x,
string ",",
newline]) xts),
string "};"],
newline],
box [string ",",
space,
string "uw_inputs"],
SOME xts)
end
| _ => raise Fail "CjrPrint: Last argument to an action isn't a record")
| _ => (List.take (ts, length ts - 1), string "", string "", NONE)
fun couldWrite ek =
case ek of
Link _ => false
| Action ef => ef = ReadCookieWrite
| Rpc ef => ef = ReadCookieWrite
| Extern _ => false
fun couldWriteDb ek =
case ek of
Link ef => ef <> ReadOnly
| Action ef => ef <> ReadOnly
| Rpc ef => ef <> ReadOnly
| Extern ef => ef <> ReadOnly
val s =
case Settings.getUrlPrefix () of
"" => s
| "/" => s
| prefix =>
if size s > 0 andalso String.sub (s, 0) = #"/" then
prefix ^ String.extract (s, 1, NONE)
else
prefix ^ s
in
box [string "if (!strncmp(request, \"",
string (Prim.toCString s),
string "\", ",
string (Int.toString (size s)),
string ") && (request[",
string (Int.toString (size s)),
string "] == 0 || request[",
string (Int.toString (size s)),
string "] == '/')) {",
newline,
string "request += ",
string (Int.toString (size s)),
string ";",
newline,
string "if (*request == '/') ++request;",
newline,
case ek of
Rpc _ => box [string "if (uw_hasPostBody(ctx)) {",
newline,
box [string "uw_Basis_postBody pb = uw_getPostBody(ctx);",
newline,
string "if (pb.data[0])",
newline,
box [string "request = uw_Basis_strcat(ctx, request, pb.data);"],
newline],
string "}",
newline]
| _ => box [],
if couldWrite ek andalso not (Settings.checkNoXsrfProtection s) then
box [string "{",
newline,
string "uw_Basis_string sig = ",
case fields of
NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")"
| SOME fields =>
case SM.find (fnums, sigName fields) of
NONE => raise Fail "CjrPrint: sig name wasn't assigned a number"
| SOME inum =>
string ("uw_get_input(ctx, " ^ Int.toString inum ^ ")"),
string ";",
newline,
string "if (sig == NULL) uw_error(ctx, FATAL, \"Missing cookie signature\");",
newline,
string "if (!uw_streq(sig, uw_cookie_sig(ctx)))",
newline,
box [string "uw_error(ctx, FATAL, \"Wrong cookie signature\");",
newline],
string "}",
newline]
else
box [],
box (case ek of
Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
newline]
| _ => [string "uw_write_header(ctx, \"Content-type: text/html; charset=utf-8\\r\\n\");",
newline,
case side of
ServerOnly => box []
| _ => box [string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
newline],
string ("uw_write(ctx, uw_begin_" ^
(if Settings.getIsHtml5 () then
"html5"
else
"xhtml") ^ ");"),
newline,
string "uw_mayReturnIndirectly(ctx);",
newline,
string "uw_set_script_header(ctx, \"",
let
val scripts =
case side of
ServerOnly => ""
| _ => allScripts
in
string scripts
end,
string "\");",
newline]),
string "uw_set_could_write_db(ctx, ",
string (if couldWriteDb ek then "1" else "0"),
string ");",
newline,
string "uw_set_at_most_one_query(ctx, ",
string (case dbmode of OneQuery => "1" | _ => "0"),
string ");",
newline,
string "uw_set_needs_push(ctx, ",
string (case side of
ServerAndPullAndPush => "1"
| _ => "0"),
string ");",
newline,
string "uw_set_needs_sig(ctx, ",
string (if tellSig then
"1"
else
"0"),
string ");",
newline,
string "uw_login(ctx);",
newline,
box [string "{",
newline,
box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
space,
string "arg",
string (Int.toString i),
space,
string "=",
space,
case #1 t of
TFfi ("Basis", "postBody") => string "uw_getPostBody(ctx)"
| TOption (TFfi ("Basis", "queryString"), _) => string "uw_queryString(ctx)"
| _ => unurlify false env t,
string ";",
newline]) ts),
defInputs,
box (case ek of
Core.Rpc _ => [p_typ env ran,
space,
string "it0",
space,
string "=",
space]
| _ => []),
p_enamed env n,
string "(",
p_list_sep (box [string ",", space])
(fn x => x)
(string "ctx"
:: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
inputsVar,
string ", 0);",
newline,
box (case ek of
Core.Rpc _ => [string "uw_write(ctx, uw_get_real_script(ctx));",
newline,
string "uw_write(ctx, \"\\n\");",
newline,
urlify env ran]
| _ => [string "uw_write(ctx, \"\");",
newline]),
string "return;",
newline,
string "}",
newline,
string "}"]
]
end
val (pds', handlers) = ListUtil.foldlMap (fn (p, handlers) =>
let
val p' = p_page p
in
(p', latestUrlHandlers () @ handlers)
end) [] ps
val (protos, defs) = ListPair.unzip handlers
val hasDb = ref false
val tables = ref []
val views = ref []
val sequences = ref []
val dbstring = ref ""
val expunge = ref 0
val initialize = ref 0
val prepped = ref []
val hasJs = ref false
val _ = foldl (fn (d, env) =>
((case #1 d of
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
| DView (s, xts, _) => views := (s, map (fn (x, t) =>
(x, sql_type_in env t)) xts) :: !views
| DSequence s => sequences := s :: !sequences
| DPreparedStatements ss => prepped := ss
| _ => ());
E.declBinds env d)) E.empty ds
val hasDb = !hasDb
fun expDb (e, _) =
case e of
ECon (_, _, SOME e) => expDb e
| ESome (_, e) => expDb e
| EFfiApp (_, _, es) => List.exists (expDb o #1) es
| EApp (e, es) => expDb e orelse List.exists expDb es
| EUnop (_, e) => expDb e
| EBinop (_, e1, e2) => expDb e1 orelse expDb e2
| ERecord (_, xes) => List.exists (expDb o #2) xes
| EField (e, _) => expDb e
| ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes
| EError (e, _) => expDb e
| EReturnBlob {blob = NONE, mimeType = e2, ...} => expDb e2
| EReturnBlob {blob = SOME e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
| ERedirect (e, _) => expDb e
| EWrite e => expDb e
| ESeq (e1, e2) => expDb e1 orelse expDb e2
| ELet (_, _, e1, e2) => expDb e1 orelse expDb e2
| EQuery _ => true
| EDml _ => true
| ENextval _ => true
| ESetval _ => true
| EUnurlify (e, _, _) => expDb e
| _ => false
fun declDb (d, _) =
case d of
DVal (_, _, _, e) => expDb e
| DFun (_, _, _, _, e) => expDb e
| DFunRec vis => List.exists (expDb o #5) vis
| DTask (_, _, _, e) => expDb e
| _ => false
val () = if not hasDb andalso List.exists declDb ds then
ErrorMsg.error "Application uses a database but has none configured with 'database' in .urp file."
else
()
val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
val cookieCode = foldl (fn (cookie, acc) =>
SOME (case acc of
NONE => string ("uw_unnull(uw_Basis_get_cookie(ctx, \""
^ cookie ^ "\"))")
| SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_get_cookie(ctx, \""
^ cookie ^ "\")), uw_Basis_strcat(ctx, \"/\", "),
acc,
string "))"]))
NONE cookies
val cookieCode = foldl (fn (evar, acc) =>
SOME (case acc of
NONE => string ("uw_unnull(uw_Basis_getenv(ctx, \""
^ Prim.toCString evar ^ "\"))")
| SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_getenv(ctx, \""
^ Prim.toCString evar ^ "\")), uw_Basis_strcat(ctx, \"/\", "),
acc,
string "))"]))
cookieCode (SideCheck.readEnvVars ())
fun makeChecker (name, rules : Settings.rule list) =
box [string "static int ",
string name,
string "(const char *s) {",
newline,
box [p_list_sep (box [])
(fn rule =>
box [string "if (!str",
case #kind rule of
Settings.Exact => box [string "cmp(s, \"",
string (Prim.toCString (#pattern rule)),
string "\"))"]
| Settings.Prefix => box [string "ncmp(s, \"",
string (Prim.toCString (#pattern rule)),
string "\", ",
string (Int.toString (size (#pattern rule))),
string "))"],
string " return ",
string (case #action rule of
Settings.Allow => "1"
| Settings.Deny => "0"),
string ";",
newline]) rules,
string "return 0;",
newline],
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 onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds
val now = Time.now ()
val nowD = Date.fromTimeUniv now
val rfcFmt = "%a, %d %b %Y %H:%M:%S GMT"
fun hexifyByte (b : Word8.word) : string =
let
val s = Int.fmt StringCvt.HEX (Word8.toInt b)
in
"\\x" ^ (if size s < 2 then "0" else "") ^ s
end
fun hexify (v : Word8Vector.vector) : string =
String.concat (Word8Vector.foldr (fn (b, ls) =>
hexifyByte b :: ls) [] v)
in
box [string "#include \"",
string (OS.Path.joinDirFile {dir = !Settings.configInclude,
file = "config.h"}),
string "\"",
newline,
string "#include ",
newline,
string "#include ",
newline,
string "#include ",
newline,
string "#include ",
newline,
string "#include ",
newline,
if hasDb then
box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"),
newline]
else
box [],
p_list_sep (box []) (fn s => box [string "#include \"",
string s,
string "\"",
newline]) (Settings.getHeaders ()),
string "#include \"",
string (OS.Path.joinDirFile {dir = !Settings.configInclude,
file = "urweb.h"}),
string "\"",
newline,
newline,
box [string "static void uw_setup_limits() {",
newline,
case Settings.getMinHeap () of
0 => box []
| n => box [string "uw_min_heap",
space,
string "=",
space,
string (Int.toString n),
string ";",
newline,
newline],
box [p_list_sep (box []) (fn (class, num) =>
let
val num = case class of
"page" => Int.max (2048, num)
| _ => num
in
box [string ("uw_" ^ class ^ "_max"),
space,
string "=",
space,
string (Int.toString num),
string ";",
newline]
end) (Settings.limits ())],
string "}",
newline,
newline],
#code (Settings.currentProtocol ()) (),
if hasDb then
#init (Settings.currentDbms ()) {dbstring = !dbstring,
prepared = !prepped,
tables = !tables,
views = !views,
sequences = !sequences}
else
box [string "static void uw_client_init(void) { };",
newline,
string "static void uw_db_init(uw_context ctx) { };",
newline,
string "static int uw_db_begin(uw_context ctx, int could_write) { return 0; };",
newline,
string "static void uw_db_close(uw_context ctx) { };",
newline,
string "static int uw_db_commit(uw_context ctx) { return 0; };",
newline,
string "static int uw_db_rollback(uw_context ctx) { return 0; };"],
newline,
newline,
(* For sqlcache. *)
let
val {setupGlobal, setupQuery, ...} = Sqlcache.getCache ()
in
box (setupGlobal :: newline :: List.map setupQuery (Sqlcache.getFfiInfo ()))
end,
newline,
p_list_sep newline (fn x => x) pds,
newline,
newline,
string "static int uw_input_num(const char *name) {",
newline,
makeSwitch (fnums, 0),
string "}",
newline,
newline,
box (ListUtil.mapi (fn (i, (_, x1, x2, e)) =>
box [string "static void uw_periodic",
string (Int.toString i),
string "(uw_context ctx) {",
newline,
box [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,
newline]) periodics),
string "static uw_periodic my_periodics[] = {",
box (ListUtil.mapi (fn (i, (n, _, _, _)) =>
box [string "{uw_periodic",
string (Int.toString i),
string ",",
space,
string (Int64.toString n),
string "},"]) periodics),
string "{NULL}};",
newline,
newline,
makeChecker ("uw_check_url", Settings.getUrlRules ()),
newline,
makeChecker ("uw_check_mime", Settings.getMimeRules ()),
newline,
makeChecker ("uw_check_requestHeader", Settings.getRequestHeaderRules ()),
newline,
makeChecker ("uw_check_responseHeader", Settings.getResponseHeaderRules ()),
newline,
makeChecker ("uw_check_envVar", Settings.getEnvVarRules ()),
newline,
string "extern void uw_sign(const char *in, char *out);",
newline,
string "extern int uw_hash_blocksize;",
newline,
string "static uw_Basis_string uw_cookie_sig(uw_context ctx) {",
newline,
box [string "uw_Basis_string r = uw_malloc(ctx, uw_hash_blocksize);",
newline,
string "uw_sign(",
case cookieCode of
NONE => string "\"\""
| SOME code => code,
string ", r);",
newline,
string "return uw_Basis_makeSigString(ctx, r);",
newline],
string "}",
newline,
newline,
box (rev protos),
box (rev defs),
string "static void uw_handle(uw_context ctx, char *request) {",
newline,
string "if (!strcmp(request, \"",
string app_js,
string "\")) {",
newline,
box [string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");",
newline,
string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt nowD ^ "\")) {"),
newline,
box [string "uw_clear_headers(ctx);",
newline,
string "uw_write_header(ctx, uw_supports_direct_status ? \"HTTP/1.1 304 Not Modified\\r\\n\" : \"Status: 304 Not Modified\\r\\n\");",
newline,
string "return;",
newline],
string "}",
newline,
newline,
string "uw_write_header(ctx, \"Content-Type: text/javascript\\r\\n\");",
newline,
string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"),
newline,
string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"),
newline,
string "uw_write(ctx, jslib);",
newline,
string "return;",
newline],
string "}",
newline,
newline,
p_list_sep newline (fn r =>
box [string "if (!strcmp(request, \"",
string (String.toCString (#Uri r)),
string "\")) {",
newline,
box [(case #ContentType r of
NONE => box []
| SOME ct => box [string "uw_write_header(ctx, \"Content-Type: ",
string (String.toCString ct),
string "\\r\\n\");",
newline]),
string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt (Date.fromTimeUniv (#LastModified r)) ^ "\\r\\n\");"),
newline,
string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"),
newline,
string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"),
newline,
string "uw_replace_page(ctx, \"",
string (hexify (#Bytes r)),
string "\", ",
string (Int.toString (Word8Vector.length (#Bytes r))),
string ");",
newline,
string "return;",
newline],
string "};",
newline]) (Settings.listFiles ()),
newline,
p_list_sep newline (fn x => x) pds',
newline,
string "uw_clear_headers(ctx);",
newline,
string "uw_write_header(ctx, uw_supports_direct_status ? \"HTTP/1.1 404 Not Found\\r\\n\" : \"Status: 404 Not Found\\r\\n\");",
newline,
string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
newline,
string "uw_write(ctx, \"Not Found\");",
newline,
string "}",
newline,
newline,
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,
if hasDb then
box [p_enamed env (!expunge),
string "(ctx, cli);",
newline]
else
box [],
string "}"],
newline,
string "static void uw_initializer(uw_context ctx) {",
newline,
box [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,
if hasDb then
box [p_enamed env (!initialize),
string "(ctx, 0);",
newline]
else
box []],
string "}",
newline,
case onError of
NONE => box []
| SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {",
newline,
if !hasJs then
box [string "uw_set_script_header(ctx, \"",
string allScripts,
string "\");",
newline]
else
box [],
box [string "uw_write(ctx, ",
p_enamed env n,
string "(ctx, msg, 0));",
newline],
string "}",
newline,
newline],
string "uw_app uw_application = {",
p_list_sep (box [string ",", newline]) string
[Int.toString (SM.foldl Int.max 0 fnums + 1),
Int.toString (Settings.getTimeout ()),
"\"" ^ Settings.getUrlPrefix () ^ "\"",
"uw_client_init", "uw_initializer", "uw_expunger",
"uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close",
"uw_handle",
"uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", "uw_check_envVar",
case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics",
"\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\"",
if Settings.getIsHtml5 () then "1" else "0"],
string "};",
newline]
end
fun p_sql env (ds, _) =
let
val (pps, _) = ListUtil.foldlMap
(fn (dAll as (d, _), env) =>
let
val pp = case d of
DTable (s, xts, pk, csts) =>
box [string "CREATE TABLE ",
string s,
string "(",
p_list (fn (x, t) =>
let
val t = sql_type_in env t
in
box [string (Settings.mangleSql (CharVector.map Char.toLower x)),
space,
string (#p_sql_type (Settings.currentDbms ()) t),
case t of
Nullable _ => box []
| _ => string " NOT NULL"]
end) xts,
case (pk, csts) of
("", []) => box []
| _ => string ",",
cut,
case pk of
"" => box []
| _ => box [string "PRIMARY",
space,
string "KEY",
space,
string "(",
string pk,
string ")",
case csts of
[] => box []
| _ => string ",",
newline],
p_list_sep (box [string ",", newline])
(fn (x, c) =>
box [string "CONSTRAINT",
space,
string s,
string "_",
string x,
space,
string c]) csts,
newline,
string ");",
newline,
newline]
| DSequence s =>
box [string (#createSequence (Settings.currentDbms ()) s),
string ";",
newline,
newline]
| DView (s, xts, q) =>
box [string "CREATE VIEW",
space,
string s,
space,
string "AS",
space,
string q,
string ";",
newline,
newline]
| _ => box []
in
(pp, E.declBinds env dAll)
end)
env ds
in
box (string (#sqlPrefix (Settings.currentDbms ())) :: pps)
end
end
urweb-20160213+dfsg/src/cjrize.sig 0000664 0000000 0000000 00000003063 12657647235 0016621 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 CJRIZE = sig
val cjrize : Mono.file -> Cjr.file
end
urweb-20160213+dfsg/src/cjrize.sml 0000664 0000000 0000000 00000076336 12657647235 0016647 0 ustar 00root root 0000000 0000000 (* 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 Cjrize :> CJRIZE = struct
structure L = Mono
structure L' = Cjr
structure IM = IntBinaryMap
structure Sm :> sig
type t
val empty : t
val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int
val findList : t * L.typ * L'.typ -> t * int
val declares : t -> (int * (string * L'.typ) list) list
val clearDeclares : t -> t
end = struct
structure FM = BinaryMapFn(struct
type ord_key = L.typ
val compare = MonoUtil.Typ.compare
end)
type t = {
count : int,
normal : int FM.map,
lists : int FM.map,
decls : (int * (string * L'.typ) list) list
}
val empty : t = {
count = 1,
normal = FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0),
lists = FM.empty,
decls = []
}
fun find (v as {count, normal, decls, lists}, xts, xts') =
let
val t = (L.TRecord xts, ErrorMsg.dummySpan)
in
case FM.find (normal, t) of
SOME i => (v, i)
| NONE => ({count = count+1,
normal = FM.insert (normal, t, count),
lists = lists,
decls = (count, xts') :: decls},
count)
end
fun findList (v as {count, normal, decls, lists}, t, t') =
case FM.find (lists, t) of
SOME i => (v, i)
| NONE =>
let
val xts = [("1", t), ("2", (L.TList t, #2 t))]
val xts' = [("1", t'), ("2", (L'.TList (t', count), #2 t'))]
in
({count = count+1,
normal = FM.insert (normal, (L.TRecord xts, ErrorMsg.dummySpan), count),
lists = FM.insert (lists, t, count),
decls = (count, xts') :: decls},
count)
end
fun declares (v : t) = #decls v
fun clearDeclares (v : t) = {count = #count v,
normal = #normal v,
lists = #lists v,
decls = []}
end
fun cifyTyp x =
let
fun cify dtmap ((t, loc), sm) =
case t of
L.TFun (t1, t2) =>
let
val (t1, sm) = cify dtmap (t1, sm)
val (t2, sm) = cify dtmap (t2, sm)
in
((L'.TFun (t1, t2), loc), sm)
end
| L.TRecord xts =>
let
val xts = MonoUtil.Typ.sortFields xts
val old_xts = xts
val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
let
val (t, sm) = cify dtmap (t, sm)
in
((x, t), sm)
end)
sm xts
val (sm, si) = Sm.find (sm, old_xts, xts)
in
((L'.TRecord si, loc), sm)
end
| L.TDatatype (n, ref (dk, xncs)) =>
(case IM.find (dtmap, n) of
SOME r => ((L'.TDatatype (dk, n, r), loc), sm)
| NONE =>
let
val r = ref []
val dtmap = IM.insert (dtmap, n, r)
val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) =>
case to of
NONE => ((x, n, NONE), sm)
| SOME t =>
let
val (t, sm) = cify dtmap (t, sm)
in
((x, n, SOME t), sm)
end)
sm xncs
in
r := xncs;
((L'.TDatatype (dk, n, r), loc), sm)
end)
| L.TFfi mx => ((L'.TFfi mx, loc), sm)
| L.TOption t =>
let
val (t, sm) = cify dtmap (t, sm)
in
((L'.TOption t, loc), sm)
end
| L.TList t =>
let
val (t', sm) = cify dtmap (t, sm)
val (sm, si) = Sm.findList (sm, t, t')
in
((L'.TList (t', si), loc), sm)
end
| L.TSource => ((L'.TFfi ("Basis", "source"), loc), sm)
| L.TSignal _ => (ErrorMsg.errorAt loc "TSignal remains";
Print.epreface ("Full type", MonoPrint.p_typ MonoEnv.empty (#1 x));
((L'.TFfi ("Basis", "bogus"), loc), sm))
in
cify IM.empty x
end
val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)
fun cifyPatCon (pc, sm) =
case pc of
L.PConVar n => (L'.PConVar n, sm)
| L.PConFfi {mod = m, datatyp, con, arg} =>
let
val (arg, sm) =
case arg of
NONE => (NONE, sm)
| SOME t =>
let
val (t, sm) = cifyTyp (t, sm)
in
(SOME t, sm)
end
in
(L'.PConFfi {mod = m, datatyp = datatyp, con = con, arg = arg}, sm)
end
fun cifyPat ((p, loc), sm) =
case p of
L.PVar (x, t) =>
let
val (t, sm) = cifyTyp (t, sm)
in
((L'.PVar (x, t), loc), sm)
end
| L.PPrim p => ((L'.PPrim p, loc), sm)
| L.PCon (dk, pc, NONE) =>
let
val (pc, sm) = cifyPatCon (pc, sm)
in
((L'.PCon (dk, pc, NONE), loc), sm)
end
| L.PCon (dk, pc, SOME p) =>
let
val (pc, sm) = cifyPatCon (pc, sm)
val (p, sm) = cifyPat (p, sm)
in
((L'.PCon (dk, pc, SOME p), loc), sm)
end
| L.PRecord xps =>
let
val (xps, sm) = ListUtil.foldlMap (fn ((x, p, t), sm) =>
let
val (p, sm) = cifyPat (p, sm)
val (t, sm) = cifyTyp (t, sm)
in
((x, p, t), sm)
end) sm xps
in
((L'.PRecord xps, loc), sm)
end
| L.PNone t =>
let
val (t, sm) = cifyTyp (t, sm)
in
((L'.PNone t, loc), sm)
end
| L.PSome (t, p) =>
let
val (t, sm) = cifyTyp (t, sm)
val (p, sm) = cifyPat (p, sm)
in
((L'.PSome (t, p), loc), sm)
end
fun cifyExp (eAll as (e, loc), sm) =
let
fun fail msg =
(ErrorMsg.errorAt loc msg;
((L'.EPrim (Prim.String (Prim.Normal, "")), loc), sm))
in
case e of
L.EPrim p => ((L'.EPrim p, loc), sm)
| L.ERel n => ((L'.ERel n, loc), sm)
| L.ENamed n => ((L'.ENamed n, loc), sm)
| L.ECon (dk, pc, eo) =>
let
val (eo, sm) =
case eo of
NONE => (NONE, sm)
| SOME e =>
let
val (e, sm) = cifyExp (e, sm)
in
(SOME e, sm)
end
val (pc, sm) = cifyPatCon (pc, sm)
in
((L'.ECon (dk, pc, eo), loc), sm)
end
| L.ENone t =>
let
val (t, sm) = cifyTyp (t, sm)
in
((L'.ENone t, loc), sm)
end
| L.ESome (t, e) =>
let
val (t, sm) = cifyTyp (t, sm)
val (e, sm) = cifyExp (e, sm)
in
((L'.ESome (t, e), loc), sm)
end
| L.EFfi mx => ((L'.EFfi mx, loc), sm)
| L.EFfiApp (m, x, es) =>
let
val (es, sm) = ListUtil.foldlMap (fn ((e, t), sm) =>
let
val (t, sm) = cifyTyp (t, sm)
val (e, sm) = cifyExp (e, sm)
in
((e, t), sm)
end) sm es
in
((L'.EFfiApp (m, x, es), loc), sm)
end
| L.EApp (e1, e2) =>
let
fun unravel (e, args) =
case e of
(L.EApp (e1, e2), _) => unravel (e1, e2 :: args)
| _ => (e, args)
val (f, es) = unravel (e1, [e2])
val (f, sm) = cifyExp (f, sm)
val (es, sm) = ListUtil.foldlMap cifyExp sm es
in
((L'.EApp (f, es), loc), sm)
end
| L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
(dummye, sm))
| L.EUnop (s, e1) =>
let
val (e1, sm) = cifyExp (e1, sm)
in
((L'.EUnop (s, e1), loc), sm)
end
| L.EBinop (_, s, e1, e2) =>
let
val (e1, sm) = cifyExp (e1, sm)
val (e2, sm) = cifyExp (e2, sm)
in
((L'.EBinop (s, e1, e2), loc), sm)
end
| L.ERecord xes =>
let
val old_xts = map (fn (x, _, t) => (x, t)) xes
val (xets, sm) = ListUtil.foldlMap (fn ((x, e, t), sm) =>
let
val (e, sm) = cifyExp (e, sm)
val (t, sm) = cifyTyp (t, sm)
in
((x, e, t), sm)
end)
sm xes
val (sm, si) = Sm.find (sm, old_xts, map (fn (x, _, t) => (x, t)) xets)
val xes = map (fn (x, e, _) => (x, e)) xets
val xes = ListMergeSort.sort (fn ((x1, _), (x2, _)) => String.compare (x1, x2) = GREATER) xes
in
((L'.ERecord (si, xes), loc), sm)
end
| L.EField (e, x) =>
let
val (e, sm) = cifyExp (e, sm)
in
((L'.EField (e, x), loc), sm)
end
| L.ECase (e, pes, {disc, result}) =>
let
val (e, sm) = cifyExp (e, sm)
val (pes, sm) = ListUtil.foldlMap
(fn ((p, e), sm) =>
let
val (e, sm) = cifyExp (e, sm)
val (p, sm) = cifyPat (p, sm)
in
((p, e), sm)
end) sm pes
val (disc, sm) = cifyTyp (disc, sm)
val (result, sm) = cifyTyp (result, sm)
in
((L'.ECase (e, pes, {disc = disc, result = result}), loc), sm)
end
| L.EError (e, t) =>
let
val (e, sm) = cifyExp (e, sm)
val (t, sm) = cifyTyp (t, sm)
in
((L'.EError (e, t), loc), sm)
end
| L.EReturnBlob {blob = NONE, mimeType, t} =>
let
val (mimeType, sm) = cifyExp (mimeType, sm)
val (t, sm) = cifyTyp (t, sm)
in
((L'.EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), sm)
end
| L.EReturnBlob {blob = SOME blob, mimeType, t} =>
let
val (blob, sm) = cifyExp (blob, sm)
val (mimeType, sm) = cifyExp (mimeType, sm)
val (t, sm) = cifyTyp (t, sm)
in
((L'.EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), sm)
end
| L.ERedirect (e, t) =>
let
val (e, sm) = cifyExp (e, sm)
val (t, sm) = cifyTyp (t, sm)
in
((L'.ERedirect (e, t), loc), sm)
end
| L.EStrcat (e1, e2) =>
let
val (e1, sm) = cifyExp (e1, sm)
val (e2, sm) = cifyExp (e2, sm)
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EFfiApp ("Basis", "strcat", [(e1, s), (e2, s)]), loc), sm)
end
| L.EWrite e =>
let
val (e, sm) = cifyExp (e, sm)
in
((L'.EWrite e, loc), sm)
end
| L.ESeq (e1, e2) =>
let
val (e1, sm) = cifyExp (e1, sm)
val (e2, sm) = cifyExp (e2, sm)
in
((L'.ESeq (e1, e2), loc), sm)
end
| L.ELet (x, t, e1, e2) =>
let
val (t, sm) = cifyTyp (t, sm)
val (e1, sm) = cifyExp (e1, sm)
val (e2, sm) = cifyExp (e2, sm)
in
((L'.ELet (x, t, e1, e2), loc), sm)
end
| L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
(dummye, sm))
| L.EQuery {exps, tables, state, query, body, initial} =>
let
val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
let
val (t, sm) = cifyTyp (t, sm)
in
((x, t), sm)
end) sm exps
val (tables', sm) = ListUtil.foldlMap (fn ((x, xts), sm) =>
let
val (xts, sm) = ListUtil.foldlMap
(fn ((x, t), sm) =>
let
val (t, sm) = cifyTyp (t, sm)
in
((x, t), sm)
end) sm xts
in
((x, xts), sm)
end) sm tables
val row = exps @ map (fn (x, xts) => (x, (L.TRecord xts, loc))) tables
val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
val (tableRows, sm) = ListUtil.foldlMap (fn (((x, xts), (_, xts')), sm) =>
let
val (sm, rnum) = Sm.find (sm, xts, xts')
in
((x, rnum), sm)
end)
sm (ListPair.zip (tables, tables'))
val row' = exps' @ map (fn (x, n) => (x, (L'.TRecord n, loc))) tableRows
val row' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row'
val (sm, rnum) = Sm.find (sm, row, row')
val (state, sm) = cifyTyp (state, sm)
val (query, sm) = cifyExp (query, sm)
val (body, sm) = cifyExp (body, sm)
val (initial, sm) = cifyExp (initial, sm)
in
((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state,
query = query, body = body, initial = initial, prepared = NONE}, loc), sm)
end
| L.EDml (e, mode) =>
let
val (e, sm) = cifyExp (e, sm)
in
((L'.EDml {dml = e, prepared = NONE, mode = mode}, loc), sm)
end
| L.ENextval e =>
let
val (e, sm) = cifyExp (e, sm)
in
((L'.ENextval {seq = e, prepared = NONE}, loc), sm)
end
| L.ESetval (e1, e2) =>
let
val (e1, sm) = cifyExp (e1, sm)
val (e2, sm) = cifyExp (e2, sm)
in
((L'.ESetval {seq = e1, count = e2}, loc), sm)
end
| L.EUnurlify (e, t, b) =>
let
val (e, sm) = cifyExp (e, sm)
val (t, sm) = cifyTyp (t, sm)
in
((L'.EUnurlify (e, t, b), loc), sm)
end
| L.EJavaScript _ => fail "Uncompilable JavaScript remains"
| L.ESignalReturn _ => fail "Signal monad 'return' remains in server-side code"
| L.ESignalBind _ => fail "Signal monad 'bind' remains in server-side code"
| L.ESignalSource _ => fail "Signal monad 'source' remains in server-side code"
| L.EServerCall _ => fail "RPC in server-side code"
| L.ERecv _ => fail "Message receive in server-side code"
| L.ESleep _ => fail "Sleep in server-side code"
| L.ESpawn _ => fail "Thread spawn in server-side code"
end
fun cifyDecl ((d, loc), sm) =
case d of
L.DDatatype dts =>
let
val (dts, sm) = ListUtil.foldlMap
(fn ((x, n, xncs), sm) =>
let
val dk = ElabUtil.classifyDatatype xncs
val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) =>
case to of
NONE => ((x, n, NONE), sm)
| SOME t =>
let
val (t, sm) = cifyTyp (t, sm)
in
((x, n, SOME t), sm)
end) sm xncs
in
((dk, x, n, xncs), sm)
end)
sm dts
in
(SOME (L'.DDatatype dts, loc), NONE, sm)
end
| L.DVal (x, n, t, e, _) =>
let
val (t, sm) = cifyTyp (t, sm)
val (d, sm) = case #1 t of
L'.TFun _ =>
let
fun unravel (tAll as (t, _), eAll as (e, _)) =
case (t, e) of
(L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) =>
let
val (args, t, e) = unravel (ran, e)
in
((ax, dom) :: args, t, e)
end
| (L'.TFun (dom, ran), _) =>
let
val e = MonoEnv.liftExpInExp 0 eAll
val e = (L.EApp (e, (L.ERel 0, loc)), loc)
val (args, t, e) = unravel (ran, e)
in
(("x", dom) :: args, t, e)
end
| _ => ([], tAll, eAll)
val (args, ran, e) = unravel (t, e)
val (e, sm) = cifyExp (e, sm)
in
(L'.DFun (x, n, args, ran, e), sm)
end
| _ =>
let
val (e, sm) = cifyExp (e, sm)
in
(L'.DVal (x, n, t, e), sm)
end
in
(SOME (d, loc), NONE, sm)
end
| L.DValRec vis =>
let
val (vis, sm) = ListUtil.foldlMap
(fn ((x, n, t, e, _), sm) =>
let
val (t, sm) = cifyTyp (t, sm)
fun unravel (tAll as (t, _), eAll as (e, _)) =
case (t, e) of
(L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) =>
let
val (args, t, e) = unravel (ran, e)
in
((ax, dom) :: args, t, e)
end
| (L'.TFun _, _) =>
(ErrorMsg.errorAt loc "Function isn't explicit at code generation";
([], tAll, eAll))
| _ => ([], tAll, eAll)
val (args, ran, e) = unravel (t, e)
val (e, sm) = cifyExp (e, sm)
in
((x, n, args, ran, e), sm)
end)
sm vis
in
(SOME (L'.DFunRec vis, loc), NONE, sm)
end
| L.DExport (ek, s, n, ts, t, b) =>
let
val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
val (t, sm) = cifyTyp (t, sm)
in
(NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush, b), sm)
end
| L.DTable (s, xts, pe, ce) =>
let
val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
let
val (t, sm) = cifyTyp (t, sm)
in
((x, t), sm)
end) sm xts
fun flatten e =
case #1 e of
L.ERecord [] => []
| L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)]
| L.EStrcat (e1, e2) => flatten e1 @ flatten e2
| _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
Print.prefaces "Undetermined constraint"
[("e", MonoPrint.p_exp MonoEnv.empty e)];
[])
val pe = case #1 pe of
L.EPrim (Prim.String (_, s)) => s
| _ => (ErrorMsg.errorAt loc "Primary key has not been fully determined";
Print.prefaces "Undetermined constraint"
[("e", MonoPrint.p_exp MonoEnv.empty pe)];
"")
in
(SOME (L'.DTable (s, xts, pe, flatten ce), loc), NONE, sm)
end
| L.DSequence s =>
(SOME (L'.DSequence s, loc), NONE, sm)
| L.DView (s, xts, e) =>
let
val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
let
val (t, sm) = cifyTyp (t, sm)
in
((x, t), sm)
end) sm xts
fun flatten e =
case #1 e of
L.ERecord [] => []
| L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)]
| L.EStrcat (e1, e2) => flatten e1 @ flatten e2
| _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
Print.prefaces "Undetermined constraint"
[("e", MonoPrint.p_exp MonoEnv.empty e)];
[])
val e = case #1 e of
L.EPrim (Prim.String (_, s)) => s
| _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined";
Print.prefaces "Undetermined VIEW query"
[("e", MonoPrint.p_exp MonoEnv.empty e)];
"")
in
(SOME (L'.DView (s, xts, e), loc), NONE, sm)
end
| L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm)
| L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm)
| L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm)
| L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm)
| L.DTask (e1, e2) =>
(case #1 e2 of
L.EAbs (x1, _, _, (L.EAbs (x2, _, _, e), _)) =>
let
val tk = case #1 e1 of
L.EFfi ("Basis", "initialize") => L'.Initialize
| L.EFfi ("Basis", "clientLeaves") => L'.ClientLeaves
| L.EFfiApp ("Basis", "periodic", [((L.EPrim (Prim.Int n), _), _)]) => L'.Periodic n
| _ => (ErrorMsg.errorAt loc "Task kind not fully determined";
L'.Initialize)
val (e, sm) = cifyExp (e, sm)
in
(SOME (L'.DTask (tk, x1, x2, e), loc), NONE, sm)
end
| _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
(NONE, NONE, sm)))
| L.DPolicy _ => (NONE, NONE, sm)
| L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm)
fun cjrize (ds, sideInfo) =
let
val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) =>
let
val (dop, pop, sm) = cifyDecl (d, sm)
val dsF = case dop of
SOME (L'.DDatatype dts, loc) =>
map (fn (dk, x, n, _) =>
(L'.DDatatypeForward (dk, x, n), loc)) dts @ dsF
| _ => dsF
val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm)
@ dsF
val (dsF, ds) = case dop of
NONE => (dsF, ds)
| SOME (d as (L'.DDatatype _, loc)) =>
(d :: dsF, ds)
| SOME d => (dsF, d :: ds)
val ps = case pop of
NONE => ps
| SOME p => p :: ps
in
(dsF, ds, ps, Sm.clearDeclares sm)
end)
([], [], [], Sm.empty) ds
val sideInfo = foldl (fn ((n, mode, dbmode), mp) => IM.insert (mp, n, (mode, dbmode))) IM.empty sideInfo
val ps = map (fn (ek, s, n, ts, t, _, b) =>
let
val (side, db) = getOpt (IM.find (sideInfo, n), (L'.ServerOnly, L'.AnyDb))
in
(ek, s, n, ts, t, side, db, b)
end) ps
in
(List.revAppend (dsF, rev ds),
ps)
end
end
urweb-20160213+dfsg/src/compiler.mlb 0000664 0000000 0000000 00000000132 12657647235 0017127 0 ustar 00root root 0000000 0000000 $(SML_LIB)/basis/basis.mlb
$(SML_LIB)/basis/mlton.mlb
$(BUILD)/urweb.mlb
main.mlton.sml
urweb-20160213+dfsg/src/compiler.sig 0000664 0000000 0000000 00000022306 12657647235 0017146 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-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.
*)
(* Ur/Web main compiler interface *)
signature COMPILER = sig
type job = {
prefix : string,
database : string option,
sources : string list,
exe : string,
sql : string option,
debug : bool,
profile : bool,
timeout : int,
ffi : string list,
link : string list,
linker : string option,
headers : string list,
scripts : string list,
clientToServer : Settings.ffi list,
effectful : Settings.ffi list,
benignEffectful : Settings.ffi list,
clientOnly : Settings.ffi list,
serverOnly : Settings.ffi list,
jsFuncs : (Settings.ffi * string) list,
rewrites : Settings.rewrite list,
filterUrl : Settings.rule list,
filterMime : Settings.rule list,
filterRequest : Settings.rule list,
filterResponse : Settings.rule list,
filterEnv : Settings.rule list,
protocol : string option,
dbms : string option,
sigFile : string option,
safeGets : string list,
onError : (string * string list * string) option,
minHeap : int
}
val compile : string -> bool
val compiler : string -> unit
val compileC : {cname : string, oname : string, ename : string, libs : string,
profile : bool, debug : bool, linker : string option, link : string list} -> bool
val beforeC : (unit -> unit) ref
(* This function is called before beginning C compilation.
* The current use is for MLton to compact its heap here, to avoid hogging
* space after all the interesting ML code is done. *)
type ('src, 'dst) phase
type ('src, 'dst) transform
val transform : ('src, 'dst) phase -> string -> ('src, 'dst) transform
val o : ('b, 'c) transform * ('a, 'b) transform -> ('a, 'c) transform
val check : ('src, 'dst) transform -> 'src -> unit
val run : ('src, 'dst) transform -> 'src -> 'dst option
val runPrint : ('src, 'dst) transform -> 'src -> unit
val runPrintToFile : ('src, 'dst) transform -> 'src -> string -> unit
val time : ('src, 'dst) transform -> 'src -> unit
val timePrint : ('src, 'dst) transform -> 'src -> unit
val runPrintCoreFuncs : ('src, Core.file) transform -> 'src -> unit
val parseUr : (string, Source.file) phase
val parseUrs : (string, Source.sgn_item list) phase
val parseUrp : (string, job) phase
val parseUrp' : (string, {Job : job, Libs : string list}) phase
val parse : (job, Source.file) phase
val elaborate : (Source.file, Elab.file) phase
val unnest : (Elab.file, Elab.file) phase
val termination : (Elab.file, Elab.file) phase
val explify : (Elab.file, Expl.file) phase
val corify : (Expl.file, Core.file) phase
val core_untangle : (Core.file, Core.file) phase
val shake : (Core.file, Core.file) phase
val rpcify : (Core.file, Core.file) phase
val tag : (Core.file, Core.file) phase
val reduce : (Core.file, Core.file) phase
val unpoly : (Core.file, Core.file) phase
val especialize : (Core.file, Core.file) phase
val specialize : (Core.file, Core.file) phase
val marshalcheck : (Core.file, Core.file) phase
val effectize : (Core.file, Core.file) phase
val css : (Core.file, Css.report) phase
val monoize : (Core.file, Mono.file) phase
val mono_opt : (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
val iflow : (Mono.file, Mono.file) phase
val namejs : (Mono.file, Mono.file) phase
val scriptcheck : (Mono.file, Mono.file) phase
val jscomp : (Mono.file, Mono.file) phase
val fuse : (Mono.file, Mono.file) phase
val pathcheck : (Mono.file, Mono.file) phase
val sidecheck : (Mono.file, Mono.file) phase
val sigcheck : (Mono.file, Mono.file) phase
val sqlcache : (Mono.file, Mono.file) phase
val cjrize : (Mono.file, Cjr.file) phase
val prepare : (Cjr.file, Cjr.file) phase
val checknest : (Cjr.file, Cjr.file) phase
val sqlify : (Mono.file, Cjr.file) phase
val toParseJob : (string, job) transform
val toParseJob' : (string, {Job : job, Libs : string list}) transform
val toParse : (string, Source.file) transform
val toElaborate : (string, Elab.file) transform
val toUnnest : (string, Elab.file) transform
val toTermination : (string, Elab.file) transform
val toExplify : (string, Expl.file) transform
val toCorify : (string, Core.file) transform
val toCore_untangle : (string, Core.file) transform
val toShake1 : (string, Core.file) transform
val toEspecialize1' : (string, Core.file) transform
val toShake1' : (string, Core.file) transform
val toRpcify : (string, Core.file) transform
val toCore_untangle2 : (string, Core.file) transform
val toShake2 : (string, Core.file) transform
val toEspecialize1 : (string, Core.file) transform
val toCore_untangle3 : (string, Core.file) transform
val toShake3 : (string, Core.file) transform
val toTag : (string, Core.file) transform
val toReduce : (string, Core.file) transform
val toShakey : (string, Core.file) transform
val toUnpoly : (string, Core.file) transform
val toSpecialize : (string, Core.file) transform
val toShake4 : (string, Core.file) transform
val toEspecialize2 : (string, Core.file) transform
val toShake4' : (string, Core.file) transform
val toSpecialize2 : (string, Core.file) transform
val toUnpoly2 : (string, Core.file) transform
val toShake4'' : (string, Core.file) transform
val toEspecialize3 : (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 toMono_opt1 : (string, Mono.file) transform
val toUntangle : (string, Mono.file) transform
val toMono_reduce : (string, Mono.file) transform
val toMono_shake : (string, Mono.file) transform
val toMono_opt2 : (string, Mono.file) transform
val toIflow : (string, Mono.file) transform
val toNamejs : (string, Mono.file) transform
val toNamejs_untangle : (string, Mono.file) transform
val toScriptcheck : (string, Mono.file) transform
val toDbmodecheck : (string, Mono.file) transform
val toJscomp : (string, Mono.file) transform
val toMono_opt3 : (string, Mono.file) transform
val toFuse : (string, Mono.file) transform
val toUntangle2 : (string, Mono.file) transform
val toMono_reduce2 : (string, Mono.file) transform
val toMono_shake2 : (string, Mono.file) transform
val toMono_opt4 : (string, Mono.file) transform
val toMono_reduce3 : (string, Mono.file) transform
val toFuse2 : (string, Mono.file) transform
val toUntangle3 : (string, Mono.file) transform
val toMono_shake3 : (string, Mono.file) transform
val toPathcheck : (string, Mono.file) transform
val toSidecheck : (string, Mono.file) transform
val toSigcheck : (string, Mono.file) transform
val toSqlcache : (string, Mono.file) transform
val toCjrize : (string, Cjr.file) transform
val toPrepare : (string, Cjr.file) transform
val toChecknest : (string, Cjr.file) transform
val toSqlify : (string, Cjr.file) transform
val debug : bool ref
val dumpSource : bool ref
val enableBoot : unit -> unit
val doIflow : bool ref
val addPath : string * string -> unit
val addModuleRoot : string * string -> unit
val moduleOf : string -> string
val setStop : string -> unit
(* Stop compilation after this phase. *)
end
urweb-20160213+dfsg/src/compiler.sml 0000664 0000000 0000000 00000223760 12657647235 0017166 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2012, 2014, 2016, 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 Compiler :> COMPILER = struct
structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token)
structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens)
structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData
structure Lex = Lex
structure LrParser = LrParser)
type job = {
prefix : string,
database : string option,
sources : string list,
exe : string,
sql : string option,
debug : bool,
profile : bool,
timeout : int,
ffi : string list,
link : string list,
linker : string option,
headers : string list,
scripts : string list,
clientToServer : Settings.ffi list,
effectful : Settings.ffi list,
benignEffectful : Settings.ffi list,
clientOnly : Settings.ffi list,
serverOnly : Settings.ffi list,
jsFuncs : (Settings.ffi * string) list,
rewrites : Settings.rewrite list,
filterUrl : Settings.rule list,
filterMime : Settings.rule list,
filterRequest : Settings.rule list,
filterResponse : Settings.rule list,
filterEnv : Settings.rule list,
protocol : string option,
dbms : string option,
sigFile : string option,
safeGets : string list,
onError : (string * string list * string) option,
minHeap : int
}
type ('src, 'dst) phase = {
func : 'src -> 'dst,
print : 'dst -> Print.PD.pp_desc
}
type pmap = (string * Time.time) list
type ('src, 'dst) transform = {
func : 'src -> 'dst option,
print : 'dst -> Print.PD.pp_desc,
time : 'src * pmap -> 'dst option * pmap
}
val debug = ref false
val dumpSource = ref false
val doIflow = ref false
val doDumpSource = ref (fn () => ())
val stop = ref (NONE : string option)
fun setStop s = stop := SOME s
fun transform (ph : ('src, 'dst) phase) name = {
func = fn input => let
val () = if !debug then
print ("Starting " ^ name ^ "....\n")
else
()
val v = #func ph input
in
if !debug then
print ("Finished " ^ name ^ ".\n")
else
();
if ErrorMsg.anyErrors () then
(!doDumpSource ();
doDumpSource := (fn () => ());
NONE)
else if !stop = SOME name then
(Print.eprint (#print ph v);
ErrorMsg.error ("Stopped compilation after phase " ^ name);
NONE)
else
(if !dumpSource then
doDumpSource := (fn () => Print.eprint (#print ph v))
else
();
SOME v)
end,
print = #print ph,
time = fn (input, pmap) => let
val () = if !debug then
print ("Starting " ^ name ^ "....\n")
else
()
val befor = Time.now ()
val v = #func ph input
val elapsed = Time.- (Time.now (), befor)
in
if !debug then
print ("Finished " ^ name ^ ".\n")
else
();
(if ErrorMsg.anyErrors () then
NONE
else
SOME v,
(name, elapsed) :: pmap)
end
}
fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
ignore (#func tr x))
fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
#func tr x)
fun runPrint (tr : ('src, 'dst) transform) input =
(ErrorMsg.resetErrors ();
case #func tr input of
NONE => print "Failure\n"
| SOME v =>
(print "Success\n";
Print.print (#print tr v);
print "\n"))
fun runPrintToFile (tr : ('src, 'dst) transform) input fname =
(ErrorMsg.resetErrors ();
case #func tr input of
NONE => print "Failure\n"
| SOME v =>
let
val outf = TextIO.openOut fname
val str = Print.openOut {dst = outf, wid = 80}
in
print "Success\n";
Print.fprint str (#print tr v);
Print.PD.PPS.closeStream str;
TextIO.closeOut outf
end)
fun time (tr : ('src, 'dst) transform) input =
let
val (_, pmap) = #time tr (input, [])
in
app (fn (name, time) =>
print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
print "\n"
end
fun timePrint (tr : ('src, 'dst) transform) input =
let
val (ro, pmap) = #time tr (input, [])
in
app (fn (name, time) =>
print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
print "\n";
case ro of
NONE => print "Failure\n"
| SOME v =>
(print "Success\n";
Print.print (#print tr v);
print "\n")
end
fun runPrintCoreFuncs (tr : ('src, Core.file) transform) input =
(ErrorMsg.resetErrors ();
case #func tr input of
NONE => print "Failure\n"
| SOME file =>
(print "Success\n";
app (fn (d, _) =>
case d of
Core.DVal (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t)
| Core.DValRec xts => app (fn (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t)) xts
| _ => ()) file))
val parseUrs =
{func = fn filename => let
val fname = OS.FileSys.tmpName ()
val outf = TextIO.openOut fname
val () = TextIO.output (outf, "sig\n")
val inf = TextIO.openIn filename
fun loop () =
case TextIO.inputLine inf of
NONE => ()
| SOME line => (TextIO.output (outf, line);
loop ())
val () = loop ()
val () = TextIO.closeIn inf
val () = TextIO.closeOut outf
val () = (ErrorMsg.resetErrors ();
ErrorMsg.resetPositioning filename;
Lex.UserDeclarations.initialize ())
val file = TextIO.openIn fname
fun get _ = TextIO.input file
fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
in
TextIO.closeIn file;
case absyn of
[(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis
| _ => (ErrorMsg.errorAt {file = filename,
first = {line = 0,
char = 0},
last = {line = 0,
char = 0}} "Not a signature";
[])
end
handle LrParser.ParseError => [],
print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item}
(* The main parsing routine *)
val parseUr = {
func = fn filename =>
let
val () = (ErrorMsg.resetErrors ();
ErrorMsg.resetPositioning filename;
Lex.UserDeclarations.initialize ())
val file = TextIO.openIn filename
fun get _ = TextIO.input file
fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
in
TextIO.closeIn file;
case absyn of
[(Source.DSgn ("?", _), _)] =>
(ErrorMsg.errorAt {file = filename,
first = {line = 0,
char = 0},
last = {line = 0,
char = 0}} "File starts with 'sig'";
[])
| _ => absyn
end
handle LrParser.ParseError => [],
print = SourcePrint.p_file}
fun p_job ({prefix, database, exe, sql, sources, debug, profile,
timeout, ffi, link, headers, scripts,
clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
let
open Print.PD
open Print
fun p_ffi name = p_list_sep (box []) (fn (m, s) =>
box [string name, space, string m, string ".", string s, newline])
in
box [if debug then
box [string "DEBUG", newline]
else
box [],
if profile then
box [string "PROFILE", newline]
else
box [],
case database of
NONE => string "No database."
| SOME db => string ("Database: " ^ db),
newline,
string "Exe: ",
string exe,
newline,
case sql of
NONE => string "No SQL file."
| SOME sql => string ("SQL fle: " ^ sql),
newline,
string "Timeout: ",
string (Int.toString timeout),
newline,
p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi,
p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers,
p_list_sep (box []) (fn s => box [string "Script", space, string s, newline]) scripts,
p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
p_ffi "ClientToServer" clientToServer,
p_ffi "Effectful" effectful,
p_ffi "BenignEffectful" benignEffectful,
p_ffi "ClientOnly" clientOnly,
p_ffi "ServerOnly" serverOnly,
p_list_sep (box []) (fn ((m, s), s') =>
box [string "JsFunc", space, string m, string ".", string s,
space, string "=", space, string s', newline]) jsFuncs,
string "Sources:",
p_list string sources,
newline]
end
fun trim s =
let
val (_, s) = Substring.splitl Char.isSpace s
val (s, _) = Substring.splitr Char.isSpace s
in
s
end
val trimS = Substring.string o trim o Substring.full
structure M = BinaryMapFn(struct
type ord_key = string
val compare = String.compare
end)
(* XXX ezyang: pathmap gets initialized /really early/, before
* we do any options parsing. So libUr will always point to the
* default. We override it explicitly in enableBoot *)
val pathmap = ref (M.insert (M.empty, "", Settings.libUr ()))
fun addPath (k, v) = pathmap := M.insert (!pathmap, k, v)
(* XXX ezyang: this is not right; it probably doesn't work in
* the case of separate build and src trees *)
fun enableBoot () =
(Settings.configBin := OS.Path.joinDirFile {dir = Config.builddir, file = "bin"};
Settings.configSrcLib := OS.Path.joinDirFile {dir = Config.builddir, file = "lib"};
(* joinDirFile is annoying... (ArcError; it doesn't like
* slashes in file) *)
Settings.configLib := Config.builddir ^ "/src/c/.libs";
Settings.configInclude := OS.Path.joinDirFile {dir = Config.builddir ^ "/include", file = "urweb"};
Settings.configSitelisp := Config.builddir ^ "/src/elisp";
addPath ("", Settings.libUr ()))
fun capitalize "" = ""
| capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
fun institutionalizeJob (job : job) =
(Settings.setDebug (#debug job);
Settings.setUrlPrefix (#prefix job);
Settings.setTimeout (#timeout job);
Settings.setHeaders (#headers job);
Settings.setScripts (#scripts job);
Settings.setClientToServer (#clientToServer job);
Settings.setEffectful (#effectful job);
Settings.setBenignEffectful (#benignEffectful job);
Settings.setClientOnly (#clientOnly job);
Settings.setServerOnly (#serverOnly job);
Settings.setJsFuncs (#jsFuncs job);
Settings.setRewriteRules (#rewrites job);
Settings.setUrlRules (#filterUrl job);
Settings.setMimeRules (#filterMime job);
Settings.setRequestHeaderRules (#filterRequest job);
Settings.setResponseHeaderRules (#filterResponse job);
Settings.setEnvVarRules (#filterEnv job);
Option.app Settings.setProtocol (#protocol job);
Option.app Settings.setDbms (#dbms job);
Settings.setSafeGets (#safeGets job);
Settings.setOnError (#onError job);
Settings.setMinHeap (#minHeap job);
Settings.setSigFile (#sigFile job))
datatype commentableLine =
EndOfFile
| OnlyComment
| Content of string
fun inputCommentableLine inf =
case TextIO.inputLine inf of
NONE => EndOfFile
| SOME s =>
let
val (befor, after) = Substring.splitl (fn ch => ch <> #"#") (Substring.full s)
in
if not (Substring.isEmpty after)
andalso Substring.foldl (fn (ch, b) => b andalso Char.isSpace ch) true befor then
OnlyComment
else
let
val s = #1 (Substring.splitr (not o Char.isSpace) befor)
in
Content (Substring.string (if Substring.size s > 0 andalso Char.isSpace (Substring.sub (s, Substring.size s - 1)) then
if Substring.size s > 1 andalso Char.isSpace (Substring.sub (s, Substring.size s - 2)) then
Substring.trimr 2 s
else
Substring.trimr 1 s
else
s))
end
end
val lastUrp = ref ""
structure SK = struct
type ord_key = string
val compare = String.compare
end
structure SS = BinarySetFn(SK)
structure SM = BinaryMapFn(SK)
fun parseUrp' accLibs fname =
(lastUrp := fname;
if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", []))
andalso Posix.FileSys.access (fname ^ ".ur", []) then
let
val job = {prefix = "/",
database = NONE,
sources = [fname],
exe = fname ^ ".exe",
sql = NONE,
debug = Settings.getDebug (),
profile = false,
timeout = 60,
ffi = [],
link = [],
linker = NONE,
headers = [],
scripts = [],
clientToServer = [],
effectful = [],
benignEffectful = [],
clientOnly = [],
serverOnly = [],
jsFuncs = [],
rewrites = [{pkind = Settings.Any,
kind = Settings.Prefix,
from = capitalize (OS.Path.file fname) ^ "/", to = "",
hyphenate = false}],
filterUrl = [],
filterMime = [],
filterRequest = [],
filterResponse = [],
filterEnv = [],
protocol = NONE,
dbms = NONE,
sigFile = NONE,
safeGets = [],
onError = NONE,
minHeap = 0}
in
institutionalizeJob job;
{Job = job, Libs = []}
end
else
let
val pathmap = ref (!pathmap)
val bigLibs = ref []
val libSet = ref SS.empty
fun pu filename =
let
val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()}
val thisPath = OS.Path.dir filename
val dir = OS.Path.dir filename
fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
val inf = opener ()
fun hasSpaceLine () =
case inputCommentableLine inf of
Content s => s = "debug" orelse s = "profile"
orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine ()
| EndOfFile => false
| OnlyComment => hasSpaceLine ()
val hasBlankLine = hasSpaceLine ()
val inf = (TextIO.closeIn inf; opener ())
fun pathify fname =
if size fname > 0 andalso String.sub (fname, 0) = #"$" then
let
val fname' = Substring.extract (fname, 1, NONE)
val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
in
case M.find (!pathmap, Substring.string befor) of
NONE => fname
| SOME rep => rep ^ Substring.string after
end
else
fname
fun relify fname =
let
val fname = pathify fname
in
OS.Path.concat (dir, fname)
handle OS.Path.Path => fname
end
fun libify path =
(if Posix.FileSys.access (path ^ ".urp", []) then
path
else
path ^ "/lib")
handle SysErr => path
fun libify' path =
(if Posix.FileSys.access (relify path ^ ".urp", []) then
path
else
path ^ "/lib")
handle SysErr => path
val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
fun relifyA fname =
OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
fun readSources acc =
case inputCommentableLine inf of
Content line =>
let
val acc = if CharVector.all Char.isSpace line then
acc
else
let
val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
(String.explode line))
val fname = relifyA fname
in
fname :: acc
end
in
readSources acc
end
| OnlyComment => readSources acc
| EndOfFile => rev acc
val prefix = ref (case Settings.getUrlPrefixFull () of "/" => NONE | s => SOME s)
val database = ref (Settings.getDbstring ())
val exe = ref (Settings.getExe ())
val sql = ref (Settings.getSql ())
val debug = ref (Settings.getDebug ())
val profile = ref false
val timeout = ref NONE
val ffi = ref []
val link = ref []
val linker = ref NONE
val headers = ref []
val scripts = ref []
val clientToServer = ref []
val effectful = ref []
val benignEffectful = ref []
val clientOnly = ref []
val serverOnly = ref []
val jsFuncs = ref []
val rewrites = ref []
val url = ref []
val mime = ref []
val request = ref []
val response = ref []
val env = ref []
val libs = ref []
val protocol = ref NONE
val dbms = ref NONE
val sigFile = ref (Settings.getSigFile ())
val safeGets = ref []
val onError = ref NONE
val minHeap = ref 0
fun finish sources =
let
val job = {
prefix = Option.getOpt (!prefix, "/"),
database = !database,
exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
ext = SOME "exe"}),
sql = !sql,
debug = !debug,
profile = !profile,
timeout = Option.getOpt (!timeout, 60),
ffi = rev (!ffi),
link = rev (!link),
linker = !linker,
headers = rev (!headers),
scripts = rev (!scripts),
clientToServer = rev (!clientToServer),
effectful = rev (!effectful),
benignEffectful = rev (!benignEffectful),
clientOnly = rev (!clientOnly),
serverOnly = rev (!serverOnly),
jsFuncs = rev (!jsFuncs),
rewrites = rev (!rewrites),
filterUrl = rev (!url),
filterMime = rev (!mime),
filterRequest = rev (!request),
filterResponse = rev (!response),
filterEnv = rev (!env),
sources = sources,
protocol = !protocol,
dbms = !dbms,
sigFile = !sigFile,
safeGets = rev (!safeGets),
onError = !onError,
minHeap = !minHeap
}
fun mergeO f (old, new) =
case (old, new) of
(NONE, _) => new
| (_, NONE) => old
| (SOME v1, SOME v2) => SOME (f (v1, v2))
fun same desc = mergeO (fn (x : string, y) =>
(if x = y then
()
else
ErrorMsg.error ("Multiple "
^ desc ^ " values that don't agree");
x))
fun merge (old : job, new : job) = {
prefix = case #prefix old of
"/" => #prefix new
| pold => case #prefix new of
"/" => pold
| pnew => (if pold = pnew then
()
else
ErrorMsg.error ("Multiple prefix values that don't agree: "
^ pold ^ ", " ^ pnew);
pold),
database = mergeO (fn (old, _) => old) (#database old, #database new),
exe = #exe old,
sql = #sql old,
debug = #debug old orelse #debug new,
profile = #profile old orelse #profile new,
timeout = #timeout old,
ffi = #ffi old @ #ffi new,
link = #link old @ #link new,
linker = mergeO (fn (_, new) => new) (#linker old, #linker new),
headers = #headers old @ #headers new,
scripts = #scripts old @ #scripts new,
clientToServer = #clientToServer old @ #clientToServer new,
effectful = #effectful old @ #effectful new,
benignEffectful = #benignEffectful old @ #benignEffectful new,
clientOnly = #clientOnly old @ #clientOnly new,
serverOnly = #serverOnly old @ #serverOnly new,
jsFuncs = #jsFuncs old @ #jsFuncs new,
rewrites = #rewrites old @ #rewrites new,
filterUrl = #filterUrl old @ #filterUrl new,
filterMime = #filterMime old @ #filterMime new,
filterRequest = #filterRequest old @ #filterRequest new,
filterResponse = #filterResponse old @ #filterResponse new,
filterEnv = #filterEnv old @ #filterEnv new,
sources = #sources new
@ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
(#sources old),
protocol = mergeO #2 (#protocol old, #protocol new),
dbms = mergeO #2 (#dbms old, #dbms new),
sigFile = mergeO #2 (#sigFile old, #sigFile new),
safeGets = #safeGets old @ #safeGets new,
onError = mergeO #2 (#onError old, #onError new),
minHeap = Int.max (#minHeap old, #minHeap new)
}
in
if accLibs then
foldr (fn (job', job) => merge (job, job')) job (!libs)
else
job
end
fun parsePkind s =
case s of
"all" => Settings.Any
| "url" => Settings.Url
| "table" => Settings.Table
| "sequence" => Settings.Sequence
| "view" => Settings.View
| "relation" => Settings.Relation
| "cookie" => Settings.Cookie
| "style" => Settings.Style
| _ => (ErrorMsg.error "Bad path kind spec";
Settings.Any)
fun parsePattern s =
if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
(Settings.Prefix, String.substring (s, 0, size s - 1))
else
(Settings.Exact, s)
fun parseFkind s =
case s of
"url" => url
| "mime" => mime
| "requestHeader" => request
| "responseHeader" => response
| "env" => env
| _ => (ErrorMsg.error "Bad filter kind";
url)
fun read () =
case inputCommentableLine inf of
EndOfFile => finish []
| OnlyComment => read ()
| Content "" => finish (readSources [])
| Content line =>
let
val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
val cmd = Substring.string (trim cmd)
val arg = Substring.string (trim arg)
fun ffiS () =
case String.fields (fn ch => ch = #".") arg of
[m, x] => (m, x)
| _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
("", ""))
fun ffiM () =
case String.fields (fn ch => ch = #"=") arg of
[f, s] =>
let
val f = trimS f
val s = trimS s
in
case String.fields (fn ch => ch = #".") f of
[m, x] => ((m, x), s)
| _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
(("", ""), ""))
end
| _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
(("", ""), ""))
in
case cmd of
"prefix" => prefix := SOME arg
| "database" =>
(case !database of
NONE => database := SOME arg
| SOME _ => ())
| "dbms" =>
(case !dbms of
NONE => dbms := SOME arg
| SOME _ => ())
| "sigfile" =>
(case !sigFile of
NONE => sigFile := SOME arg
| SOME _ => ())
| "exe" =>
(case !exe of
NONE => exe := SOME (relify arg)
| SOME _ => ())
| "sql" =>
(case !sql of
NONE => sql := SOME (relify arg)
| SOME _ => ())
| "debug" => debug := true
| "profile" => profile := true
| "timeout" =>
(case !timeout of
NONE => ()
| SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
timeout := SOME (valOf (Int.fromString arg)))
| "ffi" => ffi := relify arg :: !ffi
| "link" => let
val arg = if size arg >= 1
andalso String.sub (arg, 0) = #"-" then
arg
else
relifyA arg
in
link := arg :: !link
end
| "linker" => linker := SOME arg
| "include" => headers := relifyA arg :: !headers
| "script" => scripts := arg :: !scripts
| "clientToServer" => clientToServer := ffiS () :: !clientToServer
| "safeGet" => safeGets := arg :: !safeGets
| "effectful" => effectful := ffiS () :: !effectful
| "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
| "clientOnly" => clientOnly := ffiS () :: !clientOnly
| "serverOnly" => serverOnly := ffiS () :: !serverOnly
| "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
| "rewrite" =>
let
fun doit (pkind, from, to, hyph) =
let
val pkind = parsePkind pkind
val (kind, from) = parsePattern from
in
rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites
end
in
case String.tokens Char.isSpace arg of
[pkind, from, to, "[-]"] => doit (pkind, from, to, true)
| [pkind, from, "[-]"] => doit (pkind, from, "", true)
| [pkind, from, to] => doit (pkind, from, to, false)
| [pkind, from] => doit (pkind, from, "", false)
| _ => ErrorMsg.error "Bad 'rewrite' syntax"
end
| "allow" =>
(case String.tokens Char.isSpace arg of
[fkind, pattern] =>
let
val fkind = parseFkind fkind
val (kind, pattern) = parsePattern pattern
in
fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
end
| _ => ErrorMsg.error "Bad 'allow' syntax")
| "deny" =>
(case String.tokens Char.isSpace arg of
[fkind, pattern] =>
let
val fkind = parseFkind fkind
val (kind, pattern) = parsePattern pattern
in
fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
end
| _ => ErrorMsg.error "Bad 'deny' syntax")
| "library" =>
if accLibs then
let
val arg = libify (relify arg)
in
if SS.member (!libSet, arg) then
()
else
(libs := pu arg :: !libs;
libSet := SS.add (!libSet, arg))
end
else
bigLibs := libify' arg :: !bigLibs
| "path" =>
(case String.fields (fn ch => ch = #"=") arg of
[n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir}))
handle OS.Path.Path => ErrorMsg.error "Invalid 'path' directory argument")
| _ => ErrorMsg.error "path argument not of the form name=value'")
| "onError" =>
(case String.fields (fn ch => ch = #".") arg of
m1 :: (fs as _ :: _) =>
onError := SOME (m1, List.take (fs, length fs - 1), List.last fs)
| _ => ErrorMsg.error "invalid 'onError' argument")
| "limit" =>
(case String.fields Char.isSpace arg of
[class, num] =>
(case Int.fromString num of
NONE => ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
| SOME n =>
if n < 0 then
ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
else
Settings.addLimit (class, n))
| _ => ErrorMsg.error "invalid 'limit' arguments")
| "minHeap" =>
(case Int.fromString arg of
NONE => ErrorMsg.error ("invalid min heap '" ^ arg ^ "'")
| SOME n => minHeap := n)
| "coreInline" =>
(case Int.fromString arg of
NONE => ErrorMsg.error ("invalid core inline level '" ^ arg ^ "'")
| SOME n => Settings.setCoreInline n)
| "monoInline" =>
(case Int.fromString arg of
NONE => ErrorMsg.error ("invalid mono inline level '" ^ arg ^ "'")
| SOME n => Settings.setMonoInline n)
| "alwaysInline" => Settings.addAlwaysInline arg
| "neverInline" => Settings.addNeverInline arg
| "noXsrfProtection" => Settings.addNoXsrfProtection arg
| "timeFormat" => Settings.setTimeFormat arg
| "noMangleSql" => Settings.setMangleSql false
| "html5" => Settings.setIsHtml5 true
| "lessSafeFfi" => Settings.setLessSafeFfi true
| "file" =>
(case String.fields Char.isSpace arg of
[uri, fname] => (Settings.setFilePath thisPath;
Settings.addFile {Uri = uri,
LoadFromFilename = fname};
url := {action = Settings.Allow, kind = Settings.Exact, pattern = uri} :: !url)
| _ => ErrorMsg.error "Bad 'file' arguments")
| "jsFile" =>
(Settings.setFilePath thisPath;
Settings.addJsFile arg)
| _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
read ()
end
val job = if hasBlankLine then
read ()
else
finish (readSources [])
in
TextIO.closeIn inf;
institutionalizeJob job;
job
end
in
{Job = pu fname, Libs = !bigLibs}
end)
fun p_job' {Job = j, Libs = _ : string list} = p_job j
val parseUrp = {
func = #Job o parseUrp' true,
print = p_job
}
val parseUrp' = {
func = parseUrp' false,
print = p_job'
}
val toParseJob = transform parseUrp "parseJob"
val toParseJob' = transform parseUrp' "parseJob'"
fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
func = fn input => case #func tr1 input of
NONE => NONE
| SOME v => #func tr2 v,
print = #print tr2,
time = fn (input, pmap) => let
val (ro, pmap) = #time tr1 (input, pmap)
in
case ro of
NONE => (NONE, pmap)
| SOME v => #time tr2 (v, pmap)
end
}
structure SM = BinaryMapFn(struct
type ord_key = string
val compare = String.compare
end)
val moduleRoots = ref ([] : (string * string) list)
fun addModuleRoot (k, v) = moduleRoots :=
(OS.Path.mkAbsolute {path = k,
relativeTo = OS.FileSys.getDir ()},
v) :: !moduleRoots
exception MissingFile of string
val parse = {
func = fn {database, sources = fnames, ffi, onError, ...} : job =>
let
val mrs = !moduleRoots
val anyErrors = ref false
fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ())
fun nameOf fname =
let
val fname = OS.Path.file fname
val fst = if size fname = 0 then #"!" else String.sub (fname, 0)
in
if not (Char.isAlpha fst) then
ErrorMsg.error ("Filename doesn't start with letter: " ^ fname)
else if CharVector.exists (fn ch => not (Char.isAlphaNum ch) andalso ch <> #"_") fname then
ErrorMsg.error ("Filename contains a character that isn't alphanumeric or underscore: " ^ fname)
else
();
capitalize fname
end
fun parseFfi fname =
let
val mname = nameOf fname
val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
val loc = {file = urs,
first = ErrorMsg.dummyPos,
last = ErrorMsg.dummyPos}
val sgn = (Source.SgnConst (#func parseUrs urs), loc)
in
checkErrors ();
(Source.DFfiStr (mname, sgn, if !Elaborate.incremental then SOME (OS.FileSys.modTime urs) else NONE), loc)
end
val defed = ref SS.empty
val fulls = ref SS.empty
fun parseOne fname =
let
val mname = nameOf fname
val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
val () = if Posix.FileSys.access (ur, []) then
()
else
raise MissingFile ur
val sgnO =
if Posix.FileSys.access (urs, []) then
SOME (Source.SgnConst (#func parseUrs urs),
{file = urs,
first = ErrorMsg.dummyPos,
last = ErrorMsg.dummyPos})
before checkErrors ()
else
NONE
val loc = {file = ur,
first = ErrorMsg.dummyPos,
last = ErrorMsg.dummyPos}
val urt = OS.FileSys.modTime ur
val urst = (OS.FileSys.modTime urs) handle _ => urt
val ds = #func parseUr ur
val d = (Source.DStr (mname, sgnO, if !Elaborate.incremental then SOME (if Time.> (urt, urst) then urt else urst) else NONE,
(Source.StrConst ds, loc), false), loc)
val fname = OS.Path.mkCanonical fname
val d = case List.find (fn (root, name) =>
String.isPrefix (root ^ "/") fname) mrs of
NONE => d
| SOME (root, name) =>
let
val fname = String.extract (fname, size root + 1, NONE)
val pieces = name :: String.tokens (fn ch => ch = #"/") fname
val pieces = List.filter (fn s => size s > 0
andalso Char.isAlpha (String.sub (s, 0)))
pieces
val pieces = map capitalize pieces
val full = String.concatWith "." pieces
fun makeD first prefix pieces =
case pieces of
[] => (ErrorMsg.error "Empty module path";
(Source.DStyle "Boo", loc))
| [_] => d
| piece :: pieces =>
let
val this = case prefix of
"" => piece
| _ => prefix ^ "." ^ piece
val old = SS.member (!defed, this)
fun notThere (ch, s) =
Substring.isEmpty (#2 (Substring.splitl
(fn ch' => ch' <> ch) s))
fun simOpen () =
SS.foldl (fn (full, ds) =>
if String.isPrefix (this ^ ".") full
andalso notThere (#".",
Substring.extract (full,
size
this + 1,
NONE)) then
let
val parts = String.tokens
(fn ch => ch = #".") full
val part = List.last parts
val imp = if length parts >= 2 then
(Source.StrProj
((Source.StrVar
(List.nth (parts,
length
parts
- 2)),
loc),
part), loc)
else
(Source.StrVar part, loc)
in
(Source.DStr (part, NONE, NONE, imp, false),
loc) :: ds
end
else
ds) [] (!fulls)
in
defed := SS.add (!defed, this);
(Source.DStr (piece, NONE, NONE,
(Source.StrConst (if old then
simOpen ()
@ [makeD false this pieces]
else
[makeD false this pieces]),
loc), first andalso old),
loc)
end
in
if SS.member (!fulls, full) then
ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.")
else
();
makeD true "" pieces
before ignore (foldl (fn (new, path) =>
let
val new' = case path of
"" => new
| _ => path ^ "." ^ new
in
fulls := SS.add (!fulls, new');
new'
end) "" pieces)
end
in
checkErrors ();
d
end handle MissingFile fname => (ErrorMsg.error ("Missing source file: " ^ fname);
(Source.DSequence "", ErrorMsg.dummySpan))
val dsFfi = map parseFfi ffi
val ds = map parseOne fnames
val loc = ErrorMsg.dummySpan
in
if !anyErrors then
ErrorMsg.error "Parse failure"
else
();
let
val final = List.last fnames
val final = case List.find (fn (root, name) =>
String.isPrefix (root ^ "/") final) mrs of
NONE => (Source.StrVar (nameOf final), loc)
| SOME (root, name) =>
let
val m = (Source.StrVar name, loc)
val final = String.extract (final, size root + 1, NONE)
val fields = String.fields (fn ch => ch = #"/") final
val fields = List.filter (fn s => size s = 0
orelse not (Char.isDigit (String.sub (s, 0))))
fields
in
foldl (fn (x, m) => (Source.StrProj (m, capitalize x), loc))
m fields
end
val ds = dsFfi @ ds
@ [(Source.DExport final, loc)]
val ds = case database of
NONE => ds
| SOME s => (Source.DDatabase s, loc) :: ds
val ds = case onError of
NONE => ds
| SOME v => ds @ [(Source.DOnError v, loc)]
fun dummy fname = {file = Settings.libFile fname,
first = ErrorMsg.dummyPos,
last = ErrorMsg.dummyPos}
val used = SM.insert (SM.empty, "Basis", dummy "basis.urs")
val used = SM.insert (used, "Top", dummy "top.urs")
in
ignore (List.foldl (fn (d, used) =>
case #1 d of
Source.DStr (x, _, _, _, false) =>
(case SM.find (used, x) of
SOME loc =>
(ErrorMsg.error ("Duplicate top-level module name " ^ x);
Print.prefaces "Files" [("Previous", Print.PD.string (ErrorMsg.spanToString loc)),
("Current", Print.PD.string (ErrorMsg.spanToString (#2 d)))];
used)
| NONE =>
SM.insert (used, x, #2 d))
| _ => used) used ds);
ds
end handle Empty => ds
end,
print = SourcePrint.p_file
}
val toParse = transform parse "parse" o toParseJob
val elaborate = {
func = fn file => let
val basisF = Settings.libFile "basis.urs"
val topF = Settings.libFile "top.urs"
val topF' = Settings.libFile "top.ur"
val basis = #func parseUrs basisF
val topSgn = #func parseUrs topF
val topStr = #func parseUr topF'
val tm1 = OS.FileSys.modTime topF
val tm2 = OS.FileSys.modTime topF'
in
Elaborate.elabFile basis (OS.FileSys.modTime basisF)
topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1)
ElabEnv.empty file
end,
print = ElabPrint.p_file ElabEnv.empty
}
val toElaborate = transform elaborate "elaborate" o toParse
val unnest = {
func = Unnest.unnest,
print = ElabPrint.p_file ElabEnv.empty
}
val toUnnest = transform unnest "unnest" o toElaborate
val termination = {
func = (fn file => (Termination.check file; file)),
print = ElabPrint.p_file ElabEnv.empty
}
val toTermination = transform termination "termination" o toUnnest
val explify = {
func = Explify.explify,
print = ExplPrint.p_file ExplEnv.empty
}
val toExplify = transform explify "explify" o toUnnest
val corify = {
func = Corify.corify,
print = CorePrint.p_file CoreEnv.empty
}
val toCorify = transform corify "corify" o toExplify
(*val reduce_local = {
func = ReduceLocal.reduce,
print = CorePrint.p_file CoreEnv.empty
}
val toReduce_local = transform reduce_local "reduce_local" o toCorify*)
val especialize = {
func = ESpecialize.specialize,
print = CorePrint.p_file CoreEnv.empty
}
val core_untangle = {
func = CoreUntangle.untangle,
print = CorePrint.p_file CoreEnv.empty
}
val toCore_untangle = transform core_untangle "core_untangle" o toCorify
val shake = {
func = Shake.shake,
print = CorePrint.p_file CoreEnv.empty
}
val toShake1 = transform shake "shake1" o toCore_untangle
val toEspecialize1' = transform especialize "especialize1'" o toShake1
val toShake1' = transform shake "shake1'" o toEspecialize1'
val rpcify = {
func = Rpcify.frob,
print = CorePrint.p_file CoreEnv.empty
}
val toRpcify = transform rpcify "rpcify" o toShake1'
val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify
val toShake2 = transform shake "shake2" o toCore_untangle2
val toEspecialize1 = transform especialize "especialize1" o toShake2
val toCore_untangle3 = transform core_untangle "core_untangle3" o toEspecialize1
val toShake3 = transform shake "shake3" o toCore_untangle3
val tag = {
func = Tag.tag,
print = CorePrint.p_file CoreEnv.empty
}
val toTag = transform tag "tag" o toShake3
val reduce = {
func = Reduce.reduce,
print = CorePrint.p_file CoreEnv.empty
}
val toReduce = transform reduce "reduce" o toTag
val toShakey = transform shake "shakey" o toReduce
val unpoly = {
func = Unpoly.unpoly,
print = CorePrint.p_file CoreEnv.empty
}
val toUnpoly = transform unpoly "unpoly" o toShakey
val specialize = {
func = Specialize.specialize,
print = CorePrint.p_file CoreEnv.empty
}
val toSpecialize = transform specialize "specialize" o toUnpoly
val toShake4 = transform shake "shake4" o toSpecialize
val toEspecialize2 = transform especialize "especialize2" o toShake4
val toShake4' = transform shake "shake4'" o toEspecialize2
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 toReduce2 = transform reduce "reduce2" o toEspecialize3
val toShake5 = transform shake "shake5" o toReduce2
val marshalcheck = {
func = (fn file => (MarshalCheck.check file; file)),
print = CorePrint.p_file CoreEnv.empty
}
val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake5
val effectize = {
func = Effective.effectize,
print = CorePrint.p_file CoreEnv.empty
}
val toEffectize = transform effectize "effectize" o toMarshalcheck
val css = {
func = Css.summarize,
print = fn _ => Print.box []
}
val toCss = transform css "css" o toShake5
val monoize = {
func = Monoize.monoize CoreEnv.empty,
print = MonoPrint.p_file MonoEnv.empty
}
val toMonoize = transform monoize "monoize" o toEffectize
val mono_opt = {
func = MonoOpt.optimize,
print = MonoPrint.p_file MonoEnv.empty
}
val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
val untangle = {
func = Untangle.untangle,
print = MonoPrint.p_file MonoEnv.empty
}
val toUntangle = transform untangle "untangle" o toMono_opt1
val mono_reduce = {
func = MonoReduce.reduce,
print = MonoPrint.p_file MonoEnv.empty
}
val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
val mono_shake = {
func = MonoShake.shake,
print = MonoPrint.p_file MonoEnv.empty
}
val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
val iflow = {
func = (fn file => (if !doIflow then Iflow.check file else (); file)),
print = MonoPrint.p_file MonoEnv.empty
}
val toIflow = transform iflow "iflow" o toMono_opt2
val namejs = {
func = NameJS.rewrite,
print = MonoPrint.p_file MonoEnv.empty
}
val toNamejs = transform namejs "namejs" o toIflow
val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs
val scriptcheck = {
func = ScriptCheck.classify,
print = MonoPrint.p_file MonoEnv.empty
}
val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle
val dbmodecheck = {
func = DbModeCheck.classify,
print = MonoPrint.p_file MonoEnv.empty
}
val toDbmodecheck = transform dbmodecheck "dbmodecheck" o toScriptcheck
val jscomp = {
func = JsComp.process,
print = MonoPrint.p_file MonoEnv.empty
}
val toJscomp = transform jscomp "jscomp" o toDbmodecheck
val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
val fuse = {
func = Fuse.fuse,
print = MonoPrint.p_file MonoEnv.empty
}
val toFuse = transform fuse "fuse" o toMono_opt3
val toUntangle2 = transform untangle "untangle2" o toFuse
val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2
val toMono_reduce3 = transform mono_reduce "mono_reduce3" o toMono_opt4
val toFuse2 = transform fuse "fuse2" o toMono_reduce3
val toUntangle3 = transform untangle "untangle3" o toFuse2
val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3
val pathcheck = {
func = (fn file => (PathCheck.check file; file)),
print = MonoPrint.p_file MonoEnv.empty
}
val toPathcheck = transform pathcheck "pathcheck" o toMono_shake3
val sidecheck = {
func = SideCheck.check,
print = MonoPrint.p_file MonoEnv.empty
}
val toSidecheck = transform sidecheck "sidecheck" o toPathcheck
val sigcheck = {
func = SigCheck.check,
print = MonoPrint.p_file MonoEnv.empty
}
val toSigcheck = transform sigcheck "sigcheck" o toSidecheck
val sqlcache = {
func = (fn file =>
if Settings.getSqlcache ()
then let val file = MonoInline.inlineFull file in Sqlcache.go file end
else file),
print = MonoPrint.p_file MonoEnv.empty
}
val toSqlcache = transform sqlcache "sqlcache" o toSigcheck
val cjrize = {
func = Cjrize.cjrize,
print = CjrPrint.p_file CjrEnv.empty
}
val toCjrize = transform cjrize "cjrize" o toSqlcache
val prepare = {
func = Prepare.prepare,
print = CjrPrint.p_file CjrEnv.empty
}
val toPrepare = transform prepare "prepare" o toCjrize
val checknest = {
func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f,
print = CjrPrint.p_file CjrEnv.empty
}
val toChecknest = transform checknest "checknest" o toPrepare
val sqlify = {
func = Cjrize.cjrize,
print = CjrPrint.p_sql CjrEnv.empty
}
val toSqlify = transform sqlify "sqlify" o toMono_opt2
fun escapeFilename s =
"\""
^ String.translate (fn #"\"" => "\\\"" | #"\\" => "\\\\" | ch => str ch) s
^ "\""
val beforeC = ref (fn () => ())
structure StringSet = BinarySetFn(struct
type ord_key = string
val compare = String.compare
end)
fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} =
let
val proto = Settings.currentProtocol ()
val lib = if Settings.getBootLinking () then
!Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a"
else if Settings.getStaticLinking () then
" -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a"
else
"-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb"
val opt = if debug then
""
else
" -O3"
val compile = (Settings.getCCompiler ()) ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " -Wimplicit -Werror -Wno-unused-value"
^ opt ^ " -I " ^ !Settings.configInclude
^ " " ^ #compile proto
^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname
fun concatArgs (a1, a2) =
if CharVector.all Char.isSpace a1 then
a2
else
a1 ^ " " ^ a2
val args = concatArgs (Config.ccArgs, Config.pthreadCflags)
val args = concatArgs (args, Config.pthreadLibs)
val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ args)
val ssl = if Settings.getStaticLinking () then
Config.openssl ^ " -ldl -lz"
else
Config.openssl
val link = linker
^ " " ^ escapeFilename oname ^ " " ^ lib ^ " -lm " ^ ssl ^ " " ^ libs ^ " -o " ^ escapeFilename ename
val (compile, link) =
if profile then
(compile ^ " -pg", link ^ " -pg")
else
(compile, link)
val (compile, link) =
if debug then
(compile ^ " -g", link ^ " -g")
else
(compile, link)
val link = #1 (foldl
(fn (s, (link, set)) =>
if StringSet.member (set, s) then
(link, set)
else
((link ^ " " ^ s), StringSet.add (set, s)))
(link, StringSet.empty)
link')
fun system s =
(if debug then
print (s ^ "\n")
else
();
OS.Process.isSuccess (OS.Process.system s))
in
!beforeC ();
system compile andalso system link
end
fun compile job =
case run toChecknest job of
NONE => false
| SOME file =>
let
val job = valOf (run (transform parseUrp "parseUrp") job)
val (cname, oname, cleanup) =
if #debug job then
("/tmp/webapp.c", "/tmp/webapp.o", fn () => ())
else
let
val dir = OS.FileSys.tmpName ()
val () = if OS.FileSys.access (dir, []) then
OS.FileSys.remove dir
else
()
val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"}
val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"}
in
OS.FileSys.mkDir dir;
(cname, oname,
fn () => (if OS.Process.isSuccess (OS.Process.system ("rm -rf " ^ dir)) then
()
else
raise Fail ("Unable to delete temporary directory " ^ dir)))
end
val ename = #exe job
in
let
val outf = TextIO.openOut cname
val s = TextIOPP.openOut {dst = outf, wid = 80}
val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
val libs =
if hasDb then
#link (Settings.currentDbms ())
else
""
in
Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
TextIO.output1 (outf, #"\n");
TextIO.closeOut outf;
if ErrorMsg.anyErrors () then
false
else
(case #sql job of
NONE => ()
| SOME sql =>
let
val outf = TextIO.openOut sql
val s = TextIOPP.openOut {dst = outf, wid = 80}
in
Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
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}
before cleanup ())
end
handle ex => (((cleanup ()) handle _ => ()); raise ex)
end
fun compiler job =
if compile job then
()
else
OS.Process.exit OS.Process.failure
fun moduleOf fname =
let
val mrs = !moduleRoots
val fname = OS.Path.mkCanonical fname
in
case List.find (fn (root, _) => String.isPrefix (root ^ "/") fname) mrs of
NONE => capitalize (OS.Path.base (OS.Path.file fname))
| SOME (root, name) =>
let
val fname = OS.Path.base fname
val fname = String.extract (fname, size root + 1, NONE)
val fs = String.fields (fn ch => ch = #"/") fname
val fs = List.filter (CharVector.exists (fn ch => not (Char.isDigit ch))) fs
val fs = map capitalize fs
in
String.concatWith "." (name :: fs)
end
end
end
urweb-20160213+dfsg/src/config.sig 0000664 0000000 0000000 00000000702 12657647235 0016575 0 ustar 00root root 0000000 0000000 signature CONFIG = sig
val builddir : string
val bin : string
val srclib : string
val lib : string
val includ : string
val sitelisp : string
val ccompiler : string
val ccArgs : string
val openssl : string
val pgheader : string
val msheader : string
val sqheader : string
val versionNumber : string
val versionString : string
val pthreadCflags : string
val pthreadLibs : string
end
urweb-20160213+dfsg/src/config.sml.in 0000664 0000000 0000000 00000001665 12657647235 0017224 0 ustar 00root root 0000000 0000000 structure Config :> CONFIG = struct
val builddir = "@abs_top_builddir@"
val bin = "@BIN@"
val srclib = "@SRCLIB@"
val lib = "@LIB@"
val includ = "@INCLUDE@"
val sitelisp = "@SITELISP@"
val ccompiler = "@CC@"
val ccArgs = "@CCARGS@"
val openssl = "@OPENSSL_LDFLAGS@ @OPENSSL_LIBS@"
(* Something is rotten in the state of Ubuntu 11.10, so here's a manual fix that I hope doesn't break other platforms. *)
val openssl =
let
val tokens = String.tokens Char.isSpace openssl
in
if List.exists (fn s => s = "-lssl") tokens then
String.concatWith " " (List.filter (fn s => s <> "-lssl") tokens @ ["-lssl"])
else
openssl
end
val pgheader = "@PGHEADER@"
val msheader = "@MSHEADER@"
val sqheader = "@SQHEADER@"
val versionNumber = "@VERSION@"
val versionString = "The Ur/Web compiler, version " ^ versionNumber
val pthreadCflags = "@PTHREAD_CFLAGS@"
val pthreadLibs = "@PTHREAD_LIBS@"
end
urweb-20160213+dfsg/src/coq/ 0000775 0000000 0000000 00000000000 12657647235 0015407 5 ustar 00root root 0000000 0000000 urweb-20160213+dfsg/src/coq/Axioms.v 0000664 0000000 0000000 00000003736 12657647235 0017047 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009, 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.
*)
Set Implicit Arguments.
Axiom ext_eq : forall dom ran (f g : forall x : dom, ran x),
(forall x, f x = g x)
-> f = g.
Theorem ext_eq_forall : forall dom (f g : forall x : dom, Type),
(forall x, f x = g x)
-> (forall x, f x) = (forall x, g x).
intros.
rewrite (ext_eq _ f g H); reflexivity.
Qed.
Theorem ext_eq_forallS : forall dom (f g : forall x : dom, Set),
(forall x, f x = g x)
-> (forall x, f x) = (forall x, g x).
intros.
rewrite (ext_eq _ f g H); reflexivity.
Qed.
urweb-20160213+dfsg/src/coq/Makefile 0000664 0000000 0000000 00000000433 12657647235 0017047 0 ustar 00root root 0000000 0000000 MODULES := Axioms Name Syntax Semantics
VS := $(MODULES:%=%.v)
.PHONY: coq clean
coq: Makefile.coq
make -f Makefile.coq
Makefile.coq: Makefile $(VS)
coq_makefile -impredicative-set $(VS) -o Makefile.coq
clean:: Makefile.coq
make -f Makefile.coq clean
rm -f Makefile.coq
urweb-20160213+dfsg/src/coq/Name.v 0000664 0000000 0000000 00000003160 12657647235 0016456 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009, 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.
*)
Require Import String.
Definition name := string.
Definition name_eq_dec : forall x y : name, {x = y} + {x <> y} := string_dec.
urweb-20160213+dfsg/src/coq/README 0000664 0000000 0000000 00000000206 12657647235 0016265 0 ustar 00root root 0000000 0000000 This is a Coq formalization of a simplified version of the Ur programming language.
It has only been tested with Coq version 8.3pl2.
urweb-20160213+dfsg/src/coq/Semantics.v 0000664 0000000 0000000 00000020651 12657647235 0017530 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009, 2011, 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.
*)
Require Import Eqdep_dec.
Require Import Axioms.
Require Import Syntax.
Set Implicit Arguments.
Definition row (A : Type) : Type := name -> option A.
Definition record (r : row Set) := forall n, match r n with
| None => unit
| Some T => T
end.
Fixpoint kDen (k : kind) : Type :=
match k with
| KType => Set
| KName => name
| KArrow k1 k2 => kDen k1 -> kDen k2
| KRecord k1 => row (kDen k1)
end.
Definition disjoint T (r1 r2 : row T) :=
forall n, match r1 n, r2 n with
| Some _, Some _ => False
| _, _ => True
end.
Fixpoint cDen k (c : con kDen k) : kDen k :=
match c with
| CVar _ x => x
| Arrow c1 c2 => cDen c1 -> cDen c2
| Poly _ c1 => forall x, cDen (c1 x)
| CAbs _ _ c1 => fun x => cDen (c1 x)
| CApp _ _ c1 c2 => (cDen c1) (cDen c2)
| Name n => n
| TRecord c1 => record (cDen c1)
| CEmpty _ => fun _ => None
| CSingle _ c1 c2 => fun n => if name_eq_dec n (cDen c1) then Some (cDen c2) else None
| CConcat _ c1 c2 => fun n => match (cDen c1) n with
| None => (cDen c2) n
| v => v
end
| CMap k1 k2 => fun f r n => match r n with
| None => None
| Some T => Some (f T)
end
| TGuarded _ c1 c2 t => disjoint (cDen c1) (cDen c2) -> cDen t
end.
Theorem subs_correct : forall k1 (c1 : con kDen k1) k2 (c2 : _ -> con kDen k2) c2',
subs c1 c2 c2'
-> cDen (c2 (cDen c1)) = cDen c2'.
induction 1; simpl; intuition; try (apply ext_eq_forallS || apply ext_eq);
repeat match goal with
| [ H : _ |- _ ] => rewrite H
end; intuition.
Qed.
Definition dvar k (c1 c2 : con kDen (KRecord k)) :=
disjoint (cDen c1) (cDen c2).
Scheme deq_mut := Minimality for deq Sort Prop
with disj_mut := Minimality for disj Sort Prop.
Ltac deq_disj_correct scm :=
let t := repeat progress (simpl; intuition; subst) in
let rec use_disjoint' notDone E :=
match goal with
| [ H : disjoint _ _ |- _ ] =>
notDone H; generalize (H E); use_disjoint'
ltac:(fun H' =>
match H' with
| H => fail 1
| _ => notDone H'
end) E
| _ => idtac
end in
let use_disjoint := use_disjoint' ltac:(fun _ => idtac) in
apply (scm _ dvar
(fun k (c1 c2 : con kDen k) =>
cDen c1 = cDen c2)
(fun k (c1 c2 : con kDen (KRecord k)) =>
disjoint (cDen c1) (cDen c2))); t;
repeat ((unfold row; apply ext_eq)
|| (match goal with
| [ H : _ |- _ ] => rewrite H; []
| [ H : subs _ _ _ |- _ ] => rewrite <- (subs_correct H)
end); t);
unfold disjoint; t;
repeat (match goal with
| [ |- context[match cDen ?C ?E with Some _ => _ | None => _ end] ] =>
use_disjoint E; destruct (cDen C E)
| [ |- context[if name_eq_dec ?N1 ?N2 then _ else _] ] =>
use_disjoint N1; use_disjoint N2; destruct (name_eq_dec N1 N2)
| [ _ : context[match cDen ?C ?E with Some _ => _ | None => _ end] |- _ ] =>
use_disjoint E; destruct (cDen C E)
| [ |- context[if ?E then _ else _] ] => destruct E
end; t).
Hint Unfold dvar.
Theorem deq_correct : forall k (c1 c2 : con kDen k),
deq dvar c1 c2
-> cDen c1 = cDen c2.
deq_disj_correct deq_mut.
Qed.
Theorem disj_correct : forall k (c1 c2 : con kDen (KRecord k)),
disj dvar c1 c2
-> disjoint (cDen c1) (cDen c2).
deq_disj_correct disj_mut.
Qed.
Definition tDen (t : con kDen KType) : Set := cDen t.
Theorem name_eq_dec_refl : forall n, name_eq_dec n n = left _ (refl_equal n).
intros; destruct (name_eq_dec n n); intuition; [
match goal with
| [ e : _ = _ |- _ ] => rewrite (UIP_dec name_eq_dec e (refl_equal _)); reflexivity
end
| elimtype False; tauto
].
Qed.
Theorem cut_disjoint : forall n1 v r,
disjoint (fun n => if name_eq_dec n n1 then Some v else None) r
-> unit = match r n1 with
| Some T => T
| None => unit
end.
intros;
match goal with
| [ H : disjoint _ _ |- _ ] => generalize (H n1)
end; rewrite name_eq_dec_refl;
destruct (r n1); intuition.
Qed.
Implicit Arguments cut_disjoint [v r].
Fixpoint eDen t (e : exp dvar tDen t) : tDen t :=
match e in exp _ _ t return tDen t with
| Var _ x => x
| App _ _ e1 e2 => (eDen e1) (eDen e2)
| Abs _ _ e1 => fun x => eDen (e1 x)
| ECApp _ c _ _ e1 Hsub => match subs_correct Hsub in _ = T return T with
| refl_equal => (eDen e1) (cDen c)
end
| ECAbs _ _ e1 => fun X => eDen (e1 X)
| Cast _ _ Heq e1 => match deq_correct Heq in _ = T return T with
| refl_equal => eDen e1
end
| Empty => fun _ => tt
| Single c c' e1 => fun n => if name_eq_dec n (cDen c) as B
return (match (match (if B then _ else _) with Some _ => _ | None => _ end)
with Some _ => _ | None => unit end)
then eDen e1 else tt
| Proj c _ _ e1 =>
match name_eq_dec_refl (cDen c) in _ = B
return (match (match (if B then _ else _) with
| Some _ => _
| None => _ end)
return Set
with Some _ => _ | None => _ end) with
| refl_equal => (eDen e1) (cDen c)
end
| Cut c _ c' Hdisj e1 => fun n =>
match name_eq_dec n (cDen c) as B return (match (match (if B then Some _ else None) with Some _ => _ | None => (cDen c') n end)
with Some T => T | None => unit end
-> match (cDen c') n with
| None => unit
| Some T => T
end) with
| left Heq => fun _ =>
match sym_eq Heq in _ = n' return match cDen c' n' return Set with Some _ => _ | None => _ end with
| refl_equal =>
match cut_disjoint _ (disj_correct Hdisj) in _ = T return T with
| refl_equal => tt
end
end
| right _ => fun x => x
end ((eDen e1) n)
| Concat c1 c2 e1 e2 => fun n =>
match (cDen c1) n as D return match D with
| None => unit
| Some T => T
end
-> match (match D with
| None => (cDen c2) n
| Some v => Some v
end) with
| None => unit
| Some T => T
end with
| None => fun _ => (eDen e2) n
| _ => fun x => x
end ((eDen e1) n)
| Guarded _ _ _ _ e1 => fun pf => eDen (e1 pf)
| GuardedApp _ _ _ _ e1 Hdisj => (eDen e1) (disj_correct Hdisj)
end.
urweb-20160213+dfsg/src/coq/Syntax.v 0000664 0000000 0000000 00000016754 12657647235 0017101 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009, 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.
*)
Require Import Name.
Export Name.
Set Implicit Arguments.
(** Syntax of Featherweight Ur *)
Inductive kind : Type :=
| KType : kind
| KName : kind
| KArrow : kind -> kind -> kind
| KRecord : kind -> kind.
Section vars.
Variable cvar : kind -> Type.
Inductive con : kind -> Type :=
| CVar : forall k, cvar k -> con k
| Arrow : con KType -> con KType -> con KType
| Poly : forall k, (cvar k -> con KType) -> con KType
| CAbs : forall k1 k2, (cvar k1 -> con k2) -> con (KArrow k1 k2)
| CApp : forall k1 k2, con (KArrow k1 k2) -> con k1 -> con k2
| Name : name -> con KName
| TRecord : con (KRecord KType) -> con KType
| CEmpty : forall k, con (KRecord k)
| CSingle : forall k, con KName -> con k -> con (KRecord k)
| CConcat : forall k, con (KRecord k) -> con (KRecord k) -> con (KRecord k)
| CMap : forall k1 k2, con (KArrow (KArrow k1 k2) (KArrow (KRecord k1) (KRecord k2)))
| TGuarded : forall k, con (KRecord k) -> con (KRecord k) -> con KType -> con KType.
Variable dvar : forall k, con (KRecord k) -> con (KRecord k) -> Type.
Section subs.
Variable k1 : kind.
Variable c1 : con k1.
Inductive subs : forall k2, (cvar k1 -> con k2) -> con k2 -> Type :=
| S_Unchanged : forall k2 (c2 : con k2),
subs (fun _ => c2) c2
| S_CVar : subs (fun x => CVar x) c1
| S_Arrow : forall c2 c3 c2' c3',
subs c2 c2'
-> subs c3 c3'
-> subs (fun x => Arrow (c2 x) (c3 x)) (Arrow c2' c3')
| S_Poly : forall k (c2 : cvar k1 -> cvar k -> _) (c2' : cvar k -> _),
(forall x', subs (fun x => c2 x x') (c2' x'))
-> subs (fun x => Poly (c2 x)) (Poly c2')
| S_CAbs : forall k2 k3 (c2 : cvar k1 -> cvar k2 -> con k3) (c2' : cvar k2 -> _),
(forall x', subs (fun x => c2 x x') (c2' x'))
-> subs (fun x => CAbs (c2 x)) (CAbs c2')
| S_CApp : forall k1 k2 (c2 : _ -> con (KArrow k1 k2)) c3 c2' c3',
subs c2 c2'
-> subs c3 c3'
-> subs (fun x => CApp (c2 x) (c3 x)) (CApp c2' c3')
| S_TRecord : forall c2 c2',
subs c2 c2'
-> subs (fun x => TRecord (c2 x)) (TRecord c2')
| S_CSingle : forall k2 c2 (c3 : _ -> con k2) c2' c3',
subs c2 c2'
-> subs c3 c3'
-> subs (fun x => CSingle (c2 x) (c3 x)) (CSingle c2' c3')
| S_CConcat : forall k2 (c2 c3 : _ -> con (KRecord k2)) c2' c3',
subs c2 c2'
-> subs c3 c3'
-> subs (fun x => CConcat (c2 x) (c3 x)) (CConcat c2' c3')
| S_TGuarded : forall k2 (c2 c3 : _ -> con (KRecord k2)) c4 c2' c3' c4',
subs c2 c2'
-> subs c3 c3'
-> subs c4 c4'
-> subs (fun x => TGuarded (c2 x) (c3 x) (c4 x)) (TGuarded c2' c3' c4').
End subs.
Inductive disj : forall k, con (KRecord k) -> con (KRecord k) -> Prop :=
| DVar : forall k (c1 c2 : con (KRecord k)),
dvar c1 c2 -> disj c1 c2
| DComm : forall k (c1 c2 : con (KRecord k)),
disj c1 c2 -> disj c2 c1
| DEmpty : forall k c2,
disj (CEmpty k) c2
| DSingleKeys : forall k X1 X2 (c1 c2 : con k),
X1 <> X2
-> disj (CSingle (Name X1) c1) (CSingle (Name X2) c2)
| DSingleValues : forall k n1 n2 (c1 c2 : con k) k' (c1' c2' : con k'),
disj (CSingle n1 c1') (CSingle n2 c2')
-> disj (CSingle n1 c1) (CSingle n2 c2)
| DConcat : forall k (c1 c2 c : con (KRecord k)),
disj c1 c
-> disj c2 c
-> disj (CConcat c1 c2) c
| DEq : forall k (c1 c2 c1' : con (KRecord k)),
disj c1 c2
-> deq c1' c1
-> disj c1' c2
with deq : forall k, con k -> con k -> Prop :=
| Eq_Beta : forall k1 k2 (c1 : cvar k1 -> con k2) c2 c1',
subs c2 c1 c1'
-> deq (CApp (CAbs c1) c2) c1'
| Eq_Refl : forall k (c : con k),
deq c c
| Eq_Comm : forall k (c1 c2 : con k),
deq c2 c1
-> deq c1 c2
| Eq_Trans : forall k (c1 c2 c3 : con k),
deq c1 c2
-> deq c2 c3
-> deq c1 c3
| Eq_Cong : forall k1 k2 c1 c1' (c2 : cvar k1 -> con k2) c2' c2'',
deq c1 c1'
-> subs c1 c2 c2'
-> subs c1' c2 c2''
-> deq c2' c2''
| Eq_Concat_Empty : forall k c,
deq (CConcat (CEmpty k) c) c
| Eq_Concat_Comm : forall k (c1 c2 c3 : con (KRecord k)),
disj c1 c2
-> deq (CConcat c1 c2) (CConcat c2 c1)
| Eq_Concat_Assoc : forall k (c1 c2 c3 : con (KRecord k)),
deq (CConcat c1 (CConcat c2 c3)) (CConcat (CConcat c1 c2) c3)
| Eq_Map_Empty : forall k1 k2 f,
deq (CApp (CApp (CMap k1 k2) f) (CEmpty _)) (CEmpty _)
| Eq_Map_Cons : forall k1 k2 f c1 c2 c3,
disj (CSingle c1 c2) c3
-> deq (CApp (CApp (CMap k1 k2) f) (CConcat (CSingle c1 c2) c3))
(CConcat (CSingle c1 (CApp f c2)) (CApp (CApp (CMap k1 k2) f) c3))
| Eq_Map_Ident : forall k c,
deq (CApp (CApp (CMap k k) (CAbs (fun x => CVar x))) c) c
| Eq_Map_Dist : forall k1 k2 f c1 c2,
deq (CApp (CApp (CMap k1 k2) f) (CConcat c1 c2))
(CConcat (CApp (CApp (CMap k1 k2) f) c1) (CApp (CApp (CMap k1 k2) f) c2))
| Eq_Map_Fuse : forall k1 k2 k3 f f' c,
deq (CApp (CApp (CMap k2 k3) f')
(CApp (CApp (CMap k1 k2) f) c))
(CApp (CApp (CMap k1 k3) (CAbs (fun x => CApp f' (CApp f (CVar x))))) c).
Variable evar : con KType -> Type.
Inductive exp : con KType -> Type :=
| Var : forall t, evar t -> exp t
| App : forall dom ran, exp (Arrow dom ran) -> exp dom -> exp ran
| Abs : forall dom ran, (evar dom -> exp ran) -> exp (Arrow dom ran)
| ECApp : forall k (dom : con k) ran ran', exp (Poly ran) -> subs dom ran ran' -> exp ran'
| ECAbs : forall k (ran : cvar k -> _), (forall X, exp (ran X)) -> exp (Poly ran)
| Cast : forall t1 t2, deq t1 t2 -> exp t1 -> exp t2
| Empty : exp (TRecord (CEmpty _))
| Single : forall c t, exp t -> exp (TRecord (CConcat (CSingle c t) (CEmpty _)))
| Proj : forall c t c', exp (TRecord (CConcat (CSingle c t) c')) -> exp t
| Cut : forall c t c', disj (CSingle c t) c' -> exp (TRecord (CConcat (CSingle c t) c')) -> exp (TRecord c')
| Concat : forall c1 c2, exp (TRecord c1) -> exp (TRecord c2) -> exp (TRecord (CConcat c1 c2))
| Guarded : forall k (c1 c2 : con (KRecord k)) c, (dvar c1 c2 -> exp c) -> exp (TGuarded c1 c2 c)
| GuardedApp : forall k (c1 c2 : con (KRecord k)) t, exp (TGuarded c1 c2 t) -> disj c1 c2 -> exp t.
End vars.
urweb-20160213+dfsg/src/core.sml 0000664 0000000 0000000 00000011121 12657647235 0016266 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 2013, 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 Core = struct
type 'a located = 'a ErrorMsg.located
datatype kind' =
KType
| KArrow of kind * kind
| KName
| KRecord of kind
| KUnit
| KTuple of kind list
| KRel of int
| KFun of string * kind
withtype kind = kind' located
datatype con' =
TFun of con * con
| TCFun of string * kind * con
| TRecord of con
| CRel of int
| CNamed of int
| CFfi of string * string
| CApp of con * con
| CAbs of string * kind * con
| CKAbs of string * con
| CKApp of con * kind
| TKFun of string * con
| CName of string
| CRecord of kind * (con * con) list
| CConcat of con * con
| CMap of kind * kind
| CUnit
| CTuple of con list
| CProj of con * int
withtype con = con' located
datatype datatype_kind = datatype DatatypeKind.datatype_kind
datatype patCon =
PConVar of int
| PConFfi of {mod : string, datatyp : string, params : string list,
con : string, arg : con option, kind : datatype_kind}
datatype pat' =
PVar of string * con
| PPrim of Prim.t
| PCon of datatype_kind * patCon * con list * pat option
| PRecord of (string * pat * con) list
withtype pat = pat' located
datatype failure_mode = datatype Settings.failure_mode
datatype exp' =
EPrim of Prim.t
| ERel of int
| ENamed of int
| ECon of datatype_kind * patCon * con list * exp option
| EFfi of string * string
| EFfiApp of string * string * (exp * con) list
| EApp of exp * exp
| EAbs of string * con * con * exp
| ECApp of exp * con
| ECAbs of string * kind * exp
| EKAbs of string * exp
| EKApp of exp * kind
| ERecord of (con * exp * con) list
| EField of exp * con * { field : con, rest : con }
| EConcat of exp * con * exp * con
| ECut of exp * con * { field : con, rest : con }
| ECutMulti of exp * con * { rest : con }
| ECase of exp * (pat * exp) list * { disc : con, result : con }
| EWrite of exp
| EClosure of int * exp list
| ELet of string * con * exp * exp
| EServerCall of int * exp list * con * failure_mode
withtype exp = exp' located
datatype effect = datatype Export.effect
datatype export_kind = datatype Export.export_kind
datatype decl' =
DCon of string * int * kind * con
| DDatatype of (string * int * string list * (string * int * con option) list) list
| DVal of string * int * con * exp * string
| DValRec of (string * int * con * exp * string) list
| DExport of export_kind * int * bool
| DTable of string * int * con * string * exp * con * exp * con
| DSequence of string * int * string
| DView of string * int * string * exp * con
| DDatabase of string
| DCookie of string * int * con * string
| DStyle of string * int * string
| DTask of exp * exp
| DPolicy of exp
| DOnError of int
withtype decl = decl' located
type file = decl list
end
urweb-20160213+dfsg/src/core_env.sig 0000664 0000000 0000000 00000006114 12657647235 0017133 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 CORE_ENV = sig
val liftConInCon : int -> Core.con -> Core.con
val subConInCon : (int * Core.con) -> Core.con -> Core.con
val liftConInExp : int -> Core.exp -> Core.exp
val subConInExp : (int * Core.con) -> Core.exp -> Core.exp
val liftExpInExp : int -> Core.exp -> Core.exp
val subExpInExp : (int * Core.exp) -> Core.exp -> Core.exp
type env
val empty : env
exception UnboundRel of int
exception UnboundNamed of int
val pushKRel : env -> string -> env
val lookupKRel : env -> int -> string
val pushCRel : env -> string -> Core.kind -> env
val lookupCRel : env -> int -> string * Core.kind
val pushCNamed : env -> string -> int -> Core.kind -> Core.con option -> env
val lookupCNamed : env -> int -> string * Core.kind * Core.con option
val pushDatatype : env -> string -> int -> string list -> (string * int * Core.con option) list -> env
val lookupDatatype : env -> int -> string * string list * (string * int * Core.con option) list
val lookupConstructor : env -> int -> string * string list * Core.con option * int
val pushERel : env -> string -> Core.con -> env
val lookupERel : env -> int -> string * Core.con
val pushENamed : env -> string -> int -> Core.con -> Core.exp option -> string -> env
val lookupENamed : env -> int -> string * Core.con * Core.exp option * string
val declBinds : env -> Core.decl -> env
val patBinds : env -> Core.pat -> env
val patBindsN : Core.pat -> int
val patBindsL : Core.pat -> (string * Core.con) list
end
urweb-20160213+dfsg/src/core_env.sml 0000664 0000000 0000000 00000031777 12657647235 0017161 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 CoreEnv :> CORE_ENV = struct
open Core
structure U = CoreUtil
structure IM = IntBinaryMap
(* AST utility functions *)
val liftKindInKind =
U.Kind.mapB {kind = fn bound => fn k =>
case k of
KRel xn =>
if xn < bound then
k
else
KRel (xn + 1)
| _ => k,
bind = fn (bound, _) => bound + 1}
val liftKindInCon =
U.Con.mapB {kind = fn bound => fn k =>
case k of
KRel xn =>
if xn < bound then
k
else
KRel (xn + 1)
| _ => k,
con = fn _ => fn c => c,
bind = fn (bound, U.Con.RelK _) => bound + 1
| (bound, _) => bound}
val liftKindInExp =
U.Exp.mapB {kind = fn bound => fn k =>
case k of
KRel xn =>
if xn < bound then
k
else
KRel (xn + 1)
| _ => k,
con = fn _ => fn c => c,
exp = fn _ => fn e => e,
bind = fn (bound, U.Exp.RelK _) => bound + 1
| (bound, _) => bound}
val liftConInCon =
U.Con.mapB {kind = fn _ => fn k => k,
con = fn bound => fn c =>
case c of
CRel xn =>
if xn < bound then
c
else
CRel (xn + 1)
| _ => c,
bind = fn (bound, U.Con.RelC _) => bound + 1
| (bound, _) => bound}
val lift = liftConInCon 0
val subConInCon =
U.Con.mapB {kind = fn _ => fn k => k,
con = fn (xn, rep) => fn c =>
case c of
CRel xn' =>
(case Int.compare (xn', xn) of
EQUAL => #1 rep
| GREATER => CRel (xn' - 1)
| LESS => c)
| _ => c,
bind = fn ((xn, rep), U.Con.RelC _) => (xn+1, liftConInCon 0 rep)
| (ctx, _) => ctx}
val liftConInExp =
U.Exp.mapB {kind = fn _ => fn k => k,
con = fn bound => fn c =>
case c of
CRel xn =>
if xn < bound then
c
else
CRel (xn + 1)
| _ => c,
exp = fn _ => fn e => e,
bind = fn (bound, U.Exp.RelC _) => bound + 1
| (bound, _) => bound}
val subConInExp =
U.Exp.mapB {kind = fn _ => fn k => k,
con = fn (xn, rep) => fn c =>
case c of
CRel xn' =>
(case Int.compare (xn', xn) of
EQUAL => #1 rep
| GREATER => CRel (xn' - 1)
| LESS => c)
| _ => c,
exp = fn _ => fn e => e,
bind = fn ((xn, rep), U.Exp.RelC _) => (xn+1, liftConInCon 0 rep)
| (ctx, _) => ctx}
val liftExpInExp =
U.Exp.mapB {kind = fn _ => fn k => k,
con = fn _ => fn c => c,
exp = fn bound => fn e =>
case e of
ERel xn =>
if xn < bound then
e
else
ERel (xn + 1)
| _ => e,
bind = fn (bound, U.Exp.RelE _) => bound + 1
| (bound, _) => bound}
val subExpInExp =
U.Exp.mapB {kind = fn _ => fn k => k,
con = fn _ => fn c => c,
exp = fn (xn, rep) => fn e =>
case e of
ERel xn' =>
(case Int.compare (xn', xn) of
EQUAL => #1 rep
| GREATER=> ERel (xn' - 1)
| LESS => e)
| _ => e,
bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
| ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep)
| (ctx, _) => ctx}
(* Back to environments *)
exception UnboundRel of int
exception UnboundNamed of int
type env = {
relK : string list,
relC : (string * kind) list,
namedC : (string * kind * con option) IM.map,
datatypes : (string * string list * (string * int * con option) list) IM.map,
constructors : (string * string list * con option * int) IM.map,
relE : (string * con) list,
namedE : (string * con * exp option * string) IM.map
}
val empty = {
relK = [],
relC = [],
namedC = IM.empty,
datatypes = IM.empty,
constructors = IM.empty,
relE = [],
namedE = IM.empty
}
fun pushKRel (env : env) x =
{relK = x :: #relK env,
relC = map (fn (x, k) => (x, liftKindInKind 0 k)) (#relC env),
namedC = #namedC env,
relE = map (fn (x, c) => (x, liftKindInCon 0 c)) (#relE env),
namedE = #namedE env,
datatypes = #datatypes env,
constructors = #constructors env
}
fun lookupKRel (env : env) n =
(List.nth (#relK env, n))
handle Subscript => raise UnboundRel n
fun pushCRel (env : env) x k =
{relK = #relK env,
relC = (x, k) :: #relC env,
namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env),
datatypes = #datatypes env,
constructors = #constructors env,
relE = map (fn (x, c) => (x, lift c)) (#relE env),
namedE = IM.map (fn (x, c, eo, s) => (x, lift c, eo, s)) (#namedE env)}
fun lookupCRel (env : env) n =
(List.nth (#relC env, n))
handle Subscript => raise UnboundRel n
fun pushCNamed (env : env) x n k co =
{relK = #relK env,
relC = #relC env,
namedC = IM.insert (#namedC env, n, (x, k, co)),
datatypes = #datatypes env,
constructors = #constructors env,
relE = #relE env,
namedE = #namedE env}
fun lookupCNamed (env : env) n =
case IM.find (#namedC env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun pushDatatype (env : env) x n xs xncs =
{relK = #relK env,
relC = #relC env,
namedC = #namedC env,
datatypes = IM.insert (#datatypes env, n, (x, xs, xncs)),
constructors = foldl (fn ((x, n', to), constructors) =>
IM.insert (constructors, n', (x, xs, to, n)))
(#constructors env) xncs,
relE = #relE env,
namedE = #namedE env}
fun lookupDatatype (env : env) n =
case IM.find (#datatypes env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun lookupConstructor (env : env) n =
case IM.find (#constructors env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun pushERel (env : env) x t =
{relK = #relK env,
relC = #relC env,
namedC = #namedC env,
datatypes = #datatypes env,
constructors = #constructors env,
relE = (x, t) :: #relE env,
namedE = #namedE env}
fun lookupERel (env : env) n =
(List.nth (#relE env, n))
handle Subscript => raise UnboundRel n
fun pushENamed (env : env) x n t eo s =
{relK = #relK env,
relC = #relC env,
namedC = #namedC env,
datatypes = #datatypes env,
constructors = #constructors env,
relE = #relE env,
namedE = IM.insert (#namedE env, n, (x, t, eo, s))}
fun lookupENamed (env : env) n =
case IM.find (#namedE env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun declBinds env (d, loc) =
case d of
DCon (x, n, k, c) => pushCNamed env x n k (SOME c)
| DDatatype dts =>
foldl (fn ((x, n, xs, xncs), env) =>
let
val env = pushDatatype env x n xs xncs
val env = pushCNamed env x n (KType, loc) NONE
in
foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (CNamed n, loc) NONE ""
| ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (CNamed n, loc)), loc) NONE "")
env xncs
end) env dts
| DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
| DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
| DExport _ => env
| DTable (x, n, c, s, _, pc, _, cc) =>
let
val ct = (CFfi ("Basis", "sql_table"), loc)
val ct = (CApp (ct, c), loc)
val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc)
in
pushENamed env x n ct NONE s
end
| DSequence (x, n, s) =>
let
val t = (CFfi ("Basis", "sql_sequence"), loc)
in
pushENamed env x n t NONE s
end
| DView (x, n, s, _, c) =>
let
val ct = (CFfi ("Basis", "sql_view"), loc)
val ct = (CApp (ct, c), loc)
in
pushENamed env x n ct NONE s
end
| DDatabase _ => env
| DCookie (x, n, c, s) =>
let
val t = (CApp ((CFfi ("Basis", "http_cookie"), loc), c), loc)
in
pushENamed env x n t NONE s
end
| DStyle (x, n, s) =>
let
val t = (CFfi ("Basis", "css_class"), loc)
in
pushENamed env x n t NONE s
end
| DTask _ => env
| DPolicy _ => env
| DOnError _ => env
fun patBinds env (p, loc) =
case p of
PVar (x, t) => pushERel env x t
| PPrim _ => env
| PCon (_, _, _, NONE) => env
| PCon (_, _, _, SOME p) => patBinds env p
| PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps
fun patBindsN (p, loc) =
case p of
PVar _ => 1
| PPrim _ => 0
| PCon (_, _, _, NONE) => 0
| PCon (_, _, _, SOME p) => patBindsN p
| PRecord xps => foldl (fn ((_, p, _), count) => count + patBindsN p) 0 xps
fun patBindsL (p, loc) =
case p of
PVar (x, t) => [(x, t)]
| PPrim _ => []
| PCon (_, _, _, NONE) => []
| PCon (_, _, _, SOME p) => patBindsL p
| PRecord xps => rev (ListUtil.mapConcat (rev o patBindsL o #2) xps)
end
urweb-20160213+dfsg/src/core_print.sig 0000664 0000000 0000000 00000003737 12657647235 0017507 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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.
*)
(* Pretty-printing Ur/Web internal language *)
signature CORE_PRINT = sig
val p_kind : CoreEnv.env -> Core.kind Print.printer
val p_con : CoreEnv.env -> Core.con Print.printer
val p_patCon : CoreEnv.env -> Core.patCon Print.printer
val p_pat : CoreEnv.env -> Core.pat Print.printer
val p_exp : CoreEnv.env -> Core.exp Print.printer
val p_decl : CoreEnv.env -> Core.decl Print.printer
val p_file : CoreEnv.env -> Core.file Print.printer
val debug : bool ref
end
urweb-20160213+dfsg/src/core_print.sml 0000664 0000000 0000000 00000065222 12657647235 0017515 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2011, 2013, 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.
*)
(* Pretty-printing core Ur/Web *)
structure CorePrint :> CORE_PRINT = struct
open Print.PD
open Print
open Core
structure E = CoreEnv
val debug = ref false
fun p_kind' par env (k, _) =
case k of
KType => string "Type"
| KArrow (k1, k2) => parenIf par (box [p_kind' true env k1,
space,
string "->",
space,
p_kind env k2])
| KName => string "Name"
| KRecord k => box [string "{", p_kind env k, string "}"]
| KUnit => string "Unit"
| KTuple ks => box [string "(",
p_list_sep (box [space, string "*", space]) (p_kind env) ks,
string ")"]
| KRel n => ((if !debug then
string (E.lookupKRel env n ^ "_" ^ Int.toString n)
else
string (E.lookupKRel env n))
handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
| KFun (x, k) => box [string x,
space,
string "-->",
space,
p_kind (E.pushKRel env x) k]
and p_kind env = p_kind' false env
fun p_con' par env (c, _) =
case c of
TFun (t1, t2) => parenIf par (box [p_con' true env t1,
space,
string "->",
space,
p_con env t2])
| TCFun (x, k, c) => parenIf par (box [string x,
space,
string "::",
space,
p_kind env k,
space,
string "->",
space,
p_con (E.pushCRel env x k) c])
| TRecord (CRecord (_, xcs), _) => box [string "{",
p_list (fn (x, c) =>
box [p_name env x,
space,
string ":",
space,
p_con env c]) xcs,
string "}"]
| TRecord c => box [string "$",
p_con' true env c]
| CRel n =>
((if !debug then
string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
else
string (#1 (E.lookupCRel env n)))
handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
| CNamed n =>
((if !debug then
string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupCNamed env n)))
handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n))
| CFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
| CApp (c1, c2) => parenIf par (box [p_con env c1,
space,
p_con' true env c2])
| CAbs (x, k, c) => parenIf par (box [string "fn",
space,
string x,
space,
string "::",
space,
p_kind env k,
space,
string "=>",
space,
p_con (E.pushCRel env x k) c])
| CName s => box [string "#", string s]
| CRecord (k, xcs) =>
if !debug then
parenIf par (box [string "[",
p_list (fn (x, c) =>
box [p_con env x,
space,
string "=",
space,
p_con env c]) xcs,
string "]::",
p_kind env k])
else
parenIf par (box [string "[",
p_list (fn (x, c) =>
box [p_con env x,
space,
string "=",
space,
p_con env c]) xcs,
string "]"])
| CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
space,
string "++",
space,
p_con env c2])
| CMap _ => string "map"
| CUnit => string "()"
| CTuple cs => box [string "(",
p_list (p_con env) cs,
string ")"]
| CProj (c, n) => box [p_con env c,
string ".",
string (Int.toString n)]
| CKAbs (x, c) => box [string x,
space,
string "==>",
space,
p_con (E.pushKRel env x) c]
| CKApp (c, k) => box [p_con env c,
string "[[",
p_kind env k,
string "]]"]
| TKFun (x, c) => box [string x,
space,
string "-->",
space,
p_con (E.pushKRel env x) c]
and p_con env = p_con' false env
and p_name env (all as (c, _)) =
case c of
CName s => string s
| _ => p_con env all
fun p_enamed env n =
(if !debug then
string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupENamed env n)))
handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
fun p_con_named env n =
(if !debug then
string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupConstructor env n)))
handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n)
fun p_patCon env pc =
case pc of
PConVar n => p_con_named env n
| PConFfi {mod = m, con, arg, params, ...} =>
if !debug then
box [string "FFIC[",
case arg of
NONE => box []
| SOME t =>
let
val k = (KType, ErrorMsg.dummySpan)
val env' = foldl (fn (x, env) => E.pushCRel env x k) env params
in
p_con env' t
end,
string "](",
string m,
string ".",
string con,
string ")"]
else
box [string "FFIC(",
string m,
string ".",
string con,
string ")"]
fun p_pat' par env (p, _) =
case p of
PVar (s, _) => string s
| PPrim p => Prim.p_t p
| PCon (_, n, _, NONE) => p_patCon env n
| PCon (_, n, _, SOME p) => parenIf par (box [p_patCon env n,
space,
p_pat' true env p])
| PRecord xps =>
box [string "{",
p_list_sep (box [string ",", space]) (fn (x, p, t) =>
box [string x,
space,
string "=",
space,
p_pat env p,
if !debug then
box [space,
string ":",
space,
p_con env t]
else
box []]) xps,
string "}"]
and p_pat x = p_pat' false x
fun p_exp' par env (e, _) =
case e of
EPrim p => Prim.p_t p
| ERel n =>
((if !debug then
string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
else
string (#1 (E.lookupERel env n)))
handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
| ENamed n => p_enamed env n
| ECon (_, pc, ts, NONE) => box [string "[",
p_patCon env pc,
p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
string "]"]
| ECon (_, pc, ts, SOME e) => box [string "[",
p_patCon env pc,
space,
p_exp' true env e,
p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
string "]"]
| EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
| EFfiApp (m, x, es) => box [string "FFI(",
string m,
string ".",
string x,
string "(",
p_list (p_exp env o #1) es,
string "))"]
| EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
space,
p_exp' true env e2])
| EAbs (x, t, _, e) => parenIf par (box [string "(fn",
space,
string x,
space,
string ":",
space,
p_con env t,
space,
string "=>",
space,
p_exp (E.pushERel env x t) e,
string ")"])
| ECApp (e, c) => parenIf par (box [p_exp env e,
space,
string "[",
p_con env c,
string "]"])
| ECAbs (x, k, e) => parenIf par (box [string "fn",
space,
string x,
space,
string "::",
space,
p_kind env k,
space,
string "=>",
space,
p_exp (E.pushCRel env x k) e])
| ERecord xes => box [string "{",
p_list (fn (x, e, _) =>
box [p_name env x,
space,
string "=",
space,
p_exp env e]) xes,
string "}"]
| EField (e, c, {field, rest}) =>
if !debug then
box [p_exp' true env e,
string ".",
p_con' true env c,
space,
string "[",
p_con env field,
space,
string " in ",
space,
p_con env rest,
string "]"]
else
box [p_exp' true env e,
string ".",
p_con' true env c]
| EConcat (e1, c1, e2, c2) =>
parenIf par (if !debug then
box [p_exp' true env e1,
space,
string ":",
space,
p_con env c1,
space,
string "++",
space,
p_exp' true env e2,
space,
string ":",
space,
p_con env c2]
else
box [p_exp' true env e1,
space,
string "with",
space,
p_exp' true env e2])
| ECut (e, c, {field, rest}) =>
parenIf par (if !debug then
box [p_exp' true env e,
space,
string "--",
space,
p_con' true env c,
space,
string "[",
p_con env field,
space,
string " in ",
space,
p_con env rest,
string "]"]
else
box [p_exp' true env e,
space,
string "--",
space,
p_con' true env c])
| ECutMulti (e, c, {rest}) =>
parenIf par (if !debug then
box [p_exp' true env e,
space,
string "---",
space,
p_con' true env c,
space,
string "[",
p_con env rest,
string "]"]
else
box [p_exp' true env e,
space,
string "---",
space,
p_con' true env c])
| ECase (e, pes, {disc, result}) =>
parenIf par (box [string "case",
space,
p_exp env e,
space,
if !debug then
box [string "in",
space,
p_con env disc,
space,
string "return",
space,
p_con env result,
space]
else
box [],
string "of",
space,
p_list_sep (box [space, string "|", space])
(fn (p, e) => box [p_pat env p,
space,
string "=>",
space,
p_exp (E.patBinds env p) e]) pes])
| EWrite e => box [string "write(",
p_exp env e,
string ")"]
| EClosure (n, es) => box [string "CLOSURE(",
p_enamed env n,
p_list_sep (string "") (fn e => box [string ", ",
p_exp env e]) es,
string ")"]
| ELet (x, t, e1, e2) => box [string "let",
space,
string x,
space,
string ":",
space,
p_con env t,
space,
string "=",
space,
p_exp env e1,
space,
string "in",
newline,
p_exp (E.pushERel env x t) e2]
| EServerCall (n, es, _, _) => box [string "Server(",
p_enamed env n,
string ",",
space,
p_list (p_exp env) es,
string ")"]
| EKAbs (x, e) => box [string x,
space,
string "==>",
space,
p_exp (E.pushKRel env x) e]
| EKApp (e, k) => box [p_exp env e,
string "[[",
p_kind env k,
string "]]"]
and p_exp env = p_exp' false env
fun p_named x n =
if !debug then
box [string x,
string "__",
string (Int.toString n)]
else
string x
fun p_vali env (x, n, t, e, s) =
let
val xp = p_named x n
in
box [xp,
space,
string "as",
space,
string s,
space,
string ":",
space,
p_con env t,
space,
string "=",
space,
p_exp env e]
end
fun p_datatype env (x, n, xs, cons) =
let
val k = (KType, ErrorMsg.dummySpan)
val env = E.pushCNamed env x n (KType, ErrorMsg.dummySpan) NONE
val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
val xp = if !debug then
string (x ^ "__" ^ Int.toString n)
else
string x
in
box [xp,
p_list_sep (box []) (fn x => box [space, string x]) xs,
space,
string "=",
space,
p_list_sep (box [space, string "|", space])
(fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
else string x
| (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
else string x, space, string "of", space, p_con env t])
cons]
end
fun p_decl env (dAll as (d, _) : decl) =
case d of
DCon (x, n, k, c) =>
let
val xp = if !debug then
box [string x,
string "__",
string (Int.toString n)]
else
string x
in
box [string "con",
space,
xp,
space,
string "::",
space,
p_kind env k,
space,
string "=",
space,
p_con env c]
end
| DDatatype x => box [string "datatype",
space,
p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x]
| DVal vi => box [string "val",
space,
p_vali env vi]
| DValRec vis =>
let
val env = E.declBinds env dAll
in
box [string "val",
space,
string "rec",
space,
p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
end
| DExport (ek, n, _) => box [string "export",
space,
Export.p_export_kind ek,
space,
p_enamed env n,
space,
string "as",
space,
(p_con env (#2 (E.lookupENamed env n))
handle E.UnboundNamed _ => string "UNBOUND")]
| DTable (x, n, c, s, pe, _, ce, _) => box [string "table",
space,
p_named x n,
space,
string "as",
space,
string s,
space,
string ":",
space,
p_con env c,
space,
string "keys",
space,
p_exp env pe,
space,
string "constraints",
space,
p_exp (E.declBinds env dAll) ce]
| DSequence (x, n, s) => box [string "sequence",
space,
p_named x n,
space,
string "as",
space,
string s]
| DView (x, n, s, e, _) => box [string "view",
space,
p_named x n,
space,
string "as",
space,
p_exp env e]
| DDatabase s => box [string "database",
space,
string s]
| DCookie (x, n, c, s) => box [string "cookie",
space,
p_named x n,
space,
string "as",
space,
string s,
space,
string ":",
space,
p_con env c]
| DStyle (x, n, s) => box [string "style",
space,
p_named x n,
space,
string "as",
space,
string s]
| DTask (e1, e2) => box [string "task",
space,
p_exp env e1,
space,
string "=",
space,
p_exp env e2]
| DPolicy e1 => box [string "policy",
space,
p_exp env e1]
| DOnError _ => string "ONERROR"
fun p_file env file =
let
val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
(p_decl env d,
E.declBinds env d))
env file
in
p_list_sep newline (fn x => x) pds
end
end
urweb-20160213+dfsg/src/core_untangle.sig 0000664 0000000 0000000 00000003075 12657647235 0020163 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 CORE_UNTANGLE = sig
val untangle : Core.file -> Core.file
end
urweb-20160213+dfsg/src/core_untangle.sml 0000664 0000000 0000000 00000025441 12657647235 0020175 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 2013, 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 CoreUntangle :> CORE_UNTANGLE = struct
open Core
structure U = CoreUtil
structure E = CoreEnv
structure IS = IntBinarySet
structure IM = IntBinaryMap
fun default (k, s) = s
fun exp thisGroup (e, s) =
let
fun try n =
if IS.member (thisGroup, n) then
IS.add (s, n)
else
s
in
case e of
ENamed n => try n
| EClosure (n, _) => try n
| EServerCall (n, _, _, _) => try n
| _ => s
end
fun untangle file =
let
fun expUsed thisGroup = U.Exp.fold {con = default,
kind = default,
exp = exp thisGroup} IS.empty
fun decl (dAll as (d, loc)) =
case d of
DValRec vis =>
let
val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) =>
IS.add (thisGroup, n)) IS.empty vis
val edefs = foldl (fn ((_, n, _, e, _), edefs) =>
IM.insert (edefs, n, expUsed thisGroup e))
IM.empty vis
val used = edefs
fun expand used =
IS.foldl (fn (n, used) =>
case IM.find (edefs, n) of
NONE => used
| SOME usedHere =>
if IS.isEmpty (IS.difference (usedHere, used)) then
used
else
expand (IS.union (usedHere, used)))
used used
fun p_graph reachable =
IM.appi (fn (n, reachableHere) =>
(print (Int.toString n);
print ":";
IS.app (fn n' => (print " ";
print (Int.toString n'))) reachableHere;
print "\n")) reachable
(*val () = print "used:\n"
val () = p_graph used*)
fun expand reachable =
let
val changed = ref false
val reachable =
IM.mapi (fn (n, reachableHere) =>
IS.foldl (fn (n', reachableHere) =>
let
val more = valOf (IM.find (reachable, n'))
in
if IS.isEmpty (IS.difference (more, reachableHere)) then
reachableHere
else
(changed := true;
IS.union (more, reachableHere))
end)
reachableHere reachableHere) reachable
in
(reachable, !changed)
end
fun iterate reachable =
let
val (reachable, changed) = expand reachable
in
if changed then
iterate reachable
else
reachable
end
val reachable = iterate used
(*val () = print "reachable:\n"
val () = p_graph reachable*)
fun sccs (nodes, acc) =
case IS.find (fn _ => true) nodes of
NONE => acc
| SOME rep =>
let
val reachableHere = valOf (IM.find (reachable, rep))
val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) =>
if node = rep then
(nodes, scc)
else
let
val reachableThere =
valOf (IM.find (reachable, node))
in
if IS.member (reachableThere, rep) then
(IS.delete (nodes, node),
IS.add (scc, node))
else
(nodes, scc)
end)
(IS.delete (nodes, rep), IS.singleton rep) reachableHere
in
sccs (nodes, scc :: acc)
end
val sccs = sccs (thisGroup, [])
(*val () = app (fn nodes => (print "SCC:";
IS.app (fn i => (print " ";
print (Int.toString i))) nodes;
print "\n")) sccs*)
fun depends nodes1 nodes2 =
let
val node1 = valOf (IS.find (fn _ => true) nodes1)
val node2 = valOf (IS.find (fn _ => true) nodes2)
val reachable1 = valOf (IM.find (reachable, node1))
in
IS.member (reachable1, node2)
end
fun findReady (sccs, passed) =
case sccs of
[] => raise Fail "Untangle: Unable to topologically sort 'val rec'"
| nodes :: sccs =>
if List.exists (depends nodes) passed
orelse List.exists (depends nodes) sccs then
findReady (sccs, nodes :: passed)
else
(nodes, List.revAppend (passed, sccs))
fun topo (sccs, acc) =
case sccs of
[] => rev acc
| _ =>
let
val (node, sccs) = findReady (sccs, [])
in
topo (sccs, node :: acc)
end
val sccs = topo (sccs, [])
(*val () = app (fn nodes => (print "SCC':";
IS.app (fn i => (print " ";
print (Int.toString i))) nodes;
print "\n")) sccs*)
fun isNonrec nodes =
case IS.find (fn _ => true) nodes of
NONE => NONE
| SOME node =>
let
val nodes = IS.delete (nodes, node)
val reachableHere = valOf (IM.find (reachable, node))
in
if IS.isEmpty nodes then
if IS.member (reachableHere, node) then
NONE
else
SOME node
else
NONE
end
val ds = map (fn nodes =>
case isNonrec nodes of
SOME node =>
let
val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis)
in
(DVal vi, loc)
end
| NONE =>
(DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc))
sccs
in
ds
end
| _ => [dAll]
in
ListUtil.mapConcat decl file
end
end
urweb-20160213+dfsg/src/core_util.sig 0000664 0000000 0000000 00000026351 12657647235 0017325 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 CORE_UTIL = sig
structure Kind : sig
val compare : Core.kind * Core.kind -> order
val mapfoldB : {kind : ('context, Core.kind', 'state, 'abort) Search.mapfolderB,
bind : 'context * string -> 'context}
-> ('context, Core.kind, 'state, 'abort) Search.mapfolderB
val mapfold : (Core.kind', 'state, 'abort) Search.mapfolder
-> (Core.kind, 'state, 'abort) Search.mapfolder
val map : (Core.kind' -> Core.kind') -> Core.kind -> Core.kind
val exists : (Core.kind' -> bool) -> Core.kind -> bool
val mapB : {kind : 'context -> Core.kind' -> Core.kind',
bind : 'context * string -> 'context}
-> 'context -> (Core.kind -> Core.kind)
end
structure Con : sig
val compare : Core.con * Core.con -> order
datatype binder =
RelK of string
| RelC of string * Core.kind
| NamedC of string * int * Core.kind * Core.con option
val mapfoldB : {kind : ('context, Core.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Core.con', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Core.con, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Core.kind', 'state, 'abort) Search.mapfolder,
con : (Core.con', 'state, 'abort) Search.mapfolder}
-> (Core.con, 'state, 'abort) Search.mapfolder
val map : {kind : Core.kind' -> Core.kind',
con : Core.con' -> Core.con'}
-> Core.con -> Core.con
val mapB : {kind : 'context -> Core.kind' -> Core.kind',
con : 'context -> Core.con' -> Core.con',
bind : 'context * binder -> 'context}
-> 'context -> (Core.con -> Core.con)
val fold : {kind : Core.kind' * 'state -> 'state,
con : Core.con' * 'state -> 'state}
-> 'state -> Core.con -> 'state
val exists : {kind : Core.kind' -> bool,
con : Core.con' -> bool} -> Core.con -> bool
val existsB : {kind : 'context * Core.kind' -> bool,
con : 'context * Core.con' -> bool,
bind : 'context * binder -> 'context}
-> 'context -> Core.con -> bool
val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state,
con : Core.con' * 'state -> Core.con' * 'state}
-> 'state -> Core.con -> Core.con * 'state
end
structure Exp : sig
val compare : Core.exp * Core.exp -> order
datatype binder =
RelK of string
| RelC of string * Core.kind
| NamedC of string * int * Core.kind * Core.con option
| RelE of string * Core.con
| NamedE of string * int * Core.con * Core.exp option * string
val mapfoldB : {kind : ('context, Core.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Core.con', 'state, 'abort) Search.mapfolderB,
exp : ('context, Core.exp', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Core.exp, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Core.kind', 'state, 'abort) Search.mapfolder,
con : (Core.con', 'state, 'abort) Search.mapfolder,
exp : (Core.exp', 'state, 'abort) Search.mapfolder}
-> (Core.exp, 'state, 'abort) Search.mapfolder
val map : {kind : Core.kind' -> Core.kind',
con : Core.con' -> Core.con',
exp : Core.exp' -> Core.exp'}
-> Core.exp -> Core.exp
val mapB : {kind : 'context -> Core.kind' -> Core.kind',
con : 'context -> Core.con' -> Core.con',
exp : 'context -> Core.exp' -> Core.exp',
bind : 'context * binder -> 'context}
-> 'context -> (Core.exp -> Core.exp)
val fold : {kind : Core.kind' * 'state -> 'state,
con : Core.con' * 'state -> 'state,
exp : Core.exp' * 'state -> 'state}
-> 'state -> Core.exp -> 'state
val foldB : {kind : 'context * Core.kind' * 'state -> 'state,
con : 'context * Core.con' * 'state -> 'state,
exp : 'context * Core.exp' * 'state -> 'state,
bind : 'context * binder -> 'context}
-> 'context -> 'state -> Core.exp -> 'state
val exists : {kind : Core.kind' -> bool,
con : Core.con' -> bool,
exp : Core.exp' -> bool} -> Core.exp -> bool
val existsB : {kind : 'context * Core.kind' -> bool,
con : 'context * Core.con' -> bool,
exp : 'context * Core.exp' -> bool,
bind : 'context * binder -> 'context}
-> 'context -> Core.exp -> bool
val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state,
con : Core.con' * 'state -> Core.con' * 'state,
exp : Core.exp' * 'state -> Core.exp' * 'state}
-> 'state -> Core.exp -> Core.exp * 'state
val foldMapB : {kind : 'context * Core.kind' * 'state -> Core.kind' * 'state,
con : 'context * Core.con' * 'state -> Core.con' * 'state,
exp : 'context * Core.exp' * 'state -> Core.exp' * 'state,
bind : 'context * binder -> 'context}
-> 'context -> 'state -> Core.exp -> Core.exp * 'state
end
structure Decl : sig
datatype binder = datatype Exp.binder
val mapfoldB : {kind : ('context, Core.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Core.con', 'state, 'abort) Search.mapfolderB,
exp : ('context, Core.exp', 'state, 'abort) Search.mapfolderB,
decl : ('context, Core.decl', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Core.decl, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Core.kind', 'state, 'abort) Search.mapfolder,
con : (Core.con', 'state, 'abort) Search.mapfolder,
exp : (Core.exp', 'state, 'abort) Search.mapfolder,
decl : (Core.decl', 'state, 'abort) Search.mapfolder}
-> (Core.decl, 'state, 'abort) Search.mapfolder
val fold : {kind : Core.kind' * 'state -> 'state,
con : Core.con' * 'state -> 'state,
exp : Core.exp' * 'state -> 'state,
decl : Core.decl' * 'state -> 'state}
-> 'state -> Core.decl -> 'state
val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state,
con : Core.con' * 'state -> Core.con' * 'state,
exp : Core.exp' * 'state -> Core.exp' * 'state,
decl : Core.decl' * 'state -> Core.decl' * 'state}
-> 'state -> Core.decl -> Core.decl * 'state
val foldMapB : {kind : 'context * Core.kind' * 'state -> Core.kind' * 'state,
con : 'context * Core.con' * 'state -> Core.con' * 'state,
exp : 'context * Core.exp' * 'state -> Core.exp' * 'state,
decl : 'context * Core.decl' * 'state -> Core.decl' * 'state,
bind : 'context * binder -> 'context}
-> 'context -> 'state -> Core.decl -> Core.decl * 'state
val exists : {kind : Core.kind' -> bool,
con : Core.con' -> bool,
exp : Core.exp' -> bool,
decl : Core.decl' -> bool} -> Core.decl -> bool
end
structure File : sig
val maxName : Core.file -> int
datatype binder = datatype Exp.binder
val mapfoldB : {kind : ('context, Core.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Core.con', 'state, 'abort) Search.mapfolderB,
exp : ('context, Core.exp', 'state, 'abort) Search.mapfolderB,
decl : ('context, Core.decl', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Core.file, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Core.kind', 'state, 'abort) Search.mapfolder,
con : (Core.con', 'state, 'abort) Search.mapfolder,
exp : (Core.exp', 'state, 'abort) Search.mapfolder,
decl : (Core.decl', 'state, 'abort) Search.mapfolder}
-> (Core.file, 'state, 'abort) Search.mapfolder
val mapB : {kind : 'context -> Core.kind' -> Core.kind',
con : 'context -> Core.con' -> Core.con',
exp : 'context -> Core.exp' -> Core.exp',
decl : 'context -> Core.decl' -> Core.decl',
bind : 'context * binder -> 'context}
-> 'context -> Core.file -> Core.file
val map : {kind : Core.kind' -> Core.kind',
con : Core.con' -> Core.con',
exp : Core.exp' -> Core.exp',
decl : Core.decl' -> Core.decl'}
-> Core.file -> Core.file
val fold : {kind : Core.kind' * 'state -> 'state,
con : Core.con' * 'state -> 'state,
exp : Core.exp' * 'state -> 'state,
decl : Core.decl' * 'state -> 'state}
-> 'state -> Core.file -> 'state
val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state,
con : Core.con' * 'state -> Core.con' * 'state,
exp : Core.exp' * 'state -> Core.exp' * 'state,
decl : Core.decl' * 'state -> Core.decl' * 'state}
-> 'state -> Core.file -> Core.file * 'state
end
end
urweb-20160213+dfsg/src/core_util.sml 0000664 0000000 0000000 00000146306 12657647235 0017341 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2010, 2013, 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 CoreUtil :> CORE_UTIL = struct
open Core
structure S = Search
structure Kind = struct
open Order
fun compare ((k1, _), (k2, _)) =
case (k1, k2) of
(KType, KType) => EQUAL
| (KType, _) => LESS
| (_, KType) => GREATER
| (KArrow (d1, r1), KArrow (d2, r2)) => join (compare (d1, d2), fn () => compare (r1, r2))
| (KArrow _, _) => LESS
| (_, KArrow _) => GREATER
| (KName, KName) => EQUAL
| (KName, _) => LESS
| (_, KName) => GREATER
| (KRecord k1, KRecord k2) => compare (k1, k2)
| (KRecord _, _) => LESS
| (_, KRecord _) => GREATER
| (KUnit, KUnit) => EQUAL
| (KUnit, _) => LESS
| (_, KUnit) => GREATER
| (KTuple ks1, KTuple ks2) => joinL compare (ks1, ks2)
| (KTuple _, _) => LESS
| (_, KTuple _) => GREATER
| (KRel n1, KRel n2) => Int.compare (n1, n2)
| (KRel _, _) => LESS
| (_, KRel _) => GREATER
| (KFun (_, k1), KFun (_, k2)) => compare (k1, k2)
fun mapfoldB {kind = f, bind} =
let
fun mfk ctx k acc =
S.bindP (mfk' ctx k acc, f 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))
| KRel _ => S.return2 kAll
| KFun (x, k) =>
S.map2 (mfk (bind (ctx, x)) k,
fn k' =>
(KFun (x, k'), loc))
in
mfk
end
fun mapfold fk =
mapfoldB {kind = fn () => fk,
bind = fn ((), _) => ()} ()
fun map f k =
case mapfold (fn k => fn () => S.Continue (f k, ())) k () of
S.Return () => raise Fail "CoreUtil.Kind.map"
| S.Continue (k, ()) => k
fun mapB {kind, bind} ctx k =
case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
bind = bind} ctx k () of
S.Continue (k, ()) => k
| S.Return _ => raise Fail "CoreUtil.Kind.mapB: Impossible"
fun exists f k =
case mapfold (fn k => fn () =>
if f k then
S.Return ()
else
S.Continue (k, ())) k () of
S.Return _ => true
| S.Continue _ => false
end
structure Con = struct
open Order
fun compare ((c1, _), (c2, _)) =
case (c1, c2) of
(TFun (d1, r1), TFun (d2, r2)) => join (compare (d1, d2), fn () => compare (r1, r2))
| (TFun _, _) => LESS
| (_, TFun _) => GREATER
| (TCFun (x1, k1, r1), TCFun (x2, k2, r2)) =>
join (String.compare (x1, x2),
fn () => join (Kind.compare (k1, k2),
fn () => compare (r1, r2)))
| (TCFun _, _) => LESS
| (_, TCFun _) => GREATER
| (TRecord c1, TRecord c2) => compare (c1, c2)
| (TRecord _, _) => LESS
| (_, TRecord _) => GREATER
| (CRel n1, CRel n2) => Int.compare (n1, n2)
| (CRel _, _) => LESS
| (_, CRel _) => GREATER
| (CNamed n1, CNamed n2) => Int.compare (n1, n2)
| (CNamed _, _) => LESS
| (_, CNamed _) => GREATER
| (CFfi (m1, s1), CFfi (m2, s2)) => join (String.compare (m1, m2),
fn () => String.compare (s1, s2))
| (CFfi _, _) => LESS
| (_, CFfi _) => GREATER
| (CApp (f1, x1), CApp (f2, x2)) => join (compare (f1, f2),
fn () => compare (x1, x2))
| (CApp _, _) => LESS
| (_, CApp _) => GREATER
| (CAbs (x1, k1, b1), CAbs (x2, k2, b2)) =>
join (String.compare (x1, x2),
fn () => join (Kind.compare (k1, k2),
fn () => compare (b1, b2)))
| (CAbs _, _) => LESS
| (_, CAbs _) => GREATER
| (CName s1, CName s2) => String.compare (s1, s2)
| (CName _, _) => LESS
| (_, CName _) => GREATER
| (CRecord (k1, xvs1), CRecord (k2, xvs2)) =>
join (Kind.compare (k1, k2),
fn () =>
let
val sort = ListMergeSort.sort (fn ((x1, _), (x2, _)) =>
compare (x1, x2) = GREATER)
in
joinL (fn ((x1, v1), (x2, v2)) =>
join (compare (x1, x2),
fn () => compare (v1, v2))) (sort xvs1, sort xvs2)
end)
| (CRecord _, _) => LESS
| (_, CRecord _) => GREATER
| (CConcat (f1, s1), CConcat (f2, s2)) =>
join (compare (f1, f2),
fn () => compare (s1, s2))
| (CConcat _, _) => LESS
| (_, CConcat _) => GREATER
| (CMap (d1, r1), CMap (d2, r2)) =>
join (Kind.compare (d1, d2),
fn () => Kind.compare (r1, r2))
| (CMap _, _) => LESS
| (_, CMap _) => GREATER
| (CUnit, CUnit) => EQUAL
| (CUnit, _) => LESS
| (_, CUnit) => GREATER
| (CTuple cs1, CTuple cs2) => joinL compare (cs1, cs2)
| (CTuple _, _) => LESS
| (_, CTuple _) => GREATER
| (CProj (c1, n1), CProj (c2, n2)) => join (Int.compare (n1, n2),
fn () => compare (c1, c2))
| (CProj _, _) => LESS
| (_, CProj _) => GREATER
| (CKAbs (_, c1), CKAbs (_, c2)) => compare (c1, c2)
| (CKAbs _, _) => LESS
| (_, CKAbs _) => GREATER
| (CKApp (c1, k1), CKApp (c2, k2)) =>
join (compare (c1, c2),
fn () => Kind.compare (k1, k2))
| (CKApp _, _) => LESS
| (_, CKApp _) => GREATER
| (TKFun (_, c1), TKFun (_, c2)) => compare (c1, c2)
datatype binder =
RelK of string
| RelC of string * kind
| NamedC of string * int * kind * con option
fun mapfoldB {kind = fk, con = fc, bind} =
let
val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)}
fun mfc ctx c acc =
S.bindP (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 (x, k, c) =>
S.bind2 (mfk ctx k,
fn k' =>
S.map2 (mfc (bind (ctx, RelC (x, k))) c,
fn c' =>
(TCFun (x, k', c'), loc)))
| TRecord c =>
S.map2 (mfc ctx c,
fn c' =>
(TRecord c', loc))
| CRel _ => S.return2 cAll
| CNamed _ => S.return2 cAll
| CFfi _ => 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))
| 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
fun mapfold {kind = fk, con = fc} =
mapfoldB {kind = fn () => fk,
con = fn () => fc,
bind = fn ((), _) => ()} ()
fun map {kind, con} c =
case mapfold {kind = fn k => fn () => S.Continue (kind k, ()),
con = fn c => fn () => S.Continue (con c, ())} c () of
S.Return () => raise Fail "Core_util.Con.map"
| S.Continue (c, ()) => c
fun mapB {kind, con, bind} ctx c =
case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()),
bind = bind} ctx c () of
S.Continue (c, ()) => c
| S.Return _ => raise Fail "CoreUtil.Con.mapB: Impossible"
fun fold {kind, con} s c =
case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)),
con = fn c => fn s => S.Continue (c, con (c, s))} c s of
S.Continue (_, s) => s
| S.Return _ => raise Fail "CoreUtil.Con.fold: Impossible"
fun exists {kind, con} k =
case mapfold {kind = fn k => fn () =>
if kind k then
S.Return ()
else
S.Continue (k, ()),
con = fn c => fn () =>
if con c then
S.Return ()
else
S.Continue (c, ())} k () of
S.Return _ => true
| S.Continue _ => false
fun existsB {kind, con, bind} ctx c =
case mapfoldB {kind = fn ctx => fn k => fn () =>
if kind (ctx, k) then
S.Return ()
else
S.Continue (k, ()),
con = fn ctx => fn c => fn () =>
if con (ctx, c) then
S.Return ()
else
S.Continue (c, ()),
bind = bind} ctx c () of
S.Return _ => true
| S.Continue _ => false
fun foldMap {kind, con} s c =
case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)),
con = fn c => fn s => S.Continue (con (c, s))} c s of
S.Continue v => v
| S.Return _ => raise Fail "CoreUtil.Con.foldMap: Impossible"
end
structure Exp = struct
open Order
fun pcCompare (pc1, pc2) =
case (pc1, pc2) of
(PConVar n1, PConVar n2) => Int.compare (n1, n2)
| (PConVar _, _) => LESS
| (_, PConVar _) => GREATER
| (PConFfi {mod = m1, datatyp = d1, con = c1, ...},
PConFfi {mod = m2, datatyp = d2, con = c2, ...}) =>
join (String.compare (m1, m2),
fn () => join (String.compare (d1, d2),
fn () => String.compare (c1, c2)))
fun pCompare ((p1, _), (p2, _)) =
case (p1, p2) of
(PVar _, PVar _) => EQUAL
| (PVar _, _) => LESS
| (_, PVar _) => GREATER
| (PPrim p1, PPrim p2) => Prim.compare (p1, p2)
| (PPrim _, _) => LESS
| (_, PPrim _) => GREATER
| (PCon (_, pc1, _, po1), PCon (_, pc2, _, po2)) =>
join (pcCompare (pc1, pc2),
fn () => joinO pCompare (po1, po2))
| (PCon _, _) => LESS
| (_, PCon _) => GREATER
| (PRecord xps1, PRecord xps2) =>
joinL (fn ((x1, p1, _), (x2, p2, _)) =>
join (String.compare (x1, x2),
fn () => pCompare (p1, p2))) (xps1, xps2)
fun fmCompare (fm1, fm2) =
case (fm1, fm2) of
(None, None) => EQUAL
| (None, _) => LESS
| (_, None) => GREATER
| (Error, Error) => EQUAL
fun compare ((e1, _), (e2, _)) =
case (e1, e2) of
(EPrim p1, EPrim p2) => Prim.compare (p1, p2)
| (EPrim _, _) => LESS
| (_, EPrim _) => GREATER
| (ERel n1, ERel n2) => Int.compare (n1, n2)
| (ERel _, _) => LESS
| (_, ERel _) => GREATER
| (ENamed n1, ENamed n2) => Int.compare (n1, n2)
| (ENamed _, _) => LESS
| (_, ENamed _) => GREATER
| (ECon (_, pc1, _, eo1), ECon (_, pc2, _, eo2)) =>
join (pcCompare (pc1, pc2),
fn () => joinO compare (eo1, eo2))
| (ECon _, _) => LESS
| (_, ECon _) => GREATER
| (EFfi (f1, x1), EFfi (f2, x2)) =>
join (String.compare (f1, f2),
fn () => String.compare (x1, x2))
| (EFfi _, _) => LESS
| (_, EFfi _) => GREATER
| (EFfiApp (f1, x1, es1), EFfiApp (f2, x2, es2)) =>
join (String.compare (f1, f2),
fn () => join (String.compare (x1, x2),
fn () => joinL (fn ((e1, _), (e2, _)) => compare (e1, e2))(es1, es2)))
| (EFfiApp _, _) => LESS
| (_, EFfiApp _) => GREATER
| (EApp (f1, x1), EApp (f2, x2)) =>
join (compare (f1, f2),
fn () => compare (x1, x2))
| (EApp _, _) => LESS
| (_, EApp _) => GREATER
| (EAbs (_, _, _, e1), EAbs (_, _, _, e2)) => compare (e1, e2)
| (EAbs _, _) => LESS
| (_, EAbs _) => GREATER
| (ECApp (f1, x1), ECApp (f2, x2)) =>
join (compare (f1, f2),
fn () => Con.compare (x1, x2))
| (ECApp _, _) => LESS
| (_, ECApp _) => GREATER
| (ECAbs (_, _, e1), ECAbs (_, _, e2)) => compare (e1, e2)
| (ECAbs _, _) => LESS
| (_, ECAbs _) => GREATER
| (ERecord xes1, ERecord xes2) =>
joinL (fn ((x1, e1, _), (x2, e2, _)) =>
join (Con.compare (x1, x2),
fn () => compare (e1, e2))) (xes1, xes2)
| (ERecord _, _) => LESS
| (_, ERecord _) => GREATER
| (EField (e1, c1, _), EField (e2, c2, _)) =>
join (compare (e1, e2),
fn () => Con.compare (c1, c2))
| (EField _, _) => LESS
| (_, EField _) => GREATER
| (EConcat (x1, _, y1, _), EConcat (x2, _, y2, _)) =>
join (compare (x1, x2),
fn () => compare (y1, y2))
| (EConcat _, _) => LESS
| (_, EConcat _) => GREATER
| (ECut (e1, c1, _), ECut (e2, c2, _)) =>
join (compare (e1, e2),
fn () => Con.compare (c1, c2))
| (ECut _, _) => LESS
| (_, ECut _) => GREATER
| (ECutMulti (e1, c1, _), ECutMulti (e2, c2, _)) =>
join (compare (e1, e2),
fn () => Con.compare (c1, c2))
| (ECutMulti _, _) => LESS
| (_, ECutMulti _) => GREATER
| (ECase (e1, pes1, _), ECase (e2, pes2, _)) =>
join (compare (e1, e2),
fn () => joinL (fn ((p1, e1), (p2, e2)) =>
join (pCompare (p1, p2),
fn () => compare (e1, e2))) (pes1, pes2))
| (ECase _, _) => LESS
| (_, ECase _) => GREATER
| (EWrite e1, EWrite e2) => compare (e1, e2)
| (EWrite _, _) => LESS
| (_, EWrite _) => GREATER
| (EClosure (n1, es1), EClosure (n2, es2)) =>
join (Int.compare (n1, n2),
fn () => joinL compare (es1, es2))
| (EClosure _, _) => LESS
| (_, EClosure _) => GREATER
| (ELet (_, _, x1, e1), ELet (_, _, x2, e2)) =>
join (compare (x1, x2),
fn () => compare (e1, e2))
| (ELet _, _) => LESS
| (_, ELet _) => GREATER
| (EServerCall (n1, es1, _, fm1), EServerCall (n2, es2, _, fm2)) =>
join (Int.compare (n1, n2),
fn () => join (fmCompare (fm1, fm2),
fn () => joinL compare (es1, es2)))
| (EServerCall _, _) => LESS
| (_, EServerCall _) => GREATER
| (EKAbs (_, e1), EKAbs (_, e2)) => compare (e1, e2)
| (EKAbs _, _) => LESS
| (_, EKAbs _) => GREATER
| (EKApp (e1, k1), EKApp (e2, k2)) =>
join (compare (e1, e2),
fn () => Kind.compare (k1, k2))
datatype binder =
RelK of string
| RelC of string * kind
| NamedC of string * int * kind * con option
| RelE of string * con
| NamedE of string * int * con * exp option * string
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 mfe ctx e acc =
S.bindP (mfe' ctx e acc, fe ctx)
and mfet ctx (e, t) =
S.bind2 (mfe ctx e,
fn e' =>
S.map2 (mfc ctx t,
fn t' => (e', t')))
and mfe' ctx (eAll as (e, loc)) =
case e of
EPrim _ => S.return2 eAll
| ERel _ => S.return2 eAll
| ENamed _ => S.return2 eAll
| ECon (dk, pc, cs, NONE) =>
S.bind2 (mfpc ctx pc,
fn pc' =>
S.map2 (ListUtil.mapfold (mfc ctx) cs,
fn cs' =>
(ECon (dk, pc', cs', NONE), loc)))
| ECon (dk, pc, cs, SOME e) =>
S.bind2 (mfpc ctx pc,
fn pc' =>
S.bind2 (mfe ctx e,
fn e' =>
S.map2 (ListUtil.mapfold (mfc ctx) cs,
fn cs' =>
(ECon (dk, pc', cs', SOME e'), loc))))
| EFfi _ => S.return2 eAll
| EFfiApp (m, x, es) =>
S.map2 (ListUtil.mapfold (mfet ctx) es,
fn es' =>
(EFfiApp (m, x, es'), loc))
| 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 (x, k, e) =>
S.bind2 (mfk ctx k,
fn k' =>
S.map2 (mfe (bind (ctx, RelC (x, k))) e,
fn e' =>
(ECAbs (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)))))
| EWrite e =>
S.map2 (mfe ctx e,
fn e' =>
(EWrite e', loc))
| EClosure (n, es) =>
S.map2 (ListUtil.mapfold (mfe ctx) es,
fn es' =>
(EClosure (n, es'), loc))
| ELet (x, t, e1, e2) =>
S.bind2 (mfc ctx t,
fn t' =>
S.bind2 (mfe ctx e1,
fn e1' =>
S.map2 (mfe (bind (ctx, RelE (x, t'))) e2,
fn e2' =>
(ELet (x, t', e1', e2'), loc))))
| EServerCall (n, es, t, fm) =>
S.bind2 (ListUtil.mapfold (mfe ctx) es,
fn es' =>
S.map2 (mfc ctx t,
fn t' =>
(EServerCall (n, es', t', fm), loc)))
| 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 (mfpc ctx pc,
fn pc' =>
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 mfpc ctx pc =
case pc of
PConVar _ => S.return2 pc
| PConFfi {mod = m, datatyp, params, con, arg, kind} =>
S.map2 ((case arg of
NONE => S.return2 NONE
| SOME c =>
let
val k = (KType, ErrorMsg.dummySpan)
val ctx' = foldl (fn (x, ctx) => bind (ctx, RelC (x, k))) ctx params
in
S.map2 (mfc ctx' c, SOME)
end),
fn arg' =>
PConFfi {mod = m, datatyp = datatyp, params = params,
con = con, arg = arg', kind = kind})
in
mfe
end
fun mapfold {kind = fk, con = fc, exp = fe} =
mapfoldB {kind = fn () => fk,
con = fn () => fc,
exp = fn () => fe,
bind = fn ((), _) => ()} ()
fun mapB {kind, con, exp, bind} ctx e =
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, ()),
bind = bind} ctx e () of
S.Continue (e, ()) => e
| S.Return _ => raise Fail "CoreUtil.Exp.mapB: Impossible"
fun map {kind, con, exp} e =
case mapfold {kind = fn k => fn () => S.Continue (kind k, ()),
con = fn c => fn () => S.Continue (con c, ()),
exp = fn e => fn () => S.Continue (exp e, ())} e () of
S.Return () => raise Fail "Core_util.Exp.map"
| S.Continue (e, ()) => e
fun fold {kind, con, exp} s e =
case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)),
con = fn c => fn s => S.Continue (c, con (c, s)),
exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of
S.Continue (_, s) => s
| S.Return _ => raise Fail "CoreUtil.Exp.fold: Impossible"
fun foldB {kind, con, exp, bind} ctx s e =
case mapfoldB {kind = fn ctx => fn k => fn s => S.Continue (k, kind (ctx, k, s)),
con = fn ctx => fn c => fn s => S.Continue (c, con (ctx, c, s)),
exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)),
bind = bind} ctx e s of
S.Continue (_, s) => s
| S.Return _ => raise Fail "CoreUtil.Exp.foldB: Impossible"
fun exists {kind, con, exp} k =
case mapfold {kind = fn k => fn () =>
if kind k then
S.Return ()
else
S.Continue (k, ()),
con = fn c => fn () =>
if con c then
S.Return ()
else
S.Continue (c, ()),
exp = fn e => fn () =>
if exp e then
S.Return ()
else
S.Continue (e, ())} k () of
S.Return _ => true
| S.Continue _ => false
fun existsB {kind, con, exp, bind} ctx k =
case mapfoldB {kind = fn ctx => fn k => fn () =>
if kind (ctx, k) then
S.Return ()
else
S.Continue (k, ()),
con = fn ctx => fn c => fn () =>
if con (ctx, c) then
S.Return ()
else
S.Continue (c, ()),
exp = fn ctx => fn e => fn () =>
if exp (ctx, e) then
S.Return ()
else
S.Continue (e, ()),
bind = bind} ctx k () of
S.Return _ => true
| S.Continue _ => false
fun foldMap {kind, con, exp} s e =
case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)),
con = fn c => fn s => S.Continue (con (c, s)),
exp = fn e => fn s => S.Continue (exp (e, s))} e s of
S.Continue v => v
| S.Return _ => raise Fail "CoreUtil.Exp.foldMap: Impossible"
fun foldMapB {kind, con, exp, bind} ctx s e =
case mapfoldB {kind = fn ctx => fn k => fn s => S.Continue (kind (ctx, k, s)),
con = fn ctx => fn c => fn s => S.Continue (con (ctx, c, s)),
exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)),
bind = bind} ctx e s of
S.Continue v => v
| S.Return _ => raise Fail "CoreUtil.Exp.foldMapB: Impossible"
end
structure Decl = struct
datatype binder = datatype Exp.binder
fun mapfoldB {kind = fk, con = fc, exp = fe, 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'}
val mfe = Exp.mapfoldB {kind = fk, con = fc, exp = fe, bind = bind}
fun mfd ctx d acc =
S.bindP (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) =>
let
val k = (KType, loc)
val k' = foldl (fn (_, k') => (KArrow (k, k'), loc)) k xs
val ctx' = bind (ctx, NamedC (x, n, k', NONE))
in
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'))
end) dts,
fn dts' =>
(DDatatype dts', loc))
| DVal vi =>
S.map2 (mfvi ctx vi,
fn vi' =>
(DVal vi', loc))
| DValRec vis =>
let
val ctx = foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s)))
ctx vis
in
S.map2 (ListUtil.mapfold (mfvi ctx) vis,
fn vis' =>
(DValRec vis', loc))
end
| DExport _ => S.return2 dAll
| DTable (x, n, c, s, pe, pc, ce, cc) =>
let
val loc = #2 ce
val ct = (CFfi ("Basis", "sql_table"), loc)
val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc)
val ct = (CApp (ct, cc), loc)
val ctx' = bind (ctx, NamedE (x, n, ct, NONE, s))
in
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 (x, n, c', s, pe', pc', ce', cc'), loc))))))
end
| DSequence _ => S.return2 dAll
| DView (x, n, s, e, c) =>
S.bind2 (mfe ctx e,
fn e' =>
S.map2 (mfc ctx c,
fn c' =>
(DView (x, n, s, e', c'), loc)))
| DDatabase _ => S.return2 dAll
| DCookie (x, n, c, s) =>
S.map2 (mfc ctx c,
fn c' =>
(DCookie (x, n, c', s), 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 e =>
S.map2 (mfe ctx e,
fn e' =>
(DPolicy e', loc))
| DOnError _ => S.return2 dAll
and mfvi ctx (x, n, t, e, s) =
S.bind2 (mfc ctx t,
fn t' =>
S.map2 (mfe ctx e,
fn e' =>
(x, n, t', e', s)))
in
mfd
end
fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} =
mapfoldB {kind = fn () => fk,
con = fn () => fc,
exp = fn () => fe,
decl = fn () => fd,
bind = fn ((), _) => ()} ()
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)),
exp = fn e => fn s => S.Continue (e, exp (e, s)),
decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
S.Continue (_, s) => s
| S.Return _ => raise Fail "CoreUtil.Decl.fold: Impossible"
fun foldMap {kind, con, exp, decl} s d =
case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)),
con = fn c => fn s => S.Continue (con (c, s)),
exp = fn e => fn s => S.Continue (exp (e, s)),
decl = fn d => fn s => S.Continue (decl (d, s))} d s of
S.Continue v => v
| S.Return _ => raise Fail "CoreUtil.Decl.foldMap: Impossible"
fun foldMapB {kind, con, exp, decl, bind} ctx s d =
case mapfoldB {kind = fn ctx => fn k => fn s => S.Continue (kind (ctx, k, s)),
con = fn ctx => fn c => fn s => S.Continue (con (ctx, c, s)),
exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)),
decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)),
bind = bind} ctx d s of
S.Continue v => v
| S.Return _ => raise Fail "CoreUtil.Decl.foldMapB: Impossible"
fun exists {kind, con, exp, decl} d =
case mapfold {kind = fn k => fn () =>
if kind k then
S.Return ()
else
S.Continue (k, ()),
con = fn c => fn () =>
if con c then
S.Return ()
else
S.Continue (c, ()),
exp = fn e => fn () =>
if exp e then
S.Return ()
else
S.Continue (e, ()),
decl = fn d => fn () =>
if decl d then
S.Return ()
else
S.Continue (d, ())} d () of
S.Return _ => true
| S.Continue _ => false
end
structure File = struct
datatype binder = datatype Exp.binder
fun mapfoldB (all as {bind, ...}) =
let
val mfd = Decl.mapfoldB all
fun mff ctx ds =
case ds of
nil => S.return2 nil
| d :: ds' =>
S.bind2 (mfd ctx d,
fn d' =>
let
val ctx' =
case #1 d' of
DCon (x, n, k, c) => bind (ctx, NamedC (x, n, k, SOME c))
| DDatatype dts =>
foldl (fn ((x, n, xs, xncs), ctx) =>
let
val loc = #2 d'
val k = (KType, loc)
val k' = foldl (fn (_, k') => (KArrow (k, k'), loc)) k xs
val ctx = bind (ctx, NamedC (x, n, k', NONE))
val t = (CNamed n, #2 d')
val t = ListUtil.foldli (fn (i, _, t) =>
(CApp (t, (CRel i, loc)), loc))
t xs
in
foldl (fn ((x, n, to), ctx) =>
let
val t = case to of
NONE => t
| SOME t' => (TFun (t', t), #2 d')
val t = foldr (fn (x, t) => (TCFun (x, k, t), loc))
t xs
in
bind (ctx, NamedE (x, n, t, NONE, ""))
end)
ctx xncs
end)
ctx dts
| DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
| DValRec vis =>
foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s)))
ctx vis
| DExport _ => ctx
| DTable (x, n, c, s, _, pc, _, cc) =>
let
val loc = #2 d'
val ct = (CFfi ("Basis", "sql_table"), loc)
val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc)
val ct = (CApp (ct, cc), loc)
in
bind (ctx, NamedE (x, n, ct, NONE, s))
end
| DSequence (x, n, s) =>
let
val t = (CFfi ("Basis", "sql_sequence"), #2 d')
in
bind (ctx, NamedE (x, n, t, NONE, s))
end
| DView (x, n, s, _, c) =>
let
val loc = #2 d'
val ct = (CFfi ("Basis", "sql_view"), loc)
val ct = (CApp (ct, c), loc)
in
bind (ctx, NamedE (x, n, ct, NONE, s))
end
| DDatabase _ => ctx
| DCookie (x, n, c, s) =>
let
val t = (CApp ((CFfi ("Basis", "http_cookie"), #2 d'), c), #2 d')
in
bind (ctx, NamedE (x, n, t, NONE, s))
end
| DStyle (x, n, s) =>
let
val t = (CFfi ("Basis", "css_class"), #2 d')
in
bind (ctx, NamedE (x, n, t, NONE, s))
end
| DTask _ => ctx
| DPolicy _ => ctx
| DOnError _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
d' :: ds')
end)
in
mff
end
fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} =
mapfoldB {kind = fn () => fk,
con = fn () => fc,
exp = fn () => fe,
decl = fn () => fd,
bind = fn ((), _) => ()} ()
fun mapB {kind, con, exp, decl, bind} ctx ds =
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 ds () of
S.Continue (ds, ()) => ds
| S.Return _ => raise Fail "CoreUtil.File.mapB: Impossible"
fun map {kind, con, exp, decl} ds =
mapB {kind = fn () => kind,
con = fn () => con,
exp = fn () => exp,
decl = fn () => decl,
bind = fn _ => ()} () ds
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)),
exp = fn e => fn s => S.Continue (e, exp (e, s)),
decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
S.Continue (_, s) => s
| S.Return _ => raise Fail "CoreUtil.File.fold: Impossible"
fun foldMap {kind, con, exp, decl} s d =
case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)),
con = fn c => fn s => S.Continue (con (c, s)),
exp = fn e => fn s => S.Continue (exp (e, s)),
decl = fn d => fn s => S.Continue (decl (d, s))} d s of
S.Continue v => v
| S.Return _ => raise Fail "CoreUtil.File.foldMap: Impossible"
val maxName = foldl (fn ((d, _) : decl, count) =>
case d of
DCon (_, n, _, _) => Int.max (n, count)
| DDatatype dts => foldl (fn ((_, n, _, ns), count) =>
foldl (fn ((_, n', _), m) => Int.max (n', m))
(Int.max (n, count)) ns) count dts
| DVal (_, n, _, _, _) => Int.max (n, count)
| DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
| DExport _ => count
| DTable (_, n, _, _, _, _, _, _) => Int.max (n, count)
| DSequence (_, n, _) => Int.max (n, count)
| DView (_, n, _, _, _) => Int.max (n, count)
| DDatabase _ => count
| DCookie (_, n, _, _) => Int.max (n, count)
| DStyle (_, n, _) => Int.max (n, count)
| DTask _ => count
| DPolicy _ => count
| DOnError _ => count) 0
end
end
urweb-20160213+dfsg/src/corify.sig 0000664 0000000 0000000 00000003064 12657647235 0016627 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 CORIFY = sig
val corify : Expl.file -> Core.file
end
urweb-20160213+dfsg/src/corify.sml 0000664 0000000 0000000 00000167424 12657647235 0016653 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-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 Corify :> CORIFY = struct
structure EM = ErrorMsg
structure L = Expl
structure L' = Core
structure IM = IntBinaryMap
structure SM = BinaryMapFn(struct
type ord_key = string
val compare = String.compare
end)
fun doRestify k (mods, s) =
let
val s = if String.isPrefix "wrap_" s then
String.extract (s, 5, NONE)
else
s
val s = String.concatWith "/" (rev (s :: mods))
val s = String.implode (List.filter (fn ch => ch <> #"$") (String.explode s))
in
Settings.rewrite k s
end
val relify = CharVector.map (fn #"/" => #"_"
| ch => ch)
local
val count = ref 0
in
fun reset v = count := v
fun alloc () =
let
val r = !count
in
count := r + 1;
r
end
fun getCounter () = !count
fun setCounter n = count := n
end
structure St : sig
type t
val empty : t
val debug : t -> unit
val name : t -> string list
val enter : t * string list -> t
val leave : t -> {outer : t, inner : t}
val ffi : string -> L'.con SM.map -> (string * string list * L'.con option * L'.datatype_kind) SM.map -> t
val basisIs : t * int -> t
val lookupBasis : t -> int option
datatype core_con =
CNormal of int
| CFfi of string
val bindCon : t -> string -> int -> t * int
val lookupConById : t -> int -> int option
val lookupConByName : t -> string -> core_con
val bindConstructor : t -> string -> int -> t * int
val bindConstructorAs : t -> string -> int -> L'.patCon -> t
val lookupConstructorByNameOpt : t -> string -> L'.patCon option
val lookupConstructorByName : t -> string -> L'.patCon
val lookupConstructorById : t -> int -> L'.patCon
val lookupConstructorByIdOpt : t -> int -> L'.patCon option
datatype core_val =
ENormal of int
| EFfi of string * L'.con
val bindVal : t -> string -> int -> t * int
val bindConstructorVal : t -> string -> int -> int -> t
val lookupValById : t -> int -> int option
val lookupValByName : t -> string -> core_val
val bindStr : t -> string -> int -> t -> t
val lookupStrById : t -> int -> t
val lookupStrByIdOpt : t -> int -> t option
val lookupStrByName : string * t -> t
val lookupStrByNameOpt : string * t -> t option
val bindFunctor : t -> string -> int -> string -> int -> L.str -> t
val lookupFunctorById : t -> int -> string * int * L.str
val lookupFunctorByIdOpt : t -> int -> (string * int * L.str) option
val lookupFunctorByName : string * t -> string * int * L.str
end = struct
datatype flattening =
FNormal of {name : string list,
cons : int SM.map,
constructors : L'.patCon SM.map,
vals : int SM.map,
strs : flattening SM.map,
funs : (string * int * L.str) SM.map}
| FFfi of {mod : string,
vals : L'.con SM.map,
constructors : (string * string list * L'.con option * L'.datatype_kind) SM.map}
type t = {
basis : int option,
cons : int IM.map,
constructors : L'.patCon IM.map,
vals : int IM.map,
strs : flattening IM.map,
funs : (string * int * L.str) IM.map,
current : flattening,
nested : flattening list
}
val empty = {
basis = NONE,
cons = IM.empty,
constructors = IM.empty,
vals = IM.empty,
strs = IM.empty,
funs = IM.empty,
current = FNormal { name = [], cons = SM.empty, constructors = SM.empty,
vals = SM.empty, strs = SM.empty, funs = SM.empty },
nested = []
}
fun debug ({current = FNormal {cons, constructors, vals, strs, funs, ...}, ...} : t) =
print ("cons: " ^ Int.toString (SM.numItems cons) ^ "; "
^ "constructors: " ^ Int.toString (SM.numItems constructors) ^ "; "
^ "vals: " ^ Int.toString (SM.numItems vals) ^ "; "
^ "strs: " ^ Int.toString (SM.numItems strs) ^ "; "
^ "funs: " ^ Int.toString (SM.numItems funs) ^ "\n")
| debug _ = print "Not normal!\n"
fun name ({current = FNormal {name, ...}, ...} : t) = name
| name {current = FFfi {mod = name, ...}, ...} = [name]
fun basisIs ({cons, constructors, vals, strs, funs, current, nested, ...} : t, basis) =
{basis = SOME basis,
cons = cons,
constructors = constructors,
vals = vals,
strs = strs,
funs = funs,
current = current,
nested = nested}
fun lookupBasis ({basis, ...} : t) = basis
datatype core_con =
CNormal of int
| CFfi of string
datatype core_val =
ENormal of int
| EFfi of string * L'.con
fun bindCon {basis, cons, constructors, vals, strs, funs, current, nested} s n =
let
val n' = alloc ()
val current =
case current of
FFfi _ => raise Fail "Binding inside FFfi"
| FNormal {name, cons, constructors, vals, strs, funs} =>
FNormal {name = name,
cons = SM.insert (cons, s, n'),
constructors = constructors,
vals = vals,
strs = strs,
funs = funs}
in
({basis = basis,
cons = IM.insert (cons, n, n'),
constructors = constructors,
vals = vals,
strs = strs,
funs = funs,
current = current,
nested = nested},
n')
end
fun lookupConById ({cons, ...} : t) n = IM.find (cons, n)
fun lookupConByName ({current, ...} : t) x =
case current of
FFfi {mod = m, ...} => CFfi m
| FNormal {cons, ...} =>
case SM.find (cons, x) of
NONE => raise Fail ("Corify.St.lookupConByName " ^ x)
| SOME n => CNormal n
fun bindVal {basis, cons, constructors, vals, strs, funs, current, nested} s n =
let
val n' = alloc ()
val current =
case current of
FFfi _ => raise Fail "Binding inside FFfi"
| FNormal {name, cons, constructors, vals, strs, funs} =>
FNormal {name = name,
cons = cons,
constructors = constructors,
vals = SM.insert (vals, s, n'),
strs = strs,
funs = funs}
in
({basis = basis,
cons = cons,
constructors = constructors,
vals = IM.insert (vals, n, n'),
strs = strs,
funs = funs,
current = current,
nested = nested},
n')
end
fun bindConstructorVal {basis, cons, constructors, vals, strs, funs, current, nested} s n n' =
let
val current =
case current of
FFfi _ => raise Fail "Binding inside FFfi"
| FNormal {name, cons, constructors, vals, strs, funs} =>
FNormal {name = name,
cons = cons,
constructors = constructors,
vals = SM.insert (vals, s, n'),
strs = strs,
funs = funs}
in
{basis = basis,
cons = cons,
constructors = constructors,
vals = IM.insert (vals, n, n'),
strs = strs,
funs = funs,
current = current,
nested = nested}
end
fun lookupValById ({vals, ...} : t) n = IM.find (vals, n)
fun lookupValByName ({current, ...} : t) x =
case current of
FFfi {mod = m, vals, ...} =>
(case SM.find (vals, x) of
NONE => raise Fail ("Corify.St.lookupValByName: no type for FFI val " ^ x)
| SOME t => EFfi (m, t))
| FNormal {name, vals, ...} =>
case SM.find (vals, x) of
NONE => raise Fail ("Corify.St.lookupValByName " ^ String.concatWith "." (rev name) ^ "." ^ x)
| SOME n => ENormal n
fun bindConstructorAs {basis, cons, constructors, vals, strs, funs, current, nested} s n c' =
let
val current =
case current of
FFfi _ => raise Fail "Binding inside FFfi"
| FNormal {name, cons, constructors, vals, strs, funs} =>
FNormal {name = name,
cons = cons,
constructors = SM.insert (constructors, s, c'),
vals = vals,
strs = strs,
funs = funs}
in
{basis = basis,
cons = cons,
constructors = IM.insert (constructors, n, c'),
vals = vals,
strs = strs,
funs = funs,
current = current,
nested = nested}
end
fun bindConstructor st s n =
let
val n' = alloc ()
val c' = L'.PConVar n'
in
(bindConstructorAs st s n c', n')
end
fun lookupConstructorById ({constructors, ...} : t) n =
case IM.find (constructors, n) of
NONE => raise Fail "Corify.St.lookupConstructorById"
| SOME x => x
fun lookupConstructorByIdOpt ({constructors, ...} : t) n =
IM.find (constructors, n)
fun lookupConstructorByNameOpt ({current, ...} : t) x =
case current of
FFfi {mod = m, constructors, ...} =>
(case SM.find (constructors, x) of
NONE => NONE
| SOME (n, xs, to, dk) => SOME (L'.PConFfi {mod = m, datatyp = n, params = xs, con = x, arg = to, kind = dk}))
| FNormal {constructors, ...} =>
case SM.find (constructors, x) of
NONE => NONE
| SOME n => SOME n
fun lookupConstructorByName ({current, ...} : t) x =
case current of
FFfi {mod = m, constructors, ...} =>
(case SM.find (constructors, x) of
NONE => raise Fail "Corify.St.lookupConstructorByName [1]"
| SOME (n, xs, to, dk) => L'.PConFfi {mod = m, datatyp = n, params = xs, con = x, arg = to, kind = dk})
| FNormal {constructors, ...} =>
case SM.find (constructors, x) of
NONE => raise Fail "Corify.St.lookupConstructorByName [2]"
| SOME n => n
fun enter ({basis, cons, constructors, vals, strs, funs, current, nested}, name) =
{basis = basis,
cons = cons,
constructors = constructors,
vals = vals,
strs = strs,
funs = funs,
current = FNormal {name = name,
cons = SM.empty,
constructors = SM.empty,
vals = SM.empty,
strs = SM.empty,
funs = SM.empty},
nested = current :: nested}
fun dummy (b, f) = {basis = b,
cons = IM.empty,
constructors = IM.empty,
vals = IM.empty,
strs = IM.empty,
funs = IM.empty,
current = f,
nested = []}
fun leave {basis, cons, constructors, vals, strs, funs, current, nested = m1 :: rest} =
{outer = {basis = basis,
cons = cons,
constructors = constructors,
vals = vals,
strs = strs,
funs = funs,
current = m1,
nested = rest},
inner = dummy (basis, current)}
| leave _ = raise Fail "Corify.St.leave"
fun ffi m vals constructors = dummy (NONE, FFfi {mod = m, vals = vals, constructors = constructors})
fun bindStr ({basis, cons, constructors, vals, strs, funs,
current = FNormal {name, cons = mcons, constructors = mconstructors,
vals = mvals, strs = mstrs, funs = mfuns}, nested} : t)
x n ({current = f, ...} : t) =
{basis = basis,
cons = cons,
constructors = constructors,
vals = vals,
strs = IM.insert (strs, n, f),
funs = funs,
current = FNormal {name = name,
cons = mcons,
constructors = mconstructors,
vals = mvals,
strs = SM.insert (mstrs, x, f),
funs = mfuns},
nested = nested}
| bindStr _ _ _ _ = raise Fail "Corify.St.bindStr"
fun lookupStrById ({basis, strs, ...} : t) n =
case IM.find (strs, n) of
NONE => raise Fail ("Corify.St.lookupStrById(" ^ Int.toString n ^ ")")
| SOME f => dummy (basis, f)
fun lookupStrByIdOpt ({basis, strs, ...} : t) n =
case IM.find (strs, n) of
NONE => NONE
| SOME f => SOME (dummy (basis, f))
fun lookupStrByName (m, {basis, current = FNormal {strs, ...}, ...} : t) =
(case SM.find (strs, m) of
NONE => raise Fail "Corify.St.lookupStrByName [1]"
| SOME f => dummy (basis, f))
| lookupStrByName _ = raise Fail "Corify.St.lookupStrByName [2]"
fun lookupStrByNameOpt (m, {basis, current = FNormal {strs, ...}, ...} : t) =
(case SM.find (strs, m) of
NONE => NONE
| SOME f => SOME (dummy (basis, f)))
| lookupStrByNameOpt _ = NONE
fun bindFunctor ({basis, cons, constructors, vals, strs, funs,
current = FNormal {name, cons = mcons, constructors = mconstructors,
vals = mvals, strs = mstrs, funs = mfuns}, nested} : t)
x n xa na str =
{basis = basis,
cons = cons,
constructors = constructors,
vals = vals,
strs = strs,
funs = IM.insert (funs, n, (xa, na, str)),
current = FNormal {name = name,
cons = mcons,
constructors = mconstructors,
vals = mvals,
strs = mstrs,
funs = SM.insert (mfuns, x, (xa, na, str))},
nested = nested}
| bindFunctor _ _ _ _ _ _ = raise Fail "Corify.St.bindFunctor"
fun lookupFunctorById ({funs, ...} : t) n =
case IM.find (funs, n) of
NONE => raise Fail "Corify.St.lookupFunctorById"
| SOME v => v
fun lookupFunctorByIdOpt ({funs, ...} : t) n =
IM.find (funs, n)
fun lookupFunctorByName (m, {current = FNormal {funs, ...}, ...} : t) =
(case SM.find (funs, m) of
NONE => raise Fail ("Corify.St.lookupFunctorByName " ^ m ^ "[1]")
| SOME v => v)
| lookupFunctorByName _ = raise Fail "Corify.St.lookupFunctorByName [2]"
end
fun corifyKind (k, loc) =
case k of
L.KType => (L'.KType, loc)
| L.KArrow (k1, k2) => (L'.KArrow (corifyKind k1, corifyKind k2), loc)
| L.KName => (L'.KName, loc)
| L.KRecord k => (L'.KRecord (corifyKind k), loc)
| L.KUnit => (L'.KUnit, loc)
| L.KTuple ks => (L'.KTuple (map corifyKind ks), loc)
| L.KRel n => (L'.KRel n, loc)
| L.KFun (x, k) => (L'.KFun (x, corifyKind k), loc)
fun corifyCon st (c, loc) =
case c of
L.TFun (t1, t2) => (L'.TFun (corifyCon st t1, corifyCon st t2), loc)
| L.TCFun (x, k, t) => (L'.TCFun (x, corifyKind k, corifyCon st t), loc)
| L.TKFun (x, t) => (L'.TKFun (x, corifyCon st t), loc)
| L.TRecord c => (L'.TRecord (corifyCon st c), loc)
| L.CRel n => (L'.CRel n, loc)
| L.CNamed n =>
(case St.lookupConById st n of
NONE => (L'.CNamed n, loc)
| SOME n => (L'.CNamed n, loc))
| L.CModProj (m, ms, x) =>
let
val st = St.lookupStrById st m
val st = foldl St.lookupStrByName st ms
in
case St.lookupConByName st x of
St.CNormal n => (L'.CNamed n, loc)
| St.CFfi m =>
if (m, x) = ("Basis", "unit") then
(L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)
else
(L'.CFfi (m, x), loc)
end
| L.CApp (c1, c2) => (L'.CApp (corifyCon st c1, corifyCon st c2), loc)
| L.CAbs (x, k, c) => (L'.CAbs (x, corifyKind k, corifyCon st c), loc)
| L.CKApp (c1, k) => (L'.CKApp (corifyCon st c1, corifyKind k), loc)
| L.CKAbs (x, c) => (L'.CKAbs (x, corifyCon st c), loc)
| L.CName s => (L'.CName s, loc)
| L.CRecord (k, xcs) =>
(L'.CRecord (corifyKind k, map (fn (c1, c2) => (corifyCon st c1, corifyCon st c2)) xcs), loc)
| L.CConcat (c1, c2) => (L'.CConcat (corifyCon st c1, corifyCon st c2), loc)
| L.CMap (k1, k2) => (L'.CMap (corifyKind k1, corifyKind k2), loc)
| L.CUnit => (L'.CUnit, loc)
| L.CTuple cs => (L'.CTuple (map (corifyCon st) cs), loc)
| L.CProj (c, n) => (L'.CProj (corifyCon st c, n), loc)
fun corifyPatCon st pc =
case pc of
L.PConVar n => St.lookupConstructorById st n
| L.PConProj (m1, ms, x) =>
let
val st = St.lookupStrById st m1
val st = foldl St.lookupStrByName st ms
in
St.lookupConstructorByName st x
end
fun corifyPat st (p, loc) =
case p of
L.PVar (x, t) => (L'.PVar (x, corifyCon st t), loc)
| L.PPrim p => (L'.PPrim p, loc)
| L.PCon (dk, pc, ts, po) => (L'.PCon (dk, corifyPatCon st pc, map (corifyCon st) ts,
Option.map (corifyPat st) po), loc)
| L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, corifyPat st p, corifyCon st t)) xps), loc)
fun corifyExp st (e, loc) =
case e of
L.EPrim p => (L'.EPrim p, loc)
| L.ERel n => (L'.ERel n, loc)
| L.ENamed n =>
(case St.lookupValById st n of
NONE => (L'.ENamed n, loc)
| SOME n => (L'.ENamed n, loc))
| L.EModProj (m, ms, x) =>
let
val st = St.lookupStrById st m
val st = foldl St.lookupStrByName st ms
in
case St.lookupConstructorByNameOpt st x of
SOME (pc as L'.PConFfi {mod = m, datatyp, params, arg, kind, ...}) =>
let
val args = ListUtil.mapi (fn (i, _) => (L'.CRel i, loc)) params
val e = case arg of
NONE => (L'.ECon (kind, pc, args, NONE), loc)
| SOME dom => (L'.EAbs ("x", dom, (L'.CFfi (m, datatyp), loc),
(L'.ECon (kind, pc, args, SOME (L'.ERel 0, loc)), loc)), loc)
val k = (L'.KType, loc)
in
foldr (fn (x, e) => (L'.ECAbs (x, k, e), loc)) e params
end
| _ =>
case St.lookupValByName st x of
St.ENormal n => (L'.ENamed n, loc)
| St.EFfi (m, t) =>
case t of
(L'.CApp ((L'.CFfi ("Basis", "transaction"), _), dom), _) =>
(L'.EAbs ("arg", dom, (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc),
(L'.EFfiApp (m, x, []), loc)), loc)
| t as (L'.TFun _, _) =>
let
fun getArgs (all as (t, _), args) =
case t of
L'.TFun (dom, ran) => getArgs (ran, dom :: args)
| _ => (all, rev args)
val (result, args) = getArgs (t, [])
val (isTransaction, result) =
case result of
(L'.CApp ((L'.CFfi ("Basis", "transaction"), _),
result), _) => (true, result)
| _ => (false, result)
fun makeApp n =
let
val (actuals, _) = foldr (fn (t, (actuals, n)) =>
(((L'.ERel n, loc), t) :: actuals,
n + 1)) ([], n) args
in
(L'.EFfiApp (m, x, actuals), loc)
end
val unit = (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)
val (result, app) =
if isTransaction then
((L'.TFun (unit, result), loc),
(L'.EAbs ("_",
unit,
result,
makeApp 1), loc))
else
(result, makeApp 0)
val (abs, _, _) = foldr (fn (t, (abs, ran, n)) =>
((L'.EAbs ("arg" ^ Int.toString n,
t,
ran,
abs), loc),
(L'.TFun (t, ran), loc),
n - 1)) (app, result, length args - 1) args
in
abs
end
| _ => (L'.EFfi (m, x), loc)
end
| L.EApp (e1, e2) => (L'.EApp (corifyExp st e1, corifyExp st e2), loc)
| L.EAbs (x, dom, ran, e1) => (L'.EAbs (x, corifyCon st dom, corifyCon st ran, corifyExp st e1), loc)
| L.ECApp (e1, c) => (L'.ECApp (corifyExp st e1, corifyCon st c), loc)
| L.ECAbs (x, k, e1) => (L'.ECAbs (x, corifyKind k, corifyExp st e1), loc)
| L.EKApp (e1, k) => (L'.EKApp (corifyExp st e1, corifyKind k), loc)
| L.EKAbs (x, e1) => (L'.EKAbs (x, corifyExp st e1), loc)
| L.ERecord xes => (L'.ERecord (map (fn (c, e, t) =>
(corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc)
| L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c,
{field = corifyCon st field, rest = corifyCon st rest}), loc)
| L.EConcat (e1, c1, e2, c2) => (L'.EConcat (corifyExp st e1, corifyCon st c1, corifyExp st e2,
corifyCon st c2), loc)
| L.ECut (e1, c, {field, rest}) => (L'.ECut (corifyExp st e1, corifyCon st c,
{field = corifyCon st field, rest = corifyCon st rest}), loc)
| L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (corifyExp st e1, corifyCon st c,
{rest = corifyCon st rest}), loc)
| L.ECase (e, pes, {disc, result}) =>
(L'.ECase (corifyExp st e,
map (fn (p, e) => (corifyPat st p, corifyExp st e)) pes,
{disc = corifyCon st disc, result = corifyCon st result}),
loc)
| L.EWrite e => (L'.EWrite (corifyExp st e), loc)
| L.ELet (x, t, e1, e2) => (L'.ELet (x, corifyCon st t, corifyExp st e1, corifyExp st e2), loc)
fun isTransactional (c, _) =
case c of
L'.TFun (_, c) => isTransactional c
| L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true
| _ => false
fun corifyDecl mods (all as (d, loc : EM.span), st) =
case d of
L.DCon (x, n, k, c) =>
let
val (st, n) = St.bindCon st x n
in
([(L'.DCon (x, n, corifyKind k, corifyCon st c), loc)], st)
end
| L.DDatatype dts =>
let
val (dts, st) = ListUtil.foldlMap (fn ((x, n, xs, xncs), st) =>
let
val (st, n) = St.bindCon st x n
in
((x, n, xs, xncs), st)
end)
st dts
val (dts, (st, dcons)) =
ListUtil.foldlMap
(fn ((x, n, xs, xncs), (st, dcons)) =>
let
val (xncs, st) = ListUtil.foldlMap
(fn ((x, n, co), st) =>
let
val (st, n') = St.bindConstructor st x n
val st = St.bindConstructorVal st x n n'
val co = Option.map (corifyCon st) co
in
((x, n', co), st)
end) st xncs
val dk = ElabUtil.classifyDatatype xncs
val t = (L'.CNamed n, loc)
val nxs = length xs - 1
val t = ListUtil.foldli
(fn (i, _, t) => (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs
val k = (L'.KType, loc)
val dcons' = map (fn (x, n, to) =>
let
val args = ListUtil.mapi
(fn (i, _) => (L'.CRel (nxs - i), loc)) xs
val (e, t) =
case to of
NONE => ((L'.ECon (dk, L'.PConVar n, args, NONE),
loc), t)
| SOME t' => ((L'.EAbs ("x", t', t,
(L'.ECon (dk, L'.PConVar n,
args,
SOME (L'.ERel 0,
loc)),
loc)),
loc),
(L'.TFun (t', t), loc))
val t = foldr (fn (x, t) => (L'.TCFun (x, k, t), loc)) t xs
val e = foldr (fn (x, e) => (L'.ECAbs (x, k, e), loc)) e xs
in
(L'.DVal (x, n, t, e, ""), loc)
end) xncs
in
((x, n, xs, xncs), (st, dcons' @ dcons))
end)
(st, []) dts
in
((L'.DDatatype dts, loc) :: dcons, st)
end
| L.DDatatypeImp (x, n, m1, ms, s, xs, xncs) =>
let
val (st, n) = St.bindCon st x n
val c = corifyCon st (L.CModProj (m1, ms, s), loc)
val m = foldl (fn (x, m) => (L.StrProj (m, x), loc)) (L.StrVar m1, loc) ms
val (_, {inner, ...}) = corifyStr mods (m, st)
val (xncs, st) = ListUtil.foldlMap (fn ((x, n, co), st) =>
let
val n' = St.lookupConstructorByName inner x
val st = St.bindConstructorAs st x n n'
val (st, n) = St.bindVal st x n
val co = Option.map (corifyCon st) co
in
((x, n, co), st)
end) st xncs
val nxs = length xs - 1
val cBase = c
val c = ListUtil.foldli (fn (i, _, c) => (L'.CApp (c, (L'.CRel (nxs - i), loc)), loc)) c xs
val k = (L'.KType, loc)
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
val cds = map (fn (x, n, co) =>
let
val t = case co of
NONE => c
| SOME t' => (L'.TFun (t', c), loc)
val e = corifyExp st (L.EModProj (m1, ms, x), loc)
val t = foldr (fn (x, t) => (L'.TCFun (x, k, t), loc)) t xs
in
(L'.DVal (x, n, t, e, x), loc)
end) xncs
in
((L'.DCon (x, n, k', cBase), loc) :: cds, st)
end
| L.DVal (x, n, t, e as (L.ENamed n', _)) =>
let
val st =
case St.lookupConstructorByIdOpt st n' of
SOME pc => St.bindConstructorAs st x n pc
| _ => st
val (st, n) = St.bindVal st x n
val s = doRestify Settings.Url (mods, x)
in
([(L'.DVal (x, n, corifyCon st t, corifyExp st e, s), loc)], st)
end
| L.DVal (x, n, t, e) =>
let
val (st, n) = St.bindVal st x n
val s = doRestify Settings.Url (mods, x)
in
([(L'.DVal (x, n, corifyCon st t, corifyExp st e, s), loc)], st)
end
| L.DValRec vis =>
let
val (vis, st) = ListUtil.foldlMap
(fn ((x, n, t, e), st) =>
let
val (st, n) = St.bindVal st x n
in
((x, n, t, e), st)
end)
st vis
val vis = map
(fn (x, n, t, e) =>
let
val s = doRestify Settings.Url (mods, x)
in
(x, n, corifyCon st t, corifyExp st e, s)
end)
vis
in
([(L'.DValRec vis, loc)], st)
end
| L.DSgn _ => ([], st)
| L.DStr (x, n, _, (L.StrFun (xa, na, _, _, str), _)) =>
([], St.bindFunctor st x n xa na str)
| L.DStr (x, n, _, (L.StrProj (str, x'), _)) =>
let
val (ds, {inner, outer}) = corifyStr mods (str, st)
val st = case St.lookupStrByNameOpt (x', inner) of
SOME st' => St.bindStr st x n st'
| NONE =>
let
val (x', n', str') = St.lookupFunctorByName (x', inner)
in
St.bindFunctor st x n x' n' str'
end
in
([], st)
end
| L.DStr (x, n, _, (L.StrVar n', _)) =>
(case St.lookupFunctorByIdOpt st n' of
SOME (arg, dom, body) => ([], St.bindFunctor st x n arg dom body)
| NONE => ([], St.bindStr st x n (St.lookupStrById st n')))
| L.DStr (x, n, _, str) =>
let
val mods' =
if x = "anon" then
mods
else
x :: mods
val (ds, {inner, outer}) = corifyStr mods' (str, st)
val st = St.bindStr outer x n inner
in
(ds, st)
end
| L.DFfiStr (m, n, (sgn, _)) =>
(case sgn of
L.SgnConst sgis =>
let
val (ds, cmap, conmap, st, _) =
foldl (fn ((sgi, _), (ds, cmap, conmap, st, trans)) =>
case sgi of
L.SgiConAbs (x, n, k) =>
let
val (st, n') = St.bindCon st x n
val trans =
if x = "transaction" then
SOME n
else
trans
in
((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds,
cmap,
conmap,
st,
trans)
end
| L.SgiCon (x, n, k, _) =>
let
val (st, n') = St.bindCon st x n
in
((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds,
cmap,
conmap,
st,
trans)
end
| L.SgiDatatype dts =>
let
val k = (L'.KType, loc)
val (dts, (ds', st, cmap, conmap)) =
ListUtil.foldlMap
(fn ((x, n, xs, xnts), (ds', st, cmap, conmap)) =>
let
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc))
k xs
val dk = ElabUtil.classifyDatatype xnts
val (st, n') = St.bindCon st x n
val (xnts, (ds', st, cmap, conmap)) =
ListUtil.foldlMap
(fn ((x', n, to), (ds', st, cmap, conmap)) =>
let
val dt = (L'.CNamed n', loc)
val args = ListUtil.mapi (fn (i, _) => (L'.CRel i, loc)) xs
val to = Option.map (corifyCon st) to
val pc = L'.PConFfi {mod = m,
datatyp = x,
params = xs,
con = x',
arg = to,
kind = dk}
fun wrapT t =
foldr (fn (x, t) => (L'.TCFun (x, k, t), loc))
t xs
fun wrapE e =
foldr (fn (x, e) => (L'.ECAbs (x, k, e), loc))
e xs
val (cmap, d) =
case to of
NONE => (SM.insert (cmap, x', wrapT dt),
(L'.DVal (x', n, wrapT dt,
wrapE
(L'.ECon (dk, pc,
args,
NONE),
loc),
""), loc))
| SOME t =>
let
val tf = (L'.TFun (t, dt), loc)
val e = wrapE
(L'.EAbs ("x", t, tf,
(L'.ECon (dk,
pc,
args,
SOME
(L'.ERel 0,
loc)),
loc)), loc)
val d = (L'.DVal (x', n, wrapT tf,
e, ""), loc)
in
(SM.insert (cmap, x', wrapT tf), d)
end
val st = St.bindConstructorAs st x' n pc
val conmap = SM.insert (conmap, x',
(x, xs, to, dk))
in
((x', n, to),
(d :: ds', st, cmap, conmap))
end) (ds', st, cmap, conmap) xnts
val d = (L'.DCon (x, n', k', (L'.CFfi (m, x), loc)), loc)
in
((x, n', xs, xnts), (d :: ds', st, cmap, conmap))
end)
([], st, cmap, conmap) dts
in
(List.revAppend (ds', ds),
cmap,
conmap,
st,
trans)
end
| L.SgiVal (x, _, c) =>
let
val c =
case trans of
NONE => corifyCon st c
| SOME trans =>
let
fun transactify (all as (c, loc)) =
case c of
L.TFun (dom, ran) =>
(L'.TFun (corifyCon st dom, transactify ran), loc)
| L.CApp ((L.CNamed trans', _), t) =>
if trans' = trans then
(L'.CApp ((L'.CFfi (m, "transaction"), loc),
corifyCon st t), loc)
else
corifyCon st all
| _ => corifyCon st all
in
transactify c
end
in
if isTransactional c then
let
val ffi = (m, x)
in
if Settings.isBenignEffectful ffi then
()
else
Settings.addEffectful ffi
end
else
();
(ds,
SM.insert (cmap, x, c),
conmap,
st,
trans)
end
| _ => (ds, cmap, conmap, st, trans))
([], SM.empty, SM.empty, st, NONE) sgis
val st = St.bindStr st m n (St.ffi m cmap conmap)
in
(rev ds, if m = "Basis" then St.basisIs (st, n) else st)
end
| _ => raise Fail "Non-const signature for FFI structure")
| L.DExport (en, sgn, str) =>
(case #1 sgn of
L.SgnConst sgis =>
let
fun pathify (str, _) =
case str of
L.StrVar m => SOME (m, [])
| L.StrProj (str, s) =>
Option.map (fn (m, ms) => (m, ms @ [s])) (pathify str)
| _ => NONE
in
case pathify str of
NONE => (ErrorMsg.errorAt loc "Structure is too fancy to export";
([], st))
| SOME (m, ms) =>
let
val basis_n = case St.lookupBasis st of
NONE => raise Fail "Corify: Don't know number of Basis"
| SOME n => n
fun wrapSgi ((sgi, _), (wds, eds)) =
case sgi of
L.SgiVal (s, _, t) =>
let
fun getPage (t, args) =
case #1 t of
L.CApp ((L.CModProj (basis, [], "transaction"), _),
t' as
(L.CApp
((L.CApp
((L.CApp ((L.CModProj (basis', [], "xml"), _),
(L.CRecord (_, [((L.CName "Html", _),
_)]), _)), _), _),
_), _), _)) =>
if basis = basis_n andalso basis' = basis_n then
SOME (t', rev args)
else
NONE
| L.TFun (dom, ran) => getPage (ran, dom :: args)
| _ => NONE
in
case getPage (t, []) of
NONE => (wds, eds)
| SOME (ran', args) =>
let
val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc)
val ranT = (L.CApp ((L.CModProj (basis_n, [], "transaction"), loc),
ran), loc)
val e = (L.EModProj (m, ms, s), loc)
val ef = (L.EModProj (basis_n, [], "bind"), loc)
val ef = (L.ECApp (ef, (L.CModProj (basis_n, [], "transaction"), loc)), loc)
val ef = (L.ECApp (ef, ran'), loc)
val ef = (L.ECApp (ef, ran), loc)
val ef = (L.EApp (ef, (L.EModProj (basis_n, [], "transaction_monad"), loc)),
loc)
val ea = ListUtil.foldri (fn (i, _, ea) =>
(L.EApp (ea, (L.ERel i, loc)), loc)) e args
val ef = (L.EApp (ef, ea), loc)
val eat = (L.CApp ((L.CModProj (basis_n, [], "transaction"), loc),
ran), loc)
val ea = (L.EAbs ("p", ran', eat,
(L.EWrite (L.ERel 0, loc), loc)), loc)
val (e, tf) = ListUtil.foldri (fn (i, t, (e, tf)) =>
((L.EAbs ("x" ^ Int.toString i,
t, tf, e), loc),
(L.TFun (t, tf), loc)))
((L.EApp (ef, ea), loc), ranT) args
val expKind = if List.exists (fn t =>
case corifyCon st t of
(L'.CFfi ("Basis", "postBody"), _) => true
| _ => false) args then
L'.Extern L'.ReadCookieWrite
else
L'.Link L'.ReadCookieWrite
in
((L.DVal ("wrap_" ^ s, 0, tf, e), loc) :: wds,
(fn st =>
case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of
L'.ENamed n => (L'.DExport (expKind, n, false), loc)
| _ => raise Fail "Corify: Value to export didn't corify properly")
:: eds)
end
end
| _ => (wds, eds)
val (wds, eds) = foldl wrapSgi ([], []) sgis
val wrapper = (L.StrConst wds, loc)
val mst = St.lookupStrById st m
val mst = foldl St.lookupStrByName mst ms
val (ds, {inner, outer}) = corifyStr (St.name mst) (wrapper, st)
val st = St.bindStr outer "wrapper" en inner
val ds = ds @ map (fn f => f st) eds
in
(ds, st)
end
end
| _ => raise Fail "Non-const signature for 'export'")
| L.DTable (_, x, n, c, pe, pc, ce, cc) =>
let
val (st, n) = St.bindVal st x n
val s = relify (doRestify Settings.Table (mods, x))
in
([(L'.DTable (x, n, corifyCon st c, s,
corifyExp st pe, corifyCon st pc,
corifyExp st ce, corifyCon st cc), loc)], st)
end
| L.DSequence (_, x, n) =>
let
val (st, n) = St.bindVal st x n
val s = relify (doRestify Settings.Sequence (mods, x))
in
([(L'.DSequence (x, n, s), loc)], st)
end
| L.DView (_, x, n, e, c) =>
let
val (st, n) = St.bindVal st x n
val s = relify (doRestify Settings.View (mods, x))
in
([(L'.DView (x, n, s, corifyExp st e, corifyCon st c), loc)], st)
end
| L.DDatabase s => ([(L'.DDatabase s, loc)], st)
| L.DCookie (_, x, n, c) =>
let
val (st, n) = St.bindVal st x n
val s = doRestify Settings.Cookie (mods, x)
in
([(L'.DCookie (x, n, corifyCon st c, s), loc)], st)
end
| L.DStyle (_, x, n) =>
let
val (st, n) = St.bindVal st x n
val s = relify (doRestify Settings.Style (mods, x))
in
([(L'.DStyle (x, n, s), loc)], st)
end
| L.DTask (e1, e2) =>
([(L'.DTask (corifyExp st e1, corifyExp st e2), loc)], st)
| L.DPolicy e1 =>
([(L'.DPolicy (corifyExp st e1), loc)], st)
| L.DOnError (m, ms, x) =>
let
val st = St.lookupStrById st m
val st = foldl St.lookupStrByName st ms
in
case St.lookupValByName st x of
St.ENormal n => ([(L'.DOnError n, loc)], st)
| _ => (ErrorMsg.errorAt loc "Wrong type of identifier for 'onError'";
([], st))
end
| L.DFfi (x, n, modes, t) =>
let
val m = case St.name st of
[m] => m
| _ => (ErrorMsg.errorAt loc "Used 'ffi' declaration beneath module top level";
"")
val name = (m, x)
val (st, n) = St.bindVal st x n
val s = doRestify Settings.Url (mods, x)
val t' = corifyCon st t
fun numArgs (t : L'.con) =
case #1 t of
L'.TFun (_, ran) => 1 + numArgs ran
| _ => 0
fun makeArgs (i, t : L'.con, acc) =
case #1 t of
L'.TFun (dom, ran) => makeArgs (i-1, ran, ((L'.ERel i, loc), dom) :: acc)
| _ => rev acc
fun wrapAbs (i, t : L'.con, tTrans, e) =
case (#1 t, #1 tTrans) of
(L'.TFun (dom, ran), L'.TFun (_, ran')) => (L'.EAbs ("x" ^ Int.toString i, dom, ran, wrapAbs (i+1, ran, ran', e)), loc)
| _ => e
fun getRan (t : L'.con) =
case #1 t of
L'.TFun (_, ran) => getRan ran
| _ => t
fun addLastBit (t : L'.con) =
case #1 t of
L'.TFun (dom, ran) => (L'.TFun (dom, addLastBit ran), #2 t)
| _ => (L'.TFun ((L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), t), loc)
val isTrans = isTransactional t'
val e = (L'.EFfiApp (m, x, makeArgs (numArgs t' -
(if isTrans then
0
else
1), t', [])), loc)
val (e, tTrans) = if isTrans then
((L'.EAbs ("_", (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), getRan t', e), loc), addLastBit t')
else
(e, t')
val e = wrapAbs (0, t', tTrans, e)
in
app (fn Source.Effectful => Settings.addEffectful name
| Source.BenignEffectful => Settings.addBenignEffectful name
| Source.ClientOnly => Settings.addClientOnly name
| Source.ServerOnly => Settings.addServerOnly name
| Source.JsFunc s => Settings.addJsFunc (name, s)) modes;
if List.exists (fn Source.JsFunc _ => true | _ => false) modes then
()
else
Settings.addJsFunc (name, #2 name);
if isTrans andalso not (Settings.isBenignEffectful name) then
Settings.addEffectful name
else
();
([(L'.DVal (x, n, t', e, s), loc)], st)
end
and corifyStr mods ((str, loc), st) =
case str of
L.StrConst ds =>
let
val st = St.enter (st, mods)
val (ds, st) = ListUtil.foldlMapConcat (corifyDecl mods) st ds
in
(ds, St.leave st)
end
| L.StrVar n => ([], {inner = St.lookupStrById st n, outer = st})
| L.StrProj (str, x) =>
let
val (ds, {inner, outer}) = corifyStr mods (str, st)
in
(ds, {inner = St.lookupStrByName (x, inner), outer = outer})
end
| L.StrFun _ => raise Fail "Corify of nested functor definition"
| L.StrApp (str1, str2) =>
let
fun unwind' (str, _) =
case str of
L.StrVar n => St.lookupStrById st n
| L.StrProj (str, x) => St.lookupStrByName (x, unwind' str)
| _ => raise Fail "Corify of fancy functor application [1]"
fun unwind (str, _) =
case str of
L.StrVar n => St.lookupFunctorById st n
| L.StrProj (str, x) => St.lookupFunctorByName (x, unwind' str)
| _ => raise Fail "Corify of fancy functor application [2]"
val (xa, na, body) = unwind str1
(* An important step to make sure that nested functors
* "close under their environments": *)
val (next, body') = ExplRename.rename {NextId = getCounter (),
FormalName = xa,
FormalId = na,
Body = body}
(*val () = Print.prefaces ("RENAME " ^ ErrorMsg.spanToString loc)
[("FROM", ExplPrint.p_str ExplEnv.empty body),
("TO", ExplPrint.p_str ExplEnv.empty body')]*)
val body = body'
val () = setCounter next
val (ds1, {inner = inner', outer}) = corifyStr mods (str2, st)
val (ds2, {inner, outer}) = corifyStr mods (body, St.bindStr outer xa na inner')
in
(ds1 @ ds2, {inner = St.bindStr inner xa na inner', outer = outer})
end
fun maxName ds = foldl (fn ((d, _), n) =>
case d of
L.DCon (_, n', _, _) => Int.max (n, n')
| L.DDatatype dts => foldl (fn ((_, n', _, _), n) => Int.max (n, n')) n dts
| L.DDatatypeImp (_, n', _, _, _, _, _) => Int.max (n, n')
| L.DVal (_, n', _, _) => Int.max (n, n')
| L.DValRec vis => foldl (fn ((_, n', _, _), n) => Int.max (n, n)) n vis
| L.DSgn (_, n', _) => Int.max (n, n')
| L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str))
| L.DFfiStr (_, n', _) => Int.max (n, n')
| L.DExport _ => n
| L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n')
| L.DSequence (_, _, n') => Int.max (n, n')
| L.DView (_, _, n', _, _) => Int.max (n, n')
| L.DDatabase _ => n
| L.DCookie (_, _, n', _) => Int.max (n, n')
| L.DStyle (_, _, n') => Int.max (n, n')
| L.DTask _ => n
| L.DPolicy _ => n
| L.DOnError _ => n
| L.DFfi (_, n', _, _) => Int.max (n, n'))
0 ds
and maxNameStr (str, _) =
case str of
L.StrConst ds => maxName ds
| L.StrVar n => n
| L.StrProj (str, _) => maxNameStr str
| L.StrFun (_, _, _, _, str) => maxNameStr str
| L.StrApp (str1, str2) => Int.max (maxNameStr str1, maxNameStr str2)
fun corify ds =
let
val () = reset (maxName ds + 1)
val (ds, _) = ListUtil.foldlMapConcat (corifyDecl []) St.empty ds
in
ds
end
end
urweb-20160213+dfsg/src/css.sig 0000664 0000000 0000000 00000003720 12657647235 0016123 0 ustar 00root root 0000000 0000000 (* Copyright (c) 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.
*)
signature CSS = sig
datatype inheritable = Block | List | Table | Caption | Td
datatype others = OBlock | OTable | OTd | Tr | NonReplacedInline | ReplacedInline | Width | Height
val inheritableToString : inheritable -> string
val othersToString : others -> string
type summary = inheritable list * others list
type report = {Overall : inheritable list,
Classes : (string * summary) list}
val summarize : Core.file -> report
end
urweb-20160213+dfsg/src/css.sml 0000664 0000000 0000000 00000032567 12657647235 0016147 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2010, 2013, 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 Css :> CSS = struct
structure IM = IntBinaryMap
structure SM = BinaryMapFn(struct
type ord_key = string
val compare = String.compare
end)
datatype inheritable = Block | List | Table | Caption | Td
datatype others = OBlock | OTable | OTd | Tr | NonReplacedInline | ReplacedInline | Width | Height
fun inheritableToString x =
case x of
Block => "B"
| List => "L"
| Table => "T"
| Caption => "C"
| Td => "D"
fun othersToString x =
case x of
OBlock => "b"
| OTable => "t"
| OTd => "d"
| Tr => "-"
| NonReplacedInline => "N"
| ReplacedInline => "R"
| Width => "W"
| Height => "H"
type summary = inheritable list * others list
fun merge' (ls1, ls2) = foldl (fn (x, ls) => if List.exists (fn y => y = x) ls then ls else x :: ls) ls2 ls1
fun merge ((in1, ot1), (in2, ot2)) = (merge' (in1, in2), merge' (ot1, ot2))
fun mergePC {parent = (in1, ot1), child = in2} = (merge' (in1, in2), ot1)
val nada = ([], [])
val block = ([Block], [OBlock, Width, Height])
val inline = ([], [NonReplacedInline])
val list = ([Block, List], [OBlock, Width, Height])
val replaced = ([], [ReplacedInline, Width, Height])
val table = ([Block, Table], [OBlock, OTable, Width, Height])
val tr = ([Block], [OBlock, Tr, Height])
val td = ([Block, Td], [OBlock, OTd, Width])
val tags = [("span", inline),
("div", block),
("p", block),
("b", inline),
("i", inline),
("tt", inline),
("h1", block),
("h2", block),
("h3", block),
("h4", block),
("h5", block),
("h6", block),
("li", list),
("ol", list),
("ul", list),
("hr", block),
("a", inline),
("img", replaced),
("form", block),
("hidden", replaced),
("textbox", replaced),
("password", replaced),
("textarea", replaced),
("checkbox", replaced),
("upload", replaced),
("radio", replaced),
("select", replaced),
("submit", replaced),
("label", inline),
("ctextbox", replaced),
("cpassword", replaced),
("button", replaced),
("ccheckbox", replaced),
("cselect", replaced),
("ctextarea", replaced),
("tabl", table),
("tr", tr),
("th", td),
("td", td)]
val tags = foldl (fn ((tag, css), tags) =>
SM.insert (tags, tag, css)) SM.empty tags
open Core
fun summarize file =
let
fun decl ((d, _), st as (globals, classes)) =
let
fun getTag (e, _) =
case e of
EFfi ("Basis", tag) => SOME tag
| ECApp (e, _) => getTag e
| EApp (e, _) => getTag e
| _ => NONE
fun exp ((e, _), classes) =
case e of
EPrim _ => ([], classes)
| ERel _ => ([], classes)
| ENamed n =>
(case IM.find (globals, n) of
NONE => []
| SOME (_, sm) => sm,
classes)
| ECon (_, _, _, NONE) => ([], classes)
| ECon (_, _, _, SOME e) => exp (e, classes)
| EFfi _ => ([], classes)
| EFfiApp (_, _, es) => expList (map #1 es, classes)
| EApp (
(EApp (
(EApp (
(EApp (
(EApp (
(EApp (
(EApp (
(ECApp (
(ECApp (
(ECApp (
(ECApp (
(ECApp (
(ECApp (
(ECApp (
(ECApp (
(EFfi ("Basis", "tag"),
_), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
(ENamed class, _)), _),
_), _),
_), _),
_), _),
attrs), _),
tag), _),
xml) =>
let
val (sm, classes) = exp (xml, classes)
val (sm', classes) = exp (attrs, classes)
val sm = merge' (sm, sm')
in
case getTag tag of
NONE => (sm, classes)
| SOME tag =>
case SM.find (tags, tag) of
NONE => (sm, classes)
| SOME sm' =>
let
val sm'' = mergePC {parent = sm', child = sm}
val old = Option.getOpt (IM.find (classes, class), nada)
val classes = IM.insert (classes, class, merge (old, sm''))
in
(merge' (#1 sm', sm), classes)
end
end
| EApp (
(EApp (
(EApp (
(EApp (
(EApp (
(EApp (
(EApp (
(ECApp (
(ECApp (
(ECApp (
(ECApp (
(ECApp (
(ECApp (
(ECApp (
(ECApp (
(EFfi ("Basis", "tag"),
_), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
_), _),
_), _),
_), _),
_), _),
attrs), _),
tag), _),
xml) =>
let
val (sm, classes) = exp (xml, classes)
val (sm', classes) = exp (attrs, classes)
val sm = merge' (sm, sm')
in
case getTag tag of
NONE => (sm, classes)
| SOME tag =>
case SM.find (tags, tag) of
NONE => (sm, classes)
| SOME sm' => (merge' (#1 sm', sm), classes)
end
| EApp (e1, e2) =>
let
val (sm1, classes) = exp (e1, classes)
val (sm2, classes) = exp (e2, classes)
in
(merge' (sm1, sm2), classes)
end
| EAbs (_, _, _, e) => exp (e, classes)
| ECApp (e, _) => exp (e, classes)
| ECAbs (_, _, e) => exp (e, classes)
| EKAbs (_, e) => exp (e, classes)
| EKApp (e, _) => exp (e, classes)
| ERecord xets => expList (map #2 xets, classes)
| EField (e, _, _) => exp (e, classes)
| EConcat (e1, _, e2, _) =>
let
val (sm1, classes) = exp (e1, classes)
val (sm2, classes) = exp (e2, classes)
in
(merge' (sm1, sm2), classes)
end
| ECut (e, _, _) => exp (e, classes)
| ECutMulti (e, _, _) => exp (e, classes)
| ECase (e, pes, _) =>
let
val (sm, classes) = exp (e, classes)
val (sms, classes) = expList (map #2 pes, classes)
in
(merge' (sm, sms), classes)
end
| EWrite e => exp (e, classes)
| EClosure (_, es) => expList (es, classes)
| ELet (_, _, e1, e2) =>
let
val (sm1, classes) = exp (e1, classes)
val (sm2, classes) = exp (e2, classes)
in
(merge' (sm1, sm2), classes)
end
| EServerCall (_, es, _, _) => expList (es, classes)
and expList (es, classes) = foldl (fn (e, (sm, classes)) =>
let
val (sm', classes) = exp (e, classes)
in
(merge' (sm, sm'), classes)
end) ([], classes) es
in
case d of
DCon _ => st
| DDatatype _ => st
| DVal (_, n, _, e, _) =>
let
val (sm, classes) = exp (e, classes)
in
(IM.insert (globals, n, (NONE, sm)), classes)
end
| DValRec vis =>
let
val (sm, classes) = foldl (fn ((_, _, _, e, _),
(sm, classes)) =>
let
val (sm', classes) = exp (e, classes)
in
(merge' (sm', sm), classes)
end) ([], classes) vis
in
(foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, (NONE, sm))) globals vis,
classes)
end
| DExport _ => st
| DTable _ => st
| DSequence _ => st
| DView _ => st
| DDatabase _ => st
| DCookie _ => st
| DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes)
| DTask _ => st
| DPolicy _ => st
| DOnError _ => st
end
val (globals, classes) = foldl decl (IM.empty, IM.empty) file
in
{Overall = IM.foldl (fn ((_, sm), sm') => merge' (sm, sm')) [] globals,
Classes = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER)
(List.mapPartial (fn (i, sm) =>
case IM.find (globals, i) of
SOME (SOME s, _) => SOME (s, sm)
| _ => NONE) (IM.listItemsi classes))}
end
type report = {Overall : inheritable list,
Classes : (string * summary) list}
end
urweb-20160213+dfsg/src/datatype_kind.sml 0000664 0000000 0000000 00000003135 12657647235 0020164 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009, 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 DatatypeKind = struct
datatype datatype_kind =
Enum
| Option
| Default
end
urweb-20160213+dfsg/src/dbmodecheck.sig 0000664 0000000 0000000 00000003075 12657647235 0017566 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2014, 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 DB_MODE_CHECK = sig
val classify : Mono.file -> Mono.file
end
urweb-20160213+dfsg/src/dbmodecheck.sml 0000664 0000000 0000000 00000007430 12657647235 0017576 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2014, 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 DbModeCheck :> DB_MODE_CHECK = struct
open Mono
structure IM = IntBinaryMap
fun classify (ds, ps) =
let
fun mergeModes (m1, m2) =
case (m1, m2) of
(NoDb, _) => m2
| (_, NoDb) => m1
| _ => AnyDb
fun modeOf modes =
MonoUtil.Exp.fold {typ = fn (_, dbm) => dbm,
exp = fn (EQuery _, dbm) => mergeModes (OneQuery, dbm)
| (EDml _, _) => AnyDb
| (ENextval _, _) => AnyDb
| (ESetval _, _) => AnyDb
| (ENamed n, dbm) =>
(case IM.find (modes, n) of
NONE => dbm
| SOME dbm' => mergeModes (dbm, dbm'))
| (_, dbm) => dbm} NoDb
fun decl ((d, _), modes) =
case d of
DVal (x, n, _, e, _) => IM.insert (modes, n, modeOf modes e)
| DValRec xes =>
let
val mode = foldl (fn ((_, _, _, e, _), mode) =>
let
val mode' = modeOf modes e
in
case mode' of
NoDb => mode
| _ => AnyDb
end) NoDb xes
in
foldl (fn ((_, n, _, _, _), modes) => IM.insert (modes, n, mode)) modes xes
end
| _ => modes
val modes = foldl decl IM.empty ds
val (ps, modes) = ListUtil.foldlMap (fn ((n, side, _), modes) =>
case IM.find (modes, n) of
NONE => ((n, side, AnyDb), modes)
| SOME mode => ((n, side, mode), #1 (IM.remove (modes, n))))
modes ps
val ps = IM.foldli (fn (n, mode, ps) => (n, ServerOnly, mode) :: ps) ps modes
in
(ds, ps)
end
end
urweb-20160213+dfsg/src/demo.sig 0000664 0000000 0000000 00000003273 12657647235 0016262 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 DEMO = sig
val make : {prefix : string, dirname : string, guided : bool} -> unit
val make' : {prefix : string, dirname : string, guided : bool} -> bool
val noEmacs : bool ref
end
urweb-20160213+dfsg/src/demo.sml 0000664 0000000 0000000 00000055311 12657647235 0016273 0 ustar 00root root 0000000 0000000 (* 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 Demo :> DEMO = struct
val noEmacs = ref false
fun make' {prefix, dirname, guided} =
let
val prose = OS.Path.joinDirFile {dir = dirname,
file = "prose"}
val inf = TextIO.openIn prose
val outDir = OS.Path.concat (dirname, "out")
val () = if OS.FileSys.access (outDir, []) then
()
else
OS.FileSys.mkDir outDir
val fname = OS.Path.joinDirFile {dir = outDir,
file = "index.html"}
val out = TextIO.openOut fname
val () = (TextIO.output (out, "\n");
TextIO.output (out, " \n");
TextIO.output (out, " \n");
TextIO.output (out, " \n");
TextIO.closeOut out)
val fname = OS.Path.joinDirFile {dir = outDir,
file = "demos.html"}
val demosOut = TextIO.openOut fname
val () = (TextIO.output (demosOut, "\n\n");
TextIO.output (demosOut, " Intro \n\n"))
val fname = OS.Path.joinDirFile {dir = dirname,
file = "demo.urs"}
val ursOut = TextIO.openOut fname
val () = (TextIO.output (ursOut, "val main : unit -> transaction page\n");
TextIO.closeOut ursOut)
val fname = OS.Path.joinDirFile {dir = dirname,
file = "demo.ur"}
val urOut = TextIO.openOut fname
val () = TextIO.output (urOut, "fun main () = return \n")
fun mergeWith f (o1, o2) =
case (o1, o2) of
(NONE, _) => o2
| (_, NONE) => o1
| (SOME v1, SOME v2) => SOME (f (v1, v2))
fun combiner (combined : Compiler.job, urp : Compiler.job) = {
prefix = prefix,
database = mergeWith (fn (v1, v2) =>
if v1 = v2 then
v1
else
raise Fail "Different demos want to use different database strings")
(#database combined, #database urp),
sources = foldl (fn (file, files) =>
if List.exists (fn x => x = file) files then
files
else
files @ [file])
(#sources combined) (#sources urp),
exe = case Settings.getExe () of
NONE => OS.Path.joinDirFile {dir = dirname,
file = "demo.exe"}
| SOME s => s,
sql = SOME (case Settings.getSql () of
NONE => OS.Path.joinDirFile {dir = dirname,
file = "demo.sql"}
| SOME s => s),
debug = Settings.getDebug (),
timeout = Int.max (#timeout combined, #timeout urp),
profile = false,
ffi = [],
link = [],
linker = NONE,
headers = [],
scripts = [],
clientToServer = [],
effectful = [],
benignEffectful = [],
clientOnly = [],
serverOnly = [],
jsFuncs = [],
rewrites = #rewrites combined @ #rewrites urp,
filterUrl = #filterUrl combined @ #filterUrl urp,
filterMime = #filterMime combined @ #filterMime urp,
filterRequest = #filterRequest combined @ #filterRequest urp,
filterResponse = #filterResponse combined @ #filterResponse urp,
filterEnv = #filterEnv combined @ #filterEnv urp,
protocol = mergeWith #2 (#protocol combined, #protocol urp),
dbms = mergeWith #2 (#dbms combined, #dbms urp),
sigFile = mergeWith #2 (#sigFile combined, #sigFile urp),
safeGets = #safeGets combined @ #safeGets urp,
onError = NONE,
minHeap = 0
}
val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
fun capitalize "" = ""
| capitalize s = str (Char.toUpper (String.sub (s, 0)))
^ String.extract (s, 1, NONE)
fun startUrp urp =
let
val base = OS.Path.base urp
val name = capitalize base
val () = (TextIO.output (demosOut, " ");
TextIO.output (demosOut, name);
TextIO.output (demosOut, " \n"))
val () = (TextIO.output (urOut, " ");
TextIO.output (urOut, name);
TextIO.output (urOut, " \n"))
val urp_file = OS.Path.joinDirFile {dir = dirname,
file = urp}
val out = OS.Path.joinBaseExt {base = base,
ext = SOME "html"}
val out = OS.Path.joinDirFile {dir = outDir,
file = out}
val out = TextIO.openOut out
val () = (TextIO.output (out, "\n");
TextIO.output (out, " \n");
TextIO.output (out, " \n");
TextIO.output (out, " \n");
TextIO.closeOut out)
val () = TextIO.closeOut out
val out = OS.Path.joinBaseExt {base = base,
ext = SOME "desc"}
val out = OS.Path.joinBaseExt {base = out,
ext = SOME "html"}
val out = TextIO.openOut (OS.Path.joinDirFile {dir = outDir,
file = out})
in
case parse (OS.Path.base urp_file) of
NONE => raise Fail ("Can't parse " ^ urp_file)
| SOME urpData =>
(TextIO.output (out, "\n");
TextIO.output (out, name);
TextIO.output (out, " \n\n\n");
TextIO.output (out, name);
TextIO.output (out, " \n\n[ Application ");
TextIO.output (out, " | ");
TextIO.output (out, urp);
TextIO.output (out, " ");
app (fn file =>
let
fun ifEx s =
let
val src = OS.Path.joinBaseExt {base = file,
ext = SOME s}
val src' = OS.Path.file src
in
if String.isPrefix (OS.Path.mkAbsolute {path = dirname,
relativeTo = OS.FileSys.getDir ()}) src
andalso OS.FileSys.access (src, []) then
(TextIO.output (out, " | ");
TextIO.output (out, src');
TextIO.output (out, " "))
else
()
end
in
ifEx "urs";
ifEx "ur"
end) (#sources urpData);
TextIO.output (out, " ] \n\n");
(urpData, out))
end
fun endUrp out =
(TextIO.output (out, "\n\n");
TextIO.closeOut out)
fun readUrp (combined, out) =
let
fun finished () = endUrp out
fun readUrp' () =
case TextIO.inputLine inf of
NONE => (finished ();
combined)
| SOME line =>
if String.isSuffix ".urp\n" line then
let
val urp = String.substring (line, 0, size line - 1)
val (urpData, out) = startUrp urp
in
finished ();
readUrp (combiner (combined, urpData),
out)
end
else
(TextIO.output (out, line);
readUrp' ())
in
readUrp' ()
end
val indexFile = OS.Path.joinDirFile {dir = outDir,
file = "intro.html"}
val out = TextIO.openOut indexFile
val () = TextIO.output (out, "\nUr/Web Demo \n\n\n")
fun readIndex () =
let
fun finished () = (TextIO.output (out, "\n\n");
TextIO.closeOut out)
in
case TextIO.inputLine inf of
NONE => (finished ();
NONE)
| SOME line =>
if String.isSuffix ".urp\n" line then
let
val urp = String.substring (line, 0, size line - 1)
val (urpData, out) = startUrp urp
in
finished ();
SOME (readUrp (urpData,
out))
end
else
(TextIO.output (out, line);
readIndex ())
end
fun prettyPrint () =
let
val dir = Posix.FileSys.opendir dirname
fun loop () =
case Posix.FileSys.readdir dir of
NONE => Posix.FileSys.closedir dir
| SOME file =>
let
fun doit f =
f (OS.Path.joinDirFile {dir = dirname,
file = file},
OS.Path.mkAbsolute
{relativeTo = OS.FileSys.getDir (),
path = OS.Path.joinDirFile {dir = outDir,
file = OS.Path.joinBaseExt {base = file,
ext = SOME "html"}}})
fun highlight () =
doit (fn (src, html) =>
let
val dirty =
let
val srcSt = Posix.FileSys.stat src
val htmlSt = Posix.FileSys.stat html
in
Time.> (Posix.FileSys.ST.mtime srcSt,
Posix.FileSys.ST.mtime htmlSt)
end handle OS.SysErr _ => true
val cmd = "emacs --eval \"(progn "
^ "(global-font-lock-mode t) "
^ "(add-to-list 'load-path \\\""
^ !Settings.configSitelisp
^ "/\\\") "
^ "(load \\\"urweb-mode-startup\\\") "
^ "(urweb-mode) "
^ "(find-file \\\""
^ src
^ "\\\") "
^ "(switch-to-buffer (htmlize-buffer)) "
^ "(write-file \\\""
^ html
^ "\\\") "
^ "(kill-emacs))\""
in
if dirty then
(print (">>> " ^ cmd ^ "\n");
ignore (OS.Process.system cmd))
else
()
end)
val highlight = fn () => if !noEmacs then () else highlight ()
in
if OS.Path.base file = "demo" then
()
else case OS.Path.ext file of
SOME "urp" =>
doit (fn (src, html) =>
let
val inf = TextIO.openIn src
val out = TextIO.openOut html
fun loop () =
case TextIO.inputLine inf of
NONE => ()
| SOME line => (TextIO.output (out, line);
loop ())
in
TextIO.output (out, "\n\n");
loop ();
TextIO.output (out, " \n\n");
TextIO.closeIn inf;
TextIO.closeOut out
end)
| SOME "urs" => highlight ()
| SOME "ur" => highlight ()
| _ => ();
loop ()
end
in
loop ()
end
in
case readIndex () of
NONE => raise Fail "No demo applications!"
| SOME combined =>
let
val () = (TextIO.output (urOut, " \n");
TextIO.closeOut urOut)
val fname = OS.Path.joinDirFile {dir = dirname,
file = "demo.urp"}
val outf = TextIO.openOut fname
fun filters kind =
app (fn rule : Settings.rule =>
(TextIO.output (outf, case #action rule of
Settings.Allow => "allow"
| Settings.Deny => "deny");
TextIO.output (outf, " ");
TextIO.output (outf, kind);
TextIO.output (outf, " ");
TextIO.output (outf, #pattern rule);
case #kind rule of
Settings.Exact => ()
| Settings.Prefix => TextIO.output (outf, "*");
TextIO.output (outf, "\n")))
in
Option.app (fn db => (TextIO.output (outf, "database ");
TextIO.output (outf, db);
TextIO.output (outf, "\n")))
(#database combined);
TextIO.output (outf, "sql demo.sql\n");
TextIO.output (outf, "prefix ");
TextIO.output (outf, prefix);
TextIO.output (outf, "\n");
app (fn rule =>
(TextIO.output (outf, "rewrite ");
TextIO.output (outf, case #pkind rule of
Settings.Any => "all"
| Settings.Url => "url"
| Settings.Table => "table"
| Settings.Sequence => "sequence"
| Settings.View => "view"
| Settings.Relation => "relation"
| Settings.Cookie => "cookie"
| Settings.Style => "style");
TextIO.output (outf, " ");
TextIO.output (outf, #from rule);
case #kind rule of
Settings.Exact => ()
| Settings.Prefix => TextIO.output (outf, "*");
TextIO.output (outf, " ");
TextIO.output (outf, #to rule);
if #hyphenate rule then
TextIO.output (outf, " [-]")
else
();
TextIO.output (outf, "\n"))) (#rewrites combined);
filters "url" (#filterUrl combined);
filters "mime" (#filterMime combined);
app (fn path =>
(TextIO.output (outf, "safeGet ");
TextIO.output (outf, path);
TextIO.output (outf, "\n"))) (#safeGets combined);
TextIO.output (outf, "\n");
app (fn s =>
let
val s = OS.Path.mkAbsolute {relativeTo = OS.FileSys.getDir (),
path = s}
in
TextIO.output (outf, s);
TextIO.output (outf, "\n")
end)
(#sources combined);
TextIO.output (outf, "\n");
TextIO.output (outf, "demo\n");
TextIO.closeOut outf;
let
val b = Compiler.compile (OS.Path.base fname)
in
TextIO.output (demosOut, "\n\n");
TextIO.closeOut demosOut;
if b then
prettyPrint ()
else
();
b
end
end
end
fun make args = if make' args then
()
else
OS.Process.exit OS.Process.failure
end
urweb-20160213+dfsg/src/disjoint.sig 0000664 0000000 0000000 00000003607 12657647235 0017162 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 DISJOINT = sig
type env
val empty : env
val enter : env -> env
type goal = ErrorMsg.span * ElabEnv.env * env * Elab.con * Elab.con
val assert : ElabEnv.env -> env -> Elab.con * Elab.con -> env
val prove : ElabEnv.env -> env -> Elab.con * Elab.con * ErrorMsg.span -> goal list
val p_env : env -> unit
val proved : int ref
val reset : unit -> unit
end
urweb-20160213+dfsg/src/disjoint.sml 0000664 0000000 0000000 00000022212 12657647235 0017164 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 Disjoint :> DISJOINT = struct
open Elab
open ElabOps
datatype piece_fst =
NameC of string
| NameR of int
| NameN of int
| NameM of int * string list * string
| RowR of int
| RowN of int
| RowM of int * string list * string
type piece = piece_fst * int list
fun p2s p =
case p of
NameC s => "NameC(" ^ s ^ ")"
| NameR n => "NameR(" ^ Int.toString n ^ ")"
| NameN n => "NameN(" ^ Int.toString n ^ ")"
| NameM (n, _, s) => "NameR(" ^ Int.toString n ^ ", " ^ s ^ ")"
| RowR n => "RowR(" ^ Int.toString n ^ ")"
| RowN n => "RowN(" ^ Int.toString n ^ ")"
| RowM (n, _, s) => "RowR(" ^ Int.toString n ^ ", " ^ s ^ ")"
fun pp p = print (p2s p ^ "\n")
fun rp2s (p, ns) = String.concatWith " " (p2s p :: map Int.toString ns)
structure PK = struct
type ord_key = piece
open Order
fun compare' (p1, p2) =
case (p1, p2) of
(NameC s1, NameC s2) => String.compare (s1, s2)
| (NameR n1, NameR n2) => Int.compare (n1, n2)
| (NameN n1, NameN n2) => Int.compare (n1, n2)
| (NameM (n1, ss1, s1), NameM (n2, ss2, s2)) =>
join (Int.compare (n1, n2),
fn () => join (String.compare (s1, s2), fn () =>
joinL String.compare (ss1, ss2)))
| (RowR n1, RowR n2) => Int.compare (n1, n2)
| (RowN n1, RowN n2) => Int.compare (n1, n2)
| (RowM (n1, ss1, s1), RowM (n2, ss2, s2)) =>
join (Int.compare (n1, n2),
fn () => join (String.compare (s1, s2), fn () =>
joinL String.compare (ss1, ss2)))
| (NameC _, _) => LESS
| (_, NameC _) => GREATER
| (NameR _, _) => LESS
| (_, NameR _) => GREATER
| (NameN _, _) => LESS
| (_, NameN _) => GREATER
| (NameM _, _) => LESS
| (_, NameM _) => GREATER
| (RowR _, _) => LESS
| (_, RowR _) => GREATER
| (RowN _, _) => LESS
| (_, RowN _) => GREATER
fun compare ((p1, ns1), (p2, ns2)) =
join (compare' (p1, p2),
fn () => joinL Int.compare (ns1, ns2))
end
structure PS = BinarySetFn(PK)
structure PM = BinaryMapFn(PK)
type env = PS.set PM.map
fun p_env x =
(print "\nDENV:\n";
PM.appi (fn (p1, ps) =>
PS.app (fn p2 =>
print (rp2s p1 ^ " ~ " ^ rp2s p2 ^ "\n")) ps) x)
structure E = ElabEnv
type goal = ErrorMsg.span * E.env * env * Elab.con * Elab.con
val empty = PM.empty
fun nameToRow (c, loc) =
(CRecord ((KUnit, loc), [((c, loc), (CUnit, loc))]), loc)
fun pieceToRow' (p, loc) =
case p of
NameC s => nameToRow (CName s, loc)
| NameR n => nameToRow (CRel n, loc)
| NameN n => nameToRow (CNamed n, loc)
| NameM (n, xs, x) => nameToRow (CModProj (n, xs, x), loc)
| RowR n => (CRel n, loc)
| RowN n => (CNamed n, loc)
| RowM (n, xs, x) => (CModProj (n, xs, x), loc)
fun pieceToRow ((p, ns), loc) =
foldl (fn (n, c) => (CProj (c, n), loc)) (pieceToRow' (p, loc)) ns
datatype piece' =
Piece of piece
| Unknown of con
fun pieceEnter' p =
case p of
NameR n => NameR (n + 1)
| RowR n => RowR (n + 1)
| _ => p
fun pieceEnter (p, n) = (pieceEnter' p, n)
fun enter denv =
PM.foldli (fn (p, pset, denv') =>
PM.insert (denv', pieceEnter p, PS.map pieceEnter pset))
PM.empty denv
val lowercase = CharVector.map Char.toLower
fun prove1 denv (p1, p2) =
case (p1, p2) of
((NameC s1, _), (NameC s2, _)) => lowercase s1 <> lowercase s2
| _ =>
case PM.find (denv, p1) of
NONE => false
| SOME pset => PS.member (pset, p2)
val proved = ref 0
fun reset () = (ElabOps.reset ();
proved := 0)
fun decomposeRow env c =
let
val loc = #2 c
fun decomposeProj c =
let
val c = hnormCon env c
in
case #1 c of
CProj (c, n) =>
let
val (c', ns) = decomposeProj c
in
(c', ns @ [n])
end
| _ => (c, [])
end
fun decomposeName (c, acc) =
let
val (cAll as (c, _), ns) = decomposeProj c
in
case c of
CName s => Piece (NameC s, ns) :: acc
| CRel n => Piece (NameR n, ns) :: acc
| CNamed n => Piece (NameN n, ns) :: acc
| CModProj (m1, ms, x) => Piece (NameM (m1, ms, x), ns) :: acc
| _ => Unknown cAll :: acc
end
fun decomposeRow' (c, acc) =
let
fun default () =
let
val (cAll as (c, _), ns) = decomposeProj c
in
case c of
CRecord (_, xcs) => foldl (fn ((x, _), acc) => decomposeName (x, acc)) acc xcs
| CConcat (c1, c2) => decomposeRow' (c1, decomposeRow' (c2, acc))
| CRel n => Piece (RowR n, ns) :: acc
| CNamed n => Piece (RowN n, ns) :: acc
| CModProj (m1, ms, x) => Piece (RowM (m1, ms, x), ns) :: acc
| _ => Unknown cAll :: acc
end
in
case #1 (hnormCon env c) of
CApp (
(CApp ((CMap _, _), _), _),
r) => decomposeRow' (r, acc)
| _ => default ()
end
in
decomposeRow' (c, [])
end
and assert env denv (c1, c2) =
let
val ps1 = decomposeRow env c1
val ps2 = decomposeRow env c2
val unUnknown = List.mapPartial (fn Unknown _ => NONE | Piece p => SOME p)
val ps1 = unUnknown ps1
val ps2 = unUnknown ps2
(*val () = print "APieces1:\n"
val () = app pp ps1
val () = print "APieces2:\n"
val () = app pp ps2*)
fun assertPiece ps (p, denv) =
let
val pset = Option.getOpt (PM.find (denv, p), PS.empty)
val ps = case p of
(NameC _, _) => List.filter (fn (NameC _, _) => false | _ => true) ps
| _ => ps
val pset = PS.addList (pset, ps)
in
PM.insert (denv, p, pset)
end
val denv = foldl (assertPiece ps2) denv ps1
in
foldl (assertPiece ps1) denv ps2
end
and prove env denv (c1, c2, loc) =
let
val () = proved := !proved + 1
val ps1 = decomposeRow env c1
val ps2 = decomposeRow env c2
val hasUnknown = List.exists (fn Unknown _ => true | _ => false)
val unUnknown = List.mapPartial (fn Unknown _ => NONE | Piece p => SOME p)
in
if (hasUnknown ps1 andalso not (List.null ps2))
orelse (hasUnknown ps2 andalso not (List.null ps1)) then
[(loc, env, denv, c1, c2)]
else
let
val ps1 = unUnknown ps1
val ps2 = unUnknown ps2
in
(*print "Pieces1:\n";
app pp ps1;
print "Pieces2:\n";
app pp ps2;*)
foldl (fn (p1, rem) =>
foldl (fn (p2, rem) =>
if prove1 denv (p1, p2) then
rem
else
(loc, env, denv, pieceToRow (p1, loc), pieceToRow (p2, loc)) :: rem) rem ps2)
[] ps1
end
end
end
urweb-20160213+dfsg/src/effectize.sig 0000664 0000000 0000000 00000003072 12657647235 0017277 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009, 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 EFFECTIZE = sig
val effectize : Core.file -> Core.file
end
urweb-20160213+dfsg/src/effectize.sml 0000664 0000000 0000000 00000023331 12657647235 0017310 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009-2010, 2013, 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 Effective :> EFFECTIZE = struct
open Core
structure U = CoreUtil
structure IM = IntBinaryMap
structure SS = BinarySetFn(struct
type ord_key = string
val compare = String.compare
end)
fun effectful x = Settings.isEffectful x andalso not (Settings.isClientOnly x)
fun effectize file =
let
fun expOnload evs e =
case e of
EFfi f => effectful f
| EFfiApp (m, x, _) => effectful (m, x)
| ENamed n => IM.inDomain (evs, n)
| EServerCall (n, _, _, _) => IM.inDomain (evs, n)
| _ => false
fun couldWriteOnload evs = U.Exp.exists {kind = fn _ => false,
con = fn _ => false,
exp = expOnload evs}
fun exp evs e =
case e of
EFfi f => effectful f
| EFfiApp (m, x, _) => effectful (m, x)
| ENamed n => IM.inDomain (evs, n)
| ERecord xets => List.exists (fn ((CName "Onload", _), e, _) => couldWriteOnload evs e
| _ => false) xets
| _ => false
fun couldWrite evs = U.Exp.exists {kind = fn _ => false,
con = fn _ => false,
exp = exp evs}
fun exp writers readers pushers e =
case e of
ENamed n => IM.inDomain (pushers, n)
| EServerCall (n, _, _, _) => IM.inDomain (writers, n) andalso IM.inDomain (readers, n)
| _ => false
fun couldWriteWithRpc writers readers pushers = U.Exp.exists {kind = fn _ => false,
con = fn _ => false,
exp = exp writers readers pushers}
fun exp evs e =
case e of
EFfi ("Basis", "getCookie") => true
| EFfiApp ("Basis", "getHeader", _) => true
| EFfiApp ("Basis", "getenv", _) => true
| ENamed n => IM.inDomain (evs, n)
| EServerCall (n, _, _, _) => IM.inDomain (evs, n)
| _ => false
fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false,
con = fn _ => false,
exp = exp evs}
val dejs = U.Exp.map {kind = fn x => x,
con = fn c => c,
exp = fn ERecord xets => ERecord (List.filter (fn ((CName x, _), _ , _) => x = "Onload" orelse not (String.isPrefix "On" x)
| _ => true) xets)
| e => e}
fun doDecl (d, evs as (writers, readers, pushers)) =
case #1 d of
DVal (x, n, t, e, s) =>
let
val e' = dejs e
in
(d, (if couldWrite writers e' then
IM.insert (writers, n, (#2 d, s))
else
writers,
if couldReadCookie readers e' then
IM.insert (readers, n, (#2 d, s))
else
readers,
if couldWriteWithRpc writers readers pushers e then
IM.insert (pushers, n, (#2 d, s))
else
pushers))
end
| DValRec vis =>
let
fun oneRound evs =
foldl (fn ((_, n, _, e, s), (changed, (writers, readers, pushers))) =>
let
val e' = dejs e
val (changed, writers) =
if couldWrite writers e' andalso not (IM.inDomain (writers, n)) then
(true, IM.insert (writers, n, (#2 d, s)))
else
(changed, writers)
val (changed, readers) =
if couldReadCookie readers e' andalso not (IM.inDomain (readers, n)) then
(true, IM.insert (readers, n, (#2 d, s)))
else
(changed, readers)
val (changed, pushers) =
if couldWriteWithRpc writers readers pushers e
andalso not (IM.inDomain (pushers, n)) then
(true, IM.insert (pushers, n, (#2 d, s)))
else
(changed, pushers)
in
(changed, (writers, readers, pushers))
end) (false, evs) vis
fun loop evs =
let
val (b, evs) = oneRound evs
in
if b then
loop evs
else
evs
end
in
(d, loop (writers, readers, pushers))
end
| DExport (Link _, n, t) =>
(case IM.find (writers, n) of
NONE => ()
| SOME (loc, s) =>
if Settings.isSafeGet s then
()
else
ErrorMsg.errorAt loc ("A handler (URI prefix \"" ^ s
^ "\") accessible via GET could cause side effects; try accessing it only via forms, removing it from the signature of the main program module, or whitelisting it with the 'safeGet' .urp directive");
((DExport (Link (if IM.inDomain (writers, n) then
if IM.inDomain (readers, n) then
ReadCookieWrite
else
ReadWrite
else
ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs))
| DExport (Action _, n, _) =>
((DExport (Action (if IM.inDomain (writers, n) then
if IM.inDomain (readers, n) then
ReadCookieWrite
else
ReadWrite
else
ReadOnly), n, IM.inDomain (pushers, n)), #2 d),
evs)
| DExport (Rpc _, n, _) =>
((DExport (Rpc (if IM.inDomain (writers, n) then
if IM.inDomain (readers, n) then
ReadCookieWrite
else
ReadWrite
else
ReadOnly), n, IM.inDomain (pushers, n)), #2 d),
evs)
| DExport (Extern _, n, _) =>
((DExport (Extern (if IM.inDomain (writers, n) then
if IM.inDomain (readers, n) then
ReadCookieWrite
else
ReadWrite
else
ReadOnly), n, IM.inDomain (pushers, n)), #2 d),
evs)
| _ => (d, evs)
val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty, IM.empty) file
in
file
end
end
urweb-20160213+dfsg/src/elab.sml 0000664 0000000 0000000 00000015027 12657647235 0016252 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2011, 2014, 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 Elab = struct
type 'a located = 'a ErrorMsg.located
datatype kind' =
KType
| KArrow of kind * kind
| KName
| KRecord of kind
| KUnit
| KTuple of kind list
| KError
| KUnif of ErrorMsg.span * string * kunif ref
| KTupleUnif of ErrorMsg.span * (int * kind) list * kunif ref
| KRel of int
| KFun of string * kind
and kunif =
KUnknown of kind -> bool (* Is the kind a valid unification? *)
| KKnown of kind
withtype kind = kind' located
datatype explicitness =
Explicit
| Implicit
datatype con' =
TFun of con * con
| TCFun of explicitness * string * kind * con
| TRecord of con
| TDisjoint of con * con * con
| CRel of int
| CNamed of int
| CModProj of int * string list * string
| CApp of con * con
| CAbs of string * kind * con
| CKAbs of string * con
| CKApp of con * kind
| TKFun of string * con
| CName of string
| CRecord of kind * (con * con) list
| CConcat of con * con
| CMap of kind * kind
| CUnit
| CTuple of con list
| CProj of con * int
| CError
| CUnif of int * ErrorMsg.span * kind * string * cunif ref
and cunif =
Unknown of con -> bool (* Is the constructor a valid unification? *)
| Known of con
withtype con = con' located
datatype datatype_kind = datatype DatatypeKind.datatype_kind
datatype patCon =
PConVar of int
| PConProj of int * string list * string
datatype pat' =
PVar of string * con
| PPrim of Prim.t
| PCon of datatype_kind * patCon * con list * pat option
| PRecord of (string * pat * con) list
withtype pat = pat' located
datatype exp' =
EPrim of Prim.t
| ERel of int
| ENamed of int
| EModProj of int * string list * string
| EApp of exp * exp
| EAbs of string * con * con * exp
| ECApp of exp * con
| ECAbs of explicitness * string * kind * exp
| EKAbs of string * exp
| EKApp of exp * kind
| ERecord of (con * exp * con) list
| EField of exp * con * { field : con, rest : con }
| EConcat of exp * con * exp * con
| ECut of exp * con * { field : con, rest : con }
| ECutMulti of exp * con * { rest : con }
| ECase of exp * (pat * exp) list * { disc : con, result : con }
| EError
| EUnif of exp option ref
| ELet of edecl list * exp * con
and edecl' =
EDVal of pat * con * exp
| EDValRec of (string * con * exp) list
withtype exp = exp' located
and edecl = edecl' located
(* We have to be careful about crawling automatically generated signatures recursively,
* importing all type-class instances that we find.
* The reason is that selfification will add signatures of anonymous structures,
* and it's counterintuitive for instances to escape anonymous structures! *)
datatype import_mode = Import | Skip
datatype sgn_item' =
SgiConAbs of string * int * kind
| SgiCon of string * int * kind * con
| SgiDatatype of (string * int * string list * (string * int * con option) list) list
| SgiDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list
| SgiVal of string * int * con
| SgiStr of import_mode * string * int * sgn
| SgiSgn of string * int * sgn
| SgiConstraint of con * con
| SgiClassAbs of string * int * kind
| SgiClass of string * int * kind * con
and sgn' =
SgnConst of sgn_item list
| SgnVar of int
| SgnFun of string * int * sgn * sgn
| SgnWhere of sgn * string list * string * con
| SgnProj of int * string list * string
| SgnError
withtype sgn_item = sgn_item' located
and sgn = sgn' located
datatype decl' =
DCon of string * int * kind * con
| DDatatype of (string * int * string list * (string * int * con option) list) list
| DDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list
| DVal of string * int * con * exp
| DValRec of (string * int * con * exp) list
| DSgn of string * int * sgn
| DStr of string * int * sgn * str
| DFfiStr of string * int * sgn
| DConstraint of con * con
| DExport of int * sgn * str
| DTable of int * string * int * con * exp * con * exp * con
| DSequence of int * string * int
| DView of int * string * int * exp * con
| DDatabase of string
| DCookie of int * string * int * con
| DStyle of int * string * int
| DTask of exp * exp
| DPolicy of exp
| DOnError of int * string list * string
| DFfi of string * int * Source.ffi_mode list * con
and str' =
StrConst of decl list
| StrVar of int
| StrProj of str * string
| StrFun of string * int * sgn * sgn * str
| StrApp of str * str
| StrError
withtype decl = decl' located
and str = str' located
type file = decl list
end
urweb-20160213+dfsg/src/elab_env.sig 0000664 0000000 0000000 00000012712 12657647235 0017107 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 ELAB_ENV = sig
val liftConInCon : int -> Elab.con -> Elab.con
val mliftConInCon : int -> Elab.con -> Elab.con
val liftConInExp : int -> Elab.exp -> Elab.exp
val liftExpInExp : int -> Elab.exp -> Elab.exp
val subExpInExp : (int * Elab.exp) -> Elab.exp -> Elab.exp
type env
val dump : env -> unit
val empty : env
exception UnboundRel of int
exception UnboundNamed of int
datatype 'a var =
NotBound
| Rel of int * 'a
| Named of int * 'a
val pushKRel : env -> string -> env
val lookupKRel : env -> int -> string
val lookupK : env -> string -> int option
val pushCRel : env -> string -> Elab.kind -> env
val lookupCRel : env -> int -> string * Elab.kind
val pushCNamed : env -> string -> Elab.kind -> Elab.con option -> env * int
val pushCNamedAs : env -> string -> int -> Elab.kind -> Elab.con option -> env
val lookupCNamed : env -> int -> string * Elab.kind * Elab.con option
val lookupC : env -> string -> Elab.kind var
val pushDatatype : env -> int -> string list -> (string * int * Elab.con option) list -> env
type datatyp
val lookupDatatype : env -> int -> datatyp
val lookupDatatypeConstructor : datatyp -> int -> string * Elab.con option
val datatypeArgs : datatyp -> string list
val constructors : datatyp -> (string * int * Elab.con option) list
val lookupConstructor : env -> string -> (Elab.datatype_kind * int * string list * Elab.con option * int) option
val pushClass : env -> int -> env
val isClass : env -> Elab.con -> bool
val resolveClass : (Elab.con -> Elab.con) -> (Elab.con * Elab.con -> bool)
-> env -> Elab.con -> Elab.exp option
val resolveFailureCause : unit -> Elab.con option
val listClasses : env -> (Elab.con * (Elab.con * Elab.exp) list) list
val pushERel : env -> string -> Elab.con -> env
val lookupERel : env -> int -> string * Elab.con
val pushENamed : env -> string -> Elab.con -> env * int
val pushENamedAs : env -> string -> int -> Elab.con -> env
val lookupENamed : env -> int -> string * Elab.con
val checkENamed : env -> int -> bool
val lookupE : env -> string -> Elab.con var
val pushSgnNamed : env -> string -> Elab.sgn -> env * int
val pushSgnNamedAs : env -> string -> int -> Elab.sgn -> env
val lookupSgnNamed : env -> int -> string * Elab.sgn
val lookupSgn : env -> string -> (int * Elab.sgn) option
val pushStrNamed : env -> string -> Elab.sgn -> env * int
val pushStrNamedAs : env -> string -> int -> Elab.sgn -> env
val lookupStrNamed : env -> int -> string * Elab.sgn
val lookupStr : env -> string -> (int * Elab.sgn) option
val edeclBinds : env -> Elab.edecl -> env
val declBinds : env -> Elab.decl -> env
val sgiBinds : env -> Elab.sgn_item -> env
val hnormSgn : env -> Elab.sgn -> Elab.sgn
val projectCon : env -> { sgn : Elab.sgn, str : Elab.str, field : string } -> (Elab.kind * Elab.con option) option
val projectDatatype : env -> { sgn : Elab.sgn, str : Elab.str, field : string }
-> (string list * (string * int * Elab.con option) list) option
val projectConstructor : env -> { sgn : Elab.sgn, str : Elab.str, field : string }
-> (Elab.datatype_kind * int * string list * Elab.con option * Elab.con) option
val projectVal : env -> { sgn : Elab.sgn, str : Elab.str, field : string } -> Elab.con option
val projectSgn : env -> { sgn : Elab.sgn, str : Elab.str, field : string } -> Elab.sgn option
val projectStr : env -> { sgn : Elab.sgn, str : Elab.str, field : string } -> Elab.sgn option
val projectConstraints : env -> { sgn : Elab.sgn, str : Elab.str } -> (Elab.con * Elab.con) list option
val newNamed : unit -> int
val chaseMpath : env -> (int * string list) -> Elab.str * Elab.sgn
val patBinds : env -> Elab.pat -> env
val patBindsN : Elab.pat -> int
exception Bad of Elab.con * Elab.con
end
urweb-20160213+dfsg/src/elab_env.sml 0000664 0000000 0000000 00000200166 12657647235 0017122 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2009, 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 ElabEnv :> ELAB_ENV = struct
open Elab
structure U = ElabUtil
structure IM = IntBinaryMap
structure SM = BinaryMapFn(struct
type ord_key = string
val compare = String.compare
end)
exception UnboundRel of int
exception UnboundNamed of int
(* AST utility functions *)
val liftKindInKind =
U.Kind.mapB {kind = fn bound => fn k =>
case k of
KRel xn =>
if xn < bound then
k
else
KRel (xn + 1)
| _ => k,
bind = fn (bound, _) => bound + 1}
val liftKindInCon =
U.Con.mapB {kind = fn bound => fn k =>
case k of
KRel xn =>
if xn < bound then
k
else
KRel (xn + 1)
| _ => k,
con = fn _ => fn c => c,
bind = fn (bound, U.Con.RelK _) => bound + 1
| (bound, _) => bound}
val liftConInCon =
U.Con.mapB {kind = fn _ => fn k => k,
con = fn bound => fn c =>
case c of
CRel xn =>
if xn < bound then
c
else
CRel (xn + 1)
| CUnif (nl, loc, k, s, r) => CUnif (nl+1, loc, k, s, r)
| _ => c,
bind = fn (bound, U.Con.RelC _) => bound + 1
| (bound, _) => bound}
val lift = liftConInCon 0
fun mliftConInCon by c =
if by = 0 then
c
else
U.Con.mapB {kind = fn _ => fn k => k,
con = fn bound => fn c =>
case c of
CRel xn =>
if xn < bound then
c
else
CRel (xn + by)
| CUnif (nl, loc, k, s, r) => CUnif (nl+by, loc, k, s, r)
| _ => c,
bind = fn (bound, U.Con.RelC _) => bound + 1
| (bound, _) => bound} 0 c
val () = U.mliftConInCon := mliftConInCon
val liftKindInExp =
U.Exp.mapB {kind = fn bound => fn k =>
case k of
KRel xn =>
if xn < bound then
k
else
KRel (xn + 1)
| _ => k,
con = fn _ => fn c => c,
exp = fn _ => fn e => e,
bind = fn (bound, U.Exp.RelK _) => bound + 1
| (bound, _) => bound}
val liftConInExp =
U.Exp.mapB {kind = fn _ => fn k => k,
con = fn bound => fn c =>
case c of
CRel xn =>
if xn < bound then
c
else
CRel (xn + 1)
| CUnif (nl, loc, k, s, r) => CUnif (nl+1, loc, k, s, r)
| _ => c,
exp = fn _ => fn e => e,
bind = fn (bound, U.Exp.RelC _) => bound + 1
| (bound, _) => bound}
val liftExpInExp =
U.Exp.mapB {kind = fn _ => fn k => k,
con = fn _ => fn c => c,
exp = fn bound => fn e =>
case e of
ERel xn =>
if xn < bound then
e
else
ERel (xn + 1)
| _ => e,
bind = fn (bound, U.Exp.RelE _) => bound + 1
| (bound, _) => bound}
val liftExp = liftExpInExp 0
val subExpInExp =
U.Exp.mapB {kind = fn _ => fn k => k,
con = fn _ => fn c => c,
exp = fn (xn, rep) => fn e =>
case e of
ERel xn' =>
(case Int.compare (xn', xn) of
EQUAL => #1 rep
| GREATER=> ERel (xn' - 1)
| LESS => e)
| _ => e,
bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
| ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep)
| (ctx, _) => ctx}
(* Back to environments *)
datatype 'a var' =
Rel' of int * 'a
| Named' of int * 'a
datatype 'a var =
NotBound
| Rel of int * 'a
| Named of int * 'a
type datatyp = string list * (string * con option) IM.map
datatype class_name =
ClNamed of int
| ClProj of int * string list * string
fun class_name_out cn =
case cn of
ClNamed n => (CNamed n, ErrorMsg.dummySpan)
| ClProj x => (CModProj x, ErrorMsg.dummySpan)
fun cn2s cn =
case cn of
ClNamed n => "Named(" ^ Int.toString n ^ ")"
| ClProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")"
structure CK = struct
type ord_key = class_name
open Order
fun compare x =
case x of
(ClNamed n1, ClNamed n2) => Int.compare (n1, n2)
| (ClNamed _, _) => LESS
| (_, ClNamed _) => GREATER
| (ClProj (m1, ms1, x1), ClProj (m2, ms2, x2)) =>
join (Int.compare (m1, m2),
fn () => join (joinL String.compare (ms1, ms2),
fn () => String.compare (x1, x2)))
end
structure CS = BinarySetFn(CK)
structure CM = BinaryMapFn(CK)
type rules = (int * con list * con * exp) list
type class = {closedRules : rules,
openRules : rules}
val empty_class = {closedRules = [],
openRules = []}
type env = {
renameK : int SM.map,
relK : string list,
renameC : kind var' SM.map,
relC : (string * kind) list,
namedC : (string * kind * con option) IM.map,
datatypes : datatyp IM.map,
constructors : (datatype_kind * int * string list * con option * int) SM.map,
classes : class CM.map,
renameE : con var' SM.map,
relE : (string * con) list,
namedE : (string * con) IM.map,
renameSgn : (int * sgn) SM.map,
sgn : (string * sgn) IM.map,
renameStr : (int * sgn) SM.map,
str : (string * sgn) IM.map
}
fun dump (env : env) =
(print "NamedC:\n";
IM.appi (fn (n, (x, k, co)) => print (x ^ " [" ^ Int.toString n ^ "]\n")) (#namedC env))
val namedCounter = ref 0
fun newNamed () =
let
val r = !namedCounter
in
namedCounter := r + 1;
r
end
val empty = {
renameK = SM.empty,
relK = [],
renameC = SM.empty,
relC = [],
namedC = IM.empty,
datatypes = IM.empty,
constructors = SM.empty,
classes = CM.empty,
renameE = SM.empty,
relE = [],
namedE = IM.empty,
renameSgn = SM.empty,
sgn = IM.empty,
renameStr = SM.empty,
str = IM.empty
}
fun pushKRel (env : env) x =
let
val renameK = SM.map (fn n => n+1) (#renameK env)
in
{renameK = SM.insert (renameK, x, 0),
relK = x :: #relK env,
renameC = SM.map (fn Rel' (n, k) => Rel' (n, liftKindInKind 0 k)
| x => x) (#renameC env),
relC = map (fn (x, k) => (x, liftKindInKind 0 k)) (#relC env),
namedC = #namedC env,
datatypes = #datatypes env,
constructors = #constructors env,
classes = CM.map (fn cl => {closedRules = #closedRules cl,
openRules = map (fn (nvs, cs, c, e) =>
(nvs,
map (liftKindInCon 0) cs,
liftKindInCon 0 c,
liftKindInExp 0 e))
(#openRules cl)})
(#classes env),
renameE = SM.map (fn Rel' (n, c) => Rel' (n, liftKindInCon 0 c)
| Named' (n, c) => Named' (n, c)) (#renameE env),
relE = map (fn (x, c) => (x, liftKindInCon 0 c)) (#relE env),
namedE = #namedE env,
renameSgn = #renameSgn env,
sgn = #sgn env,
renameStr = #renameStr env,
str = #str env
}
end
fun lookupKRel (env : env) n =
(List.nth (#relK env, n))
handle Subscript => raise UnboundRel n
fun lookupK (env : env) x = SM.find (#renameK env, x)
fun pushCRel (env : env) x k =
let
val renameC = SM.map (fn Rel' (n, k) => Rel' (n+1, k)
| x => x) (#renameC env)
in
{renameK = #renameK env,
relK = #relK env,
renameC = SM.insert (renameC, x, Rel' (0, k)),
relC = (x, k) :: #relC env,
namedC = #namedC env,
datatypes = #datatypes env,
constructors = #constructors env,
classes = CM.map (fn class =>
{closedRules = #closedRules class,
openRules = map (fn (nvs, cs, c, e) =>
(nvs,
map (liftConInCon 0) cs,
liftConInCon 0 c,
liftConInExp 0 e))
(#openRules class)})
(#classes env),
renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c)
| Named' (n, c) => Named' (n, c)) (#renameE env),
relE = map (fn (x, c) => (x, lift c)) (#relE env),
namedE = #namedE env,
renameSgn = #renameSgn env,
sgn = #sgn env,
renameStr = #renameStr env,
str = #str env
}
end
fun lookupCRel (env : env) n =
(List.nth (#relC env, n))
handle Subscript => raise UnboundRel n
fun pushCNamedAs (env : env) x n k co =
{renameK = #renameK env,
relK = #relK env,
renameC = SM.insert (#renameC env, x, Named' (n, k)),
relC = #relC env,
namedC = IM.insert (#namedC env, n, (x, k, co)),
datatypes = #datatypes env,
constructors = #constructors env,
classes = #classes env,
renameE = #renameE env,
relE = #relE env,
namedE = #namedE env,
renameSgn = #renameSgn env,
sgn = #sgn env,
renameStr = #renameStr env,
str = #str env}
fun pushCNamed env x k co =
let
val n = !namedCounter
in
namedCounter := n + 1;
(pushCNamedAs env x n k co, n)
end
fun lookupCNamed (env : env) n =
case IM.find (#namedC env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun lookupC (env : env) x =
case SM.find (#renameC env, x) of
NONE => NotBound
| SOME (Rel' x) => Rel x
| SOME (Named' x) => Named x
fun pushDatatype (env : env) n xs xncs =
let
val dk = U.classifyDatatype xncs
in
{renameK = #renameK env,
relK = #relK env,
renameC = #renameC env,
relC = #relC env,
namedC = #namedC env,
datatypes = IM.insert (#datatypes env, n,
(xs, foldl (fn ((x, n, to), cons) =>
IM.insert (cons, n, (x, to))) IM.empty xncs)),
constructors = foldl (fn ((x, n', to), cmap) =>
SM.insert (cmap, x, (dk, n', xs, to, n)))
(#constructors env) xncs,
classes = #classes env,
renameE = #renameE env,
relE = #relE env,
namedE = #namedE env,
renameSgn = #renameSgn env,
sgn = #sgn env,
renameStr = #renameStr env,
str = #str env}
end
fun lookupDatatype (env : env) n =
case IM.find (#datatypes env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun lookupDatatypeConstructor (_, dt) n =
case IM.find (dt, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun lookupConstructor (env : env) s = SM.find (#constructors env, s)
fun datatypeArgs (xs, _) = xs
fun constructors (_, dt) = IM.foldri (fn (n, (x, to), ls) => (x, n, to) :: ls) [] dt
fun listClasses (env : env) =
map (fn (cn, {closedRules, openRules}) =>
(class_name_out cn,
map (fn (nvs, cs, c, e) =>
let
val loc = #2 c
val c = foldr (fn (c', c) => (TFun (c', c), loc)) c cs
val c = ListUtil.foldli (fn (n, (), c) => (TCFun (Explicit,
"x" ^ Int.toString n,
(KError, loc),
c), loc))
c (List.tabulate (nvs, fn _ => ()))
in
(c, e)
end) (closedRules @ openRules))) (CM.listItemsi (#classes env))
fun pushClass (env : env) n =
{renameK = #renameK env,
relK = #relK env,
renameC = #renameC env,
relC = #relC env,
namedC = #namedC env,
datatypes = #datatypes env,
constructors = #constructors env,
classes = CM.insert (#classes env, ClNamed n, empty_class),
renameE = #renameE env,
relE = #relE env,
namedE = #namedE env,
renameSgn = #renameSgn env,
sgn = #sgn env,
renameStr = #renameStr env,
str = #str env}
fun class_name_in (c, _) =
case c of
CNamed n => SOME (ClNamed n)
| CModProj x => SOME (ClProj x)
| CUnif (_, _, _, _, ref (Known c)) => class_name_in c
| _ => NONE
fun isClass (env : env) c =
let
fun find NONE = false
| find (SOME c) = Option.isSome (CM.find (#classes env, c))
in
find (class_name_in c)
end
fun class_head_in c =
case #1 c of
CApp (f, _) => class_head_in f
| CUnif (_, _, _, _, ref (Known c)) => class_head_in c
| _ => class_name_in c
exception Unify
fun unifyKinds (k1, k2) =
case (#1 k1, #1 k2) of
(KType, KType) => ()
| (KArrow (d1, r1), KArrow (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2))
| (KName, KName) => ()
| (KRecord k1, KRecord k2) => unifyKinds (k1, k2)
| (KUnit, KUnit) => ()
| (KTuple ks1, KTuple ks2) => (ListPair.appEq unifyKinds (ks1, ks2)
handle ListPair.UnequalLengths => raise Unify)
| (KUnif (_, _, ref (KKnown k1)), _) => unifyKinds (k1, k2)
| (_, KUnif (_, _, ref (KKnown k2))) => unifyKinds (k1, k2)
| (KRel n1, KRel n2) => if n1 = n2 then () else raise Unify
| (KFun (_, k1), KFun (_, k2)) => unifyKinds (k1, k2)
| _ => raise Unify
fun eqCons (c1, c2) =
case (#1 c1, #1 c2) of
(CUnif (nl, _, _, _, ref (Known c1)), _) => eqCons (mliftConInCon nl c1, c2)
| (_, CUnif (nl, _, _, _, ref (Known c2))) => eqCons (c1, mliftConInCon nl c2)
| (CRel n1, CRel n2) => if n1 = n2 then () else raise Unify
| (TFun (d1, r1), TFun (d2, r2)) => (eqCons (d1, d2); eqCons (r1, r2))
| (TCFun (_, _, k1, r1), TCFun (_, _, k2, r2)) => (unifyKinds (k1, k2); eqCons (r1, r2))
| (TRecord c1, TRecord c2) => eqCons (c1, c2)
| (TDisjoint (a1, b1, c1), TDisjoint (a2, b2, c2)) =>
(eqCons (a1, a2); eqCons (b1, b2); eqCons (c1, c2))
| (CNamed n1, CNamed n2) => if n1 = n2 then () else raise Unify
| (CModProj (n1, ms1, x1), CModProj (n2, ms2, x2)) =>
if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then () else raise Unify
| (CApp (f1, x1), CApp (f2, x2)) => (eqCons (f1, f2); eqCons (x1, x2))
| (CAbs (_, k1, b1), CAbs (_, k2, b2)) => (unifyKinds (k1, k2); eqCons (b1, b2))
| (CKAbs (_, b1), CKAbs (_, b2)) => eqCons (b1, b2)
| (CKApp (c1, k1), CKApp (c2, k2)) => (eqCons (c1, c2); unifyKinds (k1, k2))
| (TKFun (_, c1), TKFun (_, c2)) => eqCons (c1, c2)
| (CName s1, CName s2) => if s1 = s2 then () else raise Unify
| (CRecord (k1, xcs1), CRecord (k2, xcs2)) =>
(unifyKinds (k1, k2);
if length xcs1 <> length xcs2 then
raise Unify
else
List.app (fn (x1, c1) =>
if List.exists (fn (x2, c2) => (eqCons (x1, x2); eqCons (c1, c2); true) handle Unify => false) xcs2 then
()
else
raise Unify) xcs1)
| (CConcat (f1, x1), CConcat (f2, x2)) => (eqCons (f1, f2); eqCons (x1, x2))
| (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2))
| (CUnit, CUnit) => ()
| (CTuple cs1, CTuple cs2) => (ListPair.appEq (eqCons) (cs1, cs2)
handle ListPair.UnequalLengths => raise Unify)
| (CProj (c1, n1), CProj (c2, n2)) => (eqCons (c1, c2);
if n1 = n2 then () else raise Unify)
| _ => raise Unify
fun unifyCons (hnorm : con -> con) rs =
let
fun unify d (c1, c2) =
case (#1 (hnorm c1), #1 (hnorm c2)) of
(CUnif (nl, _, _, _, ref (Known c1)), _) => unify d (mliftConInCon nl c1, c2)
| (_, CUnif (nl, _, _, _, ref (Known c2))) => unify d (c1, mliftConInCon nl c2)
| (CUnif _, _) => ()
| (c1', CRel n2) =>
if n2 < d then
case c1' of
CRel n1 => if n1 = n2 then () else raise Unify
| _ => raise Unify
else if n2 - d >= length rs then
case c1' of
CRel n1 => if n1 = n2 - length rs then () else raise Unify
| _ => raise Unify
else
let
val r = List.nth (rs, n2 - d)
in
case !r of
NONE => r := SOME c1
| SOME c2 => eqCons (c1, c2)
end
| (TFun (d1, r1), TFun (d2, r2)) => (unify d (d1, d2); unify d (r1, r2))
| (TCFun (_, _, k1, r1), TCFun (_, _, k2, r2)) => (unifyKinds (k1, k2); unify (d + 1) (r1, r2))
| (TRecord c1, TRecord c2) => unify d (c1, c2)
| (TDisjoint (a1, b1, c1), TDisjoint (a2, b2, c2)) =>
(unify d (a1, a2); unify d (b1, b2); unify d (c1, c2))
| (CNamed n1, CNamed n2) => if n1 = n2 then () else raise Unify
| (CModProj (n1, ms1, x1), CModProj (n2, ms2, x2)) =>
if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then () else raise Unify
| (CApp (f1, x1), CApp (f2, x2)) => (unify d (f1, f2); unify d (x1, x2))
| (CAbs (_, k1, b1), CAbs (_, k2, b2)) => (unifyKinds (k1, k2); unify (d + 1) (b1, b2))
| (CKAbs (_, b1), CKAbs (_, b2)) => unify d (b1, b2)
| (CKApp (c1, k1), CKApp (c2, k2)) => (unify d (c1, c2); unifyKinds (k1, k2))
| (TKFun (_, c1), TKFun (_, c2)) => unify d (c1, c2)
| (CName s1, CName s2) => if s1 = s2 then () else raise Unify
| (CRecord (k1, xcs1), CRecord (k2, xcs2)) =>
(unifyKinds (k1, k2);
if length xcs1 <> length xcs2 then
raise Unify
else
app (fn (x1, c1) =>
if List.exists (fn (x2, c2) => (unify d (x1, x2); unify d (c1, c2); true) handle Unify => false) xcs2 then
()
else
raise Unify) xcs1)
| (CConcat (f1, x1), CConcat (f2, x2)) => (unify d (f1, f2); unify d (x1, x2))
| (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2))
| (CUnit, CUnit) => ()
| (CTuple cs1, CTuple cs2) => (ListPair.appEq (unify d) (cs1, cs2)
handle ListPair.UnequalLengths => raise Unify)
| (CProj (c1, n1), CProj (c2, n2)) => (unify d (c1, c2);
if n1 = n2 then () else raise Unify)
| _ => raise Unify
in
unify
end
fun tryUnify hnorm nRs (c1, c2) =
let
val rs = List.tabulate (nRs, fn _ => ref NONE)
in
(unifyCons hnorm rs 0 (c1, c2);
SOME (map (fn r => case !r of
NONE => raise Unify
| SOME c => c) rs))
handle Unify => NONE
end
fun unifySubst (rs : con list) =
U.Con.mapB {kind = fn _ => fn k => k,
con = fn d => fn c =>
case c of
CRel n =>
if n < d then
c
else if n - d >= length rs then
CRel (n - d)
else
#1 (List.nth (rs, n - d))
| _ => c,
bind = fn (d, U.Con.RelC _) => d + 1
| (d, _) => d}
0
exception Bad of con * con
val hasUnif = U.Con.exists {kind = fn _ => false,
con = fn CUnif (_, _, _, _, ref (Unknown _)) => true
| _ => false}
fun startsWithUnif c =
let
fun firstArg (c, acc) =
case #1 c of
CApp (f, x) => firstArg (f, SOME x)
| _ => acc
in
case firstArg (c, NONE) of
NONE => false
| SOME x => hasUnif x
end
val cause = ref (NONE : con option)
fun resolveFailureCause () = !cause
fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) =
let
fun resolve firstLevel c =
let
fun notFound () = (if firstLevel then () else cause := SOME c; NONE)
fun doHead f =
case CM.find (#classes env, f) of
NONE => notFound ()
| SOME class =>
let
val loc = #2 c
fun generalize (c as (_, loc)) =
case #1 c of
CApp (f, x) =>
let
val (f, equate) = generalize f
fun isRecord () =
let
val rk = ref (KUnknown (fn _ => true))
val k = (KUnif (loc, "k", rk), loc)
val r = ref (Unknown (fn _ => true))
val rc = (CUnif (0, loc, k, "x", r), loc)
in
((CApp (f, rc), loc),
fn () => (if consEq (rc, x) then
true
else
(raise Bad (rc, x);
false))
andalso equate ())
end
in
case #1 x of
CConcat _ => isRecord ()
| CRecord _ => isRecord ()
| _ => ((CApp (f, x), loc), equate)
end
| _ => (c, fn () => true)
val (c, equate) = generalize c
fun tryRules rules =
case rules of
[] => notFound ()
| (nRs, cs, c', e) :: rules' =>
case tryUnify hnorm nRs (c, c') of
NONE => tryRules rules'
| SOME rs =>
let
val eos = map (resolve false o unifySubst rs) cs
in
if List.exists (not o Option.isSome) eos
orelse not (equate ())
orelse not (consEq (c, unifySubst rs c')) then
tryRules rules'
else
let
val es = List.mapPartial (fn x => x) eos
val e = foldr (fn (c, e) => (ECApp (e, c), loc)) e rs
val e = foldl (fn (e', e) => (EApp (e, e'), loc)) e es
in
SOME e
end
end
in
tryRules (#openRules class @ #closedRules class)
end
in
if startsWithUnif c then
notFound ()
else
case #1 c of
TRecord c =>
(case #1 (hnorm c) of
CRecord (_, xts) =>
let
fun resolver (xts, acc) =
case xts of
[] => SOME (ERecord acc, #2 c)
| (x, t) :: xts =>
let
val t = hnorm t
val t = case t of
(CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc)
| _ => t
in
case resolve false t of
NONE => notFound ()
| SOME e => resolver (xts, (x, e, t) :: acc)
end
in
resolver (xts, [])
end
| _ => notFound ())
| _ =>
case class_head_in c of
SOME f => doHead f
| _ => notFound ()
end
in
cause := NONE;
resolve true
end
fun rule_in c =
let
fun quantifiers (c, nvars) =
case #1 c of
CUnif (_, _, _, _, ref (Known c)) => quantifiers (c, nvars)
| TCFun (_, _, _, c) => quantifiers (c, nvars + 1)
| _ =>
let
fun clauses (c, hyps) =
case #1 c of
TFun (hyp, c) =>
(case class_head_in hyp of
SOME _ => clauses (c, hyp :: hyps)
| NONE => NONE)
| _ =>
case class_head_in c of
NONE => NONE
| SOME f => SOME (f, nvars, rev hyps, c)
in
clauses (c, [])
end
in
quantifiers (c, 0)
end
fun pushERel (env : env) x t =
let
val renameE = SM.map (fn Rel' (n, t) => Rel' (n+1, t)
| x => x) (#renameE env)
val classes = CM.map (fn class =>
{openRules = map (fn (nvs, cs, c, e) => (nvs, cs, c, liftExp e)) (#openRules class),
closedRules = #closedRules class}) (#classes env)
val classes = case rule_in t of
NONE => classes
| SOME (f, nvs, cs, c) =>
case CM.find (classes, f) of
NONE => classes
| SOME class =>
let
val rule = (nvs, cs, c, (ERel 0, #2 t))
val class = {openRules = rule :: #openRules class,
closedRules = #closedRules class}
in
CM.insert (classes, f, class)
end
in
{renameK = #renameK env,
relK = #relK env,
renameC = #renameC env,
relC = #relC env,
namedC = #namedC env,
datatypes = #datatypes env,
constructors = #constructors env,
classes = classes,
renameE = SM.insert (renameE, x, Rel' (0, t)),
relE = (x, t) :: #relE env,
namedE = #namedE env,
renameSgn = #renameSgn env,
sgn = #sgn env,
renameStr = #renameStr env,
str = #str env}
end
fun lookupERel (env : env) n =
(List.nth (#relE env, n))
handle Subscript => raise UnboundRel n
fun pushENamedAs (env : env) x n t =
let
val classes = #classes env
val classes = case rule_in t of
NONE => classes
| SOME (f, nvs, cs, c) =>
case CM.find (classes, f) of
NONE => classes
| SOME class =>
let
val e = (ENamed n, #2 t)
val class =
{openRules = #openRules class,
closedRules = (nvs, cs, c, e) :: #closedRules class}
in
CM.insert (classes, f, class)
end
in
{renameK = #renameK env,
relK = #relK env,
renameC = #renameC env,
relC = #relC env,
namedC = #namedC env,
datatypes = #datatypes env,
constructors = #constructors env,
classes = classes,
renameE = SM.insert (#renameE env, x, Named' (n, t)),
relE = #relE env,
namedE = IM.insert (#namedE env, n, (x, t)),
renameSgn = #renameSgn env,
sgn = #sgn env,
renameStr = #renameStr env,
str = #str env}
end
fun pushENamed env x t =
let
val n = !namedCounter
in
namedCounter := n + 1;
(pushENamedAs env x n t, n)
end
fun lookupENamed (env : env) n =
case IM.find (#namedE env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun checkENamed (env : env) n =
Option.isSome (IM.find (#namedE env, n))
fun lookupE (env : env) x =
case SM.find (#renameE env, x) of
NONE => NotBound
| SOME (Rel' x) => Rel x
| SOME (Named' x) => Named x
fun pushSgnNamedAs (env : env) x n sgis =
{renameK = #renameK env,
relK = #relK env,
renameC = #renameC env,
relC = #relC env,
namedC = #namedC env,
datatypes = #datatypes env,
constructors = #constructors env,
classes = #classes env,
renameE = #renameE env,
relE = #relE env,
namedE = #namedE env,
renameSgn = SM.insert (#renameSgn env, x, (n, sgis)),
sgn = IM.insert (#sgn env, n, (x, sgis)),
renameStr = #renameStr env,
str = #str env}
fun pushSgnNamed env x sgis =
let
val n = !namedCounter
in
namedCounter := n + 1;
(pushSgnNamedAs env x n sgis, n)
end
fun lookupSgnNamed (env : env) n =
case IM.find (#sgn env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun lookupSgn (env : env) x = SM.find (#renameSgn env, x)
fun lookupStrNamed (env : env) n =
case IM.find (#str env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun lookupStr (env : env) x = SM.find (#renameStr env, x)
fun sgiSeek (sgi, (sgns, strs, cons)) =
case sgi of
SgiConAbs (x, n, _) => (sgns, strs, IM.insert (cons, n, x))
| SgiCon (x, n, _, _) => (sgns, strs, IM.insert (cons, n, x))
| SgiDatatype dts => (sgns, strs, foldl (fn ((x, n, _, _), cons) => IM.insert (cons, n, x)) cons dts)
| SgiDatatypeImp (x, n, _, _, _, _, _) => (sgns, strs, IM.insert (cons, n, x))
| SgiVal _ => (sgns, strs, cons)
| SgiSgn (x, n, _) => (IM.insert (sgns, n, x), strs, cons)
| SgiStr (_, x, n, _) => (sgns, IM.insert (strs, n, x), cons)
| SgiConstraint _ => (sgns, strs, cons)
| SgiClassAbs (x, n, _) => (sgns, strs, IM.insert (cons, n, x))
| SgiClass (x, n, _, _) => (sgns, strs, IM.insert (cons, n, x))
fun sgnSeek f sgis =
let
fun seek (sgis, sgns, strs, cons) =
case sgis of
[] => NONE
| (sgi, _) :: sgis =>
case f sgi of
SOME v =>
let
val cons =
case sgi of
SgiDatatype dts => foldl (fn ((x, n, _, _), cons) => IM.insert (cons, n, x)) cons dts
| SgiDatatypeImp (x, n, _, _, _, _, _) => IM.insert (cons, n, x)
| _ => cons
in
SOME (v, (sgns, strs, cons))
end
| NONE =>
let
val (sgns, strs, cons) = sgiSeek (sgi, (sgns, strs, cons))
in
seek (sgis, sgns, strs, cons)
end
in
seek (sgis, IM.empty, IM.empty, IM.empty)
end
fun id x = x
fun unravelStr (str, _) =
case str of
StrVar x => (x, [])
| StrProj (str, m) =>
let
val (x, ms) = unravelStr str
in
(x, ms @ [m])
end
| _ => raise Fail "unravelStr"
fun sgnS_con (str, (sgns, strs, cons)) c =
case c of
CModProj (m1, ms, x) =>
(case IM.find (strs, m1) of
NONE => c
| SOME m1x =>
let
val (m1, ms') = unravelStr str
in
CModProj (m1, ms' @ m1x :: ms, x)
end)
| CNamed n =>
(case IM.find (cons, n) of
NONE => c
| SOME nx =>
let
val (m1, ms) = unravelStr str
in
CModProj (m1, ms, nx)
end)
| _ => c
fun sgnS_con' (m1, ms', (sgns, strs, cons)) =
U.Con.map {kind = fn x => x,
con = fn c =>
case c of
CModProj (m1', ms, x) =>
(case IM.find (strs, m1') of
NONE => c
| SOME m1x => CModProj (m1, ms' @ m1x :: ms, x))
| CNamed n =>
(case IM.find (cons, n) of
NONE => c
| SOME nx => CModProj (m1, ms', nx))
| _ => c}
fun sgnS_sgn (str, (sgns, strs, cons)) sgn =
case sgn of
SgnProj (m1, ms, x) =>
(case IM.find (strs, m1) of
NONE => sgn
| SOME m1x =>
let
val (m1, ms') = unravelStr str
in
SgnProj (m1, ms' @ m1x :: ms, x)
end)
| SgnVar n =>
(case IM.find (sgns, n) of
NONE => sgn
| SOME nx =>
let
val (m1, ms) = unravelStr str
in
SgnProj (m1, ms, nx)
end)
| _ => sgn
fun sgnSubSgn x =
ElabUtil.Sgn.map {kind = id,
con = sgnS_con x,
sgn_item = id,
sgn = sgnS_sgn x}
and projectSgn env {sgn, str, field} =
case #1 (hnormSgn env sgn) of
SgnConst sgis =>
(case sgnSeek (fn SgiSgn (x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of
NONE => NONE
| SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn))
| SgnError => SOME (SgnError, ErrorMsg.dummySpan)
| _ => NONE
and hnormSgn env (all as (sgn, loc)) =
case sgn of
SgnError => all
| SgnVar n => hnormSgn env (#2 (lookupSgnNamed env n))
| SgnConst _ => all
| SgnFun _ => all
| SgnProj (m, ms, x) =>
let
val (_, sgn) = lookupStrNamed env m
in
case projectSgn env {str = foldl (fn (m, str) => (StrProj (str, m), loc)) (StrVar m, loc) ms,
sgn = sgn,
field = x} of
NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed"
| SOME sgn => hnormSgn env sgn
end
| SgnWhere (sgn, ms, x, c) =>
let
fun rewrite (sgn, ms) =
case #1 (hnormSgn env sgn) of
SgnError => (SgnError, loc)
| SgnConst sgis =>
let
fun traverse (ms, pre, post) =
case post of
[] => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [1]"
| (sgi as (SgiConAbs (x', n, k), loc)) :: rest =>
if List.null ms andalso x = x' then
List.revAppend (pre, (SgiCon (x', n, k, c), loc) :: rest)
else
traverse (ms, sgi :: pre, rest)
| (sgi as (SgiStr (im, x', n, sgn'), loc)) :: rest =>
(case ms of
[] => traverse (ms, sgi :: pre, rest)
| x :: ms' =>
if x = x' then
List.revAppend (pre,
(SgiStr (im, x', n,
rewrite (sgn', ms')), loc) :: rest)
else
traverse (ms, sgi :: pre, rest))
| sgi :: rest => traverse (ms, sgi :: pre, rest)
val sgis = traverse (ms, [], sgis)
in
(SgnConst sgis, loc)
end
| _ => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [2]"
in
rewrite (sgn, ms)
end
fun manifest (m, ms, loc) =
foldl (fn (m, str) => (StrProj (str, m), loc)) (StrVar m, loc) ms
fun enrichClasses env classes (m1, ms) sgn =
case #1 (hnormSgn env sgn) of
SgnConst sgis =>
let
val (classes, _, _, _) =
foldl (fn (sgi, (classes, newClasses, fmap, env)) =>
let
fun found (x, n) =
(CM.insert (classes,
ClProj (m1, ms, x),
empty_class),
IM.insert (newClasses, n, x),
sgiSeek (#1 sgi, fmap),
env)
fun default () = (classes, newClasses, sgiSeek (#1 sgi, fmap), env)
in
case #1 sgi of
SgiStr (Import, x, _, sgn) =>
let
val str = manifest (m1, ms, #2 sgi)
val sgn' = sgnSubSgn (str, fmap) sgn
in
(enrichClasses env classes (m1, ms @ [x]) sgn',
newClasses,
sgiSeek (#1 sgi, fmap),
env)
end
| SgiSgn (x, n, sgn) =>
(classes,
newClasses,
fmap,
pushSgnNamedAs env x n sgn)
| SgiClassAbs (x, n, _) => found (x, n)
| SgiClass (x, n, _, _) => found (x, n)
| SgiVal (x, n, c) =>
(case rule_in c of
NONE => default ()
| SOME (cn, nvs, cs, c) =>
let
val loc = #2 c
val globalize = sgnS_con' (m1, ms, fmap)
val nc =
case cn of
ClNamed f => IM.find (newClasses, f)
| _ => NONE
in
case nc of
NONE =>
let
val classes =
case CM.find (classes, cn) of
NONE => classes
| SOME class =>
let
val e = (EModProj (m1, ms, x), #2 sgn)
val class =
{openRules = #openRules class,
closedRules = (nvs,
map globalize cs,
globalize c,
e) :: #closedRules class}
in
CM.insert (classes, cn, class)
end
in
(classes,
newClasses,
fmap,
env)
end
| SOME fx =>
let
val cn = ClProj (m1, ms, fx)
val classes =
case CM.find (classes, cn) of
NONE => classes
| SOME class =>
let
val e = (EModProj (m1, ms, x), #2 sgn)
val class =
{openRules = #openRules class,
closedRules = (nvs,
map globalize cs,
globalize c,
e) :: #closedRules class}
in
CM.insert (classes, cn, class)
end
in
(classes,
newClasses,
fmap,
env)
end
end)
| _ => default ()
end)
(classes, IM.empty, (IM.empty, IM.empty, IM.empty), env) sgis
in
classes
end
| _ => classes
fun pushStrNamedAs (env : env) x n sgn =
{renameK = #renameK env,
relK = #relK env,
renameC = #renameC env,
relC = #relC env,
namedC = #namedC env,
datatypes = #datatypes env,
constructors = #constructors env,
classes = enrichClasses env (#classes env) (n, []) sgn,
renameE = #renameE env,
relE = #relE env,
namedE = #namedE env,
renameSgn = #renameSgn env,
sgn = #sgn env,
renameStr = SM.insert (#renameStr env, x, (n, sgn)),
str = IM.insert (#str env, n, (x, sgn))}
fun pushStrNamed env x sgn =
let
val n = !namedCounter
in
namedCounter := n + 1;
(pushStrNamedAs env x n sgn, n)
end
fun sgiBinds env (sgi, loc) =
case sgi of
SgiConAbs (x, n, k) => pushCNamedAs env x n k NONE
| SgiCon (x, n, k, c) => pushCNamedAs env x n k (SOME c)
| SgiDatatype dts =>
let
fun doOne ((x, n, xs, xncs), env) =
let
val k = (KType, loc)
val k' = foldr (fn (_, k') => (KArrow (k, k'), loc)) k xs
val env = pushCNamedAs env x n k' NONE
in
foldl (fn ((x', n', to), env) =>
let
val t =
case to of
NONE => (CNamed n, loc)
| SOME t => (TFun (t, (CNamed n, loc)), loc)
val k = (KType, loc)
val t = foldr (fn (x, t) => (TCFun (Explicit, x, k, t), loc)) t xs
in
pushENamedAs env x' n' t
end)
env xncs
end
in
foldl doOne env dts
end
| SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) =>
let
val k = (KType, loc)
val k' = foldr (fn (_, k') => (KArrow (k, k'), loc)) k xs
val env = pushCNamedAs env x n k' (SOME (CModProj (m1, ms, x'), loc))
in
foldl (fn ((x', n', to), env) =>
let
val t =
case to of
NONE => (CNamed n, loc)
| SOME t => (TFun (t, (CNamed n, loc)), loc)
val k = (KType, loc)
val t = foldr (fn (x, t) => (TCFun (Explicit, x, k, t), loc)) t xs
in
pushENamedAs env x' n' t
end)
env xncs
end
| SgiVal (x, n, t) => pushENamedAs env x n t
| SgiStr (_, x, n, sgn) => pushStrNamedAs env x n sgn
| SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn
| SgiConstraint _ => env
| SgiClassAbs (x, n, k) => pushCNamedAs env x n k NONE
| SgiClass (x, n, k, c) => pushCNamedAs env x n k (SOME c)
fun sgnSubCon x =
ElabUtil.Con.map {kind = id,
con = sgnS_con x}
fun projectStr env {sgn, str, field} =
case #1 (hnormSgn env sgn) of
SgnConst sgis =>
(case sgnSeek (fn SgiStr (_, x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of
NONE => NONE
| SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn))
| SgnError => SOME (SgnError, ErrorMsg.dummySpan)
| _ => NONE
fun chaseMpath env (n, ms) =
let
val (_, sgn) = lookupStrNamed env n
in
foldl (fn (m, (str, sgn)) =>
case projectStr env {sgn = sgn, str = str, field = m} of
NONE => raise Fail "kindof: Unknown substructure"
| SOME sgn => ((StrProj (str, m), #2 sgn), sgn))
((StrVar n, #2 sgn), sgn) ms
end
fun projectCon env {sgn, str, field} =
case #1 (hnormSgn env sgn) of
SgnConst sgis =>
(case sgnSeek (fn SgiConAbs (x, _, k) => if x = field then SOME (k, NONE) else NONE
| SgiCon (x, _, k, c) => if x = field then SOME (k, SOME c) else NONE
| SgiDatatype dts =>
(case List.find (fn (x, _, xs, _) => x = field) dts of
SOME (_, _, xs, _) =>
let
val k = (KType, #2 sgn)
val k' = foldl (fn (_, k') => (KArrow (k, k'), #2 sgn)) k xs
in
SOME (k', NONE)
end
| NONE => NONE)
| SgiDatatypeImp (x, _, m1, ms, x', xs, _) =>
if x = field then
let
val k = (KType, #2 sgn)
val k' = foldl (fn (_, k') => (KArrow (k, k'), #2 sgn)) k xs
in
SOME (k', SOME (CModProj (m1, ms, x'), #2 sgn))
end
else
NONE
| SgiClassAbs (x, _, k) => if x = field then
SOME (k, NONE)
else
NONE
| SgiClass (x, _, k, c) => if x = field then
SOME (k, SOME c)
else
NONE
| _ => NONE) sgis of
NONE => NONE
| SOME ((k, co), subs) => SOME (k, Option.map (sgnSubCon (str, subs)) co))
| SgnError => SOME ((KError, ErrorMsg.dummySpan), SOME (CError, ErrorMsg.dummySpan))
| _ => NONE
fun projectDatatype env {sgn, str, field} =
case #1 (hnormSgn env sgn) of
SgnConst sgis =>
(case sgnSeek (fn SgiDatatype dts =>
(case List.find (fn (x, _, _, _) => x = field) dts of
SOME (_, _, xs, xncs) => SOME (xs, xncs)
| NONE => NONE)
| SgiDatatypeImp (x, _, _, _, _, xs, xncs) => if x = field then SOME (xs, xncs) else NONE
| _ => NONE) sgis of
NONE => NONE
| SOME ((xs, xncs), subs) => SOME (xs,
map (fn (x, n, to) => (x, n, Option.map (sgnSubCon (str, subs)) to)) xncs))
| _ => NONE
fun projectConstructor env {sgn, str, field} =
case #1 (hnormSgn env sgn) of
SgnConst sgis =>
let
fun consider (n, xs, xncs) =
ListUtil.search (fn (x, n', to) =>
if x <> field then
NONE
else
SOME (U.classifyDatatype xncs, n', xs, to, (CNamed n, #2 str))) xncs
in
case sgnSeek (fn SgiDatatype dts =>
let
fun search dts =
case dts of
[] => NONE
| (_, n, xs, xncs) :: dts =>
case consider (n, xs, xncs) of
NONE => search dts
| v => v
in
search dts
end
| SgiDatatypeImp (_, n, _, _, _, xs, xncs) => consider (n, xs, xncs)
| _ => NONE) sgis of
NONE => NONE
| SOME ((dk, n, xs, to, t), subs) => SOME (dk, n, xs, Option.map (sgnSubCon (str, subs)) to,
sgnSubCon (str, subs) t)
end
| _ => NONE
fun projectVal env {sgn, str, field} =
case #1 (hnormSgn env sgn) of
SgnConst sgis =>
let
fun seek (n, xs, xncs) =
ListUtil.search (fn (x, _, to) =>
if x = field then
SOME (let
val base = (CNamed n, #2 sgn)
val nxs = length xs
val base = ListUtil.foldli (fn (i, _, base) =>
(CApp (base,
(CRel (nxs - i - 1), #2 sgn)),
#2 sgn))
base xs
val t =
case to of
NONE => base
| SOME t => (TFun (t, base), #2 sgn)
val k = (KType, #2 sgn)
in
foldr (fn (x, t) => (TCFun (Implicit, x, k, t), #2 sgn))
t xs
end)
else
NONE) xncs
in
case sgnSeek (fn SgiVal (x, _, c) => if x = field then SOME c else NONE
| SgiDatatype dts =>
let
fun search dts =
case dts of
[] => NONE
| (_, n, xs, xncs) :: dts =>
case seek (n, xs, xncs) of
NONE => search dts
| v => v
in
search dts
end
| SgiDatatypeImp (_, n, _, _, _, xs, xncs) => seek (n, xs, xncs)
| _ => NONE) sgis of
NONE => NONE
| SOME (c, subs) => SOME (sgnSubCon (str, subs) c)
end
| SgnError => SOME (CError, ErrorMsg.dummySpan)
| _ => NONE
fun sgnSeekConstraints (str, sgis) =
let
fun seek (sgis, sgns, strs, cons, acc) =
case sgis of
[] => acc
| (sgi, _) :: sgis =>
case sgi of
SgiConstraint (c1, c2) =>
let
val sub = sgnSubCon (str, (sgns, strs, cons))
in
seek (sgis, sgns, strs, cons, (sub c1, sub c2) :: acc)
end
| SgiConAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
| SgiCon (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
| SgiDatatype dts => seek (sgis, sgns, strs,
foldl (fn ((x, n, _, _), cons) => IM.insert (cons, n, x)) cons dts, acc)
| SgiDatatypeImp (x, n, _, _, _, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
| SgiVal _ => seek (sgis, sgns, strs, cons, acc)
| SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc)
| SgiStr (_, x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc)
| SgiClassAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
| SgiClass (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
in
seek (sgis, IM.empty, IM.empty, IM.empty, [])
end
fun projectConstraints env {sgn, str} =
case #1 (hnormSgn env sgn) of
SgnConst sgis => SOME (sgnSeekConstraints (str, sgis))
| SgnError => SOME []
| _ => NONE
fun patBinds env (p, loc) =
case p of
PVar (x, t) => pushERel env x t
| PPrim _ => env
| PCon (_, _, _, NONE) => env
| PCon (_, _, _, SOME p) => patBinds env p
| PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps
fun patBindsN (p, _) =
case p of
PVar _ => 1
| PPrim _ => 0
| PCon (_, _, _, NONE) => 0
| PCon (_, _, _, SOME p) => patBindsN p
| PRecord xps => foldl (fn ((_, p, _), n) => patBindsN p + n) 0 xps
fun edeclBinds env (d, loc) =
case d of
EDVal (p, _, _) => patBinds env p
| EDValRec vis => foldl (fn ((x, t, _), env) => pushERel env x t) env vis
fun declBinds env (d, loc) =
case d of
DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c)
| DDatatype dts =>
let
fun doOne ((x, n, xs, xncs), env) =
let
val k = (KType, loc)
val nxs = length xs
val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) =>
((CApp (tb, (CRel (nxs - i - 1), loc)), loc),
(KArrow (k, kb), loc)))
((CNamed n, loc), k) xs
val env = pushCNamedAs env x n kb NONE
val env = pushDatatype env n xs xncs
in
foldl (fn ((x', n', to), env) =>
let
val t =
case to of
NONE => tb
| SOME t => (TFun (t, tb), loc)
val t = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs
in
pushENamedAs env x' n' t
end)
env xncs
end
in
foldl doOne env dts
end
| DDatatypeImp (x, n, m, ms, x', xs, xncs) =>
let
val t = (CModProj (m, ms, x'), loc)
val k = (KType, loc)
val nxs = length xs
val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) =>
((CApp (tb, (CRel (nxs - i - 1), loc)), loc),
(KArrow (k, kb), loc)))
((CNamed n, loc), k) xs
val env = pushCNamedAs env x n kb (SOME t)
val env = pushDatatype env n xs xncs
in
foldl (fn ((x', n', to), env) =>
let
val t =
case to of
NONE => tb
| SOME t => (TFun (t, tb), loc)
val t = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs
in
pushENamedAs env x' n' t
end)
env xncs
end
| DVal (x, n, t, _) => pushENamedAs env x n t
| DValRec vis => foldl (fn ((x, n, t, _), env) => pushENamedAs env x n t) env vis
| DSgn (x, n, sgn) => pushSgnNamedAs env x n sgn
| DStr (x, n, sgn, _) => pushStrNamedAs env x n sgn
| DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn
| DConstraint _ => env
| DExport _ => env
| DTable (tn, x, n, c, _, pc, _, cc) =>
let
val ct = (CModProj (tn, [], "sql_table"), loc)
val ct = (CApp (ct, c), loc)
val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc)
in
pushENamedAs env x n ct
end
| DSequence (tn, x, n) =>
let
val t = (CModProj (tn, [], "sql_sequence"), loc)
in
pushENamedAs env x n t
end
| DView (tn, x, n, _, c) =>
let
val ct = (CModProj (tn, [], "sql_view"), loc)
val ct = (CApp (ct, c), loc)
in
pushENamedAs env x n ct
end
| DDatabase _ => env
| DCookie (tn, x, n, c) =>
let
val t = (CApp ((CModProj (tn, [], "cookie"), loc), c), loc)
in
pushENamedAs env x n t
end
| DStyle (tn, x, n) =>
let
val t = (CModProj (tn, [], "css_class"), loc)
in
pushENamedAs env x n t
end
| DTask _ => env
| DPolicy _ => env
| DOnError _ => env
| DFfi (x, n, _, t) => pushENamedAs env x n t
end
urweb-20160213+dfsg/src/elab_err.sig 0000664 0000000 0000000 00000013403 12657647235 0017105 0 ustar 00root root 0000000 0000000 (* 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.
*)
signature ELAB_ERR = sig
datatype kind_error =
UnboundKind of ErrorMsg.span * string
val kindError : ElabEnv.env -> kind_error -> unit
datatype kunify_error =
KOccursCheckFailed of Elab.kind * Elab.kind
| KIncompatible of Elab.kind * Elab.kind
| KScope of Elab.kind * Elab.kind
val kunifyError : ElabEnv.env -> kunify_error -> unit
datatype con_error =
UnboundCon of ErrorMsg.span * string
| UnboundDatatype of ErrorMsg.span * string
| UnboundStrInCon of ErrorMsg.span * string
| WrongKind of Elab.con * Elab.kind * Elab.kind * ElabEnv.env * kunify_error
| DuplicateField of ErrorMsg.span * string
| ProjBounds of Elab.con * int
| ProjMismatch of Elab.con * Elab.kind
val conError : ElabEnv.env -> con_error -> unit
datatype cunify_error =
CKind of Elab.kind * Elab.kind * ElabEnv.env * kunify_error
| COccursCheckFailed of Elab.con * Elab.con
| CIncompatible of Elab.con * Elab.con
| CExplicitness of Elab.con * Elab.con
| CKindof of Elab.kind * Elab.con * string
| CRecordFailure of Elab.con * Elab.con * (Elab.con * Elab.con * Elab.con * (ElabEnv.env * cunify_error) option) option
| TooLifty of ErrorMsg.span * ErrorMsg.span
| TooUnify of Elab.con * Elab.con
| TooDeep
| CScope of Elab.con * Elab.con
val cunifyError : ElabEnv.env -> cunify_error -> unit
datatype exp_error =
UnboundExp of ErrorMsg.span * string
| UnboundStrInExp of ErrorMsg.span * string
| Unify of Elab.exp * Elab.con * Elab.con * ElabEnv.env * cunify_error
| Unif of string * ErrorMsg.span * Elab.con
| WrongForm of string * Elab.exp * Elab.con
| IncompatibleCons of Elab.con * Elab.con
| DuplicatePatternVariable of ErrorMsg.span * string
| PatUnify of Elab.pat * Elab.con * Elab.con * ElabEnv.env * cunify_error
| UnboundConstructor of ErrorMsg.span * string list * string
| PatHasArg of ErrorMsg.span
| PatHasNoArg of ErrorMsg.span
| Inexhaustive of ErrorMsg.span * Elab.pat
| DuplicatePatField of ErrorMsg.span * string
| Unresolvable of ErrorMsg.span * Elab.con
| OutOfContext of ErrorMsg.span * (Elab.exp * Elab.con) option
| IllegalRec of string * Elab.exp
| IllegalFlex of Source.exp
val expError : ElabEnv.env -> exp_error -> unit
datatype decl_error =
KunifsRemain of Elab.decl list
| CunifsRemain of Elab.decl list
| Nonpositive of Elab.decl
val declError : ElabEnv.env -> decl_error -> unit
datatype sgn_error =
UnboundSgn of ErrorMsg.span * string
| UnmatchedSgi of ErrorMsg.span * Elab.sgn_item
| SgiWrongKind of ErrorMsg.span * Elab.sgn_item * Elab.kind * Elab.sgn_item * Elab.kind * ElabEnv.env * kunify_error
| SgiWrongCon of ErrorMsg.span * Elab.sgn_item * Elab.con * Elab.sgn_item * Elab.con * ElabEnv.env * cunify_error
| SgiMismatchedDatatypes of ErrorMsg.span * Elab.sgn_item * Elab.sgn_item
* (Elab.con * Elab.con * ElabEnv.env * cunify_error) option
| SgnWrongForm of ErrorMsg.span * Elab.sgn * Elab.sgn
| UnWhereable of Elab.sgn * string
| WhereWrongKind of Elab.kind * Elab.kind * ElabEnv.env * kunify_error
| NotIncludable of Elab.sgn
| DuplicateCon of ErrorMsg.span * string
| DuplicateVal of ErrorMsg.span * string
| DuplicateSgn of ErrorMsg.span * string
| DuplicateStr of ErrorMsg.span * string
| NotConstraintsable of Elab.sgn
val sgnError : ElabEnv.env -> sgn_error -> unit
datatype str_error =
UnboundStr of ErrorMsg.span * string
| NotFunctor of Elab.sgn
| FunctorRebind of ErrorMsg.span
| UnOpenable of Elab.sgn
| NotType of ErrorMsg.span * Elab.kind * (Elab.kind * Elab.kind * ElabEnv.env * kunify_error)
| DuplicateConstructor of string * ErrorMsg.span
| NotDatatype of ErrorMsg.span
val strError : ElabEnv.env -> str_error -> unit
end
urweb-20160213+dfsg/src/elab_err.sml 0000664 0000000 0000000 00000046543 12657647235 0017131 0 ustar 00root root 0000000 0000000 (* 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.
*)
structure ElabErr :> ELAB_ERR = struct
structure L = Source
open Elab
structure E = ElabEnv
structure U = ElabUtil
open Print
structure P = ElabPrint
val p_kind = P.p_kind
datatype kind_error =
UnboundKind of ErrorMsg.span * string
fun kindError env err =
case err of
UnboundKind (loc, s) =>
ErrorMsg.errorAt loc ("Unbound kind variable " ^ s)
datatype kunify_error =
KOccursCheckFailed of kind * kind
| KIncompatible of kind * kind
| KScope of kind * kind
fun kunifyError env err =
case err of
KOccursCheckFailed (k1, k2) =>
eprefaces "Kind occurs check failed"
[("Kind 1", p_kind env k1),
("Kind 2", p_kind env k2)]
| KIncompatible (k1, k2) =>
eprefaces "Incompatible kinds"
[("Kind 1", p_kind env k1),
("Kind 2", p_kind env k2)]
| KScope (k1, k2) =>
eprefaces "Scoping prevents kind unification"
[("Kind 1", p_kind env k1),
("Kind 2", p_kind env k2)]
fun p_con env c = P.p_con env (ElabOps.reduceCon env c)
datatype con_error =
UnboundCon of ErrorMsg.span * string
| UnboundDatatype of ErrorMsg.span * string
| UnboundStrInCon of ErrorMsg.span * string
| WrongKind of con * kind * kind * E.env * kunify_error
| DuplicateField of ErrorMsg.span * string
| ProjBounds of con * int
| ProjMismatch of con * kind
fun conError env err =
case err of
UnboundCon (loc, s) =>
ErrorMsg.errorAt loc ("Unbound constructor variable " ^ s)
| UnboundDatatype (loc, s) =>
ErrorMsg.errorAt loc ("Unbound datatype " ^ s)
| UnboundStrInCon (loc, 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),
("Have kind", p_kind env k1),
("Need kind", p_kind env k2)];
kunifyError env' kerr)
| DuplicateField (loc, 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),
("Index", Print.PD.string (Int.toString n))])
| ProjMismatch (c, k) =>
(ErrorMsg.errorAt (#2 c) "Projection from non-tuple constructor";
eprefaces' [("Constructor", p_con env c),
("Kind", p_kind env k)])
datatype cunify_error =
CKind of kind * kind * E.env * kunify_error
| COccursCheckFailed of con * con
| CIncompatible of con * con
| CExplicitness of con * con
| CKindof of kind * con * string
| CRecordFailure of con * con * (con * con * con * (E.env * cunify_error) option) option
| TooLifty of ErrorMsg.span * ErrorMsg.span
| TooUnify of con * con
| TooDeep
| CScope of con * con
fun cunifyError env err : unit =
case err of
CKind (k1, k2, env', kerr) =>
(eprefaces "Kind unification failure"
[("Have", p_kind env k1),
("Need", p_kind env k2)];
kunifyError env' kerr)
| COccursCheckFailed (c1, c2) =>
eprefaces "Constructor occurs check failed"
[("Have", p_con env c1),
("Need", p_con env c2)]
| CIncompatible (c1, c2) =>
eprefaces "Incompatible constructors"
[("Have", p_con env c1),
("Need", p_con env c2)]
| CExplicitness (c1, c2) =>
eprefaces "Differing constructor function explicitness"
[("Have", p_con env c1),
("Need", p_con env c2)]
| CKindof (k, c, expected) =>
eprefaces ("Unexpected kind for kindof calculation (expecting " ^ expected ^ ")")
[("Kind", p_kind env k),
("Con", p_con env c)]
| CRecordFailure (c1, c2, fo) =>
(eprefaces "Can't unify record constructors"
(("Have", p_con env c1)
:: ("Need", p_con env c2)
:: (case fo of
NONE => []
| SOME (nm, t1, t2, _) =>
[("Field", p_con env nm),
("Value 1", p_con env t1),
("Value 2", p_con env t2)]));
case fo of
SOME (_, _, _, SOME (env', err')) => cunifyError env' err'
| _ => ())
| TooLifty (loc1, loc2) =>
(ErrorMsg.errorAt loc1 "Can't unify two unification variables that both have suspended liftings";
eprefaces' [("Other location", Print.PD.string (ErrorMsg.spanToString loc2))])
| TooUnify (c1, c2) =>
(ErrorMsg.errorAt (#2 c1) "Substitution in constructor is blocked by a too-deep unification variable";
eprefaces' [("Replacement", p_con env c1),
("Body", p_con env c2)])
| TooDeep => ErrorMsg.error "Can't reverse-engineer unification variable lifting"
| CScope (c1, c2) =>
eprefaces "Scoping prevents constructor unification"
[("Have", p_con env c1),
("Need", p_con env c2)]
datatype exp_error =
UnboundExp of ErrorMsg.span * string
| UnboundStrInExp of ErrorMsg.span * string
| Unify of exp * con * con * E.env * cunify_error
| Unif of string * ErrorMsg.span * con
| WrongForm of string * exp * con
| IncompatibleCons of con * con
| DuplicatePatternVariable of ErrorMsg.span * string
| PatUnify of pat * con * con * E.env * cunify_error
| UnboundConstructor of ErrorMsg.span * string list * string
| PatHasArg of ErrorMsg.span
| PatHasNoArg of ErrorMsg.span
| Inexhaustive of ErrorMsg.span * pat
| DuplicatePatField of ErrorMsg.span * string
| Unresolvable of ErrorMsg.span * con
| OutOfContext of ErrorMsg.span * (exp * con) option
| IllegalRec of string * exp
| IllegalFlex of Source.exp
val simplExp = U.Exp.mapB {kind = fn _ => fn k => k,
con = fn env => fn c => #1 (ElabOps.reduceCon env (c, ErrorMsg.dummySpan)),
exp = fn _ => fn e => e,
bind = fn (env, U.Exp.RelC (x, k)) => E.pushCRel env x k
| (env, U.Exp.NamedC (x, n, k, co)) => E.pushCNamedAs env x n k co
| (env, _) => env}
fun p_exp env e = P.p_exp env (simplExp env e)
val p_pat = P.p_pat
fun expError env err =
case err of
UnboundExp (loc, s) =>
ErrorMsg.errorAt loc ("Unbound expression variable " ^ s)
| UnboundStrInExp (loc, 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),
("Have con", p_con env c1),
("Need con", p_con env c2)];
cunifyError env' uerr)
| Unif (action, loc, c) =>
(ErrorMsg.errorAt loc ("Unification variable blocks " ^ action);
eprefaces' [("Con", p_con env c)])
| WrongForm (variety, e, t) =>
(ErrorMsg.errorAt (#2 e) ("Expression is not a " ^ variety);
eprefaces' [("Expression", p_exp env e),
("Type", p_con env t)])
| IncompatibleCons (c1, c2) =>
(ErrorMsg.errorAt (#2 c1) "Incompatible constructors";
eprefaces' [("Have", p_con env c1),
("Need", p_con env c2)])
| DuplicatePatternVariable (loc, 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),
("Have con", p_con env c1),
("Need con", p_con env c2)];
cunifyError env' uerr)
| UnboundConstructor (loc, ms, s) =>
ErrorMsg.errorAt loc ("Unbound constructor " ^ String.concatWith "." (ms @ [s]) ^ " in pattern")
| PatHasArg loc =>
ErrorMsg.errorAt loc "Constructor expects no argument but is used with argument"
| PatHasNoArg loc =>
ErrorMsg.errorAt loc "Constructor expects argument but is used with no argument"
| Inexhaustive (loc, p) =>
(ErrorMsg.errorAt loc "Inexhaustive 'case'";
eprefaces' [("Missed case", p_pat env p)])
| DuplicatePatField (loc, s) =>
ErrorMsg.errorAt loc ("Duplicate record field " ^ s ^ " in pattern")
| OutOfContext (loc, co) =>
(ErrorMsg.errorAt loc "Type class wildcard occurs out of context";
Option.app (fn (e, c) => eprefaces' [("Function", p_exp env e),
("Type", p_con env c)]) co)
| Unresolvable (loc, c) =>
(ErrorMsg.errorAt loc "Can't resolve type class instance";
eprefaces' ([("Class constraint", p_con env c)]
@ (case E.resolveFailureCause () of
NONE => []
| SOME c' => [("Reduced to unresolvable", p_con env c')]))(*;
app (fn (c, rs) => (eprefaces' [("CLASS", p_con env c)];
app (fn (c, e) => eprefaces' [("RULE", p_con env c),
("IMPL", p_exp env e)]) rs))
(E.listClasses env)*))
| IllegalRec (x, e) =>
(ErrorMsg.errorAt (#2 e) "Illegal 'val rec' righthand side (must be a function abstraction)";
eprefaces' [("Variable", PD.string x),
("Expression", p_exp env e)])
| IllegalFlex e =>
(ErrorMsg.errorAt (#2 e) "Flex record syntax (\"...\") only allowed in patterns";
eprefaces' [("Expression", SourcePrint.p_exp e)])
datatype decl_error =
KunifsRemain of decl list
| CunifsRemain of decl list
| Nonpositive of decl
fun lspan [] = ErrorMsg.dummySpan
| lspan ((_, loc) :: _) = loc
val baseLen = 2000
fun p_decl env d =
let
val fname = OS.FileSys.tmpName ()
val out' = TextIO.openOut fname
val out = Print.openOut {dst = out', wid = 80}
fun readFromFile () =
let
val inf = TextIO.openIn fname
fun loop acc =
case TextIO.inputLine inf of
NONE => String.concat (rev acc)
| SOME line => loop (line :: acc)
in
loop []
before TextIO.closeIn inf
end
in
Print.fprint out (P.p_decl env d);
TextIO.closeOut out';
let
val content = readFromFile ()
in
OS.FileSys.remove fname;
Print.PD.string (if size content <= baseLen then
content
else
let
val (befor, after) = Substring.position "
(ErrorMsg.errorAt (lspan ds) "Some kind unification variables are undetermined in declaration\n(look for them as \"\")";
eprefaces' [("Decl", p_list_sep PD.newline (p_decl env) ds)])
| CunifsRemain ds =>
(ErrorMsg.errorAt (lspan ds) "Some constructor unification variables are undetermined in declaration\n(look for them as \"\")";
eprefaces' [("Decl", p_list_sep PD.newline (p_decl env) ds)])
| Nonpositive d =>
(ErrorMsg.errorAt (#2 d) "Non-strictly-positive datatype declaration (could allow non-termination)";
eprefaces' [("Decl", p_decl env d)])
datatype sgn_error =
UnboundSgn of ErrorMsg.span * string
| UnmatchedSgi of ErrorMsg.span * sgn_item
| SgiWrongKind of ErrorMsg.span * sgn_item * kind * sgn_item * kind * E.env * kunify_error
| SgiWrongCon of ErrorMsg.span * sgn_item * con * sgn_item * con * E.env * cunify_error
| SgiMismatchedDatatypes of ErrorMsg.span * sgn_item * sgn_item
* (con * con * E.env * cunify_error) option
| SgnWrongForm of ErrorMsg.span * sgn * sgn
| UnWhereable of sgn * string
| WhereWrongKind of kind * kind * E.env * kunify_error
| NotIncludable of sgn
| DuplicateCon of ErrorMsg.span * string
| DuplicateVal of ErrorMsg.span * string
| DuplicateSgn of ErrorMsg.span * string
| DuplicateStr of ErrorMsg.span * string
| NotConstraintsable of sgn
val p_sgn_item = P.p_sgn_item
val p_sgn = P.p_sgn
fun sgnError env err =
case err of
UnboundSgn (loc, s) =>
ErrorMsg.errorAt loc ("Unbound signature variable " ^ s)
| UnmatchedSgi (loc, sgi) =>
(ErrorMsg.errorAt loc "Unmatched signature item";
eprefaces' [("Item", p_sgn_item env sgi)])
| SgiWrongKind (loc, sgi1, k1, sgi2, k2, env', kerr) =>
(ErrorMsg.errorAt loc "Kind unification failure in signature matching:";
eprefaces' [("Have", p_sgn_item env sgi1),
("Need", p_sgn_item env sgi2),
("Kind 1", p_kind env k1),
("Kind 2", p_kind env k2)];
kunifyError env' kerr)
| SgiWrongCon (loc, sgi1, c1, sgi2, c2, env', cerr) =>
(ErrorMsg.errorAt loc "Constructor unification failure in signature matching:";
eprefaces' [("Have", p_sgn_item env sgi1),
("Need", p_sgn_item env sgi2),
("Con 1", p_con env c1),
("Con 2", p_con env c2)];
cunifyError env' cerr)
| SgiMismatchedDatatypes (loc, sgi1, sgi2, cerro) =>
(ErrorMsg.errorAt loc "Mismatched 'datatype' specifications:";
eprefaces' [("Have", p_sgn_item env sgi1),
("Need", p_sgn_item env sgi2)];
Option.app (fn (c1, c2, env', ue) =>
(eprefaces "Unification error"
[("Con 1", p_con env' c1),
("Con 2", p_con env' c2)];
cunifyError env' ue)) cerro)
| SgnWrongForm (loc, sgn1, sgn2) =>
(ErrorMsg.errorAt loc "Incompatible signatures:";
eprefaces' [("Sig 1", p_sgn env sgn1),
("Sig 2", p_sgn env sgn2)])
| UnWhereable (sgn, x) =>
(ErrorMsg.errorAt (#2 sgn) "Unavailable field for 'where'";
eprefaces' [("Signature", p_sgn env sgn),
("Field", PD.string x)])
| WhereWrongKind (k1, k2, env', kerr) =>
(ErrorMsg.errorAt (#2 k1) "Wrong kind for 'where'";
eprefaces' [("Have", p_kind env k1),
("Need", p_kind env k2)];
kunifyError env' kerr)
| NotIncludable sgn =>
(ErrorMsg.errorAt (#2 sgn) "Invalid signature to 'include'";
eprefaces' [("Signature", p_sgn env sgn)])
| DuplicateCon (loc, s) =>
ErrorMsg.errorAt loc ("Duplicate constructor " ^ s ^ " in signature")
| DuplicateVal (loc, s) =>
ErrorMsg.errorAt loc ("Duplicate value " ^ s ^ " in signature")
| DuplicateSgn (loc, s) =>
ErrorMsg.errorAt loc ("Duplicate signature " ^ s ^ " in signature")
| DuplicateStr (loc, s) =>
ErrorMsg.errorAt loc ("Duplicate structure " ^ s ^ " in signature")
| NotConstraintsable sgn =>
(ErrorMsg.errorAt (#2 sgn) "Invalid signature for 'open constraints'";
eprefaces' [("Signature", p_sgn env sgn)])
datatype str_error =
UnboundStr of ErrorMsg.span * string
| NotFunctor of sgn
| FunctorRebind of ErrorMsg.span
| UnOpenable of sgn
| NotType of ErrorMsg.span * kind * (kind * kind * E.env * kunify_error)
| DuplicateConstructor of string * ErrorMsg.span
| NotDatatype of ErrorMsg.span
fun strError env err =
case err of
UnboundStr (loc, s) =>
ErrorMsg.errorAt loc ("Unbound structure variable " ^ s)
| NotFunctor sgn =>
(ErrorMsg.errorAt (#2 sgn) "Application of non-functor";
eprefaces' [("Signature", p_sgn env sgn)])
| FunctorRebind loc =>
ErrorMsg.errorAt loc "Attempt to rebind functor"
| UnOpenable sgn =>
(ErrorMsg.errorAt (#2 sgn) "Un-openable structure";
eprefaces' [("Signature", p_sgn env sgn)])
| NotType (loc, k, (k1, k2, env', ue)) =>
(ErrorMsg.errorAt loc "'val' type kind is not 'Type'";
eprefaces' [("Kind", p_kind env k),
("Subkind 1", p_kind env k1),
("Subkind 2", p_kind env k2)];
kunifyError env' ue)
| DuplicateConstructor (x, loc) =>
ErrorMsg.errorAt loc ("Duplicate datatype constructor " ^ x)
| NotDatatype loc =>
ErrorMsg.errorAt loc "Trying to import non-datatype as a datatype"
end
urweb-20160213+dfsg/src/elab_ops.sig 0000664 0000000 0000000 00000004230 12657647235 0017114 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 ELAB_OPS = sig
exception SubUnif
val liftKindInKind : int -> Elab.kind -> Elab.kind
val subKindInKind : int * Elab.kind -> Elab.kind -> Elab.kind
val liftKindInCon : int -> Elab.con -> Elab.con
val subKindInCon : int * Elab.kind -> Elab.con -> Elab.con
val liftConInCon : int -> Elab.con -> Elab.con
val subConInCon : int * Elab.con -> Elab.con -> Elab.con
val subStrInSgn : int * int -> Elab.sgn -> Elab.sgn
val hnormCon : ElabEnv.env -> Elab.con -> Elab.con
val reduceCon : ElabEnv.env -> Elab.con -> Elab.con
val identity : int ref
val distribute : int ref
val fuse : int ref
val reset : unit -> unit
end
urweb-20160213+dfsg/src/elab_ops.sml 0000664 0000000 0000000 00000056721 12657647235 0017141 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 ElabOps :> ELAB_OPS = struct
open Elab
structure E = ElabEnv
structure U = ElabUtil
fun liftKindInKind' by =
U.Kind.mapB {kind = fn bound => fn k =>
case k of
KRel xn =>
if xn < bound then
k
else
KRel (xn + by)
| _ => k,
bind = fn (bound, _) => bound + 1}
fun subKindInKind' rep =
U.Kind.mapB {kind = fn (by, xn) => fn k =>
case k of
KRel xn' =>
(case Int.compare (xn', xn) of
EQUAL => #1 (liftKindInKind' by 0 rep)
| GREATER => KRel (xn' - 1)
| LESS => k)
| _ => k,
bind = fn ((by, xn), _) => (by+1, xn+1)}
val liftKindInKind = liftKindInKind' 1
fun subKindInKind (xn, rep) = subKindInKind' rep (0, xn)
fun liftKindInCon by =
U.Con.mapB {kind = fn bound => fn k =>
case k of
KRel xn =>
if xn < bound then
k
else
KRel (xn + by)
| _ => k,
con = fn _ => fn c => c,
bind = fn (bound, U.Con.RelK _) => bound + 1
| (bound, _) => bound}
fun subKindInCon' rep =
U.Con.mapB {kind = fn (by, xn) => fn k =>
case k of
KRel xn' =>
(case Int.compare (xn', xn) of
EQUAL => #1 (liftKindInKind' by 0 rep)
| GREATER => KRel (xn' - 1)
| LESS => k)
| _ => k,
con = fn _ => fn c => c,
bind = fn ((by, xn), U.Con.RelK _) => (by+1, xn+1)
| (st, _) => st}
val liftKindInCon = liftKindInCon 1
fun subKindInCon (xn, rep) = subKindInCon' rep (0, xn)
fun liftConInCon by =
U.Con.mapB {kind = fn _ => fn k => k,
con = fn bound => fn c =>
case c of
CRel xn =>
if xn < bound then
c
else
CRel (xn + by)
| CUnif (nl, loc, k, s, r) => CUnif (nl+by, loc, k, s, r)
| _ => c,
bind = fn (bound, U.Con.RelC _) => bound + 1
| (bound, _) => bound}
exception SubUnif
fun subConInCon' rep =
U.Con.mapB {kind = fn _ => fn k => k,
con = fn (by, xn) => fn c =>
case c of
CRel xn' =>
(case Int.compare (xn', xn) of
EQUAL => #1 (liftConInCon by 0 rep)
| GREATER => CRel (xn' - 1)
| LESS => c)
| CUnif (0, _, _, _, _) => raise SubUnif
| CUnif (n, loc, k, s, r) => CUnif (n-1, loc, k, s, r)
| _ => c,
bind = fn ((by, xn), U.Con.RelC _) => (by+1, xn+1)
| (ctx, _) => ctx}
val liftConInCon = liftConInCon 1
fun subConInCon (xn, rep) = subConInCon' rep (0, xn)
fun subStrInSgn (m1, m2) =
U.Sgn.map {kind = fn k => k,
con = fn c as CModProj (m1', ms, x) =>
if m1 = m1' then
CModProj (m2, ms, x)
else
c
| c => c,
sgn_item = fn sgi => sgi,
sgn = fn sgn => sgn}
val occurs =
U.Con.existsB {kind = fn _ => false,
con = fn (n, c) =>
case c of
CRel n' => n' = n
| _ => false,
bind = fn (n, b) =>
case b of
U.Con.RelC _ => n + 1
| _ => n}
0
val identity = ref 0
val distribute = ref 0
val fuse = ref 0
fun reset () = (identity := 0;
distribute := 0;
fuse := 0)
fun hnormCon env (cAll as (c, loc)) =
case c of
CUnif (nl, _, _, _, ref (Known c)) => (#1 (hnormCon env (E.mliftConInCon nl c)), loc)
| CNamed xn =>
(case E.lookupCNamed env xn of
(_, _, SOME c') => hnormCon env c'
| _ => cAll)
| CModProj (n, ms, x) =>
let
val (_, sgn) = E.lookupStrNamed env n
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => raise Fail "hnormCon: Unknown substructure"
| SOME sgn => ((StrProj (str, m), loc), sgn))
((StrVar n, loc), sgn) ms
in
case E.projectCon env {sgn = sgn, str = str, field = x} of
NONE => raise Fail "kindof: Unknown con in structure"
| SOME (_, NONE) => cAll
| SOME (_, SOME c) => hnormCon env c
end
(* Eta reduction *)
| CAbs (x, k, b) =>
(case #1 (hnormCon (E.pushCRel env x k) b) of
CApp (f, (CRel 0, _)) =>
if occurs f then
cAll
else
hnormCon env (subConInCon (0, (CUnit, loc)) f)
| _ => cAll)
| CApp (c1, c2) =>
(case #1 (hnormCon env c1) of
CAbs (x, k, cb) =>
let
val sc = (hnormCon env (subConInCon (0, c2) cb))
handle SynUnif => cAll
(*val env' = E.pushCRel env x k*)
in
(*Print.eprefaces "Subst" [("x", Print.PD.string x),
("cb", ElabPrint.p_con env' cb),
("c2", ElabPrint.p_con env c2),
("sc", ElabPrint.p_con env sc)];*)
sc
end
| c1' as CApp (c', f) =>
let
fun default () = (CApp ((c1', loc), hnormCon env c2), loc)
in
case #1 (hnormCon env c') of
CMap (ks as (k1, k2)) =>
(case #1 (hnormCon env c2) of
CRecord (_, []) => (CRecord (k2, []), loc)
| CRecord (_, (x, c) :: rest) =>
hnormCon env
(CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc),
(CApp (c1, (CRecord (k2, rest), loc)), loc)), loc)
| CConcat ((CRecord (k, (x, c) :: rest), _), rest') =>
let
val rest'' = (CConcat ((CRecord (k, rest), loc), rest'), loc)
in
hnormCon env
(CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc),
(CApp (c1, rest''), loc)), loc)
end
| _ =>
let
fun unconstraint c =
case hnormCon env c of
(TDisjoint (_, _, c), _) => unconstraint c
| c => c
fun inc r = r := !r + 1
fun tryDistributivity () =
case hnormCon env c2 of
(CConcat (c1, c2'), _) =>
let
val c = (CMap ks, loc)
val c = (CApp (c, f), loc)
val c1 = (CApp (c, c1), loc)
val c2 = (CApp (c, c2'), loc)
val c = (CConcat (c1, c2), loc)
in
inc distribute;
hnormCon env c
end
| _ => default ()
fun tryFusion () =
case #1 (hnormCon env c2) of
CApp (f', r') =>
(case #1 (hnormCon env f') of
CApp (f', inner_f) =>
(case #1 (hnormCon env f') of
CMap (dom, _) =>
let
val inner_f = liftConInCon 0 inner_f
val f = liftConInCon 0 f
val f' = (CApp (inner_f, (CRel 0, loc)), loc)
val f' = (CApp (f, f'), loc)
val f' = (CAbs ("v", dom, f'), loc)
val c = (CMap (dom, k2), loc)
val c = (CApp (c, f'), loc)
val c = (CApp (c, r'), loc)
in
inc fuse;
hnormCon env c
end
| _ => tryDistributivity ())
| _ => tryDistributivity ())
| _ => tryDistributivity ()
fun tryIdentity () =
let
fun cunif () =
let
val r = ref (Unknown (fn _ => true))
in
(r, (CUnif (0, loc, (KType, loc), "_", r), loc))
end
val (vR, v) = cunif ()
val c = (CApp (f, v), loc)
in
case unconstraint c of
(CUnif (_, _, _, _, vR'), _) =>
if vR' = vR then
(inc identity;
hnormCon env c2)
else
tryFusion ()
| _ => tryFusion ()
end
in
tryIdentity ()
end)
| _ => default ()
end
| c1' => (CApp ((c1', loc), hnormCon env c2), loc))
| CKApp (c1, k) =>
(case hnormCon env c1 of
(CKAbs (_, body), _) => hnormCon env (subKindInCon (0, k) body)
| _ => cAll)
| CConcat (c1, c2) =>
(case (hnormCon env c1, hnormCon env c2) of
((CRecord (k, xcs1), loc), (CRecord (_, xcs2), _)) =>
(CRecord (k, xcs1 @ xcs2), loc)
| ((CRecord (_, []), _), c2') => c2'
| ((CConcat (c11, c12), loc), c2') =>
hnormCon env (CConcat (c11, (CConcat (c12, c2'), loc)), loc)
| (c1', (CRecord (_, []), _)) => c1'
| (c1', c2') => (CConcat (c1', c2'), loc))
| CProj (c, n) =>
(case hnormCon env c of
(CTuple cs, _) => hnormCon env (List.nth (cs, n - 1))
| _ => cAll)
| _ => cAll
fun reduceCon env (cAll as (c, loc)) =
case c of
TFun (c1, c2) => (TFun (reduceCon env c1, reduceCon env c2), loc)
| TCFun (exp, x, k, c) => (TCFun (exp, x, k, reduceCon env c), loc)
| TRecord c => (TRecord (reduceCon env c), loc)
| TDisjoint (c1, c2, c3) => (TDisjoint (reduceCon env c1, reduceCon env c2, reduceCon env c3), loc)
| CRel _ => cAll
| CNamed xn =>
(case E.lookupCNamed env xn of
(_, _, SOME c') => reduceCon env c'
| _ => cAll)
| CModProj (n, ms, x) =>
let
val (_, sgn) = E.lookupStrNamed env n
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => raise Fail "reduceCon: Unknown substructure"
| SOME sgn => ((StrProj (str, m), loc), sgn))
((StrVar n, loc), sgn) ms
in
case E.projectCon env {sgn = sgn, str = str, field = x} of
NONE => raise Fail "reduceCon: kindof: Unknown con in structure"
| SOME (_, NONE) => cAll
| SOME (_, SOME c) => reduceCon env c
end
| CApp (c1, c2) =>
let
val c1 = reduceCon env c1
val c2 = reduceCon env c2
fun default () = (CApp (c1, c2), loc)
in
case #1 c1 of
CAbs (x, k, cb) =>
((reduceCon env (subConInCon (0, c2) cb))
handle SynUnif => default ())
| CApp (c', f) =>
let
val c' = reduceCon env c'
val f = reduceCon env f
in
case #1 c' of
CMap (ks as (k1, k2)) =>
(case #1 c2 of
CRecord (_, []) => (CRecord (k2, []), loc)
| CRecord (_, (x, c) :: rest) =>
reduceCon env
(CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc),
(CApp (c1, (CRecord (k2, rest), loc)), loc)), loc)
| CConcat ((CRecord (k, (x, c) :: rest), _), rest') =>
let
val rest'' = (CConcat ((CRecord (k, rest), loc), rest'), loc)
in
reduceCon env
(CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc),
(CApp (c1, rest''), loc)), loc)
end
| _ =>
let
fun unconstraint c =
case reduceCon env c of
(TDisjoint (_, _, c), _) => unconstraint c
| c => c
fun inc r = r := !r + 1
fun tryDistributivity () =
case reduceCon env c2 of
(CConcat (c1, c2), _) =>
let
val c = (CMap ks, loc)
val c = (CApp (c, f), loc)
val c1 = (CApp (c, c1), loc)
val c2 = (CApp (c, c2), loc)
val c = (CConcat (c1, c2), loc)
in
inc distribute;
reduceCon env c
end
| _ => default ()
fun tryFusion () =
case #1 (reduceCon env c2) of
CApp (f', r') =>
(case #1 (reduceCon env f') of
CApp (f', inner_f) =>
(case #1 (reduceCon env f') of
CMap (dom, _) =>
let
val inner_f = liftConInCon 0 inner_f
val f = liftConInCon 0 f
val f' = (CApp (inner_f, (CRel 0, loc)), loc)
val f' = (CApp (f, f'), loc)
val f' = (CAbs ("v", dom, f'), loc)
val c = (CMap (dom, k2), loc)
val c = (CApp (c, f'), loc)
val c = (CApp (c, r'), loc)
in
inc fuse;
reduceCon env c
end
| _ => tryDistributivity ())
| _ => tryDistributivity ())
| _ => tryDistributivity ()
fun tryIdentity () =
let
fun cunif () =
let
val r = ref (Unknown (fn _ => true))
in
(r, (CUnif (0, loc, (KType, loc), "_", r), loc))
end
val (vR, v) = cunif ()
val c = (CApp (f, v), loc)
in
case unconstraint c of
(CUnif (_, _, _, _, vR'), _) =>
if vR' = vR then
(inc identity;
reduceCon env c2)
else
tryFusion ()
| _ => tryFusion ()
end
in
tryIdentity ()
end)
| _ => default ()
end
| _ => default ()
end
| CAbs (x, k, b) =>
let
val b = reduceCon (E.pushCRel env x k) b
fun default () = (CAbs (x, k, b), loc)
in
case #1 b of
CApp (f, (CRel 0, _)) =>
if occurs f then
default ()
else
reduceCon env (subConInCon (0, (CUnit, loc)) f)
| _ => default ()
end
| CKAbs (x, b) => (CKAbs (x, reduceCon (E.pushKRel env x) b), loc)
| CKApp (c1, k) =>
(case reduceCon env c1 of
(CKAbs (_, body), _) => reduceCon env (subKindInCon (0, k) body)
| c1 => (CKApp (c1, k), loc))
| TKFun (x, c) => (TKFun (x, reduceCon env c), loc)
| CName _ => cAll
| CRecord (k, xcs) => (CRecord (k, map (fn (x, c) => (reduceCon env x, reduceCon env c)) xcs), loc)
| CConcat (c1, c2) =>
let
val c1 = reduceCon env c1
val c2 = reduceCon env c2
in
case (c1, c2) of
((CRecord (k, xcs1), loc), (CRecord (_, xcs2), _)) => (CRecord (k, xcs1 @ xcs2), loc)
| ((CRecord (_, []), _), _) => c2
| ((CConcat (c11, c12), loc), _) => reduceCon env (CConcat (c11, (CConcat (c12, c2), loc)), loc)
| (_, (CRecord (_, []), _)) => c1
| ((CRecord (k, xcs1), loc), (CConcat ((CRecord (_, xcs2), _), c2'), _)) => (CConcat ((CRecord (k, xcs1 @ xcs2), loc), c2'), loc)
| _ => (CConcat (c1, c2), loc)
end
| CMap _ => cAll
| CUnit => cAll
| CTuple cs => (CTuple (map (reduceCon env) cs), loc)
| CProj (c, n) =>
(case reduceCon env c of
(CTuple cs, _) => reduceCon env (List.nth (cs, n - 1))
| c => (CProj (c, n), loc))
| CError => cAll
| CUnif (nl, _, _, _, ref (Known c)) => reduceCon env (E.mliftConInCon nl c)
| CUnif _ => cAll
end
urweb-20160213+dfsg/src/elab_print.sig 0000664 0000000 0000000 00000004166 12657647235 0017457 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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.
*)
(* Pretty-printing Ur/Web *)
signature ELAB_PRINT = sig
val p_kind : ElabEnv.env -> Elab.kind Print.printer
val p_explicitness : Elab.explicitness Print.printer
val p_con : ElabEnv.env -> Elab.con Print.printer
val p_pat : ElabEnv.env -> Elab.pat Print.printer
val p_exp : ElabEnv.env -> Elab.exp Print.printer
val p_decl : ElabEnv.env -> Elab.decl Print.printer
val p_sgn_item : ElabEnv.env -> Elab.sgn_item Print.printer
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
urweb-20160213+dfsg/src/elab_print.sml 0000664 0000000 0000000 00000113261 12657647235 0017465 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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.
*)
(* Pretty-printing elaborated Ur/Web *)
structure ElabPrint :> ELAB_PRINT = struct
open Print.PD
open Print
open Elab
structure E = ElabEnv
val debug = ref false
fun p_kind' par env (k, _) =
case k of
KType => string "Type"
| KArrow (k1, k2) => parenIf par (box [p_kind' true env k1,
space,
string "->",
space,
p_kind env k2])
| KName => string "Name"
| KRecord k => box [string "{", p_kind env k, string "}"]
| KUnit => string "Unit"
| KTuple ks => box [string "(",
p_list_sep (box [space, string "*", space]) (p_kind env) ks,
string ")"]
| KError => string ""
| KUnif (_, _, ref (KKnown k)) => p_kind' par env k
| KUnif (_, s, _) => string ("")
| KTupleUnif (_, _, ref (KKnown k)) => p_kind' par env k
| KTupleUnif (_, nks, _) => box [string "(",
p_list_sep (box [space, string "*", space])
(fn (n, k) => box [string (Int.toString n ^ ":"),
space,
p_kind env k]) nks,
space,
string "*",
space,
string "...)"]
| KRel n => ((if !debug then
string (E.lookupKRel env n ^ "_" ^ Int.toString n)
else
string (E.lookupKRel env n))
handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
| KFun (x, k) => box [string x,
space,
string "-->",
space,
p_kind (E.pushKRel env x) k]
and p_kind env = p_kind' false env
fun p_explicitness e =
case e of
Explicit => string "::"
| Implicit => string ":::"
fun p_con' par env (c, _) =
case c of
TFun (t1, t2) => parenIf par (box [p_con' true env t1,
space,
string "->",
space,
p_con env t2])
| TCFun (e, x, k, c) => parenIf par (box [string x,
space,
p_explicitness e,
space,
p_kind env k,
space,
string "->",
space,
p_con (E.pushCRel env x k) c])
| TDisjoint (c1, c2, c3) => parenIf par (box [string "[",
p_con env c1,
space,
string "~",
space,
p_con env c2,
string "]",
space,
string "=>",
space,
p_con env c3])
| TRecord (CRecord (_, xcs), _) =>
let
fun isTuple (n, xcs) =
case xcs of
[] => n > 2
| ((CName s, _), _) :: xcs' =>
s = Int.toString n andalso isTuple (n+1, xcs')
| _ => false
in
if isTuple (1, xcs) then
case xcs of
(_, c) :: xcs =>
parenIf par (box [p_con' true env c,
p_list_sep (box []) (fn (_, c) => box [space,
string "*",
space,
p_con' true env c]) xcs])
| _ => raise Fail "ElabPrint: surprise empty tuple"
else
box [string "{",
p_list (fn (x, c) =>
box [p_name env x,
space,
string ":",
space,
p_con env c]) xcs,
string "}"]
end
| TRecord c => box [string "$",
p_con' true env c]
| CRel n =>
((if !debug then
string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
else
string (#1 (E.lookupCRel env n)))
handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
| CNamed n =>
((if !debug then
string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupCNamed env n)))
handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
| CModProj (m1, ms, x) =>
let
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
val m1s = if !debug then
m1x ^ "__" ^ Int.toString m1
else
m1x
in
if m1x = "Basis" andalso (case E.lookupC env x of
E.Named (n, _) =>
let
val (_, _, co) = E.lookupCNamed env n
in
case co of
SOME (CModProj (m1', [], x'), _) => m1' = m1 andalso x' = x
| _ => false
end
| E.NotBound => true
| _ => false) then
string x
else
p_list_sep (string ".") string (m1s :: ms @ [x])
end
| CApp (c1, c2) => parenIf par (box [p_con env c1,
space,
p_con' true env c2])
| CAbs (x, k, c) => parenIf true (box [string "fn",
space,
string x,
space,
string "::",
space,
p_kind env k,
space,
string "=>",
space,
p_con (E.pushCRel env x k) c])
| CName s => box [string "#", string s]
| CRecord (k, xcs) =>
if !debug then
parenIf par (box [string "[",
p_list (fn (x, c) =>
box [p_name env x,
space,
string "=",
space,
p_con env c]) xcs,
string "]::",
p_kind env k])
else
parenIf par (box [string "[",
p_list (fn (x, c) =>
box [p_name env x,
space,
string "=",
space,
p_con env c]) xcs,
string "]"])
| CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
space,
string "++",
space,
p_con env c2])
| CMap _ => string "map"
| CUnit => string "()"
| CTuple cs => box [string "(",
p_list (p_con env) cs,
string ")"]
| CProj (c, n) => box [p_con env c,
string ".",
string (Int.toString n)]
| CError => string ""
| CUnif (nl, _, _, _, ref (Known c)) => p_con' par env (E.mliftConInCon nl c)
| CUnif (nl, _, k, s, _) => box [string (" box []
| _ => string ("+" ^ Int.toString nl),
string ">"]
| CKAbs (x, c) => box [string x,
space,
string "==>",
space,
p_con (E.pushKRel env x) c]
| CKApp (c, k) => box [p_con env c,
string "[[",
p_kind env k,
string "]]"]
| TKFun (x, c) => box [string x,
space,
string "-->",
space,
p_con (E.pushKRel env x) c]
and p_con env = p_con' false env
and p_name env (all as (c, _)) =
case c of
CName s => string s
| _ => p_con env all
fun p_patCon env pc =
case pc of
PConVar n =>
((if !debug then
string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupENamed env n)))
handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
| PConProj (m1, ms, x) =>
let
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
val m1s = if !debug then
m1x ^ "__" ^ Int.toString m1
else
m1x
in
p_list_sep (string ".") string (m1x :: ms @ [x])
end
fun p_pat' par env (p, _) =
case p of
PVar (s, _) => string s
| PPrim p => Prim.p_t p
| PCon (_, pc, _, NONE) => p_patCon env pc
| PCon (_, pc, _, SOME p) => parenIf par (box [p_patCon env pc,
space,
p_pat' true env p])
| PRecord xps =>
box [string "{",
p_list_sep (box [string ",", space]) (fn (x, p, t) =>
box [string x,
space,
string "=",
space,
p_pat env p,
if !debug then
box [space,
string ":",
space,
p_con env t]
else
box []]) xps,
string "}"]
and p_pat x = p_pat' false x
fun p_exp' par env (e, _) =
case e of
EPrim p => Prim.p_t p
| ERel n =>
((if !debug then
string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
else
string (#1 (E.lookupERel env n)))
handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
| ENamed n =>
((if !debug then
string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupENamed env n)))
handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
| EModProj (m1, ms, x) =>
let
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
val m1s = if !debug then
m1x ^ "__" ^ Int.toString m1
else
m1x
in
p_list_sep (string ".") string (m1x :: ms @ [x])
end
| EApp (e1, e2) => parenIf par (box [p_exp env e1,
space,
p_exp' true env e2])
| EAbs (x, t, _, e) => parenIf par (box [string "fn",
space,
string x,
space,
string ":",
space,
p_con env t,
space,
string "=>",
space,
p_exp (E.pushERel env x t) e])
| ECApp (e, c) => parenIf par (box [p_exp env e,
space,
string "[",
p_con env c,
string "]"])
| ECAbs (exp, x, k, e) => parenIf par (box [string "fn",
space,
string x,
space,
p_explicitness exp,
space,
p_kind env k,
space,
string "=>",
space,
p_exp (E.pushCRel env x k) e])
| ERecord xes => box [string "{",
p_list (fn (x, e, _) =>
box [p_name env x,
space,
string "=",
space,
p_exp env e]) xes,
string "}"]
| EField (e, c, {field, rest}) =>
if !debug then
box [p_exp' true env e,
string ".",
p_con' true env c,
space,
string "[",
p_con env field,
space,
string " in ",
space,
p_con env rest,
string "]"]
else
box [p_exp' true env e,
string ".",
p_con' true env c]
| EConcat (e1, c1, e2, c2) =>
parenIf par (if !debug then
box [p_exp' true env e1,
space,
string ":",
space,
p_con env c1,
space,
string "++",
space,
p_exp' true env e2,
space,
string ":",
space,
p_con env c2]
else
box [p_exp' true env e1,
space,
string "++",
space,
p_exp' true env e2])
| ECut (e, c, {field, rest}) =>
parenIf par (if !debug then
box [p_exp' true env e,
space,
string "--",
space,
p_con' true env c,
space,
string "[",
p_con env field,
space,
string " in ",
space,
p_con env rest,
string "]"]
else
box [p_exp' true env e,
space,
string "--",
space,
p_con' true env c])
| ECutMulti (e, c, {rest}) =>
parenIf par (if !debug then
box [p_exp' true env e,
space,
string "---",
space,
p_con' true env c,
space,
string "[",
p_con env rest,
string "]"]
else
box [p_exp' true env e,
space,
string "---",
space,
p_con' true env c])
| ECase (e, pes, _) => parenIf par (box [string "case",
space,
p_exp env e,
space,
string "of",
space,
p_list_sep (box [space, string "|", space])
(fn (p, e) => box [p_pat env p,
space,
string "=>",
space,
p_exp (E.patBinds env p) e]) pes])
| EError => string ""
| EUnif (ref (SOME e)) => p_exp env e
| EUnif _ => string "_"
| ELet (ds, e, _) =>
let
val (dsp, env) = ListUtil.foldlMap
(fn (d, env) =>
(p_edecl env d,
E.edeclBinds env d))
env ds
in
box [string "let",
newline,
box [p_list_sep newline (fn x => x) dsp],
newline,
string "in",
newline,
box [p_exp env e],
newline,
string "end"]
end
| EKAbs (x, e) => box [string x,
space,
string "==>",
space,
p_exp (E.pushKRel env x) e]
| EKApp (e, k) => box [p_exp env e,
string "[[",
p_kind env k,
string "]]"]
and p_exp env = p_exp' false env
and p_edecl env (dAll as (d, _)) =
case d of
EDVal (p, t, e) => box [string "val",
space,
p_pat env p,
space,
string ":",
space,
p_con env t,
space,
string "=",
space,
p_exp env e]
| EDValRec vis =>
let
val env = E.edeclBinds env dAll
in
box [string "val",
space,
string "rec",
space,
p_list_sep (box [newline, string "and", space]) (p_evali env) vis]
end
and p_evali env (x, t, e) = box [string x,
space,
string ":",
space,
p_con env t,
space,
string "=",
space,
p_exp env e]
fun p_datatype env (x, n, xs, cons) =
let
val k = (KType, ErrorMsg.dummySpan)
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,
p_list_sep (box []) (fn x => box [space, string x]) xs,
space,
string "=",
space,
p_list_sep (box [space, string "|", space])
(fn (x, _, NONE) => string x
| (x, _, SOME t) => box [string x, space, string "of", space, p_con env t])
cons]
end
fun p_named x n =
if !debug then
box [string x,
string "__",
string (Int.toString n)]
else
string x
fun p_sgn_item env (sgiAll as (sgi, _)) =
case sgi of
SgiConAbs (x, n, k) => box [string "con",
space,
p_named x n,
space,
string "::",
space,
p_kind env k]
| SgiCon (x, n, k, c) => box [string "con",
space,
p_named x n,
space,
string "::",
space,
p_kind env k,
space,
string "=",
space,
p_con env c]
| SgiDatatype x => box [string "datatype",
space,
p_list_sep (box [space, string "and", space]) (p_datatype (E.sgiBinds env sgiAll)) x]
| SgiDatatypeImp (x, _, m1, ms, x', _, _) =>
let
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
in
box [string "datatype",
space,
string x,
space,
string "=",
space,
string "datatype",
space,
p_list_sep (string ".") string (m1x :: ms @ [x'])]
end
| SgiVal (x, n, c) => box [string "val",
space,
p_named x n,
space,
string ":",
space,
p_con env c]
| SgiStr (_, x, n, sgn) => box [string "structure",
space,
p_named x n,
space,
string ":",
space,
p_sgn env sgn]
| SgiSgn (x, n, sgn) => box [string "signature",
space,
p_named x n,
space,
string "=",
space,
p_sgn env sgn]
| SgiConstraint (c1, c2) => box [string "constraint",
space,
p_con env c1,
space,
string "~",
space,
p_con env c2]
| SgiClassAbs (x, n, k) => box [string "class",
space,
p_named x n,
space,
string "::",
space,
p_kind env k]
| SgiClass (x, n, k, c) => box [string "class",
space,
p_named x n,
space,
string "::",
space,
p_kind env k,
space,
string "=",
space,
p_con env c]
and p_sgn env (sgn, _) =
case sgn of
SgnConst sgis => box [string "sig",
newline,
let
val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) =>
(p_sgn_item env sgi,
E.sgiBinds env sgi))
env sgis
in
p_list_sep newline (fn x => x) psgis
end,
newline,
string "end"]
| SgnVar n => ((string (#1 (E.lookupSgnNamed env n)))
handle E.UnboundNamed _ => string ("UNBOUND_SGN_" ^ Int.toString n))
| SgnFun (x, n, sgn, sgn') => box [string "functor",
space,
string "(",
string x,
space,
string ":",
space,
p_sgn env sgn,
string ")",
space,
string ":",
space,
p_sgn (E.pushStrNamedAs env x n sgn) sgn']
| SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn,
space,
string "where",
space,
string "con",
space,
p_list_sep (string ".") string (ms @ [x]),
space,
string "=",
space,
p_con env c]
| SgnProj (m1, ms, x) =>
let
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_SGN_" ^ Int.toString m1
val m1s = if !debug then
m1x ^ "__" ^ Int.toString m1
else
m1x
in
p_list_sep (string ".") string (m1x :: ms @ [x])
end
| SgnError => string ""
fun p_vali env (x, n, t, e) = box [p_named x n,
space,
string ":",
space,
p_con env t,
space,
string "=",
space,
p_exp env e]
fun p_decl env (dAll as (d, _) : decl) =
case d of
DCon (x, n, k, c) => box [string "con",
space,
p_named x n,
space,
string "::",
space,
p_kind env k,
space,
string "=",
space,
p_con env c]
| DDatatype x => box [string "datatype",
space,
p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x]
| DDatatypeImp (x, _, m1, ms, x', _, _) =>
let
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
in
box [string "datatype",
space,
string x,
space,
string "=",
space,
string "datatype",
space,
p_list_sep (string ".") string (m1x :: ms @ [x'])]
end
| DVal vi => box [string "val",
space,
p_vali env vi]
| DValRec vis =>
let
val env = E.declBinds env dAll
in
box [string "val",
space,
string "rec",
space,
p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
end
| DSgn (x, n, sgn) => box [string "signature",
space,
p_named x n,
space,
string "=",
space,
p_sgn env sgn]
| DStr (x, n, sgn, str) => box [string "structure",
space,
p_named x n,
space,
string ":",
space,
p_sgn env sgn,
space,
string "=",
space,
p_str env str]
| DFfiStr (x, n, sgn) => box [string "extern",
space,
string "structure",
space,
p_named x n,
space,
string ":",
space,
p_sgn env sgn]
| DConstraint (c1, c2) => box [string "constraint",
space,
p_con env c1,
space,
string "~",
space,
p_con env c2]
| DExport (_, sgn, str) => box [string "export",
space,
p_str env str,
space,
string ":",
space,
p_sgn env sgn]
| DTable (_, x, n, c, pe, _, ce, _) => box [string "table",
space,
p_named x n,
space,
string ":",
space,
p_con env c,
space,
string "keys",
space,
p_exp env pe,
space,
string "constraints",
space,
p_exp env ce]
| DSequence (_, x, n) => box [string "sequence",
space,
p_named x n]
| DView (_, x, n, e, _) => box [string "view",
space,
p_named x n,
space,
string "as",
space,
p_exp env e]
| DDatabase s => box [string "database",
space,
string s]
| DCookie (_, x, n, c) => box [string "cookie",
space,
p_named x n,
space,
string ":",
space,
p_con env c]
| DStyle (_, x, n) => box [string "style",
space,
p_named x n]
| DTask (e1, e2) => box [string "task",
space,
p_exp env e1,
space,
string "=",
space,
p_exp env e2]
| DPolicy e1 => box [string "policy",
space,
p_exp env e1]
| DOnError _ => string "ONERROR"
| DFfi _ => string "FFI"
and p_str env (str, _) =
case str of
StrConst ds => box [string "struct",
newline,
p_file env ds,
newline,
string "end"]
| StrVar n => ((string (#1 (E.lookupStrNamed env n)))
handle E.UnboundNamed _ => string ("UNBOUND_STR_" ^ Int.toString n))
| StrProj (str, s) => box [p_str env str,
string ".",
string s]
| StrFun (x, n, sgn, sgn', str) =>
let
val env' = E.pushStrNamedAs env x n sgn
in
box [string "functor",
space,
string "(",
string x,
space,
string ":",
space,
p_sgn env sgn,
string ")",
space,
string ":",
space,
p_sgn env' sgn',
space,
string "=>",
space,
p_str env' str]
end
| StrApp (str1, str2) => box [p_str env str1,
string "(",
p_str env str2,
string ")"]
| StrError => string ""
and p_file env file =
let
val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
(p_decl env d,
E.declBinds env d))
env file
in
p_list_sep newline (fn x => x) pds
end
end
urweb-20160213+dfsg/src/elab_util.sig 0000664 0000000 0000000 00000031063 12657647235 0017274 0 ustar 00root root 0000000 0000000 (* 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.
*)
signature ELAB_UTIL = sig
val classifyDatatype : (string * int * 'a option) list -> Elab.datatype_kind
val mliftConInCon : (int -> Elab.con -> Elab.con) ref
structure Kind : sig
val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB,
bind : 'context * string -> 'context}
-> ('context, Elab.kind, 'state, 'abort) Search.mapfolderB
val mapfold : (Elab.kind', 'state, 'abort) Search.mapfolder
-> (Elab.kind, 'state, 'abort) Search.mapfolder
val exists : (Elab.kind' -> bool) -> Elab.kind -> bool
val mapB : {kind : 'context -> Elab.kind' -> Elab.kind',
bind : 'context * string -> 'context}
-> 'context -> (Elab.kind -> Elab.kind)
val foldB : {kind : 'context * Elab.kind' * 'state -> 'state,
bind : 'context * string -> 'context}
-> 'context -> 'state -> Elab.kind -> 'state
end
structure Con : sig
datatype binder =
RelK of string
| RelC of string * Elab.kind
| NamedC of string * int * Elab.kind * Elab.con option
val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Elab.con, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder,
con : (Elab.con', 'state, 'abort) Search.mapfolder}
-> (Elab.con, 'state, 'abort) Search.mapfolder
val mapB : {kind : 'context -> Elab.kind' -> Elab.kind',
con : 'context -> Elab.con' -> Elab.con',
bind : 'context * binder -> 'context}
-> 'context -> (Elab.con -> Elab.con)
val map : {kind : Elab.kind' -> Elab.kind',
con : Elab.con' -> Elab.con'}
-> Elab.con -> Elab.con
val appB : {kind : 'context -> Elab.kind' -> unit,
con : 'context -> Elab.con' -> unit,
bind : 'context * binder -> 'context}
-> 'context -> (Elab.con -> unit)
val app : {kind : Elab.kind' -> unit,
con : Elab.con' -> unit}
-> Elab.con -> unit
val existsB : {kind : 'context * Elab.kind' -> bool,
con : 'context * Elab.con' -> bool,
bind : 'context * binder -> 'context}
-> 'context -> Elab.con -> bool
val exists : {kind : Elab.kind' -> bool,
con : Elab.con' -> bool} -> Elab.con -> bool
val foldB : {kind : 'context * Elab.kind' * 'state -> 'state,
con : 'context * Elab.con' * 'state -> 'state,
bind : 'context * binder -> 'context}
-> 'context -> 'state -> Elab.con -> 'state
val fold : {kind : Elab.kind' * 'state -> 'state,
con : Elab.con' * 'state -> 'state}
-> 'state -> Elab.con -> 'state
end
structure Exp : 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
val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB,
exp : ('context, Elab.exp', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Elab.exp, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder,
con : (Elab.con', 'state, 'abort) Search.mapfolder,
exp : (Elab.exp', 'state, 'abort) Search.mapfolder}
-> (Elab.exp, 'state, 'abort) Search.mapfolder
val mapB : {kind : 'context -> Elab.kind' -> Elab.kind',
con : 'context -> Elab.con' -> Elab.con',
exp : 'context -> Elab.exp' -> Elab.exp',
bind : 'context * binder -> 'context}
-> 'context -> (Elab.exp -> Elab.exp)
val exists : {kind : Elab.kind' -> bool,
con : Elab.con' -> bool,
exp : Elab.exp' -> bool} -> Elab.exp -> bool
val existsB : {kind : 'context * Elab.kind' -> bool,
con : 'context * Elab.con' -> bool,
exp : 'context * Elab.exp' -> bool,
bind : 'context * binder -> 'context}
-> 'context -> Elab.exp -> bool
val foldB : {kind : 'context * Elab.kind' * 'state -> 'state,
con : 'context * Elab.con' * 'state -> 'state,
exp : 'context * Elab.exp' * 'state -> 'state,
bind : 'context * binder -> 'context}
-> 'context -> 'state -> Elab.exp -> 'state
end
structure Sgn : sig
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
val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB,
sgn_item : ('context, Elab.sgn_item', 'state, 'abort) Search.mapfolderB,
sgn : ('context, Elab.sgn', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Elab.sgn, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder,
con : (Elab.con', 'state, 'abort) Search.mapfolder,
sgn_item : (Elab.sgn_item', 'state, 'abort) Search.mapfolder,
sgn : (Elab.sgn', 'state, 'abort) Search.mapfolder}
-> (Elab.sgn, 'state, 'abort) Search.mapfolder
val map : {kind : Elab.kind' -> Elab.kind',
con : Elab.con' -> Elab.con',
sgn_item : Elab.sgn_item' -> Elab.sgn_item',
sgn : Elab.sgn' -> Elab.sgn'}
-> Elab.sgn -> Elab.sgn
val mapB : {kind : 'context -> Elab.kind' -> Elab.kind',
con : 'context -> Elab.con' -> Elab.con',
sgn_item : 'context -> Elab.sgn_item' -> Elab.sgn_item',
sgn : 'context -> Elab.sgn' -> Elab.sgn',
bind : 'context * binder -> 'context}
-> 'context -> Elab.sgn -> Elab.sgn
end
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 mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB,
exp : ('context, Elab.exp', 'state, 'abort) Search.mapfolderB,
sgn_item : ('context, Elab.sgn_item', 'state, 'abort) Search.mapfolderB,
sgn : ('context, Elab.sgn', 'state, 'abort) Search.mapfolderB,
str : ('context, Elab.str', 'state, 'abort) Search.mapfolderB,
decl : ('context, Elab.decl', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Elab.decl, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder,
con : (Elab.con', 'state, 'abort) Search.mapfolder,
exp : (Elab.exp', 'state, 'abort) Search.mapfolder,
sgn_item : (Elab.sgn_item', 'state, 'abort) Search.mapfolder,
sgn : (Elab.sgn', 'state, 'abort) Search.mapfolder,
str : (Elab.str', 'state, 'abort) Search.mapfolder,
decl : (Elab.decl', 'state, 'abort) Search.mapfolder}
-> (Elab.decl, 'state, 'abort) Search.mapfolder
val exists : {kind : Elab.kind' -> bool,
con : Elab.con' -> bool,
exp : Elab.exp' -> bool,
sgn_item : Elab.sgn_item' -> bool,
sgn : Elab.sgn' -> bool,
str : Elab.str' -> bool,
decl : Elab.decl' -> bool}
-> Elab.decl -> bool
val search : {kind : Elab.kind' -> 'a option,
con : Elab.con' -> 'a option,
exp : Elab.exp' -> 'a option,
sgn_item : Elab.sgn_item' -> 'a option,
sgn : Elab.sgn' -> 'a option,
str : Elab.str' -> 'a option,
decl : Elab.decl' -> 'a option}
-> Elab.decl -> 'a option
val foldMapB : {kind : 'context * Elab.kind' * 'state -> Elab.kind' * 'state,
con : 'context * Elab.con' * 'state -> Elab.con' * 'state,
exp : 'context * Elab.exp' * 'state -> Elab.exp' * 'state,
sgn_item : 'context * Elab.sgn_item' * 'state -> Elab.sgn_item' * 'state,
sgn : 'context * Elab.sgn' * 'state -> Elab.sgn' * 'state,
str : 'context * Elab.str' * 'state -> Elab.str' * 'state,
decl : 'context * Elab.decl' * 'state -> Elab.decl' * 'state,
bind : 'context * binder -> 'context}
-> 'context -> 'state -> Elab.decl -> Elab.decl * 'state
val map : {kind : Elab.kind' -> Elab.kind',
con : Elab.con' -> Elab.con',
exp : Elab.exp' -> Elab.exp',
sgn_item : Elab.sgn_item' -> Elab.sgn_item',
sgn : Elab.sgn' -> Elab.sgn',
str : Elab.str' -> Elab.str',
decl : Elab.decl' -> Elab.decl'}
-> Elab.decl -> Elab.decl
val mapB : {kind : 'context -> Elab.kind' -> Elab.kind',
con : 'context -> Elab.con' -> Elab.con',
exp : 'context -> Elab.exp' -> Elab.exp',
sgn_item : 'context -> Elab.sgn_item' -> Elab.sgn_item',
sgn : 'context -> Elab.sgn' -> Elab.sgn',
str : 'context -> Elab.str' -> Elab.str',
decl : 'context -> Elab.decl' -> Elab.decl',
bind : 'context * binder -> 'context}
-> 'context -> Elab.decl -> Elab.decl
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
end
structure File : sig
val maxName : Elab.file -> int
val findDecl : (Elab.decl -> bool) -> Elab.file -> Elab.decl option
end
end
urweb-20160213+dfsg/src/elab_util.sml 0000664 0000000 0000000 00000166325 12657647235 0017317 0 ustar 00root root 0000000 0000000 (* 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 ElabUtil :> ELAB_UTIL = struct
open Elab
fun classifyDatatype xncs =
case xncs of
[(_, _, NONE), (_, _, SOME _)] => Option
| [(_, _, SOME _), (_, _, NONE)] => Option
| _ =>
if List.all (fn (_, _, NONE) => true | _ => false) xncs then
Enum
else
Default
structure S = Search
structure Kind = struct
fun mapfoldB {kind, bind} =
let
fun mfk ctx k acc =
S.bindP (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
fun mapfold fk =
mapfoldB {kind = fn () => fk,
bind = fn ((), _) => ()} ()
fun mapB {kind, bind} ctx k =
case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
bind = bind} ctx k () of
S.Continue (k, ()) => k
| S.Return _ => raise Fail "ElabUtil.Kind.mapB: Impossible"
fun exists f k =
case mapfold (fn k => fn () =>
if f k then
S.Return ()
else
S.Continue (k, ())) k () of
S.Return _ => true
| S.Continue _ => false
fun foldB {kind, bind} ctx st k =
case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (k, kind (ctx, k, st)),
bind = bind} ctx k st of
S.Continue (_, st) => st
| S.Return _ => raise Fail "ElabUtil.Kind.foldB: Impossible"
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.bindP (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
fun mapfold {kind = fk, con = fc} =
mapfoldB {kind = fn () => fk,
con = fn () => fc,
bind = fn ((), _) => ()} ()
fun mapB {kind, con, bind} ctx c =
case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()),
bind = bind} ctx c () of
S.Continue (c, ()) => c
| S.Return _ => raise Fail "ElabUtil.Con.mapB: Impossible"
fun map {kind, con} s =
case mapfold {kind = fn k => fn () => S.Continue (kind k, ()),
con = fn c => fn () => S.Continue (con c, ())} s () of
S.Return () => raise Fail "ElabUtil.Con.map: Impossible"
| S.Continue (s, ()) => s
fun appB {kind, con, bind} ctx c =
case mapfoldB {kind = fn ctx => fn k => fn () => (kind ctx k; S.Continue (k, ())),
con = fn ctx => fn c => fn () => (con ctx c; S.Continue (c, ())),
bind = bind} ctx c () of
S.Continue _ => ()
| S.Return _ => raise Fail "ElabUtil.Con.appB: Impossible"
fun app {kind, con} s =
case mapfold {kind = fn k => fn () => (kind k; S.Continue (k, ())),
con = fn c => fn () => (con c; S.Continue (c, ()))} s () of
S.Return () => raise Fail "ElabUtil.Con.app: Impossible"
| S.Continue _ => ()
fun existsB {kind, con, bind} ctx c =
case mapfoldB {kind = fn ctx => fn k => fn () =>
if kind (ctx, k) then
S.Return ()
else
S.Continue (k, ()),
con = fn ctx => fn c => fn () =>
if con (ctx, c) then
S.Return ()
else
S.Continue (c, ()),
bind = bind} ctx c () of
S.Return _ => true
| S.Continue _ => false
fun exists {kind, con} c =
case mapfold {kind = fn k => fn () =>
if kind k then
S.Return ()
else
S.Continue (k, ()),
con = fn c => fn () =>
if con c then
S.Return ()
else
S.Continue (c, ())} c () of
S.Return _ => true
| S.Continue _ => false
fun foldB {kind, con, bind} ctx st c =
case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (k, kind (ctx, k, st)),
con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)),
bind = bind} ctx c st of
S.Continue (_, st) => st
| S.Return _ => raise Fail "ElabUtil.Con.foldB: Impossible"
fun fold {kind, con} st c =
case mapfoldB {kind = fn () => fn k => fn st => S.Continue (k, kind (k, st)),
con = fn () => fn c => fn st => S.Continue (c, con (c, st)),
bind = fn ((), _) => ()} () c st of
S.Continue (_, st) => st
| S.Return _ => raise Fail "ElabUtil.Con.fold: Impossible"
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.bindP (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
fun mapfold {kind = fk, con = fc, exp = fe} =
mapfoldB {kind = fn () => fk,
con = fn () => fc,
exp = fn () => fe,
bind = fn ((), _) => ()} ()
fun existsB {kind, con, exp, bind} ctx e =
case mapfoldB {kind = fn ctx => fn k => fn () =>
if kind (ctx, k) then
S.Return ()
else
S.Continue (k, ()),
con = fn ctx => fn c => fn () =>
if con (ctx, c) then
S.Return ()
else
S.Continue (c, ()),
exp = fn ctx => fn e => fn () =>
if exp (ctx, e) then
S.Return ()
else
S.Continue (e, ()),
bind = bind} ctx e () of
S.Return _ => true
| S.Continue _ => false
fun exists {kind, con, exp} k =
case mapfold {kind = fn k => fn () =>
if kind k then
S.Return ()
else
S.Continue (k, ()),
con = fn c => fn () =>
if con c then
S.Return ()
else
S.Continue (c, ()),
exp = fn e => fn () =>
if exp e then
S.Return ()
else
S.Continue (e, ())} k () of
S.Return _ => true
| S.Continue _ => false
fun mapB {kind, con, exp, bind} ctx e =
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, ()),
bind = bind} ctx e () of
S.Continue (e, ()) => e
| S.Return _ => raise Fail "ElabUtil.Exp.mapB: Impossible"
fun foldB {kind, con, exp, bind} ctx st e =
case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (k, kind (ctx, k, st)),
con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)),
exp = fn ctx => fn e => fn st => S.Continue (e, exp (ctx, e, st)),
bind = bind} ctx e st of
S.Continue (_, st) => st
| S.Return _ => raise Fail "ElabUtil.Exp.foldB: Impossible"
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.bindP (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.bindP (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
fun mapfold {kind, con, sgn_item, sgn} =
mapfoldB {kind = fn () => kind,
con = fn () => con,
sgn_item = fn () => sgn_item,
sgn = fn () => sgn,
bind = fn ((), _) => ()} ()
fun mapB {kind, con, sgn_item, sgn, bind} ctx s =
case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()),
sgn_item = fn ctx => fn sgi => fn () => S.Continue (sgn_item ctx sgi, ()),
sgn = fn ctx => fn s => fn () => S.Continue (sgn ctx s, ()),
bind = bind} ctx s () of
S.Continue (s, ()) => s
| S.Return _ => raise Fail "ElabUtil.Sgn.mapB: Impossible"
fun map {kind, con, sgn_item, sgn} s =
case mapfold {kind = fn k => fn () => S.Continue (kind k, ()),
con = fn c => fn () => S.Continue (con c, ()),
sgn_item = fn si => fn () => S.Continue (sgn_item si, ()),
sgn = fn s => fn () => S.Continue (sgn s, ())} s () of
S.Return () => raise Fail "Elab_util.Sgn.map"
| S.Continue (s, ()) => s
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.bindP (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.bindP (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 mapfold {kind, con, exp, sgn_item, sgn, str, decl} =
mapfoldB {kind = fn () => kind,
con = fn () => con,
exp = fn () => exp,
sgn_item = fn () => sgn_item,
sgn = fn () => sgn,
str = fn () => str,
decl = fn () => decl,
bind = fn ((), _) => ()} ()
fun exists {kind, con, exp, sgn_item, sgn, str, decl} k =
case mapfold {kind = fn k => fn () =>
if kind k then
S.Return ()
else
S.Continue (k, ()),
con = fn c => fn () =>
if con c then
S.Return ()
else
S.Continue (c, ()),
exp = fn e => fn () =>
if exp e then
S.Return ()
else
S.Continue (e, ()),
sgn_item = fn sgi => fn () =>
if sgn_item sgi then
S.Return ()
else
S.Continue (sgi, ()),
sgn = fn x => fn () =>
if sgn x then
S.Return ()
else
S.Continue (x, ()),
str = fn x => fn () =>
if str x then
S.Return ()
else
S.Continue (x, ()),
decl = fn x => fn () =>
if decl x then
S.Return ()
else
S.Continue (x, ())} k () of
S.Return _ => true
| S.Continue _ => false
fun search {kind, con, exp, sgn_item, sgn, str, decl} k =
case mapfold {kind = fn x => fn () =>
case kind x of
NONE => S.Continue (x, ())
| SOME v => S.Return v,
con = fn x => fn () =>
case con x of
NONE => S.Continue (x, ())
| SOME v => S.Return v,
exp = fn x => fn () =>
case exp x of
NONE => S.Continue (x, ())
| SOME v => S.Return v,
sgn_item = fn x => fn () =>
case sgn_item x of
NONE => S.Continue (x, ())
| SOME v => S.Return v,
sgn = fn x => fn () =>
case sgn x of
NONE => S.Continue (x, ())
| SOME v => S.Return v,
str = fn x => fn () =>
case str x of
NONE => S.Continue (x, ())
| SOME v => S.Return v,
decl = fn x => fn () =>
case decl x of
NONE => S.Continue (x, ())
| SOME v => S.Return v
} k () of
S.Return x => SOME x
| S.Continue _ => NONE
fun foldMapB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx st d =
case mapfoldB {kind = fn ctx => fn x => fn st => S.Continue (kind (ctx, x, st)),
con = fn ctx => fn x => fn st => S.Continue (con (ctx, x, st)),
exp = fn ctx => fn x => fn st => S.Continue (exp (ctx, x, st)),
sgn_item = fn ctx => fn x => fn st => S.Continue (sgn_item (ctx, x, st)),
sgn = fn ctx => fn x => fn st => S.Continue (sgn (ctx, x, st)),
str = fn ctx => fn x => fn st => S.Continue (str (ctx, x, st)),
decl = fn ctx => fn x => fn st => S.Continue (decl (ctx, x, st)),
bind = bind} ctx d st of
S.Continue x => x
| S.Return _ => raise Fail "ElabUtil.Decl.foldMapB: Impossible"
fun map {kind, con, exp, sgn_item, sgn, str, decl} s =
case mapfold {kind = fn k => fn () => S.Continue (kind k, ()),
con = fn c => fn () => S.Continue (con c, ()),
exp = fn e => fn () => S.Continue (exp e, ()),
sgn_item = fn si => fn () => S.Continue (sgn_item si, ()),
sgn = fn s => fn () => S.Continue (sgn s, ()),
str = fn si => fn () => S.Continue (str si, ()),
decl = fn s => fn () => S.Continue (decl s, ())} s () of
S.Return () => raise Fail "Elab_util.Decl.map"
| S.Continue (s, ()) => s
fun mapB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx s =
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 c => fn () => S.Continue (exp ctx c, ()),
sgn_item = fn ctx => fn sgi => fn () => S.Continue (sgn_item ctx sgi, ()),
sgn = fn ctx => fn s => fn () => S.Continue (sgn ctx s, ()),
str = fn ctx => fn sgi => fn () => S.Continue (str ctx sgi, ()),
decl = fn ctx => fn s => fn () => S.Continue (decl ctx s, ()),
bind = bind} ctx s () of
S.Continue (s, ()) => s
| S.Return _ => raise Fail "ElabUtil.Decl.mapB: Impossible"
fun fold {kind, con, exp, sgn_item, sgn, str, decl} (st : 'a) d : 'a =
case mapfold {kind = fn k => fn st => S.Continue (k, kind (k, st)),
con = fn c => fn st => S.Continue (c, con (c, st)),
exp = fn e => fn st => S.Continue (e, exp (e, st)),
sgn_item = fn sgi => fn st => S.Continue (sgi, sgn_item (sgi, st)),
sgn = fn s => fn st => S.Continue (s, sgn (s, st)),
str = fn str' => fn st => S.Continue (str', str (str', st)),
decl = fn d => fn st => S.Continue (d, decl (d, st))} d st of
S.Continue (_, st) => st
| S.Return _ => raise Fail "ElabUtil.Decl.fold: Impossible"
end
structure File = struct
fun maxName ds = foldl (fn (d, count) => Int.max (maxNameDecl d, count)) 0 ds
and maxNameDecl (d, _) =
case d of
DCon (_, n, _, _) => n
| DDatatype dts =>
foldl (fn ((_, n, _, ns), max) =>
foldl (fn ((_, n', _), m) => Int.max (n', m))
(Int.max (n, max)) ns) 0 dts
| DDatatypeImp (_, n1, n2, _, _, _, ns) =>
foldl (fn ((_, n', _), m) => Int.max (n', m))
(Int.max (n1, n2)) ns
| DVal (_, n, _, _) => n
| DValRec vis => foldl (fn ((_, n, _, _), count) => Int.max (n, count)) 0 vis
| DStr (_, n, sgn, str) => Int.max (n, Int.max (maxNameSgn sgn, maxNameStr str))
| DSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn)
| DFfiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn)
| DConstraint _ => 0
| DExport _ => 0
| DTable (n1, _, n2, _, _, _, _, _) => Int.max (n1, n2)
| DSequence (n1, _, n2) => Int.max (n1, n2)
| DView (n1, _, n2, _, _) => Int.max (n1, n2)
| DDatabase _ => 0
| DCookie (n1, _, n2, _) => Int.max (n1, n2)
| DStyle (n1, _, n2) => Int.max (n1, n2)
| DTask _ => 0
| DPolicy _ => 0
| DOnError _ => 0
| DFfi (_, n, _, _) => n
and maxNameStr (str, _) =
case str of
StrConst ds => maxName ds
| StrVar n => n
| StrProj (str, _) => maxNameStr str
| StrFun (_, n, dom, ran, str) => foldl Int.max n [maxNameSgn dom, maxNameSgn ran, maxNameStr str]
| StrApp (str1, str2) => Int.max (maxNameStr str1, maxNameStr str2)
| StrError => 0
and maxNameSgn (sgn, _) =
case sgn of
SgnConst sgis => foldl (fn (sgi, count) => Int.max (maxNameSgi sgi, count)) 0 sgis
| SgnVar n => n
| SgnFun (_, n, dom, ran) => Int.max (n, Int.max (maxNameSgn dom, maxNameSgn ran))
| SgnWhere (sgn, _, _, _) => maxNameSgn sgn
| SgnProj (n, _, _) => n
| SgnError => 0
and maxNameSgi (sgi, _) =
case sgi of
SgiConAbs (_, n, _) => n
| SgiCon (_, n, _, _) => n
| SgiDatatype dts =>
foldl (fn ((_, n, _, ns), max) =>
foldl (fn ((_, n', _), m) => Int.max (n', m))
(Int.max (n, max)) ns) 0 dts
| SgiDatatypeImp (_, n1, n2, _, _, _, ns) =>
foldl (fn ((_, n', _), m) => Int.max (n', m))
(Int.max (n1, n2)) ns
| SgiVal (_, n, _) => n
| SgiStr (_, _, n, sgn) => Int.max (n, maxNameSgn sgn)
| SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn)
| SgiConstraint _ => 0
| SgiClassAbs (_, n, _) => n
| SgiClass (_, n, _, _) => n
fun findDecl pred file =
let
fun decl d =
let
val r = case #1 d of
DStr (_, _, _, s) => str s
| _ => NONE
in
case r of
NONE => if pred d then SOME d else NONE
| _ => r
end
and str s =
case #1 s of
StrConst ds => ListUtil.search decl ds
| StrFun (_, _, _, _, s) => str s
| StrApp (s1, s2) =>
(case str s1 of
NONE => str s2
| r => r)
| _ => NONE
in
ListUtil.search decl file
end
end
end
urweb-20160213+dfsg/src/elaborate.sig 0000664 0000000 0000000 00000004327 12657647235 0017275 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 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
val resolveClass : ElabEnv.env -> Elab.con -> Elab.exp option
val dumpTypes : bool ref
(* After elaboration (successful or failed), should I output a mapping from
* all identifiers to their kinds/types? *)
val dumpTypesOnError : bool ref
(* Like above, but only used if there are compile errors. *)
val unifyMore : bool ref
(* Run all phases of type inference, even if an error is detected by an
* early phase. *)
val incremental : bool ref
val verbose : bool ref
end
urweb-20160213+dfsg/src/elaborate.sml 0000664 0000000 0000000 00000720174 12657647235 0017313 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2014, 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 Elaborate :> ELABORATE = struct
structure P = Prim
structure L = Source
structure L' = Elab
structure E = ElabEnv
structure U = ElabUtil
structure D = Disjoint
open Print
open ElabPrint
open ElabErr
val dumpTypes = ref false
val dumpTypesOnError = ref false
val unifyMore = ref false
val incremental = ref false
val verbose = ref false
structure IS = IntBinarySet
structure IM = IntBinaryMap
structure SK = struct
type ord_key = string
val compare = String.compare
end
structure SS = BinarySetFn(SK)
structure SM = BinaryMapFn(SK)
val basis_r = ref 0
val top_r = ref 0
fun elabExplicitness e =
case e of
L.Explicit => L'.Explicit
| L.Implicit => L'.Implicit
fun occursKind r =
U.Kind.exists (fn L'.KUnif (_, _, r') => r = r'
| _ => false)
fun validateCon env c =
(U.Con.appB {kind = fn env' => fn k => case k of
L'.KRel n => ignore (E.lookupKRel env' n)
| L'.KUnif (_, _, r as ref (L'.KUnknown f)) =>
r := L'.KUnknown (fn k => f k andalso validateKind env' k)
| _ => (),
con = fn env' => fn c => case c of
L'.CRel n => ignore (E.lookupCRel env' n)
| L'.CNamed n => ignore (E.lookupCNamed env' n)
| L'.CModProj (n, _, _) => ignore (E.lookupStrNamed env' n)
| L'.CUnif (_, _, _, _, r as ref (L'.Unknown f)) =>
r := L'.Unknown (fn c => f c andalso validateCon env' c)
| _ => (),
bind = fn (env', b) => case b of
U.Con.RelK x => E.pushKRel env' x
| U.Con.RelC (x, k) => E.pushCRel env' x k
| U.Con.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co}
env c;
true)
handle _ => false
and validateKind env k = validateCon env (L'.CRecord (k, []), ErrorMsg.dummySpan)
exception KUnify' of E.env * kunify_error
fun unifyKinds' env (k1All as (k1, _)) (k2All as (k2, _)) =
let
fun err f = raise KUnify' (env, f (k1All, k2All))
in
case (k1, k2) of
(L'.KType, L'.KType) => ()
| (L'.KUnit, L'.KUnit) => ()
| (L'.KArrow (d1, r1), L'.KArrow (d2, r2)) =>
(unifyKinds' env d1 d2;
unifyKinds' env r1 r2)
| (L'.KName, L'.KName) => ()
| (L'.KRecord k1, L'.KRecord k2) => unifyKinds' env k1 k2
| (L'.KTuple ks1, L'.KTuple ks2) =>
((ListPair.appEq (fn (k1, k2) => unifyKinds' env k1 k2) (ks1, ks2))
handle ListPair.UnequalLengths => err KIncompatible)
| (L'.KRel n1, L'.KRel n2) =>
if n1 = n2 then
()
else
err KIncompatible
| (L'.KFun (x, k1), L'.KFun (_, k2)) =>
unifyKinds' (E.pushKRel env x) k1 k2
| (L'.KError, _) => ()
| (_, L'.KError) => ()
| (L'.KUnif (_, _, ref (L'.KKnown k1All)), _) => unifyKinds' env k1All k2All
| (_, L'.KUnif (_, _, ref (L'.KKnown k2All))) => unifyKinds' env k1All k2All
| (L'.KTupleUnif (_, _, ref (L'.KKnown k)), _) => unifyKinds' env k k2All
| (_, L'.KTupleUnif (_, _, ref (L'.KKnown k))) => unifyKinds' env k1All k
| (L'.KUnif (_, _, r1 as ref (L'.KUnknown f1)), L'.KUnif (_, _, r2 as ref (L'.KUnknown f2))) =>
if r1 = r2 then
()
else
(r1 := L'.KKnown k2All;
r2 := L'.KUnknown (fn x => f1 x andalso f2 x))
| (L'.KUnif (_, _, r as ref (L'.KUnknown f)), _) =>
if occursKind r k2All then
err KOccursCheckFailed
else if not (f k2All) then
err KScope
else
r := L'.KKnown k2All
| (_, L'.KUnif (_, _, r as ref (L'.KUnknown f))) =>
if occursKind r k1All then
err KOccursCheckFailed
else if not (f k1All) then
err KScope
else
r := L'.KKnown k1All
| (L'.KTupleUnif (_, nks, r as ref (L'.KUnknown f)), L'.KTuple ks) =>
if not (f k2All) then
err KScope
else
((app (fn (n, k) => unifyKinds' env k (List.nth (ks, n-1))) nks;
r := L'.KKnown k2All)
handle Subscript => err KIncompatible)
| (L'.KTuple ks, L'.KTupleUnif (_, nks, r as ref (L'.KUnknown f))) =>
if not (f k2All) then
err KScope
else
((app (fn (n, k) => unifyKinds' env (List.nth (ks, n-1)) k) nks;
r := L'.KKnown k1All)
handle Subscript => err KIncompatible)
| (L'.KTupleUnif (loc, nks1, r1 as ref (L'.KUnknown f1)), L'.KTupleUnif (_, nks2, r2 as ref (L'.KUnknown f2))) =>
if r1 = r2 then
()
else
let
val nks = foldl (fn (p as (n, k1), nks) =>
case ListUtil.search (fn (n', k2) =>
if n' = n then
SOME k2
else
NONE) nks2 of
NONE => p :: nks
| SOME k2 => (unifyKinds' env k1 k2;
nks)) nks2 nks1
val k = (L'.KTupleUnif (loc, nks, ref (L'.KUnknown (fn x => f1 x andalso f2 x))), loc)
in
r1 := L'.KKnown k;
r2 := L'.KKnown k
end
| _ => err KIncompatible
end
exception KUnify of L'.kind * L'.kind * E.env * kunify_error
fun unifyKinds env k1 k2 =
unifyKinds' env k1 k2
handle KUnify' (env', err) => raise KUnify (k1, k2, env', err)
fun checkKind env c k1 k2 =
unifyKinds env k1 k2
handle KUnify (k1, k2, env', err) =>
conError env (WrongKind (c, k1, k2, env', err))
val dummy = ErrorMsg.dummySpan
val ktype = (L'.KType, dummy)
val kname = (L'.KName, dummy)
val ktype_record = (L'.KRecord ktype, dummy)
val cerror = (L'.CError, dummy)
val kerror = (L'.KError, dummy)
val eerror = (L'.EError, dummy)
val sgnerror = (L'.SgnError, dummy)
val strerror = (L'.StrError, dummy)
val int = ref cerror
val float = ref cerror
val string = ref cerror
val char = ref cerror
val table = ref cerror
local
val count = ref 0
in
fun resetKunif () = count := 0
fun kunif' f loc =
let
val n = !count
val s = if n <= 26 then
str (chr (ord #"A" + n))
else
"U" ^ Int.toString (n - 26)
in
count := n + 1;
(L'.KUnif (loc, s, ref (L'.KUnknown f)), loc)
end
fun kunif env = kunif' (validateKind env)
end
local
val count = ref 0
in
fun resetCunif () = count := 0
fun cunif' f (loc, k) =
let
val n = !count
val s = if n < 26 then
str (chr (ord #"A" + n))
else
"U" ^ Int.toString (n - 26)
in
count := n + 1;
(L'.CUnif (0, loc, k, s, ref (L'.Unknown f)), loc)
end
fun cunif env = cunif' (validateCon env)
end
fun elabKind env (k, loc) =
case k of
L.KType => (L'.KType, loc)
| L.KArrow (k1, k2) => (L'.KArrow (elabKind env k1, elabKind env k2), loc)
| L.KName => (L'.KName, loc)
| 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.KVar s => (case E.lookupK env s of
NONE =>
(kindError env (UnboundKind (loc, s));
kerror)
| SOME n => (L'.KRel n, loc))
| L.KFun (x, k) => (L'.KFun (x, elabKind (E.pushKRel env x) k), loc)
fun mapKind (dom, ran, loc)=
(L'.KArrow ((L'.KArrow (dom, ran), loc),
(L'.KArrow ((L'.KRecord dom, loc),
(L'.KRecord ran, loc)), loc)), loc)
fun hnormKind (kAll as (k, _)) =
case k of
L'.KUnif (_, _, ref (L'.KKnown k)) => hnormKind k
| L'.KTupleUnif (_, _, ref (L'.KKnown k)) => hnormKind k
| _ => kAll
open ElabOps
fun elabConHead env (c as (_, loc)) k =
let
fun unravel (k, c) =
case hnormKind k of
(L'.KFun (x, k'), _) =>
let
val u = kunif env loc
val k'' = subKindInKind (0, u) k'
in
unravel (k'', (L'.CKApp (c, u), loc))
end
| _ => (c, k)
in
unravel (k, c)
end
fun elabCon (env, denv) (c, loc) =
case c of
L.CAnnot (c, k) =>
let
val k' = elabKind env k
val (c', ck, gs) = elabCon (env, denv) c
in
checkKind env c' ck k';
(c', k', gs)
end
| L.TFun (t1, t2) =>
let
val (t1', k1, gs1) = elabCon (env, denv) t1
val (t2', k2, gs2) = elabCon (env, denv) t2
in
checkKind env t1' k1 ktype;
checkKind env t2' k2 ktype;
((L'.TFun (t1', t2'), loc), ktype, gs1 @ gs2)
end
| L.TCFun (e, x, k, t) =>
let
val e' = elabExplicitness e
val k' = elabKind env k
val env' = E.pushCRel env x k'
val (t', tk, gs) = elabCon (env', D.enter denv) t
in
checkKind env t' tk ktype;
((L'.TCFun (e', x, k', t'), loc), ktype, gs)
end
| L.TKFun (x, t) =>
let
val env' = E.pushKRel env x
val (t', tk, gs) = elabCon (env', denv) t
in
checkKind env t' tk ktype;
((L'.TKFun (x, t'), loc), ktype, gs)
end
| L.TDisjoint (c1, c2, c) =>
let
val (c1', k1, gs1) = elabCon (env, denv) c1
val (c2', k2, gs2) = elabCon (env, denv) c2
val ku1 = kunif env loc
val ku2 = kunif env loc
val denv' = D.assert env denv (c1', c2')
val (c', k, gs4) = elabCon (env, denv') c
in
checkKind env c1' k1 (L'.KRecord ku1, loc);
checkKind env c2' k2 (L'.KRecord ku2, loc);
checkKind env c' k (L'.KType, loc);
((L'.TDisjoint (c1', c2', c'), loc), k, gs1 @ gs2 @ gs4)
end
| L.TRecord c =>
let
val (c', ck, gs) = elabCon (env, denv) c
val k = (L'.KRecord ktype, loc)
in
checkKind env c' ck k;
((L'.TRecord c', loc), ktype, gs)
end
| L.CVar ([], s) =>
(case E.lookupC env s of
E.NotBound =>
(conError env (UnboundCon (loc, s));
(cerror, kerror, []))
| E.Rel (n, k) =>
let
val (c, k) = elabConHead env (L'.CRel n, loc) k
in
(c, k, [])
end
| E.Named (n, k) =>
let
val (c, k) = elabConHead env (L'.CNamed n, loc) k
in
(c, k, [])
end)
| L.CVar (m1 :: ms, s) =>
(case E.lookupStr env m1 of
NONE => (conError env (UnboundStrInCon (loc, m1));
(cerror, kerror, []))
| SOME (n, sgn) =>
let
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => (conError env (UnboundStrInCon (loc, m));
(strerror, sgnerror))
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) ms
val (c, k) = case E.projectCon env {sgn = sgn, str = str, field = s} of
NONE => (conError env (UnboundCon (loc, s));
(cerror, kerror))
| SOME (k, _) => elabConHead env (L'.CModProj (n, ms, s), loc) k
in
(c, k, [])
end)
| L.CApp (c1, c2) =>
let
val (c1', k1, gs1) = elabCon (env, denv) c1
val (c2', k2, gs2) = elabCon (env, denv) c2
val dom = kunif env loc
val ran = kunif env loc
in
checkKind env c1' k1 (L'.KArrow (dom, ran), loc);
checkKind env c2' k2 dom;
((L'.CApp (c1', c2'), loc), ran, gs1 @ gs2)
end
| L.CAbs (x, ko, t) =>
let
val k' = case ko of
NONE => kunif env loc
| SOME k => elabKind env k
val env' = E.pushCRel env x k'
val (t', tk, gs) = elabCon (env', D.enter denv) t
in
((L'.CAbs (x, k', t'), loc),
(L'.KArrow (k', tk), loc),
gs)
end
| L.CKAbs (x, t) =>
let
val env' = E.pushKRel env x
val (t', tk, gs) = elabCon (env', denv) t
in
((L'.CKAbs (x, t'), loc),
(L'.KFun (x, tk), loc),
gs)
end
| L.CName s =>
((L'.CName s, loc), kname, [])
| L.CRecord xcs =>
let
val k = kunif env loc
val (xcs', gs) = ListUtil.foldlMap (fn ((x, c), gs) =>
let
val (x', xk, gs1) = elabCon (env, denv) x
val (c', ck, gs2) = elabCon (env, denv) c
in
checkKind env x' xk kname;
checkKind env c' ck k;
((x', c'), gs1 @ gs2 @ gs)
end) [] xcs
val rc = (L'.CRecord (k, xcs'), loc)
(* Add duplicate field checking later. *)
fun prove (xcs, ds) =
case xcs of
[] => ds
| xc :: rest =>
let
val r1 = (L'.CRecord (k, [xc]), loc)
val ds = foldl (fn (xc', ds) =>
let
val r2 = (L'.CRecord (k, [xc']), loc)
in
D.prove env denv (r1, r2, loc) @ ds
end)
ds rest
in
prove (rest, ds)
end
in
(rc, (L'.KRecord k, loc), prove (xcs', gs))
end
| L.CConcat (c1, c2) =>
let
val (c1', k1, gs1) = elabCon (env, denv) c1
val (c2', k2, gs2) = elabCon (env, denv) c2
val ku = kunif env loc
val k = (L'.KRecord ku, loc)
in
checkKind env c1' k1 k;
checkKind env c2' k2 k;
((L'.CConcat (c1', c2'), loc), k,
D.prove env denv (c1', c2', loc) @ gs1 @ gs2)
end
| L.CMap =>
let
val dom = kunif env loc
val ran = kunif env loc
in
((L'.CMap (dom, ran), loc),
mapKind (dom, ran, loc),
[])
end
| L.CUnit => ((L'.CUnit, loc), (L'.KUnit, loc), [])
| L.CTuple cs =>
let
val (cs', ks, gs) = foldl (fn (c, (cs', ks, gs)) =>
let
val (c', k, gs') = elabCon (env, denv) c
in
(c' :: cs', k :: ks, gs' @ gs)
end) ([], [], []) cs
in
((L'.CTuple (rev cs'), loc), (L'.KTuple (rev ks), loc), gs)
end
| L.CProj (c, n) =>
let
val (c', k, gs) = elabCon (env, denv) c
val k' = kunif env loc
in
if n <= 0 then
(conError env (ProjBounds (c', n));
(cerror, kerror, []))
else
(checkKind env c' k (L'.KTupleUnif (loc, [(n, k')], ref (L'.KUnknown (validateKind env))), loc);
((L'.CProj (c', n), loc), k', gs))
end
| L.CWild k =>
let
val k' = elabKind env k
in
(cunif env (loc, k'), k', [])
end
fun kunifsRemain k =
case k of
L'.KUnif (_, _, ref (L'.KUnknown _)) => true
| L'.KTupleUnif (_, _, ref (L'.KUnknown _)) => true
| _ => false
fun cunifsRemain c =
case c of
L'.CUnif (_, loc, k, _, r as ref (L'.Unknown _)) =>
(case #1 (hnormKind k) of
L'.KUnit => (r := L'.Known (L'.CUnit, loc); false)
| _ => true)
| _ => false
val kunifsInDecl = U.Decl.exists {kind = kunifsRemain,
con = fn _ => false,
exp = fn _ => false,
sgn_item = fn _ => false,
sgn = fn _ => false,
str = fn _ => false,
decl = fn _ => false}
val cunifsInDecl = U.Decl.exists {kind = fn _ => false,
con = cunifsRemain,
exp = fn _ => false,
sgn_item = fn _ => false,
sgn = fn _ => false,
str = fn _ => false,
decl = fn _ => false}
fun occursCon r =
U.Con.exists {kind = fn _ => false,
con = fn L'.CUnif (_, _, _, _, r') => r = r'
| _ => false}
exception CUnify' of E.env * cunify_error
type record_summary = {
fields : (L'.con * L'.con) list,
unifs : (L'.con * L'.cunif ref) list,
others : L'.con list
}
fun summaryToCon {fields, unifs, others} =
let
fun concat (c1, c2) =
case #1 c1 of
L'.CRecord (_, []) => c2
| _ => case #1 c2 of
L'.CRecord (_, []) => c1
| _ => (L'.CConcat (c1, c2), dummy)
val c = (L'.CRecord (ktype, []), dummy)
val c = List.foldr concat c others
val c = List.foldr (fn ((c', _), c) => concat (c', c)) c unifs
in
concat ((L'.CRecord (ktype, fields), dummy), c)
end
fun p_summary env s = p_con env (summaryToCon s)
exception CUnify of L'.con * L'.con * E.env * cunify_error
fun kindof env (c, loc) =
case c of
L'.TFun _ => ktype
| L'.TCFun _ => ktype
| L'.TRecord _ => ktype
| L'.TDisjoint _ => ktype
| L'.CRel xn => #2 (E.lookupCRel env xn)
| L'.CNamed xn => #2 (E.lookupCNamed env xn)
| L'.CModProj (n, ms, x) =>
let
val (_, sgn) = E.lookupStrNamed env n
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => raise Fail "kindof: Unknown substructure"
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) ms
in
case E.projectCon env {sgn = sgn, str = str, field = x} of
NONE => raise Fail "kindof: Unknown con in structure"
| SOME (k, _) => k
end
| L'.CApp (c, _) =>
(case hnormKind (kindof env c) of
(L'.KArrow (_, k), _) => k
| (L'.KError, _) => kerror
| k => raise CUnify' (env, CKindof (k, c, "arrow")))
| L'.CAbs (x, k, c) => (L'.KArrow (k, kindof (E.pushCRel env x k) c), loc)
| L'.CName _ => kname
| L'.CRecord (k, _) => (L'.KRecord k, loc)
| L'.CConcat (c, _) => kindof env c
| L'.CMap (dom, ran) => mapKind (dom, ran, loc)
| L'.CUnit => (L'.KUnit, loc)
| L'.CTuple cs => (L'.KTuple (map (kindof env) cs), loc)
| L'.CProj (c, n) =>
(case hnormKind (kindof env c) of
(L'.KTuple ks, _) => List.nth (ks, n - 1)
| (L'.KUnif (_, _, r), _) =>
let
val ku = kunif env loc
val k = (L'.KTupleUnif (loc, [(n, ku)], ref (L'.KUnknown (fn _ => true))), loc)
in
r := L'.KKnown k;
ku
end
| (L'.KTupleUnif (_, nks, r), _) =>
(case ListUtil.search (fn (n', k) => if n' = n then SOME k else NONE) nks of
SOME k => k
| NONE =>
let
val ku = kunif env loc
val k = (L'.KTupleUnif (loc, ((n, ku) :: nks), ref (L'.KUnknown (fn _ => true))), loc)
in
r := L'.KKnown k;
ku
end)
| k => raise CUnify' (env, CKindof (k, c, "tuple")))
| L'.CError => kerror
| L'.CUnif (_, _, k, _, _) => k
| L'.CKAbs (x, c) => (L'.KFun (x, kindof (E.pushKRel env x) c), loc)
| L'.CKApp (c, k) =>
(case hnormKind (kindof env c) of
(L'.KFun (_, k'), _) => subKindInKind (0, k) k'
| k => raise CUnify' (env, CKindof (k, c, "kapp")))
| L'.TKFun _ => ktype
exception GuessFailure
fun isUnitCon env (c, loc) =
case c of
L'.TFun _ => false
| L'.TCFun _ => false
| L'.TRecord _ => false
| L'.TDisjoint _ => false
| L'.CRel xn => #1 (hnormKind (#2 (E.lookupCRel env xn))) = L'.KUnit
| L'.CNamed xn => #1 (hnormKind (#2 (E.lookupCNamed env xn))) = L'.KUnit
| L'.CModProj (n, ms, x) => false
(*let
val (_, sgn) = E.lookupStrNamed env n
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => raise Fail "kindof: Unknown substructure"
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) ms
in
case E.projectCon env {sgn = sgn, str = str, field = x} of
NONE => raise Fail "kindof: Unknown con in structure"
| SOME ((k, _), _) => k = L'.KUnit
end*)
| L'.CApp (c, _) => false
(*(case hnormKind (kindof env c) of
(L'.KArrow (_, k), _) => #1 k = L'.KUnit
| (L'.KError, _) => false
| k => raise CUnify' (CKindof (k, c, "arrow")))*)
| L'.CAbs _ => false
| L'.CName _ => false
| L'.CRecord _ => false
| L'.CConcat _ => false
| L'.CMap _ => false
| L'.CUnit => true
| L'.CTuple _ => false
| L'.CProj (c, n) => false
(*(case hnormKind (kindof env c) of
(L'.KTuple ks, _) => #1 (List.nth (ks, n - 1)) = L'.KUnit
| k => raise CUnify' (CKindof (k, c, "tuple")))*)
| L'.CError => false
| L'.CUnif (_, _, k, _, _) => #1 (hnormKind k) = L'.KUnit
| L'.CKAbs _ => false
| L'.CKApp _ => false
| L'.TKFun _ => false
val recdCounter = ref 0
val mayDelay = ref false
val delayedUnifs = ref ([] : (ErrorMsg.span * E.env * L'.kind * record_summary * record_summary) list)
val delayedExhaustives = ref ([] : (E.env * L'.con * L'.pat list * ErrorMsg.span) list)
exception CantSquish
fun squish by =
U.Con.mapB {kind = fn _ => fn k => k,
con = fn bound => fn c =>
case c of
L'.CRel xn =>
if xn < bound then
c
else if bound <= xn andalso xn < bound + by then
raise CantSquish
else
L'.CRel (xn - by)
| L'.CUnif _ => raise CantSquish
| _ => c,
bind = fn (bound, U.Con.RelC _) => bound + 1
| (bound, _) => bound} 0
val reducedSummaries = ref (NONE : (Print.PD.pp_desc * Print.PD.pp_desc) option)
fun unifyRecordCons env (loc, c1, c2) =
let
fun rkindof c =
case hnormKind (kindof env c) of
(L'.KRecord k, _) => k
| (L'.KError, _) => kerror
| (L'.KUnif (_, _, r as ref (L'.KUnknown f)), _) =>
let
val k = kunif' f (#2 c)
in
r := L'.KKnown (L'.KRecord k, #2 c);
k
end
| k => raise CUnify' (env, CKindof (k, c, "record"))
val k1 = rkindof c1
val k2 = rkindof c2
val r1 = recordSummary env c1
val r2 = recordSummary env c2
in
unifyKinds env k1 k2;
unifySummaries env (loc, k1, r1, r2)
end
and normalizeRecordSummary env (r : record_summary) =
recordSummary env (summaryToCon r)
and recordSummary env c =
let
val c = hnormCon env c
val sum =
case c of
(L'.CRecord (_, xcs), _) => {fields = map (fn (x, c) => (hnormCon env x, hnormCon env c)) xcs,
unifs = [], others = []}
| (L'.CConcat (c1, c2), _) =>
let
val s1 = recordSummary env c1
val s2 = recordSummary env c2
in
{fields = #fields s1 @ #fields s2,
unifs = #unifs s1 @ #unifs s2,
others = #others s1 @ #others s2}
end
| (L'.CUnif (nl, _, _, _, ref (L'.Known c)), _) => recordSummary env (E.mliftConInCon nl c)
| c' as (L'.CUnif (0, _, _, _, r), _) => {fields = [], unifs = [(c', r)], others = []}
| c' => {fields = [], unifs = [], others = [c']}
in
sum
end
and consEq env loc (c1, c2) =
let
val mayDelay' = !mayDelay
in
(mayDelay := false;
unifyCons env loc c1 c2;
mayDelay := mayDelay';
true)
handle CUnify _ => (mayDelay := mayDelay'; false)
end
and consNeq env (c1, c2) =
case (#1 (hnormCon env c1), #1 (hnormCon env c2)) of
(L'.CName x1, L'.CName x2) => x1 <> x2
| (L'.CName _, L'.CRel _) => true
| (L'.CRel _, L'.CName _) => true
| (L'.CRel n1, L'.CRel n2) => n1 <> n2
| (L'.CRel _, L'.CNamed _) => true
| (L'.CNamed _, L'.CRel _) => true
| (L'.CRel _, L'.CModProj _) => true
| (L'.CModProj _, L'.CRel _) => true
| (L'.CModProj (_, _, n1), L'.CModProj (_, _, n2)) => n1 <> n2
| (L'.CModProj _, L'.CName _) => true
| (L'.CName _, L'.CModProj _) => true
| (L'.CNamed _, L'.CName _) => true
| (L'.CName _, L'.CNamed _) => true
| _ => false
and unifySummaries env (loc, k, s1 : record_summary, s2 : record_summary) =
let
val () = reducedSummaries := NONE
(*val () = eprefaces "Summaries" [("loc", PD.string (ErrorMsg.spanToString loc)),
("#1", p_summary env s1),
("#2", p_summary env s2)]*)
fun eatMatching p (ls1, ls2) =
let
fun em (ls1, ls2, passed1) =
case ls1 of
[] => (rev passed1, ls2)
| h1 :: t1 =>
let
fun search (ls2', passed2) =
case ls2' of
[] => em (t1, ls2, h1 :: passed1)
| h2 :: t2 =>
if p (h1, h2) then
em (t1, List.revAppend (passed2, t2), passed1)
else
search (t2, h2 :: passed2)
in
search (ls2, [])
end
in
em (ls1, ls2, [])
end
val (fs1, fs2) = eatMatching (fn ((x1, c1), (x2, c2)) =>
not (consNeq env (x1, x2))
andalso consEq env loc (c1, c2)
andalso consEq env loc (x1, x2))
(#fields s1, #fields s2)
(*val () = eprefaces "Summaries2" [("#1", p_summary env {fields = fs1, unifs = #unifs s1, others = #others s1}),
("#2", p_summary env {fields = fs2, unifs = #unifs s2, others = #others s2})]*)
val (unifs1, unifs2) = eatMatching (fn ((_, r1), (_, r2)) => r1 = r2) (#unifs s1, #unifs s2)
val hasUnifs = U.Con.exists {kind = fn _ => false,
con = fn L'.CUnif _ => true
| _ => false}
val (others1, others2) = eatMatching (fn (c1, c2) =>
c1 = c2
orelse (not (hasUnifs c1 andalso hasUnifs c2)
andalso consEq env loc (c1, c2))) (#others s1, #others s2)
(*val () = eprefaces "Summaries3" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}),
("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*)
fun unsummarize {fields, unifs, others} =
let
val c = (L'.CRecord (k, fields), loc)
val c = foldl (fn ((c1, _), c2) => (L'.CConcat (c1, c2), loc))
c unifs
in
foldl (fn (c1, c2) => (L'.CConcat (c1, c2), loc))
c others
end
val empties = ([], [], [], [], [], [])
val (unifs1, fs1, others1, unifs2, fs2, others2) =
case (unifs1, fs1, others1, unifs2, fs2, others2) of
orig as ([(_, r as ref (L'.Unknown f))], [], [], _, _, _) =>
let
val c = unsummarize {fields = fs2, others = others2, unifs = unifs2}
in
if occursCon r c orelse not (f c) then
orig
else
(r := L'.Known c;
empties)
end
| orig as (_, _, _, [(_, r as ref (L'.Unknown f))], [], []) =>
let
val c = unsummarize {fields = fs1, others = others1, unifs = unifs1}
in
if occursCon r c orelse not (f c) then
orig
else
(r := L'.Known c;
empties)
end
| orig as ([(_, r1 as ref (L'.Unknown f1))], _, [], [(_, r2 as ref (L'.Unknown f2))], _, []) =>
if List.all (fn (x1, _) => List.all (fn (x2, _) => consNeq env (x1, x2)) fs2) fs1 then
let
val kr = (L'.KRecord k, loc)
val u = cunif env (loc, kr)
val c1 = (L'.CConcat ((L'.CRecord (k, fs2), loc), u), loc)
val c2 = (L'.CConcat ((L'.CRecord (k, fs1), loc), u), loc)
in
if not (f1 c1) orelse not (f2 c2) then
orig
else
(r1 := L'.Known c1;
r2 := L'.Known c2;
empties)
end
else
orig
| orig => orig
(*val () = eprefaces "Summaries4" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}),
("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*)
fun isGuessable (other, fs, unifs) =
let
val c = (L'.CRecord (k, fs), loc)
val c = foldl (fn ((c', _), c) => (L'.CConcat (c', c), loc)) c unifs
in
(guessMap env loc (other, c, GuessFailure);
true)
handle GuessFailure => false
end
val (fs1, fs2, others1, others2, unifs1, unifs2) =
case (fs1, fs2, others1, others2, unifs1, unifs2) of
([], _, [other1], [], [], _) =>
if isGuessable (other1, fs2, unifs2) then
([], [], [], [], [], [])
else
(fs1, fs2, others1, others2, unifs1, unifs2)
| (_, [], [], [other2], _, []) =>
if isGuessable (other2, fs1, unifs1) then
([], [], [], [], [], [])
else
(fs1, fs2, others1, others2, unifs1, unifs2)
| _ => (fs1, fs2, others1, others2, unifs1, unifs2)
val () = if !mayDelay then
()
else
let
val c1 = summaryToCon {fields = fs1, unifs = unifs1, others = others1}
val c2 = summaryToCon {fields = fs2, unifs = unifs2, others = others2}
in
case (c1, c2) of
((L'.CRecord (_, []), _), (L'.CRecord (_, []), _)) => reducedSummaries := NONE
| _ => reducedSummaries := SOME (p_con env c1, p_con env c2)
end
(*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}),
("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*)
val empty = (L'.CRecord (k, []), loc)
fun failure () =
let
val fs2 = #fields s2
fun findPointwise fs1 =
case fs1 of
[] => NONE
| (nm1, c1) :: fs1 =>
case List.find (fn (nm2, _) => consEq env loc (nm1, nm2)) fs2 of
NONE => findPointwise fs1
| SOME (_, c2) =>
if consEq env loc (c1, c2) then
findPointwise fs1
else
SOME (nm1, c1, c2, (unifyCons env loc c1 c2; NONE)
handle CUnify (_, _, env', err) => (reducedSummaries := NONE;
SOME (env', err)))
in
raise CUnify' (env, CRecordFailure (unsummarize s1, unsummarize s2, findPointwise (#fields s1)))
end
fun default () = if !mayDelay then
delayedUnifs := (loc, env, k, s1, s2) :: !delayedUnifs
else
failure ()
in
(case (unifs1, fs1, others1, unifs2, fs2, others2) of
(_, [], [], [], [], []) =>
app (fn (_, r) => r := L'.Known empty) unifs1
| ([], [], [], _, [], []) =>
app (fn (_, r) => r := L'.Known empty) unifs2
| (_, _, _, [], [], [cr as (L'.CUnif (nl, _, _, _, r as ref (L'.Unknown f)), _)]) =>
let
val c = summaryToCon {fields = fs1, unifs = unifs1, others = others1}
in
if occursCon r c then
(reducedSummaries := NONE;
raise CUnify' (env, COccursCheckFailed (cr, c)))
else
let
val sq = squish nl c
in
if not (f sq) then
default ()
else
r := L'.Known sq
end
handle CantSquish => default ()
end
| ([], [], [cr as (L'.CUnif (nl, _, _, _, r as ref (L'.Unknown f)), _)], _, _, _) =>
let
val c = summaryToCon {fields = fs2, unifs = unifs2, others = others2}
in
if occursCon r c then
(reducedSummaries := NONE;
raise CUnify' (env, COccursCheckFailed (cr, c)))
else
let
val sq = squish nl c
in
if not (f sq) then
default ()
else
r := L'.Known sq
end
handle CantSquish => default ()
end
| _ => default ())
(*before eprefaces "Summaries'" [("#1", p_summary env (normalizeRecordSummary env s1)),
("#2", p_summary env (normalizeRecordSummary env s2))]*)
end
and guessMap env loc (c1, c2, ex) =
let
fun unfold (dom, ran, f, r, c) =
let
fun unfold (r, c) =
case #1 (hnormCon env c) of
L'.CRecord (_, []) => unifyCons env loc r (L'.CRecord (dom, []), loc)
| L'.CRecord (_, [(x, v)]) =>
let
val v' = case dom of
(L'.KUnit, _) => (L'.CUnit, loc)
| _ => cunif env (loc, dom)
in
unifyCons env loc v (L'.CApp (f, v'), loc);
unifyCons env loc r (L'.CRecord (dom, [(x, v')]), loc)
end
| L'.CRecord (_, (x, v) :: rest) =>
let
val r1 = cunif env (loc, (L'.KRecord dom, loc))
val r2 = cunif env (loc, (L'.KRecord dom, loc))
in
unfold (r1, (L'.CRecord (ran, [(x, v)]), loc));
unfold (r2, (L'.CRecord (ran, rest), loc));
unifyCons env loc r (L'.CConcat (r1, r2), loc)
end
| L'.CConcat (c1', c2') =>
let
val r1 = cunif env (loc, (L'.KRecord dom, loc))
val r2 = cunif env (loc, (L'.KRecord dom, loc))
in
unfold (r1, c1');
unfold (r2, c2');
unifyCons env loc r (L'.CConcat (r1, r2), loc)
end
| L'.CUnif (0, _, _, _, ur as ref (L'.Unknown rf)) =>
let
val c' = (L'.CApp ((L'.CApp ((L'.CMap (dom, ran), loc), f), loc), r), loc)
in
if not (rf c') then
cunifyError env (CScope (c, c'))
else
ur := L'.Known c'
end
| _ => raise ex
in
unfold (r, c)
end
handle _ => raise ex
in
case (#1 c1, #1 c2) of
(L'.CApp ((L'.CApp ((L'.CMap (dom, ran), _), f), _), r), _) =>
unfold (dom, ran, f, r, c2)
| (_, L'.CApp ((L'.CApp ((L'.CMap (dom, ran), _), f), _), r)) =>
unfold (dom, ran, f, r, c1)
| _ => raise ex
end
and unifyCons' env loc c1 c2 =
if isUnitCon env c1 andalso isUnitCon env c2 then
()
else
let
(*val befor = Time.now ()
val old1 = c1
val old2 = c2*)
val c1 = hnormCon env c1
val c2 = hnormCon env c2
in
unifyCons'' env loc c1 c2
handle ex => guessMap env loc (c1, c2, ex)
end
and unifyCons'' env loc (c1All as (c1, _)) (c2All as (c2, _)) =
let
fun err f = raise CUnify' (env, f (c1All, c2All))
fun projSpecial1 (c1, n1, onFail) =
let
fun trySnd () =
case #1 (hnormCon env c2All) of
L'.CProj (c2, n2) =>
let
fun tryNormal () =
if n1 = n2 then
unifyCons' env loc c1 c2
else
onFail ()
in
case #1 (hnormCon env c2) of
L'.CUnif (0, _, k, _, r as ref (L'.Unknown f)) =>
(case #1 (hnormKind k) of
L'.KTuple ks =>
let
val loc = #2 c2
val us = map (fn k => cunif' f (loc, k)) ks
in
r := L'.Known (L'.CTuple us, loc);
unifyCons' env loc c1All (List.nth (us, n2 - 1))
end
| _ => tryNormal ())
| _ => tryNormal ()
end
| _ => onFail ()
in
case #1 (hnormCon env c1) of
L'.CUnif (0, _, k, _, r as ref (L'.Unknown f)) =>
(case #1 (hnormKind k) of
L'.KTuple ks =>
let
val loc = #2 c1
val us = map (fn k => cunif' f (loc, k)) ks
in
r := L'.Known (L'.CTuple us, loc);
unifyCons' env loc (List.nth (us, n1 - 1)) c2All
end
| _ => trySnd ())
| _ => trySnd ()
end
fun projSpecial2 (c2, n2, onFail) =
case #1 (hnormCon env c2) of
L'.CUnif (0, _, k, _, r as ref (L'.Unknown f)) =>
(case #1 (hnormKind k) of
L'.KTuple ks =>
let
val loc = #2 c2
val us = map (fn k => cunif' f (loc, k)) ks
in
r := L'.Known (L'.CTuple us, loc);
unifyCons' env loc c1All (List.nth (us, n2 - 1))
end
| _ => onFail ())
| _ => onFail ()
fun isRecord' () = unifyRecordCons env (loc, c1All, c2All)
fun isRecord () =
case (c1, c2) of
(L'.CProj (c1, n1), _) => projSpecial1 (c1, n1, isRecord')
| (_, L'.CProj (c2, n2)) => projSpecial2 (c2, n2, isRecord')
| _ => isRecord' ()
fun maybeIsRecord c =
case c of
L'.CRecord _ => isRecord ()
| L'.CConcat _ => isRecord ()
| _ => err COccursCheckFailed
in
(*eprefaces "unifyCons''" [("c1", p_con env c1All),
("c2", p_con env c2All)];*)
(case (c1, c2) of
(L'.CError, _) => ()
| (_, L'.CError) => ()
| (L'.CUnif (nl1, loc1, k1, _, r1 as ref (L'.Unknown f1)), L'.CUnif (nl2, loc2, k2, _, r2 as ref (L'.Unknown f2))) =>
if r1 = r2 then
if nl1 = nl2 then
()
else
err (fn _ => TooLifty (loc1, loc2))
else if nl1 = 0 then
(unifyKinds env k1 k2;
if f1 c2All then
r1 := L'.Known c2All
else
err CScope)
else if nl2 = 0 then
(unifyKinds env k1 k2;
if f2 c1All then
r2 := L'.Known c1All
else
err CScope)
else
err (fn _ => TooLifty (loc1, loc2))
| (L'.CUnif (0, _, k1, _, r as ref (L'.Unknown f)), _) =>
(unifyKinds env k1 (kindof env c2All);
if occursCon r c2All then
maybeIsRecord c2
else if f c2All then
r := L'.Known c2All
else
err CScope)
| (_, L'.CUnif (0, _, k2, _, r as ref (L'.Unknown f))) =>
(unifyKinds env (kindof env c1All) k2;
if occursCon r c1All then
maybeIsRecord c1
else if f c1All then
r := L'.Known c1All
else
err CScope)
| (L'.CUnif (nl, _, k1, _, r as ref (L'.Unknown f)), _) =>
if occursCon r c2All then
maybeIsRecord c2
else
(unifyKinds env k1 (kindof env c2All);
let
val sq = squish nl c2All
in
if f sq then
r := L'.Known sq
else
err CScope
end
handle CantSquish => err (fn _ => TooDeep))
| (_, L'.CUnif (nl, _, k2, _, r as ref (L'.Unknown f))) =>
if occursCon r c1All then
maybeIsRecord c1
else
(unifyKinds env (kindof env c1All) k2;
let
val sq = squish nl c1All
in
if f sq then
r := L'.Known sq
else
err CScope
end
handle CantSquish => err (fn _ => TooDeep))
| (L'.CRecord _, _) => isRecord ()
| (_, L'.CRecord _) => isRecord ()
| (L'.CConcat _, _) => isRecord ()
| (_, L'.CConcat _) => isRecord ()
| (L'.CUnit, L'.CUnit) => ()
| (L'.TFun (d1, r1), L'.TFun (d2, r2)) =>
(unifyCons' env loc d1 d2;
unifyCons' env loc r1 r2)
| (L'.TCFun (expl1, x1, d1, r1), L'.TCFun (expl2, _, d2, r2)) =>
if expl1 <> expl2 then
err CExplicitness
else
(unifyKinds env d1 d2;
let
(*val befor = Time.now ()*)
val env' = E.pushCRel env x1 d1
in
(*TextIO.print ("E.pushCRel: "
^ LargeReal.toString (Time.toReal (Time.- (Time.now (), befor)))
^ "\n");*)
unifyCons' env' loc r1 r2
end)
| (L'.TRecord r1, L'.TRecord r2) => unifyCons' env loc r1 r2
| (L'.TDisjoint (c1, d1, e1), L'.TDisjoint (c2, d2, e2)) =>
(unifyCons' env loc c1 c2;
unifyCons' env loc d1 d2;
unifyCons' env loc e1 e2)
| (L'.CRel n1, L'.CRel n2) =>
if n1 = n2 then
()
else
err CIncompatible
| (L'.CNamed n1, L'.CNamed n2) =>
if n1 = n2 then
()
else
err CIncompatible
| (L'.CApp (d1, r1), L'.CApp (d2, r2)) =>
(unifyCons' env loc d1 d2;
unifyCons' env loc r1 r2)
| (L'.CAbs (x1, k1, c1), L'.CAbs (_, k2, c2)) =>
(unifyKinds env k1 k2;
unifyCons' (E.pushCRel env x1 k1) loc c1 c2)
| (L'.CName n1, L'.CName n2) =>
if n1 = n2 then
()
else
err CIncompatible
| (L'.CModProj (n1, ms1, x1), L'.CModProj (n2, ms2, x2)) =>
if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then
()
else
err CIncompatible
| (L'.CTuple cs1, L'.CTuple cs2) =>
((ListPair.appEq (fn (c1, c2) => unifyCons' env loc c1 c2) (cs1, cs2))
handle ListPair.UnequalLengths => err CIncompatible)
| (L'.CProj (c1, n1), _) => projSpecial1 (c1, n1, fn () => err CIncompatible)
| (_, L'.CProj (c2, n2)) => projSpecial2 (c2, n2, fn () => err CIncompatible)
| (L'.CTuple cs, L'.CRel x) =>
(case hnormKind (kindof env c2All) of
(L'.KTuple ks, _) =>
if length cs <> length ks then
err CIncompatible
else
let
fun rightProjs (cs, n) =
case cs of
c :: cs' =>
(case hnormCon env c of
(L'.CProj ((L'.CRel x', _), n'), _) =>
x' = x andalso n' = n andalso rightProjs (cs', n+1)
| _ => false)
| [] => true
in
if rightProjs (cs, 1) then
()
else
err CIncompatible
end
| _ => err CIncompatible)
| (L'.CRel x, L'.CTuple cs) =>
unifyCons'' env loc c2All c1All
| (L'.CMap (dom1, ran1), L'.CMap (dom2, ran2)) =>
(unifyKinds env dom1 dom2;
unifyKinds env ran1 ran2)
| (L'.CKAbs (x, c1), L'.CKAbs (_, c2)) =>
unifyCons' (E.pushKRel env x) loc c1 c2
| (L'.CKApp (c1, k1), L'.CKApp (c2, k2)) =>
(unifyKinds env k1 k2;
unifyCons' env loc c1 c2)
| (L'.TKFun (x, c1), L'.TKFun (_, c2)) =>
unifyCons' (E.pushKRel env x) loc c1 c2
| _ => err CIncompatible)(*;
eprefaces "/unifyCons''" [("c1", p_con env c1All),
("c2", p_con env c2All)]*)
end
and unifyCons env loc c1 c2 =
((*Print.prefaces "uc" [("c1", p_con env c1),
("c2", p_con env c2)];*)
unifyCons' env loc c1 c2)
handle CUnify' (env', err) => raise CUnify (c1, c2, env', err)
| KUnify (arg as {3 = env', ...}) => raise CUnify (c1, c2, env', CKind arg)
fun checkCon env e c1 c2 =
unifyCons env (#2 e) c1 c2
handle CUnify (c1, c2, env', err) =>
expError env (Unify (e, c1, c2, env', err))
fun checkPatCon env p c1 c2 =
unifyCons env (#2 p) c1 c2
handle CUnify (c1, c2, env', err) =>
expError env (PatUnify (p, c1, c2, env', err))
fun primType env p =
case p of
P.Int _ => !int
| P.Float _ => !float
| P.String _ => !string
| P.Char _ => !char
datatype constraint =
Disjoint of D.goal
| TypeClass of E.env * L'.con * L'.exp option ref * ErrorMsg.span
fun relocConstraint loc c =
case c of
Disjoint (_, a, b, c, d) => Disjoint (loc, a, b, c, d)
| TypeClass (a, b, c, _) => TypeClass (a, b, c, loc)
val enD = map Disjoint
fun isClassOrFolder env cl =
E.isClass env cl
orelse case hnormCon env cl of
(L'.CKApp (cl, _), _) =>
(case hnormCon env cl of
(L'.CModProj (top_n, [], "folder"), _) => top_n = !top_r
| _ => false)
| _ => false
fun subConInCon env x y =
ElabOps.subConInCon x y
handle SubUnif => (cunifyError env (TooUnify (#2 x, y));
cerror)
fun elabHead (env, denv) infer (e as (_, loc)) t =
let
fun unravelKind (t, e) =
case hnormCon env t of
(L'.TKFun (x, t'), _) =>
let
val u = kunif env loc
val t'' = subKindInCon (0, u) t'
in
unravelKind (t'', (L'.EKApp (e, u), loc))
end
| t => (e, t, [])
fun unravel (t, e) =
case hnormCon env t of
(L'.TKFun (x, t'), _) =>
let
val u = kunif env loc
val t'' = subKindInCon (0, u) t'
in
unravel (t'', (L'.EKApp (e, u), loc))
end
| (L'.TCFun (L'.Implicit, x, k, t'), _) =>
let
val u = cunif env (loc, k)
val t'' = subConInCon env (0, u) t'
in
unravel (t'', (L'.ECApp (e, u), loc))
end
| (L'.TFun (dom, ran), _) =>
let
fun default () = (e, t, [])
fun isInstance () =
if infer <> L.TypesOnly then
let
val r = ref NONE
val (e, t, gs) = unravel (ran, (L'.EApp (e, (L'.EUnif r, loc)), loc))
in
(e, t, TypeClass (env, dom, r, loc) :: gs)
end
else
default ()
fun hasInstance c =
case hnormCon env c of
(L'.TRecord c, _) => U.Con.exists {kind = fn _ => false,
con = fn c =>
isClassOrFolder env (hnormCon env (c, loc))} c
| c =>
let
fun findHead c =
case #1 c of
L'.CApp (f, _) => findHead f
| _ => c
val cl = hnormCon env (findHead c)
in
isClassOrFolder env cl
end
in
if hasInstance dom then
isInstance ()
else
default ()
end
| (L'.TDisjoint (r1, r2, t'), loc) =>
if infer <> L.TypesOnly then
let
val gs = D.prove env denv (r1, r2, #2 e)
val (e, t, gs') = unravel (t', e)
in
(e, t, enD gs @ gs')
end
else
(e, t, [])
| t => (e, t, [])
val (e, t, gs) = case infer of
L.DontInfer => unravelKind (t, e)
| _ => unravel (t, e)
in
((#1 e, loc), (#1 t, loc), map (relocConstraint loc) gs)
end
fun elabPat (pAll as (p, loc), (env, bound)) =
let
val terror = (L'.CError, loc)
val perror = (L'.PVar ("_", terror), loc)
val pterror = (perror, terror)
val rerror = (pterror, (env, bound))
fun pcon (pc, po, xs, to, dn, dk) =
case (po, to) of
(NONE, SOME _) => (expError env (PatHasNoArg loc);
rerror)
| (SOME _, NONE) => (expError env (PatHasArg loc);
rerror)
| (NONE, NONE) =>
let
val k = (L'.KType, loc)
val unifs = map (fn _ => cunif env (loc, k)) xs
val dn = foldl (fn (u, dn) => (L'.CApp (dn, u), loc)) dn unifs
in
(((L'.PCon (dk, pc, unifs, NONE), loc), dn),
(env, bound))
end
| (SOME p, SOME t) =>
let
val ((p', pt), (env, bound)) = elabPat (p, (env, bound))
val k = (L'.KType, loc)
val unifs = map (fn _ => cunif env (loc, k)) xs
val nxs = length unifs - 1
val t = ListUtil.foldli (fn (i, u, t) => subConInCon env (nxs - i,
E.mliftConInCon (nxs - i) u) t) t unifs
val dn = foldl (fn (u, dn) => (L'.CApp (dn, u), loc)) dn unifs
in
ignore (checkPatCon env p' pt t);
(((L'.PCon (dk, pc, unifs, SOME p'), loc), dn),
(env, bound))
end
in
case p of
L.PVar x =>
let
val t = if x <> "_" andalso SS.member (bound, x) then
(expError env (DuplicatePatternVariable (loc, x));
terror)
else
cunif env (loc, (L'.KType, loc))
in
(((L'.PVar (x, t), loc), t),
(E.pushERel env x t, SS.add (bound, x)))
end
| L.PPrim p => (((L'.PPrim p, loc), primType env p),
(env, bound))
| L.PCon ([], x, po) =>
(case E.lookupConstructor env x of
NONE => (expError env (UnboundConstructor (loc, [], x));
rerror)
| SOME (dk, n, xs, to, dn) => pcon (L'.PConVar n, po, xs, to, (L'.CNamed dn, loc), dk))
| L.PCon (m1 :: ms, x, po) =>
(case E.lookupStr env m1 of
NONE => (expError env (UnboundStrInExp (loc, m1));
rerror)
| SOME (n, sgn) =>
let
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => raise Fail "elabPat: Unknown substructure"
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) ms
in
case E.projectConstructor env {str = str, sgn = sgn, field = x} of
NONE => (expError env (UnboundConstructor (loc, m1 :: ms, x));
rerror)
| SOME (dk, _, xs, to, dn) => pcon (L'.PConProj (n, ms, x), po, xs, to, dn, dk)
end)
| L.PRecord (xps, flex) =>
let
val (xpts, (env, bound, _)) =
ListUtil.foldlMap (fn ((x, p), (env, bound, fbound)) =>
let
val ((p', t), (env, bound)) = elabPat (p, (env, bound))
in
if SS.member (fbound, x) then
expError env (DuplicatePatField (loc, x))
else
();
((x, p', t), (env, bound, SS.add (fbound, x)))
end)
(env, bound, SS.empty) xps
val k = (L'.KType, loc)
val c = (L'.CRecord (k, map (fn (x, _, t) => ((L'.CName x, loc), t)) xpts), loc)
val c =
if flex then
(L'.CConcat (c, cunif env (loc, (L'.KRecord k, loc))), loc)
else
c
in
(((L'.PRecord xpts, loc),
(L'.TRecord c, loc)),
(env, bound))
end
| L.PAnnot (p, t) =>
let
val ((p', pt), (env, bound)) = elabPat (p, (env, bound))
val (t', k, _) = elabCon (env, D.empty) t
in
checkPatCon env p' pt t';
((p', t'), (env, bound))
end
end
(* This exhaustiveness checking follows Luc Maranget's paper "Warnings for pattern matching." *)
fun exhaustive (env, t, ps, loc) =
let
val pwild = L'.PVar ("_", t)
fun fail n = raise Fail ("Elaborate.exhaustive: Impossible " ^ Int.toString n)
fun patConNum pc =
case pc of
L'.PConVar n => n
| L'.PConProj (m1, ms, x) =>
let
val (str, sgn) = E.chaseMpath env (m1, ms)
in
case E.projectConstructor env {str = str, sgn = sgn, field = x} of
NONE => raise Fail "exhaustive: Can't project datatype"
| SOME (_, n, _, _, _) => n
end
fun nameOfNum (t, n) =
case t of
L'.CModProj (m1, ms, x) =>
let
val (str, sgn) = E.chaseMpath env (m1, ms)
in
case E.projectDatatype env {str = str, sgn = sgn, field = x} of
NONE => raise Fail "exhaustive: Can't project datatype"
| SOME (_, cons) =>
case ListUtil.search (fn (name, n', _) =>
if n' = n then
SOME name
else
NONE) cons of
NONE => fail 9
| SOME name => L'.PConProj (m1, ms, name)
end
| _ => L'.PConVar n
fun S (args, c, P) =
List.mapPartial
(fn [] => fail 1
| p1 :: ps =>
let
val loc = #2 p1
fun wild () =
SOME (map (fn _ => (pwild, loc)) args @ ps)
in
case #1 p1 of
L'.PPrim _ => NONE
| L'.PCon (_, c', _, NONE) =>
if patConNum c' = c then
SOME ps
else
NONE
| L'.PCon (_, c', _, SOME p) =>
if patConNum c' = c then
SOME (p :: ps)
else
NONE
| L'.PRecord xpts =>
SOME (map (fn x =>
case ListUtil.search (fn (x', p, _) =>
if x = x' then
SOME p
else
NONE) xpts of
NONE => (pwild, loc)
| SOME p => p) args @ ps)
| L'.PVar _ => wild ()
end)
P
fun D P =
List.mapPartial
(fn [] => fail 2
| (p1, _) :: ps =>
case p1 of
L'.PVar _ => SOME ps
| L'.PPrim _ => NONE
| L'.PCon _ => NONE
| L'.PRecord _ => NONE)
P
fun I (P, q) =
(*(prefaces "I" [("P", p_list (fn P' => box [PD.string "[", p_list (p_pat env) P', PD.string "]"]) P),
("q", p_list (p_con env) q)];*)
case q of
[] => (case P of
[] => SOME []
| _ => NONE)
| q1 :: qs =>
let
val loc = #2 q1
fun unapp (t, acc) =
case #1 t of
L'.CApp (t, arg) => unapp (t, arg :: acc)
| _ => (t, rev acc)
val (t1, args) = unapp (hnormCon env q1, [])
val t1 = hnormCon env t1
fun doSub t = foldl (fn (arg, t) => subConInCon env (0, arg) t) t args
fun dtype (dtO, names) =
let
val nameSet = IS.addList (IS.empty, names)
val nameSet = foldl (fn (ps, nameSet) =>
case ps of
[] => fail 4
| (L'.PCon (_, pc, _, _), _) :: _ =>
(IS.delete (nameSet, patConNum pc)
handle NotFound => nameSet)
| _ => nameSet)
nameSet P
in
nameSet
end
fun default () = (NONE, IS.singleton 0, [])
val (dtO, unused, cons) =
case #1 t1 of
L'.CNamed n =>
let
val dt = E.lookupDatatype env n
val cons = E.constructors dt
in
(SOME dt,
dtype (SOME dt, map #2 cons),
map (fn (_, n, co) =>
(n,
case co of
NONE => []
| SOME t => [("", doSub t)])) cons)
end
| L'.CModProj (m1, ms, x) =>
let
val (str, sgn) = E.chaseMpath env (m1, ms)
in
case E.projectDatatype env {str = str, sgn = sgn, field = x} of
NONE => default ()
| SOME (_, cons) =>
(NONE,
dtype (NONE, map #2 cons),
map (fn (s, _, co) =>
(patConNum (L'.PConProj (m1, ms, s)),
case co of
NONE => []
| SOME t => [("", doSub t)])) cons)
end
| L'.TRecord t =>
(case #1 (hnormCon env t) of
L'.CRecord (_, xts) =>
let
val xts = map (fn ((L'.CName x, _), co) => SOME (x, co)
| _ => NONE) xts
in
if List.all Option.isSome xts then
let
val xts = List.mapPartial (fn x => x) xts
val xts = ListMergeSort.sort (fn ((x1, _), (x2, _)) =>
String.compare (x1, x2) = GREATER) xts
in
(NONE, IS.empty, [(0, xts)])
end
else
default ()
end
| _ => default ())
| _ => default ()
in
if IS.isEmpty unused then
let
fun recurse cons =
case cons of
[] => NONE
| (name, args) :: cons =>
case I (S (map #1 args, name, P),
map #2 args @ qs) of
NONE => recurse cons
| SOME ps =>
let
val nargs = length args
val argPs = List.take (ps, nargs)
val restPs = List.drop (ps, nargs)
val p = case name of
0 => L'.PRecord (ListPair.map
(fn ((name, t), p) => (name, p, t))
(args, argPs))
| _ => L'.PCon (L'.Default, nameOfNum (#1 t1, name), [],
case argPs of
[] => NONE
| [p] => SOME p
| _ => fail 3)
in
SOME ((p, loc) :: restPs)
end
in
recurse cons
end
else
case I (D P, qs) of
NONE => NONE
| SOME ps =>
let
val p = case cons of
[] => pwild
| (0, _) :: _ => pwild
| _ =>
case IS.find (fn _ => true) unused of
NONE => fail 6
| SOME name =>
case ListUtil.search (fn (name', args) =>
if name = name' then
SOME (name', args)
else
NONE) cons of
SOME (n, []) =>
L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], NONE)
| SOME (n, [_]) =>
L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], SOME (pwild, loc))
| _ => fail 7
in
SOME ((p, loc) :: ps)
end
end
in
case I (map (fn x => [x]) ps, [t]) of
NONE => NONE
| SOME [p] => SOME p
| _ => fail 7
end
fun unmodCon env (c, loc) =
case c of
L'.CNamed n =>
(case E.lookupCNamed env n of
(_, _, SOME (c as (L'.CModProj _, _))) => unmodCon env c
| _ => (c, loc))
| L'.CModProj (m1, ms, x) =>
let
val (str, sgn) = E.chaseMpath env (m1, ms)
in
case E.projectCon env {str = str, sgn = sgn, field = x} of
NONE => raise Fail "unmodCon: Can't projectCon"
| SOME (_, SOME (c as (L'.CModProj _, _))) => unmodCon env c
| _ => (c, loc)
end
| _ => (c, loc)
fun normClassKey env c =
let
val c = hnormCon env c
in
case #1 c of
L'.CApp (c1, c2) =>
let
val c1 = normClassKey env c1
val c2 = normClassKey env c2
in
(L'.CApp (c1, c2), #2 c)
end
| L'.CRecord (k, xcs) => (L'.CRecord (k, map (fn (x, c) => (normClassKey env x,
normClassKey env c)) xcs), #2 c)
| _ => unmodCon env c
end
fun normClassConstraint env (c, loc) =
case c of
L'.CApp (f, x) =>
let
val f = normClassKey env f
val x = normClassKey env x
in
(L'.CApp (f, x), loc)
end
| L'.TFun (c1, c2) =>
let
val c1 = normClassConstraint env c1
val c2 = normClassConstraint env c2
in
(L'.TFun (c1, c2), loc)
end
| L'.TCFun (expl, x, k, c1) => (L'.TCFun (expl, x, k, normClassConstraint env c1), loc)
| L'.CUnif (nl, _, _, _, ref (L'.Known c)) => normClassConstraint env (E.mliftConInCon nl c)
| _ => unmodCon env (c, loc)
fun findHead e e' =
let
fun findHead (e, _) =
case e of
L.EVar (_, _, infer) =>
let
fun findHead' (e, _) =
case e of
L'.ENamed _ => true
| L'.EModProj _ => true
| L'.ERel _ => true
| L'.EApp (e, _) => findHead' e
| L'.ECApp (e, _) => findHead' e
| L'.EKApp (e, _) => findHead' e
| _ => false
in
if findHead' e' then
SOME infer
else
NONE
end
| L.EApp (e, _) => findHead e
| L.ECApp (e, _) => findHead e
| L.EDisjointApp e => findHead e
| _ => NONE
in
findHead e
end
datatype needed = Needed of {Cons : (L'.kind * int) SM.map,
NextCon : int,
Constraints : (E.env * (L'.con * L'.con) * ErrorMsg.span) list,
Vals : SS.set,
Mods : (E.env * needed) SM.map}
fun ncons (Needed r) = map (fn (k, (v, _)) => (k, v))
(ListMergeSort.sort (fn ((_, (_, n1)), (_, (_, n2))) => n1 > n2)
(SM.listItemsi (#Cons r)))
fun nconstraints (Needed r) = #Constraints r
fun nvals (Needed r) = #Vals r
fun nmods (Needed r) = #Mods r
val nempty = Needed {Cons = SM.empty,
NextCon = 0,
Constraints = nil,
Vals = SS.empty,
Mods = SM.empty}
fun naddCon (r : needed, k, v) =
let
val Needed r = r
in
Needed {Cons = SM.insert (#Cons r, k, (v, #NextCon r)),
NextCon = #NextCon r + 1,
Constraints = #Constraints r,
Vals = #Vals r,
Mods = #Mods r}
end
fun naddConstraint (r : needed, v) =
let
val Needed r = r
in
Needed {Cons = #Cons r,
NextCon = #NextCon r,
Constraints = v :: #Constraints r,
Vals = #Vals r,
Mods = #Mods r}
end
fun naddVal (r : needed, k) =
let
val Needed r = r
in
Needed {Cons = #Cons r,
NextCon = #NextCon r,
Constraints = #Constraints r,
Vals = SS.add (#Vals r, k),
Mods = #Mods r}
end
fun naddMod (r : needed, k, v) =
let
val Needed r = r
in
Needed {Cons = #Cons r,
NextCon = #NextCon r,
Constraints = #Constraints r,
Vals = #Vals r,
Mods = SM.insert (#Mods r, k, v)}
end
fun ndelCon (r : needed, k) =
let
val Needed r = r
in
Needed {Cons = #1 (SM.remove (#Cons r, k)) handle NotFound => #Cons r,
NextCon = #NextCon r,
Constraints = #Constraints r,
Vals = #Vals r,
Mods = #Mods r}
end
fun ndelVal (r : needed, k) =
let
val Needed r = r
in
Needed {Cons = #Cons r,
NextCon = #NextCon r,
Constraints = #Constraints r,
Vals = SS.delete (#Vals r, k) handle NotFound => #Vals r,
Mods = #Mods r}
end
fun chaseUnifs c =
case #1 c of
L'.CUnif (_, _, _, _, ref (L'.Known c)) => chaseUnifs c
| _ => c
val consEqSimple =
let
fun ces env (c1 : L'.con, c2 : L'.con) =
let
val c1 = hnormCon env c1
val c2 = hnormCon env c2
in
case (#1 c1, #1 c2) of
(L'.CRel n1, L'.CRel n2) => n1 = n2
| (L'.CNamed n1, L'.CNamed n2) =>
n1 = n2 orelse
(case #3 (E.lookupCNamed env n1) of
SOME (L'.CNamed n2', _) => n2' = n1
| _ => false)
| (L'.CModProj n1, L'.CModProj n2) => n1 = n2
| (L'.CApp (f1, x1), L'.CApp (f2, x2)) => ces env (f1, f2) andalso ces env (x1, x2)
| (L'.CAbs (x1, k1, c1), L'.CAbs (_, _, c2)) => ces (E.pushCRel env x1 k1) (c1, c2)
| (L'.CName x1, L'.CName x2) => x1 = x2
| (L'.CRecord (_, xts1), L'.CRecord (_, xts2)) =>
ListPair.all (fn ((x1, t1), (x2, t2)) =>
ces env (x1, x2) andalso ces env (t2, t2)) (xts1, xts2)
| (L'.CConcat (x1, y1), L'.CConcat (x2, y2)) =>
ces env (x1, x2) andalso ces env (y1, y2)
| (L'.CMap _, L'.CMap _) => true
| (L'.CUnit, L'.CUnit) => true
| (L'.CTuple cs1, L'.CTuple cs2) => ListPair.all (ces env) (cs1, cs2)
| (L'.CProj (c1, n1), L'.CProj (c2, n2)) => ces env (c1, c2) andalso n1 = n2
| (L'.CUnif (_, _, _, _, r1), L'.CUnif (_, _, _, _, r2)) => r1 = r2
| (L'.TFun (d1, r1), L'.TFun (d2, r2)) => ces env (d1, d2) andalso ces env (r1, r2)
| (L'.TRecord c1, L'.TRecord c2) => ces env (c1, c2)
| _ => false
end
in
ces
end
fun elabExp (env, denv) (eAll as (e, loc)) =
let
(*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)]*)
(*val befor = Time.now ()*)
val r = case e of
L.EAnnot (e, t) =>
let
val (e', et, gs1) = elabExp (env, denv) e
val (t', _, gs2) = elabCon (env, denv) t
in
checkCon env e' et t';
(e', t', gs1 @ enD gs2)
end
| L.EPrim p => ((L'.EPrim p, loc), primType env p, [])
| L.EVar ([], s, infer) =>
(case E.lookupE env s of
E.NotBound =>
(expError env (UnboundExp (loc, s));
(eerror, cerror, []))
| E.Rel (n, t) => elabHead (env, denv) infer (L'.ERel n, loc) t
| E.Named (n, t) => elabHead (env, denv) infer (L'.ENamed n, loc) t)
| L.EVar (m1 :: ms, s, infer) =>
(case E.lookupStr env m1 of
NONE => (expError env (UnboundStrInExp (loc, m1));
(eerror, cerror, []))
| SOME (n, sgn) =>
let
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => (conError env (UnboundStrInCon (loc, m));
(strerror, sgnerror))
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) ms
val t = case E.projectVal env {sgn = sgn, str = str, field = s} of
NONE => (expError env (UnboundExp (loc, s));
cerror)
| SOME t => t
in
elabHead (env, denv) infer (L'.EModProj (n, ms, s), loc) t
end)
| L.EWild =>
let
val r = ref NONE
val c = cunif env (loc, (L'.KType, loc))
in
((L'.EUnif r, loc), c, [TypeClass (env, c, r, loc)])
end
| L.EApp (e1, e2) =>
let
val (e1', t1, gs1) = elabExp (env, denv) e1
val (e2', t2, gs2) = elabExp (env, denv) e2
val dom = cunif env (loc, ktype)
val ran = cunif env (loc, ktype)
val t = (L'.TFun (dom, ran), loc)
val () = checkCon env e1' t1 t
val () = checkCon env e2' t2 dom
val ef = (L'.EApp (e1', e2'), loc)
val (ef, et, gs3) =
case findHead e1 e1' of
NONE => (ef, (#1 (chaseUnifs ran), loc), [])
| SOME infer => elabHead (env, denv) infer ef ran
in
(ef, et, gs1 @ gs2 @ gs3)
end
| L.EAbs (x, to, e) =>
let
val (t', gs1) = case to of
NONE => (cunif env (loc, ktype), [])
| SOME t =>
let
val (t', tk, gs) = elabCon (env, denv) t
in
checkKind env t' tk ktype;
(t', gs)
end
val dom = normClassConstraint env t'
val (e', et, gs2) = elabExp (E.pushERel env x dom, denv) e
in
((L'.EAbs (x, t', et, e'), loc),
(L'.TFun (t', et), loc),
enD gs1 @ gs2)
end
| L.ECApp (e, c) =>
let
val (e', et, gs1) = elabExp (env, denv) e
val oldEt = et
val (c', ck, gs2) = elabCon (env, denv) c
val (et', _) = hnormCon env et
in
case et' of
L'.CError => (eerror, cerror, [])
| L'.TCFun (_, x, k, eb) =>
let
val () = checkKind env c' ck k
val eb' = subConInCon env (0, c') eb
val ef = (L'.ECApp (e', c'), loc)
val (ef, eb', gs3) =
case findHead e e' of
NONE => (ef, eb', [])
| SOME infer => elabHead (env, denv) infer ef eb'
in
(*prefaces "Elab ECApp" [("e", SourcePrint.p_exp eAll),
("et", p_con env oldEt),
("x", PD.string x),
("eb", p_con (E.pushCRel env x k) eb),
("c", p_con env c'),
("eb'", p_con env eb')];*)
(ef, (#1 eb', loc), gs1 @ enD gs2 @ gs3)
end
| _ =>
(expError env (WrongForm ("constructor function", e', et));
(eerror, cerror, []))
end
| L.ECAbs (expl, x, k, e) =>
let
val expl' = elabExplicitness expl
val k' = elabKind env k
val env' = E.pushCRel env x k'
val (e', et, gs) = elabExp (env', D.enter denv) e
in
((L'.ECAbs (expl', x, k', e'), loc),
(L'.TCFun (expl', x, k', et), loc),
gs)
end
| L.EKAbs (x, e) =>
let
val env' = E.pushKRel env x
val (e', et, gs) = elabExp (env', denv) e
in
((L'.EKAbs (x, e'), loc),
(L'.TKFun (x, et), loc),
gs)
end
| L.EDisjoint (c1, c2, e) =>
let
val (c1', k1, gs1) = elabCon (env, denv) c1
val (c2', k2, gs2) = elabCon (env, denv) c2
val ku1 = kunif env loc
val ku2 = kunif env loc
val denv' = D.assert env denv (c1', c2')
val (e', t, gs3) = elabExp (env, denv') e
in
checkKind env c1' k1 (L'.KRecord ku1, loc);
checkKind env c2' k2 (L'.KRecord ku2, loc);
(e', (L'.TDisjoint (c1', c2', t), loc), enD gs1 @ enD gs2 @ gs3)
end
| L.EDisjointApp e =>
let
val (e', t, gs1) = elabExp (env, denv) e
val k1 = kunif env loc
val c1 = cunif env (loc, (L'.KRecord k1, loc))
val k2 = kunif env loc
val c2 = cunif env (loc, (L'.KRecord k2, loc))
val t' = cunif env (loc, ktype)
val () = checkCon env e' t (L'.TDisjoint (c1, c2, t'), loc)
val gs2 = D.prove env denv (c1, c2, loc)
in
(e', (#1 (chaseUnifs t'), loc), enD gs2 @ gs1)
end
| L.ERecord (xes, flex) =>
let
val () = if flex then
expError env (IllegalFlex eAll)
else
()
val (xes', gs) = ListUtil.foldlMap (fn ((x, e), gs) =>
let
val (x', xk, gs1) = elabCon (env, denv) x
val (e', et, gs2) = elabExp (env, denv) e
in
checkKind env x' xk kname;
((x', e', et), enD gs1 @ gs2 @ gs)
end)
[] xes
val k = (L'.KType, loc)
fun prove (xets, gs) =
case xets of
[] => gs
| (x, _, t) :: rest =>
let
val xc = (x, t)
val r1 = (L'.CRecord (k, [xc]), loc)
val gs = foldl (fn ((x', _, t'), gs) =>
let
val xc' = (x', t')
val r2 = (L'.CRecord (k, [xc']), loc)
in
D.prove env denv (r1, r2, loc) @ gs
end)
gs rest
in
prove (rest, gs)
end
val gsD = List.mapPartial (fn Disjoint d => SOME d | _ => NONE) gs
val gsO = List.filter (fn Disjoint _ => false | _ => true) gs
in
(*TextIO.print ("|gsO| = " ^ Int.toString (length gsO) ^ "\n");*)
((L'.ERecord xes', loc),
(L'.TRecord (L'.CRecord (ktype, map (fn (x', _, et) => (x', et)) xes'), loc), loc),
enD (prove (xes', gsD)) @ gsO)
end
| L.EField (e, c) =>
let
val (e', et, gs1) = elabExp (env, denv) e
val (c', ck, gs2) = elabCon (env, denv) c
val ft = cunif env (loc, ktype)
val rest = cunif env (loc, ktype_record)
val first = (L'.CRecord (ktype, [(c', ft)]), loc)
val () = checkCon env e' et
(L'.TRecord (L'.CConcat (first, rest), loc), loc);
val gs3 = D.prove env denv (first, rest, loc)
in
((L'.EField (e', c', {field = ft, rest = rest}), loc), ft, gs1 @ enD gs2 @ enD gs3)
end
| L.EConcat (e1, e2) =>
let
val (e1', e1t, gs1) = elabExp (env, denv) e1
val (e2', e2t, gs2) = elabExp (env, denv) e2
val r1 = cunif env (loc, ktype_record)
val r2 = cunif env (loc, ktype_record)
val () = checkCon env e1' e1t (L'.TRecord r1, loc)
val () = checkCon env e2' e2t (L'.TRecord r2, loc)
val gs3 = D.prove env denv (r1, r2, loc)
in
((L'.EConcat (e1', r1, e2', r2), loc),
(L'.TRecord ((L'.CConcat (r1, r2), loc)), loc),
gs1 @ gs2 @ enD gs3)
end
| L.ECut (e, c) =>
let
val (e', et, gs1) = elabExp (env, denv) e
val (c', ck, gs2) = elabCon (env, denv) c
val ft = cunif env (loc, ktype)
val rest = cunif env (loc, ktype_record)
val first = (L'.CRecord (ktype, [(c', ft)]), loc)
val () = checkCon env e' et
(L'.TRecord (L'.CConcat (first, rest), loc), loc)
val gs3 = D.prove env denv (first, rest, loc)
in
checkKind env c' ck kname;
((L'.ECut (e', c', {field = ft, rest = rest}), loc), (L'.TRecord rest, loc),
gs1 @ enD gs2 @ enD gs3)
end
| L.ECutMulti (e, c) =>
let
val (e', et, gs1) = elabExp (env, denv) e
val (c', ck, gs2) = elabCon (env, denv) c
val rest = cunif env (loc, ktype_record)
val () = checkCon env e' et
(L'.TRecord (L'.CConcat (c', rest), loc), loc)
val gs3 = D.prove env denv (c', rest, loc)
in
checkKind env c' ck (L'.KRecord ktype, loc);
((L'.ECutMulti (e', c', {rest = rest}), loc), (L'.TRecord rest, loc),
gs1 @ enD gs2 @ enD gs3)
end
| L.ECase (e, pes) =>
let
val (e', et, gs1) = elabExp (env, denv) e
val result = cunif env (loc, (L'.KType, loc))
val (pes', gs) = ListUtil.foldlMap
(fn ((p, e), gs) =>
let
val ((p', pt), (env, _)) = elabPat (p, (env, SS.empty))
val (e', et', gs1) = elabExp (env, denv) e
in
checkPatCon env p' pt et;
checkCon env e' et' result;
((p', e'), gs1 @ gs)
end)
gs1 pes
in
case exhaustive (env, et, map #1 pes', loc) of
NONE => ()
| SOME p => if !mayDelay then
delayedExhaustives := (env, et, map #1 pes', loc) :: !delayedExhaustives
else
expError env (Inexhaustive (loc, p));
((L'.ECase (e', pes', {disc = et, result = result}), loc), result, gs)
end
| L.ELet (eds, e) =>
let
val (eds, (env, gs1)) = ListUtil.foldlMap (elabEdecl denv) (env, []) eds
val (e, t, gs2) = elabExp (env, denv) e
in
((L'.ELet (eds, e, t), loc), t, gs1 @ gs2)
end
in
(*prefaces "/elabExp" [("e", SourcePrint.p_exp eAll)];*)
r
end
and elabEdecl denv (dAll as (d, loc), (env, gs)) =
let
val r =
case d of
L.EDVal (p, e) =>
let
val ((p', pt), (env', _)) = elabPat (p, (env, SS.empty))
val (e', et, gs1) = elabExp (env, denv) e
val () = checkCon env e' et pt
val env' = E.patBinds env p'
(* Redo to get proper detection of type class witnesses *)
val pt = normClassConstraint env pt
in
case exhaustive (env, et, [p'], loc) of
NONE => ()
| SOME p => if !mayDelay then
delayedExhaustives := (env, et, [p'], loc) :: !delayedExhaustives
else
expError env (Inexhaustive (loc, p));
((L'.EDVal (p', pt, e'), loc), (env', gs1 @ gs))
end
| L.EDValRec vis =>
let
fun allowable (e, _) =
case e of
L.EAbs _ => true
| L.ECAbs (_, _, _, e) => allowable e
| L.EKAbs (_, e) => allowable e
| L.EDisjoint (_, _, e) => allowable e
| _ => false
val (vis, gs) = ListUtil.foldlMap
(fn ((x, co, e), gs) =>
let
val (c', _, gs1) = case co of
NONE => (cunif env (loc, ktype), ktype, [])
| SOME c => elabCon (env, denv) c
in
((x, c', e), enD gs1 @ gs)
end) gs vis
val env = foldl (fn ((x, c', _), env) => E.pushERel env x c') env vis
val (vis, gs) = ListUtil.foldlMap (fn ((x, c', e), gs) =>
let
val (e', et, gs1) = elabExp (env, denv) e
in
checkCon env e' et c';
if allowable e then
()
else
expError env (IllegalRec (x, e'));
((x, c', e'), gs1 @ gs)
end) gs vis
in
((L'.EDValRec vis, loc), (env, gs))
end
in
r
end
val hnormSgn = E.hnormSgn
fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan)
fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan)
fun viewOf () = (L'.CModProj (!basis_r, [], "sql_view"), ErrorMsg.dummySpan)
fun queryOf () = (L'.CModProj (!basis_r, [], "sql_query"), ErrorMsg.dummySpan)
fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan)
fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan)
fun dopenConstraints (loc, env, denv) {str, strs} =
case E.lookupStr env str of
NONE => (strError env (UnboundStr (loc, str));
denv)
| SOME (n, sgn) =>
let
val (st, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {str = str, sgn = sgn, field = m} of
NONE => (strError env (UnboundStr (loc, m));
(strerror, sgnerror))
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) strs
fun collect first (st, sgn) =
case E.projectConstraints env {sgn = sgn, str = st} of
NONE => []
| SOME cs =>
case #1 (hnormSgn env sgn) of
L'.SgnConst sgis =>
foldl (fn (sgi, cs) =>
case #1 sgi of
L'.SgiStr (L'.Import, x, _, _) =>
(case E.projectStr env {sgn = sgn, str = st, field = x} of
NONE => raise Fail "Elaborate: projectStr in collect"
| SOME sgn' =>
List.revAppend (collect false ((L'.StrProj (st, x), loc), sgn'),
cs))
| _ => cs) cs sgis
| _ => cs
in
foldl (fn ((c1, c2), denv) =>
D.assert env denv (c1, c2)) denv (collect true (st, sgn))
end
fun tcdump env =
Print.preface("Instances", p_list_sep Print.PD.newline
(fn (cl, ls) =>
box [p_con env cl,
box [Print.PD.string "{",
p_list (fn (t, e) =>
box [p_exp env e,
Print.PD.string " : ",
p_con env t]) ls,
Print.PD.string "}"]])
(E.listClasses env))
fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
((*Print.preface ("elabSgi", SourcePrint.p_sgn_item (sgi, loc));*)
case sgi of
L.SgiConAbs (x, k) =>
let
val k' = elabKind env k
val (env', n) = E.pushCNamed env x k' NONE
in
([(L'.SgiConAbs (x, n, k'), loc)], (env', denv, gs))
end
| L.SgiCon (x, ko, c) =>
let
val k' = case ko of
NONE => kunif env loc
| SOME k => elabKind env k
val (c', ck, gs') = elabCon (env, denv) c
val (env', n) = E.pushCNamed env x k' (SOME c')
in
checkKind env c' ck k';
([(L'.SgiCon (x, n, k', c'), loc)], (env', denv, gs' @ gs))
end
| L.SgiDatatype dts =>
let
val k = (L'.KType, loc)
val (dts, env) = ListUtil.foldlMap (fn ((x, xs, xcs), env) =>
let
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
val (env, n) = E.pushCNamed env x k' NONE
in
((x, n, xs, xcs), env)
end)
env dts
val (dts, env) = ListUtil.foldlMap
(fn ((x, n, xs, xcs), env) =>
let
val t = (L'.CNamed n, loc)
val nxs = length xs - 1
val t = ListUtil.foldli (fn (i, _, t) =>
(L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs
val (env', denv') = foldl (fn (x, (env', denv')) =>
(E.pushCRel env' x k,
D.enter denv')) (env, denv) xs
val (xcs, (used, env, gs)) =
ListUtil.foldlMap
(fn ((x, to), (used, env, gs)) =>
let
val (to, t, gs') = case to of
NONE => (NONE, t, gs)
| SOME t' =>
let
val (t', tk, gs') =
elabCon (env', denv') t'
in
checkKind env' t' tk k;
(SOME t',
(L'.TFun (t', t), loc),
gs' @ gs)
end
val t = foldl (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc))
t xs
val (env, n') = E.pushENamed env x t
in
if SS.member (used, x) then
strError env (DuplicateConstructor (x, loc))
else
();
((x, n', to), (SS.add (used, x), env, gs'))
end)
(SS.empty, env, []) xcs
in
((x, n, xs, xcs), E.pushDatatype env n xs xcs)
end)
env dts
in
([(L'.SgiDatatype dts, loc)], (env, denv, gs))
end
| L.SgiDatatypeImp (_, [], _) => raise Fail "Empty SgiDatatypeImp"
| L.SgiDatatypeImp (x, m1 :: ms, s) =>
(case E.lookupStr env m1 of
NONE => (strError env (UnboundStr (loc, m1));
([], (env, denv, gs)))
| SOME (n, sgn) =>
let
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => (conError env (UnboundStrInCon (loc, m));
(strerror, sgnerror))
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) ms
in
case hnormCon env (L'.CModProj (n, ms, s), loc) of
(L'.CModProj (n, ms, s), _) =>
(case E.projectDatatype env {sgn = sgn, str = str, field = s} of
NONE => (conError env (UnboundDatatype (loc, s));
([], (env, denv, [])))
| SOME (xs, xncs) =>
let
val k = (L'.KType, loc)
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
val t = (L'.CModProj (n, ms, s), loc)
val (env, n') = E.pushCNamed env x k' (SOME t)
val env = E.pushDatatype env n' xs xncs
val t = (L'.CNamed n', loc)
val env = foldl (fn ((x, n, to), env) =>
let
val t = case to of
NONE => t
| SOME t' => (L'.TFun (t', t), loc)
val t = foldr (fn (x, t) =>
(L'.TCFun (L'.Implicit, x, k, t), loc))
t xs
in
E.pushENamedAs env x n t
end) env xncs
in
([(L'.SgiDatatypeImp (x, n', n, ms, s, xs, xncs), loc)], (env, denv, []))
end)
| _ => (strError env (NotDatatype loc);
([], (env, denv, [])))
end)
| L.SgiVal (x, c) =>
let
val (c', ck, gs') = elabCon (env, denv) c
val old = c'
val c' = normClassConstraint env c'
val (env', n) = E.pushENamed env x c'
in
(unifyKinds env ck ktype
handle KUnify arg => strError env (NotType (loc, ck, arg)));
([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs))
end
| L.SgiTable (x, c, pe, ce) =>
let
val cstK = (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc)
val (c', ck, gs') = elabCon (env, denv) c
val pkey = cunif env (loc, cstK)
val visible = cunif env (loc, cstK)
val x' = x ^ "_hidden_constraints"
val (env', hidden_n) = E.pushCNamed env x' cstK NONE
val hidden = (L'.CNamed hidden_n, loc)
val uniques = (L'.CConcat (visible, hidden), loc)
val ct = tableOf ()
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 gs'' = List.mapPartial (fn Disjoint x => SOME x
| _ => NONE) gs''
val pst = (L'.CModProj (!basis_r, [], "primary_key"), loc)
val pst = (L'.CApp (pst, c'), loc)
val pst = (L'.CApp (pst, pkey), loc)
val (ce', cet, gs''') = elabExp (env', denv) ce
val gs''' = List.mapPartial (fn Disjoint x => SOME x
| _ => NONE) gs'''
val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc)
val cst = (L'.CApp (cst, c'), loc)
val cst = (L'.CApp (cst, visible), loc)
val (env', n) = E.pushENamed env' x ct
in
checkKind env c' ck (L'.KRecord (L'.KType, loc), loc);
checkCon env' pe' pet pst;
checkCon env' ce' cet cst;
([(L'.SgiConAbs (x', hidden_n, cstK), loc),
(L'.SgiConstraint ((L'.CConcat (pkey, visible), loc), hidden), loc),
(L'.SgiVal (x, n, ct), loc)], (env', denv, gs''' @ gs'' @ gs' @ gs))
end
| L.SgiStr (x, sgn) =>
let
val (sgn', gs') = elabSgn (env, denv) sgn
val (env', n) = E.pushStrNamed env x sgn'
val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []}
in
([(L'.SgiStr (L'.Import, x, n, sgn'), loc)], (env', denv', gs' @ gs))
end
| L.SgiSgn (x, sgn) =>
let
val (sgn', gs') = elabSgn (env, denv) sgn
val (env', n) = E.pushSgnNamed env x sgn'
in
([(L'.SgiSgn (x, n, sgn'), loc)], (env', denv, gs' @ gs))
end
| L.SgiInclude sgn =>
let
val (sgn', gs') = elabSgn (env, denv) sgn
in
case #1 (hnormSgn env sgn') of
L'.SgnConst sgis =>
(sgis, (foldl (fn (sgi, env) => E.sgiBinds env sgi) env sgis, denv, gs' @ gs))
| _ => (sgnError env (NotIncludable sgn');
([], (env, denv, [])))
end
| L.SgiConstraint (c1, c2) =>
let
val (c1', k1, gs1) = elabCon (env, denv) c1
val (c2', k2, gs2) = elabCon (env, denv) c2
val denv = D.assert env denv (c1', c2')
in
checkKind env c1' k1 (L'.KRecord (kunif env loc), loc);
checkKind env c2' k2 (L'.KRecord (kunif env loc), loc);
([(L'.SgiConstraint (c1', c2'), loc)], (env, denv, gs1 @ gs2))
end
| L.SgiClassAbs (x, k) =>
let
val k = elabKind env k
val (env, n) = E.pushCNamed env x k NONE
val env = E.pushClass env n
in
([(L'.SgiClassAbs (x, n, k), loc)], (env, denv, []))
end
| L.SgiClass (x, k, c) =>
let
val k = elabKind env k
val (c', ck, gs) = elabCon (env, denv) c
val (env, n) = E.pushCNamed env x k (SOME c')
val env = E.pushClass env n
in
checkKind env c' ck k;
([(L'.SgiClass (x, n, k, c'), loc)], (env, denv, []))
end)
and elabSgn (env, denv) (sgn, loc) =
case sgn of
L.SgnConst sgis =>
let
val (sgis', (_, _, gs)) = ListUtil.foldlMapConcat elabSgn_item (env, denv, []) sgis
val _ = foldl (fn ((sgi, loc), (cons, vals, sgns, strs)) =>
case sgi of
L'.SgiConAbs (x, _, _) =>
(if SS.member (cons, x) then
sgnError env (DuplicateCon (loc, x))
else
();
(SS.add (cons, x), vals, sgns, strs))
| L'.SgiCon (x, _, _, _) =>
(if SS.member (cons, x) then
sgnError env (DuplicateCon (loc, x))
else
();
(SS.add (cons, x), vals, sgns, strs))
| L'.SgiDatatype dts =>
let
val (cons, vals) =
let
fun doOne ((x, _, _, xncs), (cons, vals)) =
let
val vals = foldl (fn ((x, _, _), vals) =>
(if SS.member (vals, x) then
sgnError env (DuplicateVal (loc, x))
else
();
SS.add (vals, x)))
vals xncs
in
if SS.member (cons, x) then
sgnError env (DuplicateCon (loc, x))
else
();
(SS.add (cons, x), vals)
end
in
foldl doOne (cons, vals) dts
end
in
(cons, vals, sgns, strs)
end
| L'.SgiDatatypeImp (x, _, _, _, _, _, _) =>
(if SS.member (cons, x) then
sgnError env (DuplicateCon (loc, x))
else
();
(SS.add (cons, x), vals, sgns, strs))
| L'.SgiVal (x, _, _) =>
(if SS.member (vals, x) then
sgnError env (DuplicateVal (loc, x))
else
();
(cons, SS.add (vals, x), sgns, strs))
| L'.SgiSgn (x, _, _) =>
(if SS.member (sgns, x) then
sgnError env (DuplicateSgn (loc, x))
else
();
(cons, vals, SS.add (sgns, x), strs))
| L'.SgiStr (_, x, _, _) =>
(if SS.member (strs, x) then
sgnError env (DuplicateStr (loc, x))
else
();
(cons, vals, sgns, SS.add (strs, x)))
| L'.SgiConstraint _ => (cons, vals, sgns, strs)
| L'.SgiClassAbs (x, _, _) =>
(if SS.member (cons, x) then
sgnError env (DuplicateCon (loc, x))
else
();
(SS.add (cons, x), vals, sgns, strs))
| L'.SgiClass (x, _, _, _) =>
(if SS.member (cons, x) then
sgnError env (DuplicateCon (loc, x))
else
();
(SS.add (cons, x), vals, sgns, strs)))
(SS.empty, SS.empty, SS.empty, SS.empty) sgis'
in
((L'.SgnConst sgis', loc), gs)
end
| L.SgnVar x =>
(case E.lookupSgn env x of
NONE =>
(sgnError env (UnboundSgn (loc, x));
((L'.SgnError, loc), []))
| SOME (n, sgis) => ((L'.SgnVar n, loc), []))
| L.SgnFun (m, dom, ran) =>
let
val (dom', gs1) = elabSgn (env, denv) dom
val (env', n) = E.pushStrNamed env m dom'
val denv' = dopenConstraints (loc, env', denv) {str = m, strs = []}
val (ran', gs2) = elabSgn (env', denv') ran
in
((L'.SgnFun (m, n, dom', ran'), loc), gs1 @ gs2)
end
| L.SgnWhere (sgn, ms, x, c) =>
let
val (sgn', ds1) = elabSgn (env, denv) sgn
val (c', ck, ds2) = elabCon (env, denv) c
fun checkPath (ms, sgn') =
case #1 (hnormSgn env sgn') of
L'.SgnConst sgis =>
List.exists (fn (L'.SgiConAbs (x', _, k), _) =>
List.null ms andalso x' = x andalso
(unifyKinds env k ck
handle KUnify x => sgnError env (WhereWrongKind x);
true)
| (L'.SgiStr (_, x', _, sgn''), _) =>
(case ms of
[] => false
| m :: ms' =>
m = x' andalso
checkPath (ms', sgn''))
| _ => false) sgis
| _ => false
in
if checkPath (ms, sgn') then
((L'.SgnWhere (sgn', ms, x, c'), loc), ds1 @ ds2)
else
(sgnError env (UnWhereable (sgn', x));
(sgnerror, []))
end
| L.SgnProj (m, ms, x) =>
(case E.lookupStr env m of
NONE => (strError env (UnboundStr (loc, m));
(sgnerror, []))
| SOME (n, sgn) =>
let
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => (strError env (UnboundStr (loc, m));
(strerror, sgnerror))
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) ms
in
case E.projectSgn env {sgn = sgn, str = str, field = x} of
NONE => (sgnError env (UnboundSgn (loc, x));
(sgnerror, []))
| SOME _ => ((L'.SgnProj (n, ms, x), loc), [])
end)
and selfify env {str, strs, sgn} =
case #1 (hnormSgn env sgn) of
L'.SgnError => sgn
| L'.SgnVar _ => sgn
| L'.SgnConst sgis =>
(L'.SgnConst (#1 (ListUtil.foldlMapConcat
(fn (sgi, env) =>
(case sgi of (L'.SgiConAbs (x, n, k), loc) =>
[(L'.SgiCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)]
| (L'.SgiDatatype dts, loc) =>
map (fn (x, n, xs, xncs) => (L'.SgiDatatypeImp (x, n, str, strs, x, xs, xncs), loc)) dts
| (L'.SgiClassAbs (x, n, k), loc) =>
[(L'.SgiClass (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)]
| (L'.SgiStr (im, x, n, sgn), loc) =>
[(L'.SgiStr (im, x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc)]
| x => [x],
E.sgiBinds env sgi)) env sgis)), #2 sgn)
| L'.SgnFun _ => sgn
| L'.SgnWhere _ => sgn
| L'.SgnProj (m, ms, x) =>
case E.projectSgn env {str = foldl (fn (m, str) => (L'.StrProj (str, m), #2 sgn))
(L'.StrVar m, #2 sgn) ms,
sgn = #2 (E.lookupStrNamed env m),
field = x} of
NONE => raise Fail "Elaborate.selfify: projectSgn returns NONE"
| SOME sgn => selfify env {str = str, strs = strs, sgn = sgn}
and selfifyAt env {str, sgn} =
let
fun self (str, _) =
case str of
L'.StrVar x => SOME (x, [])
| L'.StrProj (str, x) =>
(case self str of
NONE => NONE
| SOME (m, ms) => SOME (m, ms @ [x]))
| _ => NONE
in
case self str of
NONE => sgn
| SOME (str, strs) => selfify env {sgn = sgn, str = str, strs = strs}
end
and dopen env {str, strs, sgn} =
let
fun isVisible x = x <> "" andalso String.sub (x, 0) <> #"?"
val m = foldl (fn (m, str) => (L'.StrProj (str, m), #2 sgn))
(L'.StrVar str, #2 sgn) strs
in
case #1 (hnormSgn env sgn) of
L'.SgnConst sgis =>
ListUtil.foldlMapConcat
(fn ((sgi, loc), env') =>
let
val d =
case sgi of
L'.SgiConAbs (x, n, k) =>
if isVisible x then
let
val c = (L'.CModProj (str, strs, x), loc)
in
[(L'.DCon (x, n, k, c), loc)]
end
else
[]
| L'.SgiCon (x, n, k, c) =>
if isVisible x then
[(L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)]
else
[]
| L'.SgiDatatype dts =>
List.mapPartial (fn (x, n, xs, xncs) => if isVisible x then
SOME (L'.DDatatypeImp (x, n, str, strs, x, xs, xncs), loc)
else
NONE) dts
| L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) =>
if isVisible x then
[(L'.DDatatypeImp (x, n, m1, ms, x', xs, xncs), loc)]
else
[]
| L'.SgiVal (x, n, t) =>
if isVisible x then
[(L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc)]
else
[]
| L'.SgiStr (_, x, n, sgn) =>
if isVisible x then
[(L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc)]
else
[]
| L'.SgiSgn (x, n, sgn) =>
if isVisible x then
[(L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc)]
else
[]
| L'.SgiConstraint (c1, c2) =>
[(L'.DConstraint (c1, c2), loc)]
| L'.SgiClassAbs (x, n, k) =>
if isVisible x then
let
val c = (L'.CModProj (str, strs, x), loc)
in
[(L'.DCon (x, n, k, c), loc)]
end
else
[]
| L'.SgiClass (x, n, k, _) =>
if isVisible x then
let
val c = (L'.CModProj (str, strs, x), loc)
in
[(L'.DCon (x, n, k, c), loc)]
end
else
[]
in
(d, foldl (fn (d, env') => E.declBinds env' d) env' d)
end)
env sgis
| _ => (strError env (UnOpenable sgn);
([], env))
end
and sgiOfDecl (d, loc) =
case d of
L'.DCon (x, n, k, c) => [(L'.SgiCon (x, n, k, c), loc)]
| L'.DDatatype x => [(L'.SgiDatatype x, loc)]
| L'.DDatatypeImp x => [(L'.SgiDatatypeImp x, loc)]
| L'.DVal (x, n, t, _) => [(L'.SgiVal (x, n, t), loc)]
| L'.DValRec vis => map (fn (x, n, t, _) => (L'.SgiVal (x, n, t), loc)) vis
| L'.DSgn (x, n, sgn) => [(L'.SgiSgn (x, n, sgn), loc)]
| L'.DStr (x, n, sgn, _) => [(L'.SgiStr (L'.Import, x, n, sgn), loc)]
| L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (L'.Import, x, n, sgn), loc)]
| L'.DConstraint cs => [(L'.SgiConstraint cs, loc)]
| L'.DExport _ => []
| L'.DTable (tn, x, n, c, _, pc, _, cc) =>
[(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc),
(L'.CConcat (pc, cc), loc)), loc)), loc)]
| L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)]
| L'.DView (tn, x, n, _, c) =>
[(L'.SgiVal (x, n, (L'.CApp (viewOf (), c), loc)), loc)]
| L'.DDatabase _ => []
| L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)]
| L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)]
| L'.DTask _ => []
| L'.DPolicy _ => []
| L'.DOnError _ => []
| L'.DFfi (x, n, _, t) => [(L'.SgiVal (x, n, t), loc)]
and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
("sgn2", p_sgn env sgn2)];*)
case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of
(L'.SgnError, _) => ()
| (_, L'.SgnError) => ()
| (L'.SgnConst sgis1, L'.SgnConst sgis2) =>
let
(*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1),
("sgn2", p_sgn env sgn2),
("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)),
("sgis2", p_sgn env (L'.SgnConst sgis2, loc2))]*)
fun cpart n = IM.find (!counterparts, n)
fun cparts (n2, n1) = counterparts := IM.insert (!counterparts, n2, n1)
fun uncparts n2 = (counterparts := #1 (IM.remove (!counterparts, n2)))
handle NotFound => ()
val sub2 = U.Con.map {kind = fn k => k,
con = fn c =>
case c of
L'.CNamed n2 =>
(case cpart n2 of
NONE => c
| SOME n1 => L'.CNamed n1)
| _ => c}
fun folder (sgi2All as (sgi, loc), env) =
let
(*val () = prefaces "folder" [("sgi2", p_sgn_item env sgi2All)]*)
fun seek' f p =
let
fun seek env ls =
case ls of
[] => f env
| h :: t =>
case p (env, h) of
NONE =>
let
val env = case #1 h of
L'.SgiCon (x, n, k, c) =>
if E.checkENamed env n then
env
else
(uncparts n;
E.pushCNamedAs env x n k (SOME c))
| L'.SgiConAbs (x, n, k) =>
if E.checkENamed env n then
env
else
E.pushCNamedAs env x n k NONE
| _ => env
in
seek (E.sgiBinds env h) t
end
| SOME envs => envs
in
seek env sgis1
end
val seek = seek' (fn env => (sgnError env (UnmatchedSgi (strLoc, sgi2All));
env))
in
case sgi of
L'.SgiConAbs (x, n2, k2) =>
seek (fn (env, sgi1All as (sgi1, loc)) =>
let
fun found (x', n1, k1, co1) =
if x = x' then
let
val () = unifyKinds env k1 k2
handle KUnify (k1, k2, env', err) =>
sgnError env (SgiWrongKind (loc, sgi1All, k1,
sgi2All, k2, env', err))
val env = E.pushCNamedAs env x n1 k1 co1
in
SOME (if n1 = n2 then
env
else
(cparts (n2, n1);
E.pushCNamedAs env x n2 k2 (SOME (L'.CNamed n1, loc2))))
end
else
NONE
in
case sgi1 of
L'.SgiConAbs (x', n1, k1) => found (x', n1, k1, NONE)
| L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, SOME c1)
| L'.SgiDatatype dts =>
let
val k = (L'.KType, loc)
fun search dts =
case dts of
[] => NONE
| (x', n1, xs, _) :: dts =>
let
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
in
case found (x', n1, k', NONE) of
NONE => search dts
| x => x
end
in
search dts
end
| L'.SgiDatatypeImp (x', n1, m1, ms, s, xs, _) =>
let
val k = (L'.KType, loc)
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
in
found (x', n1, k', SOME (L'.CModProj (m1, ms, s), loc))
end
| L'.SgiClassAbs (x', n1, k) => found (x', n1, k, NONE)
| L'.SgiClass (x', n1, k, c) => found (x', n1, k, SOME c)
| _ => NONE
end)
| L'.SgiCon (x, n2, k2, c2) =>
seek (fn (env, sgi1All as (sgi1, loc)) =>
let
fun found (x', n1, k1, c1) =
if x = x' then
let
val c2 = sub2 c2
fun good () =
let
val env = E.pushCNamedAs env x n2 k2 (SOME c2)
val env = if n1 = n2 then
env
else
(cparts (n2, n1);
E.pushCNamedAs env x n1 k1 (SOME c1))
in
SOME env
end
in
(unifyCons env loc c1 c2;
good ())
handle CUnify (c1, c2, env', err) =>
(sgnError env (SgiWrongCon (loc, sgi1All, c1,
sgi2All, c2, env', err));
good ())
end
else
NONE
in
case sgi1 of
L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, c1)
| L'.SgiClass (x', n1, k1, c1) => found (x', n1, k1, c1)
| _ => NONE
end)
| L'.SgiDatatype dts2 =>
let
fun found' (sgi1All as (_, loc), (x1, n1, xs1, xncs1), (x2, n2, xs2, xncs2), env) =
if x1 <> x2 then
NONE
else
let
fun mismatched ue =
(sgnError env (SgiMismatchedDatatypes (loc, sgi1All, sgi2All, ue));
SOME env)
val k = (L'.KType, loc)
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs1
fun good () =
let
val env = E.sgiBinds env sgi1All
val env = if n1 = n2 then
env
else
(cparts (n2, n1);
E.pushCNamedAs env x1 n2 k'
(SOME (L'.CNamed n1, loc)))
in
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)))
val env = foldl (fn (x, env) => E.pushCRel env x k) env xs1
fun xncBad ((x1, _, t1), (x2, _, t2)) =
String.compare (x1, x2) <> EQUAL
orelse case (t1, t2) of
(NONE, NONE) => false
| (SOME t1, SOME t2) =>
(unifyCons env loc t1 (sub2 t2); false)
| _ => true
in
(if xs1 <> xs2
orelse length xncs1 <> length xncs2
orelse ListPair.exists xncBad (xncs1, xncs2) then
mismatched NONE
else
good ())
handle CUnify ue => mismatched (SOME ue)
end
in
seek'
(fn _ =>
let
fun seekOne (dt2, env) =
seek (fn (env, sgi1All as (sgi1, _)) =>
case sgi1 of
L'.SgiDatatypeImp (x', n1, _, _, _, xs, xncs1) =>
found' (sgi1All, (x', n1, xs, xncs1), dt2, env)
| _ => NONE)
fun seekAll (dts, env) =
case dts of
[] => env
| dt :: dts => seekAll (dts, seekOne (dt, env))
in
seekAll (dts2, env)
end)
(fn (env, sgi1All as (sgi1, _)) =>
let
fun found dts1 =
let
fun iter (dts1, dts2, env) =
case (dts1, dts2) of
([], []) => SOME env
| (dt1 :: dts1, dt2 :: dts2) =>
(case found' (sgi1All, dt1, dt2, env) of
NONE => NONE
| SOME env => iter (dts1, dts2, env))
| _ => NONE
in
iter (dts1, dts2, env)
end
in
case sgi1 of
L'.SgiDatatype dts1 => found dts1
| _ => NONE
end)
end
| L'.SgiDatatypeImp (x, n2, m12, ms2, s2, xs, _) =>
seek (fn (env, sgi1All as (sgi1, loc)) =>
case sgi1 of
L'.SgiDatatypeImp (x', n1, m11, ms1, s1, _, _) =>
if x = x' then
let
val k = (L'.KType, loc)
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
val t1 = (L'.CModProj (m11, ms1, s1), loc)
val t2 = (L'.CModProj (m12, ms2, s2), loc)
fun good () =
let
val env = E.pushCNamedAs env x n1 k' (SOME t1)
val env = E.pushCNamedAs env x n2 k' (SOME t2)
in
cparts (n2, n1);
SOME env
end
in
(unifyCons env loc t1 t2;
good ())
handle CUnify (c1, c2, env', err) =>
(sgnError env (SgiWrongCon (loc, sgi1All, c1, sgi2All, c2, env', err));
good ())
end
else
NONE
| _ => NONE)
| L'.SgiVal (x, n2, c2) =>
seek (fn (env, sgi1All as (sgi1, loc)) =>
case sgi1 of
L'.SgiVal (x', n1, c1) =>
if x = x' then
((*prefaces "val" [("x", PD.string x),
("n1", PD.string (Int.toString n1)),
("c1", p_con env c1),
("c2", p_con env c2),
("c2'", p_con env (sub2 c2))];*)
unifyCons env loc c1 (sub2 c2);
SOME env)
handle CUnify (c1, c2, env', err) =>
(sgnError env (SgiWrongCon (loc, sgi1All, c1, sgi2All, c2, env', err));
SOME env)
else
NONE
| _ => NONE)
| L'.SgiStr (_, x, n2, sgn2) =>
seek (fn (env, sgi1All as (sgi1, loc)) =>
case sgi1 of
L'.SgiStr (_, x', n1, sgn1) =>
if x = x' then
let
(* Don't forget to save & restore the
* counterparts map around recursive calls!
* Otherwise, all sorts of mayhem may result. *)
val saved = !counterparts
val () = subSgn' counterparts env loc sgn1 sgn2
val () = counterparts := saved
val env = E.pushStrNamedAs env x n1 sgn1
val env = if n1 = n2 then
env
else
E.pushStrNamedAs env x n2
(selfifyAt env {str = (L'.StrVar n1, #2 sgn2),
sgn = sgn2})
in
SOME env
end
else
NONE
| _ => NONE)
| L'.SgiSgn (x, n2, sgn2) =>
seek (fn (env, sgi1All as (sgi1, loc)) =>
case sgi1 of
L'.SgiSgn (x', n1, sgn1) =>
if x = x' then
let
val () = subSgn' counterparts env loc sgn1 sgn2
val () = subSgn' counterparts env loc sgn2 sgn1
val env = E.pushSgnNamedAs env x n2 sgn2
val env = if n1 = n2 then
env
else
(cparts (n2, n1);
E.pushSgnNamedAs env x n1 sgn2)
in
SOME env
end
else
NONE
| _ => NONE)
| L'.SgiConstraint (c2, d2) =>
seek (fn (env, sgi1All as (sgi1, loc)) =>
case sgi1 of
L'.SgiConstraint (c1, d1) =>
(* It's important to do only simple equality checking here,
* with no unification, because constraints are unnamed.
* It's too easy to pick the wrong pair to unify! *)
if consEqSimple env (c1, c2)
andalso consEqSimple env (d1, d2) then
SOME env
else
NONE
| _ => NONE)
| L'.SgiClassAbs (x, n2, k2) =>
seek (fn (env, sgi1All as (sgi1, loc)) =>
let
fun found (x', n1, k1, co) =
if x = x' then
let
val () = unifyKinds env k1 k2
handle KUnify (k1, k2, env', err) =>
sgnError env (SgiWrongKind (loc, sgi1All, k1,
sgi2All, k2, env', err))
val env = E.pushCNamedAs env x n1 k1 co
in
SOME (if n1 = n2 then
env
else
(cparts (n2, n1);
E.pushCNamedAs env x n2 k1 (SOME (L'.CNamed n1, loc2))))
end
else
NONE
in
case sgi1 of
L'.SgiClassAbs (x', n1, k1) => found (x', n1, k1, NONE)
| L'.SgiClass (x', n1, k1, c) => found (x', n1, k1, SOME c)
| L'.SgiConAbs (x', n1, k1) => found (x', n1, k1, NONE)
| L'.SgiCon (x', n1, k1, c) => found (x', n1, k1, SOME c)
| _ => NONE
end)
| L'.SgiClass (x, n2, k2, c2) =>
seek (fn (env, sgi1All as (sgi1, loc)) =>
let
fun found (x', n1, k1, c1) =
if x = x' then
let
val () = unifyKinds env k1 k2
handle KUnify (k1, k2, env', err) =>
sgnError env (SgiWrongKind (loc, sgi1All, k1,
sgi2All, k2, env', err))
val c2 = sub2 c2
fun good () =
let
val env = E.pushCNamedAs env x n2 k2 (SOME c2)
val env = if n1 = n2 then
env
else
(cparts (n2, n1);
E.pushCNamedAs env x n1 k2 (SOME c1))
in
SOME env
end
in
(unifyCons env loc c1 c2;
good ())
handle CUnify (c1, c2, env', err) =>
(sgnError env (SgiWrongCon (loc, sgi1All, c1,
sgi2All, c2, env', err));
good ())
end
else
NONE
in
case sgi1 of
L'.SgiClass (x', n1, k1, c1) => found (x', n1, k1, c1)
| L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, c1)
| _ => NONE
end)
end
in
ignore (foldl folder env sgis2)
end
| (L'.SgnFun (m1, n1, dom1, ran1), L'.SgnFun (m2, n2, dom2, ran2)) =>
let
val ran2 =
if n1 = n2 then
ran2
else
subStrInSgn (n2, n1) ran2
in
subSgn' counterparts env strLoc dom2 dom1;
subSgn' counterparts (E.pushStrNamedAs env m1 n1 dom2) strLoc ran1 ran2
end
| _ => sgnError env (SgnWrongForm (strLoc, sgn1, sgn2)))
and subSgn env x y z = subSgn' (ref IM.empty) env x y z
handle e as E.UnboundNamed _ => if ErrorMsg.anyErrors () then () else raise e
and positive self =
let
open L
fun none (c, _) =
case c of
CAnnot (c, _) => none c
| TFun (c1, c2) => none c1 andalso none c2
| TCFun (_, _, _, c) => none c
| TRecord c => none c
| CVar ([], x) => x <> self
| CVar _ => true
| CApp (c1, c2) => none c1 andalso none c2
| CAbs _ => false
| TDisjoint (c1, c2, c3) => none c1 andalso none c2 andalso none c3
| CKAbs _ => false
| TKFun _ => false
| CName _ => true
| CRecord xcs => List.all (fn (c1, c2) => none c1 andalso none c2) xcs
| CConcat (c1, c2) => none c1 andalso none c2
| CMap => true
| CUnit => true
| CTuple cs => List.all none cs
| CProj (c, _) => none c
| CWild _ => false
fun pos (c, _) =
case c of
CAnnot (c, _) => pos c
| TFun (c1, c2) => none c1 andalso pos c2
| TCFun (_, _, _, c) => pos c
| TRecord c => pos c
| CVar _ => true
| CApp (c1, c2) => pos c1 andalso none c2
| CAbs _ => false
| TDisjoint (c1, c2, c3) => none c1 andalso none c2 andalso none c3
| CKAbs _ => false
| TKFun _ => false
| CName _ => true
| CRecord xcs => List.all (fn (c1, c2) => none c1 andalso pos c2) xcs
| CConcat (c1, c2) => pos c1 andalso pos c2
| CMap => true
| CUnit => true
| CTuple cs => List.all pos cs
| CProj (c, _) => pos c
| CWild _ => false
in
pos
end
and wildifyStr env (str, sgn) =
case #1 (hnormSgn env sgn) of
L'.SgnConst sgis =>
(case #1 str of
L.StrConst ds =>
let
fun cname d =
case d of
L'.SgiCon (x, _, _, _) => SOME x
| L'.SgiConAbs (x, _, _) => SOME x
| L'.SgiClass (x, _, _, _) => SOME x
| L'.SgiClassAbs (x, _, _) => SOME x
| _ => NONE
fun dname (d, _) =
case d of
L.DCon (x, _, _) => SOME x
| _ => NONE
fun decompileKind (k, loc) =
case k of
L'.KType => SOME (L.KType, loc)
| L'.KArrow (k1, k2) =>
(case (decompileKind k1, decompileKind k2) of
(SOME k1, SOME k2) => SOME (L.KArrow (k1, k2), loc)
| _ => NONE)
| L'.KName => SOME (L.KName, loc)
| L'.KRecord k =>
(case decompileKind k of
SOME k => SOME (L.KRecord k, loc)
| _ => NONE)
| L'.KUnit => SOME (L.KUnit, loc)
| L'.KTuple ks =>
let
val ks' = List.mapPartial decompileKind ks
in
if length ks' = length ks then
SOME (L.KTuple ks', loc)
else
NONE
end
| L'.KError => NONE
| L'.KUnif (_, _, ref (L'.KKnown k)) => decompileKind k
| L'.KUnif _ => NONE
| L'.KTupleUnif (_, _, ref (L'.KKnown k)) => decompileKind k
| L'.KTupleUnif _ => NONE
| L'.KRel _ => NONE
| L'.KFun _ => NONE
fun maybeHnorm env c =
hnormCon env c
handle E.UnboundNamed _ => c
fun decompileCon env c =
case decompileCon' env c of
SOME v => SOME v
| NONE => decompileCon' env (maybeHnorm env c)
and decompileCon' env (c as (_, loc)) =
case #1 c of
L'.CRel i =>
let
val (s, _) = E.lookupCRel env i
in
SOME (L.CVar ([], s), loc)
end
| L'.CNamed i =>
let
val (s, _, _) = E.lookupCNamed env i
in
SOME (L.CVar ([], s), loc)
end
| L'.CModProj (m1, ms, x) =>
let
val (s, _) = E.lookupStrNamed env m1
in
SOME (L.CVar (s :: ms, x), loc)
end
| L'.CName s => SOME (L.CName s, loc)
| L'.CRecord (k, xcs) =>
let
fun fields xcs =
case xcs of
[] => SOME []
| (x, t) :: xcs =>
case (decompileCon env x, decompileCon env t, fields xcs) of
(SOME x, SOME t, SOME xcs) => SOME ((x, t) :: xcs)
| _ => NONE
val c' = Option.map (fn xcs => (L.CRecord xcs, loc))
(fields xcs)
in
Option.map (fn c' =>
case decompileKind k of
NONE => c'
| SOME k' => (L.CAnnot (c', (L.KRecord k', loc)), loc)) c'
end
| L'.CConcat (c1, c2) =>
(case (decompileCon env c1, decompileCon env c2) of
(SOME c1, SOME c2) => SOME (L.CConcat (c1, c2), loc)
| _ => NONE)
| L'.CUnit => SOME (L.CUnit, loc)
| L'.CUnif (nl, _, _, _, ref (L'.Known c)) => decompileCon env (E.mliftConInCon nl c)
| L'.CApp (f, x) =>
(case (decompileCon env f, decompileCon env x) of
(SOME f, SOME x) => SOME (L.CApp (f, x), loc)
| _ => NONE)
| L'.CTuple cs =>
let
val cs' = foldr (fn (c, cs') =>
case cs' of
NONE => NONE
| SOME cs' =>
case decompileCon env c of
NONE => NONE
| SOME c' => SOME (c' :: cs'))
(SOME []) cs
in
case cs' of
NONE => NONE
| SOME cs' => SOME (L.CTuple cs', loc)
end
| L'.CMap _ => SOME (L.CMap, loc)
| L'.TRecord c =>
(case decompileCon env c of
NONE => NONE
| SOME c' => SOME (L.TRecord c', loc))
| c => ((*Print.preface ("WTF?", p_con env (c, loc));*) NONE)
fun isClassOrFolder' env (c : L'.con) =
case #1 c of
L'.CAbs (x, k, c) =>
let
val env = E.pushCRel env x k
fun toHead (c : L'.con) =
case #1 c of
L'.CApp (c, _) => toHead c
| _ => isClassOrFolder env c
in
toHead (hnormCon env c)
end
| _ => isClassOrFolder env c
fun buildNeeded env sgis =
#1 (foldl (fn ((sgi, loc), (nd, env')) =>
(case sgi of
L'.SgiCon (x, _, k, _) => naddCon (nd, x, k)
| L'.SgiConAbs (x, _, k) => naddCon (nd, x, k)
| L'.SgiConstraint cs => naddConstraint (nd, (env', cs, loc))
| L'.SgiVal (x, _, t) =>
let
fun should t =
let
val t = normClassConstraint env' t
fun shouldR c =
case hnormCon env' c of
(L'.CApp (f, _), _) =>
(case hnormCon env' f of
(L'.CApp (f, cl), loc) =>
(case hnormCon env' f of
(L'.CMap _, _) => isClassOrFolder' env' cl
| _ => false)
| _ => false)
| (L'.CConcat (c1, c2), _) =>
shouldR c1 orelse shouldR c2
| c => false
in
case #1 t of
L'.CApp (f, _) => isClassOrFolder env' f
| L'.TRecord t => shouldR t
| _ => false
end
in
if should t then
naddVal (nd, x)
else
nd
end
| L'.SgiStr (_, x, _, s) =>
(case #1 (hnormSgn env' s) of
L'.SgnConst sgis' => naddMod (nd, x, (env', buildNeeded env' sgis'))
| _ => nd)
| _ => nd,
E.sgiBinds env' (sgi, loc)))
(nempty, env) sgis)
val nd = buildNeeded env sgis
fun removeUsed (nd, ds) =
foldl (fn ((d, _), nd) =>
case d of
L.DCon (x, _, _) => ndelCon (nd, x)
| L.DVal (x, _, _) => ndelVal (nd, x)
| L.DOpen _ => nempty
| L.DStr (x, _, _, (L.StrConst ds', _), _) =>
(case SM.find (nmods nd, x) of
NONE => nd
| SOME (env, nd') => naddMod (nd, x, (env, removeUsed (nd', ds'))))
| _ => nd)
nd ds
val nd = removeUsed (nd, ds)
(* Among the declarations present explicitly in the program, find the last constructor or constraint declaration.
* The new constructor/constraint declarations that we add may safely be put after that point. *)
fun findLast (ds, acc) =
case ds of
[] => ([], acc)
| (d : L.decl) :: ds' =>
let
val isCony = case #1 d of
L.DCon _ => true
| L.DDatatype _ => true
| L.DDatatypeImp _ => true
| L.DStr _ => true
| L.DConstraint _ => true
| _ => false
in
if isCony then
(ds, acc)
else
findLast (ds', d :: acc)
end
val (dPrefix, dSuffix) = findLast (rev ds, [])
fun extend (env, nd, ds) =
let
val ds' = List.mapPartial (fn (env', (c1, c2), loc) =>
case (decompileCon env' c1, decompileCon env' c2) of
(SOME c1, SOME c2) =>
SOME (L.DConstraint (c1, c2), loc)
| _ => NONE) (nconstraints nd)
val ds' =
case SS.listItems (nvals nd) of
[] => ds'
| xs =>
let
val ewild = (L.EWild, #2 str)
val ds'' = map (fn x => (L.DVal (x, NONE, ewild), #2 str)) xs
in
ds'' @ ds'
end
val ds' =
case ncons nd of
[] => ds'
| xs =>
map (fn (x, k) =>
let
val k =
case decompileKind k of
NONE => (L.KWild, #2 str)
| SOME k => k
val cwild = (L.CWild k, #2 str)
in
(L.DCon (x, NONE, cwild), #2 str)
end) xs @ ds'
val ds = ds @ ds'
in
map (fn d as (L.DStr (x, s, tm, (L.StrConst ds', loc'), r), loc) =>
(case SM.find (nmods nd, x) of
NONE => d
| SOME (env, nd') =>
(L.DStr (x, s, tm, (L.StrConst (extend (env, nd', ds')), loc'), r), loc))
| d => d) ds
end
in
(L.StrConst (extend (env, nd, rev dPrefix) @ dSuffix), #2 str)
end
| _ => str)
| _ => str
and elabDecl (dAll as (d, loc), (env, denv, gs)) =
let
(*val () = preface ("elabDecl", SourcePrint.p_decl dAll)*)
(*val befor = Time.now ()*)
val r =
case d of
L.DCon (x, ko, c) =>
let
val k' = case ko of
NONE => kunif env loc
| SOME k => elabKind env k
val (c', ck, gs') = elabCon (env, denv) c
val (env', n) = E.pushCNamed env x k' (SOME c')
in
checkKind env c' ck k';
([(L'.DCon (x, n, k', c'), loc)], (env', denv, enD gs' @ gs))
end
| L.DDatatype dts =>
let
val k = (L'.KType, loc)
val (dts, env) = ListUtil.foldlMap
(fn ((x, xs, xcs), env) =>
let
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
val (env, n) = E.pushCNamed env x k' NONE
in
((x, n, xs, xcs), env)
end)
env dts
val (dts, (env, gs')) = ListUtil.foldlMap
(fn ((x, n, xs, xcs), (env, gs')) =>
let
val t = (L'.CNamed n, loc)
val nxs = length xs - 1
val t = ListUtil.foldli
(fn (i, _, t) =>
(L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs
val (env', denv') = foldl (fn (x, (env', denv')) =>
(E.pushCRel env' x k,
D.enter denv')) (env, denv) xs
val (xcs, (used, env, gs')) =
ListUtil.foldlMap
(fn ((x, to), (used, env, gs)) =>
let
val (to, t, gs') = case to of
NONE => (NONE, t, gs)
| SOME t' =>
let
val (t', tk, gs') = elabCon (env', denv') t'
in
checkKind env' t' tk k;
(SOME t', (L'.TFun (t', t), loc), enD gs' @ gs)
end
val t = foldr (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) t xs
val (env, n') = E.pushENamed env x t
in
if SS.member (used, x) then
strError env (DuplicateConstructor (x, loc))
else
();
((x, n', to), (SS.add (used, x), env, gs'))
end)
(SS.empty, env, gs') xcs
in
((x, n, xs, xcs), (E.pushDatatype env n xs xcs, gs'))
end)
(env, []) dts
in
([(L'.DDatatype dts, loc)], (env, denv, gs' @ gs))
end
| L.DDatatypeImp (_, [], _) => raise Fail "Empty DDatatypeImp"
| L.DDatatypeImp (x, m1 :: ms, s) =>
(case E.lookupStr env m1 of
NONE => (expError env (UnboundStrInExp (loc, m1));
([], (env, denv, gs)))
| SOME (n, sgn) =>
let
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => (conError env (UnboundStrInCon (loc, m));
(strerror, sgnerror))
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) ms
in
case hnormCon env (L'.CModProj (n, ms, s), loc) of
(L'.CModProj (n, ms, s), _) =>
(case E.projectDatatype env {sgn = sgn, str = str, field = s} of
NONE => (conError env (UnboundDatatype (loc, s));
([], (env, denv, gs)))
| SOME (xs, xncs) =>
let
val k = (L'.KType, loc)
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
val t = (L'.CModProj (n, ms, s), loc)
val (env, n') = E.pushCNamed env x k' (SOME t)
val env = E.pushDatatype env n' xs xncs
val t = (L'.CNamed n', loc)
val nxs = length xs
val t = ListUtil.foldli (fn (i, _, t) =>
(L'.CApp (t, (L'.CRel (nxs - 1 - i), loc)), loc))
t xs
val env = foldl (fn ((x, n, to), env) =>
let
val t = case to of
NONE => t
| SOME t' => (L'.TFun (t', t), loc)
val t = foldr (fn (x, t) =>
(L'.TCFun (L'.Implicit, x, k, t), loc))
t xs
in
E.pushENamedAs env x n t
end) env xncs
in
([(L'.DDatatypeImp (x, n', n, ms, s, xs, xncs), loc)], (env, denv, gs))
end)
| _ => (strError env (NotDatatype loc);
([], (env, denv, [])))
end)
| L.DVal (x, co, e) =>
let
val (c', _, gs1) = case co of
NONE => (cunif env (loc, ktype), ktype, [])
| SOME c => elabCon (env, denv) c
val (e', et, gs2) = elabExp (env, denv) e
val () = checkCon env e' et c'
val c' = normClassConstraint env c'
val (env', n) = E.pushENamed env x c'
in
(*prefaces "DVal" [("x", Print.PD.string x),
("c'", p_con env c')];*)
([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ gs))
end
| L.DValRec vis =>
let
fun allowable (e, _) =
case e of
L.EAbs _ => true
| L.ECAbs (_, _, _, e) => allowable e
| L.EKAbs (_, e) => allowable e
| L.EDisjoint (_, _, e) => allowable e
| _ => false
val (vis, gs) = ListUtil.foldlMap
(fn ((x, co, e), gs) =>
let
val (c', _, gs1) = case co of
NONE => (cunif env (loc, ktype), ktype, [])
| SOME c => elabCon (env, denv) c
val c' = normClassConstraint env c'
in
((x, c', e), enD gs1 @ gs)
end) gs vis
val (vis, env) = ListUtil.foldlMap (fn ((x, c', e), env) =>
let
val (env, n) = E.pushENamed env x c'
in
((x, n, c', e), env)
end) env vis
val (vis, gs) = ListUtil.foldlMap (fn ((x, n, c', e), gs) =>
let
val (e', et, gs1) = elabExp (env, denv) e
in
checkCon env e' et c';
if allowable e then
()
else
expError env (IllegalRec (x, e'));
((x, n, c', e'), gs1 @ gs)
end) gs vis
val vis = map (fn (x, n, t, e) => (x, n, normClassConstraint env t, e)) vis
val d = (L'.DValRec vis, loc)
in
([d], (E.declBinds env d, denv, gs))
end
| L.DSgn (x, sgn) =>
let
val (sgn', gs') = elabSgn (env, denv) sgn
val (env', n) = E.pushSgnNamed env x sgn'
in
([(L'.DSgn (x, n, sgn'), loc)], (env', denv, enD gs' @ gs))
end
| L.DStr (x, sgno, tmo, str, _) =>
(case ModDb.lookup dAll of
SOME d =>
let
val () = if !verbose then TextIO.print ("REUSE: " ^ x ^ "\n") else ()
val env' = E.declBinds env d
val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []}
in
([d], (env', denv', gs))
end
| NONE =>
let
val () = if !verbose then TextIO.print ("CHECK: " ^ x ^ "\n") else ()
val () = if x = "Basis" then
raise Fail "Not allowed to redefine structure 'Basis'"
else
()
val formal = Option.map (elabSgn (env, denv)) sgno
val (str', sgn', gs') =
case formal of
NONE =>
let
val (str', actual, gs') = elabStr (env, denv) str
in
(str', selfifyAt env {str = str', sgn = actual}, gs')
end
| SOME (formal, gs1) =>
let
val str = wildifyStr env (str, formal)
val (str', actual, gs2) = elabStr (env, denv) str
in
subSgn env loc (selfifyAt env {str = str', sgn = actual}) formal;
(str', formal, enD gs1 @ gs2)
end
val (env', n) = E.pushStrNamed env x sgn'
val denv' =
case #1 str' of
L'.StrConst _ => dopenConstraints (loc, env', denv) {str = x, strs = []}
| L'.StrApp _ => dopenConstraints (loc, env', denv) {str = x, strs = []}
| _ => denv
val dNew = (L'.DStr (x, n, sgn', str'), loc)
in
case #1 (hnormSgn env sgn') of
L'.SgnFun _ =>
(case #1 str' of
L'.StrFun _ => ()
| _ => strError env (FunctorRebind loc))
| _ => ();
Option.map (fn tm => ModDb.insert (dNew, tm)) tmo;
([dNew], (env', denv', gs' @ gs))
end)
| L.DFfiStr (x, sgn, tmo) =>
(case ModDb.lookup dAll of
SOME d =>
let
val env' = E.declBinds env d
val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []}
in
([d], (env', denv', []))
end
| NONE =>
let
val (sgn', gs') = elabSgn (env, denv) sgn
val (env', n) = E.pushStrNamed env x sgn'
val dNew = (L'.DFfiStr (x, n, sgn'), loc)
in
case #1 sgn' of
L'.SgnConst sgis =>
(case List.find (fn (L'.SgiConAbs _, _) => false
| (L'.SgiCon _, _) => false
| (L'.SgiDatatype _, _) => false
| (L'.SgiVal _, _) => false
| _ => true) sgis of
NONE => ()
| SOME sgi => (ErrorMsg.errorAt loc "Disallowed signature item for FFI module";
epreface ("item", p_sgn_item env sgi)))
| _ => raise Fail "FFI signature isn't SgnConst";
Option.map (fn tm => ModDb.insert (dNew, tm)) tmo;
([dNew], (env', denv, enD gs' @ gs))
end)
| L.DOpen (m, ms) =>
(case E.lookupStr env m of
NONE => (strError env (UnboundStr (loc, m));
([], (env, denv, gs)))
| SOME (n, sgn) =>
let
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {str = str, sgn = sgn, field = m} of
NONE => (strError env (UnboundStr (loc, m));
(strerror, sgnerror))
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) ms
val sgn = selfifyAt env {str = str, sgn = sgn}
val (ds, env') = dopen env {str = n, strs = ms, sgn = sgn}
val denv' = dopenConstraints (loc, env', denv) {str = m, strs = ms}
in
(ds, (env', denv', gs))
end)
| L.DConstraint (c1, c2) =>
let
val (c1', k1, gs1) = elabCon (env, denv) c1
val (c2', k2, gs2) = elabCon (env, denv) c2
val gs3 = D.prove env denv (c1', c2', loc)
val denv' = D.assert env denv (c1', c2')
in
checkKind env c1' k1 (L'.KRecord (kunif env loc), loc);
checkKind env c2' k2 (L'.KRecord (kunif env loc), loc);
([(L'.DConstraint (c1', c2'), loc)], (env, denv', enD gs1 @ enD gs2 @ enD gs3 @ gs))
end
| L.DOpenConstraints (m, ms) =>
let
val denv = dopenConstraints (loc, env, denv) {str = m, strs = ms}
in
([], (env, denv, gs))
end
| L.DExport str =>
let
val (str', sgn, gs') = elabStr (env, denv) str
val sgn =
case #1 (hnormSgn env sgn) of
L'.SgnConst sgis =>
let
fun doOne (all as (sgi, _), env) =
(case sgi of
L'.SgiVal (x, n, t) =>
let
fun doPage (makeRes, ran) =
case hnormCon env ran of
(L'.CApp (tf, arg), _) =>
(case (hnormCon env tf, hnormCon env arg) of
((L'.CModProj (basis, [], "transaction"), _),
(L'.CApp (tf, arg3), _)) =>
(case (basis = !basis_r,
hnormCon env tf, hnormCon env arg3) of
(true,
(L'.CApp (tf, arg2), _),
((L'.CRecord (_, []), _))) =>
(case (hnormCon env tf) of
(L'.CApp (tf, arg1), _) =>
(case (hnormCon env tf,
hnormCon env arg1,
hnormCon env arg2) of
(tf, arg1,
(L'.CRecord (_, []), _)) =>
let
val t = (L'.CApp (tf, arg1), loc)
val t = (L'.CApp (t, arg2), loc)
val t = (L'.CApp (t, arg3), loc)
val t = (L'.CApp (
(L'.CModProj
(basis, [], "transaction"), loc),
t), loc)
fun normArgs t =
case hnormCon env t of
(L'.TFun (dom, ran), loc) =>
(L'.TFun (hnormCon env dom, normArgs ran), loc)
| t' => t'
in
(L'.SgiVal (x, n, normArgs (makeRes t)), loc)
end
| _ => all)
| _ => all)
| _ => all)
| _ => all)
| _ => all
in
case hnormCon env t of
(L'.TFun (dom, ran), _) =>
(case hnormCon env dom of
(L'.TRecord domR, _) =>
doPage (fn t => (L'.TFun ((L'.TRecord domR,
loc),
t), loc), ran)
| _ => all)
| _ => doPage (fn t => t, t)
end
| _ => all,
E.sgiBinds env all)
in
(L'.SgnConst (#1 (ListUtil.foldlMap doOne env sgis)), loc)
end
| _ => sgn
in
([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs' @ gs))
end
| L.DTable (x, c, pe, ce) =>
let
val cstK = (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc)
val (c', k, gs') = elabCon (env, denv) c
val pkey = cunif env (loc, cstK)
val uniques = cunif env (loc, cstK)
val ct = tableOf ()
val ct = (L'.CApp (ct, c'), loc)
val ct = (L'.CApp (ct, (L'.CConcat (pkey, uniques), loc)), loc)
val (env, n) = E.pushENamed env x ct
val (pe', pet, gs'') = elabExp (env, denv) pe
val (ce', cet, gs''') = elabExp (env, denv) ce
val pst = (L'.CModProj (!basis_r, [], "primary_key"), loc)
val pst = (L'.CApp (pst, c'), loc)
val pst = (L'.CApp (pst, pkey), loc)
val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc)
val cst = (L'.CApp (cst, c'), loc)
val cst = (L'.CApp (cst, uniques), loc)
in
checkKind env c' k (L'.KRecord (L'.KType, loc), loc);
checkCon env pe' pet pst;
checkCon env ce' cet cst;
([(L'.DTable (!basis_r, x, n, c', pe', pkey, ce', uniques), loc)],
(env, denv, gs''' @ gs'' @ enD gs' @ gs))
end
| L.DSequence x =>
let
val (env, n) = E.pushENamed env x (sequenceOf ())
in
([(L'.DSequence (!basis_r, x, n), loc)], (env, denv, gs))
end
| L.DView (x, e) =>
let
val (e', t, gs') = elabExp (env, denv) e
val k = (L'.KRecord (L'.KType, loc), loc)
val fs = cunif env (loc, k)
val ts = cunif env (loc, (L'.KRecord k, loc))
val tf = (L'.CApp ((L'.CMap (k, k), loc),
(L'.CAbs ("_", k, (L'.CRecord ((L'.KType, loc), []), loc)), loc)), loc)
val ts = (L'.CApp (tf, ts), loc)
val cv = viewOf ()
val cv = (L'.CApp (cv, fs), loc)
val (env', n) = E.pushENamed env x cv
val ct = queryOf ()
val ct = (L'.CApp (ct, (L'.CRecord ((L'.KRecord (L'.KType, loc), loc), []), loc)), loc)
val ct = (L'.CApp (ct, (L'.CRecord ((L'.KRecord (L'.KType, loc), loc), []), loc)), loc)
val ct = (L'.CApp (ct, ts), loc)
val ct = (L'.CApp (ct, fs), loc)
in
checkCon env e' t ct;
([(L'.DView (!basis_r, x, n, e', fs), loc)],
(env', denv, gs' @ gs))
end
| L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs))
| L.DCookie (x, c) =>
let
val (c', k, gs') = elabCon (env, denv) c
val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc)
in
checkKind env c' k (L'.KType, loc);
([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs))
end
| L.DStyle x =>
let
val (env, n) = E.pushENamed env x (styleOf ())
in
([(L'.DStyle (!basis_r, x, n), loc)], (env, denv, gs))
end
| L.DTask (e1, e2) =>
let
val (e1', t1, gs1) = elabExp (env, denv) e1
val (e2', t2, gs2) = elabExp (env, denv) e2
val targ = cunif env (loc, (L'.KType, loc))
val t1' = (L'.CModProj (!basis_r, [], "task_kind"), loc)
val t1' = (L'.CApp (t1', targ), loc)
val t2' = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc),
(L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)), loc)
val t2' = (L'.TFun (targ, t2'), loc)
in
checkCon env e1' t1 t1';
checkCon env e2' t2 t2';
([(L'.DTask (e1', e2'), loc)], (env, denv, gs2 @ gs1 @ gs))
end
| L.DPolicy e1 =>
let
val (e1', t1, gs1) = elabExp (env, denv) e1
val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc)
in
checkCon env e1' t1 t1';
([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs))
end
| L.DOnError (m1, ms, s) =>
(case E.lookupStr env m1 of
NONE => (expError env (UnboundStrInExp (loc, m1));
([], (env, denv, [])))
| SOME (n, sgn) =>
let
val (str, sgn) = foldl (fn (m, (str, sgn)) =>
case E.projectStr env {sgn = sgn, str = str, field = m} of
NONE => (conError env (UnboundStrInCon (loc, m));
(strerror, sgnerror))
| SOME sgn => ((L'.StrProj (str, m), loc), sgn))
((L'.StrVar n, loc), sgn) ms
val t = case E.projectVal env {sgn = sgn, str = str, field = s} of
NONE => (expError env (UnboundExp (loc, s));
cerror)
| SOME t => t
val page = (L'.CModProj (!basis_r, [], "page"), loc)
val xpage = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), page), loc)
val func = (L'.TFun ((L'.CModProj (!basis_r, [], "xbody"), loc), xpage), loc)
in
(unifyCons env loc t func
handle CUnify _ => ErrorMsg.error "onError handler has wrong type.");
([(L'.DOnError (n, ms, s), loc)], (env, denv, gs))
end)
| L.DFfi (x, modes, t) =>
let
val () = if Settings.getLessSafeFfi () then
()
else
ErrorMsg.errorAt loc "To enable 'ffi' declarations, the .urp directive 'lessSafeFfi' is mandatory."
val (t', _, gs1) = elabCon (env, denv) t
val t' = normClassConstraint env t'
val (env', n) = E.pushENamed env x t'
in
([(L'.DFfi (x, n, modes, t'), loc)], (env', denv, enD gs1 @ gs))
end
(*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
in
(*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll),
("d'", p_list_sep PD.newline (ElabPrint.p_decl env) (#1 r))];*)
r
end
and elabStr (env, denv) (str, loc) =
case str of
L.StrConst ds =>
let
val (ds', (_, _, gs)) = ListUtil.foldlMapConcat elabDecl (env, denv, []) ds
val sgis = ListUtil.mapConcat sgiOfDecl ds'
val (sgis, _, _, _, _) =
foldr (fn ((sgi, loc), (sgis, cons, vals, sgns, strs)) =>
case sgi of
L'.SgiConAbs (x, n, k) =>
let
val (cons, x) =
if SS.member (cons, x) then
(cons, "?" ^ x)
else
(SS.add (cons, x), x)
in
((L'.SgiConAbs (x, n, k), loc) :: sgis, cons, vals, sgns, strs)
end
| L'.SgiCon (x, n, k, c) =>
let
val (cons, x) =
if SS.member (cons, x) then
(cons, "?" ^ x)
else
(SS.add (cons, x), x)
in
((L'.SgiCon (x, n, k, c), loc) :: sgis, cons, vals, sgns, strs)
end
| L'.SgiDatatype dts =>
let
fun doOne ((x, n, xs, xncs), (cons, vals)) =
let
val (cons, x) =
if SS.member (cons, x) then
(cons, "?" ^ x)
else
(SS.add (cons, x), x)
val (xncs, vals) =
ListUtil.foldlMap
(fn ((x, n, t), vals) =>
if SS.member (vals, x) then
(("?" ^ x, n, t), vals)
else
((x, n, t), SS.add (vals, x)))
vals xncs
in
((x, n, xs, xncs), (cons, vals))
end
val (dts, (cons, vals)) = ListUtil.foldlMap doOne (cons, vals) dts
in
((L'.SgiDatatype dts, loc) :: sgis, cons, vals, sgns, strs)
end
| L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) =>
let
val (cons, x) =
if SS.member (cons, x) then
(cons, "?" ^ x)
else
(SS.add (cons, x), x)
in
((L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs), loc) :: sgis, cons, vals, sgns, strs)
end
| L'.SgiVal (x, n, c) =>
let
val (vals, x) =
if SS.member (vals, x) then
(vals, "?" ^ x)
else
(SS.add (vals, x), x)
in
((L'.SgiVal (x, n, c), loc) :: sgis, cons, vals, sgns, strs)
end
| L'.SgiSgn (x, n, sgn) =>
let
val (sgns, x) =
if SS.member (sgns, x) then
(sgns, "?" ^ x)
else
(SS.add (sgns, x), x)
in
((L'.SgiSgn (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs)
end
| L'.SgiStr (im, x, n, sgn) =>
let
val (strs, x) =
if SS.member (strs, x) then
(strs, "?" ^ x)
else
(SS.add (strs, x), x)
in
((L'.SgiStr (im, x, n, sgn), loc) :: sgis, cons, vals, sgns, strs)
end
| L'.SgiConstraint _ => ((sgi, loc) :: sgis, cons, vals, sgns, strs)
| L'.SgiClassAbs (x, n, k) =>
let
val (cons, x) =
if SS.member (cons, x) then
(cons, "?" ^ x)
else
(SS.add (cons, x), x)
in
((L'.SgiClassAbs (x, n, k), loc) :: sgis, cons, vals, sgns, strs)
end
| L'.SgiClass (x, n, k, c) =>
let
val (cons, x) =
if SS.member (cons, x) then
(cons, "?" ^ x)
else
(SS.add (cons, x), x)
in
((L'.SgiClass (x, n, k, c), loc) :: sgis, cons, vals, sgns, strs)
end)
([], SS.empty, SS.empty, SS.empty, SS.empty) sgis
in
((L'.StrConst ds', loc), (L'.SgnConst sgis, loc), gs)
end
| L.StrVar x =>
(case E.lookupStr env x of
NONE =>
(strError env (UnboundStr (loc, x));
(strerror, sgnerror, []))
| SOME (n, sgn) => ((L'.StrVar n, loc), sgn, []))
| L.StrProj (str, x) =>
let
val (str', sgn, gs) = elabStr (env, denv) str
in
case E.projectStr env {str = str', sgn = sgn, field = x} of
NONE => (strError env (UnboundStr (loc, x));
(strerror, sgnerror, []))
| SOME sgn => ((L'.StrProj (str', x), loc), sgn, gs)
end
| L.StrFun (m, dom, ranO, str) =>
let
val (dom', gs1) = elabSgn (env, denv) dom
val (env', n) = E.pushStrNamed env m dom'
val denv' = dopenConstraints (loc, env', denv) {str = m, strs = []}
val (str', actual, gs2) = elabStr (env', denv') str
val (formal, gs3) =
case ranO of
NONE => (actual, [])
| SOME ran =>
let
val (ran', gs) = elabSgn (env', denv') ran
in
subSgn env' loc actual ran';
(ran', gs)
end
in
((L'.StrFun (m, n, dom', formal, str'), loc),
(L'.SgnFun (m, n, dom', formal), loc),
enD gs1 @ gs2 @ enD gs3)
end
| L.StrApp (str1, str2) =>
let
val (str1', sgn1, gs1) = elabStr (env, denv) str1
val str2 =
case sgn1 of
(L'.SgnFun (_, _, dom, _), _) =>
let
val s = wildifyStr env (str2, dom)
in
(*Print.preface ("Wild", SourcePrint.p_str s);*)
s
end
| _ => str2
val (str2', sgn2, gs2) = elabStr (env, denv) str2
in
case #1 (hnormSgn env sgn1) of
L'.SgnError => (strerror, sgnerror, [])
| L'.SgnFun (m, n, dom, ran) =>
(subSgn env loc sgn2 dom;
case #1 (hnormSgn env ran) of
L'.SgnError => (strerror, sgnerror, [])
| L'.SgnConst sgis =>
let
(* This code handles a tricky case that led to a very nasty bug.
* An invariant about signatures of elaborated modules is that no
* identifier that could appear directly in a program is defined
* twice. We add "?" in front of identifiers where necessary to
* maintain the invariant, but the code below, to extend a functor
* body with a binding for the functor argument, wasn't written
* with the invariant in mind. Luckily for us, references to
* an identifier later within a signature work by globally
* unique index, so we just need to change the string name in the
* new declaration.
*
* ~~~ A few days later.... ~~~
* This is trickier than I thought! We might need to add
* arbitarily many question marks before the module name to
* avoid a clash, since some other code might depend on
* question-mark identifiers generated previously by this
* very code fragment. *)
fun mungeName m =
if List.exists (fn (L'.SgiStr (_, x, _, _), _) => x = m
| _ => false) sgis then
mungeName ("?" ^ m)
else
m
val m = mungeName m
in
((L'.StrApp (str1', str2'), loc),
(L'.SgnConst ((L'.SgiStr (L'.Skip, m, n, selfifyAt env {str = str2', sgn = sgn2}), loc) :: sgis), loc),
gs1 @ gs2)
end
| _ => raise Fail "Unable to hnormSgn in functor application")
| _ => (strError env (NotFunctor sgn1);
(strerror, sgnerror, []))
end
fun resolveClass env = E.resolveClass (hnormCon env) (consEq env dummy) env
fun elabFile basis basis_tm topStr topSgn top_tm env file =
let
val () = ModDb.snapshot ()
val () = mayDelay := true
val () = delayedUnifs := []
val () = delayedExhaustives := []
val d = (L.DFfiStr ("Basis", (L.SgnConst basis, ErrorMsg.dummySpan), SOME basis_tm), ErrorMsg.dummySpan)
val (basis_n, env', sgn) =
case (if !incremental then ModDb.lookup d else NONE) of
NONE =>
let
val (sgn, gs) = elabSgn (env, D.empty) (L.SgnConst basis, ErrorMsg.dummySpan)
val () = case gs of
[] => ()
| _ => (app (fn (_, env, _, c1, c2) =>
prefaces "Unresolved"
[("c1", p_con env c1),
("c2", p_con env c2)]) gs;
raise Fail "Unresolved disjointness constraints in Basis")
val (env', basis_n) = E.pushStrNamed env "Basis" sgn
in
ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm);
(basis_n, env', sgn)
end
| SOME (d' as (L'.DFfiStr (_, basis_n, sgn), _)) =>
(basis_n, E.pushStrNamedAs env "Basis" basis_n sgn, sgn)
| _ => raise Fail "Elaborate: Basis impossible"
val () = basis_r := basis_n
val (ds, env') = dopen env' {str = basis_n, strs = [], sgn = sgn}
fun discoverC r x =
case E.lookupC env' x of
E.NotBound => raise Fail ("Constructor " ^ x ^ " unbound in Basis")
| E.Rel _ => raise Fail ("Constructor " ^ x ^ " bound relatively in Basis")
| E.Named (n, (_, loc)) => r := (L'.CNamed n, loc)
val () = discoverC int "int"
val () = discoverC float "float"
val () = discoverC string "string"
val () = discoverC char "char"
val () = discoverC table "sql_table"
val d = (L.DStr ("Top", SOME (L.SgnConst topSgn, ErrorMsg.dummySpan),
SOME (if Time.< (top_tm, basis_tm) then basis_tm else top_tm),
(L.StrConst topStr, ErrorMsg.dummySpan), false), ErrorMsg.dummySpan)
val (top_n, env', topSgn, topStr) =
case (if !incremental then ModDb.lookup d else NONE) of
NONE =>
let
val (topSgn, gs) = elabSgn (env', D.empty) (L.SgnConst topSgn, ErrorMsg.dummySpan)
val () = case gs of
[] => ()
| _ => raise Fail "Unresolved disjointness constraints in top.urs"
val (topStr, topSgn', gs) = elabStr (env', D.empty) (L.StrConst topStr, ErrorMsg.dummySpan)
val () = case gs of
[] => ()
| _ => app (fn Disjoint (loc, env, denv, c1, c2) =>
(case D.prove env denv (c1, c2, loc) of
[] => ()
| _ =>
(prefaces "Unresolved constraint in top.ur"
[("loc", PD.string (ErrorMsg.spanToString loc)),
("c1", p_con env c1),
("c2", p_con env c2)];
raise Fail "Unresolved constraint in top.ur"))
| TypeClass (env, c, r, loc) =>
let
val c = normClassKey env c
in
case resolveClass env c of
SOME e => r := SOME e
| NONE => expError env (Unresolvable (loc, c))
end) gs
val () = subSgn env' ErrorMsg.dummySpan topSgn' topSgn
val (env', top_n) = E.pushStrNamed env' "Top" topSgn
in
ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm);
(top_n, env', topSgn, topStr)
end
| SOME (d' as (L'.DStr (_, top_n, topSgn, topStr), _)) =>
(top_n, E.declBinds env' d', topSgn, topStr)
| _ => raise Fail "Elaborate: Top impossible"
val () = top_r := top_n
val (ds', env') = dopen env' {str = top_n, strs = [], sgn = topSgn}
fun elabDecl' x =
(resetKunif ();
resetCunif ();
elabDecl x)
val (file, (env'', _, gs)) = ListUtil.foldlMapConcat elabDecl' (env', D.empty, []) file
fun oneSummaryRound () =
if ErrorMsg.anyErrors () then
()
else
let
val delayed = !delayedUnifs
in
delayedUnifs := [];
app (fn (loc, env, k, s1, s2) =>
unifySummaries env (loc, k, normalizeRecordSummary env s1, normalizeRecordSummary env s2))
delayed
end
val checkConstraintErrors = ref (fn () => ())
fun stopHere () = not (!unifyMore) andalso ErrorMsg.anyErrors ()
in
oneSummaryRound ();
if stopHere () then
()
else
let
fun solver (gs : constraint list) =
let
val (gs, solved) =
ListUtil.foldlMapPartial
(fn (g : constraint, solved) =>
case g of
Disjoint (loc, env, denv, c1, c2) =>
(case D.prove env denv (c1, c2, loc) of
[] => (NONE, true)
| _ => (SOME g, solved))
| TypeClass (env, c, r, loc) =>
let
fun default () = (SOME g, solved)
fun resolver r c =
let
val c = normClassKey env c
in
case resolveClass env c of
SOME e => (r := SOME e;
(NONE, true))
| NONE =>
case #1 (hnormCon env c) of
L'.CApp (f, x) =>
(case (#1 (hnormCon env f), #1 (hnormCon env x)) of
(L'.CKApp (f, _), L'.CRecord (k, xcs)) =>
(case #1 (hnormCon env f) of
L'.CModProj (top_n', [], "folder") =>
if top_n' = top_n then
let
val e = (L'.EModProj (top_n, ["Folder"], "nil"), loc)
val e = (L'.EKApp (e, k), loc)
val (folder, _) = foldr (fn ((x, c), (folder, xcs)) =>
let
val e = (L'.EModProj (top_n, ["Folder"],
"cons"), loc)
val e = (L'.EKApp (e, k), loc)
val e = (L'.ECApp (e,
(L'.CRecord (k, xcs),
loc)), loc)
val e = (L'.ECApp (e, x), loc)
val e = (L'.ECApp (e, c), loc)
val e = (L'.EApp (e, folder), loc)
in
(e, (x, c) :: xcs)
end)
(e, []) xcs
in
(r := SOME folder;
(NONE, true))
end
else
default ()
| _ => default ())
| _ => default ())
| L'.TRecord c' =>
(case #1 (hnormCon env c') of
L'.CRecord (_, xts) =>
let
val witnesses = map (fn (x, t) =>
let
val r = ref NONE
val (opt, _) = resolver r t
in
case opt of
SOME _ => NONE
| NONE =>
case !r of
NONE => NONE
| SOME e =>
SOME (x, e, t)
end) xts
in
if List.all Option.isSome witnesses then
(r := SOME (L'.ERecord (map valOf witnesses), loc);
(NONE, true))
else
(SOME g, solved)
end
| _ => (SOME g, solved))
| _ => default ()
end
in
resolver r c
end)
false gs
in
case (gs, solved) of
([], _) => ()
| (_, true) => (oneSummaryRound (); solver gs)
| _ =>
checkConstraintErrors :=
(fn () => app (fn Disjoint (loc, env, denv, c1, c2) =>
let
val c1' = ElabOps.hnormCon env c1
val c2' = ElabOps.hnormCon env c2
fun isUnif (c, _) =
case c of
L'.CUnif _ => true
| _ => false
fun maybeAttr (c, _) =
case c of
L'.CRecord ((L'.KType, _), xts) => true
| _ => false
in
ErrorMsg.errorAt loc "Couldn't prove field name disjointness";
eprefaces' [("Con 1", p_con env c1),
("Con 2", p_con env c2),
("Hnormed 1", p_con env c1'),
("Hnormed 2", p_con env c2')]
(*app (fn (loc, env, k, s1, s2) =>
eprefaces' [("s1", p_summary env (normalizeRecordSummary env s1)),
("s2", p_summary env (normalizeRecordSummary env s2))])
(!delayedUnifs);*)
end
| TypeClass (env, c, r, loc) =>
let
val c = normClassKey env c
in
case resolveClass env c of
SOME e => r := SOME e
| NONE => expError env (Unresolvable (loc, c))
end)
gs)
end
in
solver gs
end;
mayDelay := false;
if stopHere () then
()
else
(app (fn (loc, env, k, s1, s2) =>
unifySummaries env (loc, k, normalizeRecordSummary env s1, normalizeRecordSummary env s2)
handle CUnify' (env', err) => (ErrorMsg.errorAt loc "Error in final record unification";
cunifyError env' err;
case !reducedSummaries of
NONE => ()
| SOME (s1, s2) =>
(ErrorMsg.errorAt loc "Stuck unifying these records after canceling matching pieces:";
eprefaces' [("Have", s1),
("Need", s2)])))
(!delayedUnifs);
delayedUnifs := []);
if stopHere () then
()
else
if List.exists kunifsInDecl file then
case U.File.findDecl kunifsInDecl file of
NONE => ()
| SOME d => declError env'' (KunifsRemain [d])
else
();
if stopHere () then
()
else
if List.exists cunifsInDecl file then
case U.File.findDecl cunifsInDecl file of
NONE => ()
| SOME d => declError env'' (CunifsRemain [d])
else
();
if stopHere () then
()
else
app (fn all as (env, _, _, loc) =>
case exhaustive all of
NONE => ()
| SOME p => expError env (Inexhaustive (loc, p)))
(!delayedExhaustives);
if stopHere () then
()
else
!checkConstraintErrors ();
(*preface ("file", p_file env' file);*)
if !dumpTypes orelse (!dumpTypesOnError andalso ErrorMsg.anyErrors ()) then
let
open L'
open Print.PD
open Print
fun p_con env c = ElabPrint.p_con env (ElabOps.reduceCon env c)
fun dumpDecl (d, env) =
case #1 d of
DCon (x, _, k, _) => (print (box [string x,
space,
string "::",
space,
p_kind env k,
newline,
newline]);
E.declBinds env d)
| DVal (x, _, t, _) => (print (box [string x,
space,
string ":",
space,
p_con env t,
newline,
newline]);
E.declBinds env d)
| DValRec vis => (app (fn (x, _, t, _) => print (box [string x,
space,
string ":",
space,
p_con env t,
newline,
newline])) vis;
E.declBinds env d)
| DStr (x, _, _, str) => (print (box [string ("<" ^ x ^ ">"),
newline,
newline]);
dumpStr (str, env);
print (box [string ("" ^ x ^ ">"),
newline,
newline]);
E.declBinds env d)
| _ => E.declBinds env d
and dumpStr (str, env) =
case #1 str of
StrConst ds => ignore (foldl dumpDecl env ds)
| _ => ()
in
ignore (foldl dumpDecl env' file)
end
else
();
if ErrorMsg.anyErrors () then
ModDb.revert ()
else
();
(*Print.preface("File", ElabPrint.p_file env file);*)
(L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan)
:: ds
@ (L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan)
:: ds' @ file
end
handle e => (ModDb.revert ();
raise e)
end
urweb-20160213+dfsg/src/elisp/ 0000775 0000000 0000000 00000000000 12657647235 0015741 5 ustar 00root root 0000000 0000000 urweb-20160213+dfsg/src/elisp/urweb-compat.el 0000664 0000000 0000000 00000006623 12657647235 0020677 0 ustar 00root root 0000000 0000000 ;;; urweb-compat.el --- Compatibility functions for Emacs variants for urweb-mode
;; Based on sml-mode:
;; Copyright (C) 1999, 2000, 2004 Stefan Monnier
;;
;; Modified for urweb-mode:
;; Copyright (C) 2008 Adam Chlipala
;;
;; 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 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, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;;; Code:
(require 'cl)
(unless (fboundp 'set-keymap-parents)
(defun set-keymap-parents (m parents)
(if (keymapp parents) (setq parents (list parents)))
(set-keymap-parent
m
(if (cdr parents)
(reduce (lambda (m1 m2)
(let ((m (copy-keymap m1)))
(set-keymap-parent m m2) m))
parents
:from-end t)
(car parents)))))
;; for XEmacs
(when (fboundp 'temp-directory)
(defvar temporary-file-directory (temp-directory)))
(unless (fboundp 'make-temp-file)
;; Copied from Emacs-21's subr.el
(defun make-temp-file (prefix &optional dir-flag)
"Create a temporary file.
The returned file name (created by appending some random characters at the end
of PREFIX, and expanding against `temporary-file-directory' if necessary,
is guaranteed to point to a newly created empty file.
You can then use `write-region' to write new data into the file.
If DIR-FLAG is non-nil, create a new empty directory instead of a file."
(let (file)
(while (condition-case ()
(progn
(setq file
(make-temp-name
(expand-file-name prefix temporary-file-directory)))
(if dir-flag
(make-directory file)
(write-region "" nil file nil 'silent))
nil)
(file-already-exists t))
;; the file was somehow created by someone else between
;; `make-temp-name' and `write-region', let's try again.
nil)
file)))
(unless (fboundp 'regexp-opt)
(defun regexp-opt (strings &optional paren)
(let ((open (if paren "\\(" "")) (close (if paren "\\)" "")))
(concat open (mapconcat 'regexp-quote strings "\\|") close))))
;;;;
;;;; Custom
;;;;
;; doesn't exist in Emacs < 20.1
(unless (fboundp 'set-face-bold-p)
(defun set-face-bold-p (face v &optional f)
(when v (ignore-errors (make-face-bold face)))))
(unless (fboundp 'set-face-italic-p)
(defun set-face-italic-p (face v &optional f)
(when v (ignore-errors (make-face-italic face)))))
;; doesn't exist in Emacs < 20.1
(ignore-errors (require 'custom))
(unless (fboundp 'defgroup)
(defmacro defgroup (&rest rest) ()))
(unless (fboundp 'defcustom)
(defmacro defcustom (sym val str &rest rest) `(defvar ,sym ,val ,str)))
(unless (fboundp 'defface)
(defmacro defface (sym val str &rest rest)
`(defvar ,sym (make-face ',sym) ,str)))
(defvar :group ':group)
(defvar :type ':type)
(defvar :copy ':copy)
(defvar :dense ':dense)
(defvar :inherit ':inherit)
(defvar :suppress ':suppress)
(provide 'urweb-compat)
;;; urweb-compat.el ends here
urweb-20160213+dfsg/src/elisp/urweb-defs.el 0000664 0000000 0000000 00000014472 12657647235 0020336 0 ustar 00root root 0000000 0000000 ;;; urweb-defs.el --- Various definitions for urweb-mode
;; Based on sml-mode:
;; Copyright (C) 1999,2000,2003 Stefan Monnier
;;
;; Modified for urweb-mode:
;; Copyright (C) 2008 Adam Chlipala
;;
;; 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 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, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;;; Code:
(eval-when-compile (require 'cl))
(require 'urweb-util)
(defgroup urweb ()
"Editing Ur/Web code."
:group 'languages)
(defvar urweb-outline-regexp
;; `st' and `si' are to match structure and signature.
"\\|s[ti]\\|[ \t]*\\(let[ \t]+\\)?\\(fun\\|and\\)\\>"
"Regexp matching a major heading.
This actually can't work without extending `outline-minor-mode' with the
notion of \"the end of an outline\".")
;;;
;;; Internal defines
;;;
(defmap urweb-mode-map
;; smarter cursor movement
'(("\C-c\C-i" . urweb-mode-info))
"The keymap used in `urweb-mode'."
;; :inherit urweb-bindings
:group 'urweb)
(defsyntax urweb-mode-syntax-table
`((?\* . ,(if urweb-builtin-nested-comments-flag ". 23n" ". 23"))
(?\( . "()1")
(?\) . ")(4")
("._'" . "_")
(",;" . ".")
;; `!' is not really a prefix-char, oh well!
("~#!" . "'")
("%&$+-/:<=>?@`^|" . "."))
"The syntax table used in `urweb-mode'.")
(easy-menu-define urweb-mode-menu urweb-mode-map "Menu used in `urweb-mode'."
'("Ur/Web"
["Ur/Web mode help (brief)" describe-mode t]
["Ur/Web mode *info*" urweb-mode-info t]
))
;; Make's sure they appear in the menu bar when urweb-mode-map is active.
;; On the hook for XEmacs only -- see easy-menu-add in auc-menu.el.
;; (defun urweb-mode-menu-bar ()
;; "Make sure menus appear in the menu bar as well as under mouse 3."
;; (and (eq major-mode 'urweb-mode)
;; (easy-menu-add urweb-mode-menu urweb-mode-map)))
;; (add-hook 'urweb-mode-hook 'urweb-mode-menu-bar)
;;
;; regexps
;;
(defun urweb-syms-re (&rest syms)
(concat "\\<" (regexp-opt (flatten syms) t) "\\>"))
;;
(defconst urweb-module-head-syms
'("signature" "structure" "functor"))
(defconst urweb-begin-syms
'("let" "struct" "sig")
"Symbols matching the `end' symbol.")
(defconst urweb-begin-syms-re
(urweb-syms-re urweb-begin-syms)
"Symbols matching the `end' symbol.")
;; (defconst urweb-user-begin-symbols-re
;; (urweb-syms-re "let" "abstype" "local" "struct" "sig" "in" "with")
;; "Symbols matching (loosely) the `end' symbol.")
(defconst urweb-sexp-head-symbols-re
(urweb-syms-re "let" "struct" "sig" "in" "with"
"if" "then" "else" "case" "of" "fn" "fun" "val" "and"
"datatype" "type" "open" "include"
urweb-module-head-syms
"con" "map" "where" "extern" "constraint" "constraints"
"table" "sequence" "class" "cookie" "style" "task" "policy")
"Symbols starting an sexp.")
;; (defconst urweb-not-arg-start-re
;; (urweb-syms-re "in" "of" "end" "andalso")
;; "Symbols that can't be found at the head of an arg.")
;; (defconst urweb-not-arg-re
;; (urweb-syms-re "in" "of" "end" "andalso")
;; "Symbols that should not be confused with an arg.")
(defconst urweb-=-starter-syms
(list* "|" "val" "fun" "and" "datatype" "con" "type" "class"
urweb-module-head-syms)
"Symbols that can be followed by a `='.")
(defconst urweb-=-starter-re
(concat "\\S.|\\S.\\|" (urweb-syms-re (cdr urweb-=-starter-syms)))
"Symbols that can be followed by a `='.")
(defconst urweb-indent-rule
(urweb-preproc-alist
`((,urweb-module-head-syms "d=" 0)
("if" "else" 0)
(,urweb-=-starter-syms nil)
(("case" "datatype" "if" "then" "else"
"let" "open" "sig" "struct" "type" "val"
"con" "constraint" "table" "sequence" "class" "cookie"
"style" "task" "policy")))))
(defconst urweb-starters-indent-after
(urweb-syms-re "let" "in" "struct" "sig")
"Indent after these.")
(defconst urweb-delegate
(urweb-preproc-alist
`((("of" "else" "then" "with" "d=") . (not (urweb-bolp)))
("in" . t)))
"Words which might delegate indentation to their parent.")
(defcustom urweb-symbol-indent
'(("fn" . -3)
("of" . 1)
("|" . -2)
("," . -2)
(";" . -2)
;;("in" . 1)
("d=" . 2))
"Special indentation alist for some symbols.
An entry like (\"in\" . 1) indicates that a line starting with the
symbol `in' should be indented one char further to the right.
This is only used in a few specific cases, so it does not work
for all symbols and in all lines starting with the given symbol."
:group 'urweb
:type '(repeat (cons string integer)))
(defconst urweb-open-paren
(urweb-preproc-alist
`((,(list* "in" urweb-begin-syms) ,urweb-begin-syms-re "\\")))
"Symbols that should behave somewhat like opening parens.")
(defconst urweb-close-paren
`(("in" "\\")
("end" ,urweb-begin-syms-re)
("then" "\\")
("else" "\\" (urweb-bolp))
("of" "\\")
("" "")
("d=" nil))
"Symbols that should behave somewhat like close parens.")
(defconst urweb-agglomerate-re "\\"
"Regexp of compound symbols (pairs of symbols to be considered as one).")
(defconst urweb-non-nested-of-starter-re
(urweb-syms-re "datatype")
"Symbols that can introduce an `of' that shouldn't behave like a paren.")
(defconst urweb-starters-syms
(append urweb-module-head-syms
'("datatype" "fun"
"open" "type" "val" "and"
"con" "constraint" "table" "sequence" "class" "cookie"
"style" "task" "policy"))
"The starters of new expressions.")
(defconst urweb-exptrail-syms
'("if" "then" "else" "case" "of" "fn" "with" "map"))
(defconst urweb-pipeheads
'("|" "of" "fun" "fn" "and" "datatype")
"A `|' corresponds to one of these.")
(provide 'urweb-defs)
;;; urweb-defs.el ends here
urweb-20160213+dfsg/src/elisp/urweb-mode-startup.el 0000664 0000000 0000000 00000000771 12657647235 0022036 0 ustar 00root root 0000000 0000000
;;; Generated autoloads from urweb-mode.el
(add-to-list 'load-path (file-name-directory load-file-name))
(add-to-list (quote auto-mode-alist) (quote ("\\.ur\\(s\\)?\\'" . urweb-mode)))
(autoload (quote urweb-mode) "urweb-mode" "\
\\Major mode for editing Ur/Web code.
This mode runs `urweb-mode-hook' just before exiting.
\\{urweb-mode-map}
\(fn)" t nil)
;;;***
;;;### (autoloads nil nil ("urweb-compat.el" "urweb-defs.el"
;;;;;; "urweb-util.el") (18072 34664 948142))
;;;***
urweb-20160213+dfsg/src/elisp/urweb-mode.el 0000664 0000000 0000000 00000077677 12657647235 0020361 0 ustar 00root root 0000000 0000000 ;;; urweb-mode.el --- Major mode for editing (Standard) ML
;; Based on sml-mode:
;; Copyright (C) 1999,2000,2004 Stefan Monnier
;; Copyright (C) 1994-1997 Matthew J. Morley
;; Copyright (C) 1989 Lars Bo Nielsen
;;
;; Modified for urweb-mode:
;; Copyright (C) 2008 Adam Chlipala
;; Author: Lars Bo Nielsen
;; Olin Shivers
;; Fritz Knabe (?)
;; Steven Gilmore (?)
;; Matthew Morley (aka )
;; Matthias Blume (aka )
;; (Stefan Monnier) monnier@cs.yale.edu
;; Adam Chlipala
;; 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:
;;; HISTORY
;; Still under construction: History obscure, needs a biographer as
;; well as a M-x doctor. Change Log on request.
;; Hacked by Olin Shivers for comint from Lars Bo Nielsen's sml.el.
;; Hacked by Matthew Morley to incorporate Fritz Knabe's hilite and
;; font-lock patterns, some of Steven Gilmore's (reduced) easy-menus,
;; and numerous bugs and bug-fixes.
;;; DESCRIPTION
;; See accompanying info file: urweb-mode.info
;;; FOR YOUR .EMACS FILE
;; If urweb-mode.el lives in some non-standard directory, you must tell
;; emacs where to get it. This may or may not be necessary:
;; (add-to-list 'load-path "~jones/lib/emacs/")
;; Then to access the commands autoload urweb-mode with that command:
;; (load "urweb-mode-startup")
;; urweb-mode-hook is run whenever a new urweb-mode buffer is created.
;;; Code:
(eval-when-compile (require 'cl))
(require 'compile)
(require 'urweb-util)
(require 'urweb-move)
(require 'urweb-defs)
(condition-case nil (require 'skeleton) (error nil))
;;; VARIABLES CONTROLLING INDENTATION
(defcustom urweb-indent-level 4
"*Indentation of blocks in Ur/Web (see also `urweb-structure-indent')."
:group 'urweb
:type '(integer))
(defcustom urweb-indent-args urweb-indent-level
"*Indentation of args placed on a separate line."
:group 'urweb
:type '(integer))
(defcustom urweb-electric-semi-mode nil
"*If non-nil, `\;' will self insert, reindent the line, and do a newline.
If nil, just insert a `\;'. (To insert while t, do: \\[quoted-insert] \;)."
:group 'urweb
:type 'boolean)
(defcustom urweb-rightalign-and t
"If non-nil, right-align `and' with its leader.
If nil: If t:
datatype a = A datatype a = A
and b = B and b = B"
:group 'urweb
:type 'boolean)
;;; OTHER GENERIC MODE VARIABLES
(defvar urweb-mode-info "urweb-mode"
"*Where to find Info file for `urweb-mode'.
The default assumes the info file \"urweb-mode.info\" is on Emacs' info
directory path. If it is not, either put the file on the standard path
or set the variable `urweb-mode-info' to the exact location of this file
(setq urweb-mode-info \"/usr/me/lib/info/urweb-mode\")
in your .emacs file. You can always set it interactively with the
set-variable command.")
(defvar urweb-mode-hook nil
"*Run upon entering `urweb-mode'.
This is a good place to put your preferred key bindings.")
;;; CODE FOR Ur/Web-MODE
(defun urweb-mode-info ()
"Command to access the TeXinfo documentation for `urweb-mode'.
See doc for the variable `urweb-mode-info'."
(interactive)
(require 'info)
(condition-case nil
(info urweb-mode-info)
(error (progn
(describe-variable 'urweb-mode-info)
(message "Can't find it... set this variable first!")))))
;; font-lock setup
(defconst urweb-keywords-regexp
(urweb-syms-re "and" "case" "class" "con" "constraint" "constraints"
"datatype" "else" "end" "extern" "fn" "map"
"fun" "functor" "if" "include"
"of" "open" "let" "in"
"rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy"
"struct" "structure" "table" "view" "then" "type" "val" "where"
"with" "ffi"
"Name" "Type" "Unit")
"A regexp that matches any non-SQL keywords of Ur/Web.")
(defconst urweb-sql-keywords-regexp
(urweb-syms-re "SELECT" "DISTINCT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY"
"HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT"
"TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX"
"ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
"PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK"
"FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL"
"JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1"
"IF" "THEN" "ELSE" "COALESCE" "LIKE" "RANDOM")
"A regexp that matches SQL keywords.")
(defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>"
"A regexp that matches lowercase Ur/Web identifiers.")
(defconst urweb-cident-regexp "\\<[A-Z][A-Za-z0-9_']*\\>"
"A regexp that matches uppercase Ur/Web identifiers.")
;;; Font-lock settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The font lock regular expressions.
(defun urweb-in-xml ()
(save-excursion
(let (
(depth 0)
(finished nil)
(answer nil)
(bound (max 0 (- (point) 1024)))
)
(while (and (not finished)
(re-search-backward "\\(\\([-{}]\\)\\|<\\(/?xml\\)?\\)"
bound t))
(let ((xml-tag (length (or (match-string 3) "")))
(ch (match-string 2)))
(cond
((equal ch "{")
(if (> depth 0)
(decf depth)
(setq finished t)))
((equal ch "}")
(incf depth))
((= xml-tag 3)
(if (> depth 0)
(decf depth)
(progn
(setq answer t)
(setq finished t))))
((= xml-tag 4)
(incf depth))
((equal ch "-")
(if (looking-at "->")
(setq finished (= depth 0))))
((and (= depth 0)
(not (looking-at "
(let ((face (get-text-property (point) 'face)))
(funcall (if (listp face) #'member #'equal) 'font-lock-tag-face face)))
;; previous code was highlighted as tag, seems we are in xml
(progn
(setq answer t)
(setq finished t)))
((= depth 0)
;; previous thing was a tag like, but not tag
;; seems we are in usual code or comment
(setq finished t))
)))
answer)))
(defun amAttribute (face)
(if (ignore-errors (save-excursion (backward-word 2) (backward-char 1) (looking-at "<")))
nil
face))
(defconst urweb-font-lock-keywords
`(;;(urweb-font-comments-and-strings)
("\\(<\\sw+\\)\\(\\s-\\|\\sw\\|=\\|\"[^\"]*\"\\|{[^}]*}\\)*\\(/?>\\)"
(1 font-lock-tag-face)
(3 font-lock-tag-face))
("\\(\\sw+>\\)"
(1 font-lock-tag-face))
("\\([^<>{}]+\\)"
(1 (if (urweb-in-xml)
font-lock-string-face
nil)))
("\\<\\(fun\\|and\\)\\s-+\\(\\sw+\\)\\s-+[^ \t\n=]"
(1 font-lock-keyword-face)
(2 (amAttribute font-lock-function-name-face)))
("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
(1 font-lock-keyword-face)
(3 (amAttribute font-lock-type-def-face)))
("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\|policy\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
(1 font-lock-keyword-face)
(3 (amAttribute font-lock-variable-name-face)))
("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
(1 font-lock-keyword-face)
(2 (amAttribute font-lock-module-def-face)))
("\\<\\(signature\\)\\s-+\\(\\sw+\\)"
(1 font-lock-keyword-face)
(2 (amAttribute font-lock-interface-def-face)))
(,urweb-keywords-regexp . font-lock-keyword-face)
(,urweb-sql-keywords-regexp . font-lock-sql-face)
(,urweb-cident-regexp . font-lock-cvariable-face))
"Regexps matching standard Ur/Web keywords.")
(defface font-lock-type-def-face
'((t (:bold t)))
"Font Lock mode face used to highlight type definitions."
:group 'font-lock-highlighting-faces)
(defvar font-lock-type-def-face 'font-lock-type-def-face
"Face name to use for type definitions.")
(defface font-lock-module-def-face
'((t (:bold t)))
"Font Lock mode face used to highlight module definitions."
:group 'font-lock-highlighting-faces)
(defvar font-lock-module-def-face 'font-lock-module-def-face
"Face name to use for module definitions.")
(defface font-lock-interface-def-face
'((t (:bold t)))
"Font Lock mode face used to highlight interface definitions."
:group 'font-lock-highlighting-faces)
(defvar font-lock-interface-def-face 'font-lock-interface-def-face
"Face name to use for interface definitions.")
(defface font-lock-sql-face
'((t (:bold t)))
"Font Lock mode face used to highlight SQL keywords."
:group 'font-lock-highlighting-faces)
(defvar font-lock-sql-face 'font-lock-sql-face
"Face name to use for SQL keywords.")
(defface font-lock-cvariable-face
'((t (:foreground "dark blue")))
"Font Lock mode face used to highlight capitalized identifiers."
:group 'font-lock-highlighting-faces)
(defvar font-lock-cvariable-face 'font-lock-cvariable-face
"Face name to use for capitalized identifiers.")
(defface font-lock-tag-face
'((t (:bold t)))
"Font Lock mode face used to highlight XML tags."
:group 'font-lock-highlighting-faces)
(defvar font-lock-tag-face 'font-lock-tag-face
"Face name to use for XML tags.")
(defface font-lock-attr-face
'((t (:bold t)))
"Font Lock mode face used to highlight XML attributes."
:group 'font-lock-highlighting-faces)
(defvar font-lock-attr-face 'font-lock-attr-face
"Face name to use for XML attributes.")
;;
;; Code to handle nested comments and unusual string escape sequences
;;
(defsyntax urweb-syntax-prop-table
'((?\\ . ".") (?* . "."))
"Syntax table for text-properties")
;; For Emacsen that have no built-in support for nested comments
(defun urweb-get-depth-st ()
(save-excursion
(let* ((disp (if (eq (char-before) ?\)) (progn (backward-char) -1) nil))
(_ (backward-char))
(disp (if (eq (char-before) ?\() (progn (backward-char) 0) disp))
(pt (point)))
(when disp
(let* ((depth
(save-match-data
(if (re-search-backward "\\*)\\|(\\*" nil t)
(+ (or (get-char-property (point) 'comment-depth) 0)
(case (char-after) (?\( 1) (?* 0))
disp)
0)))
(depth (if (> depth 0) depth)))
(put-text-property pt (1+ pt) 'comment-depth depth)
(when depth urweb-syntax-prop-table))))))
(defconst urweb-font-lock-syntactic-keywords
`(("^\\s-*\\(\\\\\\)" (1 ',urweb-syntax-prop-table))
,@(unless urweb-builtin-nested-comments-flag
'(("(?\\(\\*\\))?" (1 (urweb-get-depth-st)))))))
(defconst urweb-font-lock-defaults
'(urweb-font-lock-keywords nil nil ((?_ . "w") (?' . "w")) nil
(font-lock-syntactic-keywords . urweb-font-lock-syntactic-keywords)))
;;;;
;;;; Imenu support
;;;;
(defvar urweb-imenu-regexp
(concat "^[ \t]*\\(let[ \t]+\\)?"
(regexp-opt (append urweb-module-head-syms
'("and" "fun" "datatype" "type")) t)
"\\>"))
(defun urweb-imenu-create-index ()
(let (alist)
(goto-char (point-max))
(while (re-search-backward urweb-imenu-regexp nil t)
(save-excursion
(let ((kind (match-string 2))
(column (progn (goto-char (match-beginning 2)) (current-column)))
(location
(progn (goto-char (match-end 0))
(urweb-forward-spaces)
(when (looking-at urweb-tyvarseq-re)
(goto-char (match-end 0)))
(point)))
(name (urweb-forward-sym)))
;; Eliminate trivial renamings.
(when (or (not (member kind '("structure" "signature")))
(progn (search-forward "=")
(urweb-forward-spaces)
(looking-at "sig\\|struct")))
(push (cons (concat (make-string (/ column 2) ?\ ) name) location)
alist)))))
alist))
;;; MORE CODE FOR URWEB-MODE
;;;###autoload (add-to-list 'load-path (file-name-directory load-file-name))
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.urs?\\'" . urweb-mode))
;;;###autoload
(defalias 'urweb-mode-derived-from
(if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode))
;;;###autoload
(define-derived-mode urweb-mode urweb-mode-derived-from "Ur/Web"
"\\Major mode for editing Ur/Web code.
This mode runs `urweb-mode-hook' just before exiting.
\\{urweb-mode-map}"
(set (make-local-variable 'font-lock-defaults) urweb-font-lock-defaults)
(set (make-local-variable 'font-lock-multiline) 'undecided)
(set (make-local-variable 'outline-regexp) urweb-outline-regexp)
(set (make-local-variable 'imenu-create-index-function)
'urweb-imenu-create-index)
(set (make-local-variable 'add-log-current-defun-function)
'urweb-current-fun-name)
;; Treat paragraph-separators in comments as paragraph-separators.
(set (make-local-variable 'paragraph-separate)
(concat "\\([ \t]*\\*)?\\)?\\(" paragraph-separate "\\)"))
(set (make-local-variable 'require-final-newline) t)
;; forward-sexp-function is an experimental variable in my hacked Emacs.
(set (make-local-variable 'forward-sexp-function) 'urweb-user-forward-sexp)
;; For XEmacs
(easy-menu-add urweb-mode-menu)
;; Compatibility. FIXME: we should use `-' in Emacs-CVS.
(unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil))
(local-set-key (kbd "C-c C-c") 'compile)
(local-set-key (kbd "C-c /") 'urweb-close-matching-tag)
(urweb-mode-variables))
(defun urweb-mode-variables ()
(set-syntax-table urweb-mode-syntax-table)
(setq local-abbrev-table urweb-mode-abbrev-table)
;; A paragraph is separated by blank lines or ^L only.
(set (make-local-variable 'indent-line-function) 'urweb-indent-line)
(set (make-local-variable 'comment-start) "(* ")
(set (make-local-variable 'comment-end) " *)")
(set (make-local-variable 'comment-nested) t)
;;(set (make-local-variable 'block-comment-start) "* ")
;;(set (make-local-variable 'block-comment-end) "")
;; (set (make-local-variable 'comment-column) 40)
(set (make-local-variable 'comment-start-skip) "(\\*+\\s-*"))
(defun urweb-funname-of-and ()
"Name of the function this `and' defines, or nil if not a function.
Point has to be right after the `and' symbol and is not preserved."
(urweb-forward-spaces)
(if (looking-at urweb-tyvarseq-re) (goto-char (match-end 0)))
(let ((sym (urweb-forward-sym)))
(urweb-forward-spaces)
(unless (or (member sym '(nil "d="))
(member (urweb-forward-sym) '("d=")))
sym)))
;;; INDENTATION !!!
(defun urweb-mark-function ()
"Synonym for `mark-paragraph' -- sorry.
If anyone has a good algorithm for this..."
(interactive)
(mark-paragraph))
(defun urweb-indent-line ()
"Indent current line of Ur/Web code."
(interactive)
(let ((savep (> (current-column) (current-indentation)))
(indent (max (or (ignore-errors (urweb-calculate-indentation)) 0) 0)))
(if savep
(save-excursion (indent-line-to indent))
(indent-line-to indent))))
(defun urweb-back-to-outer-indent ()
"Unindents to the next outer level of indentation."
(interactive)
(save-excursion
(beginning-of-line)
(skip-chars-forward "\t ")
(let ((start-column (current-column))
(indent (current-column)))
(if (> start-column 0)
(progn
(save-excursion
(while (>= indent start-column)
(if (re-search-backward "^[^\n]" nil t)
(setq indent (current-indentation))
(setq indent 0))))
(backward-delete-char-untabify (- start-column indent)))))))
(defun urweb-find-comment-indent ()
(save-excursion
(let ((depth 1))
(while (> depth 0)
(if (re-search-backward "(\\*\\|\\*)" nil t)
(cond
;; FIXME: That's just a stop-gap.
((eq (get-text-property (point) 'face) 'font-lock-string-face))
((looking-at "*)") (incf depth))
((looking-at comment-start-skip) (decf depth)))
(setq depth -1)))
(if (= depth 0)
(1+ (current-column))
nil))))
(defun urweb-empty-line ()
(save-excursion
(beginning-of-line)
(let ((start-pos (point)))
(end-of-line)
(not (re-search-backward "[^\n \t]" start-pos t)))))
(defun urweb-seek-back ()
(while (urweb-empty-line) (previous-line 1)))
(defun urweb-skip-matching-braces ()
"Skip backwards past matching brace pairs, to calculate XML indentation after quoted Ur code"
(beginning-of-line)
(let ((start-pos (point))
(depth 0))
(end-of-line)
(while (re-search-backward "[{}]" start-pos t)
(cond
((looking-at "}")
(incf depth))
((looking-at "{")
(decf depth))))
(while (and (> depth 0) (re-search-backward "[{}]" nil t)
(cond
((looking-at "}")
(incf depth))
((looking-at "{")
(decf depth)))))))
(defun urweb-new-tags ()
"Decide if the previous line of XML introduced unclosed tags"
(save-excursion
(let ((start-pos (point))
(depth 0)
(done nil))
(previous-line 1)
(urweb-seek-back)
(urweb-skip-matching-braces)
(urweb-seek-back)
(beginning-of-line)
(while (and (not done) (search-forward "<" start-pos t))
(cond
((or (looking-at " ") (looking-at "="))
nil)
((looking-at "/")
(if (re-search-forward "[^\\sw]>" start-pos t)
(when (> depth 0) (decf depth))
(setq done t)))
(t
(if (re-search-forward "[^\\sw]>" start-pos t)
(if (not (save-excursion (backward-char 2) (looking-at "/")))
(incf depth))
(setq done t)))))
(and (not done) (> depth 0)))))
(defun urweb-tag-matching-indent ()
"Seek back to a matching opener tag and get its line's indent"
(save-excursion
(end-of-line)
(search-backward "" nil t)
(urweb-tag-matcher)
(beginning-of-line)
(current-indentation)))
(defun urweb-close-matching-tag ()
"Insert a closing XML tag for whatever tag is open at the point."
(interactive)
(assert (urweb-in-xml))
(save-excursion
(urweb-tag-matcher)
(re-search-forward "<\\([^ ={/>]+\\)" nil t))
(let ((tag (match-string-no-properties 1)))
(insert "" tag ">")))
(defconst urweb-sql-main-starters
'("SQL" "SELECT" "INSERT" "UPDATE" "DELETE" "FROM" "SELECT1" "WHERE"))
(defconst urweb-sql-starters
(append urweb-sql-main-starters
'("^\\s-+FROM" "WHERE" "GROUP" "ORDER" "HAVING" "LIMIT" "OFFSET"
"VALUES" "SET")))
(defconst urweb-sql-main-starters-re
(urweb-syms-re urweb-sql-main-starters))
(defconst urweb-sql-starters-re
(urweb-syms-re urweb-sql-starters))
(defconst urweb-sql-main-starters-paren-re
(concat "(" urweb-sql-main-starters-re))
(defun urweb-in-sql ()
"Check if the point is in a block of SQL syntax."
(save-excursion
(let ((start-pos (point))
(depth 0)
done
(good t))
(when (re-search-backward urweb-sql-main-starters-paren-re nil t)
(forward-char)
(while (and (not done) (re-search-forward "[()]" start-pos t))
(save-excursion
(backward-char)
(cond
((looking-at ")")
(cond
((= depth 0) (setq done t) (setq good nil))
(t (decf depth))))
((looking-at "(")
(incf depth)))))
good))))
(defun urweb-sql-depth ()
"Check if the point is in a block of SQL syntax.
Returns the paren nesting depth if so, and nil otherwise."
(save-excursion
(let ((depth 0)
done)
(while (and (not done)
(re-search-backward "[()]" nil t))
(cond
((looking-at ")")
(decf depth))
((looking-at "(")
(if (looking-at urweb-sql-main-starters-paren-re)
(setq done t)
(incf depth)))))
(max 0 depth))))
(defun urweb-calculate-indentation ()
(save-excursion
(beginning-of-line) (skip-chars-forward "\t ")
(urweb-with-ist
;; Indentation for comments alone on a line, matches the
;; proper indentation of the next line.
(when (looking-at "(\\*") (urweb-forward-spaces))
(let (data
(sym (save-excursion (urweb-forward-sym))))
(or
;; Allow the user to override the indentation.
(when (looking-at (concat ".*" (regexp-quote comment-start)
"[ \t]*fixindent[ \t]*"
(regexp-quote comment-end)))
(current-indentation))
;; Continued comment.
(and (looking-at "\\*") (urweb-find-comment-indent))
(and (urweb-in-xml)
(let ((prev-indent (save-excursion
(previous-line 1)
(urweb-seek-back)
(urweb-skip-matching-braces)
(urweb-seek-back)
(current-indentation))))
(cond
((looking-at "")
(urweb-tag-matching-indent))
((urweb-new-tags)
(+ prev-indent 2))
(t
prev-indent))))
;; Continued string ? (Added 890113 lbn)
(and (looking-at "\\\\")
(save-excursion
(if (save-excursion (previous-line 1)
(beginning-of-line)
(looking-at "[\t ]*\\\\"))
(progn (previous-line 1) (current-indentation))
(if (re-search-backward "[^\\\\]\"" nil t)
(1+ (current-column))
0))))
;; Closing parens. Could be handled below with `urweb-indent-relative'?
(and (looking-at "\\s)")
(save-excursion
(skip-syntax-forward ")")
(backward-sexp 1)
(if (urweb-dangling-sym)
(urweb-indent-default 'noindent)
(current-column))))
(and (or (looking-at "FROM") (looking-at urweb-sql-starters-re))
(save-excursion
(and (re-search-backward urweb-sql-starters-re nil t)
(if (looking-at urweb-sql-main-starters-re)
(current-column)
(current-indentation)))))
(and (urweb-in-sql)
(setq data (urweb-sql-depth))
(save-excursion
(re-search-backward urweb-sql-starters-re nil t)
(+ (current-column) 2 (* 2 data))))
(and (setq data (assoc sym urweb-close-paren))
(urweb-indent-relative sym data))
(and (member sym urweb-starters-syms)
(urweb-indent-starter sym))
(and (string= sym "|") (urweb-indent-pipe))
(urweb-indent-arg)
(urweb-indent-default))))))
(defsubst urweb-bolp ()
(save-excursion (skip-chars-backward " \t|") (bolp)))
(defun urweb-indent-starter (orig-sym)
"Return the indentation to use for a symbol in `urweb-starters-syms'.
Point should be just before the symbol ORIG-SYM and is not preserved."
(let ((sym (unless (save-excursion (urweb-backward-arg))
(urweb-backward-spaces)
(urweb-backward-sym))))
(if (member sym '(";" "d=")) (setq sym nil))
(if sym (urweb-get-sym-indent sym)
;; FIXME: this can take a *long* time !!
(setq sym (urweb-find-matching-starter urweb-starters-syms))
;; Don't align with `and' because it might be specially indented.
(if (and (or (equal orig-sym "and") (not (equal sym "and")))
(urweb-bolp))
(+ (current-column)
(if (and urweb-rightalign-and (equal orig-sym "and"))
(- (length sym) 3) 0))
(urweb-indent-starter orig-sym)))))
(defun urweb-indent-relative (sym data)
(save-excursion
(urweb-forward-sym) (urweb-backward-sexp nil)
(unless (second data) (urweb-backward-spaces) (urweb-backward-sym))
(+ (or (cdr (assoc sym urweb-symbol-indent)) 0)
(urweb-delegated-indent))))
(defun urweb-indent-pipe ()
(let ((sym (urweb-find-matching-starter urweb-pipeheads
(urweb-op-prec "|" 'back))))
(when sym
(if (string= sym "|")
(if (urweb-bolp) (current-column) (urweb-indent-pipe))
(let ((pipe-indent (or (cdr (assoc "|" urweb-symbol-indent)) -2)))
(when (or (member sym '("datatype"))
(and (equal sym "and")
(save-excursion
(forward-word 1)
(not (urweb-funname-of-and)))))
(re-search-forward "="))
(urweb-forward-sym)
(urweb-forward-spaces)
(+ pipe-indent (current-column)))))))
(defun urweb-find-forward (re)
(urweb-forward-spaces)
(while (and (not (looking-at re))
(progn
(or (ignore-errors (forward-sexp 1) t) (forward-char 1))
(urweb-forward-spaces)
(not (looking-at re))))))
(defun urweb-indent-arg ()
(and (save-excursion (ignore-errors (urweb-forward-arg)))
;;(not (looking-at urweb-not-arg-re))
;; looks like a function or an argument
(urweb-move-if (urweb-backward-arg))
;; an argument
(if (save-excursion (not (urweb-backward-arg)))
;; a first argument
(+ (current-column) urweb-indent-args)
;; not a first arg
(while (and (/= (current-column) (current-indentation))
(urweb-move-if (urweb-backward-arg))))
(unless (save-excursion (urweb-backward-arg))
;; all earlier args are on the same line
(urweb-forward-arg) (urweb-forward-spaces))
(current-column))))
(defun urweb-get-indent (data sym)
(let (d)
(cond
((not (listp data)) data)
((setq d (member sym data)) (cadr d))
((and (consp data) (not (stringp (car data)))) (car data))
(t urweb-indent-level))))
(defun urweb-dangling-sym ()
"Non-nil if the symbol after point is dangling.
The symbol can be an Ur/Web symbol or an open-paren. \"Dangling\" means that
it is not on its own line but is the last element on that line."
(save-excursion
(and (not (urweb-bolp))
(< (urweb-point-after (end-of-line))
(urweb-point-after (or (urweb-forward-sym) (skip-syntax-forward "("))
(urweb-forward-spaces))))))
(defun urweb-delegated-indent ()
(if (urweb-dangling-sym)
(urweb-indent-default 'noindent)
(urweb-move-if (backward-word 1)
(looking-at urweb-agglomerate-re))
(current-column)))
(defun urweb-get-sym-indent (sym &optional style)
"Find the indentation for the SYM we're `looking-at'.
If indentation is delegated, point will move to the start of the parent.
Optional argument STYLE is currently ignored."
;;(assert (equal sym (save-excursion (urweb-forward-sym))))
(save-excursion
(let ((delegate (and (not (equal sym "end")) (assoc sym urweb-close-paren)))
(head-sym sym))
(when (and delegate (not (eval (third delegate))))
;;(urweb-find-match-backward sym delegate)
(urweb-forward-sym) (urweb-backward-sexp nil)
(setq head-sym
(if (second delegate)
(save-excursion (urweb-forward-sym))
(urweb-backward-spaces) (urweb-backward-sym))))
(let ((idata (assoc head-sym urweb-indent-rule)))
(when idata
;;(if (or style (not delegate))
;; normal indentation
(let ((indent (urweb-get-indent (cdr idata) sym)))
(when indent (+ (urweb-delegated-indent) indent)))
;; delgate indentation to the parent
;;(urweb-forward-sym) (urweb-backward-sexp nil)
;;(let* ((parent-sym (save-excursion (urweb-forward-sym)))
;; (parent-indent (cdr (assoc parent-sym urweb-indent-starters))))
;; check the special rules
;;(+ (urweb-delegated-indent)
;; (or (urweb-get-indent (cdr indent-data) 1 'strict)
;; (urweb-get-indent (cdr parent-indent) 1 'strict)
;; (urweb-get-indent (cdr indent-data) 0)
;; (urweb-get-indent (cdr parent-indent) 0))))))))
)))))
(defun urweb-indent-default (&optional noindent)
(condition-case nil
(progn
(let* ((sym-after (save-excursion (urweb-forward-sym)))
(_ (urweb-backward-spaces))
(sym-before (urweb-backward-sym))
(sym-indent (and sym-before (urweb-get-sym-indent sym-before)))
(indent-after (or (cdr (assoc sym-after urweb-symbol-indent)) 0)))
(when (equal sym-before "end")
;; I don't understand what's really happening here, but when
;; it's `end' clearly, we need to do something special.
(forward-word 1)
(setq sym-before nil sym-indent nil))
(cond
(sym-indent
;; the previous sym is an indentation introducer: follow the rule
(if noindent
;;(current-column)
sym-indent
(+ sym-indent indent-after)))
;; If we're just after a hanging open paren.
((and (eq (char-syntax (preceding-char)) ?\()
(save-excursion (backward-char) (urweb-dangling-sym)))
(backward-char)
(urweb-indent-default))
(t
;; default-default
(let* ((prec-after (urweb-op-prec sym-after 'back))
(prec (or (urweb-op-prec sym-before 'back) prec-after 100)))
;; go back until you hit a symbol that has a lower prec than the
;; "current one", or until you backed over a sym that has the same prec
;; but is at the beginning of a line.
(while (and (not (urweb-bolp))
(while (urweb-move-if (urweb-backward-sexp (1- prec))))
(not (urweb-bolp)))
(while (urweb-move-if (urweb-backward-sexp prec))))
(if noindent
;; the `noindent' case does back over an introductory symbol
;; such as `fun', ...
(progn
(urweb-move-if
(urweb-backward-spaces)
(member (urweb-backward-sym) urweb-starters-syms))
(current-column))
;; Use `indent-after' for cases such as when , or ; should be
;; outdented so that their following terms are aligned.
(+ (if (progn
(if (equal sym-after ";")
(urweb-move-if
(urweb-backward-spaces)
(member (urweb-backward-sym) urweb-starters-syms)))
(and sym-after (not (looking-at sym-after))))
indent-after 0)
(current-column))))))))
(error 0)))
;; maybe `|' should be set to word-syntax in our temp syntax table ?
(defun urweb-current-indentation ()
(save-excursion
(beginning-of-line)
(skip-chars-forward " \t|")
(current-column)))
(defun urweb-find-matching-starter (syms &optional prec)
(let (sym)
(ignore-errors
(while
(progn (urweb-backward-sexp prec)
(setq sym (save-excursion (urweb-forward-sym)))
(not (or (member sym syms) (bobp)))))
(if (member sym syms) sym))))
(defun urweb-skip-siblings ()
(while (and (not (bobp)) (urweb-backward-arg))
(urweb-find-matching-starter urweb-starters-syms)))
(defun urweb-beginning-of-defun ()
(let ((sym (urweb-find-matching-starter urweb-starters-syms)))
(if (member sym '("fun" "and" "functor" "signature" "structure"
"datatype"))
(save-excursion (urweb-forward-sym) (urweb-forward-spaces)
(urweb-forward-sym))
;; We're inside a "non function declaration": let's skip all other
;; declarations that we find at the same level and try again.
(urweb-skip-siblings)
;; Obviously, let's not try again if we're at bobp.
(unless (bobp) (urweb-beginning-of-defun)))))
(defcustom urweb-max-name-components 3
"Maximum number of components to use for the current function name."
:group 'urweb
:type 'integer)
(defun urweb-current-fun-name ()
(save-excursion
(let ((count urweb-max-name-components)
fullname name)
(end-of-line)
(while (and (> count 0)
(setq name (urweb-beginning-of-defun)))
(decf count)
(setq fullname (if fullname (concat name "." fullname) name))
;; Skip all other declarations that we find at the same level.
(urweb-skip-siblings))
fullname)))
(provide 'urweb-mode)
;;; urweb-mode.el ends here
urweb-20160213+dfsg/src/elisp/urweb-move.el 0000664 0000000 0000000 00000031446 12657647235 0020363 0 ustar 00root root 0000000 0000000 ;;; urweb-move.el --- Buffer navigation functions for urweb-mode
;; Based on urweb-mode:
;; Copyright (C) 1999, 2000, 2004 Stefan Monnier
;;
;; Modified for urweb-mode:
;; Copyright (C) 2008 Adam Chlipala
;;
;; 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 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, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;;; Code:
(eval-when-compile (require 'cl))
(require 'urweb-util)
(require 'urweb-defs)
(defsyntax urweb-internal-syntax-table
'((?_ . "w")
(?' . "w")
(?. . "w"))
"Syntax table used for internal urweb-mode operation."
:copy urweb-mode-syntax-table)
;;;
;;; various macros
;;;
(defmacro urweb-with-ist (&rest r)
(let ((ost-sym (make-symbol "oldtable")))
`(let ((,ost-sym (syntax-table))
(case-fold-search nil)
(parse-sexp-lookup-properties t)
(parse-sexp-ignore-comments t))
(unwind-protect
(progn (set-syntax-table urweb-internal-syntax-table) . ,r)
(set-syntax-table ,ost-sym)))))
(def-edebug-spec urweb-with-ist t)
(defmacro urweb-move-if (&rest body)
(let ((pt-sym (make-symbol "point"))
(res-sym (make-symbol "result")))
`(let ((,pt-sym (point))
(,res-sym ,(cons 'progn body)))
(unless ,res-sym (goto-char ,pt-sym))
,res-sym)))
(def-edebug-spec urweb-move-if t)
(defmacro urweb-point-after (&rest body)
`(save-excursion
,@body
(point)))
(def-edebug-spec urweb-point-after t)
;;
(defvar urweb-op-prec
(urweb-preproc-alist
'((("UNION" "INTERSECT" "EXCEPT") . 0)
(("AND" "OR") . 1)
((">=" "<>" "<=" "=") . 4)
(("+" "-" "^") . 6)
(("*" "%") . 7)
(("NOT") 9)))
"Alist of Ur/Web infix operators and their precedence.")
(defconst urweb-syntax-prec
(urweb-preproc-alist
`(("," . 20)
(("=>" "d=" "=of") . (65 . 40))
("|" . (47 . 30))
(("case" "of" "fn") . 45)
(("if" "then" "else" ) . 50)
(";" . 53)
(("<-") . 55)
("||" . 70)
("&&" . 80)
((":" ":>") . 90)
("->" . 95)
("with" . 100)
(,(cons "end" urweb-begin-syms) . 10000)))
"Alist of pseudo-precedence of syntactic elements.")
(defun urweb-op-prec (op dir)
"Return the precedence of OP or nil if it's not an infix.
DIR should be set to BACK if you want to precedence w.r.t the left side
and to FORW for the precedence w.r.t the right side.
This assumes that we are `looking-at' the OP."
(when op
(let ((sprec (cdr (assoc op urweb-syntax-prec))))
(cond
((consp sprec) (if (eq dir 'back) (car sprec) (cdr sprec)))
(sprec sprec)
(t
(let ((prec (cdr (assoc op urweb-op-prec))))
(when prec (+ prec 100))))))))
;;
(defun urweb-forward-spaces () (forward-comment 100000))
(defun urweb-backward-spaces () (forward-comment -100000))
;;
;; moving forward around matching symbols
;;
(defun urweb-looking-back-at (re)
(save-excursion
(when (= 0 (skip-syntax-backward "w_")) (backward-char))
(looking-at re)))
(defun urweb-find-match-forward (this match)
"Only works for word matches."
(let ((level 1)
(forward-sexp-function nil)
(either (concat this "\\|" match)))
(while (> level 0)
(forward-sexp 1)
(while (not (or (eobp) (urweb-looking-back-at either)))
(condition-case () (forward-sexp 1) (error (forward-char 1))))
(setq level
(cond
((and (eobp) (> level 1)) (error "Unbalanced"))
((urweb-looking-back-at this) (1+ level))
((urweb-looking-back-at match) (1- level))
(t (error "Unbalanced")))))
t))
(defun urweb-find-match-backward (this match)
(let ((level 1)
(forward-sexp-function nil)
(either (concat this "\\|" match)))
(while (> level 0)
(backward-sexp 1)
(while (not (or (bobp) (looking-at either)))
(condition-case () (backward-sexp 1) (error (backward-char 1))))
(setq level
(cond
((and (bobp) (> level 1)) (error "Unbalanced"))
((looking-at this) (1+ level))
((looking-at match) (1- level))
(t (error "Unbalanced")))))
t))
;;;
;;; read a symbol, including the special "op " case
;;;
(defmacro urweb-move-read (&rest body)
(let ((pt-sym (make-symbol "point")))
`(let ((,pt-sym (point)))
,@body
(when (/= (point) ,pt-sym)
(buffer-substring-no-properties (point) ,pt-sym)))))
(def-edebug-spec urweb-move-read t)
(defun urweb-poly-equal-p ()
(< (urweb-point-after (re-search-backward urweb-=-starter-re nil 'move))
(urweb-point-after (re-search-backward "=" nil 'move))))
(defun urweb-nested-of-p ()
(< (urweb-point-after
(re-search-backward urweb-non-nested-of-starter-re nil 'move))
(urweb-point-after (re-search-backward "\\" nil 'move))))
(defun urweb-forward-sym-1 ()
(or (/= 0 (skip-syntax-forward "'w_"))
(/= 0 (skip-syntax-forward ".'"))))
(defun urweb-forward-sym ()
(interactive)
(let ((sym (urweb-move-read (urweb-forward-sym-1))))
(cond
((equal "op" sym)
(urweb-forward-spaces)
(concat "op " (or (urweb-move-read (urweb-forward-sym-1)) "")))
((equal sym "=")
(save-excursion
(urweb-backward-sym-1)
(if (urweb-poly-equal-p) "=" "d=")))
((equal sym "of")
(save-excursion
(urweb-backward-sym-1)
(if (urweb-nested-of-p) "of" "=of")))
;; ((equal sym "datatype")
;; (save-excursion
;; (urweb-backward-sym-1)
;; (urweb-backward-spaces)
;; (if (eq (preceding-char) ?=) "=datatype" sym)))
(t sym))))
(defun urweb-backward-sym-1 ()
(or (/= 0 (skip-syntax-backward ".'"))
(/= 0 (skip-syntax-backward "'w_"))))
(defun urweb-backward-sym ()
(interactive)
(let ((sym (urweb-move-read (urweb-backward-sym-1))))
(let ((result
(when sym
;; FIXME: what should we do if `sym' = "op" ?
(let ((point (point)))
(urweb-backward-spaces)
(if (equal "op" (urweb-move-read (urweb-backward-sym-1)))
(concat "op " sym)
(goto-char point)
(cond
((string= sym "=") (if (urweb-poly-equal-p) "=" "d="))
((string= sym "of") (if (urweb-nested-of-p) "of" "=of"))
;; ((string= sym "datatype")
;; (save-excursion (urweb-backward-spaces)
;; (if (eq (preceding-char) ?=) "=datatype" sym)))
(t sym)))))))
(if (looking-at ">")
(substring result 1 nil)
result))))
;; (if (save-excursion (backward-char 5) (looking-at " "))
;; (progn
;; (backward-char 5)
;; (urweb-tag-matcher)
;; (backward-char)
;; (urweb-backward-sym))
;; result))))
(defun urweb-tag-matcher ()
"Seek back to a matching opener tag"
(let ((depth 0)
(done nil))
(while (and (not done) (search-backward ">" nil t))
(cond
((save-excursion (backward-char 1) (looking-at " "))
nil)
((save-excursion (backward-char 1) (looking-at "/"))
(when (not (re-search-backward "<[^ =]" nil t))
(setq done t)))
(t
(if (re-search-backward "<[^ =]" nil t)
(if (looking-at "")
(incf depth)
(if (= depth 0)
(setq done t)
(decf depth)))
(setq done t)))))))
(defun urweb-backward-sexp (prec)
"Move one sexp backward if possible, or one char else.
Returns t if the move indeed moved through one sexp and nil if not.
PREC is the precedence currently looked for."
(let ((result (let ((parse-sexp-lookup-properties t)
(parse-sexp-ignore-comments t))
(urweb-backward-spaces)
(let* ((op (urweb-backward-sym))
(op-prec (urweb-op-prec op 'back))
match)
(cond
((not op)
(let ((point (point)))
(ignore-errors (let ((forward-sexp-function nil)) (backward-sexp 1)))
(if (/= point (point)) t (ignore-errors (backward-char 1)) nil)))
;; stop as soon as precedence is smaller than `prec'
((and prec op-prec (>= prec op-prec)) nil)
;; special rules for nested constructs like if..then..else
((and (or (not prec) (and prec op-prec))
(setq match (second (assoc op urweb-close-paren))))
(urweb-find-match-backward (concat "\\<" op "\\>") match))
;; don't back over open-parens
((assoc op urweb-open-paren) nil)
;; infix ops precedence
((and prec op-prec) (< prec op-prec))
;; [ prec = nil ] a new operator, let's skip the sexps until the next
(op-prec (while (urweb-move-if (urweb-backward-sexp op-prec))) t)
;; special symbols indicating we're getting out of a nesting level
((string-match urweb-sexp-head-symbols-re op) nil)
;; if the op was not alphanum, then we still have to do the backward-sexp
;; this reproduces the usual backward-sexp, but it might be bogus
;; in this case since !@$% is a perfectly fine symbol
(t t))))))
(if (save-excursion (backward-char 5) (looking-at ""))
(progn
(backward-char 5)
(urweb-tag-matcher)
(backward-char)
(urweb-backward-sexp prec))
result)))
(defun urweb-forward-sexp (prec)
"Moves one sexp forward if possible, or one char else.
Returns T if the move indeed moved through one sexp and NIL if not."
(let ((parse-sexp-lookup-properties t)
(parse-sexp-ignore-comments t))
(urweb-forward-spaces)
(let* ((op (urweb-forward-sym))
(op-prec (urweb-op-prec op 'forw))
match)
(cond
((not op)
(let ((point (point)))
(ignore-errors (let ((forward-sexp-function nil)) (forward-sexp 1)))
(if (/= point (point)) t (forward-char 1) nil)))
;; stop as soon as precedence is smaller than `prec'
((and prec op-prec (>= prec op-prec)) nil)
;; special rules for nested constructs like if..then..else
((and (or (not prec) (and prec op-prec))
(setq match (cdr (assoc op urweb-open-paren))))
(urweb-find-match-forward (first match) (second match)))
;; don't forw over close-parens
((assoc op urweb-close-paren) nil)
;; infix ops precedence
((and prec op-prec) (< prec op-prec))
;; [ prec = nil ] a new operator, let's skip the sexps until the next
(op-prec (while (urweb-move-if (urweb-forward-sexp op-prec))) t)
;; special symbols indicating we're getting out of a nesting level
((string-match urweb-sexp-head-symbols-re op) nil)
;; if the op was not alphanum, then we still have to do the backward-sexp
;; this reproduces the usual backward-sexp, but it might be bogus
;; in this case since !@$% is a perfectly fine symbol
(t t))))) ;(or (string-match "\\sw" op) (urweb-backward-sexp prec))
(defun urweb-in-word-p ()
(and (eq ?w (char-syntax (or (char-before) ? )))
(eq ?w (char-syntax (or (char-after) ? )))))
(defun urweb-user-backward-sexp (&optional count)
"Like `backward-sexp' but tailored to the Ur/Web syntax."
(interactive "p")
(unless count (setq count 1))
(urweb-with-ist
(let ((point (point)))
(if (< count 0) (urweb-user-forward-sexp (- count))
(when (urweb-in-word-p) (forward-word 1))
(dotimes (i count)
(unless (urweb-backward-sexp nil)
(goto-char point)
(error "Containing expression ends prematurely")))))))
(defun urweb-user-forward-sexp (&optional count)
"Like `forward-sexp' but tailored to the Ur/Web syntax."
(interactive "p")
(unless count (setq count 1))
(urweb-with-ist
(let ((point (point)))
(if (< count 0) (urweb-user-backward-sexp (- count))
(when (urweb-in-word-p) (backward-word 1))
(dotimes (i count)
(unless (urweb-forward-sexp nil)
(goto-char point)
(error "Containing expression ends prematurely")))))))
;;(defun urweb-forward-thing ()
;; (if (= ?w (char-syntax (char-after))) (forward-word 1) (forward-char 1)))
(defun urweb-backward-arg () (interactive) (urweb-backward-sexp 1000))
(defun urweb-forward-arg () (interactive) (urweb-forward-sexp 1000))
(provide 'urweb-move)
;;; urweb-move.el ends here
urweb-20160213+dfsg/src/elisp/urweb-util.el 0000664 0000000 0000000 00000007036 12657647235 0020370 0 ustar 00root root 0000000 0000000 ;;; urweb-util.el --- Utility functions for urweb-mode
;; Based on sml-mode:
;; Copyright (C) 1999-2000 Stefan Monnier
;;
;; Modified for urweb-mode:
;; Copyright (C) 2008 Adam Chlipala
;;
;; 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 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, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;;; Code:
(require 'cl) ;for `reduce'
(require 'urweb-compat)
;;
(defun flatten (ls &optional acc)
(if (null ls) acc
(let ((rest (flatten (cdr ls) acc))
(head (car ls)))
(if (listp head)
(flatten head rest)
(cons head rest)))))
(defun urweb-preproc-alist (al)
"Expand an alist AL where keys can be lists of keys into a normal one."
(reduce (lambda (x al)
(let ((k (car x))
(v (cdr x)))
(if (consp k)
(append (mapcar (lambda (y) (cons y v)) k) al)
(cons x al))))
al
:initial-value nil
:from-end t))
;;;
;;; defmap
;;;
(defun custom-create-map (m bs args)
(let (inherit dense suppress)
(while args
(let ((key (first args))
(val (second args)))
(cond
((eq key :dense) (setq dense val))
((eq key :inherit) (setq inherit val))
((eq key :group) )
;;((eq key :suppress) (setq suppress val))
(t (message "Uknown argument %s in defmap" key))))
(setq args (cddr args)))
(unless (keymapp m)
(setq bs (append m bs))
(setq m (if dense (make-keymap) (make-sparse-keymap))))
(dolist (b bs)
(let ((keys (car b))
(binding (cdr b)))
(dolist (key (if (consp keys) keys (list keys)))
(cond
((symbolp key)
(substitute-key-definition key binding m global-map))
((null binding)
(unless (keymapp (lookup-key m key)) (define-key m key binding)))
((let ((o (lookup-key m key)))
(or (null o) (numberp o) (eq o 'undefined)))
(define-key m key binding))))))
(cond
((keymapp inherit) (set-keymap-parent m inherit))
((consp inherit) (set-keymap-parents m inherit)))
m))
(defmacro defmap (m bs doc &rest args)
`(defconst ,m
(custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
,doc))
;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun custom-create-syntax (css args)
(let ((st (make-syntax-table (cadr (memq :copy args)))))
(dolist (cs css)
(let ((char (car cs))
(syntax (cdr cs)))
(if (sequencep char)
(mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
(modify-syntax-entry char syntax st))))
st))
(defmacro defsyntax (st css doc &rest args)
`(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) ,doc))
;;;;
;;;; Compatibility info
;;;;
(defvar urweb-builtin-nested-comments-flag
(ignore-errors
(not (equal (let ((st (make-syntax-table)))
(modify-syntax-entry ?\* ". 23n" st) st)
(let ((st (make-syntax-table)))
(modify-syntax-entry ?\* ". 23" st) st))))
"Non-nil means this Emacs understands the `n' in syntax entries.")
(provide 'urweb-util)
;;; urweb-util.el ends here
urweb-20160213+dfsg/src/errormsg.sig 0000664 0000000 0000000 00000004261 12657647235 0017174 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 ERROR_MSG = sig
type pos = {line : int,
char : int}
type span = {file : string,
first : pos,
last : pos}
type 'a located = 'a * span
val posToString : pos -> string
val spanToString : span -> string
val dummyPos : pos
val dummySpan : span
val resetPositioning : string -> unit
val newline : int -> unit
val lastLineStart : unit -> int
val posOf : int -> pos
val spanOf : int * int -> span
val resetErrors : unit -> unit
val anyErrors : unit -> bool
val error : string -> unit
val errorAt : span -> string -> unit
val errorAt' : int * int -> string -> unit
end
urweb-20160213+dfsg/src/errormsg.sml 0000664 0000000 0000000 00000007311 12657647235 0017204 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 ErrorMsg :> ERROR_MSG = struct
type pos = {line : int,
char : int}
type span = {file : string,
first : pos,
last : pos}
type 'a located = 'a * span
fun posToString {line, char} =
String.concat [Int.toString line, ":", Int.toString char]
fun spanToString {file, first, last} =
String.concat [file, ":", posToString first, "-", posToString last]
val dummyPos = {line = 0,
char = 0}
val dummySpan = {file = "",
first = dummyPos,
last = dummyPos}
val file = ref ""
val numLines = ref 1
val lines : int list ref = ref []
fun resetPositioning fname = (file := fname;
numLines := 1;
lines := [])
fun newline pos = (numLines := !numLines + 1;
lines := pos :: !lines)
fun lastLineStart () =
case !lines of
[] => 0
| n :: _ => n+1
fun posOf n =
let
fun search lineNum lines =
case lines of
[] => {line = 1,
char = n}
| bound :: rest =>
if n > bound then
{line = lineNum,
char = n - bound - 1}
else
search (lineNum - 1) rest
in
search (!numLines) (!lines)
end
fun spanOf (pos1, pos2) = {file = !file,
first = posOf pos1,
last = posOf pos2}
val errors = ref false
fun resetErrors () = errors := false
fun anyErrors () = !errors
fun error s = (TextIO.output (TextIO.stdErr, s);
TextIO.output1 (TextIO.stdErr, #"\n");
errors := true)
fun errorAt (span : span) s = (TextIO.output (TextIO.stdErr, #file span);
TextIO.output (TextIO.stdErr, ":");
TextIO.output (TextIO.stdErr, posToString (#first span));
TextIO.output (TextIO.stdErr, ": (to ");
TextIO.output (TextIO.stdErr, posToString (#last span));
TextIO.output (TextIO.stdErr, ") ");
error s)
fun errorAt' span s = errorAt (spanOf span) s
end
urweb-20160213+dfsg/src/especialize.sig 0000664 0000000 0000000 00000003174 12657647235 0017633 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 ESPECIALIZE = sig
val specialize : Core.file -> Core.file
val functionInside : IntBinarySet.set -> Core.con -> bool
end
urweb-20160213+dfsg/src/especialize.sml 0000664 0000000 0000000 00000107173 12657647235 0017650 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2013, 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 ESpecialize :> ESPECIALIZE = struct
open Core
structure E = CoreEnv
structure U = CoreUtil
type skey = exp
structure K = struct
type ord_key = con list * exp list
fun compare ((cs1, es1), (cs2, es2)) = Order.join (Order.joinL U.Con.compare (cs1, cs2),
fn () => Order.joinL U.Exp.compare (es1, es2))
end
structure KM = BinaryMapFn(K)
structure IM = IntBinaryMap
structure IS = IntBinarySet
val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs,
con = fn (_, _, xs) => xs,
exp = fn (bound, e, xs) =>
case e of
ERel x =>
if x >= bound then
IS.add (xs, x - bound)
else
xs
| _ => xs,
bind = fn (bound, b) =>
case b of
U.Exp.RelE _ => bound + 1
| _ => bound}
0 IS.empty
fun isPolyT (t, _) =
case t of
TFun (_, ran) => isPolyT ran
| TCFun _ => true
| TKFun _ => true
| _ => false
fun isPoly (d, _) =
case d of
DVal (_, _, t, _, _) => isPolyT t
| DValRec vis => List.exists (isPolyT o #3) vis
| _ => false
fun positionOf (v : int, ls) =
let
fun pof (pos, ls) =
case ls of
[] => raise Fail "Defunc.positionOf"
| v' :: ls' =>
if v = v' then
pos
else
pof (pos + 1, ls')
in
pof (0, ls)
end
fun squish fvs =
U.Exp.mapB {kind = fn _ => fn k => k,
con = fn _ => fn c => c,
exp = fn bound => fn e =>
case e of
ERel x =>
if x >= bound then
ERel (positionOf (x - bound, fvs) + bound)
else
e
| _ => e,
bind = fn (bound, b) =>
case b of
U.Exp.RelE _ => bound + 1
| _ => bound}
0
type func = {
name : string,
args : int KM.map,
body : exp,
typ : con,
tag : string,
constArgs : int (* What length prefix of the arguments never vary across recursive calls? *)
}
type state = {
maxName : int,
funcs : func IM.map,
decls : (string * int * con * exp * string) list,
specialized : IS.set
}
fun default (_, x, st) = (x, st)
fun functionInside known =
U.Con.exists {kind = fn _ => false,
con = fn TFun _ => true
| TCFun _ => true
| CFfi ("Basis", "transaction") => true
| CFfi ("Basis", "eq") => true
| CFfi ("Basis", "num") => true
| CFfi ("Basis", "ord") => true
| CFfi ("Basis", "show") => true
| CFfi ("Basis", "read") => true
| CFfi ("Basis", "sql_injectable_prim") => true
| CFfi ("Basis", "sql_injectable") => true
| CNamed n => IS.member (known, n)
| _ => false}
fun getApp (e, _) =
case e of
ENamed f => SOME (f, [])
| EApp (e1, e2) =>
(case getApp e1 of
NONE => NONE
| SOME (f, xs) => SOME (f, xs @ [e2]))
| _ => NONE
val getApp = fn e => case getApp e of
v as SOME (_, _ :: _) => v
| _ => NONE
val maxInt = Option.getOpt (Int.maxInt, 9999)
fun calcConstArgs enclosingFunctions e =
let
fun ca depth e =
case #1 e of
EPrim _ => maxInt
| ERel _ => maxInt
| ENamed n => if IS.member (enclosingFunctions, n) then 0 else maxInt
| ECon (_, _, _, NONE) => maxInt
| ECon (_, _, _, SOME e) => ca depth e
| EFfi _ => maxInt
| EFfiApp (_, _, ecs) => foldl (fn ((e, _), d) => Int.min (ca depth e, d)) maxInt ecs
| EApp (e1, e2) =>
let
fun default () = Int.min (ca depth e1, ca depth e2)
in
case getApp e of
NONE => default ()
| SOME (f, args) =>
if not (IS.member (enclosingFunctions, f)) then
default ()
else
let
fun visitArgs (count, args) =
case args of
[] => count
| arg :: args' =>
let
fun default () = foldl (fn (e, d) => Int.min (ca depth e, d)) count args
in
case #1 arg of
ERel n =>
if n = depth - 1 - count then
visitArgs (count + 1, args')
else
default ()
| _ => default ()
end
in
visitArgs (0, args)
end
end
| EAbs (_, _, _, e1) => ca (depth + 1) e1
| ECApp (e1, _) => ca depth e1
| ECAbs (_, _, e1) => ca depth e1
| EKAbs (_, e1) => ca depth e1
| EKApp (e1, _) => ca depth e1
| ERecord xets => foldl (fn ((_, e, _), d) => Int.min (ca depth e, d)) maxInt xets
| EField (e1, _, _) => ca depth e1
| EConcat (e1, _, e2, _) => Int.min (ca depth e1, ca depth e2)
| ECut (e1, _, _) => ca depth e1
| ECutMulti (e1, _, _) => ca depth e1
| ECase (e1, pes, _) => foldl (fn ((p, e), d) => Int.min (ca (depth + E.patBindsN p) e, d)) (ca depth e1) pes
| EWrite e1 => ca depth e1
| EClosure (_, es) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es
| ELet (_, _, e1, e2) => Int.min (ca depth e1, ca (depth + 1) e2)
| EServerCall (_, es, _, _) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es
fun enterAbs depth e =
case #1 e of
EAbs (_, _, _, e1) => enterAbs (depth + 1) e1
| _ => ca depth e
in
enterAbs 0 e
end
fun optionExists p opt =
case opt of
NONE => false
| SOME v => p v
fun specialize' (funcs, specialized) file =
let
val known = foldl (fn (d, known) =>
case #1 d of
DCon (_, n, _, c) =>
if functionInside known c then
IS.add (known, n)
else
known
| DDatatype dts =>
if List.exists (List.exists (optionExists (functionInside known) o #3) o #4) dts then
foldl (fn (dt, known) => IS.add (known, #2 dt)) known dts
else
known
| _ => known)
IS.empty file
fun bind (env, b) =
case b of
U.Decl.RelE xt => xt :: env
| _ => env
fun exp (env, e as (_, loc), st : state) =
let
(*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty
(e, ErrorMsg.dummySpan))]*)
fun default () =
case #1 e of
EPrim _ => (e, st)
| ERel _ => (e, st)
| ENamed _ => (e, st)
| ECon (_, _, _, NONE) => (e, st)
| ECon (dk, pc, cs, SOME e) =>
let
val (e, st) = exp (env, e, st)
in
((ECon (dk, pc, cs, SOME e), loc), st)
end
| EFfi _ => (e, st)
| EFfiApp (m, x, es) =>
let
val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
let
val (e, st) = exp (env, e, st)
in
((e, t), st)
end) st es
in
((EFfiApp (m, x, es), loc), st)
end
| EApp (e1, e2) =>
let
val (e1, st) = exp (env, e1, st)
val (e2, st) = exp (env, e2, st)
in
((EApp (e1, e2), loc), st)
end
| EAbs (x, d, r, e) =>
let
val (e, st) = exp ((x, d) :: env, e, st)
in
((EAbs (x, d, r, e), loc), st)
end
| ECApp (e, c) =>
let
val (e, st) = exp (env, e, st)
in
((ECApp (e, c), loc), st)
end
| ECAbs _ => (e, st)
| EKAbs _ => (e, st)
| EKApp (e, k) =>
let
val (e, st) = exp (env, e, st)
in
((EKApp (e, k), loc), st)
end
| ERecord fs =>
let
val (fs, st) = ListUtil.foldlMap (fn ((c1, e, c2), st) =>
let
val (e, st) = exp (env, e, st)
in
((c1, e, c2), st)
end) st fs
in
((ERecord fs, loc), st)
end
| EField (e, c, cs) =>
let
val (e, st) = exp (env, e, st)
in
((EField (e, c, cs), loc), st)
end
| EConcat (e1, c1, e2, c2) =>
let
val (e1, st) = exp (env, e1, st)
val (e2, st) = exp (env, e2, st)
in
((EConcat (e1, c1, e2, c2), loc), st)
end
| ECut (e, c, cs) =>
let
val (e, st) = exp (env, e, st)
in
((ECut (e, c, cs), loc), st)
end
| ECutMulti (e, c, cs) =>
let
val (e, st) = exp (env, e, st)
in
((ECutMulti (e, c, cs), loc), st)
end
| ECase (e, pes, cs) =>
let
val (e, st) = exp (env, e, st)
val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
let
val (e, st) = exp (E.patBindsL p @ env, e, st)
in
((p, e), st)
end) st pes
in
((ECase (e, pes, cs), loc), st)
end
| EWrite e =>
let
val (e, st) = exp (env, e, st)
in
((EWrite e, loc), st)
end
| EClosure (n, es) =>
let
val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
in
((EClosure (n, es), loc), st)
end
| ELet (x, t, e1, e2) =>
let
val (e1, st) = exp (env, e1, st)
val (e2, st) = exp ((x, t) :: env, e2, st)
in
((ELet (x, t, e1, e2), loc), st)
end
| EServerCall (n, es, t, fm) =>
let
val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
in
((EServerCall (n, es, t, fm), loc), st)
end
in
case getApp e of
NONE => default ()
| SOME (f, xs) =>
case IM.find (#funcs st, f) of
NONE => ((*print ("No find: " ^ Int.toString f ^ "\n");*) default ())
| SOME {name, args, body, typ, tag, constArgs} =>
let
val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs
(*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty e)]*)
val loc = ErrorMsg.dummySpan
val oldXs = xs
fun findSplit av (initialPart, constArgs, xs, typ, fxs, fvs) =
let
fun default () =
if initialPart then
([], oldXs, IS.empty)
else
(rev fxs, xs, fvs)
in
case (#1 typ, xs) of
(TFun (dom, ran), e :: xs') =>
if constArgs > 0 then
let
val fi = functionInside known dom
in
if initialPart orelse fi then
findSplit av (not fi andalso initialPart,
constArgs - 1,
xs',
ran,
e :: fxs,
IS.union (fvs, freeVars e))
else
default ()
end
else
default ()
| _ => default ()
end
val (fxs, xs, fvs) = findSplit true (true, constArgs, xs, typ, [], IS.empty)
val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
val fxs' = map (squish (IS.listItems fvs)) fxs
val p_bool = Print.PD.string o Bool.toString
in
(*Print.prefaces "Func" [("name", Print.PD.string name),
("e", CorePrint.p_exp CoreEnv.empty e),
("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
if List.all (fn (ERel _, _) => true
| _ => false) fxs' then
default ()
else
case KM.find (args, (vts, fxs')) of
SOME f' =>
let
val e = (ENamed f', loc)
val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
e fvs
val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
e xs
in
(*Print.prefaces "Brand new (reuse)"
[("e'", CorePrint.p_exp CoreEnv.empty e)];*)
(e, st)
end
| NONE =>
let
(*val () = Print.prefaces "New one"
[("name", Print.PD.string name),
("f", Print.PD.string (Int.toString f)),
("|fvs|", Print.PD.string (Int.toString (IS.numItems fvs))),
("|fxs|", Print.PD.string (Int.toString (length fxs))),
("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs'),
("spec", Print.PD.string (Bool.toString (IS.member (#specialized st, f))))]*)
(*val () = Print.prefaces ("Yes(" ^ name ^ ")")
[("fxs'",
Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
(*val () = Print.prefaces name
[("Available", Print.PD.string (Int.toString constArgs)),
("Used", Print.PD.string (Int.toString (length fxs'))),
("fxs'",
Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
fun subBody (body, typ, fxs') =
case (#1 body, #1 typ, fxs') of
(_, _, []) => SOME (body, typ)
| (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
let
val body'' = E.subExpInExp (0, x) body'
in
subBody (body'',
typ',
fxs'')
end
| _ => NONE
in
case subBody (body, typ, fxs') of
NONE => default ()
| SOME (body', typ') =>
let
val f' = #maxName st
val args = KM.insert (args, (vts, fxs'), f')
val funcs = IM.insert (#funcs st, f, {name = name,
args = args,
body = body,
typ = typ,
tag = tag,
constArgs = calcConstArgs (IS.singleton f) body})
val st = {
maxName = f' + 1,
funcs = funcs,
decls = #decls st,
specialized = IS.add (#specialized st, f')
}
(*val () = Print.prefaces "specExp"
[("f", CorePrint.p_exp env (ENamed f, loc)),
("f'", CorePrint.p_exp env (ENamed f', loc)),
("xs", Print.p_list (CorePrint.p_exp env) xs),
("fxs'", Print.p_list
(CorePrint.p_exp E.empty) fxs'),
("e", CorePrint.p_exp env (e, loc))]*)
val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
let
val (x, xt) = List.nth (env, n)
in
((EAbs (x, xt, typ', body'),
loc),
(TFun (xt, typ'), loc))
end)
(body', typ') fvs
(*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n")*)
val body' = ReduceLocal.reduceExp body'
(*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*)
val (body', st) = exp (env, body', st)
val e' = (ENamed f', loc)
val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
e' fvs
val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
e' xs
(*val () = Print.prefaces "Brand new"
[("e'", CorePrint.p_exp CoreEnv.empty e'),
("e", CorePrint.p_exp CoreEnv.empty e),
("body'", CorePrint.p_exp CoreEnv.empty body')]*)
in
(e',
{maxName = #maxName st,
funcs = #funcs st,
decls = (name, f', typ', body', tag) :: #decls st,
specialized = #specialized st})
end
end
end
end
fun doDecl (d, (st : state, changed)) =
let
(*val befor = Time.now ()*)
val funcs = #funcs st
val funcs =
case #1 d of
DValRec vis =>
let
val fs = foldl (fn ((_, n, _, _, _), fs) => IS.add (fs, n)) IS.empty vis
val constArgs = foldl (fn ((_, _, _, e, _), constArgs) =>
Int.min (constArgs, calcConstArgs fs e))
maxInt vis
in
(*Print.prefaces "ConstArgs" [("d", CorePrint.p_decl CoreEnv.empty d),
("ca", Print.PD.string (Int.toString constArgs))];*)
foldl (fn ((x, n, c, e, tag), funcs) =>
IM.insert (funcs, n, {name = x,
args = KM.empty,
body = e,
typ = c,
tag = tag,
constArgs = constArgs}))
funcs vis
end
| _ => funcs
val st = {maxName = #maxName st,
funcs = funcs,
decls = [],
specialized = #specialized st}
(*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
val (d', st) =
if isPoly d then
(d, st)
else
case #1 d of
DVal (x, n, t, e, s) =>
let
(*val () = Print.preface ("Visiting", Print.box [Print.PD.string (x ^ "__" ^ Int.toString n),
Print.space,
Print.PD.string ":",
Print.space,
CorePrint.p_con CoreEnv.empty t])*)
val (e, st) = exp ([], e, st)
in
((DVal (x, n, t, e, s), #2 d), st)
end
| DValRec vis =>
let
(*val () = Print.preface ("Visiting", Print.p_list (fn vi =>
Print.box [Print.PD.string (#1 vi ^ "__"
^ Int.toString
(#2 vi)),
Print.space,
Print.PD.string ":",
Print.space,
CorePrint.p_con CoreEnv.empty (#3 vi)])
vis)*)
val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
let
val (e, st) = exp ([], e, st)
in
((x, n, t, e, s), st)
end) st vis
in
((DValRec vis, #2 d), st)
end
| DTable (s, n, t, s1, e1, t1, e2, t2) =>
let
val (e1, st) = exp ([], e1, st)
val (e2, st) = exp ([], e2, st)
in
((DTable (s, n, t, s1, e1, t2, e2, t2), #2 d), st)
end
| DView (x, n, s, e, t) =>
let
val (e, st) = exp ([], e, st)
in
((DView (x, n, s, e, t), #2 d), st)
end
| DTask (e1, e2) =>
let
val (e1, st) = exp ([], e1, st)
val (e2, st) = exp ([], e2, st)
in
((DTask (e1, e2), #2 d), st)
end
| _ => (d, st)
(*val () = print "/decl\n"*)
val funcs = #funcs st
val funcs =
case #1 d of
DVal (x, n, c, e as (EAbs _, _), tag) =>
((*Print.prefaces "ConstArgs[2]" [("d", CorePrint.p_decl CoreEnv.empty d),
("ca", Print.PD.string (Int.toString (calcConstArgs (IS.singleton n) e)))];*)
IM.insert (funcs, n, {name = x,
args = KM.empty,
body = e,
typ = c,
tag = tag,
constArgs = calcConstArgs (IS.singleton n) e}))
| DVal (_, n, _, (ENamed n', _), _) =>
(case IM.find (funcs, n') of
NONE => funcs
| SOME v => IM.insert (funcs, n, v))
| _ => funcs
val (changed, ds) =
case #decls st of
[] => (changed, [d'])
| vis =>
(true, case d' of
(DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
| _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
in
(*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d),
("d'", CorePrint.p_decl E.empty d')];*)
(ds, ({maxName = #maxName st,
funcs = funcs,
decls = [],
specialized = #specialized st}, changed))
end
(*val () = Print.preface ("RESET", CorePrint.p_file CoreEnv.empty file)*)
val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
({maxName = U.File.maxName file + 1,
funcs = funcs,
decls = [],
specialized = specialized},
false)
file
in
(*print ("Changed = " ^ Bool.toString changed ^ "\n");*)
(changed, ds, #funcs st, #specialized st)
end
fun specializeL (funcs, specialized) file =
let
val file = ReduceLocal.reduce file
(*val file = ReduceLocal.reduce file*)
val (changed, file, funcs, specialized) = specialize' (funcs, specialized) file
(*val file = ReduceLocal.reduce file
val file = CoreUntangle.untangle file
val file = Shake.shake file*)
in
(*print "Round over\n";*)
if changed then
let
(*val file = ReduceLocal.reduce file*)
(*val () = Print.prefaces "Pre-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
val file = CoreUntangle.untangle file
(*val () = Print.prefaces "Post-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
val file = Shake.shake file
in
(*print "Again!\n";*)
(*Print.prefaces "Again" [("file", CorePrint.p_file CoreEnv.empty file)];*)
specializeL (funcs, specialized) file
end
else
file
end
val specialize = specializeL (IM.empty, IS.empty)
end
urweb-20160213+dfsg/src/expl.sml 0000664 0000000 0000000 00000012447 12657647235 0016322 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 Expl = struct
type 'a located = 'a ErrorMsg.located
datatype kind' =
KType
| KArrow of kind * kind
| KName
| KUnit
| KTuple of kind list
| KRecord of kind
| KRel of int
| KFun of string * kind
withtype kind = kind' located
datatype con' =
TFun of con * con
| TCFun of string * kind * con
| TRecord of con
| CRel of int
| CNamed of int
| CModProj of int * string list * string
| CApp of con * con
| CAbs of string * kind * con
| CKAbs of string * con
| CKApp of con * kind
| TKFun of string * con
| CName of string
| CRecord of kind * (con * con) list
| CConcat of con * con
| CMap of kind * kind
| CUnit
| CTuple of con list
| CProj of con * int
withtype con = con' located
datatype datatype_kind = datatype DatatypeKind.datatype_kind
datatype patCon =
PConVar of int
| PConProj of int * string list * string
datatype pat' =
PVar of string * con
| PPrim of Prim.t
| PCon of datatype_kind * patCon * con list * pat option
| PRecord of (string * pat * con) list
withtype pat = pat' located
datatype exp' =
EPrim of Prim.t
| ERel of int
| ENamed of int
| EModProj of int * string list * string
| EApp of exp * exp
| EAbs of string * con * con * exp
| ECApp of exp * con
| ECAbs of string * kind * exp
| EKAbs of string * exp
| EKApp of exp * kind
| ERecord of (con * exp * con) list
| EField of exp * con * { field : con, rest : con }
| EConcat of exp * con * exp * con
| ECut of exp * con * { field : con, rest : con }
| ECutMulti of exp * con * { rest : con }
| ECase of exp * (pat * exp) list * { disc : con, result : con }
| EWrite of exp
| ELet of string * con * exp * exp
withtype exp = exp' located
datatype sgn_item' =
SgiConAbs of string * int * kind
| SgiCon of string * int * kind * con
| SgiDatatype of (string * int * string list * (string * int * con option) list) list
| SgiDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list
| SgiVal of string * int * con
| SgiSgn of string * int * sgn
| SgiStr of string * int * sgn
and sgn' =
SgnConst of sgn_item list
| SgnVar of int
| SgnFun of string * int * sgn * sgn
| SgnWhere of sgn * string list * string * con
| SgnProj of int * string list * string
withtype sgn_item = sgn_item' located
and sgn = sgn' located
datatype decl' =
DCon of string * int * kind * con
| DDatatype of (string * int * string list * (string * int * con option) list) list
| DDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list
| DVal of string * int * con * exp
| DValRec of (string * int * con * exp) list
| DSgn of string * int * sgn
| DStr of string * int * sgn * str
| DFfiStr of string * int * sgn
| DExport of int * sgn * str
| DTable of int * string * int * con * exp * con * exp * con
| DSequence of int * string * int
| DView of int * string * int * exp * con
| DDatabase of string
| DCookie of int * string * int * con
| DStyle of int * string * int
| DTask of exp * exp
| DPolicy of exp
| DOnError of int * string list * string
| DFfi of string * int * Source.ffi_mode list * con
and str' =
StrConst of decl list
| StrVar of int
| StrProj of str * string
| StrFun of string * int * sgn * sgn * str
| StrApp of str * str
withtype decl = decl' located
and str = str' located
type file = decl list
end
urweb-20160213+dfsg/src/expl_env.sig 0000664 0000000 0000000 00000005336 12657647235 0017160 0 ustar 00root root 0000000 0000000 (* 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.
*)
signature EXPL_ENV = sig
exception SynUnif
val liftConInCon : int -> Expl.con -> Expl.con
type env
val empty : env
exception UnboundRel of int
exception UnboundNamed of int
datatype 'a var =
NotBound
| Rel of int * 'a
| Named of int * 'a
val pushKRel : env -> string -> env
val lookupKRel : env -> int -> string
val pushCRel : env -> string -> Expl.kind -> env
val lookupCRel : env -> int -> string * Expl.kind
val pushCNamed : env -> string -> int -> Expl.kind -> Expl.con option -> env
val lookupCNamed : env -> int -> string * Expl.kind * Expl.con option
val pushERel : env -> string -> Expl.con -> env
val lookupERel : env -> int -> string * Expl.con
val pushENamed : env -> string -> int -> Expl.con -> env
val lookupENamed : env -> int -> string * Expl.con
val pushSgnNamed : env -> string -> int -> Expl.sgn -> env
val lookupSgnNamed : env -> int -> string * Expl.sgn
val pushStrNamed : env -> string -> int -> Expl.sgn -> env
val lookupStrNamed : env -> int -> string * Expl.sgn
val declBinds : env -> Expl.decl -> env
val sgiBinds : env -> Expl.sgn_item -> env
val patBinds : env -> Expl.pat -> env
end
urweb-20160213+dfsg/src/expl_env.sml 0000664 0000000 0000000 00000031124 12657647235 0017163 0 ustar 00root root 0000000 0000000 (* 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 ExplEnv :> EXPL_ENV = struct
open Expl
structure U = ExplUtil
structure IM = IntBinaryMap
structure SM = BinaryMapFn(struct
type ord_key = string
val compare = String.compare
end)
exception UnboundRel of int
exception UnboundNamed of int
(* AST utility functions *)
exception SynUnif
val liftKindInKind =
U.Kind.mapB {kind = fn bound => fn k =>
case k of
KRel xn =>
if xn < bound then
k
else
KRel (xn + 1)
| _ => k,
bind = fn (bound, _) => bound + 1}
val liftKindInCon =
U.Con.mapB {kind = fn bound => fn k =>
case k of
KRel xn =>
if xn < bound then
k
else
KRel (xn + 1)
| _ => k,
con = fn _ => fn c => c,
bind = fn (bound, U.Con.RelK _) => bound + 1
| (bound, _) => bound}
val liftConInCon =
U.Con.mapB {kind = fn _ => fn k => k,
con = fn bound => fn c =>
case c of
CRel xn =>
if xn < bound then
c
else
CRel (xn + 1)
(*| CUnif _ => raise SynUnif*)
| _ => c,
bind = fn (bound, U.Con.RelC _) => bound + 1
| (bound, _) => bound}
val lift = liftConInCon 0
(* Back to environments *)
datatype 'a var' =
Rel' of int * 'a
| Named' of int * 'a
datatype 'a var =
NotBound
| Rel of int * 'a
| Named of int * 'a
type env = {
relK : string list,
relC : (string * kind) list,
namedC : (string * kind * con option) IM.map,
relE : (string * con) list,
namedE : (string * con) IM.map,
sgn : (string * sgn) IM.map,
str : (string * sgn) IM.map
}
val namedCounter = ref 0
val empty = {
relK = [],
relC = [],
namedC = IM.empty,
relE = [],
namedE = IM.empty,
sgn = IM.empty,
str = IM.empty
}
fun pushKRel (env : env) x =
{relK = x :: #relK env,
relC = map (fn (x, k) => (x, liftKindInKind 0 k)) (#relC env),
namedC = #namedC env,
relE = map (fn (x, c) => (x, liftKindInCon 0 c)) (#relE env),
namedE = #namedE env,
sgn = #sgn env,
str = #str env
}
fun lookupKRel (env : env) n =
(List.nth (#relK env, n))
handle Subscript => raise UnboundRel n
fun pushCRel (env : env) x k =
{relK = #relK env,
relC = (x, k) :: #relC env,
namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env),
relE = map (fn (x, c) => (x, lift c)) (#relE env),
namedE = IM.map (fn (x, c) => (x, lift c)) (#namedE env),
sgn = #sgn env,
str = #str env
}
fun lookupCRel (env : env) n =
(List.nth (#relC env, n))
handle Subscript => raise UnboundRel n
fun pushCNamed (env : env) x n k co =
{relK = #relK env,
relC = #relC env,
namedC = IM.insert (#namedC env, n, (x, k, co)),
relE = #relE env,
namedE = #namedE env,
sgn = #sgn env,
str = #str env}
fun lookupCNamed (env : env) n =
case IM.find (#namedC env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun pushERel (env : env) x t =
{relK = #relK env,
relC = #relC env,
namedC = #namedC env,
relE = (x, t) :: #relE env,
namedE = #namedE env,
sgn = #sgn env,
str = #str env}
fun lookupERel (env : env) n =
(List.nth (#relE env, n))
handle Subscript => raise UnboundRel n
fun pushENamed (env : env) x n t =
{relK = #relK env,
relC = #relC env,
namedC = #namedC env,
relE = #relE env,
namedE = IM.insert (#namedE env, n, (x, t)),
sgn = #sgn env,
str = #str env}
fun lookupENamed (env : env) n =
case IM.find (#namedE env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun pushSgnNamed (env : env) x n sgis =
{relK = #relK env,
relC = #relC env,
namedC = #namedC env,
relE = #relE env,
namedE = #namedE env,
sgn = IM.insert (#sgn env, n, (x, sgis)),
str = #str env}
fun lookupSgnNamed (env : env) n =
case IM.find (#sgn env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun pushStrNamed (env : env) x n sgis =
{relK = #relK env,
relC = #relC env,
namedC = #namedC env,
relE = #relE env,
namedE = #namedE env,
sgn = #sgn env,
str = IM.insert (#str env, n, (x, sgis))}
fun lookupStrNamed (env : env) n =
case IM.find (#str env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun declBinds env (d, loc) =
case d of
DCon (x, n, k, c) => pushCNamed env x n k (SOME c)
| DDatatype dts =>
let
fun doOne ((x, n, xs, xncs), env) =
let
val k = (KType, loc)
val nxs = length xs
val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) =>
((CApp (tb, (CRel (nxs - i - 1), loc)), loc),
(KArrow (k, kb), loc)))
((CNamed n, loc), k) xs
val env = pushCNamed env x n kb NONE
in
foldl (fn ((x', n', to), env) =>
let
val t =
case to of
NONE => tb
| SOME t => (TFun (t, tb), loc)
val t = foldr (fn (x, t) => (TCFun (x, k, t), loc)) t xs
in
pushENamed env x' n' t
end)
env xncs
end
in
foldl doOne env dts
end
| DDatatypeImp (x, n, m, ms, x', xs, xncs) =>
let
val t = (CModProj (m, ms, x'), loc)
val env = pushCNamed env x n (KType, loc) (SOME t)
val t = (CNamed n, loc)
in
foldl (fn ((x', n', to), env) =>
let
val t =
case to of
NONE => (CNamed n, loc)
| SOME t => (TFun (t, (CNamed n, loc)), loc)
val k = (KType, loc)
val t = foldr (fn (x, t) => (TCFun (x, k, t), loc)) t xs
in
pushENamed env x' n' t
end)
env xncs
end
| DVal (x, n, t, _) => pushENamed env x n t
| DValRec vis => foldl (fn ((x, n, t, _), env) => pushENamed env x n t) env vis
| DSgn (x, n, sgn) => pushSgnNamed env x n sgn
| DStr (x, n, sgn, _) => pushStrNamed env x n sgn
| DFfiStr (x, n, sgn) => pushStrNamed env x n sgn
| DExport _ => env
| DTable (tn, x, n, c, _, pc, _, cc) =>
let
val ct = (CModProj (tn, [], "sql_table"), loc)
val ct = (CApp (ct, c), loc)
val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc)
in
pushENamed env x n ct
end
| DSequence (tn, x, n) =>
let
val t = (CModProj (tn, [], "sql_sequence"), loc)
in
pushENamed env x n t
end
| DView (tn, x, n, _, c) =>
let
val ct = (CModProj (tn, [], "sql_view"), loc)
val ct = (CApp (ct, c), loc)
in
pushENamed env x n ct
end
| DDatabase _ => env
| DCookie (tn, x, n, c) =>
let
val t = (CApp ((CModProj (tn, [], "http_cookie"), loc), c), loc)
in
pushENamed env x n t
end
| DStyle (tn, x, n) =>
let
val t = (CModProj (tn, [], "css_class"), loc)
in
pushENamed env x n t
end
| DTask _ => env
| DPolicy _ => env
| DOnError _ => env
| DFfi (x, n, _, t) => pushENamed env x n t
fun sgiBinds env (sgi, loc) =
case sgi of
SgiConAbs (x, n, k) => pushCNamed env x n k NONE
| SgiCon (x, n, k, c) => pushCNamed env x n k (SOME c)
| SgiDatatype dts =>
let
fun doOne ((x, n, xs, xncs), env) =
let
val k = (KType, loc)
val k' = foldr (fn (_, k') => (KArrow (k, k'), loc)) k xs
val env = pushCNamed env x n k' NONE
in
foldl (fn ((x', n', to), env) =>
let
val t =
case to of
NONE => (CNamed n, loc)
| SOME t => (TFun (t, (CNamed n, loc)), loc)
val k = (KType, loc)
val t = foldr (fn (x, t) => (TCFun (x, k, t), loc)) t xs
in
pushENamed env x' n' t
end)
env xncs
end
in
foldl doOne env dts
end
| SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) =>
let
val t = (CModProj (m1, ms, x'), loc)
val env = pushCNamed env x n (KType, loc) (SOME t)
val t = (CNamed n, loc)
in
foldl (fn ((x', n', to), env) =>
let
val t =
case to of
NONE => (CNamed n, loc)
| SOME t => (TFun (t, (CNamed n, loc)), loc)
val k = (KType, loc)
val t = foldr (fn (x, t) => (TCFun (x, k, t), loc)) t xs
in
pushENamed env x' n' t
end)
env xncs
end
| SgiVal (x, n, t) => pushENamed env x n t
| SgiSgn (x, n, sgn) => pushSgnNamed env x n sgn
| SgiStr (x, n, sgn) => pushStrNamed env x n sgn
fun patBinds env (p, loc) =
case p of
PVar (x, t) => pushERel env x t
| PPrim _ => env
| PCon (_, _, _, NONE) => env
| PCon (_, _, _, SOME p) => patBinds env p
| PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps
end
urweb-20160213+dfsg/src/expl_print.sig 0000664 0000000 0000000 00000003663 12657647235 0017525 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 EXPL_PRINT = sig
val p_kind : ExplEnv.env -> Expl.kind Print.printer
val p_con : ExplEnv.env -> Expl.con Print.printer
val p_exp : ExplEnv.env -> Expl.exp Print.printer
val p_decl : ExplEnv.env -> Expl.decl Print.printer
val p_sgn_item : ExplEnv.env -> Expl.sgn_item Print.printer
val p_str : ExplEnv.env -> Expl.str Print.printer
val p_file : ExplEnv.env -> Expl.file Print.printer
val debug : bool ref
end
urweb-20160213+dfsg/src/expl_print.sml 0000664 0000000 0000000 00000101341 12657647235 0017526 0 ustar 00root root 0000000 0000000 (* 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.
*)
(* Pretty-printing elaborated Ur/Web *)
structure ExplPrint :> EXPL_PRINT = struct
open Print.PD
open Print
open Expl
structure E = ExplEnv
val debug = ref false
fun p_kind' par env (k, _) =
case k of
KType => string "Type"
| KArrow (k1, k2) => parenIf par (box [p_kind' true env k1,
space,
string "->",
space,
p_kind env k2])
| KName => string "Name"
| KRecord k => box [string "{", p_kind env k, string "}"]
| KUnit => string "Unit"
| KTuple ks => box [string "(",
p_list_sep (box [space, string "*", space]) (p_kind env) ks,
string ")"]
| KRel n => ((if !debug then
string (E.lookupKRel env n ^ "_" ^ Int.toString n)
else
string (E.lookupKRel env n))
handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
| KFun (x, k) => box [string x,
space,
string "-->",
space,
p_kind (E.pushKRel env x) k]
and p_kind env = p_kind' false env
fun p_con' par env (c, _) =
case c of
TFun (t1, t2) => parenIf par (box [p_con' true env t1,
space,
string "->",
space,
p_con env t2])
| TCFun (x, k, c) => parenIf par (box [string x,
space,
string "::",
space,
p_kind env k,
space,
string "->",
space,
p_con (E.pushCRel env x k) c])
| TRecord (CRecord (_, xcs), _) => box [string "{",
p_list (fn (x, c) =>
box [p_name env x,
space,
string ":",
space,
p_con env c]) xcs,
string "}"]
| TRecord c => box [string "$",
p_con' true env c]
| CRel n =>
((if !debug then
string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
else
string (#1 (E.lookupCRel env n)))
handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
| CNamed n =>
((if !debug then
string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupCNamed env n)))
handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
| CModProj (m1, ms, x) =>
let
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString m1
val m1s = if !debug then
m1x ^ "__" ^ Int.toString m1
else
m1x
in
p_list_sep (string ".") string (m1s :: ms @ [x])
end
| CApp (c1, c2) => parenIf par (box [p_con env c1,
space,
p_con' true env c2])
| CAbs (x, k, c) => parenIf par (box [string "fn",
space,
string x,
space,
string "::",
space,
p_kind env k,
space,
string "=>",
space,
p_con (E.pushCRel env x k) c])
| CName s => box [string "#", string s]
| CRecord (k, xcs) =>
if !debug then
parenIf par (box [string "[",
p_list (fn (x, c) =>
box [p_con env x,
space,
string "=",
space,
p_con env c]) xcs,
string "]::",
p_kind env k])
else
parenIf par (box [string "[",
p_list (fn (x, c) =>
box [p_con env x,
space,
string "=",
space,
p_con env c]) xcs,
string "]"])
| CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
space,
string "++",
space,
p_con env c2])
| CMap _ => string "map"
| CUnit => string "()"
| CTuple cs => box [string "(",
p_list (p_con env) cs,
string ")"]
| CProj (c, n) => box [p_con env c,
string ".",
string (Int.toString n)]
| CKAbs (x, c) => box [string x,
space,
string "==>",
space,
p_con (E.pushKRel env x) c]
| CKApp (c, k) => box [p_con env c,
string "[[",
p_kind env k,
string "]]"]
| TKFun (x, c) => box [string x,
space,
string "-->",
space,
p_con (E.pushKRel env x) c]
and p_con env = p_con' false env
and p_name env (all as (c, _)) =
case c of
CName s => string s
| _ => p_con env all
fun p_patCon env pc =
case pc of
PConVar n =>
((if !debug then
string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupENamed env n)))
handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
| PConProj (m1, ms, x) =>
let
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
val m1s = if !debug then
m1x ^ "__" ^ Int.toString m1
else
m1x
in
p_list_sep (string ".") string (m1x :: ms @ [x])
end
fun p_pat' par env (p, _) =
case p of
PVar (s, _) => string s
| PPrim p => Prim.p_t p
| PCon (_, pc, _, NONE) => p_patCon env pc
| PCon (_, pc, cs, SOME p) =>
if !debug then
parenIf par (box [p_patCon env pc,
string "[",
p_list (p_con env) cs,
string "]",
space,
p_pat' true env p])
else
parenIf par (box [p_patCon env pc,
space,
p_pat' true env p])
| PRecord xps =>
box [string "{",
p_list_sep (box [string ",", space]) (fn (x, p, t) =>
box [string x,
space,
string "=",
space,
p_pat env p,
if !debug then
box [space,
string ":",
space,
p_con env t]
else
box []]) xps,
string "}"]
and p_pat x = p_pat' false x
fun p_exp' par env (e, loc) =
case e of
EPrim p => Prim.p_t p
| ERel n =>
((if !debug then
string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
else
string (#1 (E.lookupERel env n)))
handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
| ENamed n =>
((if !debug then
string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupENamed env n)))
handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
| EModProj (m1, ms, x) =>
let
val (m1x, sgn) = E.lookupStrNamed env m1
handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc))
val m1s = if !debug then
m1x ^ "__" ^ Int.toString m1
else
m1x
in
p_list_sep (string ".") string (m1s :: ms @ [x])
end
| EApp (e1, e2) => parenIf par (box [p_exp env e1,
space,
p_exp' true env e2])
| EAbs (x, t, _, e) => parenIf par (box [string "fn",
space,
string x,
space,
string ":",
space,
p_con env t,
space,
string "=>",
space,
p_exp (E.pushERel env x t) e])
| ECApp (e, c) => parenIf par (box [p_exp env e,
space,
string "[",
p_con env c,
string "]"])
| ECAbs (x, k, e) => parenIf par (box [string "fn",
space,
string x,
space,
string "::",
space,
p_kind env k,
space,
string "=>",
space,
p_exp (E.pushCRel env x k) e])
| ERecord xes => box [string "{",
p_list (fn (x, e, _) =>
box [p_name env x,
space,
string "=",
space,
p_exp env e]) xes,
string "}"]
| EField (e, c, {field, rest}) =>
if !debug then
box [p_exp' true env e,
string ".",
p_con' true env c,
space,
string "[",
p_con env field,
space,
string " in ",
space,
p_con env rest,
string "]"]
else
box [p_exp' true env e,
string ".",
p_con' true env c]
| EConcat (e1, c1, e2, c2) =>
parenIf par (if !debug then
box [p_exp' true env e1,
space,
string ":",
space,
p_con env c1,
space,
string "++",
space,
p_exp' true env e2,
space,
string ":",
space,
p_con env c2]
else
box [p_exp' true env e1,
space,
string "with",
space,
p_exp' true env e2])
| ECut (e, c, {field, rest}) =>
parenIf par (if !debug then
box [p_exp' true env e,
space,
string "--",
space,
p_con' true env c,
space,
string "[",
p_con env field,
space,
string " in ",
space,
p_con env rest,
string "]"]
else
box [p_exp' true env e,
space,
string "--",
space,
p_con' true env c])
| ECutMulti (e, c, {rest}) =>
parenIf par (if !debug then
box [p_exp' true env e,
space,
string "---",
space,
p_con' true env c,
space,
string "[",
p_con env rest,
string "]"]
else
box [p_exp' true env e,
space,
string "---",
space,
p_con' true env c])
| EWrite e => box [string "write(",
p_exp env e,
string ")"]
| ECase (e, pes, {disc, result}) =>
parenIf par (box [string "case",
space,
p_exp env e,
space,
if !debug then
box [string "in",
space,
p_con env disc,
space,
string "return",
space,
p_con env result,
space]
else
box [],
string "of",
space,
p_list_sep (box [space, string "|", space])
(fn (p, e) => box [p_pat env p,
space,
string "=>",
space,
p_exp (E.patBinds env p) e]) pes])
| ELet (x, t, e1, e2) => box [string "let",
space,
string x,
space,
string ":",
space,
p_con env t,
space,
string "=",
space,
p_exp env e1,
space,
string "in",
newline,
p_exp (E.pushERel env x t) e2]
| EKAbs (x, e) => box [string x,
space,
string "==>",
space,
p_exp (E.pushKRel env x) e]
| EKApp (e, k) => box [p_exp env e,
string "[[",
p_kind env k,
string "]]"]
and p_exp env = p_exp' false env
fun p_named x n =
if !debug then
box [string x,
string "__",
string (Int.toString n)]
else
string x
fun p_datatype env (x, n, xs, cons) =
let
val k = (KType, ErrorMsg.dummySpan)
val env = E.pushCNamed env x n k NONE
val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
in
box [string x,
p_list_sep (box []) (fn x => box [space, string x]) xs,
space,
string "=",
space,
p_list_sep (box [space, string "|", space])
(fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
else string x
| (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
else string x, space, string "of", space, p_con env t])
cons]
end
fun p_sgn_item env (sgiAll as (sgi, _)) =
case sgi of
SgiConAbs (x, n, k) => box [string "con",
space,
p_named x n,
space,
string "::",
space,
p_kind env k]
| SgiCon (x, n, k, c) => box [string "con",
space,
p_named x n,
space,
string "::",
space,
p_kind env k,
space,
string "=",
space,
p_con env c]
| SgiDatatype x => box [string "datatype",
space,
p_list_sep (box [space, string "and", space]) (p_datatype (E.sgiBinds env sgiAll)) x]
| SgiDatatypeImp (x, _, m1, ms, x', _, _) =>
let
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
in
box [string "datatype",
space,
string x,
space,
string "=",
space,
string "datatype",
space,
p_list_sep (string ".") string (m1x :: ms @ [x'])]
end
| SgiVal (x, n, c) => box [string "val",
space,
p_named x n,
space,
string ":",
space,
p_con env c]
| SgiStr (x, n, sgn) => box [string "structure",
space,
p_named x n,
space,
string ":",
space,
p_sgn env sgn]
| SgiSgn (x, n, sgn) => box [string "signature",
space,
p_named x n,
space,
string "=",
space,
p_sgn env sgn]
and p_sgn env (sgn, loc) =
case sgn of
SgnConst sgis => box [string "sig",
newline,
let
val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) =>
(p_sgn_item env sgi,
E.sgiBinds env sgi))
env sgis
in
p_list_sep newline (fn x => x) psgis
end,
newline,
string "end"]
| SgnVar n => string ((#1 (E.lookupSgnNamed env n))
handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n)
| SgnFun (x, n, sgn, sgn') => box [string "functor",
space,
string "(",
p_named x n,
space,
string ":",
space,
p_sgn env sgn,
string ")",
space,
string ":",
space,
p_sgn (E.pushStrNamed env x n sgn) sgn']
| SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn,
space,
string "where",
space,
string "con",
space,
p_list_sep (string ".") string (ms @ [x]),
space,
string "=",
space,
p_con env c]
| SgnProj (m1, ms, x) =>
let
val (m1x, sgn) = E.lookupStrNamed env m1
handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc))
val m1s = if !debug then
m1x ^ "__" ^ Int.toString m1
else
m1x
in
p_list_sep (string ".") string (m1x :: ms @ [x])
end
fun p_vali env (x, n, t, e) = box [p_named x n,
space,
string ":",
space,
p_con env t,
space,
string "=",
space,
p_exp env e]
fun p_decl env (dAll as (d, _) : decl) =
case d of
DCon (x, n, k, c) => box [string "con",
space,
p_named x n,
space,
string "::",
space,
p_kind env k,
space,
string "=",
space,
p_con env c]
| DDatatype x => box [string "datatype",
space,
p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x]
| DDatatypeImp (x, _, m1, ms, x', _, _) =>
let
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
in
box [string "datatype",
space,
string x,
space,
string "=",
space,
string "datatype",
space,
p_list_sep (string ".") string (m1x :: ms @ [x'])]
end
| DVal vi => box [string "val",
space,
p_vali env vi]
| DValRec vis =>
let
val env = E.declBinds env dAll
in
box [string "val",
space,
string "rec",
space,
p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
end
| DSgn (x, n, sgn) => box [string "signature",
space,
p_named x n,
space,
string "=",
space,
p_sgn env sgn]
| DStr (x, n, sgn, str) => box [string "structure",
space,
p_named x n,
space,
string ":",
space,
p_sgn env sgn,
space,
string "=",
space,
p_str env str]
| DFfiStr (x, n, sgn) => box [string "extern",
space,
string "structure",
space,
p_named x n,
space,
string ":",
space,
p_sgn env sgn]
| DExport (_, sgn, str) => box [string "export",
space,
p_str env str,
space,
string ":",
space,
p_sgn env sgn]
| DTable (_, x, n, c, pe, _, ce, _) => box [string "table",
space,
p_named x n,
space,
string ":",
space,
p_con env c,
space,
string "keys",
space,
p_exp env pe,
space,
string "constraints",
space,
p_exp env ce]
| DSequence (_, x, n) => box [string "sequence",
space,
p_named x n]
| DView (_, x, n, e, _) => box [string "view",
space,
p_named x n,
space,
string "as",
space,
p_exp env e]
| DDatabase s => box [string "database",
space,
string s]
| DCookie (_, x, n, c) => box [string "cookie",
space,
p_named x n,
space,
string ":",
space,
p_con env c]
| DStyle (_, x, n) => box [string "style",
space,
p_named x n]
| DTask (e1, e2) => box [string "task",
space,
p_exp env e1,
space,
string "=",
space,
p_exp env e2]
| DPolicy e1 => box [string "policy",
space,
p_exp env e1]
| DOnError _ => string "ONERROR"
| DFfi _ => string "FFI"
and p_str env (str, _) =
case str of
StrConst ds => box [string "struct",
newline,
p_file env ds,
newline,
string "end"]
| StrVar n =>
let
val x = #1 (E.lookupStrNamed env n)
handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n
val s = if !debug then
x ^ "__" ^ Int.toString n
else
x
in
string s
end
| StrProj (str, s) => box [p_str env str,
string ".",
string s]
| StrFun (x, n, sgn, sgn', str) =>
let
val env' = E.pushStrNamed env x n sgn
in
box [string "functor",
space,
string "(",
p_named x n,
space,
string ":",
space,
p_sgn env sgn,
string ")",
space,
string ":",
space,
p_sgn env' sgn',
space,
string "=>",
space,
p_str env' str]
end
| StrApp (str1, str2) => box [p_str env str1,
string "(",
p_str env str2,
string ")"]
and p_file env file =
let
val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
(p_decl env d,
E.declBinds env d))
env file
in
p_list_sep newline (fn x => x) pds
end
end
urweb-20160213+dfsg/src/expl_rename.sig 0000664 0000000 0000000 00000004045 12657647235 0017633 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2014, 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.
*)
(* To simplify Corify, it helps to apply a particular kind of renaming to functor
* bodies, so that nested functors refer only to fresh names. The payoff is that
* we can then implement applications of those nested functors by evaluating their
* bodies in arbitrary later contexts, even where identifiers defined in the
* outer functor body may have been shadowed. *)
signature EXPL_RENAME = sig
val rename : {NextId : int,
FormalName : string,
FormalId : int,
Body : Expl.str} -> int * Expl.str
end
urweb-20160213+dfsg/src/expl_rename.sml 0000664 0000000 0000000 00000045523 12657647235 0017652 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2014, 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 ExplRename :> EXPL_RENAME = struct
open Expl
structure E = ExplEnv
structure IM = IntBinaryMap
structure St :> sig
type t
val create : int -> t
val next : t -> int
val bind : t * int -> t * int
val lookup: t * int -> int option
end = struct
type t = {next : int,
renaming : int IM.map}
fun create next = {next = next,
renaming = IM.empty}
fun next (t : t) = #next t
fun bind ({next, renaming}, n) =
({next = next + 1,
renaming = IM.insert (renaming, n, next)}, next)
fun lookup ({next, renaming}, n) =
IM.find (renaming, n)
end
fun renameCon st (all as (c, loc)) =
case c of
TFun (c1, c2) => (TFun (renameCon st c1, renameCon st c2), loc)
| TCFun (x, k, c) => (TCFun (x, k, renameCon st c), loc)
| TRecord c => (TRecord (renameCon st c), loc)
| CRel _ => all
| CNamed n =>
(case St.lookup (st, n) of
NONE => all
| SOME n' => (CNamed n', loc))
| CModProj (n, ms, x) =>
(case St.lookup (st, n) of
NONE => all
| SOME n' => (CModProj (n', ms, x), loc))
| CApp (c1, c2) => (CApp (renameCon st c1, renameCon st c2), loc)
| CAbs (x, k, c) => (CAbs (x, k, renameCon st c), loc)
| CKAbs (x, c) => (CKAbs (x, renameCon st c), loc)
| CKApp (c, k) => (CKApp (renameCon st c, k), loc)
| TKFun (x, c) => (TKFun (x, renameCon st c), loc)
| CName _ => all
| CRecord (k, xcs) => (CRecord (k, map (fn (x, c) => (renameCon st x, renameCon st c)) xcs), loc)
| CConcat (c1, c2) => (CConcat (renameCon st c1, renameCon st c2), loc)
| CMap _ => all
| CUnit => all
| CTuple cs => (CTuple (map (renameCon st) cs), loc)
| CProj (c, n) => (CProj (renameCon st c, n), loc)
fun renamePatCon st pc =
case pc of
PConVar n =>
(case St.lookup (st, n) of
NONE => pc
| SOME n' => PConVar n')
| PConProj (n, ms, x) =>
(case St.lookup (st, n) of
NONE => pc
| SOME n' => PConProj (n', ms, x))
fun renamePat st (all as (p, loc)) =
case p of
PVar (x, c) => (PVar (x, renameCon st c), loc)
| PPrim _ => all
| PCon (dk, pc, cs, po) => (PCon (dk, renamePatCon st pc,
map (renameCon st) cs,
Option.map (renamePat st) po), loc)
| PRecord xpcs => (PRecord (map (fn (x, p, c) =>
(x, renamePat st p, renameCon st c)) xpcs), loc)
fun renameExp st (all as (e, loc)) =
case e of
EPrim _ => all
| ERel _ => all
| ENamed n =>
(case St.lookup (st, n) of
NONE => all
| SOME n' => (ENamed n', loc))
| EModProj (n, ms, x) =>
(case St.lookup (st, n) of
NONE => all
| SOME n' => (EModProj (n', ms, x), loc))
| EApp (e1, e2) => (EApp (renameExp st e1, renameExp st e2), loc)
| EAbs (x, dom, ran, e) => (EAbs (x, renameCon st dom, renameCon st ran, renameExp st e), loc)
| ECApp (e, c) => (ECApp (renameExp st e, renameCon st c), loc)
| ECAbs (x, k, e) => (ECAbs (x, k, renameExp st e), loc)
| EKAbs (x, e) => (EKAbs (x, renameExp st e), loc)
| EKApp (e, k) => (EKApp (renameExp st e, k), loc)
| ERecord xecs => (ERecord (map (fn (x, e, c) => (renameCon st x,
renameExp st e,
renameCon st c)) xecs), loc)
| EField (e, c, {field, rest}) => (EField (renameExp st e,
renameCon st c,
{field = renameCon st field,
rest = renameCon st rest}), loc)
| EConcat (e1, c1, e2, c2) => (EConcat (renameExp st e1,
renameCon st c1,
renameExp st e2,
renameCon st c2), loc)
| ECut (e, c, {field, rest}) => (ECut (renameExp st e,
renameCon st c,
{field = renameCon st field,
rest = renameCon st rest}), loc)
| ECutMulti (e, c, {rest}) => (ECutMulti (renameExp st e,
renameCon st c,
{rest = renameCon st rest}), loc)
| ECase (e, pes, {disc, result}) => (ECase (renameExp st e,
map (fn (p, e) => (renamePat st p, renameExp st e)) pes,
{disc = renameCon st disc,
result = renameCon st result}), loc)
| EWrite e => (EWrite (renameExp st e), loc)
| ELet (x, c1, e1, e2) => (ELet (x, renameCon st c1,
renameExp st e1,
renameExp st e2), loc)
fun renameSitem st (all as (si, loc)) =
case si of
SgiConAbs _ => all
| SgiCon (x, n, k, c) => (SgiCon (x, n, k, renameCon st c), loc)
| SgiDatatype dts => (SgiDatatype (map (fn (x, n, xs, cns) =>
(x, n, xs,
map (fn (x, n, co) =>
(x, n, Option.map (renameCon st) co)) cns)) dts),
loc)
| SgiDatatypeImp (x, n, n', xs, x', xs', cns) =>
(SgiDatatypeImp (x, n, n', xs, x', xs',
map (fn (x, n, co) =>
(x, n, Option.map (renameCon st) co)) cns), loc)
| SgiVal (x, n, c) => (SgiVal (x, n, renameCon st c), loc)
| SgiSgn (x, n, sg) => (SgiSgn (x, n, renameSgn st sg), loc)
| SgiStr (x, n, sg) => (SgiStr (x, n, renameSgn st sg), loc)
and renameSgn st (all as (sg, loc)) =
case sg of
SgnConst sis => (SgnConst (map (renameSitem st) sis), loc)
| SgnVar n =>
(case St.lookup (st, n) of
NONE => all
| SOME n' => (SgnVar n', loc))
| SgnFun (x, n, dom, ran) => (SgnFun (x, n, renameSgn st dom, renameSgn st ran), loc)
| SgnWhere (sg, xs, s, c) => (SgnWhere (renameSgn st sg, xs, s, renameCon st c), loc)
| SgnProj (n, ms, x) =>
(case St.lookup (st, n) of
NONE => all
| SOME n' => (SgnProj (n', ms, x), loc))
fun renameDecl st (all as (d, loc)) =
case d of
DCon (x, n, k, c) => (DCon (x, n, k, renameCon st c), loc)
| DDatatype dts => (DDatatype (map (fn (x, n, xs, cns) =>
(x, n, xs,
map (fn (x, n, co) =>
(x, n, Option.map (renameCon st) co)) cns)) dts),
loc)
| DDatatypeImp (x, n, n', xs, x', xs', cns) =>
(DDatatypeImp (x, n, n', xs, x', xs',
map (fn (x, n, co) =>
(x, n, Option.map (renameCon st) co)) cns), loc)
| DVal (x, n, c, e) => (DVal (x, n, renameCon st c, renameExp st e), loc)
| DValRec vis => (DValRec (map (fn (x, n, c, e) => (x, n, renameCon st c, renameExp st e)) vis), loc)
| DSgn (x, n, sg) => (DSgn (x, n, renameSgn st sg), loc)
| DStr (x, n, sg, str) => (DStr (x, n, renameSgn st sg, renameStr st str), loc)
| DFfiStr (x, n, sg) => (DFfiStr (x, n, renameSgn st sg), loc)
| DExport (n, sg, str) =>
(case St.lookup (st, n) of
NONE => all
| SOME n' => (DExport (n', renameSgn st sg, renameStr st str), loc))
| DTable (n, x, m, c1, e1, c2, e2, c3) =>
(DTable (n, x, m, renameCon st c1, renameExp st e1, renameCon st c2,
renameExp st e2, renameCon st c3), loc)
| DSequence _ => all
| DView (n, x, n', e, c) => (DView (n, x, n', renameExp st e, renameCon st c), loc)
| DDatabase _ => all
| DCookie (n, x, n', c) => (DCookie (n, x, n', renameCon st c), loc)
| DStyle _ => all
| DTask (e1, e2) => (DTask (renameExp st e1, renameExp st e2), loc)
| DPolicy e => (DPolicy (renameExp st e), loc)
| DOnError (n, xs, x) =>
(case St.lookup (st, n) of
NONE => all
| SOME n' => (DOnError (n', xs, x), loc))
| DFfi (x, n, modes, t) => (DFfi (x, n, modes, renameCon st t), loc)
and renameStr st (all as (str, loc)) =
case str of
StrConst ds => (StrConst (map (renameDecl st) ds), loc)
| StrVar n =>
(case St.lookup (st, n) of
NONE => all
| SOME n' => (StrVar n', loc))
| StrProj (str, x) => (StrProj (renameStr st str, x), loc)
| StrFun (x, n, dom, ran, str) => (StrFun (x, n, renameSgn st dom,
renameSgn st ran,
renameStr st str), loc)
| StrApp (str1, str2) => (StrApp (renameStr st str1, renameStr st str2), loc)
fun fromArity (n, loc) =
case n of
0 => (KType, loc)
| _ => (KArrow ((KType, loc), fromArity (n - 1, loc)), loc)
fun dupDecl (all as (d, loc), st) =
case d of
DCon (x, n, k, c) =>
let
val (st, n') = St.bind (st, n)
in
([(DCon (x, n, k, renameCon st c), loc),
(DCon (x, n', k, (CNamed n, loc)), loc)],
st)
end
| DDatatype dts =>
let
val d = (DDatatype (map (fn (x, n, xs, cns) =>
(x, n, xs,
map (fn (x, n, co) =>
(x, n, Option.map (renameCon st) co)) cns)) dts),
loc)
val (dts', st) = ListUtil.foldlMap (fn ((x, n, xs, cns), st) =>
let
val (st, n') = St.bind (st, n)
val (cns', st) = ListUtil.foldlMap
(fn ((x, n, _), st) =>
let
val (st, n') =
St.bind (st, n)
in
((x, n, n'), st)
end) st cns
in
((x, n, length xs, n', cns'), st)
end) st dts
val env = E.declBinds E.empty d
in
(d
:: map (fn (x, n, arity, n', _) =>
(DCon (x, n', fromArity (arity, loc), (CNamed n, loc)), loc)) dts'
@ ListUtil.mapConcat (fn (_, _, _, _, cns') =>
map (fn (x, n, n') =>
(DVal (x, n', #2 (E.lookupENamed env n), (ENamed n, loc)),
loc)) cns') dts',
st)
end
| DDatatypeImp (x, n, n', xs, x', xs', cns) =>
let
val d = (DDatatypeImp (x, n, n', xs, x', xs',
map (fn (x, n, co) =>
(x, n, Option.map (renameCon st) co)) cns), loc)
val (cns', st) = ListUtil.foldlMap
(fn ((x, n, _), st) =>
let
val (st, n') =
St.bind (st, n)
in
((x, n, n'), st)
end) st cns
val (st, n') = St.bind (st, n)
val env = E.declBinds E.empty d
in
(d
:: (DCon (x, n', fromArity (length xs, loc), (CNamed n, loc)), loc)
:: map (fn (x, n, n') =>
(DVal (x, n', #2 (E.lookupENamed env n), (ENamed n, loc)),
loc)) cns',
st)
end
| DVal (x, n, c, e) =>
let
val (st, n') = St.bind (st, n)
val c' = renameCon st c
in
([(DVal (x, n, c', renameExp st e), loc),
(DVal (x, n', c', (ENamed n, loc)), loc)],
st)
end
| DValRec vis =>
let
val d = (DValRec (map (fn (x, n, c, e) => (x, n, renameCon st c, renameExp st e)) vis), loc)
val (vis', st) = ListUtil.foldlMap (fn ((x, n, _, _), st) =>
let
val (st, n') = St.bind (st, n)
in
((x, n, n'), st)
end) st vis
val env = E.declBinds E.empty d
in
(d
:: map (fn (x, n, n') => (DVal (x, n', #2 (E.lookupENamed env n), (ENamed n, loc)), loc)) vis',
st)
end
| DSgn (x, n, sg) =>
let
val (st, n') = St.bind (st, n)
in
([(DSgn (x, n, renameSgn st sg), loc),
(DSgn (x, n', (SgnVar n, loc)), loc)],
st)
end
| DStr (x, n, sg, str) =>
let
val (st, n') = St.bind (st, n)
val sg' = renameSgn st sg
in
([(DStr (x, n, sg', renameStr st str), loc),
(DStr (x, n', sg', (StrVar n, loc)), loc)],
st)
end
| DFfiStr (x, n, sg) => ([(DFfiStr (x, n, renameSgn st sg), loc)], st)
| DExport (n, sg, str) =>
(case St.lookup (st, n) of
NONE => ([all], st)
| SOME n' => ([(DExport (n', renameSgn st sg, renameStr st str), loc)], st))
| DTable (n, x, m, c1, e1, c2, e2, c3) =>
let
val (st, m') = St.bind (st, m)
val d = (DTable (n, x, m, renameCon st c1, renameExp st e1, renameCon st c2,
renameExp st e2, renameCon st c3), loc)
val env = E.declBinds E.empty d
in
([d, (DVal (x, m', #2 (E.lookupENamed env m), (ENamed m, loc)), loc)], st)
end
| DSequence (n, x, m) =>
let
val (st, m') = St.bind (st, m)
val env = E.declBinds E.empty all
in
([all, (DVal (x, m', #2 (E.lookupENamed env m), (ENamed m, loc)), loc)], st)
end
| DView (n, x, m, e, c) =>
let
val (st, m') = St.bind (st, m)
val d = (DView (n, x, m, renameExp st e, renameCon st c), loc)
val env = E.declBinds E.empty d
in
([d, (DVal (x, m', #2 (E.lookupENamed env m), (ENamed m, loc)), loc)], st)
end
| DDatabase _ => ([all], st)
| DCookie (n, x, m, c) =>
let
val (st, m') = St.bind (st, m)
val d = (DCookie (n, x, m, renameCon st c), loc)
val env = E.declBinds E.empty d
in
([d, (DVal (x, m', #2 (E.lookupENamed env m), (ENamed m, loc)), loc)], st)
end
| DStyle (n, x, m) =>
let
val (st, m') = St.bind (st, m)
val env = E.declBinds E.empty all
in
([all, (DVal (x, m', #2 (E.lookupENamed env m), (ENamed m, loc)), loc)], st)
end
| DTask (e1, e2) => ([(DTask (renameExp st e1, renameExp st e2), loc)], st)
| DPolicy e => ([(DPolicy (renameExp st e), loc)], st)
| DOnError (n, xs, x) =>
(case St.lookup (st, n) of
NONE => ([all], st)
| SOME n' => ([(DOnError (n', xs, x), loc)], st))
| DFfi (x, n, modes, t) =>
let
val (st, n') = St.bind (st, n)
val t' = renameCon st t
in
([(DFfi (x, n, modes, t'), loc),
(DVal (x, n', t', (ENamed n, loc)), loc)],
st)
end
fun rename {NextId, FormalName, FormalId, Body = all as (str, loc)} =
case str of
StrConst ds =>
let
val st = St.create NextId
val (st, n) = St.bind (st, FormalId)
val (ds, st) = ListUtil.foldlMapConcat dupDecl st ds
(* Revenge of the functor parameter renamer!
* See comment in elaborate.sml for the start of the saga.
* We need to alpha-rename the argument to allow sufficient shadowing in the body. *)
fun mungeName m =
if List.exists (fn (DStr (x, _, _, _), _) => x = m
| _ => false) ds then
mungeName ("?" ^ m)
else
m
val FormalName = mungeName FormalName
val ds = (DStr (FormalName, n, (SgnConst [], loc), (StrVar FormalId, loc)), loc) :: ds
in
(St.next st, (StrConst ds, loc))
end
| _ => (NextId, all)
end
urweb-20160213+dfsg/src/expl_util.sig 0000664 0000000 0000000 00000013035 12657647235 0017340 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 EXPL_UTIL = sig
structure Kind : sig
val mapfoldB : {kind : ('context, Expl.kind', 'state, 'abort) Search.mapfolderB,
bind : 'context * string -> 'context}
-> ('context, Expl.kind, 'state, 'abort) Search.mapfolderB
val mapfold : (Expl.kind', 'state, 'abort) Search.mapfolder
-> (Expl.kind, 'state, 'abort) Search.mapfolder
val exists : (Expl.kind' -> bool) -> Expl.kind -> bool
val mapB : {kind : 'context -> Expl.kind' -> Expl.kind',
bind : 'context * string -> 'context}
-> 'context -> (Expl.kind -> Expl.kind)
end
structure Con : sig
datatype binder =
RelK of string
| RelC of string * Expl.kind
| NamedC of string * Expl.kind
val mapfoldB : {kind : ('context, Expl.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Expl.con', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Expl.con, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Expl.kind', 'state, 'abort) Search.mapfolder,
con : (Expl.con', 'state, 'abort) Search.mapfolder}
-> (Expl.con, 'state, 'abort) Search.mapfolder
val mapB : {kind : 'context -> Expl.kind' -> Expl.kind',
con : 'context -> Expl.con' -> Expl.con',
bind : 'context * binder -> 'context}
-> 'context -> (Expl.con -> Expl.con)
val map : {kind : Expl.kind' -> Expl.kind',
con : Expl.con' -> Expl.con'}
-> Expl.con -> Expl.con
val exists : {kind : Expl.kind' -> bool,
con : Expl.con' -> bool} -> Expl.con -> bool
end
structure Exp : sig
datatype binder =
RelK of string
| RelC of string * Expl.kind
| NamedC of string * Expl.kind
| RelE of string * Expl.con
| NamedE of string * Expl.con
val mapfoldB : {kind : ('context, Expl.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Expl.con', 'state, 'abort) Search.mapfolderB,
exp : ('context, Expl.exp', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Expl.exp, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Expl.kind', 'state, 'abort) Search.mapfolder,
con : (Expl.con', 'state, 'abort) Search.mapfolder,
exp : (Expl.exp', 'state, 'abort) Search.mapfolder}
-> (Expl.exp, 'state, 'abort) Search.mapfolder
val exists : {kind : Expl.kind' -> bool,
con : Expl.con' -> bool,
exp : Expl.exp' -> bool} -> Expl.exp -> bool
end
structure Sgn : sig
datatype binder =
RelK of string
| RelC of string * Expl.kind
| NamedC of string * Expl.kind
| Sgn of string * Expl.sgn
| Str of string * Expl.sgn
val mapfoldB : {kind : ('context, Expl.kind', 'state, 'abort) Search.mapfolderB,
con : ('context, Expl.con', 'state, 'abort) Search.mapfolderB,
sgn_item : ('context, Expl.sgn_item', 'state, 'abort) Search.mapfolderB,
sgn : ('context, Expl.sgn', 'state, 'abort) Search.mapfolderB,
bind : 'context * binder -> 'context}
-> ('context, Expl.sgn, 'state, 'abort) Search.mapfolderB
val mapfold : {kind : (Expl.kind', 'state, 'abort) Search.mapfolder,
con : (Expl.con', 'state, 'abort) Search.mapfolder,
sgn_item : (Expl.sgn_item', 'state, 'abort) Search.mapfolder,
sgn : (Expl.sgn', 'state, 'abort) Search.mapfolder}
-> (Expl.sgn, 'state, 'abort) Search.mapfolder
val map : {kind : Expl.kind' -> Expl.kind',
con : Expl.con' -> Expl.con',
sgn_item : Expl.sgn_item' -> Expl.sgn_item',
sgn : Expl.sgn' -> Expl.sgn'}
-> Expl.sgn -> Expl.sgn
end
end
urweb-20160213+dfsg/src/expl_util.sml 0000664 0000000 0000000 00000054647 12657647235 0017367 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 ExplUtil :> EXPL_UTIL = struct
open Expl
structure S = Search
structure Kind = struct
fun mapfoldB {kind, bind} =
let
fun mfk ctx k acc =
S.bindP (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))
| KRel _ => S.return2 kAll
| KFun (x, k) =>
S.map2 (mfk (bind (ctx, x)) k,
fn k' =>
(KFun (x, k'), loc))
in
mfk
end
fun mapfold fk =
mapfoldB {kind = fn () => fk,
bind = fn ((), _) => ()} ()
fun mapB {kind, bind} ctx k =
case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
bind = bind} ctx k () of
S.Continue (k, ()) => k
| S.Return _ => raise Fail "ExplUtil.Kind.mapB: Impossible"
fun exists f k =
case mapfold (fn k => fn () =>
if f k then
S.Return ()
else
S.Continue (k, ())) k () of
S.Return _ => true
| S.Continue _ => false
end
structure Con = struct
datatype binder =
RelK of string
| RelC of string * Expl.kind
| NamedC of string * Expl.kind
fun mapfoldB {kind = fk, con = fc, bind} =
let
val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)}
fun mfc ctx c acc =
S.bindP (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 (x, k, c) =>
S.bind2 (mfk ctx k,
fn k' =>
S.map2 (mfc (bind (ctx, RelC (x, k))) c,
fn c' =>
(TCFun (x, k', c'), 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))
| 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
fun mapfold {kind = fk, con = fc} =
mapfoldB {kind = fn () => fk,
con = fn () => fc,
bind = fn ((), _) => ()} ()
fun mapB {kind, con, bind} ctx c =
case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()),
bind = bind} ctx c () of
S.Continue (c, ()) => c
| S.Return _ => raise Fail "ExplUtil.Con.mapB: Impossible"
fun map {kind, con} s =
case mapfold {kind = fn k => fn () => S.Continue (kind k, ()),
con = fn c => fn () => S.Continue (con c, ())} s () of
S.Return () => raise Fail "ExplUtil.Con.map: Impossible"
| S.Continue (s, ()) => s
fun exists {kind, con} k =
case mapfold {kind = fn k => fn () =>
if kind k then
S.Return ()
else
S.Continue (k, ()),
con = fn c => fn () =>
if con c then
S.Return ()
else
S.Continue (c, ())} k () of
S.Return _ => true
| S.Continue _ => false
end
structure Exp = struct
datatype binder =
RelK of string
| RelC of string * Expl.kind
| NamedC of string * Expl.kind
| RelE of string * Expl.con
| NamedE of string * Expl.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 mfe ctx e acc =
S.bindP (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 (x, k, e) =>
S.bind2 (mfk ctx k,
fn k' =>
S.map2 (mfe (bind (ctx, RelC (x, k))) e,
fn e' =>
(ECAbs (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))))
| EWrite e =>
S.map2 (mfe ctx e,
fn e' =>
(EWrite e', loc))
| ECase (e, pes, {disc, result}) =>
S.bind2 (mfe ctx e,
fn e' =>
S.bind2 (ListUtil.mapfold (fn (p, e) =>
S.map2 (mfe ctx e,
fn e' => (p, e'))) 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)))))
| ELet (x, t, e1, e2) =>
S.bind2 (mfc ctx t,
fn t' =>
S.bind2 (mfe ctx e1,
fn e1' =>
S.map2 (mfe (bind (ctx, RelE (x, t))) e2,
fn e2' =>
(ELet (x, t', e1', e2'), loc))))
| 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)))
in
mfe
end
fun mapfold {kind = fk, con = fc, exp = fe} =
mapfoldB {kind = fn () => fk,
con = fn () => fc,
exp = fn () => fe,
bind = fn ((), _) => ()} ()
fun exists {kind, con, exp} k =
case mapfold {kind = fn k => fn () =>
if kind k then
S.Return ()
else
S.Continue (k, ()),
con = fn c => fn () =>
if con c then
S.Return ()
else
S.Continue (c, ()),
exp = fn e => fn () =>
if exp e then
S.Return ()
else
S.Continue (e, ())} k () of
S.Return _ => true
| S.Continue _ => false
end
structure Sgn = struct
datatype binder =
RelK of string
| RelC of string * Expl.kind
| NamedC of string * Expl.kind
| Str of string * Expl.sgn
| Sgn of string * Expl.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.bindP (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 (x, n, s) =>
S.map2 (sg ctx s,
fn s' =>
(SgiStr (x, n, s'), loc))
| SgiSgn (x, n, s) =>
S.map2 (sg ctx s,
fn s' =>
(SgiSgn (x, n, s'), loc))
and sg ctx s acc =
S.bindP (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, _, k) =>
bind (ctx, NamedC (x, k))
| SgiCon (x, _, k, _) =>
bind (ctx, NamedC (x, k))
| SgiDatatype dts =>
foldl (fn ((x, _, ks, _), ctx) =>
let
val k' = (KType, loc)
val k = foldl (fn (_, k) => (KArrow (k', k), loc))
k' ks
in
bind (ctx, NamedC (x, k))
end) ctx dts
| SgiDatatypeImp (x, _, _, _, _, _, _) =>
bind (ctx, NamedC (x, (KType, loc)))
| SgiVal _ => ctx
| SgiStr (x, _, sgn) =>
bind (ctx, Str (x, sgn))
| SgiSgn (x, _, sgn) =>
bind (ctx, Sgn (x, sgn)),
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, s1'))) s2,
fn s2' =>
(SgnFun (m, n, s1', s2'), loc)))
| 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)))
| SgnProj _ => S.return2 sAll
in
sg
end
fun mapfold {kind, con, sgn_item, sgn} =
mapfoldB {kind = fn () => kind,
con = fn () => con,
sgn_item = fn () => sgn_item,
sgn = fn () => sgn,
bind = fn ((), _) => ()} ()
fun map {kind, con, sgn_item, sgn} s =
case mapfold {kind = fn k => fn () => S.Continue (kind k, ()),
con = fn c => fn () => S.Continue (con c, ()),
sgn_item = fn si => fn () => S.Continue (sgn_item si, ()),
sgn = fn s => fn () => S.Continue (sgn s, ())} s () of
S.Return () => raise Fail "Expl_util.Sgn.map"
| S.Continue (s, ()) => s
end
end
urweb-20160213+dfsg/src/explify.sig 0000664 0000000 0000000 00000003066 12657647235 0017016 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 EXPLIFY = sig
val explify : Elab.file -> Expl.file
end
urweb-20160213+dfsg/src/explify.sml 0000664 0000000 0000000 00000026434 12657647235 0017033 0 ustar 00root root 0000000 0000000 (* 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 Explify :> EXPLIFY = struct
structure EM = ErrorMsg
structure L = Elab
structure L' = Expl
fun explifyKind (k, loc) =
case k of
L.KType => (L'.KType, loc)
| L.KArrow (k1, k2) => (L'.KArrow (explifyKind k1, explifyKind k2), loc)
| L.KName => (L'.KName, loc)
| L.KRecord k => (L'.KRecord (explifyKind k), loc)
| L.KUnit => (L'.KUnit, loc)
| L.KTuple ks => (L'.KTuple (map explifyKind ks), loc)
| L.KError => raise Fail ("explifyKind: KError at " ^ EM.spanToString loc)
| L.KUnif (_, _, ref (L.KKnown k)) => explifyKind k
| L.KUnif _ => raise Fail ("explifyKind: KUnif at " ^ EM.spanToString loc)
| L.KTupleUnif (loc, _, ref (L.KKnown k)) => explifyKind k
| L.KTupleUnif _ => raise Fail ("explifyKind: KTupleUnif at " ^ EM.spanToString loc)
| L.KRel n => (L'.KRel n, loc)
| L.KFun (x, k) => (L'.KFun (x, explifyKind k), loc)
fun explifyCon (c, loc) =
case c of
L.TFun (t1, t2) => (L'.TFun (explifyCon t1, explifyCon t2), loc)
| L.TCFun (_, x, k, t) => (L'.TCFun (x, explifyKind k, explifyCon t), loc)
| L.TDisjoint (_, _, t) => explifyCon t
| L.TRecord c => (L'.TRecord (explifyCon c), loc)
| L.CRel n => (L'.CRel n, loc)
| L.CNamed n => (L'.CNamed n, loc)
| L.CModProj (m, ms, x) => (L'.CModProj (m, ms, x), loc)
| L.CApp (c1, c2) => (L'.CApp (explifyCon c1, explifyCon c2), loc)
| L.CAbs (x, k, c) => (L'.CAbs (x, explifyKind k, explifyCon c), loc)
| L.CName s => (L'.CName s, loc)
| L.CRecord (k, xcs) => (L'.CRecord (explifyKind k, map (fn (c1, c2) => (explifyCon c1, explifyCon c2)) xcs), loc)
| L.CConcat (c1, c2) => (L'.CConcat (explifyCon c1, explifyCon c2), loc)
| L.CMap (dom, ran) => (L'.CMap (explifyKind dom, explifyKind ran), loc)
| L.CUnit => (L'.CUnit, loc)
| L.CTuple cs => (L'.CTuple (map explifyCon cs), loc)
| L.CProj (c, n) => (L'.CProj (explifyCon c, n), loc)
| L.CError => raise Fail ("explifyCon: CError at " ^ EM.spanToString loc)
| L.CUnif (nl, _, _, _, ref (L.Known c)) => explifyCon (ElabEnv.mliftConInCon nl c)
| L.CUnif _ => raise Fail ("explifyCon: CUnif at " ^ EM.spanToString loc)
| L.CKAbs (x, c) => (L'.CKAbs (x, explifyCon c), loc)
| L.CKApp (c, k) => (L'.CKApp (explifyCon c, explifyKind k), loc)
| L.TKFun (x, c) => (L'.TKFun (x, explifyCon c), loc)
fun explifyPatCon pc =
case pc of
L.PConVar n => L'.PConVar n
| L.PConProj x => L'.PConProj x
fun explifyPat (p, loc) =
case p of
L.PVar (x, t) => (L'.PVar (x, explifyCon t), loc)
| L.PPrim p => (L'.PPrim p, loc)
| L.PCon (dk, pc, cs, po) => (L'.PCon (dk, explifyPatCon pc, map explifyCon cs, Option.map explifyPat po), loc)
| L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, explifyPat p, explifyCon t)) xps), loc)
fun explifyExp (e, loc) =
case e of
L.EPrim p => (L'.EPrim p, loc)
| L.ERel n => (L'.ERel n, loc)
| L.ENamed n => (L'.ENamed n, loc)
| L.EModProj (m, ms, x) => (L'.EModProj (m, ms, x), loc)
| L.EApp (e1, e2) => (L'.EApp (explifyExp e1, explifyExp e2), loc)
| L.EAbs (x, dom, ran, e1) => (L'.EAbs (x, explifyCon dom, explifyCon ran, explifyExp e1), loc)
| L.ECApp (e1, c) => (L'.ECApp (explifyExp e1, explifyCon c), loc)
| L.ECAbs (_, x, k, e1) => (L'.ECAbs (x, explifyKind k, explifyExp e1), loc)
| L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (explifyCon c, explifyExp e, explifyCon t)) xes), loc)
| L.EField (e1, c, {field, rest}) => (L'.EField (explifyExp e1, explifyCon c,
{field = explifyCon field, rest = explifyCon rest}), loc)
| L.EConcat (e1, c1, e2, c2) => (L'.EConcat (explifyExp e1, explifyCon c1, explifyExp e2, explifyCon c2),
loc)
| L.ECut (e1, c, {field, rest}) => (L'.ECut (explifyExp e1, explifyCon c,
{field = explifyCon field, rest = explifyCon rest}), loc)
| L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (explifyExp e1, explifyCon c,
{rest = explifyCon rest}), loc)
| L.ECase (e, pes, {disc, result}) =>
(L'.ECase (explifyExp e,
map (fn (p, e) => (explifyPat p, explifyExp e)) pes,
{disc = explifyCon disc, result = explifyCon result}), loc)
| L.EError => raise Fail ("explifyExp: EError at " ^ EM.spanToString loc)
| L.EUnif (ref (SOME e)) => explifyExp e
| L.EUnif _ => raise Fail ("explifyExp: Undetermined EUnif at " ^ EM.spanToString loc)
| L.ELet (des, e, t) =>
foldr (fn ((de, loc), e) =>
case de of
L.EDValRec _ => raise Fail "explifyExp: Local 'val rec' remains"
| L.EDVal ((L.PVar (x, _), _), t', e') => (L'.ELet (x, explifyCon t', explifyExp e', e), loc)
| L.EDVal (p, t', e') => (L'.ECase (explifyExp e',
[(explifyPat p, e)],
{disc = explifyCon t', result = explifyCon t}), loc))
(explifyExp e) des
| L.EKAbs (x, e) => (L'.EKAbs (x, explifyExp e), loc)
| L.EKApp (e, k) => (L'.EKApp (explifyExp e, explifyKind k), loc)
fun explifySgi (sgi, loc) =
case sgi of
L.SgiConAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, explifyKind k), loc)
| L.SgiCon (x, n, k, c) => SOME (L'.SgiCon (x, n, explifyKind k, explifyCon c), loc)
| L.SgiDatatype dts => SOME (L'.SgiDatatype (map (fn (x, n, xs, xncs) =>
(x, n, xs,
map (fn (x, n, co) =>
(x, n, Option.map explifyCon co)) xncs)) dts), loc)
| L.SgiDatatypeImp (x, n, m1, ms, s, xs, xncs) =>
SOME (L'.SgiDatatypeImp (x, n, m1, ms, s, xs, map (fn (x, n, co) =>
(x, n, Option.map explifyCon co)) xncs), loc)
| L.SgiVal (x, n, c) => SOME (L'.SgiVal (x, n, explifyCon c), loc)
| L.SgiStr (_, x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc)
| L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc)
| L.SgiConstraint _ => NONE
| L.SgiClassAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc)), loc)
| L.SgiClass (x, n, k, c) => SOME (L'.SgiCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc),
explifyCon c), loc)
and explifySgn (sgn, loc) =
case sgn of
L.SgnConst sgis => (L'.SgnConst (List.mapPartial explifySgi sgis), loc)
| L.SgnVar n => (L'.SgnVar n, loc)
| L.SgnFun (m, n, dom, ran) => (L'.SgnFun (m, n, explifySgn dom, explifySgn ran), loc)
| L.SgnWhere (sgn, ms, x, c) => (L'.SgnWhere (explifySgn sgn, ms, x, explifyCon c), loc)
| L.SgnProj x => (L'.SgnProj x, loc)
| L.SgnError => raise Fail ("explifySgn: SgnError at " ^ EM.spanToString loc)
fun explifyDecl (d, loc : EM.span) =
case d of
L.DCon (x, n, k, c) => SOME (L'.DCon (x, n, explifyKind k, explifyCon c), loc)
| L.DDatatype dts => SOME (L'.DDatatype (map (fn (x, n, xs, xncs) =>
(x, n, xs,
map (fn (x, n, co) =>
(x, n, Option.map explifyCon co)) xncs)) dts), loc)
| L.DDatatypeImp (x, n, m1, ms, s, xs, xncs) =>
SOME (L'.DDatatypeImp (x, n, m1, ms, s, xs,
map (fn (x, n, co) =>
(x, n, Option.map explifyCon co)) xncs), loc)
| L.DVal (x, n, t, e) => SOME (L'.DVal (x, n, explifyCon t, explifyExp e), loc)
| L.DValRec vis => SOME (L'.DValRec (map (fn (x, n, t, e) => (x, n, explifyCon t, explifyExp e)) vis), loc)
| L.DSgn (x, n, sgn) => SOME (L'.DSgn (x, n, explifySgn sgn), loc)
| L.DStr (x, n, sgn, str) => SOME (L'.DStr (x, n, explifySgn sgn, explifyStr str), loc)
| L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc)
| L.DConstraint (c1, c2) => NONE
| L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc)
| L.DTable (nt, x, n, c, pe, pc, ce, cc) =>
SOME (L'.DTable (nt, x, n, explifyCon c,
explifyExp pe, explifyCon pc,
explifyExp ce, explifyCon cc), loc)
| L.DView (nt, x, n, e, c) =>
SOME (L'.DView (nt, x, n, explifyExp e, explifyCon c), loc)
| L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc)
| L.DDatabase s => SOME (L'.DDatabase s, loc)
| L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc)
| L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc)
| L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc)
| L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc)
| L.DOnError v => SOME (L'.DOnError v, loc)
| L.DFfi (x, n, modes, t) => SOME (L'.DFfi (x, n, modes, explifyCon t), loc)
and explifyStr (str, loc) =
case str of
L.StrConst ds => (L'.StrConst (List.mapPartial explifyDecl ds), loc)
| L.StrVar n => (L'.StrVar n, loc)
| L.StrProj (str, s) => (L'.StrProj (explifyStr str, s), loc)
| L.StrFun (m, n, dom, ran, str) => (L'.StrFun (m, n, explifySgn dom, explifySgn ran, explifyStr str), loc)
| L.StrApp (str1, str2) => (L'.StrApp (explifyStr str1, explifyStr str2), loc)
| L.StrError => raise Fail ("explifyStr: StrError at " ^ EM.spanToString loc)
val explify = List.mapPartial explifyDecl
end
urweb-20160213+dfsg/src/export.sig 0000664 0000000 0000000 00000003452 12657647235 0016656 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009, 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 EXPORT = sig
datatype effect =
ReadOnly
| ReadCookieWrite
| ReadWrite
datatype export_kind =
Link of effect
| Action of effect
| Rpc of effect
| Extern of effect
val p_effect : effect Print.printer
val p_export_kind : export_kind Print.printer
end
urweb-20160213+dfsg/src/export.sml 0000664 0000000 0000000 00000004271 12657647235 0016667 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009, 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 Export :> EXPORT = struct
open Print.PD
open Print
datatype effect =
ReadOnly
| ReadCookieWrite
| ReadWrite
datatype export_kind =
Link of effect
| Action of effect
| Rpc of effect
| Extern of effect
fun p_effect ef =
case ef of
ReadOnly => string "r"
| ReadCookieWrite => string "rcw"
| ReadWrite => string "rw"
fun p_export_kind ck =
case ck of
Link ef => box [string "link(", p_effect ef, string ")"]
| Action ef => box [string "action(", p_effect ef, string ")"]
| Rpc ef => box [string "rpc(", p_effect ef, string ")"]
| Extern ef => box [string "extern(", p_effect ef, string ")"]
end
urweb-20160213+dfsg/src/fastcgi.sig 0000664 0000000 0000000 00000003021 12657647235 0016745 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2009, 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 FASTCGI = sig
end
urweb-20160213+dfsg/src/fastcgi.sml 0000664 0000000 0000000 00000005367 12657647235 0016775 0 ustar 00root root 0000000 0000000 (* 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 Fastcgi :> FASTCGI = struct
open Settings
open Print.PD Print
val () = addProtocol {name = "fastcgi",
compile = "",
linkStatic = "liburweb_fastcgi.a",
linkDynamic = "-lurweb_fastcgi",
persistent = true,
code = fn () => box [string "void uw_global_custom() {",
newline,
case getSigFile () of
NONE => box []
| SOME sf => box [string "extern char *uw_sig_file;",
newline,
string "uw_sig_file = \"",
string sf,
string "\";",
newline],
string "uw_setup_limits();",
newline,
string "}",
newline]}
end
urweb-20160213+dfsg/src/fuse.sig 0000664 0000000 0000000 00000003060 12657647235 0016272 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 FUSE = sig
val fuse : Mono.file -> Mono.file
end
urweb-20160213+dfsg/src/fuse.sml 0000664 0000000 0000000 00000014736 12657647235 0016317 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 Fuse :> FUSE = struct
open Mono
structure U = MonoUtil
structure IM = IntBinaryMap
fun returnsString (t, loc) =
let
fun rs (t, loc) =
case t of
TFfi ("Basis", "string") => SOME ([], (TRecord [], loc))
| TFun (dom, ran) =>
(case rs ran of
NONE => NONE
| SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc)))
| _ => NONE
in
case t of
TFun (dom, ran) =>
(case rs ran of
NONE => NONE
| SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc)))
| _ => NONE
end
fun fuse file =
let
fun doDecl (d as (_, loc), (funcs, maxName)) =
let
exception GetBody
fun doVi ((x, n, t, e, s), funcs, maxName) =
case returnsString t of
NONE => (NONE, funcs, maxName)
| SOME (args, t') =>
let
fun getBody (e, args) =
case (#1 e, args) of
(_, []) => (e, [])
| (EAbs (x, t, _, e), _ :: args) =>
let
val (body, args') = getBody (e, args)
in
(body, (x, t) :: args')
end
| _ => raise GetBody
val (body, args) = getBody (e, args)
val body = MonoOpt.optExp (EWrite body, loc)
val (body, _) = foldr (fn ((x, dom), (body, ran)) =>
((EAbs (x, dom, ran, body), loc),
(TFun (dom, ran), loc)))
(body, (TRecord [], loc)) args
in
(SOME (x, maxName, t', body, s),
IM.insert (funcs, n, maxName),
maxName + 1)
end
handle GetBody => (NONE, funcs, maxName)
val (d, funcs, maxName) =
case #1 d of
DVal vi =>
let
val (vi', funcs, maxName) = doVi (vi, funcs, maxName)
in
(case vi' of
NONE => d
| SOME vi' => (DValRec [vi, vi'], loc),
funcs, maxName)
end
| DValRec vis =>
let
val (vis', funcs, maxName) =
foldl (fn (vi, (vis', funcs, maxName)) =>
let
val (vi', funcs, maxName) = doVi (vi, funcs, maxName)
in
(case vi' of
NONE => vis'
| SOME vi' => vi' :: vis',
funcs, maxName)
end)
([], funcs, maxName) vis
in
((DValRec (vis @ vis'), loc), funcs, maxName)
end
| _ => (d, funcs, maxName)
fun exp e =
case e of
EWrite e' =>
let
fun unravel (e, loc) =
case e of
ENamed n =>
(case IM.find (funcs, n) of
NONE => NONE
| SOME n' => SOME (ENamed n', loc))
| EApp (e1, e2) =>
(case unravel e1 of
NONE => NONE
| SOME e1 => SOME (EApp (e1, e2), loc))
| _ => NONE
in
case unravel e' of
NONE => e
| SOME (e', _) => e'
end
| _ => e
in
(U.Decl.map {typ = fn x => x,
exp = exp,
decl = fn x => x}
d,
(funcs, maxName))
end
val (ds, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) (#1 file)
in
(ds, #2 file)
end
end
urweb-20160213+dfsg/src/http.sig 0000664 0000000 0000000 00000003016 12657647235 0016310 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2009, 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 HTTP = sig
end
urweb-20160213+dfsg/src/http.sml 0000664 0000000 0000000 00000005405 12657647235 0016325 0 ustar 00root root 0000000 0000000 (* 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 Http :> HTTP = struct
open Settings
open Print.PD Print
val () = addProtocol {name = "http",
compile = "",
linkStatic = "liburweb_http.a",
linkDynamic = "-lurweb_http",
persistent = true,
code = fn () => box [string "void uw_global_custom() {",
newline,
case getSigFile () of
NONE => box []
| SOME sf => box [string "extern char *uw_sig_file;",
newline,
string "uw_sig_file = \"",
string sf,
string "\";",
newline],
string "uw_setup_limits();",
newline,
string "}",
newline]}
val () = setProtocol "http"
end
urweb-20160213+dfsg/src/iflow.sig 0000664 0000000 0000000 00000003107 12657647235 0016452 0 ustar 00root root 0000000 0000000 (* Copyright (c) 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.
*)
signature IFLOW = sig
val check : Mono.file -> unit
val debug : bool ref
end
urweb-20160213+dfsg/src/iflow.sml 0000664 0000000 0000000 00000273371 12657647235 0016477 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2010, 2013, 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 Iflow :> IFLOW = struct
open Mono
open Sql
structure IS = IntBinarySet
structure IM = IntBinaryMap
structure SK = struct
type ord_key = string
val compare = String.compare
end
structure SS = BinarySetFn(SK)
structure SM = BinaryMapFn(SK)
val writers = ["htmlifyInt_w",
"htmlifyFloat_w",
"htmlifyString_w",
"htmlifyBool_w",
"htmlifyTime_w",
"attrifyInt_w",
"attrifyFloat_w",
"attrifyString_w",
"attrifyChar_w",
"urlifyInt_w",
"urlifyFloat_w",
"urlifyString_w",
"urlifyBool_w",
"set_cookie"]
val writers = SS.addList (SS.empty, writers)
local
open Print
val string = PD.string
in
fun p_func f =
string (case f of
DtCon0 s => s
| DtCon1 s => s
| UnCon s => "un" ^ s
| Other s => s)
fun p_exp e =
case e of
Const p => Prim.p_t p
| Var n => string ("x" ^ Int.toString n)
| Lvar n => string ("X" ^ Int.toString n)
| Func (f, es) => box [p_func f,
string "(",
p_list p_exp es,
string ")"]
| Recd xes => box [string "{",
p_list (fn (x, e) => box [string x,
space,
string "=",
space,
p_exp e]) xes,
string "}"]
| Proj (e, x) => box [p_exp e,
string ("." ^ x)]
fun p_bop s es =
case es of
[e1, e2] => box [p_exp e1,
space,
string s,
space,
p_exp e2]
| _ => raise Fail "Iflow.p_bop"
fun p_reln r es =
case r of
Known =>
(case es of
[e] => box [string "known(",
p_exp e,
string ")"]
| _ => raise Fail "Iflow.p_reln: Known")
| Sql s => box [string (s ^ "("),
p_list p_exp es,
string ")"]
| PCon0 s => box [string (s ^ "("),
p_list p_exp es,
string ")"]
| PCon1 s => box [string (s ^ "("),
p_list p_exp es,
string ")"]
| Cmp Eq => p_bop "=" es
| Cmp Ne => p_bop "<>" es
| Cmp Lt => p_bop "<" es
| Cmp Le => p_bop "<=" es
| Cmp Gt => p_bop ">" es
| Cmp Ge => p_bop ">=" es
fun p_prop p =
case p of
True => string "True"
| False => string "False"
| Unknown => string "??"
| Lop (And, p1, p2) => box [string "(",
p_prop p1,
string ")",
space,
string "&&",
space,
string "(",
p_prop p2,
string ")"]
| Lop (Or, p1, p2) => box [string "(",
p_prop p1,
string ")",
space,
string "||",
space,
string "(",
p_prop p2,
string ")"]
| Reln (r, es) => p_reln r es
| Cond (e, p) => box [string "(",
p_exp e,
space,
string "==",
space,
p_prop p,
string ")"]
end
fun isKnown e =
case e of
Const _ => true
| Func (_, es) => List.all isKnown es
| Recd xes => List.all (isKnown o #2) xes
| Proj (e, _) => isKnown e
| _ => false
fun simplify unif =
let
fun simplify e =
case e of
Const _ => e
| Var _ => e
| Lvar n =>
(case IM.find (unif, n) of
NONE => e
| SOME e => simplify e)
| Func (f, es) => Func (f, map simplify es)
| Recd xes => Recd (map (fn (x, e) => (x, simplify e)) xes)
| Proj (e, s) => Proj (simplify e, s)
in
simplify
end
datatype atom =
AReln of reln * exp list
| ACond of exp * prop
fun p_atom a =
p_prop (case a of
AReln x => Reln x
| ACond x => Cond x)
(* Congruence closure *)
structure Cc :> sig
type database
exception Contradiction
val database : unit -> database
val clear : database -> unit
val assert : database * atom -> unit
val check : database * atom -> bool
val p_database : database Print.printer
val builtFrom : database * {Base : exp list, Derived : exp} -> bool
val p_repOf : database -> exp Print.printer
end = struct
local
val count = ref 0
in
fun nodeId () =
let
val n = !count
in
count := n + 1;
n
end
end
exception Contradiction
exception Undetermined
structure CM = BinaryMapFn(struct
type ord_key = Prim.t
val compare = Prim.compare
end)
datatype node = Node of {Id : int,
Rep : node ref option ref,
Cons : node ref SM.map ref,
Variety : variety,
Known : bool ref,
Ge : Int64.int option ref}
and variety =
Dt0 of string
| Dt1 of string * node ref
| Prim of Prim.t
| Recrd of node ref SM.map ref * bool
| Nothing
type representative = node ref
type database = {Vars : representative IM.map ref,
Consts : representative CM.map ref,
Con0s : representative SM.map ref,
Records : (representative SM.map * representative) list ref,
Funcs : ((string * representative list) * representative) list ref}
fun database () = {Vars = ref IM.empty,
Consts = ref CM.empty,
Con0s = ref SM.empty,
Records = ref [],
Funcs = ref []}
fun clear (t : database) = (#Vars t := IM.empty;
#Consts t := CM.empty;
#Con0s t := SM.empty;
#Records t := [];
#Funcs t := [])
fun unNode n =
case !n of
Node r => r
open Print
val string = PD.string
val newline = PD.newline
fun p_rep n =
case !(#Rep (unNode n)) of
SOME n => p_rep n
| NONE =>
box [string (Int.toString (#Id (unNode n)) ^ ":"),
space,
case #Variety (unNode n) of
Nothing => string "?"
| Dt0 s => string ("Dt0(" ^ s ^ ")")
| Dt1 (s, n) => box[string ("Dt1(" ^ s ^ ","),
space,
p_rep n,
string ")"]
| Prim p => Prim.p_t p
| Recrd (ref m, b) => box [string "{",
p_list (fn (x, n) => box [string x,
space,
string "=",
space,
p_rep n]) (SM.listItemsi m),
string "}",
if b then
box [space,
string "(complete)"]
else
box []],
if !(#Known (unNode n)) then
string " (known)"
else
box [],
case !(#Ge (unNode n)) of
NONE => box []
| SOME n => string (" (>= " ^ Int64.toString n ^ ")")]
fun p_database (db : database) =
box [string "Vars:",
newline,
p_list_sep newline (fn (i, n) => box [string ("x" ^ Int.toString i),
space,
string "=",
space,
p_rep n]) (IM.listItemsi (!(#Vars db)))]
fun repOf (n : representative) : representative =
case !(#Rep (unNode n)) of
NONE => n
| SOME r =>
let
val r = repOf r
in
#Rep (unNode n) := SOME r;
r
end
fun markKnown r =
let
val r = repOf r
in
(*Print.preface ("markKnown", p_rep r);*)
if !(#Known (unNode r)) then
()(*TextIO.print "Already known\n"*)
else
(#Known (unNode r) := true;
SM.app markKnown (!(#Cons (unNode r)));
case #Variety (unNode r) of
Dt1 (_, r) => markKnown r
| Recrd (xes, _) => SM.app markKnown (!xes)
| _ => ())
end
fun representative (db : database, e) =
let
fun rep e =
case e of
Const p => (case CM.find (!(#Consts db), p) of
SOME r => repOf r
| NONE =>
let
val r = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = ref SM.empty,
Variety = Prim p,
Known = ref true,
Ge = ref (case p of
Prim.Int n => SOME n
| _ => NONE)})
in
#Consts db := CM.insert (!(#Consts db), p, r);
r
end)
| Var n => (case IM.find (!(#Vars db), n) of
SOME r => repOf r
| NONE =>
let
val r = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = ref SM.empty,
Variety = Nothing,
Known = ref false,
Ge = ref NONE})
in
#Vars db := IM.insert (!(#Vars db), n, r);
r
end)
| Lvar _ => raise Undetermined
| Func (DtCon0 f, []) => (case SM.find (!(#Con0s db), f) of
SOME r => repOf r
| NONE =>
let
val r = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = ref SM.empty,
Variety = Dt0 f,
Known = ref true,
Ge = ref NONE})
in
#Con0s db := SM.insert (!(#Con0s db), f, r);
r
end)
| Func (DtCon0 _, _) => raise Fail "Iflow.rep: DtCon0"
| Func (DtCon1 f, [e]) =>
let
val r = rep e
in
case SM.find (!(#Cons (unNode r)), f) of
SOME r => repOf r
| NONE =>
let
val r' = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = ref SM.empty,
Variety = Dt1 (f, r),
Known = ref (!(#Known (unNode r))),
Ge = ref NONE})
in
#Cons (unNode r) := SM.insert (!(#Cons (unNode r)), f, r');
r'
end
end
| Func (DtCon1 _, _) => raise Fail "Iflow.rep: DtCon1"
| Func (UnCon f, [e]) =>
let
val r = rep e
in
case #Variety (unNode r) of
Dt1 (f', n) => if f' = f then
repOf n
else
raise Contradiction
| Nothing =>
let
val cons = ref SM.empty
val r' = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = cons,
Variety = Nothing,
Known = ref (!(#Known (unNode r))),
Ge = ref NONE})
val r'' = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = #Cons (unNode r),
Variety = Dt1 (f, r'),
Known = #Known (unNode r),
Ge = ref NONE})
in
cons := SM.insert (!cons, f, r'');
#Rep (unNode r) := SOME r'';
r'
end
| _ => raise Contradiction
end
| Func (UnCon _, _) => raise Fail "Iflow.rep: UnCon"
| Func (Other f, es) =>
let
val rs = map rep es
in
case List.find (fn (x : string * representative list, _) => x = (f, rs)) (!(#Funcs db)) of
NONE =>
let
val r = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = ref SM.empty,
Variety = Nothing,
Known = ref (f = "allow"),
Ge = ref NONE})
in
#Funcs db := ((f, rs), r) :: (!(#Funcs db));
r
end
| SOME (_, r) => repOf r
end
| Recd xes =>
let
val xes = map (fn (x, e) => (x, rep e)) xes
val len = length xes
in
case List.find (fn (xes', _) =>
SM.numItems xes' = len
andalso List.all (fn (x, n) =>
case SM.find (xes', x) of
NONE => false
| SOME n' => n = repOf n') xes)
(!(#Records db)) of
SOME (_, r) => repOf r
| NONE =>
let
val xes = foldl SM.insert' SM.empty xes
val r' = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = ref SM.empty,
Variety = Recrd (ref xes, true),
Known = ref false,
Ge = ref NONE})
in
#Records db := (xes, r') :: (!(#Records db));
r'
end
end
| Proj (e, f) =>
let
val r = rep e
in
case #Variety (unNode r) of
Recrd (xes, _) =>
(case SM.find (!xes, f) of
SOME r => repOf r
| NONE => let
val r = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = ref SM.empty,
Variety = Nothing,
Known = ref (!(#Known (unNode r))),
Ge = ref NONE})
in
xes := SM.insert (!xes, f, r);
r
end)
| Nothing =>
let
val r' = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = ref SM.empty,
Variety = Nothing,
Known = ref (!(#Known (unNode r))),
Ge = ref NONE})
val r'' = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = #Cons (unNode r),
Variety = Recrd (ref (SM.insert (SM.empty, f, r')), false),
Known = #Known (unNode r),
Ge = ref NONE})
in
#Rep (unNode r) := SOME r'';
r'
end
| _ => raise Contradiction
end
in
rep e
end
fun p_repOf db e = p_rep (representative (db, e))
fun assert (db, a) =
let
fun markEq (r1, r2) =
let
val r1 = repOf r1
val r2 = repOf r2
in
if r1 = r2 then
()
else case (#Variety (unNode r1), #Variety (unNode r2)) of
(Prim p1, Prim p2) => if Prim.equal (p1, p2) then
()
else
raise Contradiction
| (Dt0 f1, Dt0 f2) => if f1 = f2 then
()
else
raise Contradiction
| (Dt1 (f1, r1), Dt1 (f2, r2)) => if f1 = f2 then
markEq (r1, r2)
else
raise Contradiction
| (Recrd (xes1, _), Recrd (xes2, _)) =>
let
fun unif (xes1, xes2) =
SM.appi (fn (x, r1) =>
case SM.find (!xes2, x) of
NONE => xes2 := SM.insert (!xes2, x, r1)
| SOME r2 => markEq (r1, r2)) (!xes1)
in
unif (xes1, xes2);
unif (xes2, xes1)
end
| (Nothing, _) => mergeNodes (r1, r2)
| (_, Nothing) => mergeNodes (r2, r1)
| _ => raise Contradiction
end
and mergeNodes (r1, r2) =
(#Rep (unNode r1) := SOME r2;
if !(#Known (unNode r1)) then
markKnown r2
else
();
if !(#Known (unNode r2)) then
markKnown r1
else
();
#Cons (unNode r2) := SM.unionWith #1 (!(#Cons (unNode r2)), !(#Cons (unNode r1)));
case !(#Ge (unNode r1)) of
NONE => ()
| SOME n1 =>
case !(#Ge (unNode r2)) of
NONE => #Ge (unNode r2) := SOME n1
| SOME n2 => #Ge (unNode r2) := SOME (Int64.max (n1, n2));
compactFuncs ())
and compactFuncs () =
let
fun loop funcs =
case funcs of
[] => []
| (fr as ((f, rs), r)) :: rest =>
let
val rest = List.filter (fn ((f' : string, rs'), r') =>
if f' = f
andalso ListPair.allEq (fn (r1, r2) =>
repOf r1 = repOf r2)
(rs, rs') then
(markEq (r, r');
false)
else
true) rest
in
fr :: loop rest
end
in
#Funcs db := loop (!(#Funcs db))
end
in
case a of
ACond _ => ()
| AReln x =>
case x of
(Known, [e]) =>
((*Print.prefaces "Before" [("e", p_exp e),
("db", p_database db)];*)
markKnown (representative (db, e))(*;
Print.prefaces "After" [("e", p_exp e),
("db", p_database db)]*))
| (PCon0 f, [e]) =>
let
val r = representative (db, e)
in
case #Variety (unNode r) of
Dt0 f' => if f = f' then
()
else
raise Contradiction
| Nothing =>
(case SM.find (!(#Con0s db), f) of
SOME r' => markEq (r, r')
| NONE =>
let
val r' = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = ref SM.empty,
Variety = Dt0 f,
Known = ref false,
Ge = ref NONE})
in
#Rep (unNode r) := SOME r';
#Con0s db := SM.insert (!(#Con0s db), f, r')
end)
| _ => raise Contradiction
end
| (PCon1 f, [e]) =>
let
val r = representative (db, e)
in
case #Variety (unNode r) of
Dt1 (f', e') => if f = f' then
()
else
raise Contradiction
| Nothing =>
let
val cons = ref SM.empty
val r'' = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = cons,
Variety = Nothing,
Known = ref (!(#Known (unNode r))),
Ge = ref NONE})
val r' = ref (Node {Id = nodeId (),
Rep = ref NONE,
Cons = ref SM.empty,
Variety = Dt1 (f, r''),
Known = #Known (unNode r),
Ge = ref NONE})
in
cons := SM.insert (!cons, f, r');
#Rep (unNode r) := SOME r'
end
| _ => raise Contradiction
end
| (Cmp Eq, [e1, e2]) =>
markEq (representative (db, e1), representative (db, e2))
| (Cmp Ge, [e1, e2]) =>
let
val r1 = representative (db, e1)
val r2 = representative (db, e2)
in
case !(#Ge (unNode (repOf r2))) of
NONE => ()
| SOME n2 =>
case !(#Ge (unNode (repOf r1))) of
NONE => #Ge (unNode (repOf r1)) := SOME n2
| SOME n1 => #Ge (unNode (repOf r1)) := SOME (Int64.max (n1, n2))
end
| _ => ()
end handle Undetermined => ()
fun check (db, a) =
(case a of
ACond _ => false
| AReln x =>
case x of
(Known, [e]) =>
let
fun isKnown r =
let
val r = repOf r
in
!(#Known (unNode r))
orelse case #Variety (unNode r) of
Dt1 (_, r) => isKnown r
| Recrd (xes, true) => List.all isKnown (SM.listItems (!xes))
| _ => false
end
val r = representative (db, e)
in
isKnown r
end
| (PCon0 f, [e]) =>
(case #Variety (unNode (representative (db, e))) of
Dt0 f' => f' = f
| _ => false)
| (PCon1 f, [e]) =>
(case #Variety (unNode (representative (db, e))) of
Dt1 (f', _) => f' = f
| _ => false)
| (Cmp Eq, [e1, e2]) =>
let
val r1 = representative (db, e1)
val r2 = representative (db, e2)
in
repOf r1 = repOf r2
end
| (Cmp Ge, [e1, e2]) =>
let
val r1 = representative (db, e1)
val r2 = representative (db, e2)
in
case (!(#Ge (unNode (repOf r1))), #Variety (unNode (repOf r2))) of
(SOME n1, Prim (Prim.Int n2)) => Int64.>= (n1, n2)
| _ => false
end
| _ => false)
handle Undetermined => false
fun builtFrom (db, {Base = bs, Derived = d}) =
let
val bs = map (fn b => representative (db, b)) bs
fun loop d =
let
val d = repOf d
in
!(#Known (unNode d))
orelse List.exists (fn b => repOf b = d) bs
orelse (case #Variety (unNode d) of
Dt0 _ => true
| Dt1 (_, d) => loop d
| Prim _ => true
| Recrd (xes, _) => List.all loop (SM.listItems (!xes))
| Nothing => false)
orelse List.exists (fn r => List.exists (fn b => repOf b = repOf r) bs)
(SM.listItems (!(#Cons (unNode d))))
end
fun decomp e =
case e of
Func (Other _, es) => List.all decomp es
| _ => loop (representative (db, e))
in
decomp d
end handle Undetermined => false
end
val tabs = ref (SM.empty : (string list * string list list) SM.map)
fun patCon pc =
case pc of
PConVar n => "C" ^ Int.toString n
| PConFfi {mod = m, datatyp = d, con = c, ...} => m ^ "." ^ d ^ "." ^ c
type check = exp * ErrorMsg.span
structure St :> sig
val reset : unit -> unit
type stashed
val stash : unit -> stashed
val reinstate : stashed -> unit
type stashedPath
val stashPath : unit -> stashedPath
val reinstatePath : stashedPath -> unit
val nextVar : unit -> int
val assert : atom list -> unit
val addPath : check -> unit
val allowSend : atom list * exp list -> unit
val send : check -> unit
val allowInsert : atom list -> unit
val insert : ErrorMsg.span -> unit
val allowDelete : atom list -> unit
val delete : ErrorMsg.span -> unit
val allowUpdate : atom list -> unit
val update : ErrorMsg.span -> unit
val havocReln : reln -> unit
val havocCookie : string -> unit
val check : atom -> bool
val debug : unit -> unit
end = struct
val hnames = ref 1
type hyps = int * atom list * bool ref
val db = Cc.database ()
val path = ref ([] : ((int * atom list) * check) option ref list)
val hyps = ref (0, [] : atom list, ref false)
val nvar = ref 0
fun setHyps (n', hs) =
let
val (n, _, _) = !hyps
in
if n' = n then
()
else
(hyps := (n', hs, ref false);
Cc.clear db;
app (fn a => Cc.assert (db, a)) hs)
end
fun useKeys () =
let
val changed = ref false
fun findKeys (hyps, acc) =
case hyps of
[] => rev acc
| (a as AReln (Sql tab, [r1])) :: hyps =>
(case SM.find (!tabs, tab) of
NONE => findKeys (hyps, a :: acc)
| SOME (_, []) => findKeys (hyps, a :: acc)
| SOME (_, ks) =>
let
fun finder (hyps, acc) =
case hyps of
[] => rev acc
| (a as AReln (Sql tab', [r2])) :: hyps =>
if tab' = tab andalso
List.exists (List.all (fn f =>
let
val r =
Cc.check (db,
AReln (Cmp Eq, [Proj (r1, f),
Proj (r2, f)]))
in
(*Print.prefaces "Fs"
[("tab",
Print.PD.string tab),
("r1",
p_exp (Proj (r1, f))),
("r2",
p_exp (Proj (r2, f))),
("r",
Print.PD.string
(Bool.toString r))];*)
r
end)) ks then
(changed := true;
Cc.assert (db, AReln (Cmp Eq, [r1, r2]));
finder (hyps, acc))
else
finder (hyps, a :: acc)
| a :: hyps => finder (hyps, a :: acc)
val hyps = finder (hyps, [])
in
findKeys (hyps, a :: acc)
end)
| a :: hyps => findKeys (hyps, a :: acc)
fun loop hs =
let
val hs = findKeys (hs, [])
in
if !changed then
(changed := false;
loop hs)
else
()
end
val (_, hs, _) = !hyps
in
(*print "useKeys\n";*)
loop hs
end
fun complete () =
let
val (_, _, bf) = !hyps
in
if !bf then
()
else
(bf := true;
useKeys ())
end
type stashed = int * ((int * atom list) * check) option ref list * (int * atom list)
fun stash () = (!nvar, !path, (#1 (!hyps), #2 (!hyps)))
fun reinstate (nv, p, h) =
(nvar := nv;
path := p;
setHyps h)
type stashedPath = ((int * atom list) * check) option ref list
fun stashPath () = !path
fun reinstatePath p = path := p
fun nextVar () =
let
val n = !nvar
in
nvar := n + 1;
n
end
fun assert ats =
let
val n = !hnames
val (_, hs, _) = !hyps
in
hnames := n + 1;
hyps := (n, ats @ hs, ref false);
app (fn a => Cc.assert (db, a)) ats
end
fun addPath c = path := ref (SOME ((#1 (!hyps), #2 (!hyps)), c)) :: !path
val sendable = ref ([] : (atom list * exp list) list)
fun checkGoals goals k =
let
fun checkGoals goals unifs =
case goals of
[] => k unifs
| AReln (Sql tab, [Lvar lv]) :: goals =>
let
val saved = stash ()
val (_, hyps, _) = !hyps
fun tryAll unifs hyps =
case hyps of
[] => false
| AReln (Sql tab', [e]) :: hyps =>
(tab' = tab andalso
checkGoals goals (IM.insert (unifs, lv, e)))
orelse tryAll unifs hyps
| _ :: hyps => tryAll unifs hyps
in
tryAll unifs hyps
end
| (g as AReln (r, es)) :: goals =>
(complete ();
(if Cc.check (db, AReln (r, map (simplify unifs) es)) then
true
else
((*Print.preface ("Fail", p_atom (AReln (r, map (simplify unifs) es)));*)
false))
andalso checkGoals goals unifs)
| ACond _ :: _ => false
in
checkGoals goals IM.empty
end
fun buildable (e, loc) =
let
fun doPols pols acc =
case pols of
[] =>
let
val b = Cc.builtFrom (db, {Base = acc, Derived = e})
in
(*Print.prefaces "buildable" [("Base", Print.p_list p_exp acc),
("Derived", p_exp e),
("Hyps", Print.p_list p_atom (#2 (!hyps))),
("Good", Print.PD.string (Bool.toString b))];*)
b
end
| (goals, es) :: pols =>
checkGoals goals (fn unifs => doPols pols (map (simplify unifs) es @ acc))
orelse doPols pols acc
in
if doPols (!sendable) [] then
()
else
let
val (_, hs, _) = !hyps
in
ErrorMsg.errorAt loc "The information flow policy may be violated here.";
Print.prefaces "Situation" [("User learns", p_exp e),
("Hypotheses", Print.p_list p_atom hs),
("E-graph", Cc.p_database db)]
end
end
fun checkPaths () =
let
val (n, hs, _) = !hyps
val hs = (n, hs)
in
app (fn r =>
case !r of
NONE => ()
| SOME (hs, e) =>
(r := NONE;
setHyps hs;
buildable e)) (!path);
setHyps hs
end
fun allowSend v = ((*Print.prefaces "Allow" [("goals", Print.p_list p_atom (#1 v)),
("exps", Print.p_list p_exp (#2 v))];*)
sendable := v :: !sendable)
fun send (e, loc) = ((*Print.preface ("Send[" ^ Bool.toString uk ^ "]", p_exp e);*)
complete ();
checkPaths ();
if isKnown e then
()
else
buildable (e, loc))
fun doable pols (loc : ErrorMsg.span) =
let
val pols = !pols
in
complete ();
if List.exists (fn goals =>
if checkGoals goals (fn _ => true) then
((*Print.prefaces "Match" [("goals", Print.p_list p_atom goals),
("hyps", Print.p_list p_atom (#2 (!hyps)))];*)
true)
else
((*Print.prefaces "No match" [("goals", Print.p_list p_atom goals)(*,
("hyps", Print.p_list p_atom (#2 (!hyps)))*)];*)
false)) pols then
()
else
let
val (_, hs, _) = !hyps
in
ErrorMsg.errorAt loc "The database update policy may be violated here.";
Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs)(*,
("E-graph", Cc.p_database db)*)]
end
end
val insertable = ref ([] : atom list list)
fun allowInsert v = insertable := v :: !insertable
val insert = doable insertable
val updatable = ref ([] : atom list list)
fun allowUpdate v = updatable := v :: !updatable
val update = doable updatable
val deletable = ref ([] : atom list list)
fun allowDelete v = deletable := v :: !deletable
val delete = doable deletable
fun reset () = (Cc.clear db;
path := [];
hyps := (0, [], ref false);
nvar := 0;
sendable := [];
insertable := [];
updatable := [];
deletable := [])
fun havocReln r =
let
val n = !hnames
val (_, hs, _) = !hyps
in
hnames := n + 1;
hyps := (n, List.filter (fn AReln (r', _) => r' <> r | _ => true) hs, ref false)
end
fun havocCookie cname =
let
val cname = "cookie/" ^ cname
val n = !hnames
val (_, hs, _) = !hyps
in
hnames := n + 1;
hyps := (n, List.filter (fn AReln (Cmp Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false)
end
fun check a = Cc.check (db, a)
fun debug () =
let
val (_, hs, _) = !hyps
in
Print.preface ("Hyps", Print.p_list p_atom hs)
end
end
fun removeDups (ls : (string * string) list) =
case ls of
[] => []
| x :: ls =>
let
val ls = removeDups ls
in
if List.exists (fn x' => x' = x) ls then
ls
else
x :: ls
end
fun deinj env e =
case #1 e of
ERel n => SOME (List.nth (env, n))
| EField (e, f) =>
(case deinj env e of
NONE => NONE
| SOME e => SOME (Proj (e, f)))
| EApp ((EFfi mf, _), e) =>
if Settings.isEffectful mf orelse Settings.isBenignEffectful mf then
NONE
else (case deinj env e of
NONE => NONE
| SOME e => SOME (Func (Other (#1 mf ^ "." ^ #2 mf), [e])))
| _ => NONE
fun expIn rv env rvOf =
let
fun expIn e =
let
fun default () = inl (rv ())
in
case e of
SqConst p => inl (Const p)
| SqTrue => inl (Func (DtCon0 "Basis.bool.True", []))
| SqFalse => inl (Func (DtCon0 "Basis.bool.False", []))
| Null => inl (Func (DtCon0 "None", []))
| SqNot e =>
inr (case expIn e of
inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.False", [])])
| inr _ => Unknown)
| Field (v, f) => inl (Proj (rvOf v, f))
| Computed _ => default ()
| Binop (bo, e1, e2) =>
let
val e1 = expIn e1
val e2 = expIn e2
in
inr (case (bo, e1, e2) of
(RCmp c, inl e1, inl e2) => Reln (Cmp c, [e1, e2])
| (RLop l, v1, v2) =>
let
fun pin v =
case v of
inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])])
| inr p => p
in
Lop (l, pin v1, pin v2)
end
| _ => Unknown)
end
| SqKnown e =>
(case expIn e of
inl e => inr (Reln (Known, [e]))
| _ => inr Unknown)
| Inj e =>
inl (case deinj env e of
NONE => rv ()
| SOME e => e)
| SqFunc (f, e) =>
(case expIn e of
inl e => inl (Func (Other f, [e]))
| _ => default ())
| Unmodeled => inl (Func (Other "allow", [rv ()]))
end
in
expIn
end
fun decomp {Save = save, Restore = restore, Add = add} =
let
fun go p k =
case p of
True => (k () handle Cc.Contradiction => ())
| False => ()
| Unknown => ()
| Lop (And, p1, p2) => go p1 (fn () => go p2 k)
| Lop (Or, p1, p2) =>
let
val saved = save ()
in
go p1 k;
restore saved;
go p2 k
end
| Reln x => (add (AReln x); k ())
| Cond x => (add (ACond x); k ())
in
go
end
datatype queryMode =
SomeCol of {New : (string * exp) option, Old : (string * exp) option, Outs : exp list} -> unit
| AllCols of exp -> unit
type 'a doQuery = {
Env : exp list,
NextVar : unit -> exp,
Add : atom -> unit,
Save : unit -> 'a,
Restore : 'a -> unit,
Cont : queryMode
}
fun doQuery (arg : 'a doQuery) (e as (_, loc)) =
let
fun default () = (ErrorMsg.errorAt loc "Information flow checker can't parse SQL query";
Print.preface ("Query", MonoPrint.p_exp MonoEnv.empty e))
in
case parse query e of
NONE => default ()
| SOME q =>
let
fun doQuery q =
case q of
Query1 r =>
let
val new = ref NONE
val old = ref NONE
val rvs = map (fn Table (tab, v) =>
let
val nv = #NextVar arg ()
in
case v of
"New" => new := SOME (tab, nv)
| "Old" => old := SOME (tab, nv)
| _ => ();
(v, nv)
end
| _ => raise Fail "Iflow: not ready for joins or nesteds") (#From r)
fun rvOf v =
case List.find (fn (v', _) => v' = v) rvs of
NONE => raise Fail "Iflow.queryProp: Bad table variable"
| SOME (_, e) => e
val expIn = expIn (#NextVar arg) (#Env arg) rvOf
val saved = #Save arg ()
fun addFrom () = app (fn Table (t, v) => #Add arg (AReln (Sql t, [rvOf v]))
| _ => raise Fail "Iflow: not ready for joins or nesteds") (#From r)
fun usedFields e =
case e of
SqConst _ => []
| SqTrue => []
| SqFalse => []
| Null => []
| SqNot e => usedFields e
| Field (v, f) => [(false, Proj (rvOf v, f))]
| Computed _ => []
| Binop (_, e1, e2) => usedFields e1 @ usedFields e2
| SqKnown _ => []
| Inj e =>
(case deinj (#Env arg) e of
NONE => (ErrorMsg.errorAt loc "Expression injected into SQL is too complicated";
[])
| SOME e => [(true, e)])
| SqFunc (_, e) => usedFields e
| Unmodeled => []
fun normal' () =
case #Cont arg of
SomeCol k =>
let
val sis = map (fn si =>
case si of
SqField (v, f) => Proj (rvOf v, f)
| SqExp (e, f) =>
case expIn e of
inr _ => #NextVar arg ()
| inl e => e) (#Select r)
in
k {New = !new, Old = !old, Outs = sis}
end
| AllCols k =>
let
val (ts, es) =
foldl (fn (si, (ts, es)) =>
case si of
SqField (v, f) =>
let
val fs = getOpt (SM.find (ts, v), SM.empty)
in
(SM.insert (ts, v, SM.insert (fs, f, Proj (rvOf v, f))), es)
end
| SqExp (e, f) =>
let
val e =
case expIn e of
inr _ => #NextVar arg ()
| inl e => e
in
(ts, SM.insert (es, f, e))
end)
(SM.empty, SM.empty) (#Select r)
in
k (Recd (map (fn (t, fs) => (t, Recd (SM.listItemsi fs)))
(SM.listItemsi ts)
@ SM.listItemsi es))
end
fun doWhere final =
(addFrom ();
case #Where r of
NONE => final ()
| SOME e =>
let
val p = case expIn e of
inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])])
| inr p => p
val saved = #Save arg ()
in
decomp {Save = #Save arg, Restore = #Restore arg, Add = #Add arg}
p (fn () => final () handle Cc.Contradiction => ());
#Restore arg saved
end)
handle Cc.Contradiction => ()
fun normal () = doWhere normal'
in
(case #Select r of
[SqExp (Binop (RCmp bo, Count, SqConst (Prim.Int 0)), f)] =>
(case bo of
Gt =>
(case #Cont arg of
SomeCol _ => ()
| AllCols k =>
let
fun answer e = k (Recd [(f, e)])
val saved = #Save arg ()
val () = (answer (Func (DtCon0 "Basis.bool.False", [])))
handle Cc.Contradiction => ()
in
#Restore arg saved;
(*print "True time!\n";*)
doWhere (fn () => answer (Func (DtCon0 "Basis.bool.True", [])));
#Restore arg saved
end)
| _ => normal ())
| _ => normal ())
before #Restore arg saved
end
| Union (q1, q2) =>
let
val saved = #Save arg ()
in
doQuery q1;
#Restore arg saved;
doQuery q2;
#Restore arg saved
end
in
doQuery q
end
end
fun evalPat env e (pt, _) =
case pt of
PVar _ => e :: env
| PPrim _ => env
| PCon (_, pc, NONE) => (St.assert [AReln (PCon0 (patCon pc), [e])]; env)
| PCon (_, pc, SOME pt) =>
let
val env = evalPat env (Func (UnCon (patCon pc), [e])) pt
in
St.assert [AReln (PCon1 (patCon pc), [e])];
env
end
| PRecord xpts =>
foldl (fn ((x, pt, _), env) => evalPat env (Proj (e, x)) pt) env xpts
| PNone _ => (St.assert [AReln (PCon0 "None", [e])]; env)
| PSome (_, pt) =>
let
val env = evalPat env (Func (UnCon "Some", [e])) pt
in
St.assert [AReln (PCon1 "Some", [e])];
env
end
datatype arg_mode = Fixed | Decreasing | Arbitrary
type rfun = {args : arg_mode list, tables : SS.set, cookies : SS.set, body : Mono.exp}
val rfuns = ref (IM.empty : rfun IM.map)
fun evalExp env (e as (_, loc)) k =
let
(*val () = St.debug ()*)
(*val () = Print.preface ("evalExp", MonoPrint.p_exp MonoEnv.empty e)*)
fun default () = k (Var (St.nextVar ()))
fun doFfi (m, s, es) =
if m = "Basis" andalso SS.member (writers, s) then
let
fun doArgs es =
case es of
[] =>
(if s = "set_cookie" then
case es of
[_, (cname, _), _, _, _] =>
(case #1 cname of
EPrim (Prim.String (_, cname)) =>
St.havocCookie cname
| _ => ())
| _ => ()
else
();
k (Recd []))
| (e, _) :: es =>
evalExp env e (fn e => (St.send (e, loc); doArgs es))
in
doArgs es
end
else if Settings.isEffectful (m, s) andalso not (Settings.isBenignEffectful (m, s)) then
default ()
else
let
fun doArgs (es, acc) =
case es of
[] => k (Func (Other (m ^ "." ^ s), rev acc))
| (e, _) :: es =>
evalExp env e (fn e => doArgs (es, e :: acc))
in
doArgs (es, [])
end
in
case #1 e of
EPrim p => k (Const p)
| ERel n => k (List.nth (env, n))
| ENamed _ => default ()
| ECon (_, pc, NONE) => k (Func (DtCon0 (patCon pc), []))
| ECon (_, pc, SOME e) => evalExp env e (fn e => k (Func (DtCon1 (patCon pc), [e])))
| ENone _ => k (Func (DtCon0 "None", []))
| ESome (_, e) => evalExp env e (fn e => k (Func (DtCon1 "Some", [e])))
| EFfi _ => default ()
| EFfiApp ("Basis", "rand", []) =>
let
val e = Var (St.nextVar ())
in
St.assert [AReln (Known, [e])];
k e
end
| EFfiApp x => doFfi x
| EApp ((EFfi (m, s), _), e) => doFfi (m, s, [(e, (TRecord [], loc))])
| EApp (e1 as (EError _, _), _) => evalExp env e1 k
| EApp (e1, e2) =>
let
fun adefault () = (ErrorMsg.errorAt loc "Excessively fancy function call";
Print.preface ("Call", MonoPrint.p_exp MonoEnv.empty e);
default ())
fun doArgs (e, args) =
case #1 e of
EApp (e1, e2) => doArgs (e1, e2 :: args)
| ENamed n =>
(case IM.find (!rfuns, n) of
NONE => adefault ()
| SOME rf =>
if length (#args rf) <> length args then
adefault ()
else
let
val () = (SS.app (St.havocReln o Sql) (#tables rf);
SS.app St.havocCookie (#cookies rf))
val saved = St.stash ()
fun doArgs (args, modes, env') =
case (args, modes) of
([], []) => (evalExp env' (#body rf) (fn _ => ());
St.reinstate saved;
default ())
| (arg :: args, mode :: modes) =>
evalExp env arg (fn arg =>
let
val v = case mode of
Arbitrary => Var (St.nextVar ())
| Fixed => arg
| Decreasing =>
let
val v = Var (St.nextVar ())
in
if St.check (AReln (Known, [arg])) then
St.assert [(AReln (Known, [v]))]
else
();
v
end
in
doArgs (args, modes, v :: env')
end)
| _ => raise Fail "Iflow.doArgs: Impossible"
in
doArgs (args, #args rf, [])
end)
| _ => adefault ()
in
doArgs (e, [])
end
| EAbs _ => default ()
| EUnop (s, e1) => evalExp env e1 (fn e1 => k (Func (Other s, [e1])))
| EBinop (_, s, e1, e2) => evalExp env e1 (fn e1 => evalExp env e2 (fn e2 => k (Func (Other s, [e1, e2]))))
| ERecord xets =>
let
fun doFields (xes, acc) =
case xes of
[] => k (Recd (rev acc))
| (x, e, _) :: xes =>
evalExp env e (fn e => doFields (xes, (x, e) :: acc))
in
doFields (xets, [])
end
| EField (e, s) => evalExp env e (fn e => k (Proj (e, s)))
| ECase (e, pes, {result = res, ...}) =>
evalExp env e (fn e =>
if List.all (fn (_, (EWrite (EPrim _, _), _)) => true
| _ => false) pes then
(St.send (e, loc);
k (Recd []))
else
(St.addPath (e, loc);
app (fn (p, pe) =>
let
val saved = St.stash ()
in
let
val env = evalPat env e p
in
evalExp env pe k;
St.reinstate saved
end
handle Cc.Contradiction => St.reinstate saved
end) pes))
| EStrcat (e1, e2) =>
evalExp env e1 (fn e1 =>
evalExp env e2 (fn e2 =>
k (Func (Other "cat", [e1, e2]))))
| EError (e, _) => evalExp env e (fn e => St.send (e, loc))
| EReturnBlob {blob = NONE, ...} => raise Fail "Iflow doesn't support blob optimization"
| EReturnBlob {blob = SOME b, mimeType = m, ...} =>
evalExp env b (fn b =>
(St.send (b, loc);
evalExp env m
(fn m => St.send (m, loc))))
| ERedirect (e, _) =>
evalExp env e (fn e => St.send (e, loc))
| EWrite e =>
evalExp env e (fn e => (St.send (e, loc);
k (Recd [])))
| ESeq (e1, e2) =>
let
val path = St.stashPath ()
in
evalExp env e1 (fn _ => (St.reinstatePath path; evalExp env e2 k))
end
| ELet (_, _, e1, e2) =>
evalExp env e1 (fn e1 => evalExp (e1 :: env) e2 k)
| EClosure (n, es) =>
let
fun doArgs (es, acc) =
case es of
[] => k (Func (Other ("Cl" ^ Int.toString n), rev acc))
| e :: es =>
evalExp env e (fn e => doArgs (es, e :: acc))
in
doArgs (es, [])
end
| EQuery {query = q, body = b, initial = i, state = state, ...} =>
evalExp env i (fn i =>
let
val r = Var (St.nextVar ())
val acc = Var (St.nextVar ())
val (ts, cs) = MonoUtil.Exp.fold {typ = fn (_, st) => st,
exp = fn (e, st as (cs, ts)) =>
case e of
EDml (e, _) =>
(case parse dml e of
NONE => st
| SOME c =>
case c of
Insert _ => st
| Delete (tab, _) =>
(cs, SS.add (ts, tab))
| Update (tab, _, _) =>
(cs, SS.add (ts, tab)))
| EFfiApp ("Basis", "set_cookie",
[_, ((EPrim (Prim.String (_, cname)), _), _),
_, _, _]) =>
(SS.add (cs, cname), ts)
| _ => st}
(SS.empty, SS.empty) b
in
case (#1 state, SS.isEmpty ts, SS.isEmpty cs) of
(TRecord [], true, true) => ()
| _ =>
let
val saved = St.stash ()
in
(k i)
handle Cc.Contradiction => ();
St.reinstate saved
end;
SS.app (St.havocReln o Sql) ts;
SS.app St.havocCookie cs;
doQuery {Env = env,
NextVar = Var o St.nextVar,
Add = fn a => St.assert [a],
Save = St.stash,
Restore = St.reinstate,
Cont = AllCols (fn x =>
(St.assert [AReln (Cmp Eq, [r, x])];
evalExp (acc :: r :: env) b k))} q
end)
| EDml (e, _) =>
(case parse dml e of
NONE => (print ("Warning: Information flow checker can't parse DML command at "
^ ErrorMsg.spanToString loc ^ "\n");
default ())
| SOME d =>
case d of
Insert (tab, es) =>
let
val new = St.nextVar ()
val expIn = expIn (Var o St.nextVar) env
(fn _ => raise Fail "Iflow.evalExp: Bad field expression in INSERT [1]")
val es = map (fn (x, e) =>
case expIn e of
inl e => (x, e)
| inr _ => raise Fail "Iflow.evalExp: Bad field expression in INSERT [2]")
es
val saved = St.stash ()
in
St.assert [AReln (Sql (tab ^ "$New"), [Recd es])];
St.insert loc;
St.reinstate saved;
St.assert [AReln (Sql tab, [Recd es])];
k (Recd [])
end
| Delete (tab, e) =>
let
val old = St.nextVar ()
val expIn = expIn (Var o St.nextVar) env
(fn "T" => Var old
| _ => raise Fail "Iflow.evalExp: Bad field expression in DELETE")
val p = case expIn e of
inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean"
| inr p => p
val saved = St.stash ()
in
St.assert [AReln (Sql (tab ^ "$Old"), [Var old]),
AReln (Sql (tab), [Var old])];
decomp {Save = St.stash,
Restore = St.reinstate,
Add = fn a => St.assert [a]} p
(fn () => (St.delete loc;
St.reinstate saved;
St.havocReln (Sql tab);
k (Recd []))
handle Cc.Contradiction => ())
end
| Update (tab, fs, e) =>
let
val new = St.nextVar ()
val old = St.nextVar ()
val expIn = expIn (Var o St.nextVar) env
(fn "T" => Var old
| _ => raise Fail "Iflow.evalExp: Bad field expression in UPDATE")
val fs = map
(fn (x, e) =>
(x, case expIn e of
inl e => e
| inr _ => raise Fail
("Iflow.evalExp: Selecting "
^ "boolean expression")))
fs
val fs' = case SM.find (!tabs, tab) of
NONE => raise Fail "Iflow.evalExp: Updating unknown table"
| SOME (fs', _) => fs'
val fs = foldl (fn (f, fs) =>
if List.exists (fn (f', _) => f' = f) fs then
fs
else
(f, Proj (Var old, f)) :: fs) fs fs'
val p = case expIn e of
inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean"
| inr p => p
val saved = St.stash ()
in
St.assert [AReln (Sql (tab ^ "$New"), [Recd fs]),
AReln (Sql (tab ^ "$Old"), [Var old]),
AReln (Sql tab, [Var old])];
decomp {Save = St.stash,
Restore = St.reinstate,
Add = fn a => St.assert [a]} p
(fn () => (St.update loc;
St.reinstate saved;
St.havocReln (Sql tab);
k (Recd []))
handle Cc.Contradiction => ())
end)
| ENextval (EPrim (Prim.String (_, seq)), _) =>
let
val nv = St.nextVar ()
in
St.assert [AReln (Sql (String.extract (seq, 3, NONE)), [Var nv])];
k (Var nv)
end
| ENextval _ => default ()
| ESetval _ => default ()
| EUnurlify ((EFfiApp ("Basis", "get_cookie", [((EPrim (Prim.String (_, cname)), _), _)]), _), _, _) =>
let
val e = Var (St.nextVar ())
val e' = Func (Other ("cookie/" ^ cname), [])
in
St.assert [AReln (Known, [e]), AReln (Cmp Eq, [e, e'])];
k e
end
| EUnurlify _ => default ()
| EJavaScript _ => default ()
| ESignalReturn _ => default ()
| ESignalBind _ => default ()
| ESignalSource _ => default ()
| EServerCall _ => default ()
| ERecv _ => default ()
| ESleep _ => default ()
| ESpawn _ => default ()
end
datatype var_source = Input of int | SubInput of int | Unknown
structure U = MonoUtil
fun mliftExpInExp by =
U.Exp.mapB {typ = fn t => t,
exp = fn bound => fn e =>
case e of
ERel xn =>
if xn < bound then
e
else
ERel (xn + by)
| _ => e,
bind = fn (bound, U.Exp.RelE _) => bound + 1
| (bound, _) => bound}
fun nameSubexps k (e : Mono.exp) =
let
fun numParams (e : Mono.exp) =
case #1 e of
EStrcat (e1, e2) => numParams e1 + numParams e2
| EPrim (Prim.String _) => 0
| _ => 1
val nps = numParams e
fun getParams (e : Mono.exp) x =
case #1 e of
EStrcat (e1, e2) =>
let
val (ps1, e1') = getParams e1 x
val (ps2, e2') = getParams e2 (x - length ps1)
in
(ps2 @ ps1, (EStrcat (e1', e2'), #2 e))
end
| EPrim (Prim.String _) => ([], e)
| _ =>
let
val (e', k) =
case #1 e of
EFfiApp (m, f, [(e', t)]) =>
if Settings.isEffectful (m, f) orelse Settings.isBenignEffectful (m, f) then
(e, fn x => x)
else
(e', fn e' => (EFfiApp (m, f, [(e', t)]), #2 e))
| ECase (e', ps as
[((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
(EPrim (Prim.String (_, "TRUE")), _)),
((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
(EPrim (Prim.String (_, "FALSE")), _))], q) =>
(e', fn e' => (ECase (e', ps, q), #2 e))
| _ => (e, fn x => x)
in
([e'], k (ERel x, #2 e))
end
val (ps, e') = getParams e (nps - 1)
val string = (TFfi ("Basis", "string"), #2 e)
val (e', _) = foldl (fn (p, (e', liftBy)) =>
((ELet ("p" ^ Int.toString liftBy,
string,
mliftExpInExp liftBy 0 p,
e'), #2 e), liftBy - 1)) (k (nps, e'), nps - 1) ps
in
#1 e'
end
val namer = MonoUtil.File.map {typ = fn t => t,
exp = fn e =>
case e of
EDml (e, fm) =>
nameSubexps (fn (_, e') => (EDml (e', fm), #2 e)) e
| EQuery {exps, tables, state, query, body, initial} =>
nameSubexps (fn (liftBy, e') =>
(EQuery {exps = exps,
tables = tables,
state = state,
query = e',
body = mliftExpInExp liftBy 2 body,
initial = mliftExpInExp liftBy 0 initial},
#2 query)) query
| _ => e,
decl = fn d => d}
fun check (file : file) =
let
val () = (St.reset ();
rfuns := IM.empty)
(*val () = Print.preface ("FilePre", MonoPrint.p_file MonoEnv.empty file)*)
val file = MonoReduce.reduce file
val file = MonoOpt.optimize file
val file = Fuse.fuse file
val file = MonoOpt.optimize file
val file = MonoShake.shake file
val file = namer file
(*val () = Print.preface ("File", MonoPrint.p_file MonoEnv.empty file)*)
val exptd = foldl (fn ((d, _), exptd) =>
case d of
DExport (_, _, n, _, _, _) => IS.add (exptd, n)
| _ => exptd) IS.empty (#1 file)
fun decl (d, loc) =
case d of
DTable (tab, fs, pk, _) =>
let
val ks =
case #1 pk of
EPrim (Prim.String (_, s)) =>
(case String.tokens (fn ch => ch = #"," orelse ch = #" ") s of
[] => []
| pk => [pk])
| _ => []
in
if size tab >= 3 then
tabs := SM.insert (!tabs, String.extract (tab, 3, NONE),
(map #1 fs,
map (map (fn s => str (Char.toUpper (String.sub (s, 3)))
^ String.extract (s, 4, NONE))) ks))
else
raise Fail "Table name does not begin with uw_"
end
| DVal (x, n, _, e, _) =>
let
(*val () = print ("\n=== " ^ x ^ " ===\n\n");*)
val isExptd = IS.member (exptd, n)
val saved = St.stash ()
fun deAbs (e, env, ps) =
case #1 e of
EAbs (_, _, _, e) =>
let
val nv = Var (St.nextVar ())
in
deAbs (e, nv :: env,
if isExptd then
AReln (Known, [nv]) :: ps
else
ps)
end
| _ => (e, env, ps)
val (e, env, ps) = deAbs (e, [], [])
in
St.assert ps;
(evalExp env e (fn _ => ()) handle Cc.Contradiction => ());
St.reinstate saved
end
| DValRec [(x, n, _, e, _)] =>
let
val tables = ref SS.empty
val cookies = ref SS.empty
fun deAbs (e, env, modes) =
case #1 e of
EAbs (_, _, _, e) => deAbs (e, Input (length env) :: env, ref Fixed :: modes)
| _ => (e, env, rev modes)
val (e, env, modes) = deAbs (e, [], [])
fun doExp env (e as (_, loc)) =
case #1 e of
EPrim _ => e
| ERel _ => e
| ENamed _ => e
| ECon (_, _, NONE) => e
| ECon (dk, pc, SOME e) => (ECon (dk, pc, SOME (doExp env e)), loc)
| ENone _ => e
| ESome (t, e) => (ESome (t, doExp env e), loc)
| EFfi _ => e
| EFfiApp (m, f, es) =>
(case (m, f, es) of
("Basis", "set_cookie", [_, ((EPrim (Prim.String (_, cname)), _), _), _, _, _]) =>
cookies := SS.add (!cookies, cname)
| _ => ();
(EFfiApp (m, f, map (fn (e, t) => (doExp env e, t)) es), loc))
| EApp (e1, e2) =>
let
fun default () = (EApp (doExp env e1, doExp env e2), loc)
fun explore (e, args) =
case #1 e of
EApp (e1, e2) => explore (e1, e2 :: args)
| ENamed n' =>
if n' = n then
let
fun doArgs (pos, args, modes) =
case (args, modes) of
((e1, _) :: args, m1 :: modes) =>
(case e1 of
ERel n =>
(case List.nth (env, n) of
Input pos' =>
if pos' = pos then
()
else
m1 := Arbitrary
| SubInput pos' =>
if pos' = pos then
if !m1 = Arbitrary then
()
else
m1 := Decreasing
else
m1 := Arbitrary
| Unknown => m1 := Arbitrary)
| _ => m1 := Arbitrary;
doArgs (pos + 1, args, modes))
| (_ :: _, []) => ()
| ([], ms) => app (fn m => m := Arbitrary) ms
in
doArgs (0, args, modes);
(EFfi ("Basis", "?"), loc)
end
else
default ()
| _ => default ()
in
explore (e, [])
end
| EAbs (x, t1, t2, e) => (EAbs (x, t1, t2, doExp (Unknown :: env) e), loc)
| EUnop (uo, e1) => (EUnop (uo, doExp env e1), loc)
| EBinop (bi, bo, e1, e2) => (EBinop (bi, bo, doExp env e1, doExp env e2), loc)
| ERecord xets => (ERecord (map (fn (x, e, t) => (x, doExp env e, t)) xets), loc)
| EField (e1, f) => (EField (doExp env e1, f), loc)
| ECase (e, pes, ts) =>
let
val source =
case #1 e of
ERel n =>
(case List.nth (env, n) of
Input n => SOME n
| SubInput n => SOME n
| Unknown => NONE)
| _ => NONE
fun doV v =
let
fun doPat (p, env) =
case #1 p of
PVar _ => v :: env
| PPrim _ => env
| PCon (_, _, NONE) => env
| PCon (_, _, SOME p) => doPat (p, env)
| PRecord xpts => foldl (fn ((_, p, _), env) => doPat (p, env)) env xpts
| PNone _ => env
| PSome (_, p) => doPat (p, env)
in
(ECase (e, map (fn (p, e) => (p, doExp (doPat (p, env)) e)) pes, ts), loc)
end
in
case source of
NONE => doV Unknown
| SOME inp => doV (SubInput inp)
end
| EStrcat (e1, e2) => (EStrcat (doExp env e1, doExp env e2), loc)
| EError (e1, t) => (EError (doExp env e1, t), loc)
| EReturnBlob {blob = NONE, mimeType = m, t} =>
(EReturnBlob {blob = NONE, mimeType = doExp env m, t = t}, loc)
| EReturnBlob {blob = SOME b, mimeType = m, t} =>
(EReturnBlob {blob = SOME (doExp env b), mimeType = doExp env m, t = t}, loc)
| ERedirect (e1, t) => (ERedirect (doExp env e1, t), loc)
| EWrite e1 => (EWrite (doExp env e1), loc)
| ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc)
| ELet (x, t, e1, e2) => (ELet (x, t, doExp env e1, doExp (Unknown :: env) e2), loc)
| EClosure (n, es) => (EClosure (n, map (doExp env) es), loc)
| EQuery {exps, tables, state, query, body, initial} =>
(EQuery {exps = exps, tables = tables, state = state,
query = doExp env query,
body = doExp (Unknown :: Unknown :: env) body,
initial = doExp env initial}, loc)
| EDml (e1, mode) =>
(case parse dml e1 of
NONE => ()
| SOME c =>
case c of
Insert _ => ()
| Delete (tab, _) =>
tables := SS.add (!tables, tab)
| Update (tab, _, _) =>
tables := SS.add (!tables, tab);
(EDml (doExp env e1, mode), loc))
| ENextval e1 => (ENextval (doExp env e1), loc)
| ESetval (e1, e2) => (ESetval (doExp env e1, doExp env e2), loc)
| EUnurlify (e1, t, b) => (EUnurlify (doExp env e1, t, b), loc)
| EJavaScript (m, e) => (EJavaScript (m, doExp env e), loc)
| ESignalReturn _ => e
| ESignalBind _ => e
| ESignalSource _ => e
| EServerCall _ => e
| ERecv _ => e
| ESleep _ => e
| ESpawn _ => e
val e = doExp env e
in
rfuns := IM.insert (!rfuns, n, {tables = !tables, cookies = !cookies,
args = map (fn r => !r) modes, body = e})
end
| DValRec _ => ErrorMsg.errorAt loc "Iflow can't check mutually-recursive functions yet."
| DPolicy pol =>
let
val rvN = ref 0
fun rv () =
let
val n = !rvN
in
rvN := n + 1;
Lvar n
end
val atoms = ref ([] : atom list)
fun doQ k = doQuery {Env = [],
NextVar = rv,
Add = fn a => atoms := a :: !atoms,
Save = fn () => !atoms,
Restore = fn ls => atoms := ls,
Cont = SomeCol (fn r => k (rev (!atoms), r))}
fun untab (tab, nams) = List.filter (fn AReln (Sql tab', [Lvar lv]) =>
tab' <> tab
orelse List.all (fn Lvar lv' => lv' <> lv
| _ => false) nams
| _ => true)
in
case pol of
PolClient e =>
doQ (fn (ats, {Outs = es, ...}) => St.allowSend (ats, es)) e
| PolInsert e =>
doQ (fn (ats, {New = SOME (tab, new), ...}) =>
St.allowInsert (AReln (Sql (tab ^ "$New"), [new]) :: untab (tab, [new]) ats)
| _ => raise Fail "Iflow: No New in mayInsert policy") e
| PolDelete e =>
doQ (fn (ats, {Old = SOME (tab, old), ...}) =>
St.allowDelete (AReln (Sql (tab ^ "$Old"), [old]) :: untab (tab, [old]) ats)
| _ => raise Fail "Iflow: No Old in mayDelete policy") e
| PolUpdate e =>
doQ (fn (ats, {New = SOME (tab, new), Old = SOME (_, old), ...}) =>
St.allowUpdate (AReln (Sql (tab ^ "$Old"), [old])
:: AReln (Sql (tab ^ "$New"), [new])
:: untab (tab, [new, old]) ats)
| _ => raise Fail "Iflow: No New or Old in mayUpdate policy") e
| PolSequence e =>
(case #1 e of
EPrim (Prim.String (_, seq)) =>
let
val p = AReln (Sql (String.extract (seq, 3, NONE)), [Lvar 0])
val outs = [Lvar 0]
in
St.allowSend ([p], outs)
end
| _ => ())
end
| _ => ()
in
app decl (#1 file)
end
val check = fn file =>
let
val oldInline = Settings.getMonoInline ()
val oldFull = !MonoReduce.fullMode
in
(Settings.setMonoInline (case Int.maxInt of
NONE => 1000000
| SOME n => n);
MonoReduce.fullMode := true;
check file;
Settings.setMonoInline oldInline)
handle ex => (Settings.setMonoInline oldInline;
MonoReduce.fullMode := oldFull;
raise ex)
end
end
urweb-20160213+dfsg/src/jscomp.sig 0000664 0000000 0000000 00000003306 12657647235 0016626 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008, 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 JSCOMP = sig
val process : Mono.file -> Mono.file
val explainEmbed : bool ref
(* Output verbose error messages about inability to embed server-side
* values in client-side code? *)
end
urweb-20160213+dfsg/src/jscomp.sml 0000664 0000000 0000000 00000204257 12657647235 0016647 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2013, 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 JsComp :> JSCOMP = struct
open Mono
structure EM = ErrorMsg
structure E = MonoEnv
structure U = MonoUtil
structure IS = IntBinarySet
structure IM = IntBinaryMap
structure TM = BinaryMapFn(struct
type ord_key = typ
val compare = U.Typ.compare
end)
val explainEmbed = ref false
type state = {
decls : (string * int * (string * int * typ option) list) list,
script : string list,
included : IS.set,
injectors : int IM.map,
listInjectors : int TM.map,
decoders : int IM.map,
maxName : int
}
fun strcat loc es =
case es of
[] => (EPrim (Prim.String (Prim.Normal, "")), loc)
| [x] => x
| x :: es' => (EStrcat (x, strcat loc es'), loc)
exception CantEmbed of typ
fun inString {needle, haystack} = String.isSubstring needle haystack
fun process (file : file) =
let
val (someTs, nameds) =
foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e))
| ((DValRec vis, _), (someTs, nameds)) =>
(someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e))
nameds vis)
| ((DDatatype dts, _), state as (someTs, nameds)) =>
(foldl (fn ((_, _, cs), someTs) =>
if ElabUtil.classifyDatatype cs = Option then
foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t)
| (_, someTs) => someTs) someTs cs
else
someTs) someTs dts,
nameds)
| (_, state) => state)
(IM.empty, IM.empty) (#1 file)
fun str loc s = (EPrim (Prim.String (Prim.Normal, s)), loc)
fun isNullable (t, _) =
case t of
TOption _ => true
| TList _ => true
| TDatatype (_, ref (Option, _)) => true
| TRecord [] => true
| _ => false
fun quoteExp loc (t : typ) (e, st) =
case #1 t of
TSource => ((EFfiApp ("Basis", "htmlifySource", [(e, t)]), loc), st)
| TRecord [] => (str loc "null", st)
| TRecord [(x, t)] =>
let
val (e, st) = quoteExp loc t ((EField (e, x), loc), st)
in
(strcat loc [str loc ("{_" ^ x ^ ":"),
e,
str loc "}"], st)
end
| TRecord ((x, t) :: xts) =>
let
val (e', st) = quoteExp loc t ((EField (e, x), loc), st)
val (es, st) = ListUtil.foldlMap
(fn ((x, t), st) =>
let
val (e, st) = quoteExp loc t ((EField (e, x), loc), st)
in
(strcat loc [str loc (",_" ^ x ^ ":"), e], st)
end)
st xts
in
(strcat loc (str loc ("{_" ^ x ^ ":")
:: e'
:: es
@ [str loc "}"]), st)
end
| TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [(e, t)]), loc), st)
| TFfi ("Basis", "char") => ((EFfiApp ("Basis", "jsifyChar", [(e, t)]), loc), st)
| TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [(e, t)]), loc), st)
| TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [(e, t)]), loc), st)
| TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [(e, t)]), loc), st)
| TFfi ("Basis", "time") => ((EFfiApp ("Basis", "jsifyTime", [(e, t)]), loc), st)
| TFfi ("Basis", "bool") => ((ECase (e,
[((PCon (Enum, PConFfi {mod = "Basis",
datatyp = "bool",
con = "True",
arg = NONE}, NONE), loc),
str loc "true"),
((PCon (Enum, PConFfi {mod = "Basis",
datatyp = "bool",
con = "False",
arg = NONE}, NONE), loc),
str loc "false")],
{disc = (TFfi ("Basis", "bool"), loc),
result = (TFfi ("Basis", "string"), loc)}), loc),
st)
| TOption t =>
let
val (e', st) = quoteExp loc t ((ERel 0, loc), st)
in
(case #1 e' of
EPrim (Prim.String (_, "ERROR")) => raise Fail "UHOH"
| _ =>
(ECase (e,
[((PNone t, loc),
str loc "null"),
((PSome (t, (PVar ("x", t), loc)), loc),
if isNullable t then
strcat loc [str loc "{v:", e', str loc "}"]
else
e')],
{disc = (TOption t, loc),
result = (TFfi ("Basis", "string"), loc)}), loc),
st)
end
| TList t' =>
(case TM.find (#listInjectors st, t') of
SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
| NONE =>
let
val rt = (TRecord [("1", t'), ("2", t)], loc)
val n' = #maxName st
val st = {decls = #decls st,
script = #script st,
included = #included st,
injectors = #injectors st,
listInjectors = TM.insert (#listInjectors st, t', n'),
decoders = #decoders st,
maxName = n' + 1}
val s = (TFfi ("Basis", "string"), loc)
val (e', st) = quoteExp loc t' ((EField ((ERel 0, loc), "1"), loc), st)
val body = (ECase ((ERel 0, loc),
[((PNone rt, loc),
str loc "null"),
((PSome (rt, (PVar ("x", rt), loc)), loc),
strcat loc [str loc "{_1:",
e',
str loc ",_2:",
(EApp ((ENamed n', loc),
(EField ((ERel 0, loc), "2"), loc)), loc),
str loc "}"])],
{disc = t, result = s}), loc)
val body = (EAbs ("x", t, s, body), loc)
val st = {decls = ("jsify", n', (TFun (t, s), loc),
body, "jsify") :: #decls st,
script = #script st,
included = #included st,
injectors = #injectors st,
listInjectors = #listInjectors st,
decoders= #decoders st,
maxName = #maxName st}
in
((EApp ((ENamed n', loc), e), loc), st)
end)
| TDatatype (n, ref (dk, cs)) =>
(case IM.find (#injectors st, n) of
SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
| NONE =>
let
val n' = #maxName st
val st = {decls = #decls st,
script = #script st,
included = #included st,
injectors = IM.insert (#injectors st, n, n'),
listInjectors = #listInjectors st,
decoders = #decoders st,
maxName = n' + 1}
val (pes, st) = ListUtil.foldlMap
(fn ((_, cn, NONE), st) =>
(((PCon (dk, PConVar cn, NONE), loc),
case dk of
Option => str loc "null"
| _ => str loc (Int.toString cn)),
st)
| ((_, cn, SOME t), st) =>
let
val (e, st) = quoteExp loc t ((ERel 0, loc), st)
in
(((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc),
case dk of
Option =>
if isNullable t then
strcat loc [str loc "{v:",
e,
str loc "}"]
else
e
| _ => strcat loc [str loc ("{n:" ^ Int.toString cn
^ ",v:"),
e,
str loc "}"]),
st)
end)
st cs
val s = (TFfi ("Basis", "string"), loc)
val body = (ECase ((ERel 0, loc), pes,
{disc = t, result = s}), loc)
val body = (EAbs ("x", t, s, body), loc)
val st = {decls = ("jsify", n', (TFun (t, s), loc),
body, "jsify") :: #decls st,
script = #script st,
included = #included st,
injectors = #injectors st,
listInjectors = #listInjectors st,
decoders= #decoders st,
maxName = #maxName st}
in
((EApp ((ENamed n', loc), e), loc), st)
end)
| _ => (if !explainEmbed then
Print.prefaces "Can't embed" [("loc", Print.PD.string (ErrorMsg.spanToString loc)),
("e", MonoPrint.p_exp MonoEnv.empty e),
("t", MonoPrint.p_typ MonoEnv.empty t)]
else
();
raise CantEmbed t)
fun unurlifyExp loc (t : typ, st) =
case #1 t of
TRecord [] => ("(i++,null)", st)
| TFfi ("Basis", "unit") => ("(i++,null)", st)
| TRecord [(x, t)] =>
let
val (e, st) = unurlifyExp loc (t, st)
in
("{_" ^ x ^ ":" ^ e ^ "}",
st)
end
| TRecord ((x, t) :: xts) =>
let
val (e', st) = unurlifyExp loc (t, st)
val (es, st) = ListUtil.foldlMap
(fn ((x, t), st) =>
let
val (e, st) = unurlifyExp loc (t, st)
in
(",_" ^ x ^ ":" ^ e, st)
end)
st xts
in
(String.concat ("{_"
:: x
:: ":"
:: e'
:: es
@ ["}"]), st)
end
| TFfi ("Basis", "string") => ("uu(t[i++])", st)
| TFfi ("Basis", "char") => ("uu(t[i++])", st)
| TFfi ("Basis", "int") => ("parseInt(t[i++])", st)
| TFfi ("Basis", "time") => ("parseInt(t[i++])", st)
| TFfi ("Basis", "float") => ("parseFloat(t[i++])", st)
| TFfi ("Basis", "channel") => ("(t[i++].length > 0 ? parseInt(t[i-1]) : null)", st)
| TFfi ("Basis", "bool") => ("t[i++] == \"1\"", st)
| TSource => ("parseSource(t[i++], t[i++])", st)
| TOption t =>
let
val (e, st) = unurlifyExp loc (t, st)
val e = if isNullable t then
"{v:" ^ e ^ "}"
else
e
in
("(t[i++]==\"Some\"?" ^ e ^ ":null)", st)
end
| TList t =>
let
val (e, st) = unurlifyExp loc (t, st)
in
("uul(function(){return t[i++];},function(){return " ^ e ^ "})", st)
end
| TDatatype (n, ref (dk, cs)) =>
(case IM.find (#decoders st, n) of
SOME n' => ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st)
| NONE =>
let
val n' = #maxName st
val st = {decls = #decls st,
script = #script st,
included = #included st,
injectors = #injectors st,
listInjectors = #listInjectors st,
decoders = IM.insert (#decoders st, n, n'),
maxName = n' + 1}
val (e, st) = foldl (fn ((x, cn, NONE), (e, st)) =>
("x==\"" ^ x ^ "\"?"
^ (case dk of
Option => "null"
| _ => Int.toString cn)
^ ":" ^ e,
st)
| ((x, cn, SOME t), (e, st)) =>
let
val (e', st) = unurlifyExp loc (t, st)
in
("x==\"" ^ x ^ "\"?"
^ (case dk of
Option =>
if isNullable t then
"{v:" ^ e' ^ "}"
else
e'
| _ => "{n:" ^ Int.toString cn ^ ",v:" ^ e' ^ "}")
^ ":" ^ e,
st)
end)
("pf(\"" ^ ErrorMsg.spanToString loc ^ "\")", st) cs
val body = "function _n" ^ Int.toString n' ^ "(t,i){var x=t[i++];var r="
^ e ^ ";return {_1:i,_2:r}}\n\n"
val st = {decls = #decls st,
script = body :: #script st,
included = #included st,
injectors = #injectors st,
listInjectors = #listInjectors st,
decoders = #decoders st,
maxName = #maxName st}
in
("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st)
end)
| _ => (EM.errorAt loc "Don't know how to unurlify type in JavaScript";
Print.prefaces "Can't unurlify" [("t", MonoPrint.p_typ MonoEnv.empty t)];
("ERROR", st))
fun padWith (ch, s, len) =
if size s < len then
padWith (ch, String.str ch ^ s, len - 1)
else
s
val foundJavaScript = ref false
fun jsExp mode outer =
let
val len = length outer
fun jsE inner (e as (_, loc), st) =
let
(*val () = Print.prefaces "jsExp" [("e", MonoPrint.p_exp MonoEnv.empty e),
("loc", Print.PD.string (ErrorMsg.spanToString loc))]*)
val str = str loc
fun patCon pc =
case pc of
PConVar n => str (Int.toString n)
| PConFfi {mod = "Basis", con = "True", ...} => str "true"
| PConFfi {mod = "Basis", con = "False", ...} => str "false"
| PConFfi {con, ...} => str ("\"" ^ con ^ "\"")
fun unsupported s =
(EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
Print.preface ("Code", MonoPrint.p_exp MonoEnv.empty e);
(str "ERROR", st))
val strcat = strcat loc
fun jsPrim p =
let
fun jsChar ch =
case ch of
#"'" =>
if mode = Attribute then
"\\047"
else
"'"
| #"\"" => "\\\""
| #"<" => "\\074"
| #"\\" => "\\\\"
| #"\n" => "\\n"
| #"\r" => "\\r"
| #"\t" => "\\t"
| ch =>
if Char.isPrint ch orelse ord ch >= 128 then
String.str ch
else
"\\" ^ padWith (#"0",
Int.fmt StringCvt.OCT (ord ch),
3)
in
case p of
Prim.String (_, s) =>
str ("\"" ^ String.translate jsChar s ^ "\"")
| Prim.Char ch => str ("\"" ^ jsChar ch ^ "\"")
| _ => str (Prim.toString p)
end
fun jsPat (p, _) =
case p of
PVar _ => str "{/*hoho*/c:\"v\"}"
| PPrim p => strcat [str "{c:\"c\",v:",
jsPrim p,
str "}"]
| PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) =>
str "{c:\"c\",v:true}"
| PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) =>
str "{c:\"c\",v:false}"
| PCon (Option, _, NONE) =>
str "{c:\"c\",v:null}"
| PCon (Option, PConVar n, SOME p) =>
(case IM.find (someTs, n) of
NONE => raise Fail "Jscomp: Not in someTs"
| SOME t =>
strcat [str ("{c:\"s\",n:"
^ (if isNullable t then
"true"
else
"false")
^ ",p:"),
jsPat p,
str "}"])
| PCon (_, pc, NONE) => strcat [str "{c:\"c\",v:",
patCon pc,
str "}"]
| PCon (_, pc, SOME p) => strcat [str "{c:\"1\",n:",
patCon pc,
str ",p:",
jsPat p,
str "}"]
| PRecord xps => strcat [str "{c:\"r\",l:",
foldr (fn ((x, p, _), e) =>
strcat [str ("cons({n:\"" ^ x ^ "\",p:"),
jsPat p,
str "},",
e,
str ")"])
(str "null") xps,
str "}"]
| PNone _ => str "{c:\"c\",v:null}"
| PSome (t, p) => strcat [str ("{c:\"s\",n:"
^ (if isNullable t then
"true"
else
"false")
^ ",p:"),
jsPat p,
str "}"]
val jsifyString = String.translate (fn #"\"" => "\\\""
| #"\\" => "\\\\"
| ch => String.str ch)
fun jsifyStringMulti (n, s) =
case n of
0 => s
| _ => jsifyStringMulti (n - 1, jsifyString s)
fun deStrcat level (all as (e, loc)) =
case e of
EPrim (Prim.String (_, s)) => jsifyStringMulti (level, s)
| EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2
| EFfiApp ("Basis", "jsifyString", [(e, _)]) => "\"" ^ deStrcat (level + 1) e ^ "\""
| _ => (ErrorMsg.errorAt loc "Unexpected non-constant JavaScript code";
Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
"")
val quoteExp = quoteExp loc
in
(*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e),
("inner", Print.PD.string (Int.toString inner))];*)
case #1 e of
EPrim p => (strcat [str "{c:\"c\",v:",
jsPrim p,
str "}"],
st)
| ERel n =>
if n < inner then
(str ("{c:\"v\",n:" ^ Int.toString n ^ "}"), st)
else
let
val n = n - inner
(*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty
(List.nth (outer, n)))]*)
val (e, st) = quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
in
(strcat [str "{c:\"c\",v:",
e,
str "}"], st)
end
| ENamed n =>
let
val st =
if IS.member (#included st, n) then
st
else
case IM.find (nameds, n) of
NONE => raise Fail "Jscomp: Unbound ENamed"
| SOME e =>
let
val st = {decls = #decls st,
script = #script st,
included = IS.add (#included st, n),
injectors = #injectors st,
listInjectors = #listInjectors st,
decoders = #decoders st,
maxName = #maxName st}
val old = e
val (e, st) = jsExp mode [] (e, st)
val e = deStrcat 0 e
val e = String.translate (fn #"'" => "\\'"
| #"\\" => "\\\\"
| ch => String.str ch) e
val sc = "urfuncs[" ^ Int.toString n ^ "] = {c:\"t\",f:'"
^ e ^ "'};\n"
in
(*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old),
("new", MonoPrint.p_exp MonoEnv.empty new)];*)
{decls = #decls st,
script = sc :: #script st,
included = #included st,
injectors = #injectors st,
listInjectors = #listInjectors st,
decoders= #decoders st,
maxName = #maxName st}
end
in
(str ("{c:\"n\",n:" ^ Int.toString n ^ "}"), st)
end
| ECon (Option, _, NONE) => (str "{c:\"c\",v:null}", st)
| ECon (Option, PConVar n, SOME e) =>
let
val (e, st) = jsE inner (e, st)
in
case IM.find (someTs, n) of
NONE => raise Fail "Jscomp: Not in someTs [2]"
| SOME t =>
(if isNullable t then
strcat [str "{c:\"s\",v:",
e,
str "}"]
else
e, st)
end
| ECon (_, pc, NONE) => (strcat [str "{c:\"c\",v:",
patCon pc,
str "}"],
st)
| ECon (_, pc, SOME e) =>
let
val (s, st) = jsE inner (e, st)
in
(strcat [str "{c:\"1\",n:",
patCon pc,
str ",v:",
s,
str "}"], st)
end
| ENone _ => (str "{c:\"c\",v:null}", st)
| ESome (t, e) =>
let
val (e, st) = jsE inner (e, st)
in
(if isNullable t then
strcat [str "{c:\"s\",v:", e, str "}"]
else
e, st)
end
| EFfi k =>
let
val name = case Settings.jsFunc k of
NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k
^ " in JavaScript");
"ERROR")
| SOME s => s
in
(str ("{c:\"c\",v:" ^ name ^ "}"), st)
end
| EFfiApp ("Basis", "sigString", [_]) => (strcat [str "{c:\"c\",v:\"",
e,
str "\"}"], st)
| EFfiApp (m, x, args) =>
let
val name = case Settings.jsFunc (m, x) of
NONE => (EM.errorAt loc ("Unsupported FFI function "
^ m ^ "." ^ x ^ " in JavaScript");
"ERROR")
| SOME s => s
val (e, st) = foldr (fn ((e, _), (acc, st)) =>
let
val (e, st) = jsE inner (e, st)
in
(strcat [str "cons(",
e,
str ",",
acc,
str ")"],
st)
end)
(str "null", st) args
in
(strcat [str ("{c:\"f\",f:" ^ name ^ ",a:"),
e,
str "}"],
st)
end
| EApp (e1, e2) =>
let
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
(strcat [str "{c:\"a\",f:",
e1,
str ",x:",
e2,
str "}"], st)
end
| EAbs (_, _, _, e) =>
let
val (e, st) = jsE (inner + 1) (e, st)
in
(strcat [str "{c:\"l\",b:",
e,
str "}"], st)
end
| EUnop (s, e) =>
let
val name = case s of
"!" => "not"
| "-" => "neg"
| _ => raise Fail ("Jscomp: Unknown unary operator " ^ s)
val (e, st) = jsE inner (e, st)
in
(strcat [str ("{c:\"f\",f:" ^ name ^ ",a:cons("),
e,
str ",null)}"],
st)
end
| EBinop (bi, s, e1, e2) =>
let
val name = case s of
"==" => "eq"
| "!strcmp" => "eq"
| "+" => "plus"
| "-" => "minus"
| "*" => "times"
| "/" => (case bi of Int => "divInt" | NotInt => "div")
| "%" => (case bi of Int => "modInt" | NotInt => "mod")
| "fdiv" => "div"
| "fmod" => "mod"
| "<" => "lt"
| "<=" => "le"
| "strcmp" => "strcmp"
| "powl" => "pow"
| "powf" => "pow"
| _ => raise Fail ("Jscomp: Unknown binary operator " ^ s)
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
(strcat [str ("{c:\"f\",f:" ^ name ^ ",a:cons("),
e1,
str ",cons(",
e2,
str ",null))}"],
st)
end
| ERecord [] => (str "{c:\"c\",v:null}", st)
| ERecord xes =>
let
val (es, st) =
foldr (fn ((x, e, _), (es, st)) =>
let
val (e, st) = jsE inner (e, st)
in
(strcat [str ("cons({n:\"" ^ x ^ "\",v:"),
e,
str "},",
es,
str ")"],
st)
end)
(str "null", st) xes
in
(strcat [str "{c:\"r\",l:",
es,
str "}"],
st)
end
| EField (e', x) =>
let
fun default () =
let
val (e', st) = jsE inner (e', st)
in
(strcat [str "{c:\".\",r:",
e',
str (",f:\"" ^ x ^ "\"}")], st)
end
fun seek (e, xs) =
case #1 e of
ERel n =>
if n < inner then
default ()
else
let
val n = n - inner
val t = List.nth (outer, n)
val t = foldl (fn (x, (TRecord xts, _)) =>
(case List.find (fn (x', _) => x' = x) xts of
NONE => raise Fail "Jscomp: Bad seek [1]"
| SOME (_, t) => t)
| _ => raise Fail "Jscomp: Bad seek [2]")
t xs
val e = (ERel n, loc)
val e = foldl (fn (x, e) => (EField (e, x), loc)) e xs
val (e, st) = quoteExp t (e, st)
in
(strcat [str "{c:\"c\",v:",
e,
str "}"],
st)
end
| EField (e', x) => seek (e', x :: xs)
| _ => default ()
in
seek (e', [x])
end
| ECase (e', pes, _) =>
let
val (e', st) = jsE inner (e', st)
val (ps, st) =
foldr (fn ((p, e), (ps, st)) =>
let
val (e, st) = jsE (inner + E.patBindsN p) (e, st)
in
(strcat [str "cons({p:",
jsPat p,
str ",b:",
e,
str "},",
ps,
str ")"],
st)
end)
(str "null", st) pes
in
(strcat [str "{c:\"m\",e:",
e',
str ",p:",
ps,
str "}"], st)
end
| EStrcat (e1, e2) =>
let
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
(strcat [str "{c:\"f\",f:cat,a:cons(", e1, str ",cons(", e2, str ",null))}"], st)
end
| EError (e, _) =>
let
val (e, st) = jsE inner (e, st)
in
(strcat [str "{c:\"f\",f:er,a:cons(", e, str ",null)}"],
st)
end
| ESeq (e1, e2) =>
let
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
(strcat [str "{c:\";\",e1:", e1, str ",e2:", e2, str "}"], st)
end
| ELet (_, _, e1, e2) =>
let
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE (inner + 1) (e2, st)
in
(strcat [str "{c:\"=\",e1:",
e1,
str ",e2:",
e2,
str "}"], st)
end
| EJavaScript (Source _, e) =>
(foundJavaScript := true;
jsE inner (e, st))
| EJavaScript (_, e) =>
let
val (e, st) = jsE inner (e, st)
in
foundJavaScript := true;
(strcat [str "{c:\"e\",e:",
e,
str "}"],
st)
end
| EWrite _ => unsupported "EWrite"
| EClosure _ => unsupported "EClosure"
| EQuery _ => unsupported "Query"
| EDml _ => unsupported "DML"
| ENextval _ => unsupported "Nextval"
| ESetval _ => unsupported "Nextval"
| EReturnBlob _ => unsupported "EReturnBlob"
| ERedirect (e, _) =>
let
val (e, st) = jsE inner (e, st)
in
(strcat [str "{c:\"f\",f:redirect,a:cons(",
e,
str ",null)}"],
st)
end
| EUnurlify (_, _, true) => unsupported "EUnurlify"
| EUnurlify (e, t, false) =>
let
val (e, st) = jsE inner (e, st)
val (e', st) = unurlifyExp loc (t, st)
in
(strcat [str ("{c:\"f\",f:unurlify,a:cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
^ e' ^ "}},cons("),
e,
str ",null))}"],
st)
end
| ESignalReturn e =>
let
val (e, st) = jsE inner (e, st)
in
(strcat [str "{c:\"f\",f:sr,a:cons(",
e,
str ",null)}"],
st)
end
| ESignalBind (e1, e2) =>
let
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
(strcat [str "{c:\"f\",f:sb,a:cons(",
e1,
str ",cons(",
e2,
str ",null))}"],
st)
end
| ESignalSource e =>
let
val (e, st) = jsE inner (e, st)
in
(strcat [str "{c:\"f\",f:ss,a:cons(",
e,
str ",null)}"],
st)
end
| EServerCall (e, t, eff, fm) =>
let
val (e, st) = jsE inner (e, st)
val (unurl, st) = unurlifyExp loc (t, st)
val lastArg = case fm of
None => "null"
| Error =>
let
val isN = if isNullable t then
"true"
else
"false"
in
"cons({c:\"c\",v:" ^ isN ^ "},null)"
end
in
(strcat [str ("{c:\"f\",f:rc,a:cons({c:\"c\",v:\""
^ Settings.getUrlPrefix ()
^ "\"},cons("),
e,
str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
^ unurl ^ "}},cons({c:\"K\"},cons({c:\"c\",v:"
^ (case eff of
ReadCookieWrite => "true"
| _ => "false")
^ "}," ^ lastArg ^ ")))))}")],
st)
end
| ERecv (e, t) =>
let
val (e, st) = jsE inner (e, st)
val (unurl, st) = unurlifyExp loc (t, st)
in
(strcat [str ("{c:\"f\",f:rv,a:cons("),
e,
str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
^ unurl ^ "}},cons({c:\"K\"},null)))}")],
st)
end
| ESleep e =>
let
val (e, st) = jsE inner (e, st)
in
(strcat [str "{c:\"f\",f:sl,a:cons(",
e,
str ",cons({c:\"K\"},null))}"],
st)
end
| ESpawn e =>
let
val (e, st) = jsE inner (e, st)
in
(strcat [str "{c:\"f\",f:sp,a:cons(",
e,
str ",null)}"],
st)
end
end
in
jsE 0
end
fun patBinds ((p, _), env) =
case p of
PVar (_, t) => t :: env
| PPrim _ => env
| PCon (_, _, NONE) => env
| PCon (_, _, SOME p) => patBinds (p, env)
| PRecord xpts => foldl (fn ((_, p, _), env) => patBinds (p, env)) env xpts
| PNone _ => env
| PSome (_, p) => patBinds (p, env)
fun exp outer (e as (_, loc), st) =
((*Print.preface ("exp", MonoPrint.p_exp MonoEnv.empty e);*)
case #1 e of
EPrim p =>
(case p of
Prim.String (_, s) => if inString {needle = ""])
end
else
NONE)
| _ => (attrs, NONE)
val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"]
fun isSome (e, _) =
case e of
L'.ESome _ => true
| _ => false
val () = if isSome dynClass orelse isSome dynStyle then
if List.exists (fn x => x = tag) dynamics then
E.errorAt loc ("Dynamic tag <" ^ tag ^ "> cannot be combined with 'dynClass' or 'dynStyle' attribute; an additional may be useful")
else
()
else
()
fun tagStart tag' =
let
val t = (L'.TFfi ("Basis", "string"), loc)
val s = strH (String.concat ["<", tag'])
val s = (L'.EStrcat (s,
(L'.ECase (class,
[((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
strH ""),
((L'.PVar ("x", t), loc),
(L'.EStrcat (strH " class=\"",
(L'.EStrcat ((L'.ERel 0, loc),
strH "\""),
loc)), loc))],
{disc = t,
result = t}), loc)), loc)
val s = (L'.EStrcat (s,
(L'.ECase (style,
[((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
strH ""),
((L'.PVar ("x", t), loc),
(L'.EStrcat (strH " style=\"",
(L'.EStrcat ((L'.ERel 0, loc),
strH "\""),
loc)), loc))],
{disc = t,
result = t}), loc)), loc)
val (s, fm) = foldl (fn (("Action", _, _), acc) => acc
| (("Source", _, _), acc) => acc
| (("Data", e, _), (s, fm)) =>
((L'.EStrcat (s,
(L'.EStrcat (
strH " ",
e), loc)), loc),
fm)
| ((x, e, t), (s, fm)) =>
case t of
(L'.TFfi ("Basis", "bool"), _) =>
let
val s' = " " ^ lowercaseFirst x
in
((L'.ECase (e,
[((L'.PCon (L'.Enum,
L'.PConFfi {mod = "Basis",
datatyp = "bool",
con = "True",
arg = NONE},
NONE), loc),
(L'.EStrcat (s,
strH s'), loc)),
((L'.PCon (L'.Enum,
L'.PConFfi {mod = "Basis",
datatyp = "bool",
con = "False",
arg = NONE},
NONE), loc),
s)],
{disc = (L'.TFfi ("Basis", "bool"), loc),
result = (L'.TFfi ("Basis", "string"), loc)}), loc),
fm)
end
| (L'.TFun (dom, _), _) =>
let
val e =
case #1 dom of
L'.TRecord [] => (L'.EApp (e, (L'.ERecord [], loc)), loc)
| _ =>
if String.isPrefix "Onkey" x then
(L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "keyEvent", []), loc)),
loc), (L'.ERecord [], loc)), loc)
else
(L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "mouseEvent", []), loc)),
loc), (L'.ERecord [], loc)), loc)
val s' = " " ^ lowercaseFirst x ^ "='uw_event=event;exec("
in
((L'.EStrcat (s,
(L'.EStrcat (
strH s',
(L'.EStrcat (
(L'.EJavaScript (L'.Attribute, e), loc),
strH ")'"), loc)),
loc)), loc),
fm)
end
| _ =>
let
val fooify =
case x of
"Link" => urlifyExp
| "Action" => urlifyExp
| _ => attrifyExp
val x =
case x of
"Typ" => "Type"
| "Nam" => "Name"
| "Link" => "Href"
| _ => x
val x = String.translate (fn #"_" => "-"
| ch => String.str ch) x
val xp = " " ^ lowercaseFirst x ^ "=\""
val (e, fm) = fooify env fm (e, t)
val e = case (tag, x) of
("coption", "Value") => (L'.EStrcat (strH "x", e), loc)
| _ => e
in
((L'.EStrcat (s,
(L'.EStrcat (strH xp,
(L'.EStrcat (e,
strH "\""),
loc)),
loc)), loc),
fm)
end)
(s, fm) attrs
in
(if tag = "coption" andalso List.all (fn ("Value", _, _) => false | _ => true) attrs then
(L'.EStrcat (s,
strH " value=\"\""), loc)
else
s,
fm)
end
fun input typ =
case targs of
[_, (L.CName name, _)] =>
let
val (ts, fm) = tagStart "input"
in
((L'.EStrcat (ts,
strH (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")), loc), fm)
end
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to input tag")
fun normal (tag, extra) =
let
val (tagStart, fm) = tagStart tag
val tagStart = case extra of
NONE => tagStart
| SOME extra => (L'.EStrcat (tagStart, extra), loc)
val firstWord = Substring.string o #1 o Substring.splitl (fn ch => not (Char.isSpace ch)) o Substring.full
fun normal () =
let
val (xml, fm) = monoExp (env, st, fm) xml
val xml = case extraString of
NONE => xml
| SOME extra => (L'.EStrcat (extra, xml), loc)
in
((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc),
(L'.EStrcat (xml,
strH (String.concat ["", firstWord tag, ">"])), loc)),
loc),
fm)
end
fun isSingleton () =
let
val (bef, aft) = Substring.splitl (not o Char.isSpace) (Substring.full tag)
in
SS.member (singletons, if Substring.isEmpty aft then
tag
else
Substring.string bef)
end
in
case (xml, extraString) of
((L.EApp ((L.ECApp (
(L.ECApp ((L.EFfi ("Basis", "cdata"), _),
_), _),
_), _),
(L.EPrim (Prim.String (_, s)), _)), _), NONE) =>
if CharVector.all Char.isSpace s andalso isSingleton () then
((L'.EStrcat (tagStart, strH " />"), loc), fm)
else
normal ()
| _ => normal ()
end
fun setAttrs jexp =
let
val s = strH (String.concat ["<", tag])
val assgns = List.mapPartial
(fn ("Source", _, _) => NONE
| ("Onchange", e, _) =>
SOME (strcat [str "addOnChange(d,exec(",
(L'.EJavaScript (L'.Script, e), loc),
str "));"])
| (x, e, (L'.TFun ((L'.TRecord [], _), _), _)) =>
SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
(L'.EJavaScript (L'.Script, e), loc),
str ");"])
| (x, e, _) =>
if String.isPrefix "On" x then
let
val arg = if String.isPrefix "Onkey" x then
SOME (L'.EFfiApp ("Basis", "keyEvent", []), loc)
else if String.isSuffix "click" x orelse String.isPrefix "Onmouse" x then
SOME (L'.EFfiApp ("Basis", "mouseEvent", []), loc)
else
NONE
val e = liftExpInExp 0 e
val e = case arg of
NONE => e
| SOME arg => (L'.EApp (e, arg), loc)
val e = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EApp (e, (L'.ERecord [], loc)), loc)), loc)
in
case x of
"Onkeyup" =>
SOME (strcat [str ("((function(c){addOnKeyUp(d,function(ev){window.uw_event=ev?ev:window.event;return c();});})(exec("),
(L'.EJavaScript (L'.Script, e), loc),
str ")));"])
| _ =>
SOME (strcat [str ("((function(c){d." ^ lowercaseFirst x ^ "=function(ev){window.uw_event=ev?ev:window.event;return c();};})(exec("),
(L'.EJavaScript (L'.Script, e), loc),
str ")));"])
end
else
SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
(L'.EJavaScript (L'.Script, e), loc),
str ");"]))
attrs
val t = (L'.TFfi ("Basis", "string"), loc)
val setClass = (L'.ECase (class,
[((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
str ""),
((L'.PVar ("x", t), loc),
(L'.EStrcat (strH "d.className=\"",
(L'.EStrcat ((L'.ERel 0, loc),
strH "\";"), loc)),
loc))],
{disc = (L'.TOption t, loc),
result = t}), loc)
in
case assgns of
[] => strcat [str "var d=",
jexp,
str ";",
setClass]
| _ => strcat (str "var d="
:: jexp
:: str ";"
:: setClass
:: assgns)
end
fun execify e =
case e of
NONE => strH ""
| SOME e =>
let
val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
in
(L'.EStrcat (strH "exec(",
(L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
strH ")"), loc)), loc)
end
fun inTag tag' = case ctxOuter of
(L.CRecord (_, ctx), _) =>
List.exists (fn ((L.CName tag'', _), _) => tag'' = tag'
| _ => false) ctx
| _ => false
fun pnode () = if inTag "Tr" then
"tr"
else if inTag "Table" then
"table"
else
"span"
fun cinput (fallback, dynamic) =
case List.find (fn ("Source", _, _) => true | _ => false) attrs of
NONE =>
let
val (ts, fm) = tagStart "input"
in
((L'.EStrcat (ts,
strH (" type=\"" ^ fallback ^ "\" />")),
loc), fm)
end
| SOME (_, src, _) =>
let
val sc = strcat [str (dynamic ^ "(exec("),
(L'.EJavaScript (L'.Script, src), loc),
str "))"]
val sc = setAttrs sc
in
(strcat [str ""],
fm)
end
val baseAll as (base, fm) =
case tag of
"body" => let
val onload = execify onload
val onunload = execify onunload
val s = (L'.TFfi ("Basis", "string"), loc)
in
normal ("body",
SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload",
[((L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
[((L'.ERecord [], loc),
(L'.TRecord [], loc))]), loc),
onload), loc),
s)]),
loc),
(L'.EFfiApp ("Basis", "maybe_onunload",
[(onunload, s)]),
loc)), loc))
end
| "dyn" =>
let
in
case attrs of
[("Signal", e, _)] =>
((L'.EStrcat
(strH ("")), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad attributes"
end
| "active" =>
(case attrs of
[("Code", e, _)] =>
((L'.EStrcat
(strH ""), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad attributes")
| "script" =>
(case attrs of
[("Code", e, _)] =>
((L'.EStrcat
(strH ""), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad "],
fm))
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to textbox tag"))
| "password" => input "password"
| "email" => input "email"
| "search" => input "search"
| "url_" => input "url"
| "tel" => input "tel"
| "color" => input "color"
| "number" => input "number"
| "range" => input "range"
| "date" => input "date"
| "datetime" => input "datetime"
| "datetime_local" => input "datetime-local"
| "month" => input "month"
| "week" => input "week"
| "timeInput" => input "time"
| "textarea" =>
(case targs of
[_, (L.CName name, _)] =>
let
val (ts, fm) = tagStart "textarea"
val (xml, fm) = monoExp (env, st, fm) xml
in
((L'.EStrcat ((L'.EStrcat (ts,
strH (" name=\"" ^ name ^ "\">")), loc),
(L'.EStrcat (xml,
strH ""), loc)),
loc), fm)
end
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to ltextarea tag"))
| "checkbox" => input "checkbox"
| "upload" => input "file"
| "radio" =>
(case targs of
[_, (L.CName name, _)] =>
monoExp (env, St.setRadioGroup (st, name), fm) xml
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to radio tag"))
| "radioOption" =>
(case St.radioGroup st of
NONE => raise Fail "No name for radioGroup"
| SOME name =>
normal ("input",
SOME (strH (" type=\"radio\" name=\"" ^ name ^ "\""))))
| "select" =>
(case targs of
[_, (L.CName name, _)] =>
let
val (ts, fm) = tagStart "select"
val (xml, fm) = monoExp (env, st, fm) xml
in
((L'.EStrcat ((L'.EStrcat (ts,
strH (" name=\"" ^ name ^ "\">")), loc),
(L'.EStrcat (xml,
strH ""),
loc)),
loc),
fm)
end
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to lselect tag"))
| "ctextbox" => cinput ("text", "inp")
| "cpassword" => cinput ("password", "password")
| "cemail" => cinput ("email", "email")
| "csearch" => cinput ("search", "search")
| "curl" => cinput ("url", "url")
| "ctel" => cinput ("tel", "tel")
| "ccolor" => cinput ("color", "color")
| "cnumber" => cinput ("number", "number")
| "crange" => cinput ("range", "range")
| "cdate" => cinput ("date", "date")
| "cdatetime" => cinput ("datetime", "datetime")
| "cdatetime_local" => cinput ("datetime-local", "datetime_local")
| "cmonth" => cinput ("month", "month")
| "cweek" => cinput ("week", "week")
| "ctime" => cinput ("time", "time")
| "ccheckbox" => cinput ("checkbox", "chk")
| "cselect" =>
(case List.find (fn ("Source", _, _) => true | _ => false) attrs of
NONE =>
let
val (xml, fm) = monoExp (env, st, fm) xml
val (ts, fm) = tagStart "select"
in
(strcat [ts,
str ">",
xml,
str ""],
fm)
end
| SOME (_, src, _) =>
let
val (xml, fm) = monoExp (env, st, fm) xml
val sc = strcat [str "sel(exec(",
(L'.EJavaScript (L'.Script, src), loc),
str "),exec(",
(L'.EJavaScript (L'.Script, xml), loc),
str "))"]
val sc = setAttrs sc
in
(strcat [str ""],
fm)
end)
| "coption" => normal ("option", NONE)
| "ctextarea" =>
(case List.find (fn ("Source", _, _) => true | _ => false) attrs of
NONE =>
let
val (ts, fm) = tagStart "textarea"
in
((L'.EStrcat (ts,
strH " />"),
loc), fm)
end
| SOME (_, src, _) =>
let
val sc = strcat [str "tbx(exec(",
(L'.EJavaScript (L'.Script, src), loc),
str "))"]
val sc = setAttrs sc
in
(strcat [str ""],
fm)
end)
| "tabl" => normal ("table", NONE)
| _ => normal (tag, NONE)
val (dynClass', dynStyle') =
case tag of
"body" => ((L'.ENone dummyTyp, ErrorMsg.dummySpan),
(L'.ENone dummyTyp, ErrorMsg.dummySpan))
| _ => (dynClass, dynStyle)
in
case #1 dynClass' of
L'.ENone _ =>
(case #1 dynStyle' of
L'.ENone _ => baseAll
| L'.ESome (_, ds) => (strcat [str ""],
fm)
| _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
baseAll))
| L'.ESome (_, dc) =>
let
val e = case #1 dynStyle' of
L'.ENone _ => str "null"
| L'.ESome (_, ds) => strcat [str "execD(",
(L'.EJavaScript (L'.Script, ds), loc),
str ")"]
| _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
str "null")
in
(strcat [str ""],
fm)
end
| _ => (E.errorAt loc "Absence/presence of 'dynClass' unknown";
baseAll)
end
| L.EApp (
(L.EApp ((L.ECApp (
(L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
(L.CRecord (_, fields), _)), _),
class), _),
xml) =>
let
fun findSubmit (e, _) =
case e of
L.EApp (
(L.EApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "join"),
_), _), _),
_), _),
_), _),
_), _),
xml1), _),
xml2) => (case findSubmit xml1 of
Error => Error
| NotFound => findSubmit xml2
| Found e =>
case findSubmit xml2 of
NotFound => Found e
| _ => Error)
| L.EApp (
(L.EApp (
(L.EApp (
(L.EApp (
(L.EApp (
(L.EApp (
(L.EApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "tag"),
_), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
_), _),
_), _),
_), _),
_), _),
attrs), _),
_), _),
xml) =>
(case #1 attrs of
L.ERecord xes =>
(case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
| _ => NONE) xes of
NONE => findSubmit xml
| SOME et =>
case findSubmit xml of
NotFound => Found et
| _ => Error)
| _ => findSubmit xml)
| _ => NotFound
val (func, action, fm) = case findSubmit xml of
NotFound => (0, strH "", fm)
| Error => raise Fail "Not ready for multi-submit lforms yet"
| Found (action, actionT) =>
let
val func = case #1 action of
L.EClosure (n, _) => n
| _ => raise Fail "Monoize: Action is not a closure"
val actionT = monoType env actionT
val (action, fm) = monoExp (env, st, fm) action
val (action, fm) = urlifyExp env fm (action, actionT)
in
(func,
(L'.EStrcat (strH " action=\"",
(L'.EStrcat (action,
strH "\""), loc)), loc),
fm)
end
val hasUpload = CoreUtil.Exp.exists {kind = fn _ => false,
con = fn _ => false,
exp = fn e =>
case e of
L.EFfi ("Basis", "upload") => true
| _ => false} xml
val (xml, fm) = monoExp (env, st, fm) xml
val xml =
if IS.member (!readCookie, func) then
let
fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s
| _ => true) fields
fun getSigName () =
let
fun getSigName' n =
let
val s = "Sig" ^ Int.toString n
in
if inFields s then
getSigName' (n + 1)
else
s
end
in
if inFields "Sig" then
getSigName' 0
else
"Sig"
end
val sigName = getSigName ()
val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)
val sigSet = (L'.EStrcat (strH (" "), loc)
in
(L'.EStrcat (sigSet, xml), loc)
end
else
xml
val action = if hasUpload then
(L'.EStrcat (action,
strH " enctype=\"multipart/form-data\""), loc)
else
action
val stt = (L'.TFfi ("Basis", "string"), loc)
val (class, fm) = monoExp (env, st, fm) class
val action = (L'.EStrcat (action,
(L'.ECase (class,
[((L'.PNone stt, loc),
strH ""),
((L'.PSome (stt, (L'.PVar ("x", stt), loc)), loc),
(L'.EStrcat (strH " class=\"",
(L'.EStrcat ((L'.ERel 0, loc),
strH "\""), loc)), loc))],
{disc = (L'.TOption stt, loc),
result = stt}), loc)), loc)
in
((L'.EStrcat ((L'.EStrcat (strH ""), loc)), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
(L.EFfi ("Basis", "subform"), _), _), _), _),
_), _), _), (L.CName nm, loc)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("xml", s, s,
strcat [strH (" "),
(L'.ERel 0, loc),
strH (" ")]),
loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
(L.EFfi ("Basis", "subforms"), _), _), _), _),
_), _), _), (L.CName nm, loc)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("xml", s, s,
strcat [strH (" "),
(L'.ERel 0, loc),
strH (" ")]),
loc),
fm)
end
| L.ECApp ((L.ECApp (
(L.EFfi ("Basis", "entry"), _), _), _), _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("xml", s, s,
strcat [strH (" "),
(L'.ERel 0, loc),
strH (" ")]),
loc),
fm)
end
| L.EApp ((L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "useMore"), _), _), _),
_), _),
_), _),
_), _),
xml) => monoExp (env, st, fm) xml
| L.ECApp ((L.EFfi ("Basis", "error"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t,
(L'.EError ((L'.ERel 0, loc), t), loc)), loc),
fm)
end
| L.EApp (
(L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t), _),
(L.EFfiApp ("Basis", "textBlob", [(e, _)]), _)) =>
let
val t = monoType env t
val un = (L'.TRecord [], loc)
val (e, fm) = monoExp (env, st, fm) e
in
((L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
(L'.EAbs ("_", un, t,
(L'.ESeq ((L'.EFfiApp ("Basis", "clear_page", []), loc),
(L'.ESeq ((L'.EWrite (liftExpInExp 0 (liftExpInExp 0 e)), loc),
(L'.EReturnBlob {blob = NONE,
mimeType = (L'.ERel 1, loc),
t = t}, loc)), loc)), loc)), loc)),
loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
let
val t = monoType env t
val un = (L'.TRecord [], loc)
in
((L'.EAbs ("b", (L'.TFfi ("Basis", "blob"), loc),
(L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc),
(L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
(L'.EAbs ("_", un, t,
(L'.EReturnBlob {blob = SOME (L'.ERel 2, loc),
mimeType = (L'.ERel 1, loc),
t = t}, loc)), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "redirect"), _), t) =>
let
val t = monoType env t
val un = (L'.TRecord [], loc)
in
((L'.EAbs ("url", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
(L'.EAbs ("_", un, t,
(L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "serialize"), _), t) =>
let
val t = monoType env t
val (e, fm) = urlifyExp env fm ((L'.ERel 0, loc), t)
in
((L'.EAbs ("v", t, (L'.TFfi ("Basis", "string"), loc), e), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "deserialize"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t, false),
loc)), loc),
fm)
end
| L.EFfiApp ("Basis", "url", [(e, _)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
val (e, fm) = urlifyExp env fm (e, dummyTyp)
in
((L'.EStrcat (str (Settings.getUrlPrePrefix ()), e), loc), fm)
end
| L.EApp (e1, e2) =>
let
val (e1, fm) = monoExp (env, st, fm) e1
val (e2, fm) = monoExp (env, st, fm) e2
in
((L'.EApp (e1, e2), loc), fm)
end
| L.EAbs (x, dom, ran, e) =>
let
val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
in
((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
end
| L.ECApp (e, _) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
case #1 e of
L'.EFfi _ => (e, fm)
| _ => poly ()
end
| L.ECAbs _ => poly ()
| L.EFfi mx => ((L'.EFfi mx, loc), fm)
| L.EFfiApp (m, x, es) =>
let
val (es, fm) = ListUtil.foldlMap (fn ((e, t), fm) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((e, monoType env t), fm)
end) fm es
in
((L'.EFfiApp (m, x, es), loc), fm)
end
| L.ERecord xes =>
let
val (xes, fm) = ListUtil.foldlMap
(fn ((x, e, t), fm) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((monoName env x,
e,
monoType env t), fm)
end) fm xes
val xes = ListMergeSort.sort (fn ((x, _, _), (y, _, _)) => String.compare (x, y) = GREATER) xes
in
((L'.ERecord xes, loc), fm)
end
| L.EField (e, x, _) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((L'.EField (e, monoName env x), loc), fm)
end
| L.EConcat _ => poly ()
| L.ECut _ => poly ()
| L.ECutMulti _ => poly ()
| L.ECase (e, pes, {disc, result}) =>
let
val (e, fm) = monoExp (env, st, fm) e
val (pes, fm) = ListUtil.foldlMap
(fn ((p, e), fm) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((monoPat env p, e), fm)
end) fm pes
in
((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
end
| L.EWrite e =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
end
| L.EClosure (n, es) =>
let
val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
monoExp (env, st, fm) e)
fm es
val e = (L'.EClosure (n, es), loc)
in
(e, fm)
end
| L.ELet (x, t, e1, e2) =>
let
val t' = monoType env t
val (e1, fm) = monoExp (env, st, fm) e1
val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2
in
((L'.ELet (x, t', e1, e2), loc), fm)
end
| L.EServerCall (n, es, t, fmode) =>
let
val t = monoType env t
val (_, ft, _, name) = Env.lookupENamed env n
val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
fun encodeArgs (es, ft, acc, fm) =
case (es, ft) of
([], _) => (rev acc, fm)
| (e :: es, (L.TFun (dom, ran), _)) =>
let
val (e, fm) = urlifyExp env fm (e, monoType env dom)
in
encodeArgs (es, ran, e
:: str "/"
:: acc, fm)
end
| _ => raise Fail "Monoize: Not enough arguments visible in RPC function type"
val (call, fm) = encodeArgs (es, ft, [], fm)
val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc))
(str name) call
val unit = (L'.TRecord [], loc)
val eff = if IS.member (!readCookie, n) then
L'.ReadCookieWrite
else
L'.ReadOnly
val e = (L'.EServerCall (call, t, eff, fmode), loc)
val e = liftExpInExp 0 e
val e = (L'.EAbs ("_", unit, unit, e), loc)
in
(e, fm)
end
| L.EKAbs _ => poly ()
| L.EKApp _ => poly ()
end
fun monoDecl (env, fm) (all as (d, loc)) =
let
fun poly () =
(E.errorAt loc "Unsupported declaration";
Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
NONE)
fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc)
fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc)
in
case d of
L.DCon _ => NONE
| L.DDatatype [("list", n, [_], [("Nil", _, NONE),
("Cons", _, SOME (L.TRecord (L.CRecord (_,
[((L.CName "1", _),
(L.CRel 0, _)),
((L.CName "2", _),
(L.CApp ((L.CNamed n', _),
(L.CRel 0, _)),
_))]), _), _))])] =>
if n = n' then
NONE
else
poly ()
| L.DDatatype dts =>
let
val env' = Env.declBinds env all
val dts = map (fn (x, n, [], xncs) =>
(x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs)
| _ => (E.errorAt loc "Polymorphic datatype needed too late";
Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
("", 0, []))) dts
val d = (L'.DDatatype dts, loc)
in
SOME (env', fm, [d])
end
| L.DVal (x, n, t, e, s) =>
let
val (e, fm) = monoExp (env, St.empty, fm) e
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DVal (x, n, monoType env t, e, s), loc)])
end
| L.DValRec vis =>
let
val vis = map (fn (x, n, t, e, s) =>
let
fun maybeTransaction (t, e) =
case (#1 t, #1 e) of
(L.CApp ((L.CFfi ("Basis", "transaction"), _), _), _) =>
SOME (L.EAbs ("_",
(L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc),
t,
(L.EApp (CoreEnv.liftExpInExp 0 e,
(L.ERecord [], loc)), loc)), loc)
| (L.TFun (dom, ran), L.EAbs (x, _, _, e)) =>
(case maybeTransaction (ran, e) of
NONE => NONE
| SOME e => SOME (L.EAbs (x, dom, ran, e), loc))
| _ => NONE
in
(x, n, t,
case maybeTransaction (t, e) of
NONE => e
| SOME e => e,
s)
end) vis
val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
val (vis, fm) = ListUtil.foldlMap
(fn ((x, n, t, e, s), fm) =>
let
val (e, fm) = monoExp (env, St.empty, fm) e
in
((x, n, monoType env t, e, s), fm)
end)
fm vis
in
SOME (env,
fm,
[(L'.DValRec vis, loc)])
end
| L.DExport (ek, n, b) =>
let
val (_, t, _, s) = Env.lookupENamed env n
fun unwind (t, args) =
case #1 t of
L.TFun (dom, ran) => unwind (ran, dom :: args)
| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args)
| _ => (rev args, t)
val (ts, ran) = unwind (t, [])
val ts = map (monoType env) ts
val ran = monoType env ran
in
SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran, b), loc)])
end
| L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val s = Settings.mangleSqlTable s
val e_name = str s
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
val (pe, fm) = monoExp (env, St.empty, fm) pe
val (ce, fm) = monoExp (env, St.empty, fm) ce
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DTable (s, xts, pe, ce), loc),
(L'.DVal (x, n, t', e_name, s), loc)])
end
| L.DTable _ => poly ()
| L.DView (x, n, s, e, (L.CRecord (_, xts), _)) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val s = Settings.mangleSqlTable s
val e_name = str s
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
val (e, fm) = monoExp (env, St.empty, fm) e
val e = (L'.EFfiApp ("Basis", "viewify", [(e, t')]), loc)
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DView (s, xts, e), loc),
(L'.DVal (x, n, t', e_name, s), loc)])
end
| L.DView _ => poly ()
| L.DSequence (x, n, s) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val s = Settings.mangleSql s
val e = str s
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DSequence s, loc),
(L'.DVal (x, n, t', e, s), loc)])
end
| L.DDatabase _ => NONE
| L.DCookie (x, n, t, s) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val e = str s
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DCookie s, loc),
(L'.DVal (x, n, t', e, s), loc)])
end
| L.DStyle (x, n, s) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val e = strH s
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DStyle s, loc),
(L'.DVal (x, n, t', e, s), loc)])
end
| L.DTask (e1, e2) =>
let
val (e1, fm) = monoExp (env, St.empty, fm) e1
val (e2, fm) = monoExp (env, St.empty, fm) e2
val un = (L'.TRecord [], loc)
val t = if MonoUtil.Exp.exists {typ = fn _ => false,
exp = fn L'.EFfiApp ("Basis", "periodic", _) =>
(if #persistent (Settings.currentProtocol ()) then
()
else
E.errorAt (#2 e1)
("Periodic tasks aren't allowed in the selected protocol (" ^ #name (Settings.currentProtocol ()) ^ ").");
true)
| _ => false} e1 then
(L'.TFfi ("Basis", "int"), loc)
else
un
val e2 = (L'.EAbs ("$x", t, (L'.TFun (un, un), loc),
(L'.EAbs ("$y", un, un,
(L'.EApp (
(L'.EApp (e2, (L'.ERel 1, loc)), loc),
(L'.ERel 0, loc)), loc)), loc)), loc)
in
SOME (env,
fm,
[(L'.DTask (e1, e2), loc)])
end
| L.DPolicy e =>
let
fun policies (e, fm) =
case #1 e of
L.EFfiApp ("Basis", "also", [(e1, _), (e2, _)]) =>
let
val (ps1, fm) = policies (e1, fm)
val (ps2, fm) = policies (e2, fm)
in
(ps1 @ ps2, fm)
end
| _ =>
let
val (e, make) =
case #1 e of
L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sendClient"), _), _), _), _), _), e) =>
(e, L'.PolClient)
| L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayInsert"), _), _), _), _), _), e) =>
(e, L'.PolInsert)
| L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayDelete"), _), _), _), _), _), e) =>
(e, L'.PolDelete)
| L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) =>
(e, L'.PolUpdate)
| L.EFfiApp ("Basis", "sendOwnIds", [(e, _)]) =>
(e, L'.PolSequence)
| _ => (poly (); (e, L'.PolClient))
val (e, fm) = monoExp (env, St.empty, fm) e
in
([(L'.DPolicy (make e), loc)], fm)
end
val (ps, fm) = policies (e, fm)
in
SOME (env, fm, ps)
end
| L.DOnError n => SOME (env,
fm,
[(L'.DOnError n, loc)])
end
datatype expungable = Client | Channel
fun monoize env file =
let
val () = pvars := RM.empty
(* Calculate which exported functions need cookie signature protection *)
val rcook = foldl (fn ((d, _), rcook) =>
case d of
L.DExport (L.Action L.ReadCookieWrite, n, _) => IS.add (rcook, n)
| L.DExport (L.Rpc L.ReadCookieWrite, n, _) => IS.add (rcook, n)
| _ => rcook)
IS.empty file
val () = readCookie := rcook
val loc = E.dummySpan
val client = (L'.TFfi ("Basis", "client"), loc)
val unit = (L'.TRecord [], loc)
fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc)
fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc)
fun calcClientish xts =
foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
case #1 x of
L.CName x =>
(case #1 t of
L.CFfi ("Basis", "client") =>
(nullable, (x, Client) :: notNullable)
| L.CApp ((L.CFfi ("Basis", "option"), _),
(L.CFfi ("Basis", "client"), _)) =>
((x, Client) :: nullable, notNullable)
| L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
(nullable, (x, Channel) :: notNullable)
| L.CApp ((L.CFfi ("Basis", "option"), _),
(L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
((x, Channel) :: nullable, notNullable)
| _ => st)
| _ => st) ([], []) xts
fun expunger () =
let
val target = (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc)
fun doTable (tab, xts, e) =
case xts of
L.CRecord (_, xts) =>
let
val (nullable, notNullable) = calcClientish xts
fun cond (x, v) =
(L'.EStrcat ((L'.EStrcat (str ("(("
^ Settings.mangleSql x
^ (case v of
Client => ""
| Channel => " >> 32")
^ ") = "),
target), loc),
str ")"), loc)
val e =
foldl (fn ((x, v), e) =>
(L'.ESeq (
(L'.EDml ((L'.EStrcat (
str ("UPDATE "
^ Settings.mangleSql tab
^ " SET "
^ Settings.mangleSql x
^ " = NULL WHERE "),
cond (x, v)), loc), L'.Error), loc),
e), loc))
e nullable
val e =
case notNullable of
[] => e
| eb :: ebs =>
(L'.ESeq (
(L'.EDml ((L'.EStrcat (str ("DELETE FROM "
^ Settings.mangleSql tab
^ " WHERE "),
foldl (fn (eb, s) =>
(L'.EStrcat (str "(",
(L'.EStrcat (s,
(L'.EStrcat (str " OR ",
(L'.EStrcat (cond eb,
str ")"),
loc)), loc)), loc)), loc))
(cond eb)
ebs), loc),
L'.Error), loc),
e), loc)
in
e
end
| _ => e
val e = (L'.ERecord [], loc)
in
foldl (fn ((d, _), e) =>
case d of
L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
| _ => e) e file
end
fun initializer () =
let
fun doTable (tab, xts, e) =
case xts of
L.CRecord (_, xts) =>
let
val (nullable, notNullable) = calcClientish xts
val e =
case nullable of
[] => e
| (x, _) :: ebs =>
(L'.ESeq (
(L'.EDml (str
(foldl (fn ((x, _), s) =>
s ^ ", " ^ Settings.mangleSql x ^ " = NULL")
("UPDATE "
^ Settings.mangleSql tab
^ " SET "
^ Settings.mangleSql x
^ " = NULL")
ebs), L'.Error), loc),
e), loc)
val e =
case notNullable of
[] => e
| eb :: ebs =>
(L'.ESeq (
(L'.EDml (str ("DELETE FROM "
^ Settings.mangleSql tab), L'.Error), loc),
e), loc)
in
e
end
| _ => e
val e = (L'.ERecord [], loc)
in
foldl (fn ((d, _), e) =>
case d of
L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
| _ => e) e file
end
val mname = CoreUtil.File.maxName file + 1
val () = nextPvar := mname
val (_, fm, ds) = List.foldl (fn (d, (env, fm, ds)) =>
case #1 d of
L.DDatabase s =>
let
val (nExp, fm) = Fm.freshName fm
val (nIni, fm) = Fm.freshName fm
val dExp = L'.DVal ("expunger",
nExp,
(L'.TFun (client, unit), loc),
(L'.EAbs ("cli", client, unit, expunger ()), loc),
"expunger")
val dIni = L'.DVal ("initializer",
nIni,
(L'.TFun (unit, unit), loc),
(L'.EAbs ("_", unit, unit, initializer ()), loc),
"initializer")
in
(env, Fm.enter fm, (L'.DDatabase {name = s,
expunge = nExp,
initialize = nIni}, loc)
:: (dExp, loc)
:: (dIni, loc)
:: ds)
end
| _ =>
(pvarDefs := [];
pvarOldDefs := [];
case monoDecl (env, fm) d of
NONE => (env, fm, ds)
| SOME (env, fm, ds') =>
(foldr (fn ((n, cs), env) =>
Env.declBinds env (L.DDatatype [("$poly" ^ Int.toString n,
n,
[],
cs)], loc))
env (!pvarOldDefs),
Fm.enter fm,
case ds' of
[(L'.DDatatype dts, loc)] =>
(L'.DDatatype (dts @ !pvarDefs), loc) :: Fm.decls fm @ ds
| _ =>
ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds)))
(env, Fm.empty mname, []) file
val monoFile = (rev ds, [])
in
pvars := RM.empty;
pvarDefs := [];
pvarOldDefs := [];
MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile + 1);
monoFile
end
end
urweb-20160213+dfsg/src/multimap_fn.sml 0000664 0000000 0000000 00000001346 12657647235 0017661 0 ustar 00root root 0000000 0000000 functor MultimapFn (structure KeyMap : ORD_MAP structure ValSet : ORD_SET) = struct
type key = KeyMap.Key.ord_key
type item = ValSet.item
type itemSet = ValSet.set
type multimap = ValSet.set KeyMap.map
val empty : multimap = KeyMap.empty
fun insertSet (kToVs : multimap, k : key, vs : itemSet) : multimap =
KeyMap.unionWith ValSet.union (kToVs, KeyMap.singleton (k, vs))
fun insert (kToVs : multimap, k : key, v : item) : multimap =
insertSet (kToVs, k, ValSet.singleton v)
fun findSet (kToVs : multimap, k : key) =
case KeyMap.find (kToVs, k) of
SOME vs => vs
| NONE => ValSet.empty
val findList : multimap * key -> item list = ValSet.listItems o findSet
end
urweb-20160213+dfsg/src/mysql.sig 0000664 0000000 0000000 00000003017 12657647235 0016477 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2008-2009, 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 MYSQL = sig
end
urweb-20160213+dfsg/src/mysql.sml 0000664 0000000 0000000 00000250636 12657647235 0016523 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2009-2010, 2015, 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 MySQL :> MYSQL = struct
open Settings
open Print.PD
open Print
fun p_sql_type t =
case t of
Int => "bigint"
| Float => "double"
| String => "longtext"
| Char => "char"
| Bool => "bool"
| Time => "timestamp"
| Blob => "longblob"
| Channel => "bigint"
| Client => "int"
| Nullable t => p_sql_type t
fun p_buffer_type t =
case t of
Int => "MYSQL_TYPE_LONGLONG"
| Float => "MYSQL_TYPE_DOUBLE"
| String => "MYSQL_TYPE_STRING"
| Char => "MYSQL_TYPE_STRING"
| Bool => "MYSQL_TYPE_LONG"
| Time => "MYSQL_TYPE_TIMESTAMP"
| Blob => "MYSQL_TYPE_BLOB"
| Channel => "MYSQL_TYPE_LONGLONG"
| Client => "MYSQL_TYPE_LONG"
| Nullable t => p_buffer_type t
fun p_sql_type_base t =
case t of
Int => "bigint"
| Float => "double"
| String => "longtext"
| Char => "char"
| Bool => "tinyint"
| Time => "timestamp"
| Blob => "longblob"
| Channel => "bigint"
| Client => "int"
| Nullable t => p_sql_type_base t
val ident = String.translate (fn #"'" => "PRIME"
| ch => str ch)
fun checkRel (table, checkNullable) (s, xts) =
let
val sl = CharVector.map Char.toLower s
val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then
String.substring (sl, 1, size sl - 2)
else
sl
val both = "table_name = '" ^ sl ^ "'"
val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE " ^ both
val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE ",
both,
" AND (",
case String.concatWith " OR "
(map (fn (x, t) =>
String.concat ["(LOWER(column_name) = '",
Settings.mangleSqlCatalog
(CharVector.map
Char.toLower (ident x)),
"' AND data_type ",
case p_sql_type_base t of
"bigint" =>
"IN ('bigint', 'int')"
| "longtext" =>
"IN ('longtext', 'varchar')"
| s => "= '" ^ s ^ "'",
if checkNullable then
(" AND is_nullable = '"
^ (if isNotNull t then
"NO"
else
"YES")
^ "'")
else
"",
")"]) xts) of
"" => "FALSE"
| s => s,
")"]
val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE ",
both,
" AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"]
in
box [string "if (mysql_query(conn->conn, \"",
string q,
string "\")) {",
newline,
box [string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Query failed:\\n",
string q,
string "\");",
newline],
string "}",
newline,
newline,
string "if ((res = mysql_store_result(conn->conn)) == NULL) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Result store failed:\\n",
string q,
string "\");",
newline],
string "}",
newline,
newline,
string "if (mysql_num_fields(res) != 1) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Bad column count:\\n",
string q,
string "\");",
newline],
string "}",
newline,
newline,
string "if ((row = mysql_fetch_row(res)) == NULL) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Row fetch failed:\\n",
string q,
string "\");",
newline],
string "}",
newline,
newline,
string "if (strcmp(row[0], \"1\")) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
string sl,
string "' does not exist.\");",
newline],
string "}",
newline,
newline,
string "mysql_free_result(res);",
newline,
newline,
string "if (mysql_query(conn->conn, \"",
string q',
string "\")) {",
newline,
box [string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Query failed:\\n",
string q',
string "\");",
newline],
string "}",
newline,
newline,
string "if ((res = mysql_store_result(conn->conn)) == NULL) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Result store failed:\\n",
string q',
string "\");",
newline],
string "}",
newline,
newline,
string "if (mysql_num_fields(res) != 1) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Bad column count:\\n",
string q',
string "\");",
newline],
string "}",
newline,
newline,
string "if ((row = mysql_fetch_row(res)) == NULL) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Row fetch failed:\\n",
string q',
string "\");",
newline],
string "}",
newline,
newline,
string "if (strcmp(row[0], \"",
string (Int.toString (length xts)),
string "\")) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
string sl,
string "' has the wrong column types.\");",
newline],
string "}",
newline,
newline,
string "mysql_free_result(res);",
newline,
newline,
string "if (mysql_query(conn->conn, \"",
string q'',
string "\")) {",
newline,
box [string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Query failed:\\n",
string q'',
string "\");",
newline],
string "}",
newline,
newline,
string "if ((res = mysql_store_result(conn->conn)) == NULL) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Result store failed:\\n",
string q'',
string "\");",
newline],
string "}",
newline,
newline,
string "if (mysql_num_fields(res) != 1) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Bad column count:\\n",
string q'',
string "\");",
newline],
string "}",
newline,
newline,
string "if ((row = mysql_fetch_row(res)) == NULL) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Row fetch failed:\\n",
string q'',
string "\");",
newline],
string "}",
newline,
newline,
string "if (strcmp(row[0], \"",
string (Int.toString (length xts)),
string "\")) {",
newline,
box [string "mysql_free_result(res);",
newline,
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
string sl,
string "' has extra columns.\");",
newline],
string "}",
newline,
newline,
string "mysql_free_result(res);",
newline]
end
fun init {dbstring, prepared = ss, tables, views, sequences} =
let
val host = ref NONE
val user = ref NONE
val passwd = ref NONE
val db = ref NONE
val port = ref NONE
val unix_socket = ref NONE
fun stringOf r = case !r of
NONE => string "NULL"
| SOME s => box [string "\"",
string (Prim.toCString s),
string "\""]
in
app (fn s =>
case String.fields (fn ch => ch = #"=") s of
[name, value] =>
(case name of
"host" =>
if size value > 0 andalso String.sub (value, 0) = #"/" then
unix_socket := SOME value
else
host := SOME value
| "hostaddr" => host := SOME value
| "port" => port := Int.fromString value
| "dbname" => db := SOME value
| "user" => user := SOME value
| "password" => passwd := SOME value
| _ => ())
| _ => ()) (String.tokens Char.isSpace dbstring);
box [string "typedef struct {",
newline,
box [string "MYSQL *conn;",
newline,
p_list_sepi (box [])
(fn i => fn _ =>
box [string "MYSQL_STMT *p",
string (Int.toString i),
string ";",
newline])
ss],
string "} uw_conn;",
newline,
newline,
string "static void uw_client_init(void) {",
newline,
box [string "uw_sqlfmtInt = \"%lld%n\";",
newline,
string "uw_sqlfmtFloat = \"%.16g%n\";",
newline,
string "uw_Estrings = 0;",
newline,
string "uw_sql_type_annotations = 0;",
newline,
string "uw_sqlsuffixString = \"\";",
newline,
string "uw_sqlsuffixChar = \"\";",
newline,
string "uw_sqlsuffixBlob = \"\";",
newline,
string "uw_sqlfmtUint4 = \"%u%n\";",
newline,
newline,
string "if (mysql_library_init(0, NULL, NULL)) {",
newline,
box [string "fprintf(stderr, \"Could not initialize MySQL library\\n\");",
newline,
string "exit(1);",
newline],
string "}",
newline],
string "}",
newline,
newline,
if #persistent (currentProtocol ()) then
box [string "static void uw_db_validate(uw_context ctx) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
string "MYSQL_RES *res;",
newline,
string "MYSQL_ROW row;",
newline,
newline,
p_list_sep newline (checkRel ("tables", true)) tables,
p_list_sep newline (fn name => checkRel ("tables", true)
(name, [("id", Settings.Client)])) sequences,
p_list_sep newline (checkRel ("views", false)) views,
string "}",
newline,
newline,
string "static void uw_db_prepare(uw_context ctx) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
string "MYSQL_STMT *stmt;",
newline,
newline,
p_list_sepi newline (fn i => fn (s, _) =>
let
fun uhoh this s args =
box [p_list_sepi (box [])
(fn j => fn () =>
box [string
"mysql_stmt_close(conn->p",
string (Int.toString j),
string ");",
newline])
(List.tabulate (i, fn _ => ())),
box (if this then
[string
"mysql_stmt_close(conn->p",
string (Int.toString i),
string ");",
newline]
else
[]),
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"",
string s,
string "\"",
p_list_sep (box []) (fn s => box [string ", ",
string s]) args,
string ");",
newline]
in
box [string "stmt = mysql_stmt_init(conn->conn);",
newline,
string "if (stmt == NULL) {",
newline,
uhoh false "Out of memory allocating prepared statement" [],
string "}",
newline,
string "conn->p",
string (Int.toString i),
string " = stmt;",
newline,
string "if (mysql_stmt_prepare(stmt, \"",
string (Prim.toCString s),
string "\", ",
string (Int.toString (size s)),
string ")) {",
newline,
box [string "char msg[1024];",
newline,
string "strncpy(msg, mysql_stmt_error(stmt), 1024);",
newline,
string "msg[1023] = 0;",
newline,
uhoh true "Error preparing statement: %s" ["msg"]],
string "}",
newline]
end)
ss,
string "}"]
else
box [string "static void uw_db_prepare(uw_context ctx) { }",
newline,
string "static void uw_db_validate(uw_context ctx) { }"],
newline,
newline,
string "static void uw_db_init(uw_context ctx) {",
newline,
string "MYSQL *mysql = mysql_init(NULL);",
newline,
string "uw_conn *conn;",
newline,
string "if (mysql == NULL) uw_error(ctx, FATAL, ",
string "\"libmysqlclient can't allocate a connection.\");",
newline,
string "if (mysql_real_connect(mysql, ",
stringOf host,
string ", ",
stringOf user,
string ", ",
stringOf passwd,
string ", ",
stringOf db,
string ", ",
case !port of
NONE => string "0"
| SOME n => string (Int.toString n),
string ", ",
stringOf unix_socket,
string ", CLIENT_MULTI_STATEMENTS) == NULL) {",
newline,
box [string "char msg[1024];",
newline,
string "strncpy(msg, mysql_error(mysql), 1024);",
newline,
string "msg[1023] = 0;",
newline,
string "mysql_close(mysql);",
newline,
string "uw_error(ctx, FATAL, ",
string "\"Connection to MySQL server failed: %s\", msg);"],
newline,
string "}",
newline,
newline,
string "if (mysql_set_character_set(mysql, \"utf8\")) {",
newline,
box [string "char msg[1024];",
newline,
string "strncpy(msg, mysql_error(mysql), 1024);",
newline,
string "msg[1023] = 0;",
newline,
string "mysql_close(mysql);",
newline,
string "uw_error(ctx, FATAL, ",
string "\"Error setting UTF-8 character set for MySQL connection: %s\", msg);"],
newline,
string "}",
newline,
newline,
string "conn = calloc(1, sizeof(uw_conn));",
newline,
string "conn->conn = mysql;",
newline,
string "uw_set_db(ctx, conn);",
newline,
string "uw_db_validate(ctx);",
newline,
string "uw_db_prepare(ctx);",
newline,
string "}",
newline,
newline,
string "static void uw_db_close(uw_context ctx) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
p_list_sepi (box [])
(fn i => fn _ =>
box [string "if (conn->p",
string (Int.toString i),
string ") mysql_stmt_close(conn->p",
string (Int.toString i),
string ");",
newline])
ss,
string "mysql_close(conn->conn);",
newline,
string "}",
newline,
newline,
string "static int uw_db_begin(uw_context ctx, int could_write) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
newline,
string "return mysql_query(conn->conn, \"SET TRANSACTION ISOLATION LEVEL SERIALIZABLE; BEGIN\") ? 1 : (mysql_next_result(conn->conn), 0);",
newline,
string "}",
newline,
newline,
string "static int uw_db_commit(uw_context ctx) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
string "return mysql_commit(conn->conn);",
newline,
string "}",
newline,
newline,
string "static int uw_db_rollback(uw_context ctx) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
string "return mysql_rollback(conn->conn);",
newline,
string "}",
newline,
newline]
end
fun p_getcol {loc, wontLeakStrings = _, col = i, typ = t} =
let
fun getter t =
case t of
String => box [string "({",
newline,
string "uw_Basis_string s = uw_malloc(ctx, length",
string (Int.toString i),
string " + 1);",
newline,
string "out[",
string (Int.toString i),
string "].buffer = s;",
newline,
string "out[",
string (Int.toString i),
string "].buffer_length = length",
string (Int.toString i),
string " + 1;",
newline,
string "mysql_stmt_fetch_column(stmt, &out[",
string (Int.toString i),
string "], ",
string (Int.toString i),
string ", 0);",
newline,
string "s[length",
string (Int.toString i),
string "] = 0;",
newline,
string "s;",
newline,
string "})"]
| Blob => box [string "({",
newline,
string "uw_Basis_blob b = {length",
string (Int.toString i),
string ", uw_malloc(ctx, length",
string (Int.toString i),
string ")};",
newline,
string "out[",
string (Int.toString i),
string "].buffer = b.data;",
newline,
string "out[",
string (Int.toString i),
string "].buffer_length = length",
string (Int.toString i),
string ";",
newline,
string "mysql_stmt_fetch_column(stmt, &out[",
string (Int.toString i),
string "], ",
string (Int.toString i),
string ", 0);",
newline,
string "b;",
newline,
string "})"]
| Time => box [string "({",
string "MYSQL_TIME *mt = &buffer",
string (Int.toString i),
string ";",
newline,
newline,
string "struct tm t = {mt->second, mt->minute, mt->hour, mt->day, mt->month-1, mt->year - 1900, 0, 0, -1};",
newline,
string "uw_Basis_time res = {mktime(&t), 0};",
newline,
string "res;",
newline,
string "})"]
| Channel => box [string "({",
string "uw_Basis_channel ch = {buffer",
string (Int.toString i),
string " >> 32, buffer",
string (Int.toString i),
string " & 0xFFFFFFFF};",
newline,
string "ch;",
newline,
string "})"]
| _ => box [string "buffer",
string (Int.toString i)]
in
case t of
Nullable t => box [string "(is_null",
string (Int.toString i),
string " ? NULL : ",
case t of
String => getter t
| _ => box [string "({",
newline,
string (p_sql_ctype t),
space,
string "*tmp = uw_malloc(ctx, sizeof(",
string (p_sql_ctype t),
string "));",
newline,
string "*tmp = ",
getter t,
string ";",
newline,
string "tmp;",
newline,
string "})"],
string ")"]
| _ => box [string "(is_null",
string (Int.toString i),
string " ? ",
box [string "({",
string (p_sql_ctype t),
space,
string "tmp;",
newline,
string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #",
string (Int.toString i),
string "\");",
newline,
string "tmp;",
newline,
string "})"],
string " : ",
getter t,
string ")"]
end
fun queryCommon {loc, query, cols, doCols} =
box [string "int n, r;",
newline,
string "MYSQL_BIND out[",
string (Int.toString (length cols)),
string "];",
newline,
p_list_sepi (box []) (fn i => fn t =>
let
fun buffers t =
case t of
String => box [string "unsigned long length",
string (Int.toString i),
string ";",
newline]
| Blob => box [string "unsigned long length",
string (Int.toString i),
string ";",
newline]
| Time => box [string "MYSQL_TIME buffer",
string (Int.toString i),
string ";",
newline]
| Channel => box [string "unsigned long long buffer",
string (Int.toString i),
string ";",
newline]
| _ => box [string (p_sql_ctype t),
space,
string "buffer",
string (Int.toString i),
string ";",
newline]
in
box [string "my_bool is_null",
string (Int.toString i),
string ";",
newline,
case t of
Nullable t => buffers t
| _ => buffers t,
newline]
end) cols,
newline,
string "memset(out, 0, sizeof out);",
newline,
p_list_sepi (box []) (fn i => fn t =>
let
fun buffers t =
case t of
String => box [string "out[",
string (Int.toString i),
string "].length = &length",
string (Int.toString i),
string ";",
newline]
| Char => box [string "out[",
string (Int.toString i),
string "].buffer_length = 1;",
newline,
string "out[",
string (Int.toString i),
string "].buffer = &buffer",
string (Int.toString i),
string ";",
newline]
| Blob => box [string "out[",
string (Int.toString i),
string "].length = &length",
string (Int.toString i),
string ";",
newline]
| _ => box [string "out[",
string (Int.toString i),
string "].buffer = &buffer",
string (Int.toString i),
string ";",
newline]
in
box [string "out[",
string (Int.toString i),
string "].buffer_type = ",
string (p_buffer_type t),
string ";",
newline,
string "out[",
string (Int.toString i),
string "].is_null = &is_null",
string (Int.toString i),
string ";",
newline,
case t of
Nullable t => buffers t
| _ => buffers t,
newline]
end) cols,
newline,
string "if (mysql_stmt_reset(stmt)) {",
box [newline,
string "if (mysql_errno(conn->conn) == 2006) uw_try_reconnecting_and_restarting(ctx);",
newline,
string "uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": Error reseting statement: %s\\n%s\", ",
query,
string ", mysql_error(conn->conn));",
newline],
string "}",
newline,
newline,
string "if (mysql_stmt_execute(stmt)) {",
newline,
box [string "if (mysql_errno(conn->conn) == 1213)",
newline,
box [string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
newline],
newline,
string "uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": Error executing query: %s\\n%s\", ",
query,
string ", mysql_error(conn->conn));",
newline],
string "}",
newline,
newline,
string "if (mysql_stmt_bind_result(stmt, out)) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": Error binding query result: %s\\n%s\", ",
query,
string ", mysql_error(conn->conn));",
newline,
newline,
string "if (mysql_stmt_store_result(stmt)) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": Error storing query result: %s\\n%s\", ",
query,
string ", mysql_error(conn->conn));",
newline,
newline,
string "uw_end_region(ctx);",
newline,
string "while (1) {",
newline,
string "r = mysql_stmt_fetch(stmt);",
newline,
string "if (r != 0 && r != MYSQL_DATA_TRUNCATED) break;",
newline,
doCols p_getcol,
string "}",
newline,
newline,
string "if (r == 1) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": query result fetching failed: %s\\n%s\", ",
query,
string ", mysql_error(conn->conn));",
newline,
newline,
string "if (mysql_stmt_reset(stmt)) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": Error reseting statement: %s\\n%s\", ",
query,
string ", mysql_error(conn->conn));",
newline,
newline]
fun query {loc, cols, doCols} =
box [string "uw_conn *conn = uw_get_db(ctx);",
newline,
string "MYSQL_STMT *stmt = mysql_stmt_init(conn->conn);",
newline,
string "if (stmt == NULL) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": can't allocate temporary prepared statement\");",
newline,
string "uw_push_cleanup(ctx, (void (*)(void *))mysql_stmt_close, stmt);",
newline,
string "if (mysql_stmt_prepare(stmt, query, strlen(query))) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": error preparing statement: %s\\n%s\", query, mysql_error(conn->conn));",
newline,
newline,
queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"},
string "uw_pop_cleanup(ctx);",
newline]
fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
box [string "uw_conn *conn = uw_get_db(ctx);",
newline,
string "MYSQL_BIND in[",
string (Int.toString (length inputs)),
string "];",
newline,
p_list_sepi (box []) (fn i => fn t =>
let
fun buffers t =
case t of
String => box [string "unsigned long in_length",
string (Int.toString i),
string ";",
newline]
| Blob => box [string "unsigned long in_length",
string (Int.toString i),
string ";",
newline]
| Time => box [string "MYSQL_TIME in_buffer",
string (Int.toString i),
string ";",
newline]
| _ => box []
in
box [case t of
Nullable t => box [string "my_bool in_is_null",
string (Int.toString i),
string ";",
newline,
buffers t]
| _ => buffers t,
newline]
end) inputs,
if nested then
box [string "MYSQL_STMT *stmt;",
newline]
else
box [string "MYSQL_STMT *stmt = conn->p",
string (Int.toString id),
string ";",
newline,
newline,
string "if (stmt == NULL) {",
newline],
box [string "stmt = mysql_stmt_init(conn->conn);",
newline,
string "if (stmt == NULL) uw_error(ctx, FATAL, \"Out of memory allocating prepared statement\");",
newline,
if nested then
box [string "uw_push_cleanup(ctx, (void (*)(void *))mysql_stmt_close, stmt);",
newline]
else
box [],
string "if (mysql_stmt_prepare(stmt, \"",
string (Prim.toCString query),
string "\", ",
string (Int.toString (size query)),
string ")) {",
newline,
box [string "char msg[1024];",
newline,
string "strncpy(msg, mysql_stmt_error(stmt), 1024);",
newline,
string "msg[1023] = 0;",
newline,
if nested then
box []
else
box [string "mysql_stmt_close(stmt);",
newline],
string "uw_error(ctx, FATAL, \"Error preparing statement: %s\", msg);",
newline],
string "}",
newline,
if nested then
box []
else
box [string "conn->p",
string (Int.toString id),
string " = stmt;",
newline]],
if nested then
box []
else
box [string "}",
newline],
newline,
string "memset(in, 0, sizeof in);",
newline,
p_list_sepi (box []) (fn i => fn t =>
let
fun buffers t =
case t of
String => box [string "in[",
string (Int.toString i),
string "].buffer = arg",
string (Int.toString (i + 1)),
string ";",
newline,
string "in_length",
string (Int.toString i),
string "= in[",
string (Int.toString i),
string "].buffer_length = strlen(arg",
string (Int.toString (i + 1)),
string ");",
newline,
string "in[",
string (Int.toString i),
string "].length = &in_length",
string (Int.toString i),
string ";",
newline]
| Char => box [string "in[",
string (Int.toString i),
string "].buffer = &arg",
string (Int.toString (i + 1)),
string ";",
newline,
string "in[",
string (Int.toString i),
string "].buffer_length = 1;",
newline]
| Blob => box [string "in[",
string (Int.toString i),
string "].buffer = arg",
string (Int.toString (i + 1)),
string ".data;",
newline,
string "in_length",
string (Int.toString i),
string "= in[",
string (Int.toString i),
string "].buffer_length = arg",
string (Int.toString (i + 1)),
string ".size;",
newline,
string "in[",
string (Int.toString i),
string "].length = &in_length",
string (Int.toString i),
string ";",
newline]
| Time =>
let
fun oneField dst src =
box [string "in_buffer",
string (Int.toString i),
string ".",
string dst,
string " = tms.tm_",
string src,
string ";",
newline]
in
box [string "({",
newline,
string "struct tm tms;",
newline,
string "if (localtime_r(&arg",
string (Int.toString (i + 1)),
string ".seconds, &tms) == NULL) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": error converting to MySQL time\");",
newline,
oneField "year" "year + 1900",
box [string "in_buffer",
string (Int.toString i),
string ".month = tms.tm_mon + 1;",
newline],
oneField "day" "mday",
oneField "hour" "hour",
oneField "minute" "min",
oneField "second" "sec",
newline,
string "in[",
string (Int.toString i),
string "].buffer = &in_buffer",
string (Int.toString i),
string ";",
newline,
string "});",
newline]
end
| Channel => box [string "in_buffer",
string (Int.toString i),
string " = ((unsigned long long)arg",
string (Int.toString (i + 1)),
string ".cli << 32) | arg",
string (Int.toString (i + 1)),
string ".chn;",
newline,
string "in[",
string (Int.toString i),
string "].buffer = &in_buffer",
string (Int.toString i),
string ";",
newline]
| _ => box [string "in[",
string (Int.toString i),
string "].buffer = &arg",
string (Int.toString (i + 1)),
string ";",
newline]
in
box [string "in[",
string (Int.toString i),
string "].buffer_type = ",
string (p_buffer_type t),
string ";",
newline,
case t of
Nullable t => box [string "in[",
string (Int.toString i),
string "].is_null = &in_is_null",
string (Int.toString i),
string ";",
newline,
string "if (arg",
string (Int.toString (i + 1)),
string " == NULL) {",
newline,
box [string "in_is_null",
string (Int.toString i),
string " = 1;",
newline],
string "} else {",
box [case t of
String => box []
| _ =>
box [string (p_sql_ctype t),
space,
string "tmp = *arg",
string (Int.toString (i + 1)),
string ";",
newline,
string (p_sql_ctype t),
space,
string "arg",
string (Int.toString (i + 1)),
string " = tmp;",
newline],
string "in_is_null",
string (Int.toString i),
string " = 0;",
newline,
buffers t,
newline],
string "}",
newline]
| _ => buffers t,
newline]
end) inputs,
newline,
string "if (mysql_stmt_bind_param(stmt, in)) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": error binding parameters\");",
newline,
queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
string (Prim.toCString query),
string "\""]},
if nested then
box [string "uw_pop_cleanup(ctx);",
newline]
else
box []]
fun dmlCommon {loc, dml, mode} =
box [string "if (mysql_stmt_execute(stmt)) {",
box [string "if (mysql_errno(conn->conn) == 2006) uw_try_reconnecting_and_restarting(ctx);",
newline,
string "if (mysql_errno(conn->conn) == 1213)",
newline,
box [string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
newline],
newline,
case mode of
Settings.Error => box [string "uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": Error executing DML: %s\\n%s\", ",
dml,
string ", mysql_error(conn->conn));"]
| Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));",
newline],
string "}",
newline]
fun dml (loc, mode) =
box [string "uw_conn *conn = uw_get_db(ctx);",
newline,
string "MYSQL_STMT *stmt = mysql_stmt_init(conn->conn);",
newline,
string "if (stmt == NULL) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": can't allocate temporary prepared statement\");",
newline,
string "uw_push_cleanup(ctx, (void (*)(void *))mysql_stmt_close, stmt);",
newline,
string "if (mysql_stmt_prepare(stmt, dml, strlen(dml))) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": error preparing statement: %s\\n%s\", dml, mysql_error(conn->conn));",
newline,
newline,
dmlCommon {loc = loc, dml = string "dml", mode = mode},
string "uw_pop_cleanup(ctx);",
newline]
fun dmlPrepared {loc, id, dml, inputs, mode} =
box [string "uw_conn *conn = uw_get_db(ctx);",
newline,
string "MYSQL_BIND in[",
string (Int.toString (length inputs)),
string "];",
newline,
p_list_sepi (box []) (fn i => fn t =>
let
fun buffers t =
case t of
String => box [string "unsigned long in_length",
string (Int.toString i),
string ";",
newline]
| Blob => box [string "unsigned long in_length",
string (Int.toString i),
string ";",
newline]
| Time => box [string "MYSQL_TIME in_buffer",
string (Int.toString i),
string ";",
newline]
| Channel => box [string "unsigned long long in_buffer",
string (Int.toString i),
string ";",
newline]
| _ => box []
in
box [case t of
Nullable t => box [string "my_bool in_is_null",
string (Int.toString i),
string ";",
newline,
buffers t]
| _ => buffers t,
newline]
end) inputs,
string "MYSQL_STMT *stmt = conn->p",
string (Int.toString id),
string ";",
newline,
newline,
string "if (stmt == NULL) {",
newline,
box [string "stmt = mysql_stmt_init(conn->conn);",
newline,
string "if (stmt == NULL) uw_error(ctx, FATAL, \"Out of memory allocating prepared statement\");",
newline,
string "if (mysql_stmt_prepare(stmt, \"",
string (Prim.toCString dml),
string "\", ",
string (Int.toString (size dml)),
string ")) {",
newline,
box [string "char msg[1024];",
newline,
string "strncpy(msg, mysql_stmt_error(stmt), 1024);",
newline,
string "msg[1023] = 0;",
newline,
string "uw_error(ctx, FATAL, \"Error preparing statement: %s\", msg);",
newline],
string "}",
newline,
string "conn->p",
string (Int.toString id),
string " = stmt;",
newline],
string "}",
newline,
newline,
string "memset(in, 0, sizeof in);",
newline,
p_list_sepi (box []) (fn i => fn t =>
let
fun buffers t =
case t of
String => box [string "in[",
string (Int.toString i),
string "].buffer = arg",
string (Int.toString (i + 1)),
string ";",
newline,
string "in_length",
string (Int.toString i),
string "= in[",
string (Int.toString i),
string "].buffer_length = strlen(arg",
string (Int.toString (i + 1)),
string ");",
newline,
string "in[",
string (Int.toString i),
string "].length = &in_length",
string (Int.toString i),
string ";",
newline]
| Blob => box [string "in[",
string (Int.toString i),
string "].buffer = arg",
string (Int.toString (i + 1)),
string ".data;",
newline,
string "in_length",
string (Int.toString i),
string "= in[",
string (Int.toString i),
string "].buffer_length = arg",
string (Int.toString (i + 1)),
string ".size;",
newline,
string "in[",
string (Int.toString i),
string "].length = &in_length",
string (Int.toString i),
string ";",
newline]
| Time =>
let
fun oneField dst src =
box [string "in_buffer",
string (Int.toString i),
string ".",
string dst,
string " = tms.tm_",
string src,
string ";",
newline]
in
box [string "({",
newline,
string "struct tm tms;",
newline,
string "if (localtime_r(&arg",
string (Int.toString (i + 1)),
string ".seconds, &tms) == NULL) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": error converting to MySQL time\");",
newline,
oneField "year" "year + 1900",
oneField "month" "mon + 1",
oneField "day" "mday",
oneField "hour" "hour",
oneField "minute" "min",
oneField "second" "sec",
newline,
string "in[",
string (Int.toString i),
string "].buffer = &in_buffer",
string (Int.toString i),
string ";",
newline,
string "});",
newline]
end
| Channel => box [string "in_buffer",
string (Int.toString i),
string " = ((unsigned long long)arg",
string (Int.toString (i + 1)),
string ".cli << 32) | arg",
string (Int.toString (i + 1)),
string ".chn;",
newline,
string "in[",
string (Int.toString i),
string "].buffer = &in_buffer",
string (Int.toString i),
string ";",
newline]
| _ => box [string "in[",
string (Int.toString i),
string "].buffer = &arg",
string (Int.toString (i + 1)),
string ";",
newline]
in
box [string "in[",
string (Int.toString i),
string "].buffer_type = ",
string (p_buffer_type t),
string ";",
newline,
case t of
Channel => box [string "in[",
string (Int.toString i),
string "].is_unsigned = 1;",
newline]
| _ => box [],
case t of
Nullable t => box [string "in[",
string (Int.toString i),
string "].is_null = &in_is_null",
string (Int.toString i),
string ";",
newline,
string "if (arg",
string (Int.toString (i + 1)),
string " == NULL) {",
newline,
box [string "in_is_null",
string (Int.toString i),
string " = 1;",
newline],
string "} else {",
box [case t of
String => box []
| _ =>
box [string (p_sql_ctype t),
space,
string "tmp = *arg",
string (Int.toString (i + 1)),
string ";",
newline,
string (p_sql_ctype t),
space,
string "arg",
string (Int.toString (i + 1)),
string " = tmp;",
newline],
string "in_is_null",
string (Int.toString i),
string " = 0;",
newline,
buffers t,
newline],
string "}",
newline]
| _ => buffers t,
newline]
end) inputs,
newline,
string "if (mysql_stmt_bind_param(stmt, in)) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": error binding parameters\");",
newline,
dmlCommon {loc = loc, dml = box [string "\"",
string (Prim.toCString dml),
string "\""], mode = mode}]
fun nextval {loc, seqE, seqName} =
box [string "uw_conn *conn = uw_get_db(ctx);",
newline,
string "char *insert = ",
case seqName of
SOME s => string ("\"INSERT INTO " ^ s ^ " VALUES ()\"")
| NONE => box [string "uw_Basis_strcat(ctx, \"INSERT INTO \", uw_Basis_strcat(ctx, ",
seqE,
string ", \" VALUES ()\"))"],
string ";",
newline,
string "char *delete = ",
case seqName of
SOME s => string ("\"DELETE FROM " ^ s ^ "\"")
| NONE => box [string "uw_Basis_strcat(ctx, \"DELETE FROM \", ",
seqE,
string ")"],
string ";",
newline,
newline,
string "if (mysql_query(conn->conn, insert)) {",
box [newline,
string "if (mysql_errno(conn->conn) == 2006) uw_try_reconnecting_and_restarting(ctx);",
newline,
string "uw_error(ctx, FATAL, \"'nextval' INSERT failed\");",
newline],
string "}",
newline,
string "n = mysql_insert_id(conn->conn);",
newline,
string "if (mysql_query(conn->conn, delete)) uw_error(ctx, FATAL, \"'nextval' DELETE failed\");",
newline]
fun nextvalPrepared _ = raise Fail "MySQL.nextvalPrepared called"
fun setval _ = raise Fail "MySQL.setval called"
fun sqlifyString s = "'" ^ String.translate (fn #"'" => "\\'"
| #"\\" => "\\\\"
| ch =>
if Char.isPrint ch then
str ch
else
(ErrorMsg.error
"Non-printing character found in SQL string literal";
""))
(Prim.toCString s) ^ "'"
fun p_cast (s, _) = s
fun p_blank _ = "?"
val () = addDbms {name = "mysql",
header = Config.msheader,
randomFunction = "RAND",
link = "-lmysqlclient",
init = init,
p_sql_type = p_sql_type,
query = query,
queryPrepared = queryPrepared,
dml = dml,
dmlPrepared = dmlPrepared,
nextval = nextval,
nextvalPrepared = nextvalPrepared,
setval = setval,
sqlifyString = sqlifyString,
p_cast = p_cast,
p_blank = p_blank,
supportsDeleteAs = false,
supportsUpdateAs = false,
createSequence = fn s => "CREATE TABLE " ^ s ^ " (uw_id INTEGER PRIMARY KEY AUTO_INCREMENT)",
textKeysNeedLengths = true,
supportsNextval = false,
supportsNestedPrepared = false,
sqlPrefix = "SET storage_engine=InnoDB;\n\n",
supportsOctetLength = true,
trueString = "TRUE",
falseString = "FALSE",
onlyUnion = true,
nestedRelops = false,
windowFunctions = false}
end
urweb-20160213+dfsg/src/name_js.sig 0000664 0000000 0000000 00000003312 12657647235 0016744 0 ustar 00root root 0000000 0000000 (* 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.
*)
(* Phase that introduces names for fragments of JavaScript code, so that they
* may be moved to app.js and not repeated in each generated page *)
signature NAME_JS = sig
val rewrite : Mono.file -> Mono.file
end
urweb-20160213+dfsg/src/name_js.sml 0000664 0000000 0000000 00000030733 12657647235 0016764 0 ustar 00root root 0000000 0000000 (* Copyright (c) 2012-2013, 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.
*)
(* Phase that introduces names for fragments of JavaScript code, so that they
* may be moved to app.js and not repeated in each generated page *)
structure NameJS :> NAME_JS = struct
open Mono
structure U = MonoUtil
structure IS = IntBinarySet
val freeVars = U.Exp.foldB {typ = #2,
exp = fn (free, e, vs) =>
case e of
ERel n =>
if n < free then
vs
else
IS.add (vs, n - free)
| _ => vs,
bind = fn (free, b) =>
case b of
U.Exp.RelE _ => free+1
| _ => free}
0 IS.empty
fun index (ls, v) =
case ls of
[] => raise Fail "NameJs.index"
| v' :: ls' => if v = v' then 0 else 1 + index (ls', v)
fun squish vs = U.Exp.mapB {typ = fn x => x,
exp = fn free => fn e =>
case e of
ERel n =>
if n < free then
e
else
ERel (free + index (vs, n - free) + 1)
| _ => e,
bind = fn (free, b) =>
case b of
U.Exp.RelE _ => free+1
| _ => free}
0
fun rewrite file =
let
fun isTricky' dontName e =
case e of
ENamed n => IS.member (dontName, n)
| EFfiApp ("Basis", "sigString", _) => true
| _ => false
fun isTricky dontName = U.Decl.exists {typ = fn _ => false,
exp = isTricky' dontName,
decl = fn _ => false}
fun isTrickyE dontName = U.Exp.exists {typ = fn _ => false,
exp = isTricky' dontName}
val dontName = foldl (fn (d, dontName) =>
if isTricky dontName d then
case #1 d of
DVal (_, n, _, _, _) => IS.add (dontName, n)
| DValRec vis => foldl (fn ((_, n, _, _, _), dontName) => IS.add (dontName, n)) dontName vis
| _ => dontName
else
dontName) IS.empty (#1 file)
val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) =>
let
val (d, (nextName, newDs)) =
U.Decl.foldMapB {typ = fn x => x,
decl = fn (_, e, s) => (e, s),
exp = fn (env, e, st as (nextName, newDs)) =>
case e of
EJavaScript (mode, e') =>
(case mode of
Source _ => (e, st)
| _ =>
let
fun isTrulySimple (e, _) =
case e of
ERel _ => true
| ENamed _ => true
| ERecord [] => true
| _ => false
fun isAlreadySimple e =
case #1 e of
EApp (e, arg) => isTrulySimple arg andalso isAlreadySimple e
| _ => isTrulySimple e
in
if isAlreadySimple e' orelse isTrickyE dontName e' then
(e, st)
else
let
val loc = #2 e'
val vs = freeVars e'
val vs = IS.listItems vs
val x = "script" ^ Int.toString nextName
val un = (TRecord [], loc)
val s = (TFfi ("Basis", "string"), loc)
val base = (TFun (un, s), loc)
val t = foldl (fn (n, t) => (TFun (#2 (List.nth (env, n)), t), loc)) base vs
val e' = squish vs e'
val e' = (EAbs ("_", un, s, e'), loc)
val (e', _) = foldl (fn (n, (e', t)) =>
let
val (x, this) = List.nth (env, n)
in
((EAbs (x, this, t, e'), loc),
(TFun (this, t), loc))
end) (e', base) vs
val d = (x, nextName, t, e', "