diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +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. + +Neither the name of Northeastern University; nor the names of its +contributors may 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. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,64 @@ +EXE = alms +GHC = ghc +EXAMPLES = examples +SRC = $(HS_SRC) $(HSBOOT_SRC) +HS_SRC = src/*.hs src/Basis/*.hs src/Basis/Channel/*.hs \ + src/Syntax/*.hs src/Meta/*.hs +HSBOOT_SRC = src/Syntax/*.hs-boot + +DOC = dist/doc/html/alms/alms/ + +default: Setup dist/setup-config $(SRC) + ./Setup build + cp dist/build/alms/alms . + +dist/setup-config config: Setup alms.cabal + ./Setup configure --flags="$(FLAGS)" + +Setup: Setup.hs + $(GHC) -o $@ --make $< + +$(EXE): default + +test tests: $(EXE) + @$(SHELL) $(EXAMPLES)/run-tests.sh ./$(EXE) $(EXAMPLES) + +examples: $(EXE) + @for i in $(EXAMPLES)/ex*.alms; do \ + echo "$$i"; \ + head -1 "$$i"; \ + ./$(EXE) "$$i"; \ + echo; \ + done + @for i in $(EXAMPLES)/*.in; do \ + out="`echo $$i | sed 's/\.in$$/.out/'`"; \ + src="`echo $$i | sed 's/-[[:digit:]]*\.in$$/.alms/'`"; \ + echo "$$i"; \ + ./$(EXE) "$$src" < "$$i"; \ + done + +$(DOC): Setup $(wildcard src/*.hs) + ./Setup haddock --executables + +doc: $(DOC) + $(RM) html + ln -s $(DOC) html + +clean: + $(RM) *.hi *.o $(EXE) $(TARBALL) Setup + $(RM) -Rf $(DISTDIR) dist + $(RM) html + + +VERSION = 0.4.9 +DISTDIR = alms-$(VERSION) +TARBALL = $(DISTDIR).tar.gz + +dist: $(TARBALL) + +$(TARBALL): + $(RM) -Rf $(TARBALL) $(DISTDIR) + svn export . $(DISTDIR) + tar czf $(TARBALL) $(DISTDIR) + $(RM) -Rf $(DISTDIR) + chmod a+r $(TARBALL) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,168 @@ +This is a prototype implementation of Alms, an affine language with +modules and subtyping. + +Please see http://www.ccs.neu.edu/home/tov/pubs/alms/ for more +information. + +CONTENTS + + * GETTING STARTED + * WHAT TO TRY + * PAPER SYNTAX VERSUS ASCII SYNTAX + * EDITLINE TROUBLE + + +GETTING STARTED + + We require GHC to build. It is known to work with GHC 6.10.4, + and likely no longer works with GHC 6.8. + + Provided that a recent ghc is in your path, to build on UNIX it ought + to be be sufficient to type: + + % make + + This should produce an executable "alms" in the current directory, + + If this fails, it may also be necessary to either install the editline + package first or disable line editing (Please see EDITLINE TROUBLE). + + On Windows, build with Cabal: + + > runghc Setup.hs configure + > runghc Setup.hs build + + This produces an executable in "dist\build\alms\alms". + + Cabal should work on UNIX as well, but mixing Cabal and make leads to + linker errors, so it's probably best to stick with one or the other. + + +WHAT TO TRY + + Examples from the paper and several more are in the examples/ + directory. The examples from section 2 of the POPL submission are in: + + examples/ex60-popl-deposit.alms + examples/ex61-popl-AfArray.alms + examples/ex62-popl-AfArray-type-error.alms + examples/ex63-popl-CapArray.alms + examples/ex64-popl-CapLockArray.alms + examples/ex65-popl-Fractional.alms + examples/ex66-popl-RWLock.alms + + Other notable examples include two implementations of session types, + an implementation of Sutherland-Hodgman re-entrant polygon clipping + (1974) using session types, and the tracked Berkeley Sockets API from + our ESOP 2010 paper: + + lib/libsessiontype.alms + lib/libsessiontype2.alms + examples/session-types-polygons.alms + lib/libsocketcap.alms + + The echo server from the ESOP paper, which uses libsocketcap, is in + examples/echoServer.alms. To try it, listening on port 10000, run: + + % ./alms examples/echoServer.alms 10000 + + To connect to the echo server, you can run + + % ./alms examples/netcat.alms localhost 10000 + + from another terminal. + + The examples directory contains many more examples, many of which + are small, but demonstrate type or or contract errors -- the comment at + the top of each example says what to expect. Run many of the examples + with: + + % make examples + + Or run the examples as regression tests (quietly): + + % make tests + + Of course, you can also run the interpreter in interactive mode: + + % ./alms + + You can load libraries from the command line like this: + + % ./alms -l libsocketcap + + Or from within the REPL like this: + + #- #load "libsocketcap" + + Finally, it may be helpful to know about the #i command for asking the + REPL about identifiers: + + #- #i list Exn * + type +`a list : a = Cons of `a * `a list | Nil + -- built-in + module Exn + -- defined at "lib/libbasis.alms" (line 2, col. 3 to line 23, col. 3) + type +`a * +`b : a \/ b -- built-in + val ( * ) : int -> int -> int -- built-in + + +PAPER SYNTAX VERSUS ASCII SYNTAX + +The language as presented in the paper is faithful to the language as +implemented, except for issues of pretty printing: + + LaTeX (what the paper says) ASCII (what you type) + ----------------------------------------------------- + \forall \exists \lambda all ex fun (binders) + \alpha 'a (unlimited type variable) + \hat\alpha `a (affine type variable) + \to^A -o (affine arrow) + \to^{\hat\alpha} -[a]> (arrow with qualifier) + \sqcup \sqcap \/ /\ (qualifier join and meet) + \pm \baro + - = * + - (variances) + + +EDITLINE TROUBLE + + Line editing is enabled in the REPL by default, which depends on the + editline Cabal package. If make fails and says something about + editline, then there are three options: + + - Disable line editing: + + % make clean; make FLAGS=-editline + + - Use readline instead: + + % make clean; make FLAGS=readline + + - Try to install editline or readline . . . + + Installing editline can be kind of touchy. On my system, + + % cabal install editline + + seemed to install it, but Cabal still couldn't find it when + building this program. Installing editline globally made it work: + + % sudo cabal install --global editline + + (Likewise, readline didn't work until I installed it globally.) + + At this point, older versions of Cabal may give the installed library + bad permissions, so something like this may help, depending on where + it installs things: + + % sudo chmod -R a+rX /usr/local/lib/editline* + + If the cabal installation of the GHC package fails, it may be + necessary first to install the C library that it depends on. The + source is available at http://www.thrysoee.dk/editline/. On my Debian + system, I was able to install it with: + + % sudo aptitude install libedit2 libedit-dev + + Note that libeditline is a *completely different* library, and + installing that will not help. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/alms.cabal b/alms.cabal new file mode 100644 --- /dev/null +++ b/alms.cabal @@ -0,0 +1,114 @@ +Name: alms +Version: 0.4.9 +Copyright: 2010, Jesse A. Tov +Cabal-Version: >= 1.8 +License: BSD3 +License-File: LICENSE +Stability: experimental +Author: Jesse A. Tov +Maintainer: tov@ccs.neu.edu +Homepage: http://www.ccs.neu.edu/~tov/pubs/alms +Category: Compilers/Interpreters +Synopsis: a practical affine language +Build-type: Simple +Data-files: lib/*.alms examples/*.alms examples/*.sh + examples/*.in examples/*.out README Makefile + +Description: + Alms is a general-purpose programming language that supports practical + affine types. To offer the expressiveness of Girard’s linear logic while + keeping the type system light and convenient, Alms uses expressive kinds + that minimize notation while maximizing polymorphism between affine and + unlimited types. + + A key feature of Alms is the ability to introduce abstract affine types + via ML-style signature ascription. In Alms, an interface can impose + stiffer resource usage restrictions than the principal usage + restrictions of its implementation. This form of sealing allows the type + system to naturally and directly express a variety of resource + management protocols from special-purpose type systems. + +Flag editline + Description: Enable line editing using the editline package + Default: True + +Flag readline + Description: Enable line editing using the readline package + Default: False + +Executable alms + Main-Is: Main.hs + Hs-Source-Dirs: src + GHC-Options: -O3 + CPP-Options: -DALMS_CABAL_BUILD + Build-Depends: haskell98, + base == 4.*, + syb >= 0.1, + pretty >= 1, + containers >= 0.1, + parsec == 2.*, + mtl >= 1.1, + filepath >= 1.1, + network >= 2.2, + directory >= 1.0, + template-haskell >= 2.0, + QuickCheck >= 2, + HUnit >= 1.2, + random >= 1, + array >= 0.3 + Other-Modules: Basis, + Basis.Array, + Basis.Channel, + Basis.Channel.Haskell, + Basis.Exn, + Basis.Future, + Basis.IO, + Basis.MVar, + Basis.Socket, + Basis.Thread, + BasisUtils, + Coercion, + Dynamics, + Env, + ErrorST, + Lexer, + Loc, + Meta.DeriveNotable, + Meta.FileString, + Meta.Quasi, + Meta.QuoteData, + Meta.THHelpers, + PDNF, + Parser, + Paths, + Ppr, + Prec, + Rename, + Sigma, + Statics, + Syntax, + Syntax.Anti, + Syntax.Decl, + Syntax.Expr, + Syntax.Ident, + Syntax.Kind, + Syntax.Lit, + Syntax.Notable, + Syntax.POClass, + Syntax.Patt, + Syntax.SyntaxTable, + Syntax.Type, + Type, + TypeRel, + Util, + Value, + Viewable + + if flag(readline) + Build-Depends: readline >= 1.0 + CPP-Options: -DUSE_READLINE=System.Console.Readline + else + if flag(editline) + Build-Depends: editline >= 0.2.1 + CPP-Options: -DUSE_READLINE=System.Console.Editline.Readline + diff --git a/examples/echoServer.alms b/examples/echoServer.alms new file mode 100644 --- /dev/null +++ b/examples/echoServer.alms @@ -0,0 +1,43 @@ +(* Echo server written using state-tracked sockets. *) + +#load "libsocketcap" + +module EchoServer = struct + open ASocket + + (* This is a bit different than the version in the paper, because + * it uses exceptions. *) + let handleClient['t] (sock: 't socket) (f: string -> string) + (cap: 't connected) : unit = + let rec loop (cap: 't connected): unit = + let (str, cap) = recv sock 1024 cap in + let cap = send sock (f str) cap in + loop cap + in try + loop cap + with SocketError _ -> () + + let rec acceptLoop['t] (sock: 't socket) (f: string -> string) + (cap: 't listening) : unit = + let (Pack('s, clientsock, clientcap), cap) = accept sock cap in + putStrLn "Opened connection"; + (Thread.fork :> (unit -o unit) -> Thread.thread) + (fun () -> handleClient clientsock f clientcap; + putStrLn "Closed connection"); + acceptLoop sock f cap + + let serve (port: int) (f: string -> string) = + let Pack('t, sock, cap) = socket () in + let cap = bind sock port cap in + let cap = listen sock cap in + acceptLoop sock f cap +end + +let serverFun (s: string) = s + +let main (argv: string list) = + match argv with + | Cons (port, Nil) -> EchoServer.serve (int_of_string port) serverFun + | _ -> failwith "Usage: echoServer.aff PORT\n" + +in main (getArgs ()) diff --git a/examples/ex01-poly.alms b/examples/ex01-poly.alms new file mode 100644 --- /dev/null +++ b/examples/ex01-poly.alms @@ -0,0 +1,10 @@ +(* Polymorphic version: A Type-Correct, Blame-Free Program *) + +let ap = + fun `a `b (f: `a -o `b) (x: `a) -> + f x + +let inc = + fun y: int -> ap (fun z:int -> z + 1) y + +in print (inc 5) diff --git a/examples/ex01.alms b/examples/ex01.alms new file mode 100644 --- /dev/null +++ b/examples/ex01.alms @@ -0,0 +1,11 @@ +(* A Type-Correct, Blame-Free Program *) + +let ap = + fun f: (int -o int) -> + fun x: int -> + f x + +let inc = + fun y: int -> ap (fun z:int -> z + 1) y + +in print (inc 5) diff --git a/examples/ex02-poly-type-error.alms b/examples/ex02-poly-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex02-poly-type-error.alms @@ -0,0 +1,15 @@ +(* Polymorphic version: An Ill-Typed Module (type error) *) + +let ap = + fun `a -> + fun `b -> + fun f: (`a -o `b) -> + fun x: `a -> + f x + +let inc2 = + fun y: int -> + let g = ap (fun z: int -> z + 1) in + g (g y) (* g: (int -o int) is used twice here *) + +in print (inc2 5) diff --git a/examples/ex02-type-error.alms b/examples/ex02-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex02-type-error.alms @@ -0,0 +1,13 @@ +(* An Ill-Typed Module (type error) *) + +let ap = + fun f: (int -o int) -> + fun x: int -> + f x + +let inc2 = + fun y: int -> + let g = ap (fun z: int -> z + 1) in + g (g y) (* g: (int -o int) is used twice here *) + +in print[int] (inc2 5) diff --git a/examples/ex03-blame-error.alms b/examples/ex03-blame-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex03-blame-error.alms @@ -0,0 +1,12 @@ +(* A Blameworthy Coercion *) + +let ap = + fun f: (int -o int) -> + ( (fun x: int -> f x) :> int -> int ) + +let inc2 = + fun y: int -> + let g = ap (fun z: int -> z + 1) in + g (g y) (* g is used twice here *) + +in print (inc2 5) diff --git a/examples/ex03-poly-blame-error.alms b/examples/ex03-poly-blame-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex03-poly-blame-error.alms @@ -0,0 +1,12 @@ +(* Polymorphic version: A Blameworthy Coercion *) + +let ap = + fun 'a 'b (f: 'a -o 'b) (x: 'a) -> f x + +let inc2 = + fun y: int -> + let g = (ap :> all 'a 'b. ('a -o 'b) -> 'a -> 'b) + (fun z: int -> z + 1) in + g (g y) (* g is used twice here *) + +in print (inc2 5) diff --git a/examples/ex04-poly.alms b/examples/ex04-poly.alms new file mode 100644 --- /dev/null +++ b/examples/ex04-poly.alms @@ -0,0 +1,12 @@ +(* Polymorphic version: ex03 corrected *) + +let ap : all 'a 'b. ('a -o 'b) -> 'a -o 'b = + fun 'a 'b (f: 'a -o 'b) (x : 'a) -> f x + +let inc2 : int -> int = + fun y: int -> + let g = ap[int,int] (fun z: int -> z + 1) in + let h = ap[int,int] (fun z: int -> z + 1) in + h (g y) + +in print[int] (inc2 5) diff --git a/examples/ex04.alms b/examples/ex04.alms new file mode 100644 --- /dev/null +++ b/examples/ex04.alms @@ -0,0 +1,14 @@ +(* Ex04 Corrected *) + +let ap : (int -o int) -> int -o int = + fun f: (int -o int) -> + fun x: int -> + f x + +let inc2 : int -> int = + fun y: int -> + let g = ap (fun z: int -> z + 1) in + let h = ap (fun z: int -> z + 1) in + h (g y) + +in print[int] (inc2 5) diff --git a/examples/ex05-poly.alms b/examples/ex05-poly.alms new file mode 100644 --- /dev/null +++ b/examples/ex05-poly.alms @@ -0,0 +1,10 @@ +let ap : all 'a 'b. ('a -> 'b) -> 'a -> 'b = + fun 'a 'b -> + fun f: ('a -> 'b) -> + fun x: 'a -> + f x + +let inc : int -> int = + fun y: int -> ap[int,int] (fun z: int -> z + 1) y + +in print[int] (inc 5) diff --git a/examples/ex05.alms b/examples/ex05.alms new file mode 100644 --- /dev/null +++ b/examples/ex05.alms @@ -0,0 +1,9 @@ +let ap : (int -> int) -> int -> int = + fun f: (int -> int) -> + fun x: int -> + f x + +let inc : int -> int = + fun y: int -> ap (fun z: int -> z + 1) y + +in print[int] (inc 5) diff --git a/examples/ex06-poly-type-error.alms b/examples/ex06-poly-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex06-poly-type-error.alms @@ -0,0 +1,12 @@ +let ap : all 'a 'b. ('a -> 'b) -> 'a -> 'b = + fun 'a 'b -> + fun f: ('a -> 'b) -> + fun x: 'a -> + f x + +let inc : int -> int = + fun y: int -> + let g = (fun z:int -> z + 1 : int -> int :> int -o int) in + ap[int,int] g y (* g: (int -o int) is used as an (int -> int) *) + +in print[int] (inc 5) diff --git a/examples/ex06-type-error.alms b/examples/ex06-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex06-type-error.alms @@ -0,0 +1,11 @@ +let ap : (int -> int) -> int -> int = + fun f: (int -> int) -> + fun x: int -> + f x + +let inc : int -> int = + fun y: int -> + let g = (fun z:int -> z + 1 : int -> int :> int -o int) in + ap g y (* g: (int -o int) is used as an (int -> int) *) + +in print[int] (inc 5) diff --git a/examples/ex07-poly.alms b/examples/ex07-poly.alms new file mode 100644 --- /dev/null +++ b/examples/ex07-poly.alms @@ -0,0 +1,17 @@ +(* Polymorphic version: An Interface Intervenes *) + +let ap : all 'a 'b. ('a -> 'b) -> 'a -> 'b = + fun 'a 'b -> + fun f: ('a -> 'b) -> + fun x: 'a -> + f x + +let iap = (ap :> all 'a 'b. ('a -o 'b) -> 'a -o 'b) + +let inc : int -> int = + fun y: int -> + (fun g: (int -o int) -> + iap[int,int] g y) + (fun z: int -> z + 1) + +in print[int] (inc 5) diff --git a/examples/ex07.alms b/examples/ex07.alms new file mode 100644 --- /dev/null +++ b/examples/ex07.alms @@ -0,0 +1,16 @@ +(* An Interface Intervenes *) + +let ap : (int -> int) -> int -> int = + fun f: (int -> int) -> + fun x: int -> + f x + +let iap = (ap :> (int -o int) -> int -o int) + +let inc : int -> int = + fun y: int -> + (fun g: (int -o int) -> + iap g y) + (fun z: int -> z + 1) + +in print[int] (inc 5) diff --git a/examples/ex08-blame-error.alms b/examples/ex08-blame-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex08-blame-error.alms @@ -0,0 +1,16 @@ +(* A Lying Interface *) + +let ap : (int -> int) -> int -> int = + fun f: (int -> int) -> + fun x: int -> + f (f x) (* f is used twice here, despite what iap2 claims *) + +let iap2 = (ap :> (int -o int) -> int -o int) + +let inc : int -> int = + fun y: int -> + (fun g: (int -o int) -> + iap2 g y) + (fun z: int -> z + 1) + +in print[int] (inc 5) diff --git a/examples/ex08-poly-blame-error.alms b/examples/ex08-poly-blame-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex08-poly-blame-error.alms @@ -0,0 +1,17 @@ +(* A Lying Interface *) + +let ap : all 'a. ('a -> 'a) -> 'a -> 'a = + fun 'a -> + fun f: ('a -> 'a) -> + fun x: 'a -> + f (f x) (* f is used twice here, despite what iap2 claims *) + +let iap2 = (ap :> all 'a. ('a -o 'a) -> 'a -o 'a) + +let inc : int -> int = + fun y: int -> + (fun g: (int -o int) -> + iap2[int] g y) + (fun z: int -> z + 1) + +in print[int] (inc 5) diff --git a/examples/ex09-dynamic-promotion-poly.alms b/examples/ex09-dynamic-promotion-poly.alms new file mode 100644 --- /dev/null +++ b/examples/ex09-dynamic-promotion-poly.alms @@ -0,0 +1,16 @@ +(* Polymorphic version: A Dynamic Promotion Intervenes (like ex7.aff) *) + +let ap : all 'a. ('a -> 'a) -> 'a -> 'a = + fun 'a -> + fun f: ('a -> 'a) -> + fun x: 'a -> + f x + +let inc : int -> int = + fun y: int -> + (fun g: (int -o int) -> + (ap[int] : (int -> int) -> int -> int + :> (int -o int) -> int -o int) g y) + (fun z: int -> z + 1) + +in print[int] (inc 5) diff --git a/examples/ex09-dynamic-promotion.alms b/examples/ex09-dynamic-promotion.alms new file mode 100644 --- /dev/null +++ b/examples/ex09-dynamic-promotion.alms @@ -0,0 +1,15 @@ +(* A Dynamic Promotion Intervenes (like ex7.aff) *) + +let ap : (int -> int) -> int -> int = + fun f: (int -> int) -> + fun x: int -> + f x + +let inc : int -> int = + fun y: int -> + (fun g: (int -o int) -> + (ap : (int -> int) -> int -> int + :> (int -o int) -> int -o int) g y) + (fun z: int -> z + 1) + +in print[int] (inc 5) diff --git a/examples/ex10-dynamic-promotion-blame-error.alms b/examples/ex10-dynamic-promotion-blame-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex10-dynamic-promotion-blame-error.alms @@ -0,0 +1,15 @@ +(* A Lying Dynamic Promotion (like ex8.aff -- blame inc(:>)) *) + +let ap : (int -> int) -> int -> int = + fun f: (int -> int) -> + fun x: int -> + f (f x) (* f is used twice here, despite what iap2 claims *) + +let inc : int -> int = + fun y: int -> + (fun g: (int -o int) -> + (ap : (int -> int) -> int -> int + :> (int -o int) -> int -o int) g y) (* This cast goes bad *) + (fun z: int -> z + 1) + +in print[int] (inc 5) diff --git a/examples/ex10-dynamic-promotion-poly-blame-error.alms b/examples/ex10-dynamic-promotion-poly-blame-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex10-dynamic-promotion-poly-blame-error.alms @@ -0,0 +1,16 @@ +(* Polymorphic: A Lying Dynamic Promotion (like ex8.aff -- blame inc(:>)) *) + +let ap : all 'a. ('a -> 'a) -> 'a -> 'a = + fun 'a -> + fun f: ('a -> 'a) -> + fun x: 'a -> + f (f x) (* f is used twice here, despite what iap2 claims *) + +let inc : int -> int = + fun y: int -> + (fun g: (int -o int) -> + (ap[int] : (int -> int) -> int -> int (* This cast goes bad *) + :> (int -o int) -> int -o int) g y) + (fun z: int -> z + 1) + +in print[int] (inc 5) diff --git a/examples/ex11-affine-type-error.alms b/examples/ex11-affine-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex11-affine-type-error.alms @@ -0,0 +1,3 @@ +(* Can't duplicate type `a (type error) *) + +let dup[`a] (x: `a) = (x, x) diff --git a/examples/ex12-affine-type-error.alms b/examples/ex12-affine-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex12-affine-type-error.alms @@ -0,0 +1,5 @@ +(* Can't duplicate affine abstract type (type error) *) + +abstype t qualifier A = B with end + +let dup (x: t) = (x, x) diff --git a/examples/ex25-io.alms b/examples/ex25-io.alms new file mode 100644 --- /dev/null +++ b/examples/ex25-io.alms @@ -0,0 +1,41 @@ +(* Typestate file IO *) + +open IO + +abstype in_channel' = InChannel of handle with + let open_in (s: string) = InChannel (openFile s ReadMode) + let input_char (InChannel h: in_channel') = hGetChar h + let input_line (InChannel h: in_channel') = hGetLine h + let eof_in (InChannel h: in_channel') = hIsEOF h + let close_in (InChannel h: in_channel') = hClose h +end + +abstype out_channel = OutChannel of handle with + let open_out (s: string) = OutChannel (openFile s WriteMode) + let output_char (OutChannel h: out_channel) = hPutChar h + let output_string (OutChannel h: out_channel) = hPutStr h + let eof_out (OutChannel h: out_channel) = hIsEOF h + let close_out (OutChannel h: out_channel) = hClose h +end + +abstype in_channel qualifier A = InChannel of in_channel' with + let a_open_in (s: string) = InChannel (open_in s) + let a_input_char (InChannel rep as ic: in_channel) = + (input_char rep, ic) + let a_input_line (InChannel rep as ic: in_channel) = + (input_line rep, ic) + let a_close_in (InChannel rep: in_channel) = + close_in rep + let a_eof_in (InChannel rep as ic: in_channel) = + if eof_in rep + then close_in rep; None[in_channel] + else Some ic +end + +let cat (filename: string) = + let rec loop (ic: in_channel): unit = + match a_eof_in ic with + | None -> () + | Some ic -> let (c, ic) = a_input_char ic in + putChar c; loop ic + in loop (a_open_in filename) diff --git a/examples/ex26-let-bang-array.alms b/examples/ex26-let-bang-array.alms new file mode 100644 --- /dev/null +++ b/examples/ex26-let-bang-array.alms @@ -0,0 +1,83 @@ +(* An encoding of Wadler's let! construct. + Allows temporarily viewing an array as unlimited/read-only. *) + +#load "libarraycap" + +open AArray + +abstype ('t, 'c) ureadcap_rep qualifier A + = Available of ('t, 'c) readcap + | CheckedOut + | Defunct +with + abstype ('t, 'c) ureadcap qualifier U + = MkCap of ('t, 'c) ureadcap_rep ref + with + + (* We represent this thing with (essentially) as a spinlock. + Acquire the spinlock: *) + let acquireBang['t, 'c] (r: ('t, 'c) ureadcap_rep ref) = + let rec loop (): ('t, 'c) readcap = + match r <- CheckedOut with + | Available c -> c + | CheckedOut -> loop () + | Defunct -> failwith "letBang: attempt to use defunct ureadcap" + in loop () + + (* Given a capability, create a temporary, unlimited read capability + and pass that to a call-back. Return the result of the callback + and the restored capability. *) + let letBang['t, 'c, `a] (c: ('t, 'c) readcap)| + (k: ('t, 'c) ureadcap -o `a) + : `a * ('t, 'c) readcap = + let r = ref (Available c) in + let uc = MkCap r in + let a = k uc in + let c = acquireBang r in + r <- Defunct; + (a, c) + + let applyBang['t,'c,`r] + (k: ('t, 'c) readcap -o `r * ('t, 'c) readcap) + | + (MkCap r: ('t, 'c) ureadcap) + : `r = + let (result, c) = k (acquireBang r) in + r <- Available c; + result + + let liftBang['t,'c,`r] + (k: ('t, 'c) readcap -> `r * ('t, 'c) readcap) + (MkCap r: ('t, 'c) ureadcap) + : `r = + let (result, c) = k (acquireBang r) in + r <- Available c; + result + + let getAU['a,'t,'c] (a: ('a, 't) array) (ix: int) = + liftBang (get['a,'t,'c] a ix) + + let putAU['a,'t] (a: ('a, 't) array) (ix: int) (new: 'a) = + let f (cap: 't writecap) = ((), set['a,'t] a ix new cap) in + liftBang f + end +end + +type 't uwritecap = ('t, 1) ureadcap + +let test () = + let n = 10 in + let Pack('t, a, cap) = new[int] n 0 in + let rec loop (i: int) (cap: 't writecap): 't writecap = + if i >= n + then cap + else loop (i + 1) (set a i (i * i) cap) in + let cap = loop 0 cap in + let (r, cap) = letBang cap + (fun (cap: 't uwritecap) -> + getAU a 1 cap + getAU a 3 cap + getAU a 5 cap) in + set a 0 (-1) cap; + r + +in print (test ()) + diff --git a/examples/ex27-focusing-and-adoption.alms b/examples/ex27-focusing-and-adoption.alms new file mode 100644 --- /dev/null +++ b/examples/ex27-focusing-and-adoption.alms @@ -0,0 +1,95 @@ +(* Demonstrates Pottier's (2007) version of adoption/focus + (Faehnrich and DeLine, 2002). *) + +(* Some affine list operations. *) + +(* + type variables: + `a stored value + 't region name + + variables: + x, y: `a stored value + xs: `a list region representation + + T[[ { p |-> t } ]] = (p, T[[ t ]]) region1 + T[[ { p |->^w t } ]] = (p, T[[ t ]]) region + T[[ Ptr t ]] = T[[ t ]] ptr + +*) + +let length[`a] (xs: `a list) : int * `a list = + foldr (fun (x: `a) (n: int, xs: `a list) -> + (n + 1, Cons (x, xs))) + (0, Nil[`a]) xs + +let snoc[`a] (x: `a) | (xs: `a list) : `a list = + foldr (fun (x: `a) (xs: `a list) -> Cons (x, xs)) + (Cons (x, Nil[`a])) xs + +let revAppN = + let rec loop[`a] (n: int) (xs: `a list) | (acc: `a list) + : `a list * `a list = + match n with + | 0 -> (acc, xs) + | _ -> match xs with + | Cons(x, xs) -> loop (n - 1) xs (Cons (x, acc)) + | xs -> (acc, xs) + in loop + +let rev[`a] (xs: `a list) : `a list = + let (_, acc) = revAppN (-1) xs Nil[`a] + in acc + +let swapN[`a] (ix: int) (y: `a) | (xs: `a list) + : `a * `a list = + let (Cons(x, xs), acc) = revAppN ix xs Nil[`a] in + let (xs, _) = revAppN (-1) acc (Cons (y, xs)) in + (x, xs) + +abstype ('t, `a) region qualifier A = Rgn of `a list + and ('t, `a) region1 qualifier A = Rgn1 of `a + and 't ptr qualifier U = Ptr of int +with + let newRgn[`a] () = + Pack[ex 't. ('t, `a) region] (unit, Rgn[unit] (Nil[`a])) + let freeRgn[`a,'t] (_: ('t, `a) region) = () + + let mallocIn[`a,'t] (Rgn xs: ('t, `a) region) | (a: `a) + : 't ptr * ('t, `a) region = + let (ix, xs) = length xs in + (Ptr['t] ix, Rgn['t] (snoc a xs)) + let swap[`a,'t] (Rgn xs: ('t, `a) region) | + (Ptr ix: 't ptr) (x: `a) + : `a * ('t, `a) region = + let (y, xs) = swapN ix x xs in + (y, Rgn['t] xs) + + let malloc () = + Pack[ex 't. ('t, unit) region1 * 't ptr] + (unit, Rgn1[unit] (), Ptr[unit] 0) + let swap1[`a,`b,'t] (Rgn1 x: ('t, `a) region1) | + (_: 't ptr) (y: `b) + : `a * ('t, `b) region1 = + (x, Rgn1['t] y) + let free[`a, 't] (_: ('t, `a) region1) = () + + let adopt[`a,'t1,'t2] (rgn: ('t1, `a) region) | + (Rgn1 x: ('t2, `a) region1) + (_: 't2 ptr) + : 't1 ptr * ('t1, `a) region = + mallocIn rgn x + + let focus[`a,'t] + (Rgn xs: ('t, `a) region) | + (Ptr ix: 't ptr) + : ex 't1. ('t1, `a) region1 * 't1 ptr * + (('t1, `a) region1 -o ('t, `a) region) = + let (Cons (x, xs), acc) = revAppN ix xs Nil[`a] in + Pack[ex 't1. ('t1, `a) region1 * 't1 ptr * + (('t1, `a) region1 -o ('t, `a) region)] + (unit, Rgn1[unit] x, Ptr[unit] 0, + fun (Rgn1 y: (unit, `a) region1) -> + let (xs, _) = revAppN (-1) acc (Cons (y, xs)) in + Rgn['t] xs) +end diff --git a/examples/ex28-focusing-and-adoption.alms b/examples/ex28-focusing-and-adoption.alms new file mode 100644 --- /dev/null +++ b/examples/ex28-focusing-and-adoption.alms @@ -0,0 +1,80 @@ +(* Demonstrates adoption/focus (Faehnrich and DeLine, 2002). *) + +(* + type variables: + `a `b stored value + 't 's capability name +*) + +let length[`a] (xs: `a list) : int * `a list = + foldr (fun (x: `a) (n: int, xs: `a list) -> + (n + 1, Cons (x, xs))) + (0, Nil[`a]) xs + +let snoc[`a] (x: `a) | (xs: `a list) : `a list = + foldr (fun (x: `a) (xs: `a list) -> Cons (x, xs)) + (Cons (x, Nil[`a])) xs + +let revAppN = + let rec loop[`a] (n: int) (xs: `a list) | (acc: `a list) + : `a list * `a list = + match n with + | 0 -> (acc, xs) + | _ -> match xs with + | Cons(x, xs) -> loop (n - 1) xs (Cons (x, acc)) + | xs -> (acc, xs) + in loop + +let swapN[`a] (ix: int) (y: `a) | (xs: `a list) + : `a * `a list = + let (Cons(x, xs), acc) = revAppN ix xs Nil[`a] in + let (xs, _) = revAppN (-1) acc (Cons (y, xs)) in + (x, xs) + +abstype 't tr qualifier U = Tr + and ('t, `a) cap qualifier A = Cap of `a * (unit -o unit) list + and ('t, `a) guarded qualifier U = + Guarded of (`a * (unit -o unit) list) option ref +with + let new[`a] (x: `a) : ex 't. ('t, `a) cap * 't tr = + Pack[ex 't. ('t, `a) cap * 't tr] + (unit, Cap[unit, `a] (x, Nil[unit -o unit]), Tr[unit]) + let swap[`a,`b,'t] ((Cap (x, fs), _) : ('t, `a) cap * 't tr) | + (y : `b) + : ('t, `b) cap * `a = + (Cap['t] (y, fs), x) + let free[`a, 't] (Cap (_, fs): ('t, `a) cap) = + let rec loop (fs : (unit -o unit) list) : unit = + match fs with + | Nil -> () + | Cons(f, fs) -> f (); loop fs + in loop fs + + let adoptByThen[`a,'ta,`b,'tb] + ((Cap adoptee, _) : ('ta, `a) cap * 'ta tr) | + ((Cap (adoptor, destructors), _) : ('tb, `b) cap * 'tb tr) + (destroy : ('ta, `a) cap -o unit) + : ('tb, `b) cap * ('tb, `a) guarded = + let r = ref (Some adoptee) in + let g () = match r <- None with + | None -> failwith "Can't happen" + | Some c -> destroy (Cap['ta] c) in + (Cap['tb] (adoptor, Cons(g, destructors)), Guarded['tb] r) + let adoptBy[`a,'ta,`b,'tb] + (adoptee : ('ta, `a) cap * 'ta tr) | + (adoptor : ('tb, `b) cap * 'tb tr) + : ('tb, `b) cap * ('tb, `a) guarded + = adoptByThen adoptee adoptor (fun (_: ('ta, `a) cap) -> ()) + + let focusIn[`a,'t,`b,`r] + ((guard, Guarded r) : ('t, `a) cap * ('t, `b) guarded) | + (body : (all 's. ('s, `b) cap * 's tr -o + ('s, `b) cap * `r)) + : ('t, `a) cap * `r = + match r <- None with + | None -> failwith "Can't happen" + | Some c -> + let (Cap c, result) = body[unit] (Cap[unit] c, Tr[unit]) + in r <- Some c; + (guard, result) +end diff --git a/examples/ex31-exceptions.alms b/examples/ex31-exceptions.alms new file mode 100644 --- /dev/null +++ b/examples/ex31-exceptions.alms @@ -0,0 +1,56 @@ +(* Exception tests -- should print nothing *) + +let assert (b: bool) (msg: string) = + if b + then () + else putStrLn ("Failed assertion: "^msg) + +module Group1 = struct + exception A + exception B of int + + let match1(e: exn) = + match e with + | A -> 0 + | B z -> z + | _ -> -1 + + let dummy = + assert (match1 A == 0) "test 1"; + assert (match1 (B 4) == 4) "test 2" + + exception A + + let dummy = + assert (match1 A == -1) "test 3" + + exception A + exception B of int +end + +exception C of int + +module Group2 = struct + exception A + exception B of int + + let match1(e: exn) = + match e with + | A -> 0 + | B z -> z + | C z -> z + 10 + | _ -> -1 + + let dummy = + assert (match1 A == 0) "test 1"; + assert (match1 (B 4) == 4) "test 2" + + exception A + + let dummy = + assert (match1 A == -1) "test 3"; + assert (match1 (C 8) == 18) "test 4" + + exception A + exception B of int +end diff --git a/examples/ex32-exceptions.alms b/examples/ex32-exceptions.alms new file mode 100644 --- /dev/null +++ b/examples/ex32-exceptions.alms @@ -0,0 +1,10 @@ +(* Do IO exceptions get converted? (should print nothing.) *) + +#load "libsocket" + +open Socket + +let dummy = + let sock = socket () in + try bind sock 3; failwith "bug: didn't raise!" with + | IOError _ -> () diff --git a/examples/ex33-session-types.alms b/examples/ex33-session-types.alms new file mode 100644 --- /dev/null +++ b/examples/ex33-session-types.alms @@ -0,0 +1,31 @@ +(* An example with session types *) + +#load "libthread" +#load "libsessiontype" + +open SessionType + +type protocol = !int; !int; ?int; 1 + +let server = + fun c : protocol dual channel -> + let (x, c) = recv c in + let (y, c) = recv c in + send c (x + y); + () + +let client = + fun c : protocol channel -> + fun (x : int) (y : int) -> + let c = send c x in + let c = send c y in + let (r, _) = recv c in + r + +let main = + fun (x : int) (y : int) -> + let rv = newRendezvous[protocol] () in + AThread.fork (fun () -> server (accept rv)); + client (request rv) x y + +in print (main 3 4) diff --git a/examples/ex34-session-types.alms b/examples/ex34-session-types.alms new file mode 100644 --- /dev/null +++ b/examples/ex34-session-types.alms @@ -0,0 +1,40 @@ +(* An example with session types, including choice. *) + +#load "libthread" +#load "libsessiontype" + +open SessionType + +type 'a protocol = !'a; !'a; ?'a; 1 + |+| + !'a; ?'a; 1 + +let server = + fun c : int protocol dual channel -> + match follow c with + | Left c -> + let (x, c) = recv c in + let (y, c) = recv c in + send c (x + y); + () + | Right c -> + let (x, c) = recv c in + send c (0 - x); + () + +let client = + fun c : int protocol channel -> + fun (x : int) (y : int) -> + let c = sel1 c in + let c = send c x in + let c = send c y in + let (r, _) = recv c in + r + +let main = + fun (x : int) (y : int) -> + let rv = newRendezvous[int protocol] () in + AThread.fork (fun () -> server (accept rv)); + client (request rv) x y + +in print (main 3 4) diff --git a/examples/ex35-session-types-type-error.alms b/examples/ex35-session-types-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex35-session-types-type-error.alms @@ -0,0 +1,40 @@ +(* An example with session types, including choice. (Type error) *) + +#load "libthread" +#load "libsessiontype" + +open SessionType + +type 'a protocol = !'a; !'a; ?'a; 1 + |+| + !'a; ?'a; 1 + +let server = + fun c : int protocol dual channel -> + match follow c with + | Left c -> + let (x, _) = recv c in + let (y, c) = recv c in + send c (x + y); + () + | Right c -> + let (x, c) = recv c in + send c (0 - x); + () + +let client = + fun c : int protocol channel -> + fun (x : int) (y : int) -> + let c = sel1 c in + let c = send c x in + let c = send c y in + let (r, _) = recv c in + r + +let main = + fun (x : int) (y : int) -> + let rv = newRendezvous[int protocol] () in + AThread.fork (fun () -> server (accept rv)); + client (request rv) x y + +in print (main 3 4) diff --git a/examples/ex36-session-types-type-error.alms b/examples/ex36-session-types-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex36-session-types-type-error.alms @@ -0,0 +1,40 @@ +(* An example with session types, including choice. (Type error) *) + +#load "libthread" +#load "libsessiontype" + +open SessionType + +type 'a protocol = !'a; !'a; ?'a; 1 + |+| + !'a; ?'a; 1 + +let server = + fun c : int protocol dual channel -> + match follow c with + | Left c -> + let (x, c) = recv c in + send c (0 - x); + () + | Right c -> + let (x, c) = recv c in + let (y, c) = recv c in + send c (x + y); + () + +let client = + fun c : int protocol channel -> + fun (x : int) (y : int) -> + let c = sel1 c in + let c = send c x in + let c = send c y in + let (r, _) = recv c in + r + +let main = + fun (x : int) (y : int) -> + let rv = newRendezvous[int protocol] () in + AThread.fork (fun () -> server (accept rv)); + client (request rv) x y + +in print (main 3 4) diff --git a/examples/ex37-session-types-type-error.alms b/examples/ex37-session-types-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex37-session-types-type-error.alms @@ -0,0 +1,40 @@ +(* An example with session types, including choice. (type error) *) + +#load "libthread" +#load "libsessiontype" + +open SessionType + +type 'a protocol = !'a; !'a; ?'a; 1 + |+| + !'a; ?'a; 1 + +let server = + fun c : int protocol dual channel -> + match follow c with + | Left c -> + let (x, c) = recv c in + let (y, c) = recv c in + send c (x + y); + () + | Right c -> + let (x, c) = recv c in + send c (0 - x); + () + +let client = + fun c : int protocol channel -> + fun (x : int) (y : int) -> + let c = sel1 c in + let c = send c (string_of_int x) in + let c = send c y in + let (r, _) = recv c in + r + +let main = + fun (x : int) (y : int) -> + let rv = newRendezvous[int protocol] () in + AThread.fork (fun () -> server (accept rv)); + client (request rv) x y + +in print (main 3 4) diff --git a/examples/ex38-session-types-type-error.alms b/examples/ex38-session-types-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex38-session-types-type-error.alms @@ -0,0 +1,40 @@ +(* An example with session types, including choice. (Type error) *) + +#load "libthread" +#load "libsessiontype" + +open SessionType + +type 'a protocol = !'a; !'a; ?'a; 1 + |+| + !'a; ?'a; 1 + +let server = + fun c : int protocol dual channel -> + match follow c with + | Left c -> + let (x, c) = recv c in + let (y, c) = recv c in + send c (x + y); + () + | Right c -> + let (x, c) = recv c in + send c (0 - x); + () + +let client = + fun c : int protocol channel -> + fun (x : int) (y : int) -> + let c = sel1 c in + let c = send c x in + let (r, c) = recv c in + let _ = send c y in + r + +let main = + fun (x : int) (y : int) -> + let rv = newRendezvous[int protocol] () in + AThread.fork (fun () -> server (accept rv)); + client (request rv) x y + +in print (main 3 4) diff --git a/examples/ex40-signatures.alms b/examples/ex40-signatures.alms new file mode 100644 --- /dev/null +++ b/examples/ex40-signatures.alms @@ -0,0 +1,25 @@ +(* Signature tests -- should print nothing *) + +module type S = sig + type t + val f : int -> t + val g : t -> int +end + +module A = struct + type t = int + let f = (+) 1 + let g = (+) 1 +end + +module B : S = A +module C : S = A + +let f (x: int) = A.f (A.g x) +let f (x: int) = A.g (A.f x) +let f (x: A.t) = A.f (A.g x) +let f (x: A.t) = A.g (A.f x) +let f (x: int) = B.g (B.f x) +let f (x: B.t) = B.f (B.g x) +let f (x: int) = C.g (C.f x) +let f (x: C.t) = C.f (C.g x) diff --git a/examples/ex41-signatures-type-error.alms b/examples/ex41-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex41-signatures-type-error.alms @@ -0,0 +1,18 @@ +(* Signature tests -- should print type error *) + +module type S = sig + type t + val f : int -> t + val g : t -> int +end + +module A = struct + type t = int + let f = (+) 1 + let g = (+) 1 +end + +module B : S = A +module C : S = A + +let f (x: int) = B.g x diff --git a/examples/ex42-signatures-type-error.alms b/examples/ex42-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex42-signatures-type-error.alms @@ -0,0 +1,18 @@ +(* Signature tests -- should print type error *) + +module type S = sig + type t + val f : int -> t + val g : t -> int +end + +module A = struct + type t = int + let f = (+) 1 + let g = (+) 1 +end + +module B : S = A +module C : S = A + +let f (x: B.t) = B.f x diff --git a/examples/ex43-signatures-type-error.alms b/examples/ex43-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex43-signatures-type-error.alms @@ -0,0 +1,18 @@ +(* Signature tests -- should print type error *) + +module type S = sig + type t + val f : int -> t + val g : t -> int +end + +module A = struct + type t = int + let f = (+) 1 + let g = (+) 1 +end + +module B : S = A +module C : S = A + +let f (x: B.t) = C.g x diff --git a/examples/ex44-signatures-type-error.alms b/examples/ex44-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex44-signatures-type-error.alms @@ -0,0 +1,18 @@ +(* Signature tests -- should print type error *) + +module type S = sig + type t + val f : int -> t + val g : t -> int +end + +module A = struct + type t = int + let f = (+) 1 + let g = (+) 1 +end + +module B : S = A +module C : S = A + +let f (x: A.t) = B.g x diff --git a/examples/ex45-signatures-type-error.alms b/examples/ex45-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex45-signatures-type-error.alms @@ -0,0 +1,16 @@ +(* Signature tests -- should print type error (missing structure item) *) + +module type S = sig + type t + val f : int -> t + val g : t -> int +end + +module A = struct + type t = int + let g = (+) 1 +end + +module B : S = A +module C : S = A + diff --git a/examples/ex46-signatures-type-error.alms b/examples/ex46-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex46-signatures-type-error.alms @@ -0,0 +1,17 @@ +(* Signature tests -- should print type error *) + +module type S = sig + type t + val f : int -> t + val g : t -> int +end + +module A = struct + type t = int + let f = (+) 1 + let g = (^) "hi" +end + +module B : S = A +module C : S = A + diff --git a/examples/ex47-signatures.alms b/examples/ex47-signatures.alms new file mode 100644 --- /dev/null +++ b/examples/ex47-signatures.alms @@ -0,0 +1,17 @@ +(* Signature tests -- should print nothing *) + +module type S = sig + type t + val g : t -> int +end + +module A = struct + type t = int + let f = (+) 1 + let g = (+) 1 +end + +module B : S = A +module C : S = A + +let f (x: B.t) = B.g x diff --git a/examples/ex48-signatures-type-error.alms b/examples/ex48-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex48-signatures-type-error.alms @@ -0,0 +1,18 @@ +(* Signature tests -- should print type error *) + +module type S = sig + type t + val f : int -> t + val g : t -> int +end + +module A = struct + type t = int + let f = (+) 1 + let g = (+) 1 +end + +module B : S = A +module C : S = A + +let f (x: int) = B.g x diff --git a/examples/ex49-signatures-type-error.alms b/examples/ex49-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex49-signatures-type-error.alms @@ -0,0 +1,14 @@ +(* Signature tests -- should print type error *) + +module type S = sig + type t + val f : t -> t -> t +end + +module A = struct + type t = int + let f : int -> int -o int = (+) +end + +module B : S = A +module C : S = A diff --git a/examples/ex50-signatures.alms b/examples/ex50-signatures.alms new file mode 100644 --- /dev/null +++ b/examples/ex50-signatures.alms @@ -0,0 +1,14 @@ +(* Signature tests -- should print type error *) + +module type S = sig + type t + val f : t -> t -o t +end + +module A = struct + type t = int + let f = (+) +end + +module B : S = A +module C : S = A diff --git a/examples/ex51-signatures-type-error.alms b/examples/ex51-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex51-signatures-type-error.alms @@ -0,0 +1,10 @@ +(* Signature tests -- should print type error *) + +module A : sig + type t qualifier A +end = struct + type t = unit + let f (x: t) = (x, x) +end + +let f (x: A.t) = (x, x) diff --git a/examples/ex52-signatures.alms b/examples/ex52-signatures.alms new file mode 100644 --- /dev/null +++ b/examples/ex52-signatures.alms @@ -0,0 +1,10 @@ +(* Signature tests -- should print nothing *) + +module A : sig + type t +end = struct + type t = unit + let f (x: t) = (x, x) +end + +let f (x: A.t) = (x, x) diff --git a/examples/ex53-signatures.alms b/examples/ex53-signatures.alms new file mode 100644 --- /dev/null +++ b/examples/ex53-signatures.alms @@ -0,0 +1,10 @@ +(* Signature tests -- should print nothing *) + +module A : sig + type `a t qualifier a +end = struct + type `a t = unit + let f[`b] (x: `b t) = (x, x) +end + +let f['b] (x: 'b A.t) = (x, x) diff --git a/examples/ex54-signatures-type-error.alms b/examples/ex54-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex54-signatures-type-error.alms @@ -0,0 +1,10 @@ +(* Signature tests -- should print type error *) + +module A : sig + type `a t qualifier a +end = struct + type `a t = unit + let f[`b] (x: `b t) = (x, x) +end + +let f[`b] (x: `b A.t) = (x, x) diff --git a/examples/ex55-signatures-type-error.alms b/examples/ex55-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex55-signatures-type-error.alms @@ -0,0 +1,7 @@ +(* Signature tests -- should print type error *) + +module A : sig + type `a t +end = struct + type `a t = `a +end diff --git a/examples/ex56-signatures-type-error.alms b/examples/ex56-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex56-signatures-type-error.alms @@ -0,0 +1,7 @@ +(* Signature tests -- should print type error *) + +module A : sig + type -`a t qualifier a +end = struct + type `a t = `a +end diff --git a/examples/ex57-signatures.alms b/examples/ex57-signatures.alms new file mode 100644 --- /dev/null +++ b/examples/ex57-signatures.alms @@ -0,0 +1,7 @@ +(* Signature tests -- should print type error *) + +module A : sig + type +`a t qualifier a +end = struct + type `a t = `a +end diff --git a/examples/ex60-popl-deposit.alms b/examples/ex60-popl-deposit.alms new file mode 100644 --- /dev/null +++ b/examples/ex60-popl-deposit.alms @@ -0,0 +1,32 @@ +(* Example: conventional arrays and locks *) + +#load "libarray" + +module A = Array + +(* The first array example. *) +let deposit (a: int A.array) (acct: int) (amount: int) = + A.set a acct (A.get a acct + amount) + +(* Alms doesn't provide locks, since MVars are strictly better, + * but for the sake of example: *) +module type LOCK = sig + type lock + val new : unit -> lock + val acquire : lock -> unit + val release : lock -> unit +end + +module Lock : LOCK = struct + type lock = unit MVar.mvar + let new = MVar.new + let acquire = MVar.take + let release (mv: lock) = MVar.put mv () +end + +(* The array example with locks. *) +let deposit' (a: int A.array) (acct: int) (amount: int) + (lock: Lock.lock) = + Lock.acquire lock; + A.set a acct (A.get a acct + amount); + Lock.release lock diff --git a/examples/ex61-popl-AfArray.alms b/examples/ex61-popl-AfArray.alms new file mode 100644 --- /dev/null +++ b/examples/ex61-popl-AfArray.alms @@ -0,0 +1,110 @@ +(* Example: affine arrays *) + +module type AF_ARRAY = sig + type 'a array : A + + val new : int -> 'a -> 'a array + val set : 'a array -> int -o 'a -o 'a array + val get : 'a array -> int -o 'a * 'a array + + val size : 'a array -> int * 'a array +end + +#load "libarray" +module A = Array + +module AfArray : AF_ARRAY = struct + type 'a array = 'a A.array + + let new = A.new + let set (a: 'a array) (ix: int) (v: 'a) = + A.set a ix v; a + let get (a: 'a array) (ix: int) = + (A.get a ix, a) + + let size (a: 'a array) = (A.size a, a) +end + +let deposit (a: int AfArray.array) (ix: int) (amount: int) = + let (balance, a) = AfArray.get a ix in + AfArray.set a ix (balance + amount) + +(*** Some definitions used by the next example. ***) + + (* Placing them here ensures that "make test" will catch if they + * stop typing, since the example where they are used demonstrates + * a type error. *) + +module A = AfArray + +(* Swap the values at the given array indices *) +let swapIndices (a: 'a A.array) (i: int) (j: int) = + let (ai, a) = A.get a i in + let (aj, a) = A.get a j in + A.set (A.set a i aj) j ai + +(* Fisher-Yates shuffle *) +let inPlaceShuffle (a: 'a A.array) = + let rec loop (i: int) (a: 'a A.array) : 'a A.array = + if i == 0 + then a + else let j = random_int () % (i + 1) in + loop (i - 1) (swapIndices a i j) in + let (n, a) = A.size a in + loop (n - 1) a + +(* Quicksort *) +let inPlaceSort (a: int A.array) = + let rec quicksort (start: int) (limit: int) (a: int A.array) : int A.array = + if limit > start + then let (pivot, a) = A.get a limit in + let rec loop (i: int) (j: int) (a: int A.array) + : int * int A.array = + if i < limit + then let (ai, a) = A.get a i in + if ai <= pivot + then loop (i + 1) (j + 1) (swapIndices a i j) + else loop (i + 1) j a + else (j, a) in + let (j, a) = loop start start a in + let a = swapIndices a j limit in + let a = quicksort start (j - 1) a in + quicksort (j + 1) limit a + else a in + let (n, a) = A.size a in + quicksort 0 (n - 1) a + +(* For testing: *) +let listToArray (Cons(x,xs): 'a list) = + let n = length xs + 1 in + let rec loop (i: int) (xs: 'a list) (a: 'a A.array) : 'a A.array = + match xs with + | Nil -> a + | Cons(x,xs) -> loop (i + 1) xs (A.set a i x) + in loop 1 xs (A.new n x) + +let arrayToList (a: 'a A.array) = + let (n, a) = A.size a in + let rec loop (i: int) (xs: 'a list) (a: 'a A.array) + : 'a list * 'a A.array = + if i < 0 + then (xs, a) + else let (ai, a) = A.get a i in + loop (i - 1) (Cons(ai, xs)) a + in loop (n - 1) Nil a + +module Tests = struct + let unsorted = Cons(4,Cons(1,Cons(0,Cons(3,Cons(2,Nil))))) + let sorted = Cons(0,Cons(1,Cons(2,Cons(3,Cons(4,Nil))))) + let sorted' = fst(arrayToList(inPlaceSort(listToArray(unsorted)))) + let () = if sorted == sorted' + then () + else failwith "test failed: inPlaceSort (1)" + + let sorted' = + fst(arrayToList(inPlaceSort(inPlaceShuffle(listToArray(sorted))))) + let () = if sorted == sorted' + then () + else failwith "test failed: inPlaceSort (2)" +end + diff --git a/examples/ex62-popl-AfArray-type-error.alms b/examples/ex62-popl-AfArray-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex62-popl-AfArray-type-error.alms @@ -0,0 +1,33 @@ +(* Example: demonstrates a type error using affine arrays. *) + +#load "ex61-popl-AfArray" + +(* This has a type error because a is reused: *) +let deposit (a: int AfArray.array) (ix: int) (amount: int) = + let (balance, _) = AfArray.get a ix in + AfArray.set a ix (balance + amount) + +(* This is a really bad idea -- and a type error! Alms reports: + * + * "examples/ex62-popl-AfArray-type-error.alms" (line 6, column 20): + * type error: Affine variable a : 'a array duplicated in lambda body + * + * (This example is no longer in the paper.) + *) +(* +let shuffleAndSort (a: int AfArray.array) = + let f1 = Future.new (fun _ -> inPlaceShuffle a) in + let f2 = Future.new (fun _ -> inPlaceSort a) in + Future.sync f1; Future.sync f2 + *) + +(* N.B.: The duplication is the only cause of the type error. + * This version is well typed: + +let shuffleAndSort (a: int AfArray.array) (b: int AfArray.array) = + let f1 = Future.new (fun _ -> inPlaceShuffle a) in + let f2 = Future.new (fun _ -> inPlaceSort b) in + Future.sync f1; Future.sync f2 + + *) + diff --git a/examples/ex63-popl-CapArray.alms b/examples/ex63-popl-CapArray.alms new file mode 100644 --- /dev/null +++ b/examples/ex63-popl-CapArray.alms @@ -0,0 +1,107 @@ +(* Example: unlimited arrays with affine capabilities *) + +module type CAP_ARRAY = sig + type ('a,'b) array + type 'b cap : A + + val new : int -> 'a -> ex 'b. ('a,'b) array * 'b cap + val set : ('a,'b) array -> int -> 'a -> 'b cap -> 'b cap + val get : ('a,'b) array -> int -> 'b cap -> 'a * 'b cap + + val dirtyGet : ('a,'b) array -> int -> 'a + val size : ('a,'b) array -> int +end + +#load "libarray" +module A = Array + +module CapArray : CAP_ARRAY = struct + type ('a,'b) array = 'a A.array + type 'a cap = unit + + let new (size: int) (init: 'a) = (A.new size init, ()) + let set (a: ('a,'b) array) (ix: int) (v: 'a) _ = + A.set a ix v + let get (a: ('a,'b) array) (ix: int) _ = + (A.get a ix, ()) + + let dirtyGet = A.get + let size = A.size +end + +let deposit (a: (int,'b) CapArray.array) (ix: int) (amount: int) + (cap: 'b CapArray.cap) = + let (balance, cap) = CapArray.get a ix cap in + CapArray.set a ix (balance + amount) cap + +module A = CapArray + +(* Swap the values at the given array indices *) +let swapIndices (a: ('a,'b) A.array) (i: int) (j: int) (cap: 'b A.cap) = + let (ai, cap) = A.get a i cap in + let (aj, cap) = A.get a j cap in + A.set a j ai (A.set a i aj cap) + +(* Fisher-Yates shuffle *) +let inPlaceShuffle (a: ('a,'b) A.array) (cap: 'b A.cap) = + let rec loop (i: int) (cap: 'b A.cap) : 'b A.cap = + if i == 0 + then cap + else let j = random_int () % (i + 1) in + loop (i - 1) (swapIndices a i j cap) + in loop (A.size a - 1) cap + +let dirtySumArray (a: (int,'b) A.array) = + let rec loop (i: int) (acc: int) : int = + if i < 0 + then acc + else loop (i - 1) (acc + A.dirtyGet a i) + in loop (A.size a - 1) 0 + +let shuffleAndDirtySum (a: (int,'b) A.array) (cap: 'b A.cap) = + let f1 = Future.new (fun _ -> inPlaceShuffle a cap) in + let f2 = Future.new (fun _ -> dirtySumArray a) in + (Future.sync f1, Future.sync f2) + +(* For testing: *) +let listToArray (Cons(x,xs): 'a list) = + let n = length xs + 1 in + let ('b, a, cap) = A.new n x in + let rec loop (i: int) (xs: 'a list) (cap: 'b A.cap) : 'b A.cap = + match xs with + | Nil -> cap + | Cons(x,xs) -> loop (i + 1) xs (A.set a i x cap) + in Pack('b, a, loop 1 xs cap) + +let dirtyArrayToList (a: ('a,'b) A.array) = + let n = A.size a in + let rec loop (i: int) (xs: 'a list) : 'a list = + if i < 0 + then xs + else loop (i - 1) (Cons(A.dirtyGet a i, xs)) + in loop (n - 1) Nil + +let randomIntList = + let rec loop (acc: int list) (len: int) : int list = + if len == 0 + then acc + else loop (Cons(random_int (), acc)) (len - 1) + in loop Nil + +module Tests = struct + let test (size: int) = + let ('b, a, cap) = listToArray (randomIntList size) in + let correctsum = dirtySumArray a in + let (_, dirtysum) = shuffleAndDirtySum a cap + in if correctsum == dirtysum + then () + else putStrLn ("dirtySumArray observed race condition: " ^ + string_of_int correctsum ^ " <> " ^ + string_of_int dirtysum) + + (* experimentally, it appears that size = 100 gives us about a 20% + * chance of observing a race. size = 1000 seems to observe a race + * almost without fail. *) + let _ = test 100 +end + diff --git a/examples/ex64-popl-CapLockArray.alms b/examples/ex64-popl-CapLockArray.alms new file mode 100644 --- /dev/null +++ b/examples/ex64-popl-CapLockArray.alms @@ -0,0 +1,61 @@ +(* Example: arrays with capability locks *) + +#load "ex63-popl-CapArray" + +module type CAP_LOCK_ARRAY = sig + include CAP_ARRAY + + (* Already inherited new from CAP_ARRAY, so we need to use a + * different name here: *) + val new' : int -> 'a -> ex 'b. ('a,'b) array + val acquire : ('a, 'b) array -> 'b cap + val release : ('a, 'b) array -> 'b cap -> unit +end + +module CapLockArray : CAP_LOCK_ARRAY = struct + open CapArray + + type ('a,'b) array = ('a,'b) CapArray.array * 'b cap MVar.mvar + + let new' (size: int) (init: 'a) = + let ('b, a, cap) = new size init in + (a, MVar.new cap) + + let acquire (a: ('a,'b) array) = MVar.take (snd a) + let release (a: ('a,'b) array) = MVar.put (snd a) + + let new (size: int) (init: 'a) = + let a = new' size init in (a, acquire a) + + let set (a: ('a,'b) array) = set (fst a) + let get (a: ('a,'b) array) = get (fst a) + let dirtyGet (a: ('a,'b) array) = dirtyGet (fst a) + let size (a: ('a,'b) array) = size (fst a) +end + +module A = CapLockArray + +let deposit (a: (int,'b) A.array) (acct: int) (amount: int) = + let cap = A.acquire a in + let (balance, cap) = A.get a acct cap in + let cap = A.set a acct (balance + amount) cap in + A.release a cap + +(* To use the imperative variable notation right now, we need set to + * return a pair, as the translation expects the result of operations + * that take imperative variables to produce both a direct result and a + * new value for the imperative variable. (If the notation proves + * beneficial it may be worth defining interfaces in this way all the + * time. *) +module A = struct + open CapLockArray + let set (a: ('a,'b) array) (ix: int) (v: 'a) (cap: 'b cap) = + ((), set a ix v cap) +end + +(* Example with imperative variables: *) +let deposit' (a: (int,'b) A.array) (acct: int) (amount: int) = + let !cap = A.acquire a in + A.set a acct (A.get a acct cap + amount) cap; + A.release a cap + diff --git a/examples/ex65-popl-Fractional.alms b/examples/ex65-popl-Fractional.alms new file mode 100644 --- /dev/null +++ b/examples/ex65-popl-Fractional.alms @@ -0,0 +1,39 @@ +(* Example: arrays with fractional capabilities *) + +module type FRACTIONAL = sig + type ('a,'b) array + type 1 + type 2 + type 'c / 'd + type ('b,'c) cap : A + + val new : int -> 'a -> + ex 'b. ('a,'b) array * ('b,1) cap + val get : ('a,'b) array -> int -> + ('b,'c) cap -> 'a * ('b,'c) cap + val set : ('a,'b) array -> int -> 'a -> + ('b,1) cap -> ('b,1) cap + + val split : ('b,'c) cap -> ('b,'c/2) cap * ('b,'c/2) cap + val join : ('b,'c/2) cap * ('b,'c/2) cap -> ('b,'c) cap +end + +#load "libarray" +module A = Array + +module Fractional : FRACTIONAL = struct + type ('a,'b) array = 'a A.array + type 1 + type 2 + type 'c / 'd + type ('b,'c) cap = unit + + let new (size: int) (init: 'a) = (A.new size init, ()) + + let get (ar: 'a A.array) (ix: int) _ = (A.get ar ix, ()) + let set (ar: 'a A.array) (ix: int) (new: 'a) _ = + A.set ar ix new + + let split _ = ((), ()) + let join _ = () +end diff --git a/examples/ex66-popl-RWLock.alms b/examples/ex66-popl-RWLock.alms new file mode 100644 --- /dev/null +++ b/examples/ex66-popl-RWLock.alms @@ -0,0 +1,196 @@ +(* Example: reader-writer locks with capabilities *) + +module type RW_LOCK = sig + type ('a,'b) array + type read + type write + type 'b@'c : A + + val new : int -> 'a -> ex 'b. ('a, 'b) array + (* build is more convenient than new, but it would take more space + * in the paper. *) + val build : int -> (int -> 'a) -> ex 'b. ('a, 'b) array + + val acquireR : ('a,'b) array -> 'b@read + val acquireW : ('a,'b) array -> 'b@write + val release : ('a,'b) array -> 'b@'c -> unit * unit + + val get : ('a,'b) array -> int -> 'b@'c -> 'a * 'b@'c + val set : ('a,'b) array -> int -> 'a -> 'b@write -> unit * 'b@write + (* We added (unit * _) to result types of release and get to support + * the imperative variable notation. *) +end + +#load "libqueue" +#load "libarray" + +module A = Array + +module RWLock : RW_LOCK = struct + (* We keep a queue of waiting readers and writers blocked on mvars. + * We maintain the invariant that if read-only capabilities are + * outstanding, the either the queue is empty or the head of the + * queue is either a writer. We don't allow readers to jump ahead in + * line, because that could starve writers. *) + type queue = (unit MVar.mvar + unit MVar.mvar) Queue.queue + (* The lock state is synchronized by an mvar. We keep the queue and + * an integer, which tells us what capabilites are outstanding: + * - -1 for read-write + * - 0 for nothing outstanding + * - N >= 0 for N readers + *) + type lock = (queue * int) MVar.mvar + type ('a,'t) array = 'a A.array * lock + type read + type write + type 't@'m = unit + + let new (size: int) (init: 'a) = + (A.new size init, MVar.new ((Queue.empty : queue), 0)) + let build (size: int) (builder: int -> 'a) = + (A.build size builder, MVar.new ((Queue.empty : queue), 0)) + + (* To see what's happening, uncomment the rest of show. *) + let show (who: string) ((q, count): queue * int) = () + (* + ; + putStr ("[" ^ who ^ "] count: " ^ string_of_int count ^ " "); + let rec loop (q: queue) : unit = + match Queue.dequeueA q with + | None -> putStr "\n" + | Some (Left _, q) -> putStr "R"; loop q + | Some (Right _, q) -> putStr "W"; loop q + in loop q; + *) + + let showL (who: string) (lock: lock) = + let (q, count) = MVar.take lock in + show who (q, count); + MVar.put lock (q, count) + + (* After the queue has changed, wake restores our queue invariant + * described above. *) + let wake (lock: lock) = + showL "wake" lock; + let rec wakeReaders (q: queue) (count: int) : unit = + show "wakeReaders" (q, count); + match Queue.dequeueA q with + | Some (Left reader, q) -> + MVar.put reader (); + wakeReaders q (count + 1) + | _ -> MVar.put lock (q, count); show "endWR" (q, count) in + match MVar.take lock with + | (q, -1) -> MVar.put lock (q, -1) + | (q, 0) -> (match Queue.dequeueA q with + | None -> MVar.put lock (q, 0) + | Some (Right writer, q) -> + MVar.put writer (); + MVar.put lock (q, -1) + | _ -> wakeReaders q 0) + | (q, count) -> wakeReaders q count + + (* acquireR creates an mvar for the requesting reader to wait on and + * adds it to the tail of the queue. It calls wake to process the + * queue and then waits in the mvar. *) + let acquireR ((rep, lock) : ('a,'t) array) = + let (q, count) = MVar.take lock in + show "acquireR" (q, count); + let wait = MVar.newEmpty[unit] () in + MVar.put lock (Queue.enqueue (Left wait) q, count); + wake lock; + MVar.take wait + + (* Same idea as acquireR -- could probably refactor. *) + let acquireW ((rep, lock) : ('a,'t) array) = + let (q, count) = MVar.take lock in + show "acquireW" (q, count); + let wait = MVar.newEmpty[unit] () in + MVar.put lock (Queue.enqueue (Right wait) q, count); + wake lock; + MVar.take wait + + (* We don't need separate releaseR and releaseW because the count has + * enough information to figure out what kind of release is happening. + * We update the counter and then call wake to process the queue. *) + let release ((rep, lock) : ('a,'t) array) _ = + let (q, count) = MVar.take lock in + show "release" (q, count); + let count' = if count > 1 then count - 1 else 0 in + MVar.put lock (q, count'); + (wake lock, ()) + + let get ((rep, _) : ('a,'t) array) (ix: int) () = + (A.get rep ix, ()) + let set ((rep, _) : ('a,'t) array) (ix: int) (v: 'a) () = + (A.set rep ix v, ()) +end + +(* Try + * RWLockTest.go n + * to create n random readers and writers that all attempt to + * acquire the lock. Once acquired, they perform an array operation, + * sleep a bit, and then check that the array hasn't changed while + * they looked away. + * + * Currently we create writers with probably 1/8 so + * that we can see a lot of reader overlap, though other values may be + * interesting as well. + *) +module RWLockTest = struct + open RWLock + + let makeCounter () = + let counter = MVar.new 0 in + fun () -> + let count = MVar.take counter in + MVar.put counter (count + 1); + count + + let delay () = Thread.delay 250000 + + let reader (me: int) (a: (int,'t) array) = + Future.new + (fun () -> + putStrLn ("reader " ^ string_of_int me ^ ": waiting"); + let !cap = acquireR a in + putStrLn ("reader " ^ string_of_int me ^ ": acquired"); + let n = get a 0 cap in + delay (); + let m = get a 0 cap in + putStrLn ("reader " ^ string_of_int me ^ ": releasing"); + release a cap; + if n != m + then failwith "reader: meh" + else ()) + + let writer (me: int) (a: (int,'t) array) = + Future.new + (fun () -> + putStrLn ("writer " ^ string_of_int me ^ ": waiting"); + let !cap = acquireW a in + putStrLn ("writer " ^ string_of_int me ^ ": acquired"); + set a 0 me cap; + delay (); + let me' = get a 0 cap in + putStrLn ("writer " ^ string_of_int me ^ ": releasing"); + release a cap; + if me != me' + then failwith "writer: meh" + else ()) + + let go (iters: int) = + let next = makeCounter () in + let ('t,a) = build 10 (fun x:int -> x) in + let rec start (n: int) : U Future.future list = + if n < 1 + then Nil[any] + else Cons (if random_int () % 8 == 0 + then writer (next ()) a + else reader (next ()) a, + start (n - 1)) in + let rec stop (fs: U Future.future list) : unit = + match fs with + | Nil -> () + | Cons(f, fs) -> Future.sync f; stop fs in + stop (start iters) +end diff --git a/examples/futures1.alms b/examples/futures1.alms new file mode 100644 --- /dev/null +++ b/examples/futures1.alms @@ -0,0 +1,27 @@ +(* An example with futures *) + +#load "libthread" + +let prompt : unit -> string Future.future = + fun _:unit -> Future.new getLine + +let printDots : int -> int -> unit = + let rec loop (count : int) (delay : int) : unit = + if count <= 0 + then () + else + putStr "."; + flush (); + AThread.delay (1000 * delay); + loop (count - 1) delay + in loop + +let main : string -> unit = + fun message: string -> + putStrLn message; + let future = prompt () in + printDots 80 20; + putStrLn ""; + putStrLn (Future.sync future) + +in main "whadday say? " diff --git a/examples/netcat.alms b/examples/netcat.alms new file mode 100644 --- /dev/null +++ b/examples/netcat.alms @@ -0,0 +1,52 @@ +(* Poor programmer's telnet *) + +open Prim.Socket + +local + open IO +with + let rec sendThread (sock: socket): unit = + if hIsEOF stdin + then + shutdown sock ShutdownSend + else + try + send sock (getLine () ^ "\r\n"); + sendThread sock + with + IOError _ -> () + + let rec recvThread (sock: socket): unit = + try + putStr (recv sock 1024); recvThread sock + with + IOError _ -> () +end + +let setupConnection (addr: sockAddr): socket = + let s = socket AF_INET Stream defaultProtocol in + connect s addr; + s + +let teardownConnection (sock: socket): unit = + close sock + +let getAddr (): sockAddr = + match getArgs () with + | Cons(host, Cons(port, Nil)) + -> let info = AddrInfo(Nil[addrInfoFlag], AF_INET, + Stream, defaultProtocol, + SockAddrInet(PortNum 0, 0), None[string]) in + (match getAddrInfo (Some info) (Some host) (Some port) with + | Cons (AddrInfo (_, _, _, _, sockAddr, _), _) -> sockAddr + | _ -> failwith ("Could not resolve address "^host^":"^port)) + | _ -> failwith ("Usage: " ^ getProgName () ^ " HOST SERVICE") + +let main () = + let sock = setupConnection (getAddr ()) in + let wait = Future.new (fun () -> recvThread sock) in + sendThread sock; + Future.sync wait; + teardownConnection sock + +in main () diff --git a/examples/run-test.sh b/examples/run-test.sh new file mode 100644 --- /dev/null +++ b/examples/run-test.sh @@ -0,0 +1,35 @@ +#!/bin/sh + +exe="$1" +test="$2" + +echo "$test" + +case "$test" in + *-type-error.alms) + if ! ./"$exe" "$test" 2>&1 | + grep '^\(type\|name\) error: ' > /dev/null; then + echo + echo "TEST FAILED (expected type error):" + head -1 "$test" + echo + fi >&2 + ;; + *-blame-error.alms) + if ! ./"$exe" "$test" 2>&1 | + grep ' Blame (' > /dev/null; then + echo + echo "TEST FAILED (expected blame error):" + head -1 "$test" + echo + fi >&2 + ;; + *) + if ! ./"$exe" "$test" > /dev/null; then + echo + echo "TEST FAILED:" + head -1 "$test" + echo + fi >&2 + ;; +esac diff --git a/examples/run-tests.sh b/examples/run-tests.sh new file mode 100644 --- /dev/null +++ b/examples/run-tests.sh @@ -0,0 +1,16 @@ +#/bin/sh + +EXE="$1" +EXAMPLES="$2" +LIB="`dirname "$EXAMPLES"`/lib" + +for i in $EXAMPLES/ex*.alms $LIB/lib*.alms; do + /bin/sh $EXAMPLES/run-test.sh $EXE "$i" +done + +for i in $EXAMPLES/*.in; do + out="`echo $i | sed 's/\.in$/.out/'`" + src="`echo $i | sed 's/-[[:digit:]]*\.in$/.alms/'`" + echo "$i" + $EXE "$src" < "$i" | diff "$out" - +done diff --git a/examples/session-types-interactive.alms b/examples/session-types-interactive.alms new file mode 100644 --- /dev/null +++ b/examples/session-types-interactive.alms @@ -0,0 +1,46 @@ +(* An example with session types, including recursion. + Reads natural numbers (very brittle) from standard input + until getting a blank line, then prints the sum. *) + +#load "libthread" +#load "libsessiontype" + +open SessionType + +type protocol = ?int; 1 |+| !int; protocol + +let server = + let rec loop (acc : int) + (c : protocol dual channel) + : unit = + match follow c with + | Left c -> + send c acc; + () + | Right c -> + let (x, c) = recv c in + loop (acc + x) c + in loop 0 + +let client = + let rec loop (c : protocol channel) : int = + let s = getLine () in + if s == "" + then + let c = sel1 c in + let (r, _) = recv c in + r + else + let c = sel2 c in + let c = send c (int_of_string s) in + loop c + in loop + +let main = + fun _ : unit -> + let rv = newRendezvous[protocol] () in + AThread.fork (fun _:unit -> server (accept rv)); + client (request rv) + +in print (main ()) + diff --git a/examples/session-types-polygons-1.in b/examples/session-types-polygons-1.in new file mode 100644 --- /dev/null +++ b/examples/session-types-polygons-1.in @@ -0,0 +1,7 @@ +0x + 0y + 1z + 0 > 0 + +(1, 0, 1) +(1, 0, -1) +(-1, 0, -1) +(-1, 0, 1) + diff --git a/examples/session-types-polygons-1.out b/examples/session-types-polygons-1.out new file mode 100644 --- /dev/null +++ b/examples/session-types-polygons-1.out @@ -0,0 +1,4 @@ +(1.0, 0.0, 1.0) +(1.0, 0.0, 0.0) +(-1.0, 0.0, 0.0) +(-1.0, 0.0, 1.0) diff --git a/examples/session-types-polygons-2.in b/examples/session-types-polygons-2.in new file mode 100644 --- /dev/null +++ b/examples/session-types-polygons-2.in @@ -0,0 +1,6 @@ +0x + 0y + 1z + 0 > 0 + +(1, 0, 1) +(1, 0, -1) +(-1, 0, -1) + diff --git a/examples/session-types-polygons-2.out b/examples/session-types-polygons-2.out new file mode 100644 --- /dev/null +++ b/examples/session-types-polygons-2.out @@ -0,0 +1,3 @@ +(1.0, 0.0, 1.0) +(1.0, 0.0, 0.0) +(0.0, 0.0, 0.0) diff --git a/examples/session-types-polygons-3.in b/examples/session-types-polygons-3.in new file mode 100644 --- /dev/null +++ b/examples/session-types-polygons-3.in @@ -0,0 +1,15 @@ +0x + 0y + 1z + 0 > 0 +0x + 1y + 0z + 0 > 0 +1x + 0y + 0z + 0 > 0 + +(0, 0, -1) +(3, 3, 2) +(-6, 3, 2) +(1, 10, 9) +(8, 4, 4) +(3, -1, -1) +(-1, 3, 3) +(-1, -1, 3) +(-1, -1, -1) +(0, 0, -1) + diff --git a/examples/session-types-polygons-3.out b/examples/session-types-polygons-3.out new file mode 100644 --- /dev/null +++ b/examples/session-types-polygons-3.out @@ -0,0 +1,10 @@ +(1.0, 1.0, 0.0) +(3.0, 3.0, 2.0) +(0.0, 3.0, 2.0) +(0.0, 9.0, 8.0) +(1.0, 10.0, 9.0) +(8.0, 4.0, 4.0) +(4.0, 0.0, 0.0) +(2.0, 0.0, 0.0) +(0.0, 2.0, 2.0) +(0.0, 0.0, 0.0) diff --git a/examples/session-types-polygons.alms b/examples/session-types-polygons.alms new file mode 100644 --- /dev/null +++ b/examples/session-types-polygons.alms @@ -0,0 +1,211 @@ +-- Sutherland-Hodgman (1974) re-entrant polygon clipping + +#load "libthread" +#load "libsessiontype" + +open SessionType + +let putAny 'a (x: 'a) = putStr (string_of x) + +-- +-- We first build a tiny 3-D geometry library +-- + +-- Points and planes in R^3. +type point = Point of float * float * float +type plane = Plane of float * float * float * float + +-- We use the plane Plane(a, b, c, d) to represent the open half-space +-- { Point(x, y, z) | ax + by + cz + d > 0 } + +let string_of_point (Point(x, y, z): point) = + "(" ^ string_of x ^ ", " ^ string_of y ^ ", " ^ string_of z ^ ")" + +let string_of_plane (Plane(a, b, c, d): plane) = + string_of a ^ "x + " ^ string_of b ^ "y + " ^ + string_of c ^ "z + " ^ string_of d ^ " > 0" + +(* Some of this should be in the library! *) +let splitWhile['a] : ('a -> bool) -> 'a list -> 'a list * 'a list + = fun pred: ('a -> bool) -> + let rec loop (acc: 'a list) (xs: 'a list) : 'a list * 'a list = + match xs with + | Nil -> (rev acc, Nil['a]) + | Cons(x,xs') -> if pred x + then loop (Cons(x,acc)) xs' + else (rev acc, xs) + in loop Nil['a] + +let not (b: bool) = if b then false else true + +let notp['a] (pred: 'a -> bool): 'a -> bool = + fun a: 'a -> not (pred a) + +let isSpace (c: int): bool = + match c with + | ' ' -> true + | '\t' -> true + | '\n' -> true + | '\r' -> true + | _ -> false + +let dropSpace (cs : int list) : int list = + let (_, result) = splitWhile isSpace cs in result + +let parsePoint (s : string) : point = + let foil (x: int list) = float_of_string (implode x) in + let cs = explode s in + let Cons('(', cs) = dropSpace cs in + let (x, Cons(_,cs)) = splitWhile (notp ((==) ',')) (dropSpace cs) in + let (y, Cons(_,cs)) = splitWhile (notp ((==) ',')) (dropSpace cs) in + let (z, Cons(_,cs)) = splitWhile (notp ((==) ')')) (dropSpace cs) in + Point (foil x, foil y, foil z) + +let parsePlane (s: string) : plane = + let foil (x: int list) = float_of_string (implode x) in + let cs = explode s in + let (a, Cons(_,cs)) = splitWhile (notp ((==) 'x')) (dropSpace cs) in + let Cons('+',cs) = dropSpace cs in + let (b, Cons(_,cs)) = splitWhile (notp ((==) 'y')) (dropSpace cs) in + let Cons('+',cs) = dropSpace cs in + let (c, Cons(_,cs)) = splitWhile (notp ((==) 'z')) (dropSpace cs) in + let Cons('+',cs) = dropSpace cs in + let (d, Cons(_,cs)) = splitWhile (notp ((==) '>')) (dropSpace cs) in + let Cons('0',cs) = dropSpace cs in + Plane (foil a, foil b, foil c, foil d) + +-- Is the point above the plane? (i.e., in the semi-space) +let isPointAbovePlane (Point(x, y, z): point) + (Plane(a, b, c, d): plane): bool = + a *. x +. b *. y +. c *. z +. d >. 0.0 + +-- Does the line segment between the two points intersect the plane, +-- and if so, where? +let intersect (Point(x1, y1, z1) as p1 : point) + (Point(x2, y2, z2) as p2 : point) + (Plane(a, b, c, d) as plane : plane): point option = + if isPointAbovePlane p1 plane == isPointAbovePlane p2 plane + then None[point] + else let t = (a *. x1 +. b *. y1 +. c *. z1 +. d) /. + (a *. (x1 -. x2) +. + b *. (y1 -. y2) +. + c *. (z1 -. z2)) in + let x = x1 +. (x2 -. x1) *. t in + let y = y1 +. (y2 -. y1) *. t in + let z = z1 +. (z2 -. z1) *. t in + Some (Point (x, y, z)) + +-- +-- When we implement the algorithm in A, we will treat points +-- and planes as opaque objects, so there's no need to marshal them, +-- but we do need to marshal options for the result of intersect. +-- The standard way to do this is to write an elimination function +-- in the "from" sublanguage and then call the elimination function +-- with "to" constructors in the "to" sublanguage: +-- + +let maybeC['a,'r] (some: 'a -> 'r) (none: 'r) (opt: 'a option): 'r = + match opt with + | Some a -> some a + | None -> none + +-- +-- In sublanguage A, our protocol is to send an unbounded +-- sequence of points: +-- + +type 'a stream = mu 'x. 1 |&| ?'a; 'x + +-- +-- Each transducer takes a plane to clip by, and two rendezvous objects, +-- the first on which it expects to receive points, and the second on +-- which it will send points. +-- + +let clipper (plane: plane) + (ic: point stream channel)| + (oc: point stream dual channel): unit = + let finish (oc: point stream dual channel) = + sel1 oc; () in + let put (oc: point stream dual channel) (pt: point) = + send (sel2 oc) pt in + let putCross (oc: point stream dual channel) + (p1: point) (p2: point) = + match intersect p1 p2 plane with + | Some pt -> put oc pt + | None -> oc in + let putVisible (oc: point stream dual channel) + (pt: point) = + if isPointAbovePlane pt plane + then put oc pt + else oc in + match follow ic with + | Left _ -> finish oc + | Right ic -> + let (pt0, ic) = recv ic in + let rec loop (ic: point stream channel)| + (oc: point stream dual channel) + (pt: point) : unit = + let oc = putVisible oc pt in + match follow ic with + | Left _ -> let oc = putCross oc pt pt0 in + finish oc + | Right ic -> let (pt', ic) = recv ic in + let oc = putCross oc pt pt' in + loop ic oc pt' + in loop ic oc pt0 + +let printer : point stream channel -> unit = + let rec loop (ic: point stream channel): unit = + match follow ic with + | Left _ -> () + | Right ic -> let (pt, ic) = recv ic in + putStrLn (string_of_point pt); + loop ic + in loop + +-- The main protocol for the program, which lets us split our parser +-- from our main loop. +type main_prot = mu 'x. point stream |&| ?plane; 'x + +let parser : main_prot dual channel -> unit = + let rec plane_loop (oc: main_prot dual channel): unit = + match getLine () with + | "" -> point_loop (sel1 oc) + | s -> let plane = parsePlane s in + let oc = send (sel2 oc) plane in + plane_loop oc + and point_loop (oc: point stream dual channel): unit = + match getLine () with + | "" -> sel1 oc; () + | s -> let point = parsePoint s in + let oc = send (sel2 oc) point in + point_loop oc + in plane_loop + +let main : unit -> unit = + let rec get_planes (acc: plane list) (ic: main_prot channel) + : plane list * point stream channel = + match follow ic with + | Left ic -> (rev acc, ic) + | Right ic -> let (plane, ic) = recv ic in + get_planes (Cons(plane,acc)) ic in + let rec connect (planes: plane list) + (ic: point stream channel) + : point stream channel = + match planes with + | Nil -> ic + | Cons(plane,rest) -> + let outrv = newRendezvous[point stream] () in + AThread.fork (fun () -> + clipper plane ic (accept outrv)); + connect rest (request outrv) in + fun () -> + let rv = newRendezvous[main_prot] () in + let _ = AThread.fork (fun () -> parser (accept rv)) in + let (planes, ic) = get_planes Nil[plane] (request rv) in + let ic = connect planes ic in + printer ic + +in + main () diff --git a/examples/session-types-polygons2.alms b/examples/session-types-polygons2.alms new file mode 100644 --- /dev/null +++ b/examples/session-types-polygons2.alms @@ -0,0 +1,215 @@ +-- Sutherland-Hodgman (1974) re-entrant polygon clipping + +#load "libthread" +#load "libsessiontype2" + +open SessionType + +-- Some basic, low-level stuff +let putAny 'a (x: 'a) = putStr (string_of x) + +-- +-- We first build a 3-D geometry library in sublanguage C: +-- + +-- Points and planes in R^3. +type point = Point of float * float * float +type plane = Plane of float * float * float * float + +-- We use the plane Plane(a, b, c, d) to represent the open half-space +-- { Point(x, y, z) | ax + by + cz + d > 0 } + +let string_of_point (Point(x, y, z): point) = + "(" ^ string_of x ^ ", " ^ string_of y ^ ", " ^ string_of z ^ ")" + +let string_of_plane (Plane(a, b, c, d): plane) = + string_of a ^ "x + " ^ string_of b ^ "y + " ^ + string_of c ^ "z + " ^ string_of d ^ " > 0" + +let splitWhile['a] : ('a -> bool) -> 'a list -> 'a list * 'a list + = fun pred: ('a -> bool) -> + let rec loop (acc: 'a list) (xs: 'a list) : 'a list * 'a list = + match xs with + | Nil -> (rev acc, Nil['a]) + | Cons(x,xs') -> if pred x + then loop (Cons(x,acc)) xs' + else (rev acc, xs) + in loop Nil['a] + +let notp['a] (pred: 'a -> bool) (x: 'a) = not (pred x) + +let isSpace (c: int): bool = + match c with + | ' ' -> true + | '\t' -> true + | '\n' -> true + | '\r' -> true + | _ -> false + +let dropSpace (cs : int list) : int list = + let (_, result) = splitWhile isSpace cs in result + +let parsePoint (s : string) : point = + let foil (x: int list) = float_of_string (implode x) in + let cs = explode s in + let Cons('(', cs) = dropSpace cs in + let (x, Cons(_,cs)) = splitWhile (notp ((==) ',')) (dropSpace cs) in + let (y, Cons(_,cs)) = splitWhile (notp ((==) ',')) (dropSpace cs) in + let (z, Cons(_,cs)) = splitWhile (notp ((==) ')')) (dropSpace cs) in + Point (foil x, foil y, foil z) + +let parsePlane (s: string) : plane = + let foil (x: int list) = float_of_string (implode x) in + let cs = explode s in + let (a, Cons(_,cs)) = splitWhile (notp ((==) 'x')) (dropSpace cs) in + let Cons('+',cs) = dropSpace cs in + let (b, Cons(_,cs)) = splitWhile (notp ((==) 'y')) (dropSpace cs) in + let Cons('+',cs) = dropSpace cs in + let (c, Cons(_,cs)) = splitWhile (notp ((==) 'z')) (dropSpace cs) in + let Cons('+',cs) = dropSpace cs in + let (d, Cons(_,cs)) = splitWhile (notp ((==) '>')) (dropSpace cs) in + let Cons('0',cs) = dropSpace cs in + Plane (foil a, foil b, foil c, foil d) + +-- Is the point above the plane? (i.e., in the semi-space) +let isPointAbovePlane (Point(x, y, z): point) + (Plane(a, b, c, d): plane): bool = + a *. x +. b *. y +. c *. z +. d >. 0.0 + +-- Does the line segment between the two points intersect the plane, +-- and if so, where? +let intersect (Point(x1, y1, z1) as p1 : point) + (Point(x2, y2, z2) as p2 : point) + (Plane(a, b, c, d) as plane : plane): point option = + if isPointAbovePlane p1 plane == isPointAbovePlane p2 plane + then None[point] + else let t = (a *. x1 +. b *. y1 +. c *. z1 +. d) /. + (a *. (x1 -. x2) +. + b *. (y1 -. y2) +. + c *. (z1 -. z2)) in + let x = x1 +. (x2 -. x1) *. t in + let y = y1 +. (y2 -. y1) *. t in + let z = z1 +. (z2 -. z1) *. t in + Some (Point (x, y, z)) + +-- +-- When we implement the algorithm in A, we will treat points +-- and planes as opaque objects, so there's no need to marshal them, +-- but we do need to marshal options for the result of intersect. +-- The standard way to do this is to write an elimination function +-- in the "from" sublanguage and then call the elimination function +-- with "to" constructors in the "to" sublanguage: +-- + +let maybeC['a,'r] (some: 'a -> 'r) (none: 'r) (opt: 'a option): 'r = + match opt with + | Some a -> some a + | None -> none + +-- +-- In sublanguage A, our protocol is to send an unbounded +-- sequence of points: +-- + +type 'a stream = ?->('a step) + and 'a step = Done of 1 channel + | Next of (?'a; 'a stream) channel + +-- +-- Each transducer takes a plane to clip by, and two rendezvous objects, +-- the first on which it expects to receive points, and the second on +-- which it will send points. +-- + +let clipper (plane: plane) + !(ic: point stream channel, oc: point stream dual channel) + : unit * (1 channel * 1 channel) = + let finish !(oc: point stream dual channel) = + choose Done[point] oc in + let put (pt: point) !(oc: point stream dual channel) = + choose Next[point] oc; + send pt oc in + let putCross (p1: point) (p2: point) + !(oc: point stream dual channel) = + match intersect p1 p2 plane with + | Some pt -> put pt oc + | None -> () in + let putVisible (pt: point) + !(oc: point stream dual channel) = + if isPointAbovePlane pt plane + then put pt oc + else () in + follow ic; + match ic with + | Done ic -> finish oc + | Next ic -> + let pt0 = recv ic in + let rec loop (pt: point) + !(ic: point stream channel, + oc: point stream dual channel) + : unit * (1 channel * 1 channel) = + putVisible pt oc; + follow ic; + match ic with + | Done ic -> putCross pt pt0 oc; + finish oc + | Next ic -> let pt' = recv ic in + putCross pt pt' oc; + loop pt' (ic, oc) + in loop pt0 (ic, oc) + +let rec printer !(ic: point stream channel): unit * 1 channel = + follow ic; + match ic with + | Done ic -> () + | Next ic -> putStrLn (string_of_point (recv ic)); + printer ic + +-- The main protocol for the program, which lets us split our parser +-- from our main loop. +type main_prot = ?->main2 + and main2 = Planes of (?plane; main_prot) channel + | Points of point stream channel + +let parser : main_prot dual channel -> unit * 1 channel = + let rec plane_loop !(oc: main_prot dual channel): unit * 1 channel = + match getLine () with + | "" -> choose Points oc; + point_loop oc + | s -> choose Planes oc; + send (parsePlane s) oc; + plane_loop oc + and point_loop !(oc: point stream dual channel): unit * 1 channel = + match getLine () with + | "" -> choose Done[point] oc + | s -> choose Next[point] oc; + send (parsePoint s) oc; + point_loop oc + in plane_loop + +let main = + let rec get_planes (acc: plane list) !(ic: main_prot channel) + : plane list * point stream channel = + follow ic; + match ic with + | Points ic -> rev acc + | Planes ic -> get_planes (Cons(recv ic,acc)) ic in + let rec connect (planes: plane list) + (ic: point stream channel) + : point stream channel = + match planes with + | Nil -> ic + | Cons(plane,rest) -> + let outrv = newRendezvous[point stream] () in + AThread.fork + (fun () -> clipper plane (ic, accept outrv); ()); + connect rest (request outrv) in + fun () -> + let rv = newRendezvous[main_prot] () in + let _ = AThread.fork (fun () -> parser (accept rv); ()) in + let (planes, ic) = get_planes Nil[plane] (request rv) in + let ic = connect planes ic in + printer ic + +in + main () diff --git a/examples/skewness-dynamic-bad.alms b/examples/skewness-dynamic-bad.alms new file mode 100644 --- /dev/null +++ b/examples/skewness-dynamic-bad.alms @@ -0,0 +1,119 @@ +(* Demonstrates (affine) abstract types. Correct. *) + +(* + This program demonstrats how a dynamic promotion is prevented from + abusing the affinity constraints of an library. + This is like skewness-good.alms, but it has an error in its capability + threading, which manifests as a type error. +*) + +#load "libarraycap" + +open AArray + +module SkewnessExample = struct + let sum ['t,'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + fold (+.) 0.0 a c + + let mean ['t, 'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + let (total, c) = sum a c in + (total /. float_of_int (size a), c) + + let stdDev ['t, 'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + let (mean, c) = mean a c in + let (num, c) = fold + (fun (x: float) (acc: float) -> + acc +. (x -. mean) ** 2.0) + 0.0 a c in + (sqrt (num /. float_of_int (size a)), c) + + let skewness ['t, 'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + let n = float_of_int (size a) in + let (m, c) = mean a c in + let (s, c) = stdDev a c in + let (devs, c) = fold + (fun (x: float) (acc: float) -> + (x -. m) ** 3.0 +. acc) + 0.0 a c in + (devs /. ((n -. 1.0) *. s ** 3.0), c) + + type transformation = T of string * (float -> float) + + let reduceSkewness ['t] + (ts: transformation list) + (a: (float, 't) array) + (c0: 't writecap) = + let get_c0 = (fun () -> c0 :> unit -> 't writecap) in + let rec replace (i: int) + (T(_, ft) as t: transformation) + (c: 't writecap) + : 't writecap = + if i < size a + then let (x, c) = at a i c in + let c = update a i (ft x) c in + replace (i + 1) t c + else c in + let rec find ['c] (ix: int) + (ts: transformation list) + (c: ('t, 'c) readcap) + : float * transformation * ('t, 'c) readcap = + match ts with + | Nil -> let (sk, c) = skewness a c in + (sk, T("identity", fun f: float -> f), c) + | Cons(T(_, ft) as t, ts) + -> let ((sk1, t1), (sk2, t2), c) = + par + (fun 'c (c: ('t, 'c) readcap) -> find['c] (ix + 1) ts c) + (fun 'c (c: ('t, 'c) readcap) -> + let (Pack('s, b, d), c) = map ft a c in + let (sk, d) = skewness b d in + (sk, t, c)) + c + in if absf sk2 <. absf sk1 + then (replace 0 t1 (get_c0 ()); (sk2, t2, c)) + else (sk1, t1, c) in + let (sk, t, c) = find 0 ts (get_c0 ()) in + (sk, t, replace 0 t c) + + let newDistribution + (n: int) (T(_, gen): transformation) + : ex 't. (float, 't) array * 't writecap = + let Pack('t, a, c) = new[float] n in + let rec loop (i: int) (c: 't writecap): 't writecap = + if i < n + then loop (i + 1) (update a i (gen (float_of_int (i + 1))) c) + else c in + Pack[ex 't. (float, 't) array * 't writecap]('t, a, loop 0 c) + + let (^:) 'a (t: 'a) (ts: 'a list) = Cons(t, ts) + + let functions (n: int) = + T("1", fun (ix: float) -> 1.0) ^: + T("x", fun (ix: float) -> ix) ^: + T("x^2", flip ( ** ) 2.0) ^: + T("sqrt x", sqrt) ^: + T("x^5", flip ( ** ) 5.0) ^: + T("x^1/5", flip ( ** ) 0.2) ^: + T("e^x", ( ** ) 2.718) ^: + T("log x", log) ^: + T("1/x", (/.) 1.0) ^: + T("-x", (-.) (float_of_int n)) ^: + Nil + + let testCase (n: int) (T(name, _) as t: transformation) = + let Pack('t, a, c) = newDistribution n t in + let (sk0, c) = skewness a c in + let (sk, T(name', _), c) = reduceSkewness (functions n) a c in + putStrLn ("Distribution: " ^ name); + putStrLn ("Original skewness: " ^ string_of sk0); + putStrLn ("Improved skewness: " ^ string_of sk); + putStrLn ("Winning function: " ^ name'); + putStrLn "" + + let tests (n: int) = + foldl (fun (t: transformation) () -> testCase n t) + () (functions n) +end + +in + SkewnessExample.tests 30 diff --git a/examples/skewness-good.alms b/examples/skewness-good.alms new file mode 100644 --- /dev/null +++ b/examples/skewness-good.alms @@ -0,0 +1,118 @@ +(* Demonstrates (affine) abstract types. Correct. *) + +(* + This program uses a read-write lock array library in, where the + locks are statically checked capabilities. It runs an algorithm + that copies an array a bunch of times, mutates the copies in + parallel, and recombines the results. The locks ensure that we + don't read an array at the same time someone is writing it. +*) + +#load "libarraycap" + +open AArray + +module SkewnessExample = struct + let sum ['t,'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + fold (+.) 0.0 a c + + let mean ['t, 'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + let (total, c) = sum a c in + (total /. float_of_int (size a), c) + + let stdDev ['t, 'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + let (mean, c) = mean a c in + let (num, c) = fold + (fun (x: float) (acc: float) -> + acc +. (x -. mean) ** 2.0) + 0.0 a c in + (sqrt (num /. float_of_int (size a)), c) + + let skewness ['t, 'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + let n = float_of_int (size a) in + let (m, c) = mean a c in + let (s, c) = stdDev a c in + let (devs, c) = fold + (fun (x: float) (acc: float) -> + (x -. m) ** 3.0 +. acc) + 0.0 a c in + (devs /. ((n -. 1.0) *. s ** 3.0), c) + + type transformation = T of string * (float -> float) + + let reduceSkewness ['t] + (ts: transformation list) + (a: (float, 't) array) + (c0: 't writecap) = + let rec replace (i: int) + (T(_, ft) as t: transformation) + (c: 't writecap) + : 't writecap = + if i < size a + then let (x, c) = at a i c in + let c = update a i (ft x) c in + replace (i + 1) t c + else c in + let rec find ['c] (ix: int) + (ts: transformation list) + (c: ('t, 'c) readcap) + : float * transformation * ('t, 'c) readcap = + match ts with + | Nil -> let (sk, c) = skewness a c in + (sk, T("identity", fun f: float -> f), c) + | Cons(T(_, ft) as t, ts) + -> let ((sk1, t1), (sk2, t2), c) = + par + (fun 'c (c: ('t, 'c) readcap) -> find['c] (ix + 1) ts c) + (fun 'c (c: ('t, 'c) readcap) -> + let (Pack('s, b, d), c) = map ft a c in + let (sk, d) = skewness b d in + (sk, t, c)) + c + in if absf sk2 <. absf sk1 + then (sk2, t2, c) + else (sk1, t1, c) in + let (sk, t, c) = find 0 ts c0 in + (sk, t, replace 0 t c) + + let newDistribution (n: int) (T(_, gen): transformation) + : ex 't. (float, 't) array * 't writecap = + let Pack('t, a, c) = new[float] n in + let rec loop (i: int) (c: 't writecap): 't writecap = + if i < n + then loop (i + 1) (update a i (gen (float_of_int (i + 1))) c) + else c in + Pack[ex 't. (float, 't) array * 't writecap]('t, a, loop 0 c) + + let (^:) `a (t: `a) (ts: `a list) = Cons(t, ts) + + let functions (n: int) = + T("1", fun (ix: float) -> 1.0) ^: + T("x", fun (ix: float) -> ix) ^: + T("x^2", flip ( ** ) 2.0) ^: + T("sqrt x", sqrt) ^: + T("x^5", flip ( ** ) 5.0) ^: + T("x^1/5", flip ( ** ) 0.2) ^: + T("e^x", ( ** ) 2.718) ^: + T("log x", log) ^: + T("1/x", (/.) 1.0) ^: + T("-x", (-.) (float_of_int n)) ^: + Nil + + let testCase (n: int) (T(name, _) as t: transformation) = + let Pack('t, a, c) = newDistribution n t in + let (sk0, c) = skewness a c in + let (sk, T(name', _), c) = reduceSkewness (functions n) a c in + putStrLn ("Distribution: " ^ name); + putStrLn ("Original skewness: " ^ string_of sk0); + putStrLn ("Improved skewness: " ^ string_of sk); + putStrLn ("Winning function: " ^ name'); + putStrLn "" + + let tests (n: int) = + foldl (fun (t: transformation) () -> testCase n t) + () (functions n) +end + +in + SkewnessExample.tests 30 diff --git a/examples/skewness-static-bad.alms b/examples/skewness-static-bad.alms new file mode 100644 --- /dev/null +++ b/examples/skewness-static-bad.alms @@ -0,0 +1,114 @@ +(* Demonstrates (affine) abstract types. Correct. *) + +(* + This is like skewness-good.alms, but it has an error in its capability + threading, which manifests as a type error. +*) + +#load "libarraycap" + +open AArray + +module SkewnessExample = struct + let sum ['t,'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + fold (+.) 0.0 a c + + let mean ['t, 'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + let (total, c) = sum a c in + (total /. float_of_int (size a), c) + + let stdDev ['t, 'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + let (mean, c) = mean a c in + let (num, c) = fold + (fun (x: float) (acc: float) -> (x -. mean) ** 2.0) + 0.0 a c in + (sqrt (num /. float_of_int (size a)), c) + + let skewness ['t, 'c] (a: (float, 't) array) (c: ('t, 'c) readcap) = + let n = float_of_int (size a) in + let (m, c) = mean a c in + let (s, c) = stdDev a c in + let (devs, c) = fold + (fun (x: float) (acc: float) -> + (x -. m) ** 3.0 +. acc) + 0.0 a c in + (devs /. ((n -. 1.0) *. s ** 3.0), c) + + type transformation = T of string * (float -> float) + + let reduceSkewness ['t] + (ts: transformation list) + (a: (float, 't) array) + (c0: 't writecap) = + let rec replace (i: int) + (T(_, ft) as t: transformation) + (c: 't writecap) + : 't writecap = + if i < size a + then let (x, c) = at a i c in + let c = update a i (ft x) c in + replace (i + 1) t c + else c in + let rec find ['c] (ix: int) + (ts: transformation list) + (c: ('t, 'c) readcap) + : float * transformation * ('t, 'c) readcap = + match ts with + | Nil -> let (sk, c) = skewness a c in + (sk, T("identity", fun f: float -> f), c) + | Cons(T(_, ft) as t, ts) + -> let ((sk1, t1), (sk2, t2), c) = + par + (fun 'c (c: ('t, 'c) readcap) -> find['c] (ix + 1) ts c) + (fun 'c (c: ('t, 'c) readcap) -> + let (Pack('s, b, d), c) = map ft a c in + let (sk, d) = skewness b d in + (sk, t, c)) + c + in if absf sk2 <. absf sk1 + then (replace 0 t1 c0; (sk2, t2, c)) + else (sk1, t1, c) in + find 0 ts c0 + + let newDistribution + (n: int) (T(_, gen): transformation) + : ex 't. (float, 't) array * 't writecap = + let Pack('t, a, c) = new[float] n in + let rec loop (i: int) (c: 't writecap): 't writecap = + if i < n + then loop (i + 1) (update a i (gen (float_of_int (i + 1))) c) + else c in + Pack[ex 't. (float, 't) array * 't writecap]('t, a ,loop 0 c) + + let (^:) `a (t: `a) (ts: `a list) = Cons(t, ts) + + let functions (n: int) = + T("1", fun (ix: float) -> 1.0) ^: + T("x", fun (ix: float) -> ix) ^: + T("x^2", flip ( ** ) 2.0) ^: + T("sqrt x", sqrt) ^: + T("x^5", flip ( ** ) 5.0) ^: + T("x^1/5", flip ( ** ) 0.2) ^: + T("e^x", ( ** ) 2.718) ^: + T("log x", log) ^: + T("1/x", (/.) 1.0) ^: + T("-x", (-.) (float_of_int n)) ^: + Nil + + let testCase (n: int) (T(name, _) as t: transformation) = + let Pack('t, a, c) = newDistribution n t in + let (sk0, c) = skewness a c in + let (sk, T(name', _), c) = reduceSkewness (functions n) a c in + putStrLn ("Distribution: " ^ name); + putStrLn ("Original skewness: " ^ string_of sk0); + putStrLn ("Improved skewness: " ^ string_of sk); + putStrLn ("Winning function: " ^ name'); + putStrLn "" + + let tests (n: int) = + foldl (fun (t: transformation) () -> testCase n t) + () (functions n) +end + +in + SkewnessExample.tests 30 diff --git a/examples/threads1.alms b/examples/threads1.alms new file mode 100644 --- /dev/null +++ b/examples/threads1.alms @@ -0,0 +1,17 @@ +(* An example with threads. *) + +let printer : unit -> unit = + let rec loop (_ : unit) : unit = + Thread.delay 100000; + putStr "x"; + flush (); + loop () + in loop + +let timer : unit -> unit = + fun _: unit -> + let id = Thread.fork printer in + Thread.delay 2000000; + Thread.kill id + +in timer () diff --git a/examples/threads2.alms b/examples/threads2.alms new file mode 100644 --- /dev/null +++ b/examples/threads2.alms @@ -0,0 +1,25 @@ +(* Another example with threads. *) + +let printer : unit -> unit = + let rec loop (_ : unit) : unit = + Thread.delay 100000; + putStr "x"; + flush (); + loop () + in loop + +let startStop : unit -> unit -o unit = + fun _: unit -> + let id = Thread.fork printer in + let id = Thread.print id in + fun _: unit -> + Thread.kill id + +let timer : unit -> unit = + fun _: unit -> + let stop = startStop () in + Thread.delay 2000000; + stop () + +in timer () + diff --git a/examples/threads3.alms b/examples/threads3.alms new file mode 100644 --- /dev/null +++ b/examples/threads3.alms @@ -0,0 +1,32 @@ +(* A bad example with threads. (type error!) *) + +let printer : unit -> unit = + let rec loop (_ : unit) : unit = + Thread.delay 100000; + putStr "x"; + flush (); + loop () + in loop + +let startStop : unit -> unit -o unit = + fun _: unit -> + let id = Thread.fork printer in + let id = Thread.print id in + fun _: unit -> + Thread.kill id + +let after : int -> (unit -o unit) -> unit = + fun delay: int -> + fun stop: (unit -o unit) -> + Thread.fork (fun _:unit -> Thread.delay delay; stop ()); + () + +let main : unit -> unit = + fun _: unit -> + let stop = startStop () in + after 2000000 stop; + getLine (); + stop () (* stop used twice! *) + +in main () + diff --git a/examples/threads4.alms b/examples/threads4.alms new file mode 100644 --- /dev/null +++ b/examples/threads4.alms @@ -0,0 +1,45 @@ +(* A semi-bad example with threads. (Possible contract error!) + We start a thread printing 'x's, and then two threads, each + of which can kill it: + + 1. counts 4 second + 2. waits for user input + + If 2 happens first (press enter), then the program exits + without error! But if 1 happens first, then 2 will wait + for input, and when it tries to kill the printer thread, + that's a contract violation. +*) + +#load "libthread" + +let printer : unit -> unit = + let rec loop (_ : unit) : unit = + AThread.delay 100000; + putStr "x"; + flush (); + loop () + in loop + +let startStop : unit -> unit -> unit = + fun _: unit -> + let id = AThread.fork printer in + let id = AThread.print id in + (fun () -> AThread.kill id :> unit -> unit) + +let after : int -> (unit -o unit) -> unit = + fun delay: int -> + fun stop: (unit -o unit) -> + AThread.fork (fun () -> AThread.delay delay; stop ()); + () + +let main : unit -> unit = + fun _: unit -> + putStrLn "Press to exit."; + let stop = startStop () in + after 4000000 stop; + getLine (); + stop () + +in main () + diff --git a/lib/libachan.alms b/lib/libachan.alms new file mode 100644 --- /dev/null +++ b/lib/libachan.alms @@ -0,0 +1,76 @@ +(* Asynchronous channels *) +#load "libqueue" + +module AChan : sig + type 'a achan + + val new : all 'a. unit -> 'a achan + val recv : all 'a. 'a achan -> 'a + val send : all 'a. 'a achan -> 'a -> unit + val tryRecv : all 'a. 'a achan -> 'a option + val trySend : all 'a. 'a achan -> 'a -> bool + val size : all 'a. 'a achan -> int +end = struct + module Q = Queue + module M = MVar + type 'a mvar = 'a M.mvar + type 'a queue = 'a Q.queue + type 'a repr = Readers of 'a M.mvar queue + | Writers of 'a queue + + type 'a achan = 'a repr M.mvar + + let new['a] () = M.new (Writers Q.empty['a]) + + let recv['a] (mv : 'a achan) = + let wait (readers : 'a mvar queue) = + let reader = M.newEmpty['a] () in + (Readers (Q.enqueue reader readers), + fun () -> M.take reader) in + M.modify mv (fun repr : 'a repr -> + match repr with + | Readers readers -> wait readers + | Writers writers -> + match Q.dequeueA writers with + | None -> wait Q.empty['a mvar] + | Some (x, xs) -> (Writers xs, fun () -> x)) + () + + let send['a] (mv : 'a achan) (x : 'a) = + M.modify_ mv (fun repr : 'a repr -> + match repr with + | Writers writers -> Writers (Q.enqueue x writers) + | Readers readers -> + match Q.dequeueA readers with + | None -> Writers (Q.enqueue x Q.empty['a]) + | Some (reader, readers') + -> M.put reader x; + Readers readers') + + let tryRecv['a] (mv : 'a achan) = + M.modify mv (fun repr : 'a repr -> + match repr with + | Readers readers -> (repr, None['a]) + | Writers writers -> + match Q.dequeueA writers with + | None -> (repr, None['a]) + | Some (x, xs) -> (Writers xs, Some x)) + + (* Send always succeeds, but trySend succeeds only if there's + a reader ready to receive the send. *) + let trySend['a] (mv : 'a achan) (x : 'a) = + M.modify mv (fun repr : 'a repr -> + match repr with + | Writers writers -> (repr, false) + | Readers readers -> + match Q.dequeueA readers with + | None -> (repr, false) + | Some (reader, readers') + -> M.put reader x; + (Readers readers', true)) + + let size['a] (mv : 'a achan) = + match M.read mv with + | Writers writers -> Q.size writers + | Readers readers -> ~(Q.size readers) +end diff --git a/lib/libarray.alms b/lib/libarray.alms new file mode 100644 --- /dev/null +++ b/lib/libarray.alms @@ -0,0 +1,32 @@ +(* + An array library. +*) + +module Array : sig + exception ArrayIndex + type `a array = `a Prim.Array.array + + val build : all `a. int -> (int -> `a) -> `a array + val swap : all `a. `a array -> int -> `a -> `a + val set : all `a. `a array -> int -> `a -> unit + val size : all `a. `a array -> int + + (* Unlimited-only operations *) + val new : all 'a. int -> 'a -> 'a array + val get : all 'a. 'a array -> int -> 'a +end = struct + open Prim.Array + + exception ArrayIndex + type `a array = `a Prim.Array.array + + let new['a] (size : int) (elt : 'a) = + build size (fun (_: int) -> elt) + + let swap[`a] (a : `a array) (ix : int) (elt : `a) = + try swap a ix elt + with _ -> raise ArrayIndex + + let set[`a] (a : `a array) (ix : int) (elt : `a) = + swap a ix elt; () +end diff --git a/lib/libarraycap.alms b/lib/libarraycap.alms new file mode 100644 --- /dev/null +++ b/lib/libarraycap.alms @@ -0,0 +1,128 @@ +(* + An affine array library. +*) + +#load "libarray" + +module type AARRAY_PRIM = sig + type ('a, 't) array + type `a / `b + type 1 + type 2 + type ('t, 'c) readcap qualifier A + type 't writecap = ('t, 1) readcap + + val new : all 'a. int -> 'a -> ex 't. ('a, 't) array * 't writecap + val build : all 'a. int -> (int -> 'a) -> + ex 't. ('a, 't) array * 't writecap + val split : all 't 'c. ('t, 'c) readcap -> + ('t, 'c/2) readcap * ('t, 'c/2) readcap + val join : all 't 'c. ('t, 'c/2) readcap * ('t, 'c/2) readcap -> + ('t, 'c) readcap + val get : all 'a 't 'c. ('a, 't) array -> int -> ('t, 'c) readcap -> + 'a * ('t, 'c) readcap + val set : all 'a 't. ('a, 't) array -> int -> 'a -> + 't writecap -> 't writecap + val size : all 'a 't. ('a, 't) array -> int +end + +module AArray : sig + include AARRAY_PRIM + + val par : all 't 'c `r1 `r2. + (all 'd. ('t, 'd) readcap -> `r1 * ('t, 'd) readcap) -> + (all 'd. ('t, 'd) readcap -> `r2 * ('t, 'd) readcap) -> + ('t, 'c) readcap -> + `r1 * `r2 * ('t, 'c) readcap + val fold : all 'a 't 'c `r. + ('a -> `r -> `r) -> `r -> ('a, 't) array -[r]> + ('t, 'c) readcap -[r]> + `r * ('t, 'c) readcap + val map : all 'a 't 'c 'b. + ('a -> 'b) -> ('a, 't) array -> ('t, 'c) readcap -> + (ex 's. ('b, 's) array * 's writecap) * ('t, 'c) readcap + val putArray + : all 'a 't 'c. ('a, 't) array -> ('t, 'c) readcap -> + ('t, 'c) readcap +end = struct + module A = Array + + open struct + type ('a, 't) array = 'a A.array + type `a / `b + type 1 + type 2 + type ('t, 'c) readcap = unit + type 't writecap = ('t, 1) readcap + + let new['a] (size: int) (x : 'a) = + Pack[ex 't. ('a, 't) array * unit] + (unit, A.new['a] size x, ()) + + let build['a] (size: int) (builder : int -> 'a) = + Pack[ex 't. ('a, 't) array * unit] + (unit, A.build['a] size builder, ()) + + let split['t,'c] () = ((), ()) + + let join['t,'c] (_: unit * unit) = () + + let get['a,'t,'c] (arr: ('a, 't) array) (ix: int) () = + (A.get arr ix, ()) + + let set['a,'t] (arr: ('a, 't) array) (ix: int) (new: 'a) () = + A.set arr ix new + + let size['a,'t] (arr: ('a, 't) array) = + A.size arr + end : AARRAY_PRIM + + let par ['t,'c,`r1,`r2] + (left: all 'd. ('t, 'd) readcap -> `r1 * ('t, 'd) readcap) + (right: all 'd. ('t, 'd) readcap -> `r2 * ('t, 'd) readcap) + (c: ('t, 'c) readcap) + : `r1 * `r2 * ('t, 'c) readcap = + let (c1, c2) = split c in + let future = Future.new (fun () -> left c1) in + let (r2, c2) = right c2 in + let (r1, c1) = Future.sync future in + (r1, r2, join (c1, c2)) + + let fold ['a,'t,'c,`r] + (f: 'a -> `r -> `r) (z: `r) + (a: ('a, 't) array) (c: ('t, 'c) readcap) = + let rec loop (i: int) (z: `r)| (c: ('t, 'c) readcap) + : `r * ('t, 'c) readcap = + if i < size a + then let (elt, c) = get a i c in + loop (i + 1) (f elt z) c + else (z, c) + in loop 0 z c + + let map ['a,'t,'c,'b] + (f: 'a -> 'b) + (a: ('a, 't) array) (c: ('t, 'c) readcap) + : (ex 's. ('b, 's) array * 's writecap) * ('t, 'c) readcap = + let holder = ref (Some c) in + let builder (ix : int) = match holder <- None with + | None -> failwith "can't happen" + | Some c -> + let (x, c) = get a ix c in + holder <- Some c; + f x in + let res = build (size a) builder in + match holder <- None with + | None -> failwith "can't happen" + | Some c -> (res, c) + + let putArray['a,'t,'c] (a: ('a, 't) array) (c: ('t, 'c) readcap) = + putStr "["; + let (_, c) = + fold (fun (x: 'a) (comma: bool) -> + (if comma then putStr "," else ()); + putStr (string_of x); + true) + false a c in + putStrLn "]"; + c +end diff --git a/lib/libbasis.alms b/lib/libbasis.alms new file mode 100644 --- /dev/null +++ b/lib/libbasis.alms @@ -0,0 +1,154 @@ +module INTERNALS = struct + module Exn = struct + open Prim.Exn + + exception Failure of string + exception IOError of string + exception Blame of string * string + exception PatternMatch of string * string list + + let failwith (msg: string) = + raise (Failure msg) + + let tryfun[`a] (thunk: unit -o `a) : exn + `a = + match tryfun_string thunk with + | Right a -> Right[exn,`a] a + | Left (Left e) -> Left[exn,`a] e + | Left (Right s) -> Left[exn,`a] (IOError s) + + let raiseBlame (who: string) (what: string) = + raise (Blame (who, what)) + end + + local + module INTERNALS = struct + module Exn = Exn + end + with + module Contract = struct + type party = string + type (`a, `b) coercion = party * party -> `a -> `b + type `a contract = party * party -> `a -> `a + + (* Flat contracts for unlimited values. *) + let flat['a] (pred: 'a -> bool) : 'a contract = + fun (neg: party, pos: party) (a: 'a) -> + if pred a + then a + else Exn.raiseBlame pos "violated contract" + + (* Flat contracts for affine values. *) + let flatA[`a] (pred: `a -> bool * `a) : `a contract = + fun (neg: party, pos: party) (a: `a) -> + match pred a with + | (true, a) -> a + | (false, _) -> Exn.raiseBlame pos "violated contract" + + (* The identity contract. *) + let any[`a] : `a contract = + fun (_: party, _: party) (a: `a) -> a + + (* Add domain and codomain contracts to a function. *) + let func[`q] + [`a1, `a2] (dom: (`a1, `a2) coercion) + [`b1, `b2] (cod: (`b1, `b2) coercion) + : (`a2 -[`q]> `b1, `a1 -[`q]> `b2) coercion = + fun (neg: party, pos: party) (f: `a2 -[`q]> `b1) -> + fun (a: `a1) -> cod (neg, pos) (f (dom (pos, neg) a)) + + (* Coerce an affine function to an unlimited function, and + check dynamically that it's applied only once. *) + let affunc[`a1, `a2] (dom: (`a1, `a2) coercion) + [`b1, `b2] (cod: (`b1, `b2) coercion) + : (`a2 -o `b1, `a1 -> `b2) coercion = + fun (neg: party, pos: party) (f: `a2 -o `b1) -> + let rf = ref (Some f) in + fun (a: `a1) -> + match rf <- None[`a2 -o `b1] with + | Some f -> cod (neg, pos) (f (dom (pos, neg) a)) + | None -> Exn.raiseBlame neg "reused one-shot function" + + (* Check that an ostensibly unlimited function is actually + unlimited. *) + let unfunc[`a1, `a2] (dom: (`a1, `a2) coercion) + [`b1, `b2] (cod: (`b1, `b2) coercion) + : (`a2 -> `b1, `a1 -> `b2) coercion = + fun (neg: party, pos: party) (f: `a2 -> `b1) -> + fun (x: `a1) -> + let x' = dom (pos, neg) x in + let y = try f x' with + | Exn.Blame(p, "reused one-shot function") + -> Exn.raiseBlame pos "raised blame" in + cod (neg, pos) y + end + end +end + +let not (b: bool) = if b then false else true +let (!=)['a] (x: 'a) (y: 'a) = not (x == y) + +let flip['a,'b,'c] (f: 'a -> 'b -> 'c) (y: 'b) (x: 'a) = f x y + +let (<) (x: int) (y: int) = not (y <= x) +let (>) = flip (<) +let (>=) = flip (<=) +let (>.) = flip (<.) +let (>=.) = flip (<=.) + +let null = fun 'a (x : 'a list) -> + match x with + | Nil -> true + | _ -> false +let anull = fun `a (xs : `a list) -> + match xs with + | Nil -> (Nil[`a], true) + | Cons(x, xs') -> (Cons(x, xs'), false) +let hd = fun 'a (xs : 'a list) -> + let Cons(x, _) = xs in x +let tl = fun 'a (xs : 'a list) -> + let Cons(_, xs') = xs in xs' +let foldr = + let rec foldr `a `b (f : `a -> `b -o `b) + (z : `b) |[b](xs : `a list) : `b = + match xs with + | Nil -> z + | Cons(x,xs) -> f x (foldr f z xs) + in foldr +let foldl = + let rec foldl `a `b (f : `a -> `b -o `b) + (z : `b) |[b](xs : `a list) : `b = + match xs with + | Nil -> z + | Cons(x,xs) -> foldl f (f x z) xs + in foldl +let map `a `b (f: `a -> `b) (xs: `a list) = + foldr (fun (x: `a) (xs': `b list) -> Cons (f x, xs')) Nil xs +let filter 'a (f: 'a -> bool) (xs: 'a list) = + foldr (fun (x: 'a) (xs': 'a list) -> + if f x then Cons(x, xs') else xs') + Nil +let mapFilterA `a `b (f: `a -> `b option) (xs: `a list) = + foldr (fun (x: `a) (xs': `b list) -> + match f x with + | Some y -> Cons(y, xs') + | None -> xs') + Nil +let revApp[`c] (xs : `c list) (ys : `c list) = + let cons (x : `c) (acc : `c list) = Cons (x, acc) in + foldl cons ys xs +let rev[`b] (xs : `b list) = revApp xs Nil +let append[`a] (xs : `a list) = revApp (rev xs) +let length[`a] (xs : `a list) = + foldr (fun (x : `a) -> (+) 1) 0 xs +let lengthA[`a] (xs : `a list) = + let count (x : `a) (n : int, xs' : `a list) = + (1 + n, Cons (x, xs')) in + foldr count (0, Nil[`a]) xs + +let fst[`a,`b] (x: `a, _: `b) = x +let snd[`a,`b] (_: `a, y: `b) = y + +let (=>!) [`a] (x: `a) [`b] (y: `b) = (y, x) + +open INTERNALS +open Exn diff --git a/lib/libqueue.alms b/lib/libqueue.alms new file mode 100644 --- /dev/null +++ b/lib/libqueue.alms @@ -0,0 +1,58 @@ +module type QUEUE = sig + type +`a queue qualifier `a + exception Empty + + val emptyA : all `a. unit -> `a queue + val isEmptyA : all `a. `a queue -> bool * `a queue + val sizeA : all `a. `a queue -> int * `a queue + val dequeueA : all `a. `a queue -> (`a * `a queue) option + + val enqueue : all `a. `a -> `a queue -[a]> `a queue + + val empty : all 'a. 'a queue + val isEmpty : all 'a. 'a queue -> bool + val size : all 'a. 'a queue -> int + val first : all 'a. 'a queue -> 'a + val dequeue : all 'a. 'a queue -> 'a queue +end + +module Queue : QUEUE = struct + type `a queue = `a list * `a list + + exception Empty + + let emptyA[`a] () = (Nil[`a], Nil[`a]) + let isEmptyA[`a] (q : `a queue) = + match q with + | (Nil, Nil) -> (true, (Nil[`a], Nil[`a])) + | q -> (false, q) + let sizeA[`a] ((front, back) : `a queue) = + let (lenf, front) = lengthA front in + let (lenb, back) = lengthA back in + (lenf + lenb, (front, back)) + let dequeueA[`a] ((front, back) : `a queue) = + match front with + | Cons (x, xs) -> Some (x, (xs, back)) + | Nil -> + match rev back with + | Cons (x, xs) -> Some (x, (xs, Nil[`a])) + | Nil -> None[`a * `a queue] + + let empty['a] = (Nil['a], Nil['a]) + let isEmpty[`a] (q : `a queue) = + match q with + | (Nil, Nil) -> true + | _ -> false + let enqueue[`a] (x : `a) ((front, back) : `a queue) = + (front, Cons (x, back)) + let first[`a] (q : `a queue) = + match dequeueA q with + | Some (x, _) -> x + | None -> raise Empty + let dequeue[`a] (q : `a queue) = + match dequeueA q with + | Some (_, q') -> q' + | None -> raise Empty + let size[`a] ((front, back) : `a queue) = + length front + length back +end diff --git a/lib/libsessiontype.alms b/lib/libsessiontype.alms new file mode 100644 --- /dev/null +++ b/lib/libsessiontype.alms @@ -0,0 +1,85 @@ +(* + A session types library +*) + +module type SESSION_TYPE = sig + type 1 + type +'a ; +'s + type ! -`a + type ? +`a + type +'a |+| +'b + type +'a |&| +'b + + type 1 dual = 1 + | (!`a ; 's) dual = ?`a ; 's dual + | (?`a ; 's) dual = !`a ; 's dual + | ('a |+| 'b) dual = 'a dual |&| 'b dual + | ('a |&| 'b) dual = 'a dual |+| 'b dual + + type 's rendezvous + type +'s channel qualifier A + + val newRendezvous : all 's. unit -> 's rendezvous + + val request : all 's. 's rendezvous -> 's channel + val accept : all 's. 's rendezvous -> 's dual channel + + val send : all `a 's. (!`a; 's) channel -> `a -o 's channel + val recv : all `a 's. (?`a; 's) channel -> `a * 's channel + val sel1 : all 's 'r. ('s |+| 'r) channel -> 's channel + val sel2 : all 's 'r. ('s |+| 'r) channel -> 'r channel + val follow : all 's 'r. ('s |&| 'r) channel -> 's channel + 'r channel +end + +module SessionType : SESSION_TYPE = struct + module C = Channel + + type 1 + type +'a ; +'s + type ! -`a + type ? +`a + type +'a |+| +'b + type +'a |&| +'b + + type 1 dual = 1 + | (!`a ; 's) dual = ?`a ; 's dual + | (?`a ; 's) dual = !`a ; 's dual + | ('a |+| 'b) dual = 'a dual |&| 'b dual + | ('a |&| 'b) dual = 'a dual |+| 'b dual + + type rep = bool C.channel + type 's channel = rep + type 's rendezvous = rep C.channel + + let newRendezvous['s] () = + (C.new['s channel] ()) + + let request['s] (r: 's rendezvous) = + C.recv r + + let accept['s] (r: 's rendezvous) = + let c = C.new[bool] () in + C.send r c; + c + + let send[`a, 's] (c: rep)| (a: `a) = + C.send c (Unsafe.unsafeCoerce[bool] a); + c + + let recv[`a, 's] (c: rep) = + (Unsafe.unsafeCoerce[`a] (C.recv c), c) + + let sel1['s1, 's2] (c: ('s1 |+| 's2) channel) + : 's1 channel = + C.send c true; + c + + let sel2['s1, 's2] (c: rep) = + C.send c false; + c + + let follow['s1, 's2] (c: rep) = + if C.recv c + then Left [rep, rep] c + else Right[rep, rep] c +end diff --git a/lib/libsessiontype2.alms b/lib/libsessiontype2.alms new file mode 100644 --- /dev/null +++ b/lib/libsessiontype2.alms @@ -0,0 +1,118 @@ +(* + Another session types library. Doesn't use equirecursive types. +*) + +module type SESSION_TYPE = sig + type 1 + type +'a ; +'s + type ! -`a + type ? +`a + + type 1 dual = 1 + | (!`a ; 's) dual = ?`a ; 's dual + | (?`a ; 's) dual = !`a ; 's dual + + type ?-> `c = ?`c; 1 + type !-> `c = !`c; 1 + + type 's rendezvous + type +'s channel qualifier A + + val newRendezvous : all 's. unit -> 's rendezvous + + val request : all 's. 's rendezvous -> 's channel + val accept : all 's. 's rendezvous -> 's dual channel + + val send : all `a. `a -> all 's. (!`a; 's) channel -[a]> + unit * 's channel + val recv : all `a 's. (?`a; 's) channel -> `a * 's channel + + val follow : all `c. ?-> `c channel -> unit * `c + val choose : all 's `c. ('s channel -> `c) -> !-> `c channel -> + unit * 's dual channel +end + +module SessionType : SESSION_TYPE = struct + module C = Channel + + type 1 + type +'a ; +'s + type ! -`a + type ? +`a + + type 1 dual = 1 + | (!`a ; 's) dual = ?`a ; 's dual + | (?`a ; 's) dual = !`a ; 's dual + + type ?-> `c = ?`c; 1 + type !-> `c = !`c; 1 + + type rep = any C.channel + type 's channel = rep + type 's rendezvous = rep C.channel + + let newRendezvous () = C.new[rep] () + + let request (r: unit rendezvous) = C.recv r + + let accept (r: unit rendezvous) = + let c = C.new () in + C.send r c; + c + + let newPair () = + let c = C.new () in + (c, c) + + let send[`a] (a: `a) (c: rep) = + C.send c (Unsafe.unsafeCoerce a); + ((), c) + + let recv[`a] (c: rep) = (C.recv c, c) + + let follow (c: rep) = + let (c', _) = recv c in ((), c') + + let choose[`c] (ctor: rep -> `c) (c: rep) = + let (theirs, mine) = newPair () in + send (ctor theirs) c; + ((), mine) +end + +module SessionType2Test = struct + open SessionType + + type state1 = !int; ?->state2 + and state2 = Done of (?int; 1) channel + | More of (!int; ?->state2) channel + | Again of (?int; state1) channel + + let client (c: state1 channel) = + let rec s1 !(c: state1 channel) : int * 1 channel = + send 1 c; + follow c; + s2 c + and s2 !(c: state2) : int * 1 channel = + match c with + | Done c -> recv c + | More c -> send 2 c; + follow c; + s2 c + | Again c -> let z = recv c in + s1 c + in fst (s1 c) + + let server (c: state1 dual channel) = + let rec s1 !(c : state1 dual channel) : unit * 1 channel = + match recv c with + | 0 -> choose More c; + let z' = recv c in + choose Done c; + send z' c + | 1 -> choose Again c; + send 1 c; + s1 c + | z -> choose Done c; + send z c + in fst (s1 c) +end diff --git a/lib/libsocket.alms b/lib/libsocket.alms new file mode 100644 --- /dev/null +++ b/lib/libsocket.alms @@ -0,0 +1,42 @@ +(* + A simple sockets library. +*) + +module Socket = struct + local + module S = Prim.Socket + with + let getAddrByName (host: string) (port: string) : S.sockAddr = + let info = S.AddrInfo(Nil[S.addrInfoFlag], S.AF_INET, + S.Stream, S.defaultProtocol, + S.SockAddrInet(S.PortNum 0, 0), None[string]) in + match S.getAddrInfo (Some info) (Some host) (Some port) with + | Cons (S.AddrInfo (_, _, _, _, sockAddr, _), _) -> sockAddr + | _ -> failwith ("Could not resolve address "^host^":"^port) + + type socket = S.socket + + let socket (): socket = + S.socket S.AF_INET S.Stream S.defaultProtocol + + let bind (sock: socket) (port: int) : unit = + S.bind sock (S.SockAddrInet (S.PortNum port, S.inaddr_any)) + + let connect (sock: socket) (host: string) (port: string) : unit = + S.connect sock (getAddrByName host port) + + let listen (sock: socket) : unit = S.listen sock 5 + + let accept (sock: socket) : socket = + let (new, _) = S.accept sock in new + + let send (sock: socket) (data: string) : int = + S.send sock data + + let recv (sock: socket) (len: int) : string = + S.recv sock len + + let close (sock: socket) : unit = + S.close sock + end +end diff --git a/lib/libsocketcap.alms b/lib/libsocketcap.alms new file mode 100644 --- /dev/null +++ b/lib/libsocketcap.alms @@ -0,0 +1,189 @@ +(* + A typestate sockets library + + This is a bit more involved than the example in the paper, + because we have error cases. We deal with this by raising + an exception which contains a witness that allows recovering + the capability if presented with the corresponding socket. +*) + +#load "libsocket" + +module type ASOCKET = sig + (* The representation of a socket *) + type 't socket + + (* The socket states *) + type 't initial qualifier A + type 't bound qualifier A + type 't listening qualifier A + type 't connected qualifier A + + (* Socket operations *) + val socket : unit -> ex 't. 't socket * 't initial + val bind : all 't. 't socket -> int -> 't initial -> 't bound + val connect : all 't. 't socket -> string -> string -> + 't initial + 't bound -> 't connected + val listen : all 't. 't socket -> 't bound -> 't listening + val accept : all 't. 't socket -> 't listening -> + (ex 's. 's socket * 's connected) * 't listening + val send : all 't. 't socket -> string -> + 't connected -> 't connected + val recv : all 't. 't socket -> int -> + 't connected -> string * 't connected + val close : all 't.'t socket -> 't connected -> unit + + (* When we raise an exception, we "freeze" the capability. + * We can thaw the frozen capability if we have the socket that + * it goes with. (This requires a dynamic check.) This lets us + * recover the capability with a type paramater that matches any + * extant sockets that go with it. *) + type frozenInitial qualifier A + type frozenBound qualifier A + type frozenListening qualifier A + type frozenConnected qualifier A + + (* Operations for reassociating frozen capabilities with their + sockets. *) + val thawInitial : all 't. 't socket -> frozenInitial -> + frozenInitial + 't initial + val thawBound : all 't. 't socket -> frozenBound -> + frozenBound + 't bound + val thawListening : all 't. 't socket -> frozenListening -> + frozenListening + 't listening + val thawConnected : all 't. 't socket -> frozenConnected -> + frozenConnected + 't connected + + (* Operations for catching the error state associated with a given + socket. *) + val catchInitial : all 't `a. 't socket -> + (unit -o `a) -> ('t initial -o `a) -o `a + val catchBound : all 't `a. 't socket -> + (unit -o `a) -> ('t bound -o `a) -o `a + val catchListening : all 't `a. 't socket -> + (unit -o `a) -> ('t listening -o `a) -o `a + val catchConnected : all 't `a. 't socket -> + (unit -o `a) -> ('t connected -o `a) -o `a + + (* Socket exceptions *) + exception SocketError of string + exception StillInitial of frozenInitial * string + exception StillBound of frozenBound * string + exception StillListening of frozenListening * string + exception StillConnected of frozenConnected * string +end + +module ASocket : ASOCKET = struct + module S = Socket + let getAddrByName = S.getAddrByName + + type rep = S.socket + type 't socket = S.socket + + exception SocketError of string + exception StillInitial of rep * string + exception StillBound of rep * string + exception StillListening of rep * string + exception StillConnected of rep * string + + let socket () = + try (S.socket (), ()) + with + IOError s -> raise (SocketError s) + + let bind['t] (sock: rep) (port: int) () = + try S.bind sock port + with + IOError msg -> raise (StillInitial (sock, msg)) + + let connect['t] (sock: rep) (host: string) (port: string) + (cap: unit + unit) = + try S.connect sock host port + with + IOError msg -> match cap with + | Left _ -> raise (StillInitial (sock, msg)) + | Right _ -> raise (StillBound (sock, msg)) + + let listen['t] (sock: rep) () = + try S.listen sock + with + IOError msg -> raise (StillBound (sock, msg)) + + let accept['t] (sock: rep) () = + try (S.accept sock, (), ()) + with + IOError msg -> raise (StillListening (sock, msg)) + + let send['t] (sock: rep) (data: string) () = + try + S.send sock data; + () + with + IOError msg -> raise (SocketError msg) + + let recv['t] (sock: rep) (len: int) () = + try (S.recv sock len, ()) + with + IOError msg -> raise (SocketError msg) + + let close['t] (sock: rep) () = + try S.close sock + with + IOError msg -> raise (SocketError msg) + + (* Convenience functions for catching and thawing frozen socket + * capabilities. *) + let thaw ['t] (sock: rep) (sock': rep) = + if sock == sock' + then Right () + else Left sock' + + let thawInitial = thaw + let thawBound = thaw + let thawListening = thaw + let thawConnected = thaw + + let catchInitial['t,`a] (sock: rep) (body: unit -o `a) + (handler: unit -o `a) = + try body () with + | StillInitial (frz, msg) -> + match thawInitial sock frz with + | Left frz -> raise (StillInitial (frz, msg)) + | Right cap -> handler cap + + let catchBound['t,`a] (sock: rep) (body: unit -o `a) + (handler: unit -o `a) = + try body () with + | StillBound (frz, msg) -> + match thawBound sock frz with + | Left frz -> raise (StillBound (frz, msg)) + | Right cap -> handler cap + + let catchListening['t,`a] (sock: rep) (body: unit -o `a) + (handler: unit -o `a) = + try body () with + | StillListening (frz, msg) -> + match thawListening sock frz with + | Left frz -> raise (StillListening (frz, msg)) + | Right cap -> handler cap + + let catchConnected['t,`a] (sock: rep) (body: unit -o `a) + (handler: unit -o `a) = + try body () with + | StillConnected (frz, msg) -> + match thawConnected sock frz with + | Left frz -> raise (StillConnected (frz, msg)) + | Right cap -> handler cap + + (* Types for the interface *) + type 't initial = unit + type 't bound = unit + type 't listening = unit + type 't connected = unit + + type frozenInitial = rep + type frozenBound = rep + type frozenListening = rep + type frozenConnected = rep +end + diff --git a/lib/libsocketcap2.alms b/lib/libsocketcap2.alms new file mode 100644 --- /dev/null +++ b/lib/libsocketcap2.alms @@ -0,0 +1,175 @@ +(* + A typestate sockets library + + This is a bit more involved than the example in the paper, + because we have error cases. We deal with this by raising + an exception which contains a witness that allows recovering + the capability if presented with the corresponding socket. +*) + +#load "libsocket" + +module type ASOCKET = sig + (* The representation of a socket *) + type 't socket + + (* Socket capabilities and the socket states *) + type 't @@ 's qualifier A + type initial + type bound + type listening + type connected + + (* Socket operations *) + val socket : unit -> ex 't. 't socket * 't@@initial + val bind : all 't. 't socket -> int -> 't@@initial -> 't@@bound + val connect : all 't. 't socket -> string -> string -> + 't@@initial + 't@@bound -> 't@@connected + val listen : all 't. 't socket -> 't@@bound -> 't@@listening + val accept : all 't. 't socket -> 't@@listening -> + (ex 's. 's socket * 's@@connected) * 't@@listening + val send : all 't. 't socket -> string -> + 't@@connected -> 't@@connected + val recv : all 't. 't socket -> int -> + 't@@connected -> string * 't@@connected + val close : all 't. 't socket -> 't@@connected -> unit + + (* When we raise an exception, we "freeze" the capability. + * We can thaw the frozen capability if we have the socket that + * it goes with. (This requires a dynamic check.) This lets us + * recover the capability with a type paramater that matches any + * extant sockets that go with it. *) + type 'a frozen qualifier A + + val thaw : all 't. 't socket -> all 's. 's frozen -> 's frozen + 't@@'s + + (* Operations for catching the error state associated with a given + socket. *) + val catchInitial : all 't `a. 't socket -> + (unit -o `a) -> ('t@@initial -o `a) -o `a + val catchBound : all 't `a. 't socket -> + (unit -o `a) -> ('t@@bound -o `a) -o `a + val catchListening : all 't `a. 't socket -> + (unit -o `a) -> ('t@@listening -o `a) -o `a + val catchConnected : all 't `a. 't socket -> + (unit -o `a) -> ('t@@connected -o `a) -o `a + + (* Socket exceptions *) + type socketError = StillInitial of initial frozen + | StillBound of bound frozen + | StillListening of listening frozen + | StillConnected of connected frozen + | Disconnected + exception SocketError of socketError * string +end + +module ASocket : ASOCKET = struct + module S = Socket + let getAddrByName = S.getAddrByName + + type rep = S.socket + type 't socket = S.socket + + type socketError = StillInitial of rep + | StillBound of rep + | StillListening of rep + | StillConnected of rep + | Disconnected + exception SocketError of socketError * string + + let error (se: socketError) (msg: string) = + raise (SocketError (se, msg)) + + let socket () = + try (S.socket (), ()) + with + IOError msg -> error Disconnected msg + + let bind (sock: rep) (port: int) () = + try S.bind sock port + with + IOError msg -> error (StillInitial sock) msg + + let connect (sock: rep) (host: string) (port: string) + (cap: unit + unit) = + try S.connect sock host port + with + IOError msg -> match cap with + | Left _ -> error (StillInitial sock) msg + | Right _ -> error (StillBound sock) msg + + let listen (sock: rep) () = + try S.listen sock + with + IOError msg -> error (StillBound sock) msg + + let accept (sock: rep) () = + try (S.accept sock, (), ()) + with + IOError msg -> error (StillListening sock) msg + + let send (sock: rep) (data: string) () = + try + S.send sock data; + () + with + IOError msg -> error Disconnected msg + + let recv (sock: rep) (len: int) () = + try (S.recv sock len, ()) + with + IOError msg -> error Disconnected msg + + let close (sock: rep) () = + try S.close sock + with + IOError msg -> error Disconnected msg + + (* Convenience functions for catching and thawing frozen socket + * capabilities. *) + let thaw (sock: rep) (sock': rep) = + if sock == sock' + then Right () + else Left sock' + + let catchInitial[`a] (sock: rep) (body: unit -o `a) + (handler: unit -o `a) = + try body () with + | SocketError (StillInitial frz, msg) -> + match thaw sock frz with + | Left frz -> error (StillInitial frz) msg + | Right cap -> handler cap + + let catchBound[`a] (sock: rep) (body: unit -o `a) + (handler: unit -o `a) = + try body () with + | SocketError (StillBound frz, msg) -> + match thaw sock frz with + | Left frz -> error (StillBound frz) msg + | Right cap -> handler cap + + let catchListening[`a] (sock: rep) (body: unit -o `a) + (handler: unit -o `a) = + try body () with + | SocketError (StillListening frz, msg) -> + match thaw sock frz with + | Left frz -> error (StillListening frz) msg + | Right cap -> handler cap + + let catchConnected[`a] (sock: rep) (body: unit -o `a) + (handler: unit -o `a) = + try body () with + | SocketError (StillConnected frz, msg) -> + match thaw sock frz with + | Left frz -> error (StillConnected frz) msg + | Right cap -> handler cap + + (* Types for the interface *) + type 't @@ 's = unit + type initial + type bound + type listening + type connected + type 's frozen = rep +end + diff --git a/lib/libthread.alms b/lib/libthread.alms new file mode 100644 --- /dev/null +++ b/lib/libthread.alms @@ -0,0 +1,14 @@ +(* "Single-threaded" threads *) + +module AThread : sig + type thread qualifier A + + val fork : (unit -o unit) -> thread + val kill : thread -> unit + val delay : int -> unit + val print : thread -> thread +end = struct + open Thread + let fork = (fork :> (unit -o unit) -> thread) + let print (th: thread) = print th; th +end diff --git a/src/Basis.hs b/src/Basis.hs new file mode 100644 --- /dev/null +++ b/src/Basis.hs @@ -0,0 +1,209 @@ +-- | Built-in operations and types +{-# LANGUAGE + DeriveDataTypeable, + QuasiQuotes, + TemplateHaskell #-} +module Basis ( + primBasis, srcBasis, basis2venv, basis2tenv +) where + +import Util +import BasisUtils +import Value (Valuable(..), Value(..)) +import Syntax +import Type + +import qualified Loc +import qualified Syntax.Notable +import qualified Syntax.Decl + +import qualified Basis.IO +import qualified Basis.Socket +import qualified Basis.Exn +import qualified Basis.Thread +import qualified Basis.Channel +import qualified Basis.MVar +import qualified Basis.Future +import qualified Basis.Array + +import qualified IO +import qualified System.Environment as Env +import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef) +import System.Random (randomIO) +import Data.Typeable + +-- Primitive operations implemented in Haskell +primBasis :: [Entry Raw] +primBasis = [ + --- + --- Ordinary constants: + --- + + --- name -: type -= value + + -- Primitive types: + "unit" `primtype` tcUnit, + "any" `primtype` tcBot, + "exn" `primtype` tcExn, + dec [$dc| type bool = false | true |], + "int" `primtype` tcInt, + dec [$dc| type char = int |], + "float" `primtype` tcFloat, + "string" `primtype` tcString, + "U" `primtype` tcUn, + "A" `primtype` tcAf, + "*" `primtype` tcTuple, + + -- Sums + dec [$dc| type `a option = None | Some of `a |], + dec [$dc| type `a + `b = Left of `a | Right of `b |], + + -- Lists + dec [$dc| type `a list = Nil | Cons of `a * `a list |], + + -- Arithmetic + binArith "+" (+), + binArith "-" (-), + binArith "*" (*), + binArith "/" div, + binArith "%" mod, + fun "~" -: [$ty| int -> int |] + -= (negate :: Integer -> Integer), + fun "abs" -: [$ty| int -> int |] + -= (abs :: Integer -> Integer) , + fun "<=" -: [$ty| int -> int -> bool |] + -= ((<=) :: Integer -> Integer -> Bool), + fun "string_of_int" -: [$ty| int -> string |] + -= (show :: Integer -> String), + fun "int_of_string" -: [$ty| string -> int |] + -= (read :: String -> Integer), + fun "random_int" -: [$ty| unit -> int |] + -= \() -> (randomIO :: IO Int), + + -- Floating point arithmetic + fun "<=." -: [$ty| float -> float -> bool |] + -= ((<=) :: Double -> Double -> Bool), + fun "<." -: [$ty| float -> float -> bool |] + -= ((<) :: Double -> Double -> Bool), + fun "+." -: [$ty| float -> float -> float |] + -= ((+) :: Double -> Double -> Double), + fun "-." -: [$ty| float -> float -> float |] + -= ((-) :: Double -> Double -> Double), + fun "*." -: [$ty| float -> float -> float |] + -= ((*) :: Double -> Double -> Double), + fun "/." -: [$ty| float -> float -> float |] + -= ((/) :: Double -> Double -> Double), + fun "**" -: [$ty| float -> float -> float |] + -= ((**) :: Double -> Double -> Double), + fun "~." -: [$ty| float -> float |] + -= (negate :: Double -> Double), + fun "sqrt" -: [$ty| float -> float |] + -= (sqrt :: Double -> Double), + fun "log" -: [$ty| float -> float |] + -= (log :: Double -> Double), + fun "absf" -: [$ty| float -> float |] + -= (abs :: Double -> Double), + fun "float_of_int" -: [$ty| int -> float |] + -= (fromIntegral :: Integer -> Double), + fun "int_of_float" -: [$ty| float -> int |] + -= (round :: Double -> Integer), + fun "string_of_float" -: [$ty| float -> string |] + -= (show :: Double -> String), + fun "float_of_string" -: [$ty| string -> float |] + -= (read :: String -> Double), + + -- Strings + fun "explode" -: [$ty| string -> int list |] + -= map char2integer, + fun "implode" -: [$ty| int list -> string |] + -= map integer2char, + fun "^" -: [$ty| string -> string -> string |] + -= ((++) :: String -> String -> String), + fun "string_of" -: [$ty| all 'a. 'a -> string |] + -= (return . show :: Value -> IO String), + fun "string_length" -: [$ty| string -> int |] + -= \s -> toInteger (length (s :: String)), + + -- "Magic" equality and print; failure + fun "==" -: [$ty| all 'a. 'a -> 'a -> bool |] + -= ((==) :: Value -> Value -> Bool), + fun "print" -: [$ty| all 'a. 'a -> unit |] + -= (print :: Value -> IO ()), + + -- I/O + fun "putChar" -: [$ty| int -> unit |] + -= putChar . integer2char, + fun "getChar" -: [$ty| unit -> int |] + -= \() -> fmap char2integer getChar, + fun "flush" -: [$ty| unit -> unit |] + -= \() -> IO.hFlush IO.stdout, + fun "putStr" -: [$ty| string -> unit |] + -= putStr, + fun "putStrLn" -: [$ty| string -> unit |] + -= putStrLn, + fun "getLine" -: [$ty| unit -> string |] + -= \() -> getLine, + + -- The environment + fun "getArgs" -: [$ty| unit -> string list |] + -= \() -> Env.getArgs, + fun "getProgName" -: [$ty| unit -> string |] + -= \() -> Env.getProgName, + fun "getEnv" -: [$ty| string -> string |] + -= Env.getEnv, + fun "getEnvironment" -: [$ty| unit -> (string * string) list |] + -= \() -> Env.getEnvironment, + + -- References + dec [$dc| type `a ref qualifier U |], + dec [$dc| type `a aref qualifier A |], + fun "ref" -: [$ty| all `a. `a -> `a ref |] + -= (\v -> Ref `fmap` newIORef v), + fun "aref" -: [$ty| all `a. `a -> `a aref |] + -= (\v -> Ref `fmap` newIORef v), + + fun "!" -: [$ty| all 'a. 'a ref -> 'a |] + -= (\r -> readIORef (unRef r)), + fun "!!" -: [$ty| all 'a. 'a aref -> 'a aref * 'a |] + -= (\r -> do + v <- readIORef (unRef r) + return (r, v)), + fun "<-" -: [$ty| all `a. `a ref -> `a -o `a |] + -= (\r v -> do + atomicModifyIORef (unRef r) (\v' -> (v, v'))), + fun "<-!" -: [$ty| all `a `b. `a aref -> + `b -o `b aref * `a |] + -= (\r v -> do + atomicModifyIORef (unRef r) (\v' -> (v, (r, v')))), + + submod "Unsafe" [ + -- Unsafe coercions + fun "unsafeCoerce" -: [$ty| all `b `a. `a -> `b |] + -= (id :: Value -> Value), + fun "unsafeDup" -: [$ty| all `a. `a -> `a * `a |] + -= ((\v -> (v, v)) :: Value -> (Value, Value)) + ], + + submod "IO" Basis.IO.entries, + submod "Channel" Basis.Channel.entries, + submod "Thread" Basis.Thread.entries, + submod "MVar" Basis.MVar.entries, + submod "Future" Basis.Future.entries, + + submod "Prim" [ + submod "Socket" Basis.Socket.entries, + submod "Exn" Basis.Exn.entries, + submod "Array" Basis.Array.entries + ] + ] + +newtype Ref = Ref { unRef :: IORef Value } + deriving (Eq, Typeable) + +instance Valuable Ref where + veq = (==) + vpprPrec _ _ = text "#" + +-- | Built-in operations implemented in the object language +srcBasis :: String +srcBasis = "libbasis.alms" diff --git a/src/Basis/Array.hs b/src/Basis/Array.hs new file mode 100644 --- /dev/null +++ b/src/Basis/Array.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE + DeriveDataTypeable, + QuasiQuotes #-} +module Basis.Array (entries) where + +import Data.Typeable (Typeable) +import BasisUtils +import Syntax +import Util +import Value (Value, Valuable(..)) + +import qualified Loc +import qualified Syntax.Notable +import qualified Syntax.Decl + +import qualified Data.Array.IO as A + +newtype Array = Array { unArray :: A.IOArray Int Value } + deriving (Eq, Typeable) + +instance Valuable Array where + veq = (==) + vpprPrec _ _ = text "#" + +io :: IO a -> IO a +io = id + +entries :: [Entry Raw] +entries = [ + dec [$dc| type `a array |], + fun "build" -: [$ty| all `a. int -> (int -> `a) -> `a array |] + -= \size builder -> io $ do + a <- A.newArray_ (0, size - 1) + forM_ [ 0 .. size - 1 ] $ \i -> + vapp builder i >>= A.writeArray a i + return (Array a), + fun "size" -: [$ty| all `a. `a array -> int |] + -= \a -> io $ do + (_, limit) <- A.getBounds (unArray a) + return (limit + 1), + fun "swap" -: [$ty| all `a. `a array -> int -> `a -> `a |] + -= \(Array a) ix new -> io $ do + old <- A.readArray a ix + A.writeArray a ix new + return old, + fun "get" -: [$ty| all 'a. 'a array -> int -> 'a |] + -= \(Array a) ix -> io $ A.readArray a ix + ] + diff --git a/src/Basis/Channel.hs b/src/Basis/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Basis/Channel.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE + DeriveDataTypeable, + QuasiQuotes #-} +module Basis.Channel (Channel, entries) where + +import Data.Typeable (Typeable) +import BasisUtils +import Syntax +import Value (Value, Valuable(..)) + +import qualified Loc +import qualified Syntax.Notable +import qualified Syntax.Decl + +import qualified Basis.Channel.Haskell as C + +newtype Channel = Channel { unChannel :: C.Chan Value } + deriving (Eq, Typeable) + +instance Valuable Channel where + veq = (==) + vpprPrec _ _ = text "#" + +entries :: [Entry Raw] +entries = [ + dec [$dc| type 'a channel |], + fun "new" -: [$ty| all 'a. unit -> 'a channel |] + -= \() -> Channel `fmap` C.newChan, + fun "send" -: [$ty| all 'a. 'a channel -> 'a -> unit |] + -= \c a -> do + C.writeChan (unChannel c) a + return (), + fun "recv" -: [$ty| all 'a. 'a channel -> 'a |] + -= \c -> C.readChan (unChannel c) + ] diff --git a/src/Basis/Channel/Haskell.hs b/src/Basis/Channel/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Basis/Channel/Haskell.hs @@ -0,0 +1,672 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Basis.Channel.Haskell +-- Copyright : (c) 2009 Jesse A. Tov +-- License : BSD (see the file LICENSE) +-- +-- Maintainer : tov@ccs.neu.edu +-- Stability : experimental +-- Portability : somewhat portable? +-- +-- This module provides synchronous channels. Unlike the channels in +-- 'Control.Concurrent.Chan', which are unbounded queues on which +-- writers never block, these channels allow each writer to block until +-- it synchronizes with the particular reader that receives its message. +-- +-- We actually provide three classes of channel operations: +-- +-- [Synchronous, blocking] These operations block until they +-- synchronize their communication with another thread. +-- +-- [Synchronous, non-blocking] These operations complete immediately +-- if another thread is ready to synchronize, and otherwise return +-- a failure code immediate. +-- +-- [Asynchronous] These operations complete immediately and always +-- succeed, though the value they send may not be received until +-- another thread tries to receive it. +-- +----------------------------------------------------------------------------- +module Basis.Channel.Haskell ( + -- * The channel datatype + Chan, -- abstract: * -> * + -- ** Construction and observation + newChan, -- IO (Chan a) + isEmptyChan, -- Chan a -> IO Bool + + -- * Synchronous, blocking operations + -- | The synchronous, blocking channel operations are designed + -- to complete only when a writing thread synchronizes with a + -- reading thread. + -- + -- They are exception safe, in the sense that if + -- an asynchronous exception is delivered to a blocked thread, + -- that thread is removed from the pool and cannot synchronize + -- with another. In particular, we can write code like this: + -- + -- @ + -- 'Control.Exception.block' $ do + -- msg <- 'readChan' c + -- 'writeIORef' r msg + -- @ + -- + -- In this case, the call to 'readChan' may be interrupted, but + -- if the message is delivered, the 'writeIORef' will happen. There + -- is no case where the writing thread synchronizes and unblocks + -- and the message is dropped on the floor. This make it possible + -- to safely implement features such as timeouts on blocking + -- operations. + + -- ** Basic operations + writeChan, -- Chan a -> a -> IO () + readChan, -- Chan a -> IO a + -- ** Questionable operations + unGetChan, -- Chan a -> a -> IO () + swapChan, -- Chan a -> a -> IO a + -- ** List operations + getChanContents, -- Chan a -> IO [a] + getChanN, -- Chan a -> Integer -> IO [a] + writeList2Chan, -- Chan a -> [a] -> IO () + + -- * Synchronous, non-blocking operations + -- | These operations are similar to the blocking operations in that + -- they only succeed by synchronizing with another thread, but + -- they return a failure code rather than block if no other thread + -- is ready or if they cannot acquire a lock on the channel. + -- + -- Generally, a non-blocking operation from this section + -- cannot synchronize with another non-blocking operation. The + -- other operation that pairs up with one of these operations will + -- always be blocking or asynchronous. + -- + -- These operations are designed to operate in constant time + -- (or linear time for the list operations). + -- In particular, it may be possible to attempt to synchronize with + -- a waiting thread that gives up before the operation is complete. + -- Rather than look for another opportunity, which could lead to + -- an arbitrary number of attempts, the operation fails with + -- 'TryAgain'. + + -- ** The non-blocking result datatype + TryResult(..), -- concrete: * -> * + maybeTry, -- IO (TryResult a) -> IO (Maybe a) + + -- ** Basic operations + tryWriteChan, -- Chan a -> a -> IO (TryResult () + tryReadChan, -- Chan a -> IO (TryResult a) + tryPeekChan, -- Chan a -> IO (TryResult a) + -- ** List operations + tryGetChanContents, -- Chan a -> IO (TryResult [a]) + tryGetChanN, -- Chan a -> Integer -> IO (TryResult [a]) + tryWriteList2Chan, -- Chan a -> Integer -> IO (TryResult (), [a]) + + -- * Asynchronous operations + -- | The asynchronous operations always succeed immediately. + -- They should be semantically equivalent to forking another thread + -- and performing the equivalent blocking operation (though they do + -- not actually require a separate thread). + + asyncWriteChan, -- Chan a -> a -> IO () + asyncUnGetChan, -- Chan a -> a -> IO () + tryAsyncSwapChan, -- Chan a -> a -> IO a + asyncWriteList2Chan -- Chan a -> [a] -> IO () +) where + +import Control.Concurrent.MVar hiding ( modifyMVar ) +import Control.Exception +import Control.Monad +import Data.IORef +import System.IO.Unsafe ( unsafeInterleaveIO ) + +--- +--- Amortized O(1) queues +--- + +data Q a = Q { readEnd :: ![a], writeEnd :: ![a] } + +empty :: Q a +empty = Q [] [] + +(|>) :: Q a -> a -> Q a +(|>) q a = q { writeEnd = a : writeEnd q } + +(<|) :: a -> Q a -> Q a +(<|) a q = q { readEnd = a : readEnd q } + +(|>>>) :: Q a -> [a] -> Q a +(|>>>) q as = Q { readEnd = concat [ readEnd q, + reverse (writeEnd q), + as ], + writeEnd = [] } + +data QView a b = !a :< !(Q a) + | NoQ !b + +dequeue :: b -> Q a -> QView a b +dequeue b (Q [] []) = NoQ b +dequeue _ (Q (r:rs) ws) = r :< Q rs ws +dequeue b (Q [] ws) = dequeue b (Q (reverse ws) []) + +--- +--- Chan representation +--- + +-- Both readers and writers include IORef (Maybe ...) in their +-- representations. This allows \"revoking\" an operation in case the +-- blocked thread is interrupted. +-- +-- A reader contains an MVar in which to write a message to it, whereas +-- a writer contains the value it has sent and an MVar on which to +-- confirm receipt of the message. A channel at any point in time is +-- represented as either a queue of waiting writers or a queue of +-- waiting readers. +type Reader a = (IORef (Maybe (MVar a))) +type Writer a = (IORef (Maybe a), MVar ()) +data Rep a = RQ !(Q (Reader a)) + | WQ !(Q (Writer a)) + +-- | The abstract channel type for sending values of type @a@. +newtype Chan a = Chan (MVar (Rep a)) + deriving Eq + +-- | The synchronous, non-blocking operations may succeed immediately, +-- or they may give up for a variety of reasons: +data TryResult a = + -- | The operation succeeded. + Success { getSuccess :: a } + -- | No other thread is currently ready to synchronize for the + -- requested operation. + | NotReady + -- | An attempt was made to synchronize with another thread, but + -- the other thread bailed out before it could complete. Another + -- thread may be available, so it may be worth trying again + -- immediately. + | TryAgain + -- | Another thread is currently operating on the channel. It may + -- be worth trying again very soon. + | WouldBlock + deriving (Eq, Show) + +getReaders :: Rep a -> QView (Reader a) (Q (Writer a)) +getReaders (RQ q) = dequeue empty q +getReaders (WQ q) = dequeue q empty + +getWriters :: Rep a -> QView (Writer a) (Q (Reader a)) +getWriters (RQ q) = dequeue q empty +getWriters (WQ q) = dequeue empty q + +clear :: IO a -> IORef (Maybe b) -> IO a +clear io r = block $ io `finally` writeIORef r Nothing + +-- | Make a new channel. +newChan :: IO (Chan a) +newChan = fmap Chan (newMVar (RQ empty)) + +genericWriteChan :: (Q (Writer a) -> Writer a -> Q (Writer a)) -> + Bool -> + Chan a -> a -> IO () +genericWriteChan enq wait (Chan m) a = join $ modifyMVar m modify + where + modify e = case getReaders e of + r :< readers -> do + maybereader <- readIORef r + case maybereader of + Just reader -> do + putMVar reader a + return (RQ readers, return ()) + Nothing -> + modify e + NoQ writers -> do + r <- newIORef (Just a) + confirm <- newEmptyMVar + return (WQ (writers `enq` (r, confirm)), + if wait + then takeMVar confirm `clear` r + else return ()) + +-- | +-- Write a value to a channel, possibly blocking until synchronizing +-- with a reader. +writeChan :: Chan a -> a -> IO () +writeChan = genericWriteChan (|>) True + +-- | +-- Write to the \"read end\" of a channel. If several writers are +-- waiting, this jumps ahead of them to the front of the line. Blocks +-- until matched up with a reader. +unGetChan :: Chan a -> a -> IO () +unGetChan = genericWriteChan (flip (<|)) True + +-- | +-- Write a value to a channel, returning immediately rather than +-- waiting for the reader to arrive. +asyncWriteChan :: Chan a -> a -> IO () +asyncWriteChan = genericWriteChan (|>) False + +-- | +-- Write a value to the \"read end\" of a channel, succeeding immediately +-- rather than waiting for a reader. +asyncUnGetChan :: Chan a -> a -> IO () +asyncUnGetChan = genericWriteChan (flip (<|)) False + +-- | +-- Attempts to write a value to a channel, succeeding immediately +-- if a reader is already available to synchronize. Will fail +-- if the reader is interrupted before the operation completes, if there +-- is no reader available, or if another thread is currently starting +-- an operation on the channel. +tryWriteChan :: Chan a -> a -> IO (TryResult ()) +tryWriteChan (Chan m) a = tryModifyMVar m modify + where + modify e = case getReaders e of + r :< readers -> do + maybereader <- readIORef r + case maybereader of + Just reader -> do + putMVar reader a + return (RQ readers, Success ()) + Nothing -> + return (e, TryAgain) + NoQ _ -> + return (e, NotReady) + +-- | +-- Reads a value from a channel, potentially blocking until a writer +-- is ready to synchronize. +readChan :: Chan a -> IO a +readChan (Chan m) = join $ modifyMVar m modify + where + modify e = case getWriters e of + NoQ readers -> do + message <- newEmptyMVar + r <- newIORef (Just message) + return (RQ (readers |> r), + takeMVar message `clear` r) + (r, confirm) :< writers -> do + maybea <- readIORef r + case maybea of + Just a -> do + putMVar confirm () + return (WQ writers, return a) + Nothing -> + modify (WQ writers) + +-- | +-- Attempts to read a value from a channel, succeeding immediately +-- if a writer is already available to synchronize. +tryReadChan :: Chan a -> IO (TryResult a) +tryReadChan (Chan m) = tryModifyMVar m modify + where + modify e = case getWriters e of + NoQ _ -> + return (e, NotReady) + (r, confirm) :< writers -> do + maybea <- readIORef r + case maybea of + Just a -> do + putMVar confirm () + return (WQ writers, Success a) + Nothing -> do + return (WQ writers, TryAgain) + +-- | +-- Attempts to read a value from a channel, but does not allow a writer +-- to synchronize, and does not remove the observed value from the +-- channel. Fails if no writer is currently available, if the first +-- writer has bailed, or if it cannot immediately get a lock on the +-- channel. +tryPeekChan :: Chan a -> IO (TryResult a) +tryPeekChan (Chan m) = tryModifyMVar m modify + where + modify e = + case getWriters e of + NoQ _ -> return (e, NotReady) + (r, _) :< writers -> do + maybea <- readIORef r + case maybea of + Just a -> return (e, Success a) + Nothing -> return (WQ writers, TryAgain) + +-- | +-- Reads a value from a channel, replacing it with a different value. +-- Blocks until the replacement value is read, and then returns the old +-- value. +-- +-- /CAUTION:/ This operation does not guarantee that the read and +-- subsequent write are atomic. It is somewhat likely to be better +-- in that respect than 'readChan' followed by 'unGetChan', however. +swapChan :: Chan a -> a -> IO a +swapChan (Chan m) a' = join $ transactMVar m modify + where + modify e commit = case getWriters e of + NoQ readers -> do + message <- newEmptyMVar + r <- newIORef (Just message) + _ <- commit (RQ (readers |> r)) + return $ do + a <- takeMVar message `clear` r + -- Race condition here! I think we'd need a different + -- representation to do this one right. + writeChan (Chan m) a' + return a + (r, confirm) :< writers -> do + maybea <- readIORef r + case maybea of + Just a -> do + r' <- newIORef (Just a') + confirm' <- newEmptyMVar + _ <- block $ do + putMVar confirm () + commit (WQ ((r', confirm') <| writers)) + return $ do + takeMVar confirm' `clear` r' + return a + Nothing -> do + modify (WQ writers) commit + +-- | +-- If a writer is available to synchronize with, synchronizes with the +-- writer, allowing its operation to complete, writes the replacement +-- value ahead of any other writers, and then returns immediately. +-- Unlike 'swapChan', guarantees that no other write can intervene. +tryAsyncSwapChan :: Chan a -> a -> IO (TryResult a) +tryAsyncSwapChan (Chan m) a' = tryModifyMVar m modify + where + modify e = case getWriters e of + NoQ _ -> return (e, NotReady) + (r, confirm) :< writers -> do + maybea <- readIORef r + case maybea of + Just a -> do + r' <- newIORef (Just a') + confirm' <- newEmptyMVar + putMVar confirm () + return (WQ ((r', confirm') <| writers), Success a) + Nothing -> return (WQ writers, TryAgain) + +-- | Is the channel currently empty? Note that the answer may become +-- false arbitrarily soon. Don't rely on this operation. +isEmptyChan :: Chan a -> IO Bool +isEmptyChan (Chan m) = do + e <- readMVar m + case getWriters e of + NoQ _ -> return True + _ -> return False + +-- Helper for pulling getting all the waiting data in +-- a channel while discharging the writers. Returns a (possibly +-- empty) queue of readers. +-- +-- Rather complicated interface! It takes a channel representation, +-- and maybe an integer bound on how much stuff to read. It then +-- returns: +-- * The list of results, +-- * A queue of readers, possibly empty, and +-- * one of: +-- * The remaining list of writers, if the counter ran out, or +-- * The remaining counter, if the writers ran out. +getImmediateChanContents :: + Rep a -> Maybe Integer -> + IO ([a], Q (Reader a), Either (Q (Writer a)) (Maybe Integer)) +getImmediateChanContents e0 n0 = case getWriters e0 of + NoQ readers -> + return ([], readers, Right n0) + ((r, confirm) :< writers) -> do + loop n0 ((r, confirm) :< writers) + where + loop n (NoQ ()) = + return ([], empty, Right n) + loop (Just 0) (writer :< writers) = + return ([], empty, Left (writer <| writers)) + loop n ((r, confirm) :< writers) = unsafeInterleaveIO $ do + maybea <- readIORef r + case maybea of + Just a -> do + putMVar confirm () + (as, rs, rest) <- loop (fmap pred n) (dequeue () writers) + return (a:as, rs, rest) + Nothing -> + loop n (dequeue () writers) + +getChanMaybeN :: Chan a -> Maybe Integer -> IO [a] +getChanMaybeN (Chan m) n = modifyMVar m modify + where + modify e = do + stopr <- newIORef False + (as, readers, rest) <- getImmediateChanContents e n + case rest of + Left writers -> return (WQ writers, as) + Right n' -> do + readers' <- makereaders n' stopr + as' <- loop stopr readers' + return (RQ $ readers |>>> readers', as ++ as') + loop _ [] = return [] + loop stopr (r:rs) = unsafeInterleaveIO $ do + maybereader <- readIORef r + case maybereader of + Just reader -> do + a <- (readMVar reader `clear` r) + `onException` writeIORef stopr True + as <- loop stopr rs + return (a:as) + Nothing -> + loop stopr rs + makereaders (Just 0) _ = return [] + makereaders n' stopr = unsafeInterleaveIO $ do + stop <- readIORef stopr + if stop + then return [] + else do + message <- newEmptyMVar + r <- newIORef (Just message) + rest <- makereaders (fmap pred n') stopr + return (r:rest) +-- | +-- Read the contents of the channel as a lazy list. While this +-- operation returns immediately, forcing evaluation of the list will +-- block, which is why this is included among the blocking operations. +-- Writers will block until each link in the list is forced as well. +-- +-- Any subsequent attempts to read from the channel will fail, unless +-- a thread is interrupted while blocking on forcing the list. Don't +-- rely on this behavior. +getChanContents :: Chan a -> IO [a] +getChanContents c = getChanMaybeN c Nothing + +-- | +-- Read a given number of elements from the channel as a lazy list. +-- Like 'getChanContents', this operation returns immediately, but it +-- will block when the list is forced. (Taking the length of the list +-- should block until all the matching writes complete.) +getChanN :: Chan a -> Integer -> IO [a] +getChanN c = getChanMaybeN c . Just + +-- | +-- Read the currently available elements from the channel as a lazy +-- list. The list is lazy because the number of currently available +-- elements may be infinite (see 'writeList2Chan'). +tryGetChanContents :: Chan a -> IO (TryResult [a]) +tryGetChanContents (Chan m) = tryModifyMVar m modify + where + modify e = do + (as, readers, _) <- getImmediateChanContents e Nothing + return (RQ readers, Success as) + +-- | +-- Read up to the given number of currently available elements +-- from the channel. The list will be no longer than the given +-- number, but if there are insufficient writers available then +-- it may be shorter. The writers will block until their portions +-- of the list's spine are forced. +tryGetChanN :: Chan a -> Integer -> IO (TryResult [a]) +tryGetChanN (Chan m) n = tryModifyMVar m modify + where + modify e = do + (as, readers, rest) <- getImmediateChanContents e (Just n) + case rest of + Left writers -> return (WQ writers, Success as) + Right _ -> return (RQ readers, Success as) + +genericWriteList2Chan :: Bool -> Chan a -> [a] -> IO () +genericWriteList2Chan wait (Chan m) as0 = join $ modifyMVar m (loop as0) + where + loop [] e = return (e, return ()) + loop (a:as) e = + case getReaders e of + r :< readers -> do + maybereader <- readIORef r + case maybereader of + Just reader -> do + putMVar reader a + loop as (RQ readers) + Nothing -> + loop (a:as) (RQ readers) + NoQ writers -> do + stopr <- newIORef False + writers' <- makeWriters stopr (a:as) + -- This seems like overkill, maybe, but it ensures that + -- if the writer gets killed, the remainder of the list + -- not yet delivered is dropped. + let each (r, c) = do + (takeMVar c `clear` r) + `onException` writeIORef stopr True + action = if wait + then mapM_ each writers' + else return () + return (WQ (writers |>>> writers'), action) + makeWriters _ [] = return [] + makeWriters stopr (a:as) = unsafeInterleaveIO $ do + stop <- readIORef stopr + if stop + then return [] + else do + rI <- newIORef (Just a) + confirmI <- newEmptyMVar + rest <- makeWriters stopr as + return ((rI, confirmI):rest) + +-- | +-- Write a list to a channel, blocking until the read completes. +-- It is guaranteed that no other writes can intervene among the +-- list elements. (This cannot be implemented in terms of +-- 'writeChan'.) The list may be infinite, in which case this +-- operation never completes. +-- +-- Interrupting this operation before the list is read completely causes +-- the rest of the list not to be written. (If you want to write the +-- whole list, 'asyncWriteList2Chan' may be suitable.) +writeList2Chan :: Chan a -> [a] -> IO () +writeList2Chan = genericWriteList2Chan True + +-- | +-- Write a list to a channel, succeeding immediately. The list may +-- be infinite, in which case the operation still completes +-- immediately. (Actually, it may take time proportional to the number +-- of readers that are ready, so if an infinite list is written to +-- 'getChanContents' on the other side, it may not actually complete.) +asyncWriteList2Chan :: Chan a -> [a] -> IO () +asyncWriteList2Chan = genericWriteList2Chan False + +-- | +-- Attempt to write as much of a list as possible to a channel +-- synchronously, but without blocking; returns the unwritten remainder +-- of the list. This operation will write additional list elements so +-- long as -- there are readers ready to receive them (and so long as the +-- list doesn't run out). +tryWriteList2Chan :: Chan a -> [a] -> IO (TryResult (), [a]) +tryWriteList2Chan (Chan m) as0 = do + result <- tryModifyMVar m (loop as0) + case result of + Success pair -> return pair + WouldBlock -> return (WouldBlock, as0) + TryAgain -> return (TryAgain, as0) + NotReady -> return (NotReady, as0) + where + loop [] e = return (e, Success (Success (), [])) + loop (a:as) e = do + case getReaders e of + r :< readers -> block $ do + maybereader <- readIORef r + case maybereader of + Just reader -> do + putMVar reader a + loop as (RQ readers) + Nothing -> + return (RQ readers, Success (TryAgain, a:as)) + NoQ _ -> return (e, Success (NotReady, a:as)) + +-- | +-- Lift results of the try* operations into 'Maybe'. 'Success' goes +-- to 'Just' and all kinds of failure go to 'Nothing'. +maybeTry :: IO (TryResult a) -> IO (Maybe a) +maybeTry io = do + tr <- io + return $ case tr of + Success r -> Just r + _ -> Nothing + +--- +--- Helpful MVar stuff +--- + +saveBlock :: IO (IO a -> IO a) +saveBlock = do + b <- blocked + case b of + True -> return block + False -> return unblock + +modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b +modifyMVar m io = do + restore <- saveBlock + block $ do + a <- takeMVar m + (a',b) <- restore (io a) + `onException` putMVar m a + putMVar m a' + return b + +-- Control.Concurrent.MVar doesn't have this, but it's pretty useful +-- for implementing non-blocking operations. +tryModifyMVar :: MVar a -> (a -> IO (a, TryResult b)) -> IO (TryResult b) +tryModifyMVar m io = do + restore <- saveBlock + block $ do + maybea <- tryTakeMVar m + case maybea of + Just a -> do + (a',b) <- restore (io a) + `onException` putMVar m a + putMVar m a' + return b + Nothing -> + return WouldBlock + +transactMVar :: MVar a -> + (a -> (a -> IO ()) -> IO b) -> + IO b +transactMVar m io = do + restore <- saveBlock + block $ do + a <- takeMVar m + r <- newIORef a + restore (io a (writeIORef r)) + `finally` (readIORef r >>= putMVar m) + +{- +tryTransactMVar :: MVar a -> + (a -> (a -> IO ()) -> IO (TryResult b)) -> + IO (TryResult b) +tryTransactMVar m io = do + restore <- saveBlock + block $ do + maybea <- tryTakeMVar m + case maybea of + Just a -> do + r <- newIORef a + restore (io a (writeIORef r)) + `finally` (readIORef r >>= putMVar m) + Nothing -> + return WouldBlock +-} + diff --git a/src/Basis/Exn.hs b/src/Basis/Exn.hs new file mode 100644 --- /dev/null +++ b/src/Basis/Exn.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE + QuasiQuotes #-} +module Basis.Exn ( entries ) where + +import BasisUtils +import Value +import Syntax + +import qualified Loc +import qualified Syntax.Notable + +import Control.Exception + +entries :: [Entry Raw] +entries = [ + fun "raise" -: [$ty| all `a. exn -> `a |] + -= \exn -> throw (VExn exn :: VExn) + :: IO Value, + fun "tryfun_string" + -: [$ty| all `a. (unit -o `a) -> (exn + string) + `a |] + -= \(VaFun _ f) -> do + fmap Right (f vaUnit) `catches` + [ Handler $ \(VExn v) -> return (Left (Left v)) + , Handler $ \e -> return (Left (Right (show (e:: IOError)))) ] + ] diff --git a/src/Basis/Future.hs b/src/Basis/Future.hs new file mode 100644 --- /dev/null +++ b/src/Basis/Future.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE + DeriveDataTypeable, + QuasiQuotes #-} +module Basis.Future (entries) where + +import Data.Typeable (Typeable) +import BasisUtils +import Syntax +import Value (Value, Valuable(..)) + +import qualified Loc +import qualified Syntax.Notable +import qualified Syntax.Decl + +import qualified Control.Concurrent as CC +import qualified Control.Concurrent.MVar as MV + +newtype Future = Future { unFuture :: MV.MVar Value } + deriving (Eq, Typeable) + +instance Valuable Future where + veq = (==) + vpprPrec _ _ = text "#<(co)future>" + + +entries :: [Entry Raw] +entries = [ + -- Futures + dec [$dc| type +`a future qualifier A |], + dec [$dc| type -`a cofuture qualifier A |], + + fun "new" -: [$ty| all `a. (unit -o `a) -> `a future |] + -= \f -> do + future <- MV.newEmptyMVar + CC.forkIO (vapp f () >>= MV.putMVar future) + return (Future future), + fun "sync" -: [$ty| all `a. `a future -> `a |] + -= (MV.takeMVar . unFuture), + fun "coNew" -: [$ty| all `a. (`a future -o unit) -> `a cofuture |] + -= \f -> do + future <- MV.newEmptyMVar + CC.forkIO (vapp f (Future future) >> return ()) + return (Future future), + fun "coSync" -: [$ty| all `a. `a cofuture -> `a -o unit |] + -= \future value -> MV.putMVar (unFuture future) value, + fun "newPair" -: [$ty| all `a. unit -> `a future * `a cofuture |] + -= \() -> do + future <- MV.newEmptyMVar + return (Future future, Future future) + ] + diff --git a/src/Basis/IO.hs b/src/Basis/IO.hs new file mode 100644 --- /dev/null +++ b/src/Basis/IO.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE + DeriveDataTypeable, + QuasiQuotes, + StandaloneDeriving + #-} +module Basis.IO ( entries ) where + +import qualified IO + +import Data.Data (Typeable, Data) +import BasisUtils +import Syntax +import Util +import Value (Valuable(..), vinjData, vprjDataM) + +import qualified Loc +import qualified Syntax.Notable +import qualified Syntax.Decl + +instance Valuable IO.Handle where + veq = (==) + vpprPrec _ _ = text "#" + +instance Valuable IO.IOMode where + veq = (==) + vpprPrec _ = text . show + vinj = vinjData + vprjM = vprjDataM +deriving instance Typeable IO.IOMode +deriving instance Data IO.IOMode + +entries :: [Entry Raw] +entries = [ + dec [$dc| type handle |], + dec [$dc| type ioMode = ReadMode + | WriteMode + | AppendMode + | ReadWriteMode |], + -- File operations + fun "openFile" -: [$ty| string -> ioMode -> handle |] + -= IO.openFile, + fun "hGetChar" -: [$ty| handle -> char |] + -= fmap char2integer . IO.hGetChar, + fun "hGetLine" -: [$ty| handle -> string |] + -= IO.hGetLine, + fun "hIsEOF" -: [$ty| handle -> bool |] + -= IO.hIsEOF, + fun "hPutChar" -: [$ty| handle -> char -> unit |] + -= \h -> IO.hPutChar h . integer2char, + fun "hPutStr" -: [$ty| handle -> string -> unit |] + -= IO.hPutStr, + fun "hClose" -: [$ty| handle -> unit |] + -= IO.hClose, + fun "hFlush" -: [$ty| handle -> unit |] + -= IO.hFlush, + + val "stdin" -: [$ty| handle |] -= IO.stdin, + val "stdout" -: [$ty| handle |] -= IO.stdout, + val "stderr" -: [$ty| handle |] -= IO.stderr + ] diff --git a/src/Basis/MVar.hs b/src/Basis/MVar.hs new file mode 100644 --- /dev/null +++ b/src/Basis/MVar.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE + DeriveDataTypeable, + QuasiQuotes #-} +module Basis.MVar (entries) where + +import Data.Typeable (Typeable) +import BasisUtils +import Syntax +import Util +import Value (Value, Valuable(..)) + +import qualified Loc +import qualified Syntax.Notable +import qualified Syntax.Decl + +import qualified Control.Concurrent.MVar as MV + +newtype MVar = MVar { unMVar :: MV.MVar Value } + deriving (Eq, Typeable) + +instance Valuable MVar where + veq = (==) + vpprPrec _ _ = text "#" + +entries :: [Entry Raw] +entries = [ + dec [$dc| type `a mvar qualifier U |], + fun "new" -: [$ty| all `a. `a -> `a mvar |] + -= liftM MVar . MV.newMVar, + fun "newEmpty" + -: [$ty| all `a. unit -> `a mvar |] + -= \() -> MVar `liftM` MV.newEmptyMVar, + fun "take" + -: [$ty| all `a. `a mvar -> `a |] + -= MV.takeMVar . unMVar, + fun "put" + -: [$ty| all `a. `a mvar -> `a -> unit |] + -= MV.putMVar . unMVar, + fun "read" + -: [$ty| all 'a. 'a mvar -> 'a |] -- important! + -= MV.readMVar . unMVar, + fun "swap" + -: [$ty| all `a. `a mvar -> `a -> `a |] + -= MV.swapMVar . unMVar, + fun "tryTake" + -: [$ty| all `a. `a mvar -> `a option |] + -= MV.tryTakeMVar . unMVar, + fun "tryPut" + -: [$ty| all `a. `a mvar -> `a -> bool |] + -= MV.tryPutMVar . unMVar, + fun "isEmpty" + -: [$ty| all `a. `a mvar -> bool |] + -= MV.isEmptyMVar . unMVar, + fun "callWith" + -: [$ty| all `a `b. `a mvar -> (`a -> `b) -> `b |] + -= \mv callback -> MV.withMVar (unMVar mv) (vapp callback), + fun "modify_" + -: [$ty| all `a. `a mvar -> (`a -> `a) -> unit |] + -= \mv callback -> MV.modifyMVar_ (unMVar mv) (vapp callback), + fun "modify" + -: [$ty| all `a `b. `a mvar -> (`a -> `a * `b) -> `b |] + -= \mv callback -> MV.modifyMVar (unMVar mv) $ \v -> do + result <- vapp callback v + (vprjM result :: IO (Value, Value)) + ] + diff --git a/src/Basis/Socket.hs b/src/Basis/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Basis/Socket.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE + DeriveDataTypeable, + QuasiQuotes, + StandaloneDeriving + #-} +module Basis.Socket ( entries ) where + +import Data.Data as Data +import Foreign.C.Types (CInt) +import qualified Network.Socket as S + +import Basis.IO () +import BasisUtils +import Syntax +import Value + +import qualified Loc +import qualified Syntax.Notable +import qualified Syntax.Decl + +instance Valuable S.Socket where + veq = (==) + vpprPrec _ _ = text "#" + +instance Valuable S.Family where + veq = (==) + vpprPrec _ = text . show + vinj = vinjData + vprjM = vprjDataM +deriving instance Typeable S.Family +deriving instance Data S.Family + +instance Valuable S.ShutdownCmd where + veq = (==) + vpprPrec _ = text . show + vinj = vinjData + vprjM = vprjDataM +deriving instance Eq S.ShutdownCmd +deriving instance Show S.ShutdownCmd +deriving instance Data S.ShutdownCmd + +instance Valuable S.SocketType where + veq = (==) + vpprPrec _ = text . show + vinj = vinjData + vprjM = vprjDataM +deriving instance Data S.SocketType + +instance Valuable S.AddrInfoFlag where + veq = (==) + vpprPrec _ = text . show + vinj = vinjData + vprjM = vprjDataM +deriving instance Data S.AddrInfoFlag + +instance Valuable S.PortNumber where + veq = (==) + vpprPrec _ = text . show + vinj = vinjData + vprjM = vprjDataM + +portNumberType :: DataType +portNumberType = mkDataType "Network.Socket.PortNumber" [portNumConstr] +portNumConstr :: Constr +portNumConstr = mkConstr portNumberType "PortNum" [] Prefix + +fakePortNumCon :: Integer -> S.PortNumber +fakePortNumCon = fromIntegral +fakePortNumSel :: S.PortNumber -> Integer +fakePortNumSel = toInteger + +instance Data S.PortNumber where + gfoldl f z portNum = z fakePortNumCon `f` (fakePortNumSel portNum) + toConstr (S.PortNum _) = portNumConstr + gunfold k z c = case constrIndex c of + 1 -> k (z fakePortNumCon) + _ -> error "gunfold" + dataTypeOf _ = portNumberType + +instance Data.Data CInt where + toConstr x = mkIntegralConstr cIntType (fromIntegral x :: CInt) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = cIntType +cIntType :: DataType +cIntType = mkIntType "Foreign.C.Types.CInt" + +instance Valuable S.SockAddr where + veq = (==) + vpprPrec _ = text . show + vinj = vinjData + vprjM = vprjDataM +deriving instance Data S.SockAddr + +instance Valuable S.AddrInfo where + veq = (==) + vpprPrec _ = text . show + vinj = vinjData + vprjM = vprjDataM +deriving instance Data S.AddrInfo + +entries :: [Entry Raw] +entries = [ + dec [$dc| type portNumber = PortNum of int |], + dec [$dc| type socket |], + typ (enumTypeDecl S.AF_INET), + typ (enumTypeDecl S.Stream), + dec [$dc| type protocolNumber = int |], + dec [$dc| type hostAddress = int |], + dec [$dc| type flowInfo = int |], + dec [$dc| type hostAddress6 = int * int * int * int |], + dec [$dc| type scopeID = int |], + dec [$dc| type sockAddr + = SockAddrInet of portNumber * hostAddress + | SockAddrInet6 of + portNumber * flowInfo * hostAddress6 * scopeID + | SockAddrUnix of string |], + typ (enumTypeDecl S.AI_ALL), + typ (enumTypeDecl S.ShutdownSend), + dec [$dc| type addrInfo + = AddrInfo of + addrInfoFlag list * family * socketType * + protocolNumber * sockAddr * string option |], + dec [$dc| type hostName = string |], + dec [$dc| type serviceName = string |], + + val "inaddr_any" -: [$ty| hostAddress |] + -= S.iNADDR_ANY, + val "defaultProtocol" -: [$ty| protocolNumber |] + -= S.defaultProtocol, + val "defaultHints" -: [$ty| addrInfo |] + -= S.defaultHints { + S.addrAddress = S.SockAddrInet S.aNY_PORT S.iNADDR_ANY, + S.addrCanonName = Nothing + }, + + fun "getAddrInfo" + -: [$ty| addrInfo option -> hostName option -> + serviceName option -> addrInfo list |] + -= S.getAddrInfo, + fun "inet_addr" -: [$ty| string -> hostAddress |] + -= S.inet_addr, + + fun "socket" -: [$ty| family -> socketType -> protocolNumber -> socket |] + -= S.socket, + fun "bind" -: [$ty| socket -> sockAddr -> unit |] + -= S.bindSocket, + fun "connect" -: [$ty| socket -> sockAddr -> unit |] + -= S.connect, + fun "listen" -: [$ty| socket -> int -> unit |] + -= S.listen, + fun "accept" -: [$ty| socket -> socket * sockAddr |] + -= S.accept, + fun "send" -: [$ty| socket -> string -> int |] + -= \sock str -> S.send sock str, + fun "recv" -: [$ty| socket -> int -> string |] + -= \sock len -> S.recv sock len, + fun "shutdown" -: [$ty| socket -> shutdownCmd -> unit |] + -= S.shutdown, + fun "close" -: [$ty| socket -> unit |] + -= S.sClose, + + fun "isReadable" -: [$ty| socket -> bool |] + -= S.sIsReadable, + fun "isWritable" -: [$ty| socket -> bool |] + -= S.sIsWritable + ] + diff --git a/src/Basis/Thread.hs b/src/Basis/Thread.hs new file mode 100644 --- /dev/null +++ b/src/Basis/Thread.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE + DeriveDataTypeable, + QuasiQuotes #-} +module Basis.Thread (entries) where + +import BasisUtils +import Syntax +import Value (Vinj(..)) + +import qualified Loc +import qualified Syntax.Notable +import qualified Syntax.Decl + +import qualified Control.Concurrent as CC + +entries :: [Entry Raw] +entries = [ + -- Threads + dec [$dc| type thread |], + fun "fork" -: [$ty| (unit -> unit) -> thread |] + -= \f -> Vinj `fmap` CC.forkIO (vapp f () >> return ()), + fun "kill" -: [$ty| thread -> unit |] + -= CC.killThread . unVinj, + fun "delay" -: [$ty| int -> unit |] + -= CC.threadDelay . (fromIntegral :: Integer -> Int), + fun "print" -: [$ty| thread -> thread |] + -= \t -> do print (t :: Vinj CC.ThreadId); return t + ] diff --git a/src/BasisUtils.hs b/src/BasisUtils.hs new file mode 100644 --- /dev/null +++ b/src/BasisUtils.hs @@ -0,0 +1,198 @@ +-- | Tools for implementing primitive operations -- essentially an +-- object-language/meta-language FFI. +{-# LANGUAGE + FlexibleInstances, + QuasiQuotes #-} +module BasisUtils ( + -- | * Initial environment entries + Entry, + -- ** Entry constructors + -- *** Values + fun, val, binArith, + -- *** Types + dec, typ, primtype, + -- *** Modules + submod, + -- ** Sugar operators for entry construction + (-:), (-=), + -- ** Default location for entries + _loc, + module Loc, + -- ** Environment construction + basis2venv, basis2tenv, basis2renv, + + -- * Function embedding + MkFun(..), baseMkFun, vapp, + + -- * Re-exports + text, Uid(..), + module Meta.Quasi, +) where + +import Dynamics (E, addVal, addMod) +import Env (GenEmpty(..)) +import Meta.Quasi +import Parser (ptd) +import Ppr (ppr, pprPrec, text, precApp) +import Rename +import Statics (S, env0, runTC, tcMapM, addVal, addDecl, addType, addMod) +import Syntax +import qualified Syntax.Notable +import qualified Syntax.Decl +import Type (TyCon, tcName) +import Loc (Loc(Loc), mkBogus, setLoc) +import Util +import Value (Valuable(..), FunName(..), funNameDocs, Value(..)) + +-- | Kind of identifier used in this module +type R = Raw + +-- | Default source location for primitives +_loc :: Loc +_loc = mkBogus "" + +-- | An entry in the initial environment +data Entry i + -- | A value entry has a name, a types, and a value + = ValEn { + enName :: Lid i, + enType :: Type i, + enValue :: Value + } + -- | A declaration entry + | DecEn { + enSrc :: Decl i + } + -- | A type entry associates a tycon name with information about it + | TypEn { + enName :: Lid i, + enTyCon :: TyCon + } + -- | A module entry associates a module name with a list of entries + | ModEn { + enModName :: Uid i, + enEnts :: [Entry i] + } + +-- | Type class for embedding Haskell functions as object language +-- values. Dispatches on return type @r@. +class MkFun r where + mkFun :: Valuable v => FunName -> (v -> r) -> Value + +-- | Recursive case is functions that return functions: accept +-- one argument, then look for more +instance (Valuable v, MkFun r) => MkFun (v -> r) where + mkFun n f = VaFun n $ \v -> + vprjM v >>! mkFun (next v) . f + where + next v = FNAnonymous (funNameDocs n ++ [pprPrec precApp v]) + +-- Base cases for various return types + +-- | Base case for functions returning in the 'IO' monad +instance Valuable r => MkFun (IO r) where + mkFun n f = VaFun n $ \v -> vprjM v >>= f >>! vinj + +-- | Base case for functions that already return 'Value' +instance MkFun Value where + mkFun n f = VaFun n $ \v -> vprjM v >>! f + +instance MkFun Integer where mkFun = baseMkFun +instance MkFun Double where mkFun = baseMkFun +instance MkFun Char where mkFun = baseMkFun +instance MkFun Bool where mkFun = baseMkFun +instance MkFun () where mkFun = baseMkFun +instance (Valuable a, MkFun a) => + MkFun [a] where mkFun = baseMkFun +instance (Valuable a, Valuable b, MkFun a, MkFun b) => + MkFun (a, b) where mkFun = baseMkFun + +baseMkFun :: (Valuable a, Valuable b) => FunName -> (a -> b) -> Value +baseMkFun n f = VaFun n $ \v -> vprjM v >>! vinj . f + +-- | Make a value entry for a Haskell non-function. +val :: Valuable v => String -> Type R -> v -> Entry Raw +val name t v = ValEn (lid name) t (vinj v) + +-- | Make a value entry for a Haskell function, given a names and types +-- for the sublanguages. (Leave blank to leave the binding out of +-- that language. +fun :: (MkFun r, Valuable v) => + String -> Type R -> (v -> r) -> Entry Raw +fun name t f = ValEn (lid name) t + (mkFun (FNNamed (ppr (lid name :: Lid R))) f) + +typ :: String -> Entry Raw +typ s = DecEn [$dc| type $tydec:td |] where td = ptd s + +-- | Creates a declaration entry +dec :: Decl R -> Entry Raw +dec = DecEn + +-- | Creates a module entry +submod :: String -> [Entry Raw] -> Entry Raw +submod = ModEn . uid + +-- | Creates a primitve type entry, binding a name to a type tag +-- (which is usually defined in Syntax.hs) +primtype :: String -> TyCon -> Entry Raw +primtype = TypEn . lid + +-- | Application +(-:), (-=) :: (a -> b) -> a -> b +(-:) = ($) +(-=) = ($) +-- | Application twice, for giving the same type in C and A +infixl 5 -: +infixr 0 -= + +-- | Instance of 'fun' for making binary arithmetic functions +binArith :: String -> (Integer -> Integer -> Integer) -> Entry Raw +binArith name = fun name [$ty| int -> int -> int |] + +-- | Apply an object language function (as a 'Value') +vapp :: Valuable a => Value -> a -> IO Value +vapp = \(VaFun _ f) x -> f (vinj x) +infixr 0 `vapp` + +-- | Build the renaming environment and rename the entries +basis2renv :: Monad m => [Entry Raw] -> + m ([Entry Renamed], RenameState) +basis2renv = + runRenamingM False _loc renameState0 . renameMapM each where + each ValEn { enName = u, enType = t, enValue = v } = do + u' <- Rename.addVal u + t' <- renameType t + return ValEn { enName = u', enType = t', enValue = v } + each DecEn { enSrc = d } = do + d' <- renameDecl d + return DecEn { enSrc = d' } + each TypEn { enName = l, enTyCon = tc } = do + l' <- Rename.addType l (lidUnique (jname (tcName tc))) + return TypEn { enName = l', enTyCon = tc } + each ModEn { enModName = u, enEnts = es } = do + (u', es') <- Rename.addMod u $ renameMapM each es + return ModEn { enModName = u', enEnts = es' } + +-- | Build the dynamic environment +basis2venv :: Monad m => [Entry Renamed] -> m E +basis2venv es = foldM add genEmpty es where + add :: Monad m => E -> Entry Renamed -> m E + add e (ValEn { enName = n, enValue = v }) + = return (Dynamics.addVal e n v) + add e (ModEn { enModName = n, enEnts = es' }) + = Dynamics.addMod e n `liftM` basis2venv es' + add e _ = return e + +-- | Build the static environment +basis2tenv :: Monad m => [Entry Renamed] -> m S +basis2tenv = liftM snd . runTC env0 . tcMapM each where + each ValEn { enName = n, enType = t } + = Statics.addVal n t + each DecEn { enSrc = decl } + = Statics.addDecl decl + each TypEn { enName = n, enTyCon = i } + = Statics.addType n i + each ModEn { enModName = n, enEnts = es } + = Statics.addMod n $ tcMapM each es + diff --git a/src/Coercion.hs b/src/Coercion.hs new file mode 100644 --- /dev/null +++ b/src/Coercion.hs @@ -0,0 +1,135 @@ +-- | Converts coercion expressions to dynamic checks. +{-# LANGUAGE + PatternGuards, + QuasiQuotes, + ViewPatterns #-} +module Coercion ( + coerceExpression, + translate, translateDecls, TEnv, tenv0 +) where + +import Loc +import Meta.Quasi +import Ppr () +import qualified Syntax +import qualified Syntax.Expr +import qualified Syntax.Notable +import qualified Syntax.Patt +import Syntax hiding (Type, Type'(..)) +import Type +import TypeRel () +import Util + +import qualified Data.Map as M +import qualified Control.Monad.State as CMS + +-- | The translation environment. This currently doesn't carry +-- any information, but we keep it in the interface for later use. +type TEnv = () + +-- | The initial translation environment +tenv0 :: TEnv +tenv0 = () + +-- | Translate a whole program +translate :: TEnv -> Prog Renamed -> Prog Renamed +translate _ = id + +-- | Location to use for constructed code +_loc :: Loc +_loc = mkBogus "" + +-- | Translation a sequence of declarations in the context +-- of a translation environment, returning a new translation +-- environment +translateDecls :: TEnv -> [Decl Renamed] -> (TEnv, [Decl Renamed]) +translateDecls tenv decls = (tenv, decls) + +coerceExpression :: Monad m => + Expr Renamed -> Type -> Type -> m (Expr Renamed) +coerceExpression e tfrom tto = do + prj <- CMS.evalStateT (build True M.empty tfrom tto) 0 + return $ exApp (exApp prj (exPair (exStr neg) (exStr pos))) e + where + neg = "context at " ++ show (getLoc e) + pos = "value at " ++ show (getLoc e) + +build :: Monad m => + Bool -> M.Map (TyVarR, TyVarR) (Maybe (Lid Renamed)) -> + Type -> Type -> CMS.StateT Integer m (Expr Renamed) +build b recs tfrom tto + | (tvs, TyFun qd t1 t2) <- vtQus Forall tfrom, + (tvs', TyFun qd' t1' t2') <- vtQus Forall tto, + length tvs == length tvs' + = do + let which = case (qConstBound qd, qConstBound qd') of + (Qa, Qu) -> [$ex|+ INTERNALS.Contract.affunc |] + (Qu, _ ) -> [$ex|+ INTERNALS.Contract.func[U] |] + (_ , Qa) -> [$ex|+ INTERNALS.Contract.func[A] |] + recs' = foldr2 + M.insert + (shadow tvs tvs' recs) + (zip tvs tvs') + (repeat Nothing) + dom <- build (not b) recs' t1' t1 + cod <- build b recs' t2 t2' + let body = [$ex|+ $which $dom $cod |] + return $ if null tvs + then body + else absContract $ + exAbsVar' (lid "f") (typeToStx tfrom) $ + foldr (\tv0 acc -> exTAbs tv0 . acc) id tvs $ + exAbsVar' (lid "x") (typeToStx t1') $ + instContract body `exApp` + foldl (\acc tv0 -> exTApp acc (Syntax.tyVar tv0)) + (exBVar (lid "f")) tvs `exApp` + exBVar (lid "x") +build b recs (view -> TyQu Exists tv t) (view -> TyQu Exists tv' t') = do + let recs' = M.insert (tv, tv') Nothing (shadow [tv] [tv'] recs) + body <- build b recs' t t' >>! instContract + let tv'' = freshTyVar tv (ftv (tv, tv')) + return $ + absContract $ + [$ex|+ fun (Pack('$tv'', e) : ex '$tv. $stx:t) -> + Pack[ex '$tv'. $stx:t']('$tv'', $body e) |] +build b recs (view -> TyMu tv t) (view -> TyMu tv' t') = do + l <- freshLid + let recs' = M.insert (tv, tv') (Just l) (shadow [tv] [tv'] recs) + body <- build b recs' t t' + return $ + [$ex|+ + let rec $lid:l + (parties : string * string) + : (mu '$tv. $stx:t) -> mu '$tv'. $stx:t' + = $body parties + in $lid:l + |] +build b recs (view -> TyVar tv) (view -> TyVar tv') + | Just (Just l) <- M.lookup (if b then (tv, tv') else (tv', tv)) recs + = return [$ex|+ $lid:l |] + | Just Nothing <- M.lookup (if b then (tv, tv') else (tv', tv)) recs + = return [$ex|+ INTERNALS.Contract.any ['$tv'] |] +build _ _ t t' = + if t <: t' + then return [$ex|+ INTERNALS.Contract.any [$stx:t'] |] + else fail $ "type error: no coercion from " ++ show t ++ " to " ++ show t' + -- ++ "\n" ++ show recs + +shadow :: [TyVarR] -> [TyVarR] -> + M.Map (TyVarR, TyVarR) a -> M.Map (TyVarR, TyVarR) a +shadow tvs tvs' = M.filterWithKey + (\(tv, tv') _ -> tv `notElem` tvs && tv' `notElem` tvs') + +absContract :: Expr Renamed -> Expr Renamed +absContract body = + [$ex|+ fun (neg: string, pos: string) -> $body |] + +instContract :: Expr Renamed -> Expr Renamed +instContract con = [$ex|+ $con (neg, pos) |] + +freshLid :: Monad m => CMS.StateT Integer m (Lid Renamed) +freshLid = do + n <- CMS.get + CMS.put (n + 1) + return (lid ("c" ++ show n)) + diff --git a/src/Dynamics.hs b/src/Dynamics.hs new file mode 100644 --- /dev/null +++ b/src/Dynamics.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE + FlexibleInstances, + MultiParamTypeClasses, + QuasiQuotes, + TemplateHaskell #-} +-- | The dynamics of the interpreter +module Dynamics ( + -- * Static API + E, addVal, addMod, NewValues, + -- * Dynamic API + eval, addDecls, Result, + -- * Re-export to remove warning (!) + -- | We need to import Quasi for the TH phase, but using it at the + -- TH phase isn't sufficient to prevent an unused import warning. + module Meta.Quasi +) where + +import Meta.Quasi +import Value +import Util +import Syntax +import qualified Syntax.Decl +import qualified Syntax.Expr +import qualified Syntax.Notable +import qualified Syntax.Patt +import Env +import Ppr (Ppr(..), Doc, text, precApp) + +import Data.IORef (newIORef, readIORef, writeIORef) +import Control.Exception (throw) + +-- +-- Our semantic domains +-- + +-- | The kind of identifiers used +type R = Renamed + +-- | The result of a computation +type Result = IO Value + +-- | The run-time environment is a stack of scopes which are, for our +-- purposes, abstract. The interface merely allows us to bind new +-- values and modules in the top scope. +type E = [Scope] +-- | Each scope binds paths of uppercase identifiers to flat value +-- and exn environments +type Scope = PEnv (Uid R) Level +-- | A level binds values and exceptions +data Level = Level { + vlevel :: !VE + } +-- | We bind 'IO' 'Value's rather than values, so that we can use +-- 'IORef' to set up recursion +type VE = Env (Lid R) (IO Value) + +-- | To distinguish exn names from path components. +newtype ExnName = ExnName (Uid R) + deriving (Eq, Ord) + +instance GenEmpty Level where + genEmpty = Level empty +instance GenLookup Level (Lid R) (IO Value) where + level =..= k = vlevel level =..= k +instance GenExtend Level Level where + Level ve =+= Level ve' = Level (ve =+= ve') +instance GenExtend Level (Env (Lid R) (IO Value)) where + level =+= ve' = level =+= Level ve' + +-- | Domain for the meaning of an expression: +type D = E -> Result +-- | Domain for the meaning of a declaration: +type DDecl = E -> IO E + +(=:!=) :: Ord v => v -> a -> Env v (IO a) +(=:!=) = (=::=) + +infix 6 =:!= + +-- +-- Evaluation +-- + +evalDecls :: [Decl R] -> DDecl +evalDecls = (flip . foldM . flip) evalDecl + +evalDecl :: Decl R -> DDecl +evalDecl [$dc| let $x : $opt:_ = $e |] = evalLet x e +evalDecl [$dc| type $list:_ |] = return +evalDecl [$dc| abstype $list:_ with $list:ds end |] = evalDecls ds +evalDecl [$dc| open $b |] = evalOpen b +evalDecl [$dc| module $uid:n = $b |] = evalMod n b +evalDecl [$dc| module type $uid:_ = $_ |] = return +evalDecl [$dc| local $list:d0 with $list:d1 end |] = evalLocal d0 d1 +evalDecl [$dc| exception $uid:n of $opt:mt |] = evalExn n mt +evalDecl [$dc| $anti:a |] = $antifail + +evalLet :: Patt R -> Expr R -> DDecl +evalLet x e env = do + v <- valOf e env + case bindPatt x v env of + Just env' -> return env' + Nothing -> throwPatternMatch v [show x] env + +evalOpen :: ModExp R -> DDecl +evalOpen b env = do + e <- evalModExp b env + return (env =+= e) + +evalMod :: Uid R -> ModExp R -> DDecl +evalMod x b env = do + e <- evalModExp b env + return (env =+= x =:= e) + +evalLocal :: [Decl R] -> [Decl R] -> DDecl +evalLocal ds ds' env0 = do + env1 <- evalDecls ds (genEmpty:env0) + scope:_:env2 <- evalDecls ds' (genEmpty:env1) + return (env2 =+= scope) + +evalModExp :: ModExp R -> E -> IO Scope +evalModExp [$me| struct $list:ds end |] env = do + scope:_ <- evalDecls ds (genEmpty:env) + return scope +evalModExp [$me| $quid:n $list:_ |] env = do + case env =..= n of + Just scope -> return scope + Nothing -> fail $ "BUG! Unknown module: " ++ show n +evalModExp [$me| $me1 : $_ |] env = do + evalModExp me1 env +evalModExp [$me| $anti:a |] _ = $antifail + +evalExn :: Uid R -> Maybe (Type R) -> DDecl +evalExn _ _ env = return env + +eval :: E -> Prog R -> Result +eval env0 [$prQ| $list:ds in $e0 |] = evalDecls ds env0 >>= valOf e0 +eval env0 [$prQ| $list:ds |] = evalDecls ds env0 >> return (vinj ()) + +-- The meaning of an expression +valOf :: Expr R -> D +valOf e env = case e of + [$ex| $id:ident |] -> case view ident of + Left x -> case env =..= x of + Just v -> v + Nothing -> fail $ "BUG! unbound identifier: " ++ show x + Right c -> return (VaCon (jname c) Nothing) + [$ex| $str:s |] -> return (vinj s) + [$ex| $int:z |] -> return (vinj z) + [$ex| $flo:f |] -> return (vinj f) + [$ex| $antiL:a |] -> $antifail + [$ex| match $e1 with $list:clauses |] -> do + v1 <- valOf e1 env + let loop (N _ (CaClause xi ei):rest) = case bindPatt xi v1 env of + Just env' -> valOf ei env' + Nothing -> loop rest + loop [] = throwPatternMatch v1 + (map (show . capatt . dataOf) clauses) env + loop (N _ (CaAnti a):_) = $antifail + loop clauses + [$ex| let rec $list:bs in $e2 |] -> do + let extend (envI, rs) (N _ b) = do + r <- newIORef (fail "Accessed let rec binding too early") + return (envI =+= bnvar b =:= join (readIORef r), r : rs) + (env', rev_rs) <- foldM extend (env, []) bs + zipWithM_ + (\r (N _ b) -> do + v <- valOf (bnexpr b) env' + writeIORef r (return v)) + (reverse rev_rs) + bs + valOf e2 env' + [$ex| let $decl:d in $e2 |] -> do + env' <- evalDecl d env + valOf e2 env' + [$ex| ($e1, $e2) |] -> do + v1 <- valOf e1 env + v2 <- valOf e2 env + return (vinj (v1, v2)) + [$ex| fun $x : $_ -> $e' |] -> + return (VaFun (FNAnonymous [pprPrec (precApp + 1) e]) + (\v -> bindPatt x v env >>= valOf e')) + [$ex| $e1 $e2 |] -> do + v1 <- valOf e1 env + v2 <- valOf e2 env + case v1 of + VaFun n f -> f v2 >>! nameApp n (pprPrec (precApp + 1) v2) + VaCon c _ -> return (VaCon c (Just v2)) + _ -> fail $ "BUG! applied non-function " ++ show v1 + ++ " to argument " ++ show v2 + [$ex| fun '$_ -> $e1 |] -> valOf e1 env + [$ex| $e1 [$_] |] -> valOf e1 env + [$ex| Pack[$opt:_]($_, $e1) |] -> valOf e1 env + [$ex| ( $e1 : $_ ) |] -> valOf e1 env + [$ex| ( $e1 :> $_ ) |] -> valOf e1 env + [$ex| $anti:a |] -> $antifail + +bindPatt :: Monad m => Patt R -> Value -> E -> m E +bindPatt x0 v env = case x0 of + [$pa| _ |] + -> return env + [$pa| $lid:l |] + -> return (env =+= l =:!= (l `nameFun` v)) + [$pa| $quid:qu $opt:mx |] + -> let u = jname qu in + case (mx, v) of + (Nothing, VaCon u' Nothing) | u == u' -> return env + (Just x, VaCon u' (Just v')) | u == u' -> bindPatt x v' env + _ -> perr + [$pa| ($x, $y) |] + -> case vprjM v of + Just (vx, vy) -> bindPatt x vx env >>= bindPatt y vy + Nothing -> perr + [$pa| $str:s |] + -> if v == vinj s + then return env + else perr + [$pa| $int:z |] + -> if v == vinj z + then return env + else perr + [$pa| $float:f |] + -> if v == vinj f + then return env + else perr + [$pa| Pack('$_, $x) |] + -> bindPatt x v env + [$pa| $x as $lid:l |] + -> do + env' <- bindPatt x v env + return (env' =+= l =:!= v) + [$pa| $anti:a |] + -> antifail "dynamics" a + [$pa| $antiL:a |] + -> antifail "dynamics" a + where perr = fail $ + "Pattern match failure: " ++ show x0 ++ + " does not match " ++ show v + +throwPatternMatch :: Value -> [String] -> E -> IO a +throwPatternMatch v ps _ = + throw VExn { + exnValue = VaCon (uid "PatternMatch") (Just (vinj (show v, ps))) + } + +--- +--- helpful stuff +--- + +-- Add the given name to an anonymous function +nameFun :: Lid R -> Value -> Value +nameFun (Lid r x) (VaFun (FNAnonymous _) lam) + | x /= "it" || not (isTrivial r) = VaFun (FNNamed (text x)) lam +nameFun _ value = value + +-- Get the name of an applied function +nameApp :: FunName -> Doc -> Value -> Value +nameApp fn arg (VaFun (FNAnonymous _) lam) + = VaFun (FNAnonymous (funNameDocs fn ++ [ arg ])) lam +nameApp _ _ value = value + +collapse :: E -> Scope +collapse = foldr (flip (=+=)) genEmpty + +-- Public API + +-- | For printing in the REPL, 'addDecls' returns an environment +-- mapping any newly bound names to their values +type NewValues = Env (Lid R) Value + +-- | Interpret declarations by adding to the environment, potentially +-- with side effects +addDecls :: E -> [Decl R] -> IO (E, NewValues) +addDecls env decls = do + env' <- evalDecls decls (genEmpty : [collapse env]) + let PEnv _ level : _ = env' + vl' <- mapValsM id (vlevel level) + return (env', vl') + +-- | Bind a name to a value +addVal :: E -> Lid R -> Value -> E +addVal e n v = e =+= n =:= (return v :: IO Value) + +-- | Bind a name to a module, which is represented as a nested +-- environment +addMod :: E -> Uid R -> E -> E +addMod e n e' = e =+= n =:= collapse e' + diff --git a/src/Env.hs b/src/Env.hs new file mode 100644 --- /dev/null +++ b/src/Env.hs @@ -0,0 +1,433 @@ +-- | Flat, deep, and generalized environments +{-# LANGUAGE + DeriveDataTypeable, + FlexibleInstances, + FunctionalDependencies, + MultiParamTypeClasses, + OverlappingInstances, + ScopedTypeVariables, + TypeOperators, + UndecidableInstances #-} +module Env ( + -- * Basic type and operations + Env(unEnv), + -- ** Key subsumption + (:>:)(..), + -- ** Constructors + empty, (-:-), (-::-), + (-:+-), (-+-), (-\-), (-\\-), (-|-), + -- ** Destructors + isEmpty, (-.-), + -- ** Higher-order constructors + unionWith, unionSum, unionProduct, + -- ** Higher-order destructors + mapVals, mapValsM, mapAccum, mapAccumM, + -- ** List conversions + toList, fromList, domain, range, + + -- * Deep environments + PEnv(..), Path(..), ROOT(..), (<.>), + + -- * Generalized environments + GenEmpty(..), + GenExtend(..), (=++=), GenModify(..), GenRemove(..), + GenLookup(..), + + -- * Aliases (why?) + (=:=), (=::=), (=:+=) +) where + +import Util +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Generics (Typeable, Data) +import Data.Monoid + +infix 6 -:-, -::-, -:+- +infixl 6 -.- +infixr 5 -+- +infixl 5 -\-, -\\-, -|- + +-- | The basic type, mapping keys @k@ to values @v@ +newtype Env k v = Env { unEnv:: M.Map k v } + deriving (Eq, Typeable, Data) + +-- | Key subsumption. Downside: keys sometimes need to be +-- declared. Upside: we can use shorter keys that embed into +-- larger keyspaces. +class (Ord x, Ord y) => x :>: y where + liftKey :: y -> x + liftEnv :: Env y v -> Env x v + liftEnv (Env m) = Env (M.mapKeys liftKey m) + +-- | Every ordered type is a key, reflexively +instance Ord k => (:>:) k k where + liftKey = id + liftEnv = id + +-- | The empty environment +empty :: Env k v +empty = Env M.empty + +-- | Is this an empty environment? +isEmpty :: Env k v -> Bool +isEmpty = M.null . unEnv + +-- | Create a singleton environment +(-:-) :: Ord k => k -> v -> Env k v +k -:- v = Env (M.singleton k v) + +-- | Monadic bind creates a singleton environment whose value is +-- monadic, given a pure value +(-::-) :: (Monad m, Ord k) => k -> v -> Env k (m v) +k -::- v = k -:- return v + +-- | "Closure bind" ensures that every element of the range maps to +-- itself as well. (This is good for substitutions.) +(-:+-) :: Ord k => k -> k -> Env k k +k -:+- k' = k -:- k' -+- k' -:- k' + +-- | Union (right preference) +(-+-) :: (k :>: k') => Env k v -> Env k' v -> Env k v +m -+- n = m `mappend` liftEnv n + +-- | Remove a binding +(-\-) :: (k :>: k') => Env k v -> k' -> Env k v +m -\- y = Env (M.delete (liftKey y) (unEnv m)) + +-- | Difference, removing a set of keys +(-\\-) :: (k :>: k') => Env k v -> S.Set k' -> Env k v +m -\\- ys = Env (S.fold (M.delete . liftKey) (unEnv m) ys) + +-- | Lookup +(-.-) :: (k :>: k') => Env k v -> k' -> Maybe v +m -.- y = M.lookup (liftKey y) (unEnv m) + +-- | Intersection +(-|-) :: (k :>: k') => Env k v -> Env k' w -> Env k (v, w) +m -|- n = Env (M.intersectionWith (,) (unEnv m) (unEnv (liftEnv n))) + +-- | Union, given a combining function +unionWith :: (k :>: k') => (v -> v -> v) -> + Env k v -> Env k' v -> Env k v +unionWith f e e' = Env (M.unionWith f (unEnv e) (unEnv (liftEnv e'))) + +-- | Additive union (right preference) +unionSum :: (k :>: k') => Env k v -> Env k' w -> Env k (Either v w) +unionSum e e' = fmap Left e -+- fmap Right e' + +-- | Multiplicative union +unionProduct :: (k :>: k') => Env k v -> Env k' w -> Env k (Maybe v, Maybe w) +unionProduct m n = Env (M.unionWith combine m' n') where + m' = fmap (\v -> (Just v, Nothing)) (unEnv m) + n' = fmap (\w -> (Nothing, Just w)) (unEnv (liftEnv n)) + combine (mv, _) (_, mw) = (mv, mw) + +infix 5 `unionSum`, `unionProduct` + +instance Ord k => Functor (Env k) where + fmap f = Env . M.map f . unEnv + +-- | Map over the values of an environment +mapVals :: Ord k => + (v -> w) -> Env k v -> Env k w +mapVals f = Env . M.map f . unEnv + +-- | Map over the values of an environment (monadic) +mapValsM :: (Ord k, Monad m) => + (v -> m w) -> Env k v -> m (Env k w) +mapValsM f = liftM snd . mapAccumM (\v _ -> (,) () `liftM` f v) () + +-- | Map over an environment, with an opportunity to maintain an +-- accumulator +mapAccum :: Ord k => (v -> a -> (a, w)) -> a -> Env k v -> (a, Env k w) +mapAccum f z m = case M.mapAccum (flip f) z (unEnv m) of + (w, m') -> (w, Env m') + +-- | Map over an environment, with an opportunity to maintain an +-- accumulator (monadic) +mapAccumM :: (Ord k, Monad m) => + (v -> a -> m (a, w)) -> a -> Env k v -> m (a, Env k w) +mapAccumM f z m = do + (a, elts) <- helper z [] (M.toAscList (unEnv m)) + return (a, Env (M.fromDistinctAscList (reverse elts))) + where + helper a acc [] = return (a, acc) + helper a acc ((k, v):rest) = do + (a', w) <- f v a + helper a' ((k, w) : acc) rest + +-- | Get an association list +toList :: Ord k => Env k v -> [(k, v)] +toList = M.toList . unEnv + +-- | Make an environment from an association list +fromList :: Ord k => [(k, v)] -> Env k v +fromList = Env . M.fromList + +-- | The keys +domain :: Ord k => Env k v -> [k] +domain = M.keys . unEnv + +-- | The values +range :: Ord k => Env k v -> [v] +range = M.elems . unEnv + +instance Ord k => Monoid (Env k v) where + mempty = empty + mappend m n = Env (M.unionWith (\_ v -> v) (unEnv m) (unEnv n)) + +instance (Ord k, Show k, Show v) => Show (Env k v) where + showsPrec _ env = foldr (.) id + [ shows k . (" : "++) . shows v . ('\n':) + | (k, v) <- M.toList (unEnv env) ] + +(=:=) :: Ord k => k -> v -> Env k v +(=::=) :: (Ord k, Monad m) => k -> v -> Env k (m v) +(=:+=) :: Ord k => k -> k -> Env k k +(=:=) = (-:-) +(=::=) = (-::-) +(=:+=) = (-:+-) + +infix 6 =:=, =::=, =:+= +infixl 6 =.=, =..= +infixr 5 =+=, =++= +infixl 5 =\=, =\\= + +instance (k :>: k') => GenExtend (Env k v) (Env k' v) where (=+=) = (-+-) +instance Ord k => GenRemove (Env k v) k where (=\=) = (-\-) +instance (k :>: k') => GenLookup (Env k v) k' v where (=..=) = (-.-) +instance (k :>: k') => GenModify (Env k v) k' v where + genModify e k fv = case e =..= k of + Nothing -> e + Just v -> e =+= k -:- fv v +instance GenEmpty (Env k v) where genEmpty = empty + +-- | A path environment maps paths of @p@ components to @e@. +data PEnv p e = PEnv { + -- | Nested path environments + envenv :: Env p (PEnv p e), + -- | The top level flat environment + valenv :: e + } + deriving (Show, Typeable, Data) + +-- | A path of @p@ components with final key type @k@ +data Path p k = J { + jpath :: [p], + jname :: k + } + deriving (Eq, Ord, Typeable, Data) + +-- | Add a qualifier to the front of a path +(<.>) :: p -> Path p k -> Path p k +p <.> J ps k = J (p:ps) k + +infixr 8 <.> + +-- | Newtype for selecting instances operations that operate at the root +newtype ROOT e = ROOT { unROOT :: e } + deriving (Eq, Ord, Show, Typeable, Data) + +-- Utility instances + +instance Ord p => Functor (PEnv p) where + fmap f (PEnv envs vals) = PEnv (fmap (fmap f) envs) (f vals) + +instance (Show p, Show k) => Show (Path p k) where + showsPrec _ (J ps k) = foldr (\p r -> shows p . ('.':) . r) (shows k) ps + +instance Functor (Path p) where + fmap f (J p k) = J p (f k) + +instance Functor ROOT where + fmap f (ROOT x) = ROOT (f x) + +instance Monad ROOT where + return = ROOT + ROOT x >>= f = f x + +-- Some structural rules: + +instance GenLookup e k v => GenLookup (Maybe e) k v where + Just e =..= k = e =..= k + Nothing =..= _ = Nothing + +instance GenLookup e k v => GenLookup [e] k v where + es =..= k = foldr (\e r -> maybe r Just (e =..= k)) Nothing es + +instance (GenEmpty e, GenExtend e e') => GenExtend [e] e' where + (e:es) =+= e' = (e =+= e') : es + [] =+= e' = [ (genEmpty :: e) =+= e' ] + +instance GenEmpty e => GenEmpty [e] where + genEmpty = [genEmpty] + +instance GenRemove e k => GenRemove [e] k where + e =\= k = map (=\= k) e + +-- | A generalization of environment union. If the environments +-- have different types, we assume the right type may be lifted +-- to the left types. +-- +-- We can extend a nested env with +-- +-- * some subenvs +-- +-- * a value env +-- +-- * another nested env (preferring the right) +-- +-- * '(=++=)' pathwise-unions subenvs rather than replacing +class GenExtend e e' where + (=+=) :: e -> e' -> e + +instance Ord p => GenExtend (PEnv p e) (Env p (PEnv p e)) where + penv =+= e = penv { envenv = envenv penv =+= e } + +instance Ord p => GenExtend (PEnv p e) (Env p e) where + penv =+= e = penv =+= fmap (PEnv (empty :: Env p (PEnv p e))) e + +instance GenExtend e e' => + GenExtend (PEnv p e) e' where + penv =+= e = penv { valenv = valenv penv =+= e } + +instance (Ord p, GenExtend e e) => + GenExtend (PEnv p e) (PEnv p e) where + PEnv es vs =+= PEnv es' vs' = PEnv (es =+= es') (vs =+= vs') + +instance (Ord p, Ord k, GenEmpty e, GenExtend e (Env k v)) => + GenExtend (PEnv p e) (Env (Path p k) v) where + penv =+= env = foldr (flip (=+=)) penv (toList env) + +instance (Ord p, Ord k, GenEmpty e, GenExtend e (Env k v)) => + GenExtend (PEnv p e) (Path p k, v) where + PEnv ee ve =+= (J ps0 k, v) = case ps0 of + [] -> PEnv ee (ve =+= k =:= v) + p:ps -> let penv' = maybe genEmpty id (ee =..= p) =+= (J ps k, v) + in PEnv (ee =+= p =:= penv') ve + +-- | tree-wise union: +(=++=) :: (Ord p, GenExtend e e) => PEnv p e -> PEnv p e -> PEnv p e +PEnv (Env m) e =++= PEnv (Env m') e' = + PEnv (Env (M.unionWith (=++=) m m')) (e =+= e') + +-- | Generalization class for lookup, where the environment and key +-- types determine the value type +-- +-- Instances allow us to lookup in a nested env by +-- +-- * one path component +-- +-- * a path +-- +-- * a path to a key +-- +-- * a path to a path component +-- +-- * one key (must wrap the environment in 'ROOT') +class GenLookup e k v | e k -> v where + (=..=) :: e -> k -> Maybe v + +instance Ord p => GenLookup (PEnv p e) p (PEnv p e) where + penv =..= p = envenv penv =..= p + +instance Ord p => GenLookup (PEnv p e) [p] (PEnv p e) where + (=..=) = foldM (=..=) + +instance Ord p => GenLookup (PEnv p e) (Path p p) (PEnv p e) where + penv =..= J ps p = penv =..= (ps++[p]) + +instance (Ord p, GenLookup e k v) => + GenLookup (PEnv p e) (Path p k) v where + penv =..= J path k = penv =..= path >>= (=.= k) + +instance GenLookup e k v => GenLookup (ROOT (PEnv p e)) k v where + ROOT penv =..= k = valenv penv =..= k + +-- alias for looking up a simple key +(=.=) :: GenLookup e k v => PEnv p e -> k -> Maybe v +(=.=) = (=..=) . ROOT + +-- | Generalization of a value update operation +-- +-- We can modify a nested env at +-- +-- * one path component +-- +-- * a path to a nested env +-- +-- * a path to an env +-- +-- * a path to a key +-- +-- * a single key (ROOT) +class GenModify e k v where + genModify :: e -> k -> (v -> v) -> e + +instance Ord p => GenModify (PEnv p e) p (PEnv p e) where + genModify penv p f = genModify penv [p] f + +instance Ord p => GenModify (PEnv p e) [p] (PEnv p e) where + genModify penv [] f = f penv + genModify penv (p:ps) f = case envenv penv =..= p of + Nothing -> penv + Just penv' -> penv =+= p =:= genModify penv' ps f + +instance Ord p => GenModify (PEnv p e) [p] e where + genModify penv path fe = genModify penv path fpenv where + fpenv :: PEnv p e -> PEnv p e + fpenv penv' = penv' { valenv = fe (valenv penv') } + +instance (Ord p, GenModify e k v) => + GenModify (PEnv p e) (Path p k) v where + genModify penv (J path k) fv = genModify penv path fe where + fe :: e -> e + fe e = genModify e k fv + +instance GenModify e k v => GenModify (ROOT (PEnv p e)) k v where + genModify (ROOT penv) k fv = ROOT (penv { valenv = fe (valenv penv) }) + where + fe :: e -> e + fe e = genModify e k fv + +-- | Generalization class for key removal +-- +-- We can remove at +-- +-- * a single path component +-- +-- * a path to a key +-- +-- * a path to a path +-- +-- * a single key (using 'ROOT') +class GenRemove e k where + (=\=) :: e -> k -> e + (=\\=) :: e -> S.Set k -> e + e =\\= set = foldl (=\=) e (S.toList set) + +instance Ord p => GenRemove (PEnv p e) p where + penv =\= p = penv { envenv = envenv penv =\= p } + +instance (Ord p, GenRemove e k) => GenRemove (PEnv p e) (Path p k) where + penv =\= J path k = genModify penv path fe where + fe :: e -> e + fe = (=\= k) + +instance Ord p => GenRemove (PEnv p e) (Path p p) where + penv =\= J path p = genModify penv path fpenv where + fpenv :: PEnv p e -> PEnv p e + fpenv = (=\= p) + +instance GenRemove e k => GenRemove (ROOT (PEnv p e)) k where + ROOT penv =\= k = ROOT (penv { valenv = valenv penv =\= k }) + +-- | Generalization of the empty environment +class GenEmpty e where + genEmpty :: e + +-- we can make empty PEnvs if we can put an empty env in it +instance GenEmpty e => GenEmpty (PEnv p e) where + genEmpty = PEnv genEmpty genEmpty + diff --git a/src/ErrorST.hs b/src/ErrorST.hs new file mode 100644 --- /dev/null +++ b/src/ErrorST.hs @@ -0,0 +1,142 @@ +-- | A semi-transactional version of the ST monad +{-# LANGUAGE + DeriveDataTypeable, + FlexibleInstances, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + RankNTypes #-} +module ErrorST ( + -- * The 'ST' monad with errors + ST, + -- ** Operations + runST, transaction, liftST, + catchError, throwError, + -- * 'STRef's + STRef, + -- ** Operations + newSTRef, newTransSTRef, readSTRef, writeSTRef, modifySTRef, + unsafeIOToST +) where + +import Control.Applicative +import Control.Monad.Error +import Control.Monad.State +import qualified Control.Monad.ST as Super +import Data.Data +import qualified Data.STRef as S + +-- | Like the 'ST' monad, but with errors and transactions. Each STRef +-- is declared to be transaction alor not. Transaction STRefs lose +-- any changes made between an exception handler and an exception +-- being thrown. +newtype ST s e a = ST { unST :: Rep s e a } + deriving (Functor, Monad, Typeable) +type Rep s e a = ErrorT e (StateT (Super.ST s ()) (Super.ST s)) a + +instance Error e => Applicative (ST s e) where + pure = return + (<*>) = ap + +instance Error e => MonadError e (ST s e) where + throwError = ST . throwError + catchError body handler = ST $ do + oldUndo <- get + put (return ()) + do res <- unST body + modify (>> oldUndo) + return res + `catchError` \e -> do + newUndo <- get + put oldUndo + liftST_ newUndo + unST (handler e) + +runST :: Error e => (forall s. ST s e a) -> Either e a +runST block = + Super.runST (evalStateT (runErrorT (unST (transaction block))) (return ())) + +-- | Run something directly in the underlying ST monad +liftST :: Error e => Super.ST s a -> ST s e a +liftST = ST . liftST_ + +transaction :: Error e => ST s e a -> ST s e a +transaction block = block `catchError` throwError + +data STRef s a + = NonTr { + getRef :: !(S.STRef s a) + } + | Trans { + getRef :: !(S.STRef s a) + } + deriving Typeable + +-- | Create a new 'STRef' whose changes survive failed transactions +newSTRef :: Error e => a -> ST s e (STRef s a) +newSTRef = liftM NonTr . ST . liftST_ . S.newSTRef + +-- | Create a new 'STRef' whose changes are reverted by failed transactions +newTransSTRef :: Error e => a -> ST s e (STRef s a) +newTransSTRef = liftM Trans . ST . liftST_ . S.newSTRef + +readSTRef :: Error e => STRef s a -> ST s e a +readSTRef = ST . liftST_ . S.readSTRef . getRef + +writeSTRef :: Error e => STRef s a -> a -> ST s e () +writeSTRef (NonTr r) a = ST . liftST_ . S.writeSTRef r $ a +writeSTRef (Trans r) a = ST $ do + old <- liftST_ (S.readSTRef r) + addUndo_ (S.writeSTRef r old) + liftST_ (S.writeSTRef r a) + +modifySTRef :: Error e => STRef s a -> (a -> a) -> ST s e () +modifySTRef (NonTr r) f = ST . liftST_ . S.modifySTRef r $ f +modifySTRef (Trans r) f = ST $ do + old <- liftST_ (S.readSTRef r) + addUndo_ (S.writeSTRef r old) + liftST_ (S.writeSTRef r (f old)) + +unsafeIOToST :: Error e => IO a -> ST s e a +unsafeIOToST = ST . liftST_ . Super.unsafeIOToST + +-- helpers + +addUndo_ :: Error e => Super.ST s () -> Rep s e () +addUndo_ = modify . (>>) + +liftST_ :: Error e => Super.ST s a -> Rep s e a +liftST_ = lift . lift + +{- +test :: IO () +test = either fail id . runST $ do + a <- newSTRef "a0" + b <- newTransSTRef "b0" + c <- newSTRef "c0" + d <- newTransSTRef "d0" + e <- newSTRef "e0" + f <- newTransSTRef "f0" + do + writeSTRef a "a1" + writeSTRef b "b1" + writeSTRef d "d1" + transaction $ do + writeSTRef c "c2" + writeSTRef d "d2" + throwError "ERROR!" + writeSTRef a "a3" + writeSTRef b "b3" + `catchError` \_ -> do + writeSTRef e "e4" + writeSTRef f "f4" + ra <- readSTRef a + rb <- readSTRef b + rc <- readSTRef c + rd <- readSTRef d + re <- readSTRef e + rf <- readSTRef f + return $ + print [(ra, "a1"), (rb, "b0"), + (rc, "c2"), (rd, "d0"), + (re, "e4"), (rf, "f4")] +-} diff --git a/src/Lexer.hs b/src/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Lexer.hs @@ -0,0 +1,226 @@ +-- | Lexer setup for parsec +module Lexer ( + -- * Identifier tokens + isUpperIdentifier, lid, uid, + + -- * Special, unreserved operators + sharpLoad, sharpInfo, + semis, bang, star, slash, plus, + lolli, arrow, funbraces, funbraceLeft, funbraceRight, + qualbox, qualboxLeft, qualboxRight, + qualU, qualA, + opP, + + -- * Token parsers from Parsec + identifier, reserved, operator, reservedOp, charLiteral, + stringLiteral, natural, integer, integerOrFloat, float, + naturalOrFloat, decimal, hexadecimal, octal, symbol, lexeme, + whiteSpace, parens, braces, angles, brackets, squares, semi, comma, + colon, dot, semiSep, semiSep1, commaSep, commaSep1 +) where + +import Prec + +import Data.Char (isUpper) +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as T + +tok :: T.TokenParser st +tok = T.makeTokenParser T.LanguageDef { + T.commentStart = "(*", + T.commentEnd = "*)", + T.commentLine = "--", + T.nestedComments = True, + T.identStart = upper <|> lower <|> oneOf "_", + T.identLetter = alphaNum <|> oneOf "_'", + T.opStart = oneOf "!$%&*+-/<=>?@^|~", + T.opLetter = oneOf "!$%&*+-/<=>?@^|~.:", + T.reservedNames = ["fun", "sigma", + "if", "then", "else", + "match", "with", "as", "_", + "try", + "local", "open", "exception", + "let", "rec", "and", "in", + "Pack", + "interface", "abstype", "end", + "module", "struct", + "sig", "val", "include", + "all", "ex", "mu", "of", + "type", "qualifier"], + T.reservedOpNames = ["|", "=", ":", ":>", "->"], + T.caseSensitive = True + } + +identifier :: CharParser st String +identifier = T.identifier tok +reserved :: String -> CharParser st () +reserved = T.reserved tok +operator :: CharParser st String +operator = T.operator tok +reservedOp :: String -> CharParser st () +reservedOp = T.reservedOp tok +charLiteral :: CharParser st Char +charLiteral = T.charLiteral tok +stringLiteral :: CharParser st String +stringLiteral = T.stringLiteral tok +natural :: CharParser st Integer +natural = T.natural tok +integer :: CharParser st Integer +integer = lexeme $ try $ do + sign <- choice [ + char '+' >> return id, + char '-' >> return negate, + return id + ] + nat <- natural + return (sign nat) +integerOrFloat :: CharParser st (Either Integer Double) +integerOrFloat = lexeme $ try $ do + sign <- choice [ + char '+' >> return id, + char '-' >> return (either (Left . negate) (Right . negate)), + return id + ] + nof <- naturalOrFloat + return (sign nof) + +float :: CharParser st Double +float = T.float tok +naturalOrFloat :: CharParser st (Either Integer Double) +naturalOrFloat = T.naturalOrFloat tok +decimal :: CharParser st Integer +decimal = T.decimal tok +hexadecimal :: CharParser st Integer +hexadecimal = T.hexadecimal tok +octal :: CharParser st Integer +octal = T.octal tok +symbol :: String -> CharParser st String +symbol = T.symbol tok +lexeme :: CharParser st a -> CharParser st a +lexeme = T.lexeme tok +whiteSpace :: CharParser st () +whiteSpace = T.whiteSpace tok +parens :: CharParser st a -> CharParser st a +parens = T.parens tok +braces :: CharParser st a -> CharParser st a +braces = T.braces tok +angles :: CharParser st a -> CharParser st a +angles = T.angles tok +brackets :: CharParser st a -> CharParser st a +brackets = T.brackets tok +squares :: CharParser st a -> CharParser st a +squares = T.squares tok +semi :: CharParser st String +semi = T.semi tok +comma :: CharParser st String +comma = T.comma tok +colon :: CharParser st String +colon = T.reservedOp tok ":" >> return ":" +dot :: CharParser st String +dot = T.dot tok +semiSep :: CharParser st a -> CharParser st [a] +semiSep = T.semiSep tok +semiSep1 :: CharParser st a -> CharParser st [a] +semiSep1 = T.semiSep1 tok +commaSep :: CharParser st a -> CharParser st [a] +commaSep = T.commaSep tok +commaSep1 :: CharParser st a -> CharParser st [a] +commaSep1 = T.commaSep1 tok + +-- | The @#load@ pragma +sharpLoad :: CharParser st () +sharpLoad = reserved "#l" <|> reserved "#load" + +-- | The @#info@ pragma +sharpInfo :: CharParser st () +sharpInfo = reserved "#i" <|> reserved "#info" + +-- | @!@, which has special meaning in let patterns +bang :: CharParser st String +bang = symbol "!" + +-- | The @-o@ type operator, which violates our other lexer rules +lolli :: CharParser st () +lolli = reserved "-o" + +-- | The @->@ type operator +arrow :: CharParser st () +arrow = reservedOp "->" + +-- | The left part of the $-[_]>$ operator +funbraceLeft :: CharParser st () +funbraceLeft = try (symbol "-[") >> return () + +-- | The right part of the $-[_]>$ operator +funbraceRight :: CharParser st () +funbraceRight = try (symbol "]>") >> return () + +funbraces :: CharParser st a -> CharParser st a +funbraces = between funbraceLeft funbraceRight + +-- | The left part of the $|[_]$ annotation +qualboxLeft :: CharParser st () +qualboxLeft = try (symbol "|[") >> return () + +-- | The right part of the $|[_]$ annotation +qualboxRight :: CharParser st () +qualboxRight = try (symbol "]") >> return () + +qualbox :: CharParser st a -> CharParser st a +qualbox = between qualboxLeft qualboxRight + +-- | @;@, @;;@, ... +semis :: CharParser st String +semis = lexeme (many1 (char ';')) + +-- | @*@, which is reserved in types but not in expressions +star :: CharParser st String +star = symbol "*" + +-- | @/@, which is reserved in types but not in expressions +slash :: CharParser st String +slash = symbol "/" + +-- | @+@, which is reserved in types but not in expressions +plus :: CharParser st String +plus = symbol "+" + +-- | Qualifier @U@ (not reserved) +qualU :: CharParser st () +qualU = reserved "U" +-- | Qualifier @A@ (not reserved) +qualA :: CharParser st () +qualA = reserved "A" + +-- | Is the string an uppercase identifier? (Special case: @true@ and +-- @false@ are consider uppercase.) +isUpperIdentifier :: String -> Bool +isUpperIdentifier "true" = True +isUpperIdentifier "false" = True +isUpperIdentifier "()" = True +isUpperIdentifier (c:_) = isUpper c +isUpperIdentifier _ = False + +-- | Lex a lowercase identifer +lid :: CharParser st String +lid = try $ do + s <- identifier + if isUpperIdentifier s + then pzero "lowercase identifier" + else return s +-- | Lex an uppercase identifer +uid :: CharParser st String +uid = try $ do + s <- identifier <|> symbol "()" + if isUpperIdentifier s + then return s + else pzero "uppercase identifier" + +-- | Accept an operator having the specified precedence +opP :: Prec -> CharParser st String +opP p = try $ do + op <- operator + if precOp op == p + then return op + else pzero + diff --git a/src/Loc.hs b/src/Loc.hs new file mode 100644 --- /dev/null +++ b/src/Loc.hs @@ -0,0 +1,216 @@ +-- | Source locations +{-# LANGUAGE + DeriveDataTypeable, + TypeFamilies #-} +module Loc ( + -- * Type and constructors + Loc(..), + initial, spanLocs, mkBogus, bogus, + -- * Destructors + isBogus, startOfLoc, endOfLoc, + + -- * Generic function for clearing source locations everywhere + scrub, + + -- * For locating things + -- ** Datatype interface + {- + Located(..), mkBogL, bogL, + -} + + -- ** Type class interface + Locatable(..), Relocatable(..), (<<@), + + -- * Interface to 'Parsec' and 'TH' source positions + toSourcePos, fromSourcePos, fromSourcePosSpan, fromTHLoc +) where + +import Data.Generics (Typeable, Data, everywhere, mkT) +import Text.ParserCombinators.Parsec.Pos +import qualified Language.Haskell.TH as TH + +-- | Source locations +data Loc = Loc { + file :: !String, + line1 :: !Int, + col1 :: !Int, + line2 :: !Int, + col2 :: !Int + } + deriving (Eq, Ord, Typeable, Data) + +-- | Construct a location spanning two locations; assumes the locations +-- are correctly ordered. +spanLocs :: Loc -> Loc -> Loc +spanLocs loc1 loc2 + | isBogus loc2 = loc1 + | isBogus loc1 = loc2 + | otherwise = + Loc (file loc1) (line1 loc1) (col1 loc1) (line2 loc2) (col2 loc2) + +-- | Get a single-point location from the start of a span +startOfLoc :: Loc -> Loc +startOfLoc loc = Loc (file loc) (line1 loc) (col1 loc) (line1 loc) (col1 loc) + +-- | Get a single-point location from the end of a span +endOfLoc :: Loc -> Loc +endOfLoc loc = Loc (file loc) (line2 loc) (col2 loc) (line2 loc) (col2 loc) + +-- | Extract a 'Parsec' source position +toSourcePos :: Loc -> SourcePos +toSourcePos loc = newPos (file loc) (line1 loc) (col1 loc) + +-- | Create from a 'Parsec' source position +fromSourcePos :: SourcePos -> Loc +fromSourcePos pos + = Loc (sourceName pos) (sourceLine pos) (sourceColumn pos) + (sourceLine pos) (sourceColumn pos) + +-- | Create a span from two 'Parsec' source positions +fromSourcePosSpan :: SourcePos -> SourcePos -> Loc +fromSourcePosSpan pos1 pos2 + = Loc (sourceName pos1) (sourceLine pos1) (sourceColumn pos1) + (sourceLine pos2) (sourceColumn pos2) + +fromTHLoc :: TH.Loc -> Loc +fromTHLoc loc = Loc (TH.loc_filename loc) + (fst (TH.loc_start loc)) + (snd (TH.loc_start loc)) + (fst (TH.loc_end loc)) + (snd (TH.loc_end loc)) + +-- | The initial location for a named source file +initial :: String -> Loc +initial = fromSourcePos . initialPos + +-- | The bogus location. +-- (Avoids need for @Maybe Loc@ and lifting) +bogus :: Loc +bogus = mkBogus "" + +-- | A named bogus location; useful to provide default locations +-- for generated code without losing real locations. +mkBogus :: String -> Loc +mkBogus s = Loc s (-1) (-1) (-1) (-1) + +-- | Is the location bogus? +isBogus :: Loc -> Bool +isBogus (Loc _ (-1) _ _ _) = True +isBogus _ = False + +-- | A value with a location attached +{- +data Located a = L { + locatedLoc :: !Loc, + locatedVal :: !a + } + deriving (Eq, Ord, Typeable, Data) + +mkBogL :: String -> a -> Located a +mkBogL = L . mkBogus + +bogL :: a -> Located a +bogL = mkBogL "" + +instance Show a => Show (Located a) where + showsPrec p = showsPrec p . locatedVal + +instance Viewable (Located a) where + type View (Located a) = a + view = locatedVal +-} + +-- | Class for types that carry source locations +class Locatable a where + getLoc :: a -> Loc + +-- | Class for types that can have their source locations updated +class Relocatable a where + setLoc :: a -> Loc -> a + +{- +instance Locatable (Located a) where + getLoc (L loc _) = loc + +instance Relocatable (Located a) where + setLoc (L _ a) loc = L loc a +-} + +instance Locatable Loc where + getLoc = id + +instance Relocatable Loc where + setLoc a b + | isBogus b = a + | otherwise = b + +instance Locatable a => Locatable (Maybe a) where + getLoc Nothing = bogus + getLoc (Just a) = getLoc a + +instance Relocatable a => Relocatable (Maybe a) where + setLoc Nothing _ = Nothing + setLoc (Just a) l = l `seq` a `seq` Just (setLoc a l) + +instance Locatable a => Locatable [a] where + getLoc = foldr spanLocs bogus . map getLoc + +instance (Locatable a, Locatable b) => Locatable (Either a b) where + getLoc (Left x) = getLoc x + getLoc (Right x) = getLoc x + +instance (Relocatable a, Relocatable b) => Relocatable (Either a b) where + setLoc (Left x) l = Left (setLoc x l) + setLoc (Right x) l = Right (setLoc x l) + +instance (Locatable a, Locatable b) => Locatable (a, b) where + getLoc (x, y) = getLoc x `spanLocs` getLoc y + +instance (Locatable a, Locatable b, Locatable c) => + Locatable (a, b, c) where + getLoc (x, y, z) = getLoc x `spanLocs` getLoc y `spanLocs` getLoc z + +instance (Locatable a, Locatable b, Locatable c, Locatable d) => + Locatable (a, b, c, d) where + getLoc (x, y, z, v) = getLoc x `spanLocs` getLoc y `spanLocs` getLoc z + `spanLocs` getLoc v + +instance (Locatable a, Locatable b, Locatable c, Locatable d, Locatable e) => + Locatable (a, b, c, d, e) where + getLoc (x, y, z, v, w) = getLoc x `spanLocs` getLoc y `spanLocs` getLoc z + `spanLocs` getLoc v `spanLocs` getLoc w + +instance Relocatable b => Relocatable (a -> b) where + setLoc f loc x = setLoc (f x) loc + +-- | Copy the source location from the second operand to the first +(<<@) :: (Relocatable a, Locatable b) => a -> b -> a +a <<@ b = setLoc a (getLoc b) + +-- | Bogosify all source locations (as far as SYB can find them) +scrub :: Data a => a -> a +scrub a = everywhere (mkT bogosify) a where + bogosify :: Loc -> Loc + bogosify = const bogus + +instance Show Loc where + showsPrec _ loc + | isBogus loc = shows (file loc) + | otherwise = + shows (file loc) . showString " (" . + showCoords . showString ")" + where + showCoords = + if line1 loc == line2 loc || col2 loc == 1 then + showString "line " . shows (line1 loc) . showString ", " . + if col1 loc == col2 loc || col2 loc == 1 then + showString "column " . shows (col1 loc) + else + showString "columns " . shows (col1 loc) . + showString "-" . shows (col2 loc) + else + showString "line " . shows (line1 loc) . + showString ", col. " . shows (col1 loc) . + showString " to line " . shows (line2 loc) . + showString ", col. " . shows (col2 loc) + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,396 @@ +-- | The main driver program, which performs all manner of unpleasant +-- tasks to tie everything together +{-# LANGUAGE CPP #-} +module Main ( + main +) where + +import Util +import Ppr (Ppr(..), (<+>), (<>), text, char, hang, ($$), nest, printDoc) +import qualified Ppr +import Parser (parse, parseInteractive, parseProg, parseGetInfo) +import Paths (findAlmsLib, findAlmsLibRel, versionString, shortenPath) +import Rename (RenameState, runRenamingM, renameDecls, renameProg, + getRenamingInfo, RenamingInfo(..)) +import Statics (tcProg, tcDecls, S, runTC, runTCNew, Module(..), + getExnParam, tyConToDec, getVarInfo, getTypeInfo, + getConInfo) +import Coercion (translate, translateDecls, TEnv, tenv0) +import Value (VExn(..), vppr) +import Dynamics (eval, addDecls, E, NewValues) +import Basis (primBasis, srcBasis) +import BasisUtils (basis2venv, basis2tenv, basis2renv) +import Syntax (Prog, Decl, TyDec, BIdent(..), prog2decls, + Ident, Raw, Renamed) +import Env (empty, (=..=)) +import Loc (isBogus, initial) + +import System.Exit (exitFailure) +import System.Environment (getArgs, getProgName, withProgName, withArgs) +import System.IO.Error (ioeGetErrorString, isUserError) +import IO (hPutStrLn, stderr) +import qualified Control.Exception as Exn + +#ifdef USE_READLINE +import qualified USE_READLINE as RL +#else +import IO (hFlush, stdout) +#endif + +data Option = Don'tExecute + | Don'tCoerce + | NoBasis + | Verbose + | Quiet + | LoadFile String + deriving Eq + +-- | The main procedure +main :: IO () +main = do + args <- getArgs + processArgs [] args $ \opts mmsrc filename -> do + (primBasis', r0) <- basis2renv primBasis + g0 <- basis2tenv primBasis' + e0 <- basis2venv primBasis' + case mmsrc of + Nothing | Quiet `notElem` opts -> hPutStrLn stderr versionString + _ -> return () + let st0 = RS r0 g0 tenv0 e0 + st1 <- if NoBasis `elem` opts + then return st0 + else findAlmsLib srcBasis >>= tryLoadFile st0 srcBasis + st2 <- foldM (\st n -> findAlmsLibRel n "." >>= tryLoadFile st n) + st1 (reverse [ name | LoadFile name <- opts ]) + maybe interactive (batch filename) mmsrc (`elem` opts) st2 + `handleExns` exitFailure + +tryLoadFile :: ReplState -> String -> Maybe String -> IO ReplState +tryLoadFile st name mfile = case mfile of + Nothing -> do + carp $ name ++ ": could not load" + return st + Just file -> loadFile st file + +loadFile :: ReplState -> String -> IO ReplState +loadFile st name = do + src <- readFile name + name' <- shortenPath name + loadString st name' src + +loadString :: ReplState -> String -> String -> IO ReplState +loadString st name src = do + case parse parseProg name src of + Left e -> fail $ show e + Right ast0 -> do + (st1, ast1) <- renaming (st, prog2decls (ast0 :: Prog Raw)) + (st2, _, ast2) <- statics False (st1, ast1) + (st3, ast3) <- translation (st2, ast2) + (st4, _) <- dynamics (st3, ast3) + return st4 + +batch :: String -> IO String -> (Option -> Bool) -> ReplState -> IO () +batch filename msrc opt st0 = do + src <- msrc + case parse parseProg filename src of + Left e -> fail $ show e + Right ast -> rename ast where + rename :: Prog Raw -> IO () + check :: Prog Renamed -> IO () + coerce :: Prog Renamed -> IO () + execute :: Prog Renamed -> IO () + + rename ast0 = do + (ast1, _) <- runRenamingM True (initial filename) + (rsRenaming st0) (renameProg ast0) + check ast1 + + check ast0 = do + ((t, ast1), _) <- runTC (rsStatics st0) (tcProg ast0) + when (opt Verbose) $ + mumble "TYPE" t + coerce ast1 + + coerce ast1 = + if opt Don'tCoerce + then execute ast1 + else do + let ast2 = translate (rsTranslation st0) ast1 + when (opt Verbose) $ + mumble "TRANSLATION" ast2 + execute ast2 + + execute ast2 = + unless (opt Don'tExecute) $ do + v <- eval (rsDynamics st0) ast2 + when (opt Verbose) $ + mumble "RESULT" v + +data ReplState = RS { + rsRenaming :: RenameState, + rsStatics :: S, + rsTranslation :: TEnv, + rsDynamics :: E +} + +renaming :: (ReplState, [Decl Raw]) -> IO (ReplState, [Decl Renamed]) +statics :: Bool -> (ReplState, [Decl Renamed]) -> + IO (ReplState, Module, [Decl Renamed]) +translation :: (ReplState, [Decl Renamed]) -> IO (ReplState, [Decl Renamed]) +dynamics :: (ReplState, [Decl Renamed]) -> IO (ReplState, NewValues) + +renaming (st, ast) = do + (ast', r') <- runRenamingM True (initial "-") + (rsRenaming st) (renameDecls ast) + return (st { rsRenaming = r' }, ast') + +statics _ (rs, ast) = do + (ast', new, s') <- runTCNew (rsStatics rs) (tcDecls ast) + return (rs { rsStatics = s' }, new, ast') + +translation (rs, ast) = do + let (menv', ast') = translateDecls (rsTranslation rs) ast + return (rs { rsTranslation = menv' }, ast') + +dynamics (rs, ast) = do + (e', new) <- addDecls (rsDynamics rs) ast + return (rs { rsDynamics = e' }, new) + +carp :: String -> IO () +carp msg = do + prog <- getProgName + hPutStrLn stderr (prog ++ ": " ++ msg) + +handleExns :: IO a -> IO a -> IO a +handleExns body handler = + (body + `Exn.catch` + \e@(VExn { }) -> do + prog <- getProgName + hPutStrLn stderr . + show $ + hang (text (prog ++ ": Uncaught exception:")) + 2 + (vppr e) + handler) + `Exn.catch` + \err -> do + hPutStrLn stderr (errorString err) + handler + +interactive :: (Option -> Bool) -> ReplState -> IO () +interactive opt rs0 = do + initialize + repl 1 rs0 + where + repl row st = do + mres <- reader row st + case mres of + Nothing -> return () + Just (row', ast) -> do + st' <- doLine st ast + `handleExns` return st + repl row' st' + doLine st ast = let + rename :: (ReplState, [Decl Raw]) -> IO ReplState + check :: (ReplState, [Decl Renamed]) -> IO ReplState + coerce :: Module -> (ReplState, [Decl Renamed]) -> IO ReplState + execute :: Module -> (ReplState, [Decl Renamed]) -> IO ReplState + display :: Module -> NewValues -> ReplState -> IO ReplState + + rename (st0, ast0) = do + renaming (st0, ast0) >>= check + + check stast0 = do + (st1, newDefs, ast1) <- statics True stast0 + coerce newDefs (st1, ast1) + + coerce newDefs stast1 + = if opt Don'tCoerce + then execute newDefs stast1 + else do + stast2 <- translation stast1 + when (opt Verbose) $ + mumbles "TRANSLATION" (snd stast2) + execute newDefs stast2 + + execute newDefs stast2 + = if opt Don'tExecute + then display newDefs empty (fst stast2) + else do + (st3, newVals) <- dynamics stast2 + display newDefs newVals st3 + + display newDefs newVals st3 + = do printResult newDefs newVals + return st3 + + in rename (st, ast) + quiet = opt Quiet + say = if quiet then const (return ()) else printDoc + get = if quiet then const (readline "") else readline + reader :: Int -> ReplState -> IO (Maybe (Int, [Decl Raw])) + reader row st = loop 1 [] + where + fixup = unlines . mapTail (" " ++) . reverse + loop count acc = do + mline <- get (if null acc then "#- " else "#= ") + case (mline, acc) of + (Nothing, []) -> return Nothing + (Nothing, (_,err):_) -> do + addHistory (fixup (map fst acc)) + hPutStrLn stderr "" + hPutStrLn stderr (show err) + reader (row + count) st + (Just line, _) -> + case parseGetInfo line of + Nothing -> + let cmd = fixup (line : map fst acc) in + case parseInteractive row cmd of + Right ast -> do + addHistory cmd + return (Just (row + count, ast)) + Left derr -> + loop (count + 1) ((line, derr) : acc) + Just ids -> do + mapM_ (printInfo st) ids + addHistory line + loop (count + 1) acc + printResult :: Module -> NewValues -> IO () + printResult md00 values = say (loop True md00) where + loop tl md0 = case md0 of + MdNil -> Ppr.empty + MdApp md1 md2 -> loop tl md1 $$ loop tl md2 + MdValue (Var l) t -> pprValue tl l t (values =..= l) + MdValue (Con u) t -> case getExnParam t of + Nothing -> Ppr.empty + Just Nothing -> text "exception"<+>ppr u + Just (Just t') -> text "exception"<+>ppr u<+>text "of"<+>ppr t' + MdTycon _ tc -> + text "type" <+> ppr (tyConToDec tc :: TyDec Renamed) + MdModule u md1 -> + text "module" <+> ppr u <+> char ':' <+> text "sig" + $$ nest 2 (loop False md1) + $$ text "end" + MdSig u md1 -> + text "module type" <+> ppr u <+> char '=' <+> text "sig" + $$ nest 2 (loop False md1) + $$ text "end" + pprValue tl x t mv = + addHang '=' (if tl then fmap ppr mv else Nothing) $ + addHang ':' (Just (ppr t)) $ + (if tl then ppr x else text "val" <+> ppr x) + addHang c m d = case m of + Nothing -> d + Just t -> hang (d <+> char c) 2 t + +printInfo :: ReplState -> Ident Raw -> IO () +printInfo st ident = case getRenamingInfo ident (rsRenaming st) of + [] -> putStrLn $ "not bound: `" ++ show ident ++ "'" + ris -> mapM_ each ris + where + each (SigAt loc x') = + mention "module type" (ppr x') Ppr.empty loc + each (ModuleAt loc x') = + mention "module" (ppr x') Ppr.empty loc + each (VariableAt loc x') = + case getVarInfo x' s of + Nothing -> mention "val" (ppr x') Ppr.empty loc + Just t -> mention "val" (ppr x') (char ':' <+> ppr t) loc + each (TyconAt loc x') = + case getTypeInfo x' s of + Nothing -> mention "type" (ppr x') Ppr.empty loc + Just tc -> mention "type" Ppr.empty (ppr tc) loc + each (DataconAt loc x') = + case getConInfo x' s of + Nothing -> mention "val" (ppr x') Ppr.empty loc + Just (Left mt) -> + mention "type" (text "exn") + (Ppr.sep [ text "= ...", + char '|' <+> ppr x' <+> + case mt of + Nothing -> Ppr.empty + Just t -> text "of" <+> ppr t ]) + loc + Just (Right tc) -> + mention "type" Ppr.empty (ppr tc) loc + -- + s = rsStatics st + -- + mention what who rhs loc = do + printDoc $ text what <+> ppr who + >?> rhs Ppr.>?> + if isBogus loc + then text " -- built-in" + else text " -- defined at" <+> text (show loc) + where (>?>) = if Ppr.isEmpty who then (<+>) else (Ppr.>?>) + +mumble :: Ppr a => String -> a -> IO () +mumble s a = printDoc $ hang (text s <> char ':') 2 (ppr a) + +mumbles :: Ppr a => String -> [a] -> IO () +mumbles s as = printDoc $ hang (text s <> char ':') 2 (Ppr.vcat (map ppr as)) + +errorString :: IOError -> String +errorString e | isUserError e = ioeGetErrorString e + | otherwise = show e + +processArgs :: [Option] -> [String] -> + ([Option] -> Maybe (IO String) -> String -> IO a) -> + IO a +processArgs opts0 args0 k = loop opts0 args0 where + loop opts [] = go "-" [] opts Nothing + loop opts ("-":args) + = go "-" args opts (Just getContents) + loop opts ("--":name:args) + = go name args opts (Just (readFile name)) + loop opts ("-l":name:r) + = loop (LoadFile name:opts) r + loop opts (('-':'l':name):r) + = loop (LoadFile name:opts) r + loop opts ("-b":r) = loop (NoBasis:opts) r + loop opts ("-x":r) = loop (Don'tExecute:opts) r + loop opts ("-c":r) = loop (Don'tCoerce:opts) r + loop opts ("-v":r) = loop (Verbose:opts) r + loop opts ("-q":r) = loop (Quiet:opts) r + loop opts (('-':c:d:e):r) + = loop opts (['-',c]:('-':d:e):r) + loop _ (('-':_):_) = usage + loop opts (name:args) = go name args opts (Just (readFile name)) + + go name args opts mmsrc = + withProgName name $ + withArgs args $ + k opts mmsrc name + +usage :: IO a +usage = do + hPutStrLn stderr "Usage: alms [OPTIONS...] [--] [FILENAME] [ARGS...]" + hPutStrLn stderr "" + hPutStrLn stderr "Options:" + hPutStrLn stderr " -l FILE Load file" + hPutStrLn stderr " -q Don't print prompt, greeting, responses" + hPutStrLn stderr "" + hPutStrLn stderr "Debugging options:" + hPutStrLn stderr " -b Don't load libbasis.alms" + hPutStrLn stderr " -c Don't add contracts" + hPutStrLn stderr " -x Don't execute" + hPutStrLn stderr " -v Verbose (show translation, results, types)" + exitFailure + +initialize :: IO () +readline :: String -> IO (Maybe String) +addHistory :: String -> IO () + +#ifdef USE_READLINE +initialize = RL.initialize +addHistory = RL.addHistory +readline = RL.readline +#else +initialize = return () +addHistory _ = return () +readline s = do + putStr s + hFlush stdout + catch (fmap Just getLine) (\_ -> return Nothing) +#endif diff --git a/src/Meta/DeriveNotable.hs b/src/Meta/DeriveNotable.hs new file mode 100644 --- /dev/null +++ b/src/Meta/DeriveNotable.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE + FlexibleInstances, + MultiParamTypeClasses, + TemplateHaskell, + TypeFamilies #-} +module Meta.DeriveNotable ( + deriveNotable +) where + +import Syntax.Notable +import Meta.THHelpers + +import Data.Char (toLower) +import Language.Haskell.TH + +data DeriveNotableRec + = DeriveNotableRec { + dnFrom :: Maybe Name, + dnBy :: Name, + dnExcept :: [Name], + dnContext :: [(Name, [Int])] + } + +class ExtDN a r where + extDN :: DeriveNotableRec -> a -> r +instance ExtDN Name (Q [Dec]) where + extDN = deriveNotableRec +instance ExtDN a r => ExtDN (Maybe Name) (a -> r) where + extDN dn mn = extDN (dn { dnFrom = mn }) +instance ExtDN a r => ExtDN Name (a -> r) where + extDN dn n = extDN (dn { dnBy = n }) +instance ExtDN a r => ExtDN [Name] (a -> r) where + extDN dn ns = extDN (dn { dnExcept = ns }) +instance (ExtDN a r, ix ~ Int) => ExtDN (Name, [ix]) (a -> r) where + extDN dn context = extDN (dn { dnContext = context : dnContext dn }) + +deriveNotable :: ExtDN a r => a -> r +deriveNotable = extDN DeriveNotableRec { + dnBy = 'newN, + dnExcept = [], + dnFrom = Nothing, + dnContext = [] +} + +deriveNotableRec :: DeriveNotableRec -> Name -> Q [Dec] +deriveNotableRec dnr toName = do + TyConI tc <- case dnFrom dnr of + Just n -> reify n + Nothing -> do + TyConI (TySynD _ _ fromType) <- reify toName + case fromType of + AppT (AppT _ (AppT _ _)) (AppT (ConT n) _) -> reify n + AppT (AppT _ (ConT n)) _ -> reify n + _ -> fail "deriveNotable: Can't find data type" + case tc of + DataD context _ tvs cons _ -> go dnr toName context tvs cons + NewtypeD context _ tvs con _ -> go dnr toName context tvs [con] + _ -> fail "deriveNotable supports data and newtype only" + +go :: DeriveNotableRec -> Name -> Cxt -> [TyVarBndr] -> [Con] -> Q [Dec] +go dnr toName context tvs cons = do + context' <- buildContext tvs (dnContext dnr) + let rtype = foldl appT (conT toName) (map typeOfTyVarBndr tvs) + quant = forallT tvs (return (context' ++ context)) + declses <- sequence [ deriveOne (dnBy dnr) quant rtype con + | con <- cons, + conName con `notElem` dnExcept dnr ] + return (concat declses) + +deriveOne :: Name -> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q [Dec] +deriveOne new quant rtype (NormalC cname params0) = do + let ptypes = map (return . snd) params0 + funName = mkName (lowerFirst (nameBase cname)) + params <- mapM (newName . const "x") params0 + prot <- sigD funName (quant (foldr (\ _tj _tr -> [t| $_tj -> $_tr |]) + rtype ptypes)) + decl <- funD funName + [ + clause (map varP params) + (normalB + (appE (varE new) + (foldl appE (conE cname) (map varE params)))) + [] + ] + return [prot, decl] +deriveOne new tvs rtype (RecC cname params) = + deriveOne new tvs rtype (NormalC cname [ (s, t) | (_, s, t) <- params ]) +deriveOne new tvs rtype (InfixC st1 cname st2) = + deriveOne new tvs rtype (NormalC cname [st1, st2]) +deriveOne new tvs rtype (ForallC _ _ con) = deriveOne new tvs rtype con + +lowerFirst :: String -> String +lowerFirst "" = "" +lowerFirst (c:cs) = toLower c : cs diff --git a/src/Meta/FileString.hs b/src/Meta/FileString.hs new file mode 100644 --- /dev/null +++ b/src/Meta/FileString.hs @@ -0,0 +1,19 @@ +module Meta.FileString ( + fileString, fileStringCheck +) where + +import Language.Haskell.TH + +fileString :: String -> ExpQ +fileString = fileStringCheck (const (return Nothing)) + +fileStringCheck :: (String -> IO (Maybe (Bool, String))) -> String -> ExpQ +fileStringCheck check file = do + (str, chk) <- runIO $ do + str <- readFile file + chk <- check str + return (str, chk) + case chk of + Nothing -> return () + Just (b, s) -> report b s + litE (stringL str) diff --git a/src/Meta/Quasi.hs b/src/Meta/Quasi.hs new file mode 100644 --- /dev/null +++ b/src/Meta/Quasi.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE + FlexibleContexts, + FlexibleInstances, + QuasiQuotes, + RankNTypes, + ScopedTypeVariables, + TemplateHaskell, + TypeSynonymInstances #-} +module Meta.Quasi ( + pa, ty, ex, dc, me, + prQ, tdQ, atQ, caQ, bnQ, qeQ, tpQ, seQ, sgQ, +) where + +import Meta.QuoteData +import Meta.THHelpers +import Parser +import Syntax +import Util + +import Data.Generics +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) + +toAstQ :: (Data a, ToSyntax b) => a -> TH.Q b +toAstQ x = whichS' (toExpQ x) (toPatQ x) + +toExpQ :: Data a => a -> TH.ExpQ +toExpQ = dataToExpQ antiExp moduleQuals + +toPatQ :: Data a => a -> TH.PatQ +toPatQ = dataToPatQ antiPat moduleQuals + +moduleQuals :: [(String, String)] +moduleQuals = [ ("Syntax.Type", "Syntax") ] + +antiExp :: Data a => a -> Maybe TH.ExpQ +antiExp = antiGen + +antiPat :: Data a => a -> Maybe TH.PatQ +antiPat = antiGen + `extQ` antiLocPat + `extQ` antiUnitPat + `extQ` antiRawPat + +antiGen :: forall a b. (Data a, ToSyntax b) => a -> Maybe (TH.Q b) +antiGen = $(expandAntibles [''Raw, ''Renamed] 'toAstQ syntaxTable) + $ const Nothing + +antiLocPat :: Loc -> Maybe TH.PatQ +antiLocPat _ = Just TH.wildP + +antiUnitPat :: () -> Maybe TH.PatQ +antiUnitPat _ = Just TH.wildP + +antiRawPat :: Raw -> Maybe TH.PatQ +antiRawPat _ = Just TH.wildP + +--- +--- Syntax helpers +--- + +mkvarE :: String -> TH.ExpQ +mkvarE = TH.varE . TH.mkName + +mkvarP :: String -> TH.PatQ +mkvarP "_" = TH.wildP +mkvarP n = TH.varP (TH.mkName n) + +--- +--- Quasiquoters +--- + +pa, ty, ex, dc, me, prQ, tdQ, atQ, caQ, bnQ, qeQ, tpQ, seQ, sgQ + :: QuasiQuoter + +ex = mkQuasi parseExpr +dc = mkQuasi parseDecl +ty = mkQuasi parseType +me = mkQuasi parseModExp +pa = mkQuasi parsePatt +prQ = mkQuasi parseProg +tdQ = mkQuasi parseTyDec +atQ = mkQuasi parseAbsTy +caQ = mkQuasi parseCaseAlt +bnQ = mkQuasi parseBinding +qeQ = mkQuasi parseQExp +tpQ = mkQuasi parseTyPat +seQ = mkQuasi parseSigExp +sgQ = mkQuasi parseSigItem + +mkQuasi :: forall stx note. + (Data (note Raw), Data (stx Raw), + LocAst (N (note Raw) (stx Raw)), + Data (note Renamed), Data (stx Renamed), + LocAst (N (note Renamed) (stx Renamed))) => + (forall i. Id i => P (N (note i) (stx i))) -> + QuasiQuoter +mkQuasi parser = QuasiQuoter qast qast where + qast s = + join $ + parseQuasi s $ \iflag lflag -> + case iflag of + Just '+' -> do + stx <- parser :: P (N (note Renamed) (stx Renamed)) + convert lflag stx + _ -> do + stx <- parser :: P (N (note Raw) (stx Raw)) + convert lflag stx + convert flag stx = return $ maybe toAstQ toLocAstQ flag (scrub stx) + +deriveLocAsts 'toAstQ syntaxTable + diff --git a/src/Meta/QuoteData.hs b/src/Meta/QuoteData.hs new file mode 100644 --- /dev/null +++ b/src/Meta/QuoteData.hs @@ -0,0 +1,79 @@ +--- +--- My verson of Language.Haskell.TH.Quote +--- +{-# LANGUAGE + RankNTypes, + RelaxedPolyRec, + PatternGuards, + ScopedTypeVariables #-} +module Meta.QuoteData (dataToExpQ, dataToPatQ) where + +import Language.Haskell.TH + +import Data.Data + +dataToQa :: forall a k q. Data a + => (Name -> k) + -> (Lit -> Q q) + -> (k -> [Q q] -> Q q) + -> (forall b . Data b => b -> Maybe (Q q)) + -> [(String, String)] + -> a + -> Q q +dataToQa mkCon mkLit appCon antiQ quals = loop where + loop :: forall b. Data b => b -> Q q + loop t = + case antiQ t of + Nothing -> + case () of + _ | Just str <- cast t -> mkLit (stringL str) + | otherwise -> + case constrRep constr of + AlgConstr _ -> + appCon con conArgs + IntConstr n -> + mkLit $ integerL n + FloatConstr n -> + mkLit $ rationalL (toRational n) + CharConstr c -> + mkLit $ charL c + where + constr :: Constr + constr = toConstr t + constrName :: Constr -> String + constrName k = + qual k $ + case showConstr k of + name@('(':',':_) -> name + '(':name -> init name + name -> name + qual :: Constr -> String -> String + qual k = + let modname = tyconModule (dataTypeName (constrType k)) in + case lookup modname quals of + Nothing -> id + Just s -> ((s ++ ".") ++) + con :: k + con = mkCon (mkName (constrName constr)) + conArgs :: [Q q] + conArgs = gmapQ loop t + + Just y -> y + +-- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the same +-- value. It takes a function to handle type-specific cases. +dataToExpQ :: Data a + => (forall b . Data b => b -> Maybe (Q Exp)) + -> [(String, String)] + -> a + -> Q Exp +dataToExpQ = dataToQa conE litE (foldl appE) + +-- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same +-- value. It takes a function to handle type-specific cases. +dataToPatQ :: Data a + => (forall b . Data b => b -> Maybe (Q Pat)) + -> [(String, String)] + -> a + -> Q Pat +dataToPatQ = dataToQa id litP conP diff --git a/src/Meta/THHelpers.hs b/src/Meta/THHelpers.hs new file mode 100644 --- /dev/null +++ b/src/Meta/THHelpers.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE + DeriveDataTypeable, + RankNTypes, + TemplateHaskell, + TypeSynonymInstances #-} +module Meta.THHelpers ( + -- * Simplified TH quasiquote + th, + -- * Generic expression/pattern AST construction + ToSyntax(..), + -- * Miscellany + buildContext, typeOfTyVarBndr, conName, +) where + +import Lexer (lid, uid) +import Util + +import Data.Generics (Typeable, Data, everything, mkQ) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Language (haskell) +import Text.ParserCombinators.Parsec.Token + +-- | A very limited Haskell abstract syntax for describing both +-- patterns and expressions +data HsAst = HsApp HsAst HsAst + | HsWild + | HsVar String + | HsCon String + | HsList [HsAst] + | HsRec String [(String, HsAst)] + | HsOr HsAst HsAst + | HsAnti String String + deriving (Show, Typeable, Data) + +-- | The quasiquoter for building TH expressions +th :: QuasiQuoter +th = QuasiQuoter qexp qpat where + qexp s = parseHs s >>= hsToExpQ + qpat _ = fail "Quasiquoter `hs' does not support patterns" + +-- | Don't allow HsOr to the left of HsApp: +hsApp :: HsAst -> HsAst -> HsAst +hsApp (HsOr hs11 hs12) hs2 = HsOr (hsApp hs11 hs2) (hsApp hs12 hs2) +hsApp hs1 hs2 = HsApp hs1 hs2 + +-- | Turn AST into a TH expression that constructs a TH expression or +-- pattern, depending on the context. +-- +-- In particular, if we parameterize TH types with the type of +-- expression they construct, hsToExpQ has the types: +-- +-- @ +-- HsAst -> ExpQ (ExpQ ???) +-- HsAst -> ExpQ (PatQ ???) +-- @ +hsToExpQ :: HsAst -> ExpQ +hsToExpQ hs0 = do + name <- newName "underscore" + expr <- loop (antiName name) hs0 + if hasUnderscore hs0 + then lam1E (varP name) (return expr) + else return expr + where + antiName def "_" = def + antiName _ name = mkName name + loop n hs = case unfoldApp hs of + (HsAnti v "th", []) -> varE (n v) + (HsAnti v "", args) -> [| varS $(varE (n v)) + $(listE (map (loop n) args)) |] + (HsAnti v "con", args) + -> [| conS $(varE (n v)) + $(listE (map (loop n) args)) |] + (HsVar str, args) -> [| varS $(litE (qstringL str)) + $(listE (map (loop n) args)) |] + (HsCon str, args) -> [| conS $(litE (qstringL str)) + $(listE (map (loop n) args)) |] + (HsWild, []) -> [| wildS |] + (HsList hss, []) -> [| listS $(listE (map (loop n) hss)) |] + (HsRec con fs, []) -> [| recS (toName $(litE (stringL con))) + $(listE + [ [| fieldS (toName $(litE (stringL lj))) + $(loop n hj) |] + | (lj, hj) <- fs ]) |] + (HsOr hs1 hs2, []) -> [| whichS $(loop n hs1) $(loop n hs2) |] + (HsAnti _ tag, _) -> fail $ "hs: unrecognized antiquote: " ++ tag + (op, _:_) -> fail $ "hs: cannot apply " ++ show op ++ + " to arguments" + (HsApp _ _, []) -> fail $ "hs: impossible!" + +-- | Qualify a string literal with +qstringL :: String -> Lit +qstringL s = stringL ("Syntax." ++ s) + +-- | Does the given AST contain an antiquote named '_'? If so, we +-- create an implicit parameter and fill it in there. +hasUnderscore :: HsAst -> Bool +hasUnderscore = everything (||) $ mkQ False check where + check (HsAnti "_" _) = True + check _ = False + +-- Allow us to use both Strings and Names where Names are expected +class Show a => ToName a where + toName :: a -> Name + nameIsWild :: a -> Bool +instance ToName Name where + toName = id + nameIsWild = (== "_") . show +instance ToName String where + toName = mkName + nameIsWild = (== "_") + +-- Generic constructors for building both patterns and expressions +class Data b => ToSyntax b where + varS :: ToName a => a -> [Q b] -> Q b + conS :: ToName a => a -> [Q b] -> Q b + listS :: [Q b] -> Q b + recS :: Name -> [Q (Name, b)] -> Q b + fieldS :: Name -> Q b -> Q (Name, b) + -- | Return the first argument in expression context and the second + -- in pattern context + whichS :: Q b -> Q b -> Q b + whichS':: Q Exp -> Q Pat -> Q b + -- | A wild card expression, interpreted as @()@ in expression + -- (strange, but often right) + wildS :: Q b + -- | Lift data, generically + dataS :: Data a => (forall c. Data c => c -> Maybe (Q b)) -> a -> Q b + +instance ToSyntax Exp where + varS = foldl appE . varE . toName + conS = foldl appE . conE . toName + listS = listE + recS = recConE + fieldS = fieldExp + whichS = const + whichS' = const + wildS = conE (mkName "()") + dataS = dataToExpQ + +instance ToSyntax Pat where + varS n [] + | nameIsWild n = wildP + | otherwise = varP (toName n) + varS n _ = fail $ "hs: pattern can't have variable head: " ++ show n + conS = conP . toName + listS = listP + recS = recP + fieldS = fieldPat + whichS = const id + whichS' = const id + wildS = wildP + dataS = dataToPatQ + +-- ! Build a type class context from a list of type class names +-- and parameter positions, given a list of binders to use +-- as parameters. +buildContext :: [TyVarBndr] -> [(Name, [Int])] -> CxtQ +buildContext = mapM . each . map typeOfTyVarBndr + where + each tvs (n, ixs) = classP n [ tvs !! ix | ix <- ixs ] + +-- Turn a type variable binder into a type +typeOfTyVarBndr :: TyVarBndr -> TypeQ +typeOfTyVarBndr (PlainTV tv) = varT tv +typeOfTyVarBndr (KindedTV tv k) = sigT (varT tv) k + +-- The name of a data constructor +conName :: Con -> Name +conName (NormalC n _) = n +conName (RecC n _) = n +conName (InfixC _ n _) = n +conName (ForallC _ _ con) = conName con + +-- Figure out the head and arguments of a curried application +unfoldApp :: HsAst -> (HsAst, [HsAst]) +unfoldApp (HsApp hs1 hs2) = second (++[hs2]) (unfoldApp hs1) +unfoldApp hs = (hs, []) + +-- Parse a string into a (very limited) Haskell AST that can be +-- interpreted as both expression and pattern +parseHs :: String -> Q HsAst +parseHs str0 = do + loc <- location + case parse (start loc) "" str0 of + Left e -> fail (show e) + Right ast -> return ast + where + start loc = do + pos <- getPosition + setPosition $ + (flip setSourceName) (loc_filename loc) $ + (flip setSourceLine) (fst (loc_start loc)) $ + (flip setSourceColumn) (snd (loc_start loc)) $ + pos + spaces + level0 <* eof + level0 = hsOr <$> level1 + <*> optionMaybe (reservedOp haskell "|" *> level1) + level1 = foldl1 hsApp <$> many1 level2 + level2 = choice + [ + HsWild <$ underscore, + HsVar <$> lid, + hsUid <$> uid + <*> optionMaybe (braces haskell + (sepBy recfield (comma haskell))), + HsList <$> brackets haskell (sepBy level0 (comma haskell)), + angles haskell (HsAnti <$> lid_ + <*> option "" (colon haskell *> + option "" lid)), + parens haskell level0 + ] + recfield = (,) <$> lid <*> (reservedOp haskell "=" *> level0) + hsUid str (Just rec) = HsRec str rec + hsUid str Nothing = HsCon str + hsOr hs1 Nothing = hs1 + hsOr hs1 (Just hs2) = HsOr hs1 hs2 + underscore = symbol haskell "_" + lid_ = lid <|> underscore + +-- | Parsec parsers are Applicatives, which lets us write slightly +-- more pleasant, non-monadic-looking parsers +instance Applicative (GenParser a b) where + pure = return + (<*>) = ap diff --git a/src/PDNF.hs b/src/PDNF.hs new file mode 100644 --- /dev/null +++ b/src/PDNF.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | Positive Disjunctive Normal Form +module PDNF ( + -- * Abstract representation + PDNF, + -- * Construction + variable, conjunct, disjunct, disjoinClause, conjoinClause, + -- * Queries + isUnsat, isValid, support, + -- ** Assignments + Assignment, satisfies, findUnsat, + -- * Resolution and substitution + assume, replace, mapVars, mapVarsM, mapReplace, mapReplaceM, + -- * To and from lists + fromLists, fromListsUnsafe, toLists, + -- * Tests + tests +) where + +import Syntax.POClass +import Util + +import Data.Generics (Typeable, Data) +import Data.List (intersperse, nub, sort) +import qualified Data.Set as S +import qualified Test.QuickCheck as QC + +-- | The type of a Positive DNF over some type 'a' +newtype PDNF a = PDNF { unPDNF :: [S.Set a] } + deriving (Typeable, Data) + +-- | Is the formula unsatisfiable? +-- O(1) +isUnsat :: PDNF a -> Bool +isUnsat = null . unPDNF + +-- | Is the formula valid? +isValid :: Eq a => PDNF a -> Bool +isValid = (== [S.empty]) . unPDNF + +-- | To update the formula to reflect an assumption about the +-- assignment for a particular variable. +assume :: Ord a => Bool -> a -> PDNF a -> PDNF a +assume True v formula = PDNF . normalize' $ + map (S.delete v) (unPDNF formula) +assume False v formula = PDNF $ + filter (S.notMember v) (unPDNF formula) + +-- | To substitute a PDNF formula for a given variable in another +-- formula. +replace :: Ord a => a -> PDNF a -> PDNF a -> PDNF a +replace v (PDNF f1) (PDNF f2) = PDNF $ + normalize' $ concatMap eachClause f2 + where + eachClause clause + | v `S.member` clause = conjoinClause' (S.delete v clause) f1 + | otherwise = [clause] + +-- | To map every variable in a formula +mapVars :: (Ord a, Ord b) => (a -> b) -> PDNF a -> PDNF b +mapVars f = PDNF . normalize' . map (S.map f) . unPDNF + +-- | To map every variable in a formula, in an arbitrary monad +mapVarsM :: (Ord a, Ord b, Monad m) => + (a -> m b) -> PDNF a -> m (PDNF b) +mapVarsM f = liftM fromLists . mapM (mapM f) . toLists' + +-- | To map every variable in a formula to a formula, possibly over +-- a different type +mapReplace :: (Ord a, Ord b) => + PDNF a -> (a -> PDNF b) -> PDNF b +mapReplace m k = bigVee [ bigWedge [ k var | var <- clause ] + | clause <- toLists' m ] + +-- | To map every variable in a formula to a formula, possibly over +-- a different type, in an arbitrary monad +mapReplaceM :: (Ord a, Ord b, Monad m) => + PDNF a -> (a -> m (PDNF b)) -> m (PDNF b) +mapReplaceM m k = liftM bigVee (mapM (liftM bigWedge . mapM k) (toLists' m)) + +-- | To construct a formula of a single variable +variable :: a -> PDNF a +variable = PDNF . return . S.singleton + +-- | To find the support of a PDNF +support :: Ord a => PDNF a -> S.Set a +support = foldr S.union S.empty . unPDNF + +-- | To construct a formula of one conjuction +conjunct :: Ord a => [a] -> PDNF a +conjunct = PDNF . return . S.fromList + +disjunct :: Ord a => [a] -> PDNF a +disjunct = PDNF . map S.singleton . nub + +instance Ord a => PO (PDNF a) where + f1 \/ f2 = PDNF $ foldr disjoinClause' (unPDNF f1) (unPDNF f2) + f1 /\ f2 = PDNF $ + normalize' [ clause1 `S.union` clause2 + | clause1 <- unPDNF f1 + , clause2 <- unPDNF f2 ] + PDNF ant <: PDNF con + = all (\clause -> any (`S.isSubsetOf` clause) con) ant + +instance Bounded (PDNF a) where + minBound = PDNF [] + maxBound = PDNF [S.empty] + +instance Ord a => Eq (PDNF a) where + f1 == f2 = compare f1 f2 == EQ + +instance Ord a => Ord (PDNF a) where + f1 `compare` f2 = toLists f1 `compare` toLists f2 + +-- | To add a clause to a formula +disjoinClause :: Ord a => [a] -> PDNF a -> PDNF a +disjoinClause c' = PDNF . disjoinClause' (S.fromList c') . unPDNF + +-- | To distribute a clause over a formula +conjoinClause :: Ord a => [a] -> PDNF a -> PDNF a +conjoinClause c' = PDNF . conjoinClause' (S.fromList c') . unPDNF + +disjoinClause' :: Ord a => S.Set a -> [S.Set a] -> [S.Set a] +disjoinClause' c' [] = [c'] +disjoinClause' c' (c:cs) = + if c' `S.isSubsetOf` c + then disjoinClause' c' cs + else if c `S.isSubsetOf` c' + then c:cs + else c:disjoinClause' c' cs + +conjoinClause' :: Ord a => S.Set a -> [S.Set a] -> [S.Set a] +conjoinClause' c' cs = map (S.union c') cs + +normalize' :: Ord a => [S.Set a] -> [S.Set a] +normalize' = foldr disjoinClause' [] + +-- | To construct a PDNF. +fromLists :: Ord a => [[a]] -> PDNF a +fromLists = foldr (\/) minBound . map conjunct + +-- | To construct a PDNF quickly, assuming that no list is a superset +-- of an other list. +fromListsUnsafe :: Ord a => [[a]] -> PDNF a +fromListsUnsafe = PDNF . map S.fromList + +-- | To construct a canonical list of lists of variables. +toLists :: Ord a => PDNF a -> [[a]] +toLists = sort . map S.toAscList . unPDNF + +toLists' :: PDNF a -> [[a]] +toLists' = map S.toList . unPDNF + +instance (Eq a, Show a) => Show (PDNF a) where + showsPrec _ pdnf + | isValid pdnf = showString "#t" + | isUnsat pdnf = showString "#f" + showsPrec p (PDNF formula) = + showParen (p > 5) $ + foldr (.) id $ + intersperse (showString " | ") + [ foldr (.) id $ + intersperse (showString " & ") $ + [ showsPrec 6 lit + | lit <- S.toList clause ] + | clause <- formula ] + +--- +--- Assignments +--- + +-- | An assignment is a map from variables to booleans, represented +-- as a list of variables to map to true, with all others mapped +-- to false. +type Assignment a = [a] + +-- | Does the given assignment satisfy the PDNF? +satisfies :: Ord a => PDNF a -> Assignment a -> Bool +satisfies pdnf vs = isValid (foldr (assume True) pdnf vs) + +-- | Find an assignment that satisfies the first PDNF but not +-- the second. +findUnsat :: Ord a => PDNF a -> PDNF a -> [Assignment a] +findUnsat (PDNF f1) (PDNF f2) = + [ S.toList clause + | clause <- f1 + , not (any (`S.isSubsetOf` clause) f2) ] + +--- +--- Tests +--- + +assignFor :: Ord a => PDNF a -> QC.Gen (Assignment a) +assignFor pdnf = + genSublist (S.toList (support pdnf)) + where + genSublist :: [a] -> QC.Gen [a] + genSublist lst = do + let den = length lst + num <- QC.choose (0, den `div` 2) + let each rest elt = do + pick <- QC.choose (1, den) + return $ if pick > num + then elt:rest + else rest + foldM each [] lst + +instance (Ord a, QC.Arbitrary a) => QC.Arbitrary (PDNF a) where + arbitrary = fromLists `fmap` QC.arbitrary + shrink = map fromLists . QC.shrink . toLists + +prop_Impl :: PDNF Int -> PDNF Int -> QC.Property +prop_Impl f1 f2 = + if f1 <: f2 then + impl f1 f2 + else if f2 <: f1 then + impl f2 f1 + else + QC.classify True "counterexample" $ + not (null (findUnsat f1 f2)) + where impl f1' f2' = + QC.classify True "implication" $ + QC.forAll (assignFor (f1' \/ f2')) $ \s -> + satisfies f1' s QC.==> satisfies f2' s + +prop_Disj :: PDNF Int -> PDNF Int -> Bool +prop_Disj f1 f2 = f1 <: f1 \/ f2 + +prop_Conj :: PDNF Int -> PDNF Int -> Bool +prop_Conj f1 f2 = f1 /\ f2 <: f1 + +prop_Replace :: PDNF Int -> Bool -> QC.Property +prop_Replace pdnf b = + QC.forAll (QC.elements (S.toList (support pdnf))) $ \v -> + replace v (if b then maxBound else minBound) pdnf == assume b v pdnf + +tests :: IO () +tests = do + QC.quickCheck prop_Replace + QC.quickCheck prop_Impl + QC.quickCheck prop_Disj + QC.quickCheck prop_Conj diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,1238 @@ +{-# LANGUAGE + PatternGuards, + ScopedTypeVariables, + TypeFamilies, + TypeSynonymInstances #-} +-- | Parser +module Parser ( + -- * The parsing monad + P, parse, + -- ** Quasiquote parsing + parseQuasi, + -- ** REPL command parsing + parseGetInfo, parseInteractive, + -- ** Parsers + parseProg, parseRepl, parseDecls, parseDecl, parseModExp, + parseTyDec, parseAbsTy, parseType, parseTyPat, + parseQExp, parseExpr, parsePatt, + parseCaseAlt, parseBinding, + parseSigExp, parseSigItem, + -- * Convenience parsers (quick and dirty) + pp, pds, pd, pme, ptd, pt, ptp, pqe, pe, px +) where + +import Util +import Paths +import Prec +import Syntax +import Sigma +import Lexer + +import qualified Data.Map as M +import qualified Language.Haskell.TH as TH +import Text.ParserCombinators.Parsec hiding (parse) +import System.IO.Unsafe (unsafePerformIO) + +data St = St { + stSigma :: Bool, + stAnti :: Bool + } + +-- | A 'Parsec' character parser, with abstract state +type P a = CharParser St a + +state0 :: St +state0 = St { + stSigma = False, + stAnti = False + } + +-- | Run a parser, given the source file name, on a given string +parse :: P a -> SourceName -> String -> Either ParseError a +parse p = runParser p state0 + +-- | Run a parser on the given string in quasiquote mode +parseQuasi :: String -> (Maybe Char -> Maybe TH.Name -> P a) -> TH.Q a +parseQuasi str p = do + setter <- TH.location >>! mkSetter + let parser = do + setter + iflag <- optionMaybe (char '+') + lflag <- choice [ + do char '@' + choice [ char '=' >> identp_no_ws >>! Just, + char '!' >> return Nothing ], + char '!' >> return Nothing, + return (Just "_loc") + ] + p iflag (fmap TH.mkName lflag) + case runParser parser state0 { stAnti = True } "" str of + Left e -> fail (show e) + Right a -> return a + where + mkSetter = setPosition . toSourcePos . fromTHLoc + +parseGetInfo :: String -> Maybe [Ident Raw] +parseGetInfo = (const Nothing ||| Just) . runParser parser state0 "-" + where + parser = finish $ + sharpInfo *> + many1 (identp + <|> fmap Var <$> qlidnatp + <|> J [] . Var . Syntax.lid <$> (operator <|> semis)) + +parseInteractive :: Id i => Int -> String -> Either ParseError [Decl i] +parseInteractive line src = parse p "-" src where + p = do + pos <- getPosition + setPosition (pos `setSourceLine` line) + optional whiteSpace + r <- replp + eof + return r + +withSigma :: Bool -> P a -> P a +withSigma = mapSigma . const + +mapSigma :: (Bool -> Bool) -> P a -> P a +mapSigma f p = do + st <- getState + setState st { stSigma = f (stSigma st) } + r <- p + setState st + return r + +getSigma :: P Bool +getSigma = stSigma `fmap` getState + +curLoc :: P Loc +curLoc = getPosition >>! fromSourcePos + +addLoc :: Relocatable a => P a -> P a +addLoc p = do + before <- getPosition + a <- p + after <- getPosition + return (a <<@ fromSourcePosSpan before after) + +class Nameable a where + (@@) :: String -> a -> a + +infixr 0 @@ + +instance Relocatable a => Nameable (P a) where + s @@ p = addLoc p s + +instance Nameable r => Nameable (a -> r) where + s @@ p = \x -> s @@ p x + +punit :: P () +punit = pure () + +delimList :: P pre -> (P [a] -> P [a]) -> P sep -> P a -> P [a] +delimList before around delim each = + choice [ + before >> choice [ + around (each `sepBy` delim), + each >>! \x -> [x] + ], + return [] + ] + +chainl1last :: P a -> P (a -> a -> a) -> P a -> P a +chainl1last each sep final = start where + start = each >>= loop + loop a = option a $ do + build <- sep + choice + [ each >>= loop . build a, + final >>= return . build a ] + +chainr1last :: P a -> P (a -> a -> a) -> P a -> P a +chainr1last each sep final = start where + start = do + a <- each + builder <- loop + return (builder a) + loop = option id $ do + build <- sep + choice + [ do + b <- each + builder <- loop + return (\a -> a `build` builder b), + do + b <- final + return (\a -> a `build` b) ] + +foldlp :: (a -> b -> a) -> P a -> P b -> P a +foldlp make start follow = foldl make <$> start <*> many follow + +-- Antiquote +antip :: AntiDict -> P Anti +antip dict = antilabels . lexeme . try $ do + char '$' "" + (s1, s2) <- (,) <$> option "" (try (option "" identp_no_ws <* char ':')) + <*> identp_no_ws + assertAnti + case M.lookup s1 dict of + Just _ -> return (Anti s1 s2) + Nothing -> unexpected $ "antiquote tag: `" ++ s1 ++ "'" + where + antilabels p = do + st <- getState + if (stAnti st) + then labels p [ "antiquote `" ++ key ++ "'" + | key <- M.keys dict, key /= "" ] + else p + +identp_no_ws :: P String +identp_no_ws = do + c <- lower <|> char '_' + cs <- many (alphaNum <|> oneOf "_'") + return (c:cs) + +-- Fail if we should not recognize antiquotes +assertAnti :: P () +assertAnti = do + st <- getState + unless (stAnti st) (unexpected "antiquote") + +-- | Parse an antiquote and inject into syntax +antiblep :: forall a. Antible a => P a +antiblep = antip (dictOf (undefined::a)) >>! injAnti + +antioptp :: Antible a => P a -> P (Maybe a) +antioptp = antioptaroundp id + +antioptaroundp :: Antible a => + (P (Maybe a) -> P (Maybe a)) -> + P a -> P (Maybe a) +antioptaroundp wrap p = wrap present <|> pure Nothing + where present = antiblep + <|> Just <$> antiblep + <|> Just <$> p + +antilist1p :: Antible a => P b -> P a -> P [a] +antilist1p sep p = antiblep + <|> sepBy1 (antiblep <|> p) sep + +-- Just uppercase identifiers +uidp :: Id i => P (Uid i) +uidp = Syntax.uid <$> Lexer.uid + <|> antiblep + "uppercase identifier" + +-- Just lowercase identifiers +lidp :: Id i => P (Lid i) +lidp = Syntax.lid <$> Lexer.lid + <|> antiblep + "lowercase identifier" + +-- Lowercase identifiers or naturals +-- - tycon declarations +lidnatp :: Id i => P (Lid i) +lidnatp = Syntax.lid <$> (Lexer.lid <|> show <$> natural) + <|> operatorp + <|> Syntax.lid <$> try (parens semis) + <|> antiblep + "type name" + +-- Just operators +operatorp :: Id i => P (Lid i) +operatorp = try (parens operator) >>! Syntax.lid + "operator name" + +-- Add a path before something +pathp :: Id i => P ([Uid i] -> b) -> P b +pathp p = try $ do + path <- many $ try $ uidp <* dot + make <- p + return (make path) + +-- Qualified uppercase identifiers: +-- - module names occurences +-- - datacons in patterns (though path is ignored) +quidp :: Id i => P (QUid i) +quidp = pathp (uidp >>! flip J) + <|> antiblep + "uppercase identifier" + +-- Qualified lowercase identifiers: +-- - module name identifier lists +qlidp :: Id i => P (QLid i) +qlidp = pathp (lidp >>! flip J) + <|> antiblep + "lowercase identifier" + +-- Qualified lowercase identifiers or naturals: +-- - tycon occurences +qlidnatp :: Id i => P (QLid i) +qlidnatp = pathp (lidnatp >>! flip J) + <|> antiblep + "type name" + +-- Lowercase identifiers and operators +-- - variable bindings +varp :: Id i => P (Lid i) +varp = lidp <|> operatorp + "variable name" + +-- Qualified lowercase identifers and operators +-- - variable occurences +-- qvarp :: Id i => P (QLid i) +-- qvarp = pathp (varp >>! flip J) + +-- Identifier expressions +identp :: Id i => P (Ident i) +identp = antiblep + <|> pathp (flip J <$> (Var <$> varp <|> Con <$> uidp)) + "identifier" + +-- Type variables +tyvarp :: Id i => P (TyVar i) +tyvarp = char '\'' *> (antiblep <|> TV <$> lidp <*> pure Qu) + <|> char '`' *> (antiblep <|> TV <$> lidp <*> pure Qa) + "type variable" + +oplevelp :: Id i => Prec -> P (Lid i) +oplevelp = ( "operator") . liftM Syntax.lid . opP + +quantp :: P Quant +quantp = Forall <$ reserved "all" + <|> Exists <$ reserved "ex" + <|> antiblep + "quantifier" + +typep :: Id i => P (Type i) +typep = typepP precStart + +typepP :: Id i => Int -> P (Type i) +typepP p = "type" @@ case () of + _ | p == precStart + -> do + tc <- tyQu <$> quantp + <|> tyMu <$ reserved "mu" + tvs <- many tyvarp + dot + t <- typepP p + return (foldr tc t tvs) + <|> typepP (p + 1) + | p == precArr + -> chainr1last + (typepP (p + 1)) + (choice + [ tyArr <$ arrow, + tyLol <$ lolli, + funbraces (tyFun <$> qExpp), + tybinopp (Right precArr) ]) + (typepP precStart) + | p == precSemi + -> chainr1last (typepP (p + 1)) + (tyBinOp <$> semis) + (typepP precStart) + | Just (Left _) <- fixities p + -> chainl1last (typepP (p + 1)) + (tybinopp (Left p)) + (typepP precStart) + | Just (Right _) <- fixities p + -> chainr1last (typepP (p + 1)) + (tybinopp (Right p)) + (typepP precStart) + | p == precApp -- this case ensures termination + -> tyarg >>= tyapp' + | p < precApp + -> typepP (p + 1) + | otherwise + -> typepP precStart + where + tyarg :: Id i => P [Type i] + tyarg = choice + [ (:[]) <$> tyatom, + parens $ antiblep <|> commaSep1 (typepP precStart) ] + -- + tyatom :: Id i => P (Type i) + tyatom = tyVar <$> tyvarp + <|> tyApp <$> qlidnatp <*> pure [] + <|> antiblep + <|> tyUn <$ qualU + <|> tyAf <$ qualA + <|> do + ops <- many1 $ addLoc $ + oplevelp (Right precBang) >>! tyApp . J [] + arg <- tyatom <|> parens (typepP precStart) + return (foldr (\op t -> op [t]) arg ops) + -- + tyapp' :: Id i => [Type i] -> P (Type i) + tyapp' [t] = option t $ do + tc <- qlidnatp + tyapp' [tyApp tc [t]] + tyapp' ts = do + tc <- qlidnatp + tyapp' [tyApp tc ts] + +tybinopp :: Id i => Prec -> P (Type i -> Type i -> Type i) +tybinopp p = try $ do + op <- oplevelp p + when (unLid op == "-") pzero + return (\t1 t2 -> tyApp (J [] op) [t1, t2]) + +progp :: Id i => P (Prog i) +progp = choice [ + do ds <- declsp + when (null ds) pzero + e <- antioptaroundp (reserved "in" `between` punit) exprp + return (prog ds e), + antioptp exprp >>! prog [] + ] + +replp :: Id i => P [Decl i] +replp = choice [ + try $ do + ds <- declsp + when (null ds) pzero + eof + return ds, + exprp >>! (prog2decls . prog [] . Just) + ] + +declsp :: Id i => P [Decl i] +declsp = antiblep <|> loop + where loop = + choice [ + do + d <- declp + ds <- loop + return (d : ds), + ( "#load") $ do + sharpLoad + name <- stringLiteral + rel <- sourceName `liftM` getPosition + let mcontents = unsafePerformIO $ do + mfile <- findAlmsLibRel name rel + gmapM readFile mfile + contents <- case mcontents of + Just contents -> return contents + Nothing -> fail $ "Could not load: " ++ name + ds <- case parse parseProg name contents of + Left e -> fail (show e) + Right p -> return (prog2decls p) + ds' <- loop + return (ds ++ ds'), + return [] + ] + +declp :: Id i => P (Decl i) +declp = "declaration" @@ choice [ + do + reserved "type" + tyDecsp >>! dcTyp, + letp, + do + reserved "open" + modexpp >>! dcOpn, + do + reserved "module" + choice [ + do + reserved "type" + n <- uidp + reservedOp "=" + s <- sigexpp + return (dcSig n s), + do + n <- uidp + asc <- option id $ do + colon + sigexpp >>! flip meAsc + reservedOp "=" + b <- modexpp >>! asc + return (dcMod n b) + ], + do + reserved "local" + ds0 <- declsp + reserved "with" + ds1 <- declsp + reserved "end" + return (dcLoc ds0 ds1), + do + reserved "abstype" + at <- absTysp + reserved "with" + ds <- declsp + reserved "end" + return (dcAbs at ds), + do + reserved "exception" + n <- uidp + t <- antioptaroundp (reserved "of" `between` punit) typep + return (dcExn n t), + antiblep + ] + +modexpp :: Id i => P (ModExp i) +modexpp = "structure" @@ foldlp meAsc body ascription where + body = choice [ + meStr <$> between (reserved "struct") (reserved "end") declsp, + meName <$> quidp + <*> option [] (antilist1p comma qlidp), + antiblep + ] + ascription = colon *> sigexpp + +sigexpp :: Id i => P (SigExp i) +sigexpp = "signature" @@ do + se <- choice [ + seSig <$> between (reserved "sig") (reserved "end") + (antiblep <|> many sigitemp), + seName <$> quidp + <*> option [] (antilist1p comma qlidp), + antiblep + ] + specs <- many $ do + reserved "with" + reserved "type" + flip sepBy1 (reserved "and") $ "signature specialization" @@ do + (tvs, tc) <- tyAppp (antiblep <|>) tyvarp (J []) qlidnatp + reservedOp "=" + t <- typep + return (\sig -> seWith sig tc tvs t) + return (foldl (flip ($)) se (concat specs)) + +sigitemp :: Id i => P (SigItem i) +sigitemp = "signature item" @@ choice [ + do + reserved "val" + n <- lidp + colon + t <- typep + return (sgVal n t), + do + reserved "type" + sgTyp <$> tyDecsp, + do + reserved "module" + choice [ + do + reserved "type" + n <- uidp + reservedOp "=" + s <- sigexpp + return (sgSig n s), + do + n <- uidp + colon + s <- sigexpp + return (sgMod n s) + ], + do + reserved "include" + sgInc <$> sigexpp, + do + reserved "exception" + n <- uidp + t <- antioptaroundp (reserved "of" `between` punit) typep + return (sgExn n t), + antiblep + ] + +tyDecsp :: Id i => P [TyDec i] +tyDecsp = antilist1p (reserved "and") tyDecp + +tyDecp :: Id i => P (TyDec i) +tyDecp = "type declaration" @@ addLoc $ choice + [ antiblep + , do + optional (reservedOp "|") + tp <- typatp + (name, ps) <- checkHead tp + case checkTVs ps of + Just (True, tvs, arity) -> + reservedOp "=" *> + (tdDat name tvs <$> altsp + <|> tryTySyn name ps) + <|> tdAbs name tvs arity <$> qualsp + Just (_, tvs, arity) -> + reservedOp "=" *> tryTySyn name ps + <|> tdAbs name tvs arity <$> qualsp + Nothing -> + reservedOp "=" *> tryTySyn name ps + ] + where + tryTySyn name ps = do + t <- typep + alts <- many $ do + reservedOp "|" + tp <- typatp + (name', ps') <- checkHead tp + unless (name == name') $ + unexpected $ + "non-matching type operators `" ++ show name' ++ + "' and `" ++ show name ++ "' in type pattern" + reservedOp "=" + ti <- typep + return (ps', ti) + return (tdSyn name ((ps,t):alts)) + -- + checkHead tp = case dataOf tp of + TpApp (J [] name) ps -> return (name, ps) + TpApp _ _ -> unexpected "qualified identifier" + TpVar _ _ -> unexpected "type variable" + TpAnti _ -> unexpected "antiquote" + -- + checkTVs [] = return (True, [], []) + checkTVs (N _ (TpVar tv var):rest) = do + (b, tvs, vars) <- checkTVs rest + return (b && var == Invariant, tv:tvs, var:vars) + checkTVs _ = Nothing + +tyAppp :: Id i => (P [a] -> P [a]) -> P a -> (Lid i -> b) -> P b -> P ([a], b) +tyAppp wrap param oper suffix = choice [ + do + l <- oplevelp (Right precBang) + p1 <- param + return ([p1], oper l), + try $ do + p1 <- param + n <- choice [ semis, operator ] + when (n == "-" || precOp n == Right precBang) pzero + p2 <- param + return ([p1, p2], oper (Syntax.lid n)), + do + ps <- wrap (delimList punit parens comma param) + name <- suffix + return (ps, name) + ] + +tyProtp :: Id i => P ([(Variance, TyVar i)], Lid i) +tyProtp = tyAppp id paramVp id lidnatp + +typatp :: Id i => P (TyPat i) +typatp = typatpP precStart + +typatpP :: Id i => Int -> P (TyPat i) +typatpP p = "type pattern" @@ case () of + _ | p == precSemi + -> chainr1last (typatpP (p + 1)) + (tpBinOp . J [] . Syntax.lid <$> semis) + (typatpP precStart) + | Just (Left _) <- fixities p + -> chainl1last (typatpP (p + 1)) + (tpBinOp . J [] <$> oplevelp (Left p)) + (typatpP precStart) + | Just (Right _) <- fixities p + -> chainr1last (typatpP (p + 1)) + (tpBinOp . J [] <$> oplevelp (Right p)) + (typatpP precStart) + | p == precApp -- this case ensures termination + -> tparg >>= tpapp' + | p < precApp + -> typatpP (p + 1) + | otherwise + -> typatpP precStart + where + tpBinOp ql tp1 tp2 = tpApp ql [tp1, tp2] + -- + tparg :: Id i => P [TyPat i] + tparg = choice + [ (:[]) <$> tpatom, + parens $ antiblep <|> commaSep1 (typatpP precStart) ] + -- + tpatom :: Id i => P (TyPat i) + tpatom = uncurry (flip tpVar) <$> paramVp + <|> tpApp <$> qlidnatp <*> pure [] + <|> antiblep + <|> tpApp (qlid "U") [] <$ qualU + <|> tpApp (qlid "A") [] <$ qualA + <|> do + ops <- many1 $ addLoc $ + oplevelp (Right precBang) >>! tpApp . J [] + arg <- tpatom <|> parens (typatpP precStart) + return (foldr (\op t -> op [t]) arg ops) + tpapp' :: Id i => [TyPat i] -> P (TyPat i) + tpapp' [t] = option t $ do + tc <- qlidnatp + tpapp' [tpApp tc [t]] + tpapp' ts = do + tc <- qlidnatp + tpapp' [tpApp tc ts] + +letp :: Id i => P (Decl i) +letp = do + reserved "let" + choice [ + do + reserved "rec" + bindings <- flip sepBy1 (reserved "and") $ do + f <- varp + (sigma, fixt, fixe) <- afargsp + colon + t <- typep + reservedOp "=" + e <- withSigma sigma exprp + return (bnBind f (fixt t) (fixe e)) + let names = map (bnvar . dataOf) bindings + namesExp = foldl1 exPair (map exBVar names) + namesPat = foldl1 paPair (map paVar names) + tempVar = Syntax.lid "#letrec" + decls0 = [ dcLet (paVar tempVar) Nothing $ + exLetRec bindings namesExp ] + decls1 = [ dcLet (paVar (bnvar binding)) Nothing $ + exLet namesPat (exBVar tempVar) $ + exBVar (bnvar binding) + | N _ binding <- bindings ] + return $ dcLoc decls0 decls1, + do + f <- varp + (sigma, fixt, fixe) <- afargsp + t <- antioptaroundp (colon `between` punit) typep + reservedOp "=" + e <- withSigma sigma exprp + return (dcLet (paVar f) (fmap fixt t) (fixe e)), + dcLet <$> pattp + <*> antioptaroundp (colon `between` punit) typep + <* reservedOp "=" + <*> exprp + ] + +absTysp :: Id i => P [AbsTy i] +absTysp = antilist1p (reserved "and") $ absTyp + +absTyp :: Id i => P (AbsTy i) +absTyp = addLoc $ antiblep <|> do + ((arity, tvs), name) <- tyProtp >>! first unzip + quals <- qualsp + reservedOp "=" + alts <- altsp + return (absTy arity quals (tdDat name tvs alts)) + +paramVp :: Id i => P (Variance, TyVar i) +paramVp = do + v <- variancep + tv <- tyvarp + return (v, tv) + +variancep :: P Variance +variancep = + choice + [ char '+' >> return Covariant, + char '-' >> return Contravariant, + char '*' >> return Omnivariant, + char '=' >> return Invariant, + return Invariant ] + +qualsp :: Id i => P (QExp i) +qualsp = option minBound $ + (reserved "qualifier" <|> reservedOp ":") *> qExpp + +qExpp :: Id i => P (QExp i) +qExpp = "qualifier expression" @@ qexp where + qexp = addLoc $ qeDisj <$> sepBy1 qterm (reservedOp "\\/") + qterm = addLoc $ qeConj <$> sepBy1 qfact (reservedOp "/\\") + qfact = addLoc $ parens qexp <|> qatom + qatom = addLoc $ + qeLit Qu <$ qualU + <|> qeLit Qa <$ qualA + <|> clean <$> tyvarp + <|> qeLid <$> lidp + <|> antiblep + qeLid = qeVar . flip TV Qa + clean (TV _ Qu) = minBound + clean tv = qeVar tv + +altsp :: Id i => P [(Uid i, Maybe (Type i))] +altsp = sepBy1 altp (reservedOp "|") + +altp :: Id i => P (Uid i, Maybe (Type i)) +altp = do + k <- try $ uidp <* try (dot *> pzero <|> punit) + t <- optionMaybe $ do + reserved "of" + typep + return (k, t) + +exprp :: Id i => P (Expr i) +exprp = expr0 where + onlyOne [x] = [x True] + onlyOne xs = map ($ False) xs + mark = ("expression" @@) + expr0 = mark $ choice + [ do reserved "let" + choice + [ do reserved "rec" + bs <- antilist1p (reserved "and") $ bindingp + reserved "in" + e2 <- expr0 + return (exLetRec bs e2), + do (x, sigma, lift) <- pattbangp + if sigma + then do + reservedOp "=" + e1 <- expr0 + reserved "in" + e2 <- withSigma True expr0 + return (lift True (flip exLet e1) x e2) + else do + (sigma', args) <- argsp + reservedOp "=" + e1 <- withSigma sigma' expr0 + reserved "in" + e2 <- expr0 + return (exLet x (args e1) e2), + do reserved "let" + unexpected "let", + do d <- withSigma False declp + reserved "in" + e2 <- expr0 + return (exLetDecl d e2) ], + do reserved "if" + ec <- expr0 + clt <- addLoc $ do + reserved "then" + caClause (paCon (quid "true") Nothing) <$> expr0 + clf <- addLoc $ do + reserved "else" + caClause (paCon (quid "false") Nothing) <$> expr0 + return (exCase ec [clt, clf]), + do reserved "match" + e1 <- expr0 + reserved "with" + choice [ + exCase e1 <$> antiblep, + do + optional (reservedOp "|") + clauses <- flip sepBy1 (reservedOp "|") preCasealtp + return (exCase e1 (onlyOne clauses)) ], + do reserved "try" + e1 <- expr0 + reserved "with" + optional (reservedOp "|") + clauses <- flip sepBy1 (reservedOp "|") $ addLoc $ do + (xi, sigma, lift) <- pattbangp + reservedOp "->" + ei <- mapSigma (sigma ||) expr0 + return $ + lift False + (\xi' ei' -> + -- TODO: Make this robust to redefinition of + -- Left and Right + caClause (paCon (quid "Left") (Just xi')) ei') + xi ei + let tryQ = qlid $ + "INTERNALS.Exn.tryfun" + return $ + exCase (exApp (exVar tryQ) + (exAbs paWild tyUnit + e1)) $ + caClause (paCon (quid "Right") + (Just (paVar (Syntax.lid "x")))) + (exVar (qlid "x")) + : + clauses ++ + [caClause + (paCon (quid "Left") + (Just (paVar (Syntax.lid "e")))) + (exApp (exVar (qlid "INTERNALS.Exn.raise")) + (exVar (qlid "e"))) + ], + do reserved "fun" + (sigma, build) <- choice + [ + argsp1, + do + (x, sigma, lift) <- pattbangp + colon + t <- typepP (precArr + 1) + return (sigma, lift True (flip exAbs t) x) + ] + arrow + withSigma sigma expr0 >>! build, + expr1 ] + expr1 = mark $ do + e1 <- expr3 + choice + [ do semi + e2 <- expr0 + return (exSeq e1 e2), + return e1 ] + expr3 = mark $ chainl1last expr4 (opappp (Left 3)) expr0 + expr4 = mark $ chainr1last expr5 (opappp (Right 4)) expr0 + expr5 = mark $ chainl1last expr6 (opappp (Left 5)) expr0 + expr6 = mark $ chainl1last expr7 (opappp (Left 6)) expr0 + expr7 = expr8 + expr8 = mark $ chainr1last expr9 (opappp (Right 8)) expr0 + expr9 = mark $ choice + [ chainl1 expr10 (addLoc (return exApp)), + do + reserved "Pack" + t1 <- antioptaroundp brackets typep + parens $ do + t2 <- typep + comma + e <- exprN1 + return (exPack t1 t2 e) + ] + expr10 = mark $ do + ops <- many $ addLoc $ oplevelp (Right 10) >>! exBVar + arg <- expr11 + return (foldr exApp arg ops) + expr11 = mark $ do + e <- exprA + ts <- many . brackets $ commaSep1 typep + return (foldl exTApp e (concat ts)) + exprA = mark $ choice + [ identp >>! exId, + litp >>! exLit, + antiblep, + parens (exprN1 <|> return (exBCon (Syntax.uid "()"))) + ] + exprN1 = mark $ do + e1 <- expr0 + choice + [ do colon + t1 <- typep + let e1' = exCast e1 t1 False + option e1' $ do + reservedOp ":>" + t2 <- typep + return (exCast e1' t2 True), + do reservedOp ":>" + t2 <- typep + return (exCast e1 t2 True), + do comma + es <- commaSep1 expr0 + return (foldl exPair e1 es), + return e1 ] + +preCasealtp :: Id i => P (Bool -> CaseAlt i) +preCasealtp = "match clause" @@ (const <$> antiblep) <|> do + (xi, sigma, lift) <- pattbangp + reservedOp "->" + ei <- mapSigma (sigma ||) exprp + return (\b -> lift b caClause xi ei) + +casealtp :: Id i => P (CaseAlt i) +casealtp = preCasealtp >>! ($ False) + +bindingp :: Id i => P (Binding i) +bindingp = "let rec binding" @@ antiblep <|> do + x <- varp + (sigma, ft, fe) <- afargsp + colon + t <- typep + reservedOp "=" + e <- withSigma sigma exprp + return (bnBind x (ft t) (fe e)) + +-- Parse an infix operator at given precedence +opappp :: Id i => Prec -> P (Expr i -> Expr i -> Expr i) +opappp p = do + op <- addLoc (oplevelp p >>! exBVar) + return (\e1 e2 -> op `exApp` e1 `exApp` e2) + +-- Zero or more of (pat:typ, ...), (), or tyvar, recognizing '|' +-- to introduce affine arrows +afargsp :: Id i => P (Bool, Type i -> Type i, Expr i -> Expr i) +afargsp = loop tyArr where + loop arrcon0 = do + arrcon <- option arrcon0 $ choice + [ tyFun <$> qualbox qExpp, + do + reservedOp "|" + return tyLol ] + choice + [ do (tvt, tve) <- tyargp + (b, ft, fe) <- loop arrcon + return (b, tvt . ft, tve . fe), + do (b, ft, fe) <- vargp arrcon + if b + then return (b, ft, fe) + else do + (b', fts, fes) <- loop arrcon + return (b', ft . fts, fe . fes), + return (False, id, id) ] + +-- One or more of (pat:typ, ...), (), tyvar +argsp1 :: Id i => P (Bool, Expr i -> Expr i) +argsp1 = do + (b, fe) <- argp + if b + then return (b, fe) + else second (fe .) `fmap` option (False, id) argsp1 + +-- Zero or more of (pat:typ, ...), (), tyvar +argsp :: Id i => P (Bool, Expr i -> Expr i) +argsp = option (False, id) $ do + (b, fe) <- argp + if b + then return (b, fe) + else second (fe .) `fmap` argsp + +-- Parse a (pat:typ, ...), (), or tyvar +argp :: Id i => P (Bool, Expr i -> Expr i) +argp = choice [ + do + (_, fe) <- tyargp + return (False, fe), + do + (b, _, fe) <- vargp const + return (b, fe) + ] + +-- Parse a (pat:typ, ...) or () argument +vargp :: Id i => + (Type i -> Type i -> Type i) -> + P (Bool, Type i -> Type i, Expr i -> Expr i) +vargp arrcon = do + inBang <- bangp + loc <- curLoc + (p, t) <- paty + return (inBang, arrcon t, condSigma inBang True (flip exAbs t) p <<@ loc) + +-- Parse a (pat:typ, ...) or () argument +paty :: Id i => P (Patt i, Type i) +paty = do + (p, mt) <- pamty + case (dataOf p, mt) of + (_, Just t) -> return (p, t) + (PaCon (J [] (Uid _ "()")) Nothing, Nothing) + -> return (p, tyUnit) + (PaWild, Nothing) + -> return (p, tyAf) + _ -> pzero ":" + +-- Parse a (), (pat:typ, ...) or (pat) argument +pamty :: Id i => P (Patt i, Maybe (Type i)) +pamty = choice + [ (paWild, Nothing) <$ reserved "_", + parens $ do + tvs <- many (tyvarp <* comma) + (p, mt) <- choice + [ do + (p, mt) <- pamty + maybe (maybecolon p) (morepts p) mt, + do + p <- pattp + maybecolon p, + return (paCon (quid "()") Nothing, Nothing) + ] + return (foldr paPack p tvs, + fmap (\t -> foldr tyEx t tvs) mt) + ] + where + maybecolon p = choice + [ + do + colon + t <- typep + morepts p t, + moreps p + ] + moreps p = do + ps <- many (comma >> pattp) + return (foldl paPair p ps, Nothing) + morepts p0 t0 = do + (ps, ts) <- liftM unzip . many $ do + comma + choice + [ + do + (p, mt) <- pamty + case mt of + Just t -> return (p, t) + Nothing -> colonType p, + do + p <- pattp + colonType p + ] + return (foldl paPair p0 ps, Just (foldl tyTuple t0 ts)) + colonType p = do + colon + t <- typep + return (p, t) + +-- Parse a sequence of one or more tyvar arguments +tyargp :: Id i => P (Type i -> Type i, Expr i -> Expr i) +tyargp = do + tvs <- liftM return loctv <|> brackets (commaSep1 loctv) + return (\t -> foldr (\(_, tv) -> tyAll tv) t tvs, + \e -> foldr (\(loc, tv) -> exTAbs tv <<@ loc) e tvs) + where + loctv = liftM2 (,) curLoc tyvarp + +pattbangp :: Id i => + P (Patt i, Bool, + Bool -> (Patt i -> Expr i -> b) -> Patt i -> Expr i -> b) +pattbangp = do + inSigma <- getSigma + inBang <- bangp + x <- pattp + let trans = inBang && not inSigma + wrap = inBang && inSigma + return (condMakeBang wrap x, inBang, condSigma trans) + +condSigma :: Id i => + Bool -> Bool -> + (Patt i -> Expr i -> a) -> + Patt i -> Expr i -> a +condSigma True = exSigma +condSigma False = const id + +condMakeBang :: Id i => Bool -> Patt i -> Patt i +condMakeBang True = makeBangPatt +condMakeBang False = id + +bangp :: P Bool +bangp = (bang >> return True) <|> return False + +pattp :: Id i => P (Patt i) +pattp = patt0 where + mark = ("pattern" @@) + patt0 = mark $ do + x <- patt9 + choice + [ do + reserved "as" + y <- varp + return (paAs x y), + return x + ] + patt9 = mark $ choice + [ do + reserved "Pack" + parens $ do + tv <- tyvarp + comma + x <- pattN1 + return (paPack tv x), + paCon <$> quidp + <*> antioptp (try pattA), + pattA ] + pattA = mark $ choice + [ paWild <$ reserved "_", + paVar <$> varp, + paLit <$> litp, + paCon <$> quidp + <*> pure Nothing, + antiblep, + parens pattN1 + ] + pattN1 = mark $ choice + [ paPack <$> try (tyvarp <* comma) + <*> pattN1, + do + xs <- commaSep patt0 + case xs of + [] -> return (paCon (quid "()") Nothing) + x:xs' -> return (foldl paPair x xs') ] + +litp :: P Lit +litp = ( "literal") $ choice [ + integerOrFloat >>! either LtInt LtFloat, + charLiteral >>! (LtInt . fromIntegral . fromEnum), + stringLiteral >>! LtStr, + antiblep + ] + +finish :: CharParser st a -> CharParser st a +finish p = do + optional (whiteSpace) + r <- p + eof + return r + +-- | Parse a program +parseProg :: Id i => P (Prog i) +-- | Parse a REPL line +parseRepl :: Id i => P [Decl i] +-- | Parse a sequence of declarations +parseDecls :: Id i => P [Decl i] +-- | Parse a declaration +parseDecl :: Id i => P (Decl i) +-- | Parse a module expression +parseModExp :: Id i => P (ModExp i) +-- | Parse a type declaration +parseTyDec :: Id i => P (TyDec i) +-- | Parse a abstype declaration +parseAbsTy :: Id i => P (AbsTy i) +-- | Parse a type +parseType :: Id i => P (Type i) +-- | Parse a type pattern +parseTyPat :: Id i => P (TyPat i) +-- | Parse a qualifier expression +parseQExp :: Id i => P (QExp i) +-- | Parse an expression +parseExpr :: Id i => P (Expr i) +-- | Parse a pattern +parsePatt :: Id i => P (Patt i) +-- | Parse a case alternative +parseCaseAlt :: Id i => P (CaseAlt i) +-- | Parse a let rec binding +parseBinding :: Id i => P (Binding i) +-- | Parse a signature +parseSigExp :: Id i => P (SigExp i) +-- | Parse a signature item +parseSigItem :: Id i => P (SigItem i) + +parseProg = finish progp +parseRepl = finish replp +parseDecls = finish declsp +parseDecl = finish declp +parseModExp = finish modexpp +parseTyDec = finish tyDecp +parseAbsTy = finish absTyp +parseType = finish typep +parseTyPat = finish typatp +parseQExp = finish qExpp +parseExpr = finish exprp +parsePatt = finish pattp +parseCaseAlt = finish casealtp +parseBinding = finish bindingp +parseSigExp = finish sigexpp +parseSigItem = finish sigitemp + +-- Convenience functions for quick-and-dirty parsing: + +-- | Parse a program +pp :: String -> Prog Renamed +pp = makeQaD parseProg + +-- | Parse a sequence of declarations +pds :: String -> [Decl Renamed] +pds = makeQaD parseDecls + +-- | Parse a declaration +pd :: String -> Decl Renamed +pd = makeQaD parseDecl + +pme :: String -> ModExp Renamed +pme = makeQaD parseModExp + +-- | Parse a type declaration +ptd :: String -> TyDec Raw +ptd = makeQaD parseTyDec + +-- | Parse a type +pt :: String -> Type Renamed +pt = makeQaD parseType + +-- | Parse a type pattern +ptp :: String -> TyPat Renamed +ptp = makeQaD parseTyPat + +-- | Parse a qualifier expression +pqe :: String -> QExp Renamed +pqe = makeQaD parseQExp + +-- | Parse an expression +pe :: String -> Expr Renamed +pe = makeQaD parseExpr + +-- | Parse a pattern +px :: String -> Patt Renamed +px = makeQaD parsePatt + +makeQaD :: P a -> String -> a +makeQaD parser = + either (error . show) id . runParser parser state0 "" diff --git a/src/Paths.hs b/src/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Paths.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE + CPP, + TemplateHaskell #-} +module Paths ( + findFirstInPath, findInPath, + almsLibPath, findAlmsLib, findAlmsLibRel, + shortenPath, + version, versionString +) where + +import Util + +import Language.Haskell.TH +import System.FilePath +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (getEnv) +import Data.Version + +#ifdef ALMS_CABAL_BUILD +import Paths_alms +#endif + +builddir :: FilePath +builddir = $(runIO getCurrentDirectory >>= litE . stringL) + +getBuildDir :: IO FilePath +getBuildDir = catch (getEnv "alms_builddir") (\_ -> return builddir) + +#ifndef ALMS_CABAL_BUILD +version :: Version +version = Version {versionBranch = [0,0,0], versionTags = ["dev"]} + +bindir, datadir :: FilePath + +bindir = builddir +datadir = dropFileName builddir "lib" + +getBinDir, getDataDir :: IO FilePath +getBinDir = catch (getEnv "alms_bindir") (\_ -> return bindir) +getDataDir = catch (getEnv "alms_datadir") (\_ -> return datadir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir name) +#endif + +findFirstInPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath) +findFirstInPath [] _ = return Nothing +findFirstInPath (f:fs) ds = do + mpath <- findInPath f ds + case mpath of + Nothing -> findFirstInPath fs ds + Just _ -> return mpath + +findInPath :: FilePath -> [FilePath] -> IO (Maybe FilePath) +findInPath _ [] = return Nothing +findInPath name (d:ds) = do + b <- doesFileExist (d name) + if b + then return (Just (normalise (d name))) + else findInPath name ds + +almsLibPath :: IO [FilePath] +almsLibPath = do + user <- liftM splitSearchPath (getEnv "ALMS_LIB_PATH") + `catch` \_ -> return [] + system <- getDataDir + build <- liftM ( "lib") getBuildDir + return $ user ++ [ system, build ] + +findAlmsLib :: FilePath -> IO (Maybe FilePath) +findAlmsLib name = do + path <- almsLibPath + findFirstInPath [ name, name <.> "alms" ] path + +findAlmsLibRel :: FilePath -> FilePath -> IO (Maybe FilePath) +findAlmsLibRel name rel = do + path <- almsLibPath + let rel' = case rel of + "." -> "." + "-" -> "." + _ -> dropFileName rel + findFirstInPath [ name, name <.> "alms" ] (rel' : path) + +shortenPath :: FilePath -> IO FilePath +shortenPath fp = do + cwd <- getCurrentDirectory + let fp' = makeRelativeTo cwd fp + return $ if length fp' < length fp then fp' else fp + +makeRelativeTo :: FilePath -> FilePath -> FilePath +makeRelativeTo fp1 fp2 = loop (splitDirectories fp1) (splitDirectories fp2) + where + loop [] [] = "." + loop [] ts = joinPath ts + loop fs [] = joinPath [ ".." | _ <- fs ] + loop (f:fs) (t:ts) + | f == t = loop fs ts + | otherwise = loop (f:fs) [] loop [] (t:ts) + +versionString :: String +versionString = "Alms, version " ++ showVersion version + diff --git a/src/Ppr.hs b/src/Ppr.hs new file mode 100644 --- /dev/null +++ b/src/Ppr.hs @@ -0,0 +1,587 @@ +-- | Pretty-printing +{-# LANGUAGE + PatternGuards, + QuasiQuotes, + TypeSynonymInstances + #-} +module Ppr ( + -- * Pretty-printing class + Ppr(..), + -- * Pretty-printing combinators + parensIf, (>+>), (>?>), pprTyApp, + -- * Renderers + render, renderS, printDoc, printPpr, + -- ** Instance helpers + showFromPpr, pprFromShow, + -- * Re-exports + module Text.PrettyPrint, + module Prec +) where + +import Meta.Quasi +import Prec +import Syntax +import Util + +import qualified Syntax.Decl +import qualified Syntax.Expr +import qualified Syntax.Notable +import qualified Syntax.Patt +import qualified Loc + +import Text.PrettyPrint hiding (render) +import Data.List (intersperse) + +-- | Class for pretty-printing at different types +-- +-- Minimal complete definition is one of: +-- +-- * 'pprPrec' +-- +-- * 'ppr' +class Ppr p where + -- | Print at the specified enclosing precedence + pprPrec :: Int -> p -> Doc + -- | Print at top-level precedence + ppr :: p -> Doc + -- | Print a list at the specified enclosing precedence with + -- the specified style + pprPrecStyleList :: Int -> ListStyle -> [p] -> Doc + -- | Print a list at the specified enclosing precedence + pprPrecList :: Int -> [p] -> Doc + -- | Print a list at top-level precedence + pprList :: [p] -> Doc + -- | Style for printing lists + listStyle :: [p] -> ListStyle + -- + ppr = pprPrec precDot + pprPrec _ = ppr + pprPrecStyleList _ st [] = + if listStyleDelimitEmpty st + then listStyleBegin st <> listStyleEnd st + else empty + pprPrecStyleList p st [x] = + if listStyleDelimitSingleton st + then listStyleBegin st <> ppr x <> listStyleEnd st + else pprPrec p x + pprPrecStyleList _ st xs = + listStyleBegin st <> + listStyleJoiner st (punctuate (listStylePunct st) (map ppr xs)) + <> listStyleEnd st + pprPrecList p xs = pprPrecStyleList p (listStyle xs) xs + pprList = pprPrecList 0 + listStyle _ = ListStyle { + listStyleBegin = lparen, + listStyleEnd = rparen, + listStylePunct = comma, + listStyleDelimitEmpty = False, + listStyleDelimitSingleton = False, + listStyleJoiner = fsep + } + +data ListStyle = ListStyle { + listStyleBegin, listStyleEnd, listStylePunct :: Doc, + listStyleDelimitEmpty, listStyleDelimitSingleton :: Bool, + listStyleJoiner :: [Doc] -> Doc +} + +-- | Conditionally add parens around the given 'Doc' +parensIf :: Bool -> Doc -> Doc +parensIf True doc = parens doc +parensIf False doc = doc + +instance Ppr a => Ppr [a] where + pprPrec = pprPrecList + +instance Ppr a => Ppr (Maybe a) where + pprPrec _ Nothing = empty + pprPrec p (Just a) = pprPrec p a + +class Ppr a => IsInfix a where + isInfix :: a -> Bool + pprRight :: Int -> a -> Doc + pprRight p a = + if isInfix a + then pprPrec p a + else ppr a + +instance Ppr Doc where + ppr = id + +instance IsInfix (Type i) where + isInfix [$ty| ($_, $_) $lid:n |] = isOperator n + isInfix [$ty| $_ -[$_]> $_ |] = True + isInfix _ = False + +-- | To pretty print the application of a type constructor to +-- generic parameters +pprTyApp :: (Ppr a) => Int -> QLid i -> [a] -> Doc +pprTyApp _ ql [] = ppr ql +pprTyApp p (J [] l) [t1] + | isOperator l, precOp (unLid l) == Right precBang + = parensIf (p > precBang) $ + text (unLid l) <> pprPrec (precBang + 1) t1 +pprTyApp p (J [] l) [t1, t2] + -- print @ without space around it: + | isOperator l, '@':_ <- unLid l, Right prec <- precOp (unLid l) + = parensIf (p > prec) $ + pprPrec (prec + 1) t1 <> text (unLid l) <> pprPrec prec t2 + | isOperator l, Left prec <- precOp (unLid l) + = parensIf (p > prec) $ + sep [ pprPrec prec t1, + text (unLid l) <+> pprPrec (prec + 1) t2 ] + | isOperator l, Right prec <- precOp (unLid l) + = parensIf (p > prec) $ + sep [ pprPrec (prec + 1) t1, + text (unLid l) <+> pprPrec prec t2] +pprTyApp p ql ts = parensIf (p > precApp) $ + sep [ pprPrec precApp ts, + ppr ql ] + +instance Ppr (Type i) where + -- Print sugar for infix type constructors: + pprPrec p [$ty| $t1 ; $t2 |] + = parensIf (p > precSemi) $ + sep [ pprPrec (precSemi + 1) t1 <> text ";", + pprPrec precSemi t2 ] + -- pprPrec p (TyFun q t1 t2) + pprPrec p [$ty| $t1 -[$q]> $t2 |] + = parensIf (p > precArr) $ + sep [ pprPrec (precArr + 1) t1, + pprArr (view q) <+> pprRight precArr t2 ] + where pprArr (QeLit Qu) = text "->" + pprArr (QeLit Qa) = text "-o" + pprArr _ = text "-[" <> pprPrec precStart q <> text "]>" + pprPrec p [$ty| ($list:ts) $qlid:n |] + = pprTyApp p n ts + -- debugging: <> text (show (ttId (unsafeCoerce tag :: TyTag))) + pprPrec p [$ty| '$x |] = pprPrec p x + pprPrec p [$ty| $quant:qu '$x. $t |] + = parensIf (p > precDot) $ + ppr qu <+> + fsep (map (pprPrec (precDot + 1)) + tvs) <> + char '.' + >+> pprPrec precDot body + where (tvs, body) = unfoldTyQu qu [$ty| $quant:qu '$x. $t |] + pprPrec p [$ty| mu '$x. $t |] + = parensIf (p > precDot) $ + text "mu" <+> + pprPrec (precDot + 1) x <> + char '.' + >+> pprPrec precDot t + pprPrec p [$ty| $anti:a |] = pprPrec p a + +instance Ppr (TyPat i) where + pprPrec p tp0 = case tp0 of + N _ (TpVar tv var) -> pprParamV var tv + [$tpQ| ($list:tps) $qlid:ql |] + -> pprTyApp p ql tps + [$tpQ| $antiP:a |] -> ppr a + +instance Ppr (QExp i) where + pprPrec p [$qeQ| $qlit:qu |] = pprPrec p qu + pprPrec p [$qeQ| $qvar:v |] = pprPrec p (tvname v) + pprPrec p [$qeQ| $qdisj:qes |] = case qes of + [] -> pprPrec p Qu + [qe] -> pprPrec p qe + _ -> parensIf (p > precPlus) $ + fsep $ + intersperse (text "\\/") $ + map (pprPrec (precPlus + 1)) qes + pprPrec p [$qeQ| $qconj:qes |] = case qes of + [] -> pprPrec p Qa + [qe] -> pprPrec p qe + _ -> parensIf (p > precStar) $ + hcat $ + intersperse (text "/\\") $ + map (pprPrec (precStar + 1)) qes + pprPrec p [$qeQ| $anti:a |] = pprPrec p a + +instance Ppr Int where + ppr = int + +instance Ppr (Prog i) where + ppr [$prQ| $list:ms |] = vcat (map ppr ms) + ppr [$prQ| $expr:e |] = ppr e + ppr [$prQ| $list:ms in $e |] = vcat (map ppr ms) $+$ + (text "in" >+> ppr e) + +instance Ppr (Decl i) where + ppr [$dc| let $x = $e |] = sep + [ text "let" <+> ppr x, + nest 2 $ equals <+> ppr e ] + ppr [$dc| let $x : $t = $e |] = sep + [ text "let" <+> ppr x, + nest 2 $ colon <+> ppr t, + nest 4 $ equals <+> ppr e ] + ppr [$dc| type $list:tds |] = pprTyDecs tds + ppr [$dc| abstype $list:ats0 with $list:ds end |] = + case ats0 of + [] -> + vcat [ + text "abstype with", + nest 2 $ vcat (map ppr ds), + text "end" + ] + at:ats -> + vcat [ + vcat (text "abstype" <+> pprAbsTy at : + [ nest 4 $ text "and" <+> pprAbsTy ati | ati <- ats ]) + <+> text "with", + nest 2 $ vcat (map ppr ds), + text "end" + ] + ppr [$dc| open $b |] = pprModExp (text "open" <+>) b + ppr [$dc| module $uid:n : $s = $b |] = pprModExp add1 b where + add1 body = pprSigExp add2 s <+> equals <+> body + add2 body = text "module" <+> ppr n <+> colon <+> body + ppr [$dc| module $uid:n = $b |] = pprModExp add b where + add body = text "module" <+> ppr n <+> equals <+> body + ppr [$dc| module type $uid:n = $s |] = pprSigExp add s where + add body = text "module type" <+> ppr n <+> equals <+> body + ppr [$dc| local $list:d0 with $list:d1 end |] = + vcat [ + text "local", + nest 2 (vcat (map ppr d0)), + text "with", + nest 2 (vcat (map ppr d1)), + text "end" + ] + ppr [$dc| exception $uid:n of $opt:mt |] = + pprExcDec n mt + ppr [$dc| $anti:a |] = ppr a + +pprTyDecs :: [TyDec i] -> Doc +pprTyDecs tds = + vcat $ + mapHead (text "type" <+>) $ + mapTail ((nest 1) . (text "and" <+>)) $ + map ppr tds + +pprExcDec :: Uid i -> Maybe (Type i) -> Doc +pprExcDec u Nothing = + text "exception" <+> ppr u +pprExcDec u (Just t) = + text "exception" <+> ppr u <+> text "of" <+> ppr t + +instance Ppr (TyDec i) where + ppr td = case view td of + TdAbs n ps vs qs -> pprProtoV n vs ps >?> pprQuals qs + TdSyn n [(ps,t)] -> pprProto n ps >+> equals <+> ppr t + TdSyn n cs -> vcat [ char '|' <+> each ci | ci <- cs ] + where + each (ps, rhs) = pprProto n ps + >+> char '=' <+> ppr rhs + TdDat n ps alts -> pprProtoV n (repeat Invariant) ps + >?> pprAlternatives alts + TdAnti a -> ppr a + +pprAbsTy :: AbsTy i -> Doc +pprAbsTy at = case view at of + AbsTy variances qual (N _ (TdDat name params alts)) -> + pprProtoV name variances params + >?> pprQuals qual + >?> pprAlternatives alts + AbsTy _ _ td -> ppr td -- shouldn't happen (yet) + AbsTyAnti a -> ppr a + +pprProto :: Lid i -> [TyPat i] -> Doc +pprProto n ps = ppr (tpApp (J [] n) ps) + +pprProtoV :: Lid i -> [Variance] -> [TyVar i] -> Doc +pprProtoV n vs tvs = pprProto n (zipWith tpVar tvs vs) + +pprParamV :: Variance -> TyVar i -> Doc +pprParamV Invariant tv = ppr tv +pprParamV v tv = ppr v <> ppr tv + +pprQuals :: QExp i -> Doc +pprQuals [$qeQ| U |] = empty +pprQuals qs = text ":" <+> pprPrec precApp qs + +pprAlternatives :: [(Uid i, Maybe (Type i))] -> Doc +pprAlternatives [] = equals +pprAlternatives (a:as) = sep $ + equals <+> alt a : [ char '|' <+> alt a' | a' <- as ] + where + alt (u, Nothing) = ppr u + alt (u, Just t) = ppr u <+> text "of" <+> pprPrec precDot t + +pprModExp :: (Doc -> Doc) -> ModExp i -> Doc +pprModExp add modexp = case modexp of + [$me| $quid:n |] -> add (ppr n) + [$me| $quid:n $list:qls |] -> + add (ppr n) <+> + brackets (fsep (punctuate comma (map ppr qls))) + [$me| struct $list:ds end |] -> + add (text "struct") + $$ nest 2 (vcat (map ppr ds)) + $$ text "end" + [$me| $me1 : $se2 |] -> + pprSigExp (pprModExp add me1 <+> colon <+>) se2 + [$me| $anti:a |] -> add (ppr a) + +pprSigExp :: (Doc -> Doc) -> SigExp i -> Doc +pprSigExp add se0 = body >+> withs where + (wts, se1) = unfoldSeWith se0 + body = case se1 of + [$seQ| $quid:n |] -> add (ppr n) + [$seQ| $quid:n $list:qls |] -> + add (ppr n) <+> + brackets (fsep (punctuate comma (map ppr qls))) + [$seQ| sig $list:sgs end |] -> + add (text "sig") + $$ nest 2 (vcat (map ppr sgs)) + $$ text "end" + [$seQ| $_ with type $list:_ $qlid:_ = $_ |] -> + error "BUG! can't happen in pprSigExp" + [$seQ| $anti:a |] -> add (ppr a) + withs = + sep $ + mapHead (text "with type" <+>) $ + mapTail ((nest 6) . (text "and" <+>)) $ + [ pprTyApp 0 tc tvs <+> equals <+> ppr t + | (tc, tvs, t) <- wts ] + +instance Ppr (SigItem i) where + ppr sg0 = case sg0 of + [$sgQ| val $lid:n : $t |] -> + text "val" <+> ppr n >+> colon <+> ppr t + [$sgQ| type $list:tds |] -> + pprTyDecs tds + [$sgQ| module $uid:u : $s |] -> + pprSigExp add s where + add body = text "module" <+> ppr u <+> colon <+> body + [$sgQ| module type $uid:u = $s |] -> + pprSigExp add s where + add body = text "module type" <+> ppr u <+> equals <+> body + [$sgQ| include $s |] -> + pprSigExp (text "include" <+>) s + [$sgQ| exception $uid:u of $opt:mt |] -> + pprExcDec u mt + [$sgQ| $anti:a |] -> + ppr a + +instance Ppr (Expr i) where + pprPrec p e0 = case e0 of + [$ex| $id:x |] -> pprPrec p x + [$ex| $lit:lt |] -> pprPrec p lt + [$ex| if $ec then $et else $ef |] -> + parensIf (p > precDot) $ + sep [ text "if" <+> ppr ec, + nest 2 $ text "then" <+> ppr et, + nest 2 $ text "else" <+> pprPrec precDot ef ] + [$ex| $e1; $e2 |] -> + parensIf (p > precSemi) $ + sep [ pprPrec (precSemi + 1) e1 <> semi, + ppr e2 ] + [$ex| let $x = $e1 in $e2 |] -> + pprLet p (ppr x) e1 e2 + [$ex| match $e1 with $list:clauses |] -> + parensIf (p > precDot) $ + vcat (sep [ text "match", + nest 2 $ ppr e1, + text "with" ] : map alt clauses) + where + alt (N _ (CaClause xi ei)) = + hang (char '|' <+> pprPrec precDot xi <+> text "->") + 4 + (pprPrec precDot ei) + alt (N _ (CaAnti a)) = char '|' <+> ppr a + [$ex| let rec $list:bs in $e2 |] -> + text "let" <+> + vcat (zipWith each ("rec" : repeat "and") bs) $$ + text "in" <+> pprPrec precDot e2 + where + each kw (N _ (BnBind x t e)) = + -- This could be better by pulling some args out. + hang (hang (text kw <+> ppr x) + 6 + (colon <+> ppr t <+> equals)) + 2 + (ppr e) + each kw (N _ (BnAnti a)) = text kw <+> ppr a + [$ex| let $decl:d in $e2 |] -> + text "let" <+> ppr d $$ + (text "in" >+> pprPrec precDot e2) + [$ex| ($e1, $e2) |] -> + parensIf (p > precCom) $ + sep [ pprPrec precCom e1 <> comma, + pprPrec (precCom + 1) e2 ] + [$ex| fun $_ : $_ -> $_ |] -> pprAbs p e0 + [$ex| $name:x $e2 |] + | Right p' <- precOp x, + p' == 10 + -> parensIf (p > p') $ + text x <+> pprPrec p' e2 + [$ex| ($name:x $e12) $e2 |] + | (dl, dr, p') <- either ((,,) 0 1) ((,,) 1 0) (precOp x), + p' < 9 + -> parensIf (p > p') $ + sep [ pprPrec (p' + dl) e12, + text x, + pprPrec (p' + dr) e2 ] + [$ex| $e1 $e2 |] + -> parensIf (p > precApp) $ + sep [ pprPrec precApp e1, + pprPrec (precApp + 1) e2 ] + [$ex| fun '$_ -> $_ |] -> pprAbs p e0 + [$ex| $_ [$_] |] -> + parensIf (p > precTApp) $ + cat [ pprPrec precTApp op, + brackets . fsep . punctuate comma $ + map (pprPrec precCom) args ] + where + (args, op) = unfoldExTApp e0 + [$ex| Pack[$opt:t1]($t2, $e) |] -> + parensIf (p > precApp) $ + text "Pack" <> maybe empty (brackets . ppr) t1 <+> + parens (sep [ pprPrec (precCom + 1) t2 <> comma, + pprPrec precCom e ]) + [$ex| ( $e : $t1 :> $t2 ) |] -> + parensIf (p > precCast) $ + sep [ pprPrec (precCast + 2) e, + colon <+> pprPrec (precCast + 2) t1, + text ":>" <+> pprPrec (precCast + 2) t2 ] + [$ex| ( $e : $t1 ) |] -> + parensIf (p > precCast) $ + sep [ pprPrec (precCast + 2) e, + colon <+> pprPrec (precCast + 2) t1 ] + [$ex| ( $e :> $t1 ) |] -> + parensIf (p > precCast) $ + sep [ pprPrec (precCast + 2) e, + text ":>" <+> pprPrec (precCast + 2) t1 ] + [$ex| $anti:a |] -> pprPrec p a + +pprLet :: Int -> Doc -> Expr i -> Expr i -> Doc +pprLet p pat e1 e2 = parensIf (p > precDot) $ + hang (text "let" <+> pat <+> pprArgList args <+> equals + >+> ppr body <+> text "in") + (if isLet (view e2) + then 0 + else 2) + (pprPrec precDot e2) + where + (args, body) = unfoldExAbs e1 + isLet (ExCase _ [_]) = True + isLet _ = False + +pprAbs :: Int -> Expr i -> Doc +pprAbs p e = parensIf (p > precDot) $ + text "fun" <+> argsDoc <+> text "->" + >+> pprPrec precDot body + where (args, body) = unfoldExAbs e + argsDoc = case args of + [Left ([$pa| _ |], [$ty|@! unit |])] + -> parens empty + [Left (x, t)] -> ppr x <+> char ':' <+> pprPrec (precArr + 1) t + _ -> pprArgList args + +pprArgList :: [Either (Patt i, Type i) (TyVar i)] -> Doc +pprArgList = fsep . map eachArg . combine where + eachArg (Left ([$pa| _ |], [$ty|@! unit |])) + = parens empty + eachArg (Left (x, t)) = parens $ + ppr x + >+> colon <+> ppr t + eachArg (Right tvs) = brackets . + sep . + punctuate comma $ + map ppr tvs + + combine :: [Either a b] -> [Either a [b]] + combine = foldr each [] where + each (Right b) (Right bs : es) = Right (b : bs) : es + each (Right b) es = Right [b] : es + each (Left a) es = Left a : es + +instance Ppr (Patt i) where + pprPrec _ [$pa| _ |] = text "_" + pprPrec _ [$pa| $lid:l |] = ppr l + pprPrec _ [$pa| $quid:qu |] = ppr qu + pprPrec p [$pa| $quid:qu $x |] = parensIf (p > precApp) $ + pprPrec precApp qu <+> + pprPrec (precApp + 1) x + pprPrec p [$pa| ($x, $y) |] = parensIf (p > precCom) $ + pprPrec precCom x <> comma <+> + pprPrec (precCom + 1) y + pprPrec p [$pa| $lit:lt |] = pprPrec p lt + pprPrec p [$pa| $x as $lid:l |] = parensIf (p > precDot) $ + pprPrec (precDot + 1) x <+> + text "as" <+> ppr l + pprPrec p [$pa| Pack('$tv,$x) |] = parensIf (p > precApp) $ + text "Pack" <+> parens (sep pair) + where pair = [ pprPrec (precCom + 1) tv <> comma, + pprPrec precCom x ] + pprPrec p [$pa| $anti:a |] = pprPrec p a + +instance Ppr Lit where + ppr (LtInt i) = integer i + ppr (LtFloat f) = double f + ppr (LtStr s) = text (show s) + ppr (LtAnti a) = ppr a + +instance Show (Prog i) where showsPrec = showFromPpr +instance Show (Decl i) where showsPrec = showFromPpr +instance Show (TyDec i) where showsPrec = showFromPpr +instance Show (Expr i) where showsPrec = showFromPpr +instance Show (Patt i) where showsPrec = showFromPpr +instance Show Lit where showsPrec = showFromPpr +instance Show (Type i) where showsPrec = showFromPpr +instance Show (TyPat i) where showsPrec = showFromPpr +instance Show (QExp i) where showsPrec = showFromPpr +instance Show (SigItem i)where showsPrec = showFromPpr + +instance Ppr QLit where pprPrec = pprFromShow +instance Ppr Variance where pprPrec = pprFromShow +instance Ppr Quant where pprPrec = pprFromShow +instance Ppr (Lid i) where pprPrec = pprFromShow +instance Ppr (Uid i) where pprPrec = pprFromShow +instance Ppr (BIdent i)where pprPrec = pprFromShow +instance Ppr (TyVar i) where pprPrec = pprFromShow +instance Ppr Anti where pprPrec = pprFromShow +instance (Show p, Show k) => Ppr (Path p k) where pprPrec = pprFromShow + +-- Render a document in the preferred style, given a string continuation +renderS :: Doc -> ShowS +renderS doc rest = fullRender PageMode 80 1.5 each rest doc + where each (Chr c) s' = c:s' + each (Str s) s' = s++s' + each (PStr s) s' = s++s' + +-- Render a document in the preferred style +render :: Doc -> String +render doc = renderS doc "" + +-- Render and display a document in the preferred style +printDoc :: Doc -> IO () +printDoc = fullRender PageMode 80 1.5 each (putChar '\n') + where each (Chr c) io = putChar c >> io + each (Str s) io = putStr s >> io + each (PStr s) io = putStr s >> io + +-- Pretty-print, render and display in the preferred style +printPpr :: Ppr a => a -> IO () +printPpr = printDoc . ppr + +showFromPpr :: Ppr a => Int -> a -> ShowS +showFromPpr p t = renderS (pprPrec p t) + +pprFromShow :: Show a => Int -> a -> Doc +pprFromShow p t = text (showsPrec p t "") + +liftEmpty :: (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc +liftEmpty joiner d1 d2 + | isEmpty d1 = d2 + | isEmpty d2 = d1 + | otherwise = joiner d1 d2 + +(>+>) :: Doc -> Doc -> Doc +(>+>) = flip hang 2 + +(>?>) :: Doc -> Doc -> Doc +(>?>) = liftEmpty (>+>) + +infixr 5 >+>, >?> + diff --git a/src/Prec.hs b/src/Prec.hs new file mode 100644 --- /dev/null +++ b/src/Prec.hs @@ -0,0 +1,65 @@ +-- | Operator precdences +-- +-- We use operator precedences from Ocaml. The precence and +-- associativity of an operator is determined by its first character. +module Prec ( + Prec, precOp, fixities, + -- * Precedences for reserved operators needed by the parser + precMin, precStart, precMax, + precCast, precCom, precDot, precSemi, precEq, precCaret, precArr, + precPlus, precStar, precAt, precApp, precBang, precTApp +) where + +-- | Precedence and associativity, e.g. @Right 4@ is right-associative +-- at level 4. Higher precedences bind tighter, with application +-- at precedence 9. +type Prec = Either Int Int + +precOp :: String -> Prec +precOp ('*':'*':_) = Right precAt +precOp ('-':'>':_) = Right precArr +precOp ('-':'o':_) = Right precArr +precOp "-[]>" = Right precArr +precOp (';':_) = Right precSemi +precOp "!=" = Left precEq +precOp (c:_) + | c `elem` "=<>|&$" = Left precEq + | c `elem` "*/%" = Left precStar + | c `elem` "+-" = Left precPlus + | c `elem` "^" = Right precCaret + | c `elem` "@" = Right precAt + | c `elem` "!~?" = Right precBang +precOp _ = Left precApp + +precMin, precStart, precMax, + precCast, precCom, precDot, precSemi, precEq, precCaret, precArr, + precPlus, precStar, precAt, precApp, precBang, precTApp :: Int +precMin = -2 +precCast = -2 -- :> +precCom = -1 -- , +precStart = 0 +precDot = 1 -- in, else, as, of, . +precArr = 2 -- -> +precEq = 3 -- != = < > | & $ +precCaret = 4 -- ^ (infixr) +precPlus = 5 -- - + +precStar = 6 -- % / * +precSemi = 7 -- ; (types only) +precAt = 8 -- @ ** (infixr) +precApp = 9 -- f x +precBang = 10 -- ! ~ ? (prefix) +precTApp = 11 -- f[t] +precMax = 11 + +-- To find out the fixity of a precedence level +fixities :: Int -> Maybe Prec +fixities n + | n == precArr = Just $ Right precArr + | n == precEq = Just $ Left precEq + | n == precCaret= Just $ Right precCaret + | n == precPlus = Just $ Left precPlus + | n == precStar = Just $ Left precStar + | n == precSemi = Just $ Right precSemi + | n == precAt = Just $ Right precAt + | n == precBang = Just $ Right precBang + | otherwise = Nothing diff --git a/src/Rename.hs b/src/Rename.hs new file mode 100644 --- /dev/null +++ b/src/Rename.hs @@ -0,0 +1,921 @@ +{-# LANGUAGE + FlexibleInstances, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + QuasiQuotes, + RankNTypes, + RelaxedPolyRec, + TemplateHaskell, + TypeSynonymInstances #-} +module Rename ( + -- * The renaming monad and runners + Renaming, runRenaming, runRenamingM, + renameMapM, + -- * State between renaming steps + RenameState, renameState0, + -- ** Adding the basis + addVal, addType, addMod, + -- * Renamers + renameProg, renameDecls, renameDecl, renameType, + -- * REPL query + getRenamingInfo, RenamingInfo(..), +) where + +import Meta.Quasi +import Syntax hiding ((&)) +import qualified Loc +import qualified Syntax.Decl +import qualified Syntax.Expr +import qualified Syntax.Notable +import qualified Syntax.Patt +import Util + +import qualified Data.List as List +import Data.Monoid +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Monad.RWS as RWST +import qualified Control.Monad.State as M.S +import Control.Monad.Error as M.E + +-- | The type to save the state of the renamer between calls +data RenameState = RenameState { + savedEnv :: Env, + savedCounter :: Renamed +} deriving Show + +-- | The initial state +renameState0 :: RenameState +renameState0 = RenameState { + savedEnv = mempty { + datacons = M.singleton (uid "()") (uid "()", mkBogus "built-in", ()) + }, + savedCounter = renamed0 +} + +-- | The renaming monad: Reads a context, writes a module, and +-- keeps track of a renaming counter state. +newtype Renaming a = R { + unR :: RWST Context Module Renamed (Either String) a +} deriving Functor + +instance Monad Renaming where + return = R . return + m >>= k = R (unR m >>= unR . k) + fail s = R $ do + loc <- asks location + fail $ if isBogus loc + then s + else show loc ++ ":\nname error: " ++ s + +instance MonadWriter Module Renaming where + listen = R . listen . unR + tell = R . tell + pass = R . pass . unR + +instance MonadReader Env Renaming where + ask = R (asks env) + local f = R . local (\cxt -> cxt { env = f (env cxt) }) . unR + +instance MonadError String Renaming where + throwError = fail + catchError body handler = + R (catchError (unR body) (unR . handler)) + +-- | The renaming environment +data Env = Env { + tycons, vars :: !(EnvMap Lid ()), + datacons :: !(EnvMap Uid ()), + modules, sigs :: !(EnvMap Uid (Module, Env)), + tyvars :: !(EnvMap TyVar Bool) +} deriving Show + +type EnvMap f i = M.Map (f Raw) (f Renamed, Loc, i) + +-- | A module item is one of 5 renaming entries, an empty module, r +-- a pair of modules. Note that while type variables are not actual +-- module items, they are exported from patterns, so it's useful to +-- have them here. +data Module + = MdNil + | MdApp !Module !Module + | MdTycon !Loc !(Lid Raw) !(Lid Renamed) + | MdVar !Loc !(Lid Raw) !(Lid Renamed) + | MdDatacon !Loc !(Uid Raw) !(Uid Renamed) + | MdModule !Loc !(Uid Raw) !(Uid Renamed) !Module + | MdSig !Loc !(Uid Raw) !(Uid Renamed) !Module + | MdTyvar !Loc !(TyVar Raw) !(TyVar Renamed) + deriving Show + +-- | The renaming context, which includes the environment (which is +-- persistant), and other information with is not +data Context = Context { + env :: !Env, + allocate :: !Bool, + location :: !Loc +} + +-- | Run a renaming computation +runRenaming :: Bool -> Loc -> RenameState -> Renaming a -> + Either String (a, RenameState) +runRenaming nonTrivial loc saved action = do + (result, counter, md) <- + runRWST (unR action) + Context { + env = savedEnv saved, + allocate = nonTrivial, + location = loc + } + (savedCounter saved) + let env' = savedEnv saved `mappend` envify md + return (result, RenameState env' counter) + +-- | Run a renaming computation +runRenamingM :: Monad m => + Bool -> Loc -> RenameState -> Renaming a -> m (a, RenameState) +runRenamingM = either fail return <$$$$> runRenaming + +-- | Alias +type R a = Renaming a + +instance Monoid Env where + mempty = Env M.empty M.empty M.empty M.empty M.empty M.empty + mappend (Env a1 a2 a3 a4 a5 a6) (Env b1 b2 b3 b4 b5 b6) = + Env (a1 & b1) (a2 & b2) (a3 & b3) (a4 & b4) (a5 & b5) (a6 & b6) + where a & b = M.union b a + +instance Monoid Module where + mempty = MdNil + mappend = MdApp + +-- | Open a module into an environment +envify :: Module -> Env +envify MdNil = mempty +envify (MdApp md1 md2) = envify md1 `mappend` envify md2 +envify (MdTycon loc l l') + = mempty { tycons = M.singleton l (l', loc, ()) } +envify (MdVar loc l l') + = mempty { vars = M.singleton l (l', loc, ()) } +envify (MdDatacon loc u u') + = mempty { datacons = M.singleton u (u', loc, ()) } +envify (MdModule loc u u' md) + = mempty { modules = M.singleton u (u',loc,(md,envify md)) } +envify (MdSig loc u u' md) + = mempty { sigs = M.singleton u (u',loc,(md,envify md)) } +envify (MdTyvar loc tv tv') + = mempty { tyvars = M.singleton tv (tv',loc,True) } + +-- | Like 'asks', but in the 'R' monad +withContext :: (Context -> R a) -> R a +withContext = R . (ask >>=) . fmap unR + +-- | Run in the context of a given source location +withLoc :: Locatable loc => loc -> R a -> R a +withLoc loc = + R . local (\cxt -> cxt { location = location cxt <<@ loc }) . unR + +-- | Append a module to the current environment +inModule :: Module -> R a -> R a +inModule m = local (\e -> e `mappend` envify m) + +-- | Run in the environment consisting of only the given module +onlyInModule :: Module -> R a -> R a +onlyInModule = local (const mempty) <$$> inModule + +-- | Temporarily stop allocating unique ids +don'tAllocate :: R a -> R a +don'tAllocate = R . local (\cxt -> cxt { allocate = False }) . unR + +-- | Generate an unbound name error +unbound :: Show a => String -> a -> R b +unbound ns a = fail $ ns ++ " not in scope: `" ++ show a ++ "'" + +-- | Are all keys of the list unique? If not, return a pair of +-- values +unique :: Ord a => (b -> a) -> [b] -> Maybe (b, b) +unique getKey = loop M.empty where + loop _ [] = Nothing + loop seen (x:xs) = + let k = getKey x + in case M.lookup k seen of + Nothing -> loop (M.insert k x seen) xs + Just x' -> Just (x', x) + +-- | Grab the module produced by a computation, and +-- produce no module +steal :: R a -> R (a, Module) +steal = R . censor (const mempty) . listen . unR + +-- | Get all the variable names, included qualified, bound in a module +getAllVariables :: Module -> [QLid Renamed] +getAllVariables = S.toList . loop where + loop (MdApp md1 md2) = loop md1 `S.union` loop md2 + loop (MdVar _ _ l') = S.singleton (J [] l') + loop (MdModule _ _ u' md) = S.mapMonotonic (\(J us l) -> J (u':us) l) + (loop md) + loop _ = S.empty + +-- | Temporarily hide the type variables in scope, and pass the +-- continuation a function to bring them back +hideTyvars :: R a -> R a +hideTyvars = local (\e -> e { tyvars = M.map each (tyvars e) }) + where each (tv, loc, _) = (tv, loc, False) + +-- | Look up something in an environment +envLookup :: (Ord k, Show k) => + (Env -> M.Map k k') -> + Path (Uid Raw) k -> + Env -> + Either (Maybe (Path (Uid Renamed) (Uid Raw))) + (Path (Uid Renamed) k') +envLookup prj = loop [] where + loop ms' (J [] x) e = case M.lookup x (prj e) of + Just x' -> Right (J (reverse ms') x') + Nothing -> Left Nothing + loop ms' (J (m:ms) x) e = case M.lookup m (modules e) of + Just (m', _, (_, e')) -> loop (m':ms') (J ms x) e' + Nothing -> Left (Just (J (reverse ms') m)) + +-- | Look up something in the environment +getGenericFull :: (Ord k, Show k) => + String -> (Env -> M.Map k k') -> + Path (Uid Raw) k -> R (Path (Uid Renamed) k') +getGenericFull what prj qx = do + e <- ask + case envLookup prj qx e of + Right qx' -> return qx' + Left Nothing -> unbound what qx + Left (Just m) -> unbound "module" m + +-- | Look up something in the environment +getGeneric :: (Ord (f Raw), Show (f Raw)) => + String -> (Env -> EnvMap f i) -> + Path (Uid Raw) (f Raw) -> R (Path (Uid Renamed) (f Renamed)) +getGeneric = liftM (fmap (\(qx', _, _) -> qx')) <$$$> getGenericFull + +-- | Look up a variable in the environment +getVar :: QLid Raw -> R (QLid Renamed) +getVar = getGeneric "variable" vars + +-- | Look up a data constructor in the environment +getDatacon :: QUid Raw -> R (QUid Renamed) +getDatacon = getGeneric "data constructor" datacons + +-- | Look up a variable in the environment +getTycon :: QLid Raw -> R (QLid Renamed) +getTycon = getGeneric "type constructor" tycons + +-- | Look up a module in the environment +getModule :: QUid Raw -> R (QUid Renamed, Module, Env) +getModule = liftM pull . getGenericFull "structure" modules + where + pull (J ps (qu, _, (m, e))) = (J ps qu, m, e) + +-- | Look up a module in the environment +getSig :: QUid Raw -> R (QUid Renamed, Module, Env) +getSig = liftM pull . getGenericFull "signature" sigs + where + pull (J ps (qu, _, (m, e))) = (J ps qu, m, e) + +-- | Look up a variable in the environment +getTyvar :: TyVar Raw -> R (TyVar Renamed) +getTyvar tv = do + e <- asks tyvars + case M.lookup tv e of + Nothing -> fail $ "type variable not in scope: " ++ show tv + Just (tv', _, True) -> return tv' + Just (_, loc, False) -> fail $ + "type variable not in scope: " ++ show tv ++ "\n" ++ + "NB: It was bound at " ++ show loc ++ " but nested declarations\n" ++ + "cannot see tyvars from their parent expression." + +-- | Get a new name for a variable binding +bindGeneric :: (Ord ident, Show ident, Antible ident) => + (Renamed -> ident -> ident') -> + (Loc -> ident -> ident' -> Module) -> + ident -> R ident' +bindGeneric ren build x = R $ do + case prjAnti x of + Just a -> $antifail + Nothing -> return () + doAlloc <- asks allocate + x' <- if doAlloc + then do + counter <- get + put (succ counter) + return (ren counter x) + else do + return (ren trivialId x) + loc <- asks location + tell (build loc x x') + return x' + +-- | Get a new name for a variable binding +bindVar :: Lid Raw -> R (Lid Renamed) +bindVar = bindGeneric (\r -> Lid r . unLid) MdVar + +-- | Get a new name for a variable binding +bindTycon :: Lid Raw -> R (Lid Renamed) +bindTycon = bindGeneric (\r -> Lid r . unLid) MdTycon + +-- | Get a new name for a data constructor binding +bindDatacon :: Uid Raw -> R (Uid Renamed) +bindDatacon = bindGeneric (\r -> Uid r . unUid) MdDatacon + +-- | Get a new name for a module, and bind it in the environment +bindModule :: Uid Raw -> Module -> R (Uid Renamed) +bindModule u0 md = bindGeneric (\r -> Uid r . unUid) build u0 + where build loc old new = MdModule loc old new md + +-- | Get a new name for a signature, and bind it in the environment +bindSig :: Uid Raw -> Module -> R (Uid Renamed) +bindSig u0 md = bindGeneric (\r -> Uid r . unUid) build u0 + where build loc old new = MdSig loc old new md + +-- | Add a type variable to the scope +bindTyvar :: TyVar Raw -> R (TyVar Renamed) +bindTyvar = bindGeneric (\r (TV l q) -> TV (Lid r (unLid l)) q) MdTyvar + +-- | Map a function over a list, allowing the exports of each item +-- to be in scope for the rest +renameMapM :: (a -> R b) -> [a] -> R [b] +renameMapM _ [] = return [] +renameMapM f (x:xs) = do + (x', md) <- listen (f x) + xs' <- inModule md $ renameMapM f xs + return (x':xs') + +-- | Rename a program +renameProg :: Prog Raw -> R (Prog Renamed) +renameProg [$prQ| $list:ds in $opt:me1 |] = do + (ds', md) <- listen $ renameDecls ds + me1' <- inModule md $ gmapM renameExpr me1 + return [$prQ|+ $list:ds' in $opt:me1' |] + +-- | Rename a list of declarations and return the environment +-- that they bind +renameDecls :: [Decl Raw] -> R [Decl Renamed] +renameDecls = renameMapM renameDecl + +-- | Rename a declaration and return the environment that it binds +renameDecl :: Decl Raw -> R (Decl Renamed) +renameDecl d0 = withLoc d0 $ case d0 of + [$dc| let $x : $opt:mt = $e |] -> do + x' <- renamePatt x + mt' <- gmapM renameType (fmap closeType mt) + e' <- renameExpr (closeExpr e) + return [$dc|+ let $x' : $opt:mt' = $e' |] + [$dc| type $list:tds |] -> do + tds' <- renameTyDecs tds + return [$dc|+ type $list:tds' |] + [$dc| abstype $list:ats with $list:ds end |] -> do + let bindEach [$atQ| $anti:a |] = $antifail + bindEach (N _ (AbsTy _ _ [$tdQ| $anti:a |])) = $antifail + bindEach (N note at) = withLoc note $ do + let l = (tdName (dataOf (atdecl at))) + bindTycon l + return (l, getLoc note) + (llocs, mdT) <- listen $ mapM bindEach ats + case unique fst llocs of + Nothing -> return () + Just ((l, loc1), (_, loc2)) -> fail $ + "type `" ++ show l ++ "' declared twice in abstype group at " ++ + show loc1 ++ " and " ++ show loc2 + (ats', mdD) <- + steal $ + inModule mdT $ + forM ats $ \at -> withLoc at $ case dataOf at of + AbsTy variances qe td -> do + (Just qe', td') <- renameTyDec (Just qe) td + return (absTy variances qe' td' <<@ at) + AbsTyAnti a -> $antifail + -- Don't tell mdD upward, since we're censoring the datacons + ds' <- inModule (mdT `mappend` mdD) $ renameDecls ds + return [$dc|+ abstype $list:ats' with $list:ds' end |] + [$dc| module INTERNALS = $me1 |] -> + R $ local (\context -> context { allocate = False }) $ unR $ do + let u = uid "INTERNALS" + (me1', md) <- steal $ renameModExp me1 + u' <- bindModule u md + return [$dc|+ module $uid:u' = $me1' |] + [$dc| module $uid:u = $me1 |] -> do + (me1', md) <- steal $ renameModExp me1 + u' <- bindModule u md + return [$dc|+ module $uid:u' = $me1' |] + [$dc| module type $uid:u = $se1 |] -> do + (se1', md) <- steal $ renameSigExp se1 + u' <- bindSig u md + return [$dc|+ module type $uid:u' = $se1' |] + [$dc| open $me1 |] -> do + me1' <- renameModExp me1 + return [$dc|+ open $me1' |] + [$dc| local $list:ds1 with $list:ds2 end |] -> do + (ds1', md) <- steal $ renameDecls ds1 + ds2' <- inModule md $ renameDecls ds2 + return [$dc| local $list:ds1' with $list:ds2' end |] + [$dc| exception $uid:u of $opt:mt |] -> do + u' <- bindDatacon u + mt' <- gmapM renameType mt + return [$dc|+ exception $uid:u' of $opt:mt' |] + [$dc| $anti:a |] -> $antifail + +renameTyDecs :: [TyDec Raw] -> R [TyDec Renamed] +renameTyDecs tds = do + let bindEach [$tdQ| $anti:a |] = $antifail + bindEach (N note td) = withLoc note $ do + bindTycon (tdName td) + return (tdName td, getLoc note) + (llocs, md) <- listen $ mapM bindEach tds + case unique fst llocs of + Nothing -> return () + Just ((l, loc1), (_, loc2)) -> fail $ + "type `" ++ show l ++ "' declared twice in type group at " ++ + show loc1 ++ " and " ++ show loc2 + inModule md $ mapM (liftM snd . renameTyDec Nothing) tds + +renameTyDec :: Maybe (QExp Raw) -> TyDec Raw -> + R (Maybe (QExp Renamed), TyDec Renamed) +renameTyDec _ (N _ (TdAnti a)) = $antierror +renameTyDec mqe (N note (TdSyn l clauses)) = withLoc note $ do + case mqe of + Nothing -> return () + Just _ -> fail "BUG! can't rename QExp in context of type synonym" + J [] l' <- getTycon (J [] l) + clauses' <- forM clauses $ \(ps, rhs) -> withLoc ps $ do + (ps', md) <- steal $ renameTyPats ps + rhs' <- inModule md $ renameType rhs + return (ps', rhs') + return (Nothing, tdSyn l' clauses' <<@ note) +renameTyDec mqe (N note td) = withLoc note $ do + J [] l' <- getTycon (J [] (tdName td)) + let tvs = tdParams td + case unique id tvs of + Nothing -> return () + Just (tv, _) -> fail $ + "type variable " ++ show tv ++ " repeated in type parameters" + (tvs', mdTvs) <- steal $ mapM bindTyvar tvs + inModule mdTvs $ do + mqe' <- gmapM renameQExp mqe + td' <- case td of + TdAbs _ _ variances qe -> do + qe' <- renameQExp qe + return (tdAbs l' tvs' variances qe') + TdSyn _ _ -> fail "BUG! can't happen in Rename.renameTyDec" + TdDat _ _ cons -> do + case unique fst cons of + Nothing -> return () + Just ((u, _), (_, _)) -> fail $ + "repeated constructor `" ++ show u ++ "' in type declaration" + cons' <- forM cons $ \(u, mt) -> withLoc mt $ do + let u' = uid (unUid u) + tell (MdDatacon (getLoc mt) u u') + mt' <- gmapM renameType mt + return (u', mt') + return (tdDat l' tvs' cons') + TdAnti a -> $antifail + return (mqe', td' <<@ note) + +renameModExp :: ModExp Raw -> R (ModExp Renamed) +renameModExp me0 = withLoc me0 $ case me0 of + [$me| struct $list:ds end |] -> do + ds' <- renameDecls ds + return [$me|+ struct $list:ds' end |] + [$me| $quid:qu $list:_ |] -> do + (qu', md, _) <- getModule qu + let qls = getAllVariables md + tell md + return [$me|+ $quid:qu' $list:qls |] + [$me| $me1 : $se2 |] -> do + (me1', md1) <- steal $ renameModExp me1 + (se2', md2) <- steal $ renameSigExp se2 + onlyInModule md1 $ sealWith md2 + return [$me| $me1' : $se2' |] + [$me| $anti:a |] -> $antifail + +renameSigExp :: SigExp Raw -> R (SigExp Renamed) +renameSigExp se0 = withLoc se0 $ case se0 of + [$seQ| sig $list:sgs end |] -> do + (sgs', md) <- listen $ don'tAllocate $ renameMapM renameSigItem sgs + onlyInModule mempty $ checkSigDuplicates md + return [$seQ|+ sig $list:sgs' end |] + [$seQ| $quid:qu $list:_ |] -> do + (qu', md, _) <- getSig qu + let qls = getAllVariables md + tell md + return [$seQ|+ $quid:qu' $list:qls |] + [$seQ| $se1 with type $list:tvs $qlid:ql = $t |] -> do + (se1', md) <- listen $ renameSigExp se1 + ql' <- onlyInModule md $ getTycon ql + case unique id tvs of + Nothing -> return () + Just (tv, _) -> fail $ + "type variable `" ++ show tv ++ "' bound twice in `with type'" + (tvs', mdtvs) <- steal $ mapM bindTyvar tvs + t' <- inModule mdtvs $ renameType t + return [$seQ|+ $se1' with type $list:tvs' $qlid:ql' = $t' |] + [$seQ| $anti:a |] -> $antifail + +checkSigDuplicates :: Module -> R () +checkSigDuplicates md = case md of + MdNil -> return () + MdApp md1 md2 -> do + checkSigDuplicates md1 + inModule md1 $ checkSigDuplicates md2 + MdTycon loc l _ -> mustFail loc "type" l $ getTycon (J [] l) + MdVar loc l _ -> mustFail loc "variable" l $ getVar (J [] l) + MdDatacon loc u _ -> mustFail loc "constructor" u $ getDatacon (J [] u) + MdModule loc u _ _ -> mustFail loc "structure" u $ getModule (J [] u) + MdSig loc u _ _ -> mustFail loc "signature" u $ getSig (J [] u) + MdTyvar loc tv _ -> mustFail loc "tyvar" tv $ getTyvar tv + where + mustFail loc kind which check = do + failed <- (False <$ check) `M.E.catchError` \_ -> return True + unless failed $ do + withLoc loc $ + fail $ + "signature contains repeated " ++ kind ++ + " `" ++ show which ++ "'" + +sealWith :: Module -> R () +sealWith md = case md of + MdNil -> return () + MdApp md1 md2 -> do sealWith md1; sealWith md2 + MdTycon _ l _ -> do + (l', loc, _) <- find "type constructor" tycons l + tell (MdTycon loc l l') + MdVar _ l _ -> do + (l', loc, _) <- find "variable" vars l + tell (MdVar loc l l') + MdDatacon _ u _ -> do + (u', loc, _) <- find "data constructor" datacons u + tell (MdDatacon loc u u') + MdModule _ u _ md2 -> do + (u', loc, (md1, _)) <- find "module" modules u + ((), md1') <- steal $ onlyInModule md1 $ sealWith md2 + tell (MdModule loc u u' md1') + MdSig _ u _ md2 -> do + (u', loc, (md1, _)) <- find "module type" sigs u + let ctch body = body `catchError` \_ -> fail $ + "signature `" ++ show u ++ "' must match exactly" + ((), _ ) <- ctch $ steal $ onlyInModule md2 $ sealWith md1 + ((), md1') <- ctch $ steal $ onlyInModule md1 $ sealWith md2 + tell (MdSig loc u u' md1') + MdTyvar _ _ _ -> fail $ "signature can't declare type variable" + where + find what prj ident = do + m <- asks prj + case M.lookup ident m of + Just ident' -> return ident' + Nothing -> fail $ + "structure missing " ++ what ++ " `" ++ show ident ++ + "' which is present in ascribed signature" + +-- | Rename a signature item and return the environment +-- that they bind +renameSigItem :: SigItem Raw -> R (SigItem Renamed) +renameSigItem sg0 = case sg0 of + [$sgQ| val $lid:l : $t |] -> do + l' <- bindVar l + t' <- renameType (closeType t) + return [$sgQ|+ val $lid:l' : $t' |] + [$sgQ| type $list:tds |] -> do + tds' <- renameTyDecs tds + return [$sgQ|+ type $list:tds' |] + [$sgQ| module $uid:u : $se1 |] -> do + (se1', md) <- steal $ renameSigExp se1 + u' <- bindModule u md + return [$sgQ|+ module $uid:u' : $se1' |] + [$sgQ| module type $uid:u = $se1 |] -> do + (se1', md) <- steal $ renameSigExp se1 + u' <- bindSig u md + return [$sgQ|+ module type $uid:u' = $se1' |] + [$sgQ| include $se1 |] -> do + se1' <- renameSigExp se1 + return [$sgQ|+ include $se1' |] + [$sgQ| exception $uid:u of $opt:mt |] -> do + u' <- bindDatacon u + mt' <- gmapM renameType mt + return [$sgQ|+ exception $uid:u' of $opt:mt' |] + [$sgQ| $anti:a |] -> $antifail + +-- | Rename an expression +renameExpr :: Expr Raw -> R (Expr Renamed) +renameExpr e0 = withLoc e0 $ case e0 of + [$ex| $id:x |] -> case view x of + Left ql -> do + ql' <- getVar ql + let x' = fmap Var ql' + return [$ex|+ $id:x' |] + Right qu -> do + qu' <- getDatacon qu + let x' = fmap Con qu' + return [$ex|+ $id:x' |] + [$ex| $lit:lit |] -> do + lit' <- renameLit lit + return [$ex|+ $lit:lit' |] + [$ex| match $e1 with $list:cas |] -> do + e1' <- renameExpr e1 + cas' <- mapM renameCaseAlt cas + return [$ex|+ match $e1' with $list:cas' |] + [$ex| let rec $list:bns in $e |] -> do + (bns', md) <- renameBindings bns + e' <- inModule md $ renameExpr e + return [$ex|+ let rec $list:bns' in $e' |] + [$ex| let $decl:d in $e |] -> do + (d', md) <- steal $ hideTyvars $ renameDecl d + e' <- inModule md (renameExpr e) + return [$ex|+ let $decl:d' in $e' |] + [$ex| ($e1, $e2) |] -> do + e1' <- renameExpr e1 + e2' <- renameExpr e2 + return [$ex|+ ($e1', $e2') |] + [$ex| fun $x : $t -> $e |] -> do + t' <- renameType t + (x', md) <- steal $ renamePatt x + e' <- inModule md $ renameExpr e + return [$ex|+ fun $x' : $t' -> $e' |] + [$ex| $e1 $e2 |] -> do + e1' <- renameExpr e1 + e2' <- renameExpr e2 + return [$ex|+ $e1' $e2' |] + [$ex| fun '$tv -> $e |] -> do + (tv', md) <- steal $ bindTyvar tv + e' <- inModule md $ renameExpr e + return [$ex|+ fun '$tv' -> $e' |] + [$ex| $e [$t] |] -> do + e' <- renameExpr e + t' <- renameType t + return [$ex|+ $e' [$t'] |] + [$ex| Pack[$opt:mt]($t, $e) |] -> do + mt' <- gmapM renameType mt + t' <- renameType t + e' <- renameExpr e + return [$ex|+ Pack[$opt:mt']($t', $e') |] + [$ex| ( $e : $t) |] -> do + e' <- renameExpr e + t' <- renameType t + return [$ex| ( $e' : $t' ) |] + [$ex| ( $e :> $t) |] -> do + e' <- renameExpr e + t' <- renameType t + return [$ex| ( $e' :> $t' ) |] + [$ex| $anti:a |] -> $antifail + +-- | Rename a literal (no-op, except fails on antiquotes) +renameLit :: Lit -> R Lit +renameLit lit0 = case lit0 of + LtAnti a -> $antifail + _ -> return lit0 + +-- | Rename a case alternative +renameCaseAlt :: CaseAlt Raw -> R (CaseAlt Renamed) +renameCaseAlt ca0 = withLoc ca0 $ case ca0 of + [$caQ| $x -> $e |] -> do + (x', md) <- steal $ renamePatt x + e' <- inModule md $ renameExpr e + return [$caQ|+ $x' -> $e' |] + [$caQ| $antiC:a |] -> $antifail + +-- | Rename a set of let rec bindings +renameBindings :: [Binding Raw] -> R ([Binding Renamed], Module) +renameBindings bns = do + lxtes <- forM bns $ \bn -> + case bn of + [$bnQ| $lid:x : $t = $e |] -> return (_loc, x, t, e) + [$bnQ| $antiB:a |] -> $antifail + case unique (\(_,x,_,_) -> x) lxtes of + Nothing -> return () + Just ((l1,x,_,_),(l2,_,_,_)) -> fail $ + "variable `" ++ show x ++ "' bound twice in let rec at " ++ + show l1 ++ " and " ++ show l2 + let bindEach rest (l,x,t,e) = withLoc l $ do + x' <- bindVar x + return ((l,x',t,e):rest) + (lxtes', md) <- steal $ foldM bindEach [] lxtes + bns' <- inModule md $ + forM (reverse lxtes') $ \(l,x',t,e) -> withLoc l $ do + let _loc = l + t' <- renameType t + e' <- renameExpr e + return [$bnQ|+ $lid:x' : $t' = $e' |] + return (bns', md) + +-- | Rename a type +renameType :: Type Raw -> R (Type Renamed) +renameType t0 = case t0 of + [$ty| ($list:ts) $qlid:ql |] -> do + ql' <- getTycon ql + ts' <- mapM renameType ts + return [$ty|+ ($list:ts') $qlid:ql' |] + [$ty| '$tv |] -> do + tv' <- getTyvar tv + return [$ty|+ '$tv' |] + [$ty| $t1 -[$qe]> $t2 |] -> do + t1' <- renameType t1 + qe' <- renameQExp qe + t2' <- renameType t2 + return [$ty|+ $t1' -[$qe']> $t2' |] + [$ty| $quant:u '$tv. $t |] -> do + (tv', md) <- steal $ bindTyvar tv + t' <- inModule md $ renameType t + return [$ty|+ $quant:u '$tv'. $t' |] + [$ty| mu '$tv. $t |] -> do + (tv', md) <- steal $ bindTyvar tv + t' <- inModule md $ renameType t + return [$ty|+ mu '$tv'. $t' |] + [$ty| $anti:a |] -> $antifail + +-- | Rename a type pattern +renameTyPats :: [TyPat Raw] -> R [TyPat Renamed] +renameTyPats x00 = + withLoc x00 $ + M.S.evalStateT (mapM loop x00) M.empty where + loop :: TyPat Raw -> + M.S.StateT (M.Map (TyVar Raw) Loc) Renaming (TyPat Renamed) + loop x0 = case x0 of + [$tpQ| $antiP:a |] -> $antifail + N note (TpVar tv var) -> do + tv' <- tyvar (getLoc note) tv + return (tpVar tv' var <<@ note) + [$tpQ| ($list:tps) $qlid:ql |] -> do + ql' <- lift (withLoc _loc (getTycon ql)) + tps' <- mapM loop tps + return [$tpQ|+ ($list:tps') $qlid:ql' |] + -- + tyvar :: Loc -> TyVar Raw -> + M.S.StateT (M.Map (TyVar Raw) Loc) Renaming (TyVar Renamed) + tyvar loc1 tv = do + seen <- get + case M.lookup tv seen of + Just loc2 -> fail $ + "type variable " ++ show tv ++ " bound twice in type pattern at " ++ + show loc1 ++ " and " ++ show loc2 + Nothing -> do + put (M.insert tv loc1 seen) + lift (bindTyvar tv) + +-- | Rename a qualifier expression +renameQExp :: QExp Raw -> R (QExp Renamed) +renameQExp qe0 = case qe0 of + [$qeQ| $qlit:qlit |] -> do + return [$qeQ|+ $qlit:qlit |] + [$qeQ| $qvar:tv |] -> do + tv' <- getTyvar tv + return [$qeQ| $qvar:tv' |] + [$qeQ| $qdisj:qes |] -> do + qes' <- mapM renameQExp qes + return [$qeQ| $qdisj:qes' |] + [$qeQ| $qconj:qes |] -> do + qes' <- mapM renameQExp qes + return [$qeQ| $qconj:qes' |] + [$qeQ| $anti:a |] -> do + $antifail + +-- | Rename a pattern +renamePatt :: Patt Raw -> R (Patt Renamed) +renamePatt x00 = + withLoc x00 $ + M.S.evalStateT (loop x00) M.empty where + loop :: Patt Raw -> + M.S.StateT (M.Map (Either (Lid Raw) (TyVar Raw)) Loc) + Renaming (Patt Renamed) + loop x0 = case x0 of + [$pa| _ |] -> + return [$pa|+ _ |] + [$pa| $lid:l |] -> do + l' <- var _loc l + return [$pa|+ $lid:l' |] + [$pa| $quid:qu |] -> do + qu' <- lift $ getDatacon qu + return [$pa|+ $quid:qu' |] + [$pa| $quid:qu $x |] -> do + qu' <- lift $ getDatacon qu + x' <- loop x + return [$pa|+ $quid:qu' $x' |] + [$pa| ($x1, $x2) |] -> do + x1' <- loop x1 + x2' <- loop x2 + return [$pa|+ ($x1', $x2') |] + [$pa| $lit:lit |] -> do + lit' <- lift $ renameLit lit + return [$pa|+ $lit:lit' |] + [$pa| $x as $lid:l |] -> do + x' <- loop x + l' <- var _loc l + return [$pa|+ $x' as $lid:l' |] + [$pa| Pack('$tv, $x) |] -> do + tv' <- tyvar _loc tv + x' <- loop x + return [$pa|+ Pack('$tv', $x') |] + [$pa| $anti:a |] -> do + $antifail + -- + var loc1 l = do + seen <- get + case M.lookup (Left l) seen of + Just loc2 -> fail $ + "variable `" ++ show l ++ "' bound twice in pattern at " ++ + show loc1 ++ " and " ++ show loc2 + Nothing -> do + put (M.insert (Left l) loc1 seen) + lift (withLoc loc1 (bindVar l)) + -- + tyvar loc1 tv = do + seen <- get + case M.lookup (Right tv) seen of + Just loc2 -> fail $ + "type variable " ++ show tv ++ " bound twice in pattern at " ++ + show loc1 ++ " and " ++ show loc2 + Nothing -> do + put (M.insert (Right tv) loc1 seen) + lift (bindTyvar tv) + +-- | Univerally-quantify all free type variables +closeType :: Type Raw -> Type Raw +closeType t = foldr tyAll t (ftvList t) + +-- | Add type abstractions for free type variables in +-- function arguments +closeExpr :: Expr Raw -> Expr Raw +closeExpr e = foldr exTAbs e (ftvList e) + +class FtvList a where + ftvList :: a -> [TyVar Raw] + +instance FtvList a => FtvList [a] where + ftvList = foldr List.union [] . map ftvList + +instance FtvList a => FtvList (Maybe a) where + ftvList = maybe [] ftvList + +-- | Get the free type variables in a QExp, in order of appearance +instance FtvList (QExp Raw) where + ftvList qe0 = case qe0 of + [$qeQ| $qlit:_ |] -> [] + [$qeQ| '$tv |] -> [tv] + [$qeQ| $qdisj:qes |] -> ftvList qes + [$qeQ| $qconj:qes |] -> ftvList qes + [$qeQ| $anti:a |] -> $antierror + +-- | Get the free type variables in a type, in order of appearance +instance FtvList (Type Raw) where + ftvList t0 = case t0 of + [$ty| ($list:ts) $qlid:_ |] -> ftvList ts + [$ty| '$tv |] -> [tv] + [$ty| $t1 -[$qe]> $t2 |] -> + ftvList t1 `List.union` ftvList qe `List.union` ftvList t2 + [$ty| $quant:_ '$tv. $t |] -> List.delete tv (ftvList t) + [$ty| mu '$tv. $t |] -> List.delete tv (ftvList t) + [$ty| $anti:a |] -> $antierror + +instance FtvList (Expr Raw) where + ftvList e0 = case e0 of + [$ex| fun ($_ : $t) -> $e |] -> + ftvList t `List.union` ftvList e + [$ex| fun '$tv -> $e |] -> + List.delete tv (ftvList e) + _ -> [] + +addVal :: Lid Raw -> R (Lid Renamed) +addType :: Lid Raw -> Renamed -> R (Lid Renamed) +addMod :: Uid Raw -> R a -> R (Uid Renamed, a) + +addVal = bindVar + +addType l i = do + let l' = Lid i (unLid l) + loc <- R $ asks location + tell (MdTycon loc l l') + return l' + +addMod u body = do + let u' = uid (unUid u) + (a, md) <- steal body + loc <- R $ asks location + tell (MdModule loc u u' md) + return (u', a) + +-- | Result for 'getRenamingInfo' +data RenamingInfo + = ModuleAt { renInfoLoc :: Loc, renInfoQUid :: QUid Renamed } + | SigAt { renInfoLoc :: Loc, renInfoQUid :: QUid Renamed } + | VariableAt { renInfoLoc :: Loc, renInfoQLid :: QLid Renamed } + | TyconAt { renInfoLoc :: Loc, renInfoQLid :: QLid Renamed } + | DataconAt { renInfoLoc :: Loc, renInfoQUid :: QUid Renamed } + deriving Show + +-- | For the REPL to find out where identifiers are bound and their +-- renamed name for looking up type info +getRenamingInfo :: Ident Raw -> RenameState -> [RenamingInfo] +getRenamingInfo ident RenameState { savedEnv = e } = + catMaybes $ case view ident of + Left ql -> [ look tycons ql TyconAt, + look vars ql VariableAt ] + Right qu -> [ look sigs qu SigAt, + look modules qu ModuleAt, + look datacons qu DataconAt ] + where + look prj qx build = case envLookup prj qx e of + Left _ -> Nothing + Right (J ps (x', loc, _)) -> Just (build loc (J ps x')) + diff --git a/src/Sigma.hs b/src/Sigma.hs new file mode 100644 --- /dev/null +++ b/src/Sigma.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE + GeneralizedNewtypeDeriving, + PatternGuards, + ViewPatterns #-} +module Sigma ( + makeBangPatt, parseBangPatt, exSigma +) where + +import Syntax +import Util + +import qualified Control.Monad.State as CMS +import Data.Generics (Data, everywhere, mkT, extT) +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Foldable (Foldable, toList) + +-- | To lift a binder to bind effect variables rather than +-- normal variables. (Boolean specifies whether the result +-- should include the effect variables.) +exSigma :: Id i => + Bool -> + (Patt i -> Expr i -> a) -> + Patt i -> Expr i -> a +exSigma ret binder patt body = + let (b_vars, b_code) = transform (dv patt) body in + binder (ren patt) $ + exLet' (paVar r1 -:: b_vars) b_code $ + if ret + then exPair (exBVar r1) (patt2expr (ren (flatpatt patt))) + else exBVar r1 + +-- | To lift a binder to bind effect variables rather than +-- normal variables. +exAddSigma :: Id i => + Bool -> + ([Lid i] -> Patt i -> Expr i -> a) -> + S.Set (Lid i) -> Patt i -> Expr i -> a +exAddSigma ret binder env patt body = + let env' = dv patt + (b_vars, b_code) = transform (env' `S.union` env) body + vars = [ v | v <- b_vars, v `S.notMember` ren env' ] + in binder vars (ren patt) $ + exLet' (paVar r1 -:: b_vars) b_code $ + if ret + then exPair (exBVar r1) (patt2expr (ren (flatpatt patt))) +:: vars + else exBVar r1 +:: vars + +{- +---- The one variable case: + + (x is the variable name, y is the fresh state name) + + fun !(x:t) -> e === fun y:t -> [[ e ]] + let !x = e1 in e2 === let y = e1 in [[ e ]] + + [[ e1 x ]] = let (r, y) = [[ e1 ]] in + r y + [[ e1 e2 ]] = let (r1, y) = [[ e1 ]] in + let (r2, y) = [[ e2 ]] in + (r1 r2, y) + [[ x ]] = (y, ()) + [[ v ]] = (v, y) + [[ match e with + | p1 -> e1 + | ... + | pk -> ek ]] + = let (r, y) = [[ e ]] in + match r with + | p1 -> [[ e1 ]] + | ... + | pk -> [[ ek ]] + [[ e [t] ]] = let (r, y) = [[ e ]] in + (r [t], y) + [[ c e ]] = let (r, y) = [[ e ]] in + (c r, y) + +-- The pattern case (2): + + (p! is a renaming of p) + + fun !(p:t) -> e === fun p!:t -> + let (r1, e.vars) = e.code + in (r1, p!) + where e.env = dv p in + let !p = e1 in e2 === let p! = e1 in + let (r1, e.vars) = e.code + in (r1, p!) + where e.env = dv p in + + e ::= e1 p2 | dv p2 `subseteq` dv e.env && dv p2 != empty + + e1.env = e.env + e.vars = e1.vars `union` dv p2! + e.code = let (r1, e1.vars) = e1.code in + let (r2, p2!) = r1 p2! in + (r2, e.vars) + + e ::= e1 e2 + + e1.env = e2.env = e.env + e.vars = e1.vars `union` e2.vars + e.code = let (r1, e1.vars) = e1.code in + let (r2, e2.vars) = e2.code in + (r1 r2, e.vars) + + e ::= x | x `member` dv p + + e.vars = x! + e.code = (x!, ()) + + e ::= v + + e.vars = fv v `intersect` env + e.code = let e.vars = e.vars! in + (v, [ () | _ <- e.vars ]) + + e ::= match p0 with + | p1 -> e1 + | ... + | pk -> ek + | dv p0 `subseteq` dv e.env && dv p0 != empty + + if p1 is a bang pattern + then e1.env = e.env `union` dv p1 + else e1.env = e.env - (dv p1 - dv p0) + ... + if pk is a bang pattern + then ek.env = e.env `union` dv pk + else ek.env = e.env - (dv pk - dv p0) + + e.vars = e.env `intersection` (e1.vars `union` ... `union` ek.vars) + e.code = match p0! with + | p1[p0!/p0] -> let (p0 - p1)! = ((), ..., ()) in + let (r2, e1.vars) = e1.code in (r2, e.vars) + | ... + (if pk is not a bang pattern then) + | pk[p0!/p0] -> let (p0 - pk)! = ((), ..., ()) in + let (r2, e1.vars) = e1.code in (r2, e.vars) + (else) + | pk! -> let (p0 - pk)! = ((), ..., ()) in + let (r2, e1.vars) = e1.code in (r2, e.vars) + + e ::= match e0 with + | p1 -> e1 + | ... + | pk -> ek + + e0.env = e.env + e1.env = e.env - dv p1 + ... + ek.env = e.env - dv pk + + e.vars = e.env `intersection` + (e0.vars `union` e1.vars `union` ... `union` ek.vars) + e.code = let (r1, e0.vars) = e0.code in + match r1 with + | p1 -> let (r2, e1.vars) = e1.code in (r2, e.vars) + | ... + | pk -> let (r2, ek.vars) = ek.code in (r2, e.vars) + + e ::= let rec f1 = v1 + and ... + and fk = vk + in e1 + + captured = { x `in` (fv v1 `union` ... `union` fv vk) + | x! `in` e.env } + + e1.env = e.env - { f1, ..., fk } + e.vars = e1.vars `union` captured! + e.code = let captured = captured! in + let captured! = ((), ..., ()) in + let rec f1 = v1 + and ... + and fk = vk + in let (r1, e1.vars) = e1.code + in (r1, e.vars) + + e ::= e1[t] + + e1.env = e.env + e.vars = e1.vars + e.code = let (r1, e1.vars) = e1.code in + (r1[t], e.vars) + + e ::= let !p1 = e1 in e2 + + e1.env = e.env + e2.env = e.env `union` dv p1 + e.vars = e1.vars `union` (e2.vars `intersection` e.env) + e.code = let (p1!, e1.vars) = e1.code in + let (r2, e2.vars) = e2.code in + ((r2, p1!), e.vars) + [assuming no shadowing] +-} + +transform :: Id i => S.Set (Lid i) -> Expr i -> ([Lid i], Expr i) +transform env = loop where + capture e1 + | vars <- [ v | J [] v <- M.keys (fv e1), + v `S.member` env ], + code <- translate paVar (exBVar . ren) vars . + kill (ren vars) + = Just (ren vars, code) + | otherwise + = Nothing + + unop kont (e1_vars, e1_code) + | Just (k_vars, k_code) <- capture (kont exUnit), + vars <- k_vars `L.union` e1_vars, + code <- k_code $ + exLet' (paVar r1 -:: e1_vars) e1_code $ + (kont (exBVar r1) +:: vars) + = (vars, code) + unop kont ([], e1_code) + = ([], kont e1_code +:: []) + unop kont (e1_vars, e1_code) + | vars <- e1_vars, + code <- exLet' (paPair (paVar r1) (paVar r2)) e1_code $ + exPair (kont (exBVar r1)) (exBVar r2) + = (vars, code) + + binder kont (e1_vars, e1_code) + | Just (k_vars, k_code) <- capture (kont exUnit), + vars <- k_vars `L.union` e1_vars, + code <- k_code $ + kont $ + exLet' (paVar r1 -:: e1_vars) e1_code $ + (exBVar r1 +:: vars) + = (vars, code) + | vars <- e1_vars, + code <- kont e1_code + = (vars, code) + + binop kont e1 e2 = + case (loop e1, loop e2) of + (([], e1_code), ([], e2_code)) + -> ([], kont e1_code e2_code +:: []) + (([], e1_code), (e2_vars, e2_code)) + | syntacticValue e1_code, + vars <- e2_vars, + code <- exLet' (paVar r2 -:: e2_vars) e2_code $ + kont e1_code (exBVar r2) +:: vars + -> (vars, code) + ((e1_vars, e1_code), ([], e2_code)) + | syntacticValue e2_code, + vars <- e1_vars, + code <- exLet' (paVar r1 -:: e1_vars) e1_code $ + kont (exBVar r1) e2_code +:: vars + -> (vars, code) + ((e1_vars, e1_code), (e2_vars, e2_code)) + | vars <- e1_vars `L.union` e2_vars, + code <- exLet' (paVar r1 -:: e1_vars) e1_code $ + exLet' (paVar r2 -:: e2_vars) e2_code $ + kont (exBVar r1) (exBVar r2) +:: vars + -> (vars, code) + + shadow vs e = transform (env `S.difference` vs) e + + loop e = let (vars, e') = loop' e in (vars, e' <<@ e) + + loop' e = case view e of + ExId (J [] (Var x)) + | x `S.member` env, + vars <- [ren x] + -> (vars, ren (exBVar x) +:+ [exUnit]) + + ExCase e0 bs + | Just p0 <- expr2patt env S.empty e0, + not (dv p0 `disjoint` env), + e0_vars <- toList (dv (ren p0)), + e0_code <- ren e0, + bs' <- + [ case parseBangPatt pj of + Nothing -> + (renOnly (dv p0) pj, + shadow (dv pj `S.difference` dv p0) ej) + Just pj' -> + (ren pj', + transform (env `S.union` dv pj) ej) + | N _ (CaClause pj ej) <- bs ], + vars <- [ v | v <- foldl L.union e0_vars (map (fst . snd) bs'), + v `S.member` ren env ], + code <- exCase e0_code $ + [ caClause pj (kill (dv (ren p0) `S.difference` dv pj) $ + exLet' (paVar r1 -:: ej_vars) ej_code $ + (exBVar r1 +:: vars)) + | (pj, (ej_vars, ej_code)) <- bs' ] + -> (vars, code) + + | (e0_vars, e0_code) <- loop e0, + bs' <- + [ case parseBangPatt pj of + Nothing -> (pj, shadow (dv pj) ej) + Just pj' -> exAddSigma + (length bs == 1) + (\vars patt expr -> (patt, (vars, expr))) + env pj' ej + | N _ (CaClause pj ej) <- bs ], + vars <- foldl L.union e0_vars (map (fst . snd) bs'), + code <- exLet' (paVar r1 -:: e0_vars) e0_code $ + exCase (exBVar r1) $ + [ caClause pj + (exLet' (paVar r2 -:: ej_vars) ej_code $ + exBVar r2 +:: vars) + | (pj, (ej_vars, ej_code)) <- bs' ] + -> (vars, code) + + ExLetRec bs e1 + -> binder (exLetRec bs) + (shadow (S.fromList (map (bnvar . dataOf) bs)) e1) + + ExLetDecl ds e1 + -> binder (exLetDecl ds) (loop e1) + + ExPair e1 e2 + -> binop exPair e1 e2 + + ExApp e1 e2 + | Just p2 <- expr2patt env S.empty e2, + not (dv p2 `disjoint` env), + (e1_vars, e1_code) <- loop e1, + vars <- e1_vars `L.union` toList (dv (ren p2)), + (v1, f1) <- if null e1_vars + then (e1_code, id) + else (exBVar r1, + exLet' (paVar r1 -:: e1_vars) e1_code), + code <- f1 $ + exLet' (paPair (paVar r2) (flatpatt (ren p2))) + (exApp v1 (ren e2)) $ + exBVar r2 +:: vars + -> (vars, code) + + | otherwise + -> binop exApp e1 e2 + + ExTApp e1 t2 + -> unop (flip exTApp t2) (loop e1) + + ExPack mt t1 e2 + -> unop (exPack mt t1) (loop e2) + + ExCast e1 t2 b + -> unop (flip (flip exCast t2) b) (loop e1) + + _ | Just (k_vars, k_code) <- capture e + -> (k_vars, k_code $ e +:: k_vars) + + | vars <- [] + -> (vars, e +:: vars) + +(+:+) :: Id i => Expr i -> [Expr i] -> Expr i +(+:+) = foldl exPair + +(+::) :: Id i => Expr i -> [Lid i] -> Expr i +e +:: vs = e +:+ map exBVar vs + +(-:-) :: Id i => Patt i -> [Patt i] -> Patt i +(-:-) = foldl paPair + +(-::) :: Id i => Patt i -> [Lid i] -> Patt i +p -:: vs = p -:- map paVar vs + +r1, r2 :: Id i => Lid i +r1 = lid "r1.!" +r2 = lid "r2.!" + +{- +expr2vs :: Expr i -> Maybe [Lid i] +expr2vs e = case view e of + ExId (J [] (Var l)) -> return [l] + ExPair e1 e2 + | ExId (J [] (Var l)) <- view e2 -> do + vs <- expr2vs e1 + return (vs ++ [l]) + _ -> mzero +-} + +makeBangPatt :: Id i => Patt i -> Patt i +makeBangPatt p = paCon (J [] (uid "!")) (Just p) + +parseBangPatt :: Id i => Patt i -> Maybe (Patt i) +parseBangPatt (dataOf -> PaCon (J [] (Uid i "!")) mp) + | isTrivial i = mp +parseBangPatt _ = Nothing + +{- +fbvSet :: Expr i -> S.Set (Lid i) +fbvSet e = S.fromList [ lid | J [] lid <- M.keys (fv e) ] +-} + +disjoint :: Ord a => S.Set a -> S.Set a -> Bool +disjoint s1 s2 = S.null (s1 `S.intersection` s2) + +-- | Transform an expression into a pattern, if possible, using only +-- the specified variables and type variables +expr2patt :: Id i => + S.Set (Lid i) -> S.Set (TyVar i) -> Expr i -> Maybe (Patt i) +expr2patt vs0 tvs0 e0 = CMS.evalStateT (loop e0) (vs0, tvs0) where + loop e = case view e of + ExId ident -> case view ident of + Left (J [] l) -> do + sawVar l + return (paVar l) + Left (J _ _) -> mzero + Right qu -> return (paCon qu Nothing) + -- no string or integer literals + ExPair e1 e2 -> do + p1 <- loop e1 + p2 <- loop e2 + return (paPair p1 p2) + ExApp e1 e2 | + ExId ident <- view (snd (unfoldExTApp e1)), + Right qu <- view ident + -> do + p2 <- loop e2 + return (paCon qu (Just p2)) + ExTApp e1 _ -> loop e1 + ExPack Nothing (dataOf -> TyVar tv) e2 -> do + sawTyVar tv + p2 <- loop e2 + return (paPack tv p2) + _ -> mzero + + sawVar v = do + (vs, tvs) <- CMS.get + if v `S.member` vs + then CMS.put (v `S.delete` vs, tvs) + else mzero + + sawTyVar tv = do + (vs, tvs) <- CMS.get + if tv `S.member` tvs + then CMS.put (vs, tv `S.delete` tvs) + else mzero + +-- | Transform a pattern to an expression. +patt2expr :: Id i => Patt i -> Expr i +patt2expr p = case dataOf p of + PaWild -> exUnit + PaVar l -> exBVar l + PaCon u Nothing + -> exCon u + PaCon u (Just p2) + -> exApp e1 e2 where + e1 = patt2expr (paCon u Nothing) + e2 = patt2expr p2 + PaPair p1 p2 -> exPair e1 e2 where + e1 = patt2expr p1 + e2 = patt2expr p2 + PaLit lt -> exLit lt + PaAs _ l -> exBVar l + PaPack a p2 -> exPack Nothing (tyVar a) (patt2expr p2) + PaAnti a -> antierror "exSigma" a + +-- | Transform a pattern to a flattened pattern. +flatpatt :: Id i => Patt i -> Patt i +flatpatt p0 = case loop p0 of + [] -> paUnit + p:ps -> foldl paPair p ps + where + loop p = case dataOf p of + PaWild -> [] + PaVar l -> [paVar l] + PaCon _ Nothing + -> [] + PaCon _ (Just p2) + -> loop p2 + PaPair p1 p2 -> loop p1 ++ loop p2 + PaLit _ -> [] + PaAs _ l -> [paVar l] + PaPack a p2 -> [paPack a (flatpatt p2)] + PaAnti a -> antierror "exSigma" a + +ren :: Data a => a -> a +ren = everywhere (mkT eachRaw `extT` eachRen) where + eachRaw :: Lid Raw -> Lid Raw + eachRen :: Lid Renamed -> Lid Renamed + eachRaw = each; eachRen = each + each (Lid _ s) = lid (s ++ "!") + each (LidAnti a) = LidAnti a + +renOnly :: (Data a, Id i) => S.Set (Lid i) -> a -> a +renOnly set = everywhere (mkT each) where + each l | l `S.member` set = lid (unLid l ++ "!") + | otherwise = l + +{- +remove :: Data a => S.Set Lid -> a -> a +remove set = everywhere (mkT expr `extT` patt) where + patt (PaVar v) + | v `S.member` set = paUnit + patt p = p + expr :: Ident -> Ident + expr (J [] (Var v)) + | v `S.member` set = J [] (Con (Uid "()")) + expr e = e + -} + +kill :: (Id i, Foldable f) => f (Lid i) -> Expr i -> Expr i +kill = translate paVar (const exUnit) + +translate :: (Id i, Foldable f) => + (Lid i -> Patt i) -> (Lid i -> Expr i) -> + f (Lid i) -> Expr i -> Expr i +translate mkpatt mkexpr set = + case toList set of + [] -> id + v:vs -> exLet' (mkpatt v -:- map mkpatt vs) + (mkexpr v +:+ map mkexpr vs) + +exUnit :: Id i => Expr i +exUnit = exCon (quid "()") + +paUnit :: Id i => Patt i +paUnit = paCon (quid "()") Nothing + diff --git a/src/Statics.hs b/src/Statics.hs new file mode 100644 --- /dev/null +++ b/src/Statics.hs @@ -0,0 +1,1592 @@ +-- | The type checker +{-# LANGUAGE + DeriveDataTypeable, + FlexibleContexts, + FlexibleInstances, + GeneralizedNewtypeDeriving, + ImplicitParams, + MultiParamTypeClasses, + ParallelListComp, + PatternGuards, + QuasiQuotes, + ScopedTypeVariables, + TemplateHaskell, + TypeSynonymInstances, + UndecidableInstances, + ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Statics ( + -- * The type checking monad + TC, runTC, tcMapM, + -- * Static environments + S, env0, + -- ** Environment construction + addVal, addType, addMod, addDecl, + -- * Type checking + tcProg, tcDecls, + -- * Type checking results for the REPL + runTCNew, Module(..), getExnParam, tyConToDec, + getVarInfo, getTypeInfo, getConInfo, +) where + +import Meta.Quasi +import Util +import qualified Syntax +import qualified Syntax.Decl +import qualified Syntax.Expr +import qualified Syntax.Notable +import qualified Syntax.Patt +import Syntax hiding (Type, Type'(..), tyAll, tyEx, tyUn, tyAf, + tyTuple, tyUnit, tyArr, tyApp, + TyPat, TyPat'(..)) +import Loc +import Env as Env +import Ppr () +import Type +import TypeRel +import Coercion (coerceExpression) + +import Control.Monad.RWS as RWS +import Data.Data (Typeable, Data) +import Data.Generics (everywhere, mkT) +import Data.List (transpose) +import Data.Monoid +import qualified Data.Map as M +import qualified Data.Set as S + +import System.IO.Unsafe (unsafePerformIO) +pP :: Show a => a -> b -> b +pP a b = unsafePerformIO (print a) `seq` b +pM :: (Show a, Monad m) => a -> m () +pM a = if pP a True then return () else fail "wibble" + +-- The kind of names we're using. +type R = Renamed + +--- +--- Type checking environment +--- + +-- | Mapping from identifiers to value types (includes datacons) +type VE = Env (BIdent R) Type +-- | Mapping from type constructor names to tycon info +type TE = Env (Lid R) TyCon +-- | Mapping from module names to modules +type ME = Env (Uid R) (Module, E) +-- | Mapping from module type names to signatures +type SE = Env SIGVAR (Module, E) +-- | An environment +data E = E { + vlevel :: VE, -- values + tlevel :: TE, -- types + mlevel :: ME, -- modules + slevel :: SE -- module types + } + deriving (Typeable, Data) + +-- | To distinguish signature variables from module variables +-- in overloaded situations +newtype SIGVAR = SIGVAR { unSIGVAR :: Uid R } + deriving (Eq, Ord, Typeable, Data) + +instance Show SIGVAR where + showsPrec p (SIGVAR u) = showsPrec p u + +-- | A module item is empty, a pair of modules, a value entry (variable +-- or data constructor), a type constructor, or a module. +data Module + = MdNil + | MdApp !Module !Module + | MdValue !(BIdent R) !Type + | MdTycon !(Lid R) !TyCon + | MdModule !(Uid R) !Module + | MdSig !(Uid R) !Module + deriving (Typeable, Data, Show) + +-- | Convert an ordered module into an un-ordered environment +envify :: Module -> E +envify MdNil = genEmpty +envify (MdApp md1 md2) = envify md1 =+= envify md2 +envify (MdValue x t) = genEmpty =+= x =:= t +envify (MdTycon l tc) = genEmpty =+= l =:= tc +envify (MdModule u md) = genEmpty =+= u =:= (md, envify md) +envify (MdSig u md) = genEmpty =+= SIGVAR u =:= (md, envify md) + +instance Monoid Module where + mempty = MdNil + mappend = MdApp + +instance Monoid E where + mempty = E empty empty empty empty + mappend (E a1 a2 a3 a4) (E b1 b2 b3 b4) + = E (a1 =+= b1) (a2 =+= b2) (a3 =+= b3) (a4 =+= b4) + +-- Instances for generalizing environment operations over +-- the whole environment structure + +instance GenEmpty E where + genEmpty = mempty + +instance GenExtend E E where + (=+=) = mappend +instance GenExtend E VE where + e =+= ve' = e =+= E ve' empty empty empty +instance GenExtend E TE where + e =+= te' = e =+= E empty te' empty empty +instance GenExtend E ME where + e =+= me' = e =+= E empty empty me' empty +instance GenExtend E SE where + e =+= se' = e =+= E empty empty empty se' +instance GenLookup E (BIdent R) Type where + e =..= k = vlevel e =..= k +instance GenLookup E (Lid R) TyCon where + e =..= k = tlevel e =..= k +instance GenLookup E (Uid R) (Module, E) where + e =..= k = mlevel e =..= k +instance GenLookup E SIGVAR (Module, E) where + e =..= k = slevel e =..= k +instance GenLookup E k v => + GenLookup E (Path (Uid R) k) v where + e =..= J [] k = e =..= k + e =..= J (p:ps) k = do + (_, e') <- e =..= p + e' =..= J ps k + +--- +--- Type checking context and state +--- + +-- | The type checking context +data Context = Context { + environment :: !E, + modulePath :: ![Uid R] +} + +-- | The packaged-up state of the type-checker, which needs to be +-- threaded from one interaction to the next by the REPL +data S = S { + -- | The environment + sEnv :: E, + -- | Index for gensyms + currIx :: !Int + } + +instance GenLookup E k v => + GenLookup Context (Path (Uid R) k) v where + cxt =..= k = environment cxt =..= k + +instance GenExtend Context E where + cxt =+= e = cxt { environment = environment cxt =+= e } +instance GenExtend Context VE where + cxt =+= venv = cxt =+= E venv empty empty empty +instance GenExtend Context TE where + cxt =+= tenv = cxt =+= E empty tenv empty empty +instance GenExtend Context ME where + cxt =+= menv = cxt =+= E empty empty menv empty +instance GenExtend Context SE where + cxt =+= senv = cxt =+= E empty empty empty senv + +--- +--- The type-checking monad +--- + +-- | The type checking monad reads an environment, writes a module, +-- and keeps track of a gensym counter (currently unused). +newtype TC m a = TC { unTC :: RWST Context Module Int m a } + deriving (Functor, Monad) + +instance Monad m => Applicative (TC m) where + pure = return + (<*>) = ap + +instance Monad m => MonadWriter Module (TC m) where + tell = TC . tell + listen = TC . listen . unTC + pass = TC . pass . unTC + +instance Monad m => MonadReader Context (TC m) where + ask = TC ask + local f = TC . local f . unTC + +-- | Like 'ask', but monadic +asksM :: MonadReader r m => (r -> m a) -> m a +asksM = (ask >>=) + +-- | Run a type checking computation with the given initial state, +-- returning the result and the updated state +runTC :: Monad m => S -> TC m a -> m (a, S) +runTC = liftM prj <$$> runTCNew where + prj (a, _, s) = (a, s) + +-- | Run a type checking computation with the given initial state, +-- returning the result and the updated state +runTCNew :: Monad m => S -> TC m a -> m (a, Module, S) +runTCNew s action = do + let cxt = Context (sEnv s) [] + ix = currIx s + (a, ix', md) <- runRWST (unTC action) cxt ix + let e' = sEnv s =+= envify md + return (a, md, S e' ix') + +-- | Generate a fresh integer for use as a 'TyCon' id +newIndex :: Monad m => TC m Int +newIndex = TC $ do + i <- get + put (i + 1) + return i + +-- | Add a module to the current module path +enterModule :: Monad m => Uid R -> TC m a -> TC m a +enterModule u = local $ \cxt -> + cxt { modulePath = u : modulePath cxt } + +currentModulePath :: Monad m => TC m [Uid R] +currentModulePath = asks (reverse . modulePath) + +-- | Add a variable binding to the generated module +bindVar :: Monad m => Lid R -> Type -> TC m () +bindVar l t = tell (MdValue (Var l) t) + +-- | Add a data constructor binding to the generated module +bindCon :: Monad m => Uid R -> Type -> TC m () +bindCon u t = tell (MdValue (Con u) t) + +-- | Add a type constructor binding to the generated module +bindTycon :: Monad m => Lid R -> TyCon -> TC m () +bindTycon l tc = tell (MdTycon l tc) + +-- | Add a module binding to the generated module +bindModule :: Monad m => Uid R -> Module -> TC m () +bindModule u md = tell (MdModule u md) + +-- | Add a module type binding to the generated module +bindSig :: Monad m => Uid R -> Module -> TC m () +bindSig u md = tell (MdSig u md) + +-- | Run some computation with the context extended by a module +inModule :: Monad m => Module -> TC m a -> TC m a +inModule md = local (=+= envify md) + +-- | Run in the environment consisting of only the given module +onlyInModule :: Monad m => Module -> TC m a -> TC m a +onlyInModule = local (\cxt -> cxt { environment = mempty }) <$$> inModule + +-- | Grab the module generated by a computate, and generate the empty +-- module in turn +steal :: Monad m => TC m a -> TC m (a, Module) +steal = censor (const mempty) . listen + +-- | Map a function over a list, allowing the exports of each item +-- to be in scope for the rest +tcMapM :: Monad m => (a -> TC m b) -> [a] -> TC m [b] +tcMapM _ [] = return [] +tcMapM f (x:xs) = do + (x', md) <- listen (f x) + xs' <- inModule md $ tcMapM f xs + return (x':xs') + +{- -- deprecated? +-- | Abstract the given type by removing its datacon or synonym info +withoutConstructors :: Monad m => + TyCon -> TC m a -> TC m a +withoutConstructors tc = TC . M.R.local clean . unTC where + -- Note: only filters immediate scope -- should be right. + clean (TCEnv env) = TCEnv (map eachScope env) + eachScope :: Scope -> Scope + eachScope scope = genModify scope emptyPath flevel + flevel :: Level -> Level + flevel level = level { vlevel = eachVe (vlevel level) } + eachVe :: VE -> VE + eachVe = fromList . filter keep . toList + keep :: (BIdent R, Type) -> Bool + keep (Con _, TyFun _ _ (TyApp tc' _ _)) = tc' /= tc + keep (Con _, TyApp tc' _ _) = tc' /= tc + keep _ = True +-} + +-- | Try to look up any environment binding (value, tycon, ...) +find :: (Monad m, GenLookup Context k v, Show k) => + k -> TC m v +find k = asksM $ \cxt -> case cxt =..= k of + Just v -> return v + Nothing -> fail $ + "BUG! type checker got unbound identifier: " ++ show k + +-- | Try to look up any environment binding (value, tycon, ...) +tryFind :: (Monad m, GenLookup Context k v, Show k) => + k -> TC m (Maybe v) +tryFind k = asks (=..= k) + +--- +--- Type errors +--- + +-- | Raise a type error, with the dynamically-bound source location +terr :: (?loc :: Loc, Monad m) => String -> m a +terr = fail . (label ++) + where label = if isBogus ?loc + then "type error: " + else show ?loc ++ ":\ntype error: " + +-- | A type checking "assertion" raises a type error if the +-- asserted condition is false. +tassert :: (?loc :: Loc, Monad m) => + Bool -> String -> m () +tassert True _ = return () +tassert False s = terr s + +-- | A common form of type error: A got B where C expected +tgot :: (?loc :: Loc, Monad m) => + String -> Type -> String -> m a +tgot who got expected = terr $ who ++ " got " ++ show got ++ + " where " ++ expected ++ " expected" + +-- | Combination of 'tassert' and 'tgot' +tassgot :: (?loc :: Loc, Monad m) => + Bool -> String -> Type -> String -> m () +tassgot False = tgot +tassgot True = \_ _ _ -> return () + +-- | Run a partial computation, and if it fails, substitute +-- the given failure message for the one generated +(|!) :: (?loc :: Loc, Monad m) => Maybe a -> String -> m a +m |! s = case m of + Just r -> return r + _ -> terr s +infix 1 |! + +-- | Conveniently weak-head normalize a type +hnT :: Monad m => Type -> m Type +hnT = headNormalizeTypeM 100 + +-- | Check type for closed-ness and and defined-ness, and add info +tcType :: (?loc :: Loc, Monad m) => + Syntax.Type R -> TC m Type +tcType = tc where + tc :: Monad m => Syntax.Type R -> TC m Type + tc [$ty| '$tv |] = do + return (TyVar tv) + tc [$ty| $t1 -[$q]> $t2 |] = do + TyFun <$> qInterpretM q + <*> tcType t1 + <*> tcType t2 + tc [$ty| ($list:ts) $qlid:n |] = do + ts' <- mapM tc ts + tc' <- find n + checkLength (length (tcArity tc')) + checkBound (tcBounds tc') ts' + return (tyApp tc' ts') + where + checkLength len = + tassert (length ts == len) $ + "Type constructor " ++ show n ++ " applied to " ++ + show (length ts) ++ " arguments where " ++ + show len ++ " expected" + checkBound quals ts' = + tassert (all2 (\qlit t -> qualConst t <: qlit) quals ts') $ + "Type constructor " ++ show n ++ + " used at " ++ show (map (qRepresent . qualifier) ts') ++ + " where at most " ++ show quals ++ " is permitted" + tc [$ty| $quant:u '$tv . $t |] = + TyQu u tv <$> tc t + tc [$ty| mu '$tv . $t |] = do + case unfoldTyMu t of + (_, N _ (Syntax.TyVar tv')) | tv == tv' -> + terr $ "Recursive type ‘" ++ show (Syntax.tyMu tv t) ++ + "’ is not contractive." + _ -> return () + t' <- tc t + tassert (qualConst t' == tvqual tv) $ + "Recursive type " ++ show (Syntax.tyMu tv t) ++ " qualifier " ++ + "does not match its own type variable." + return (TyMu tv t') + tc [$ty| $anti:a |] = $antifail + +-- | Type check an A expression +tcExpr :: Monad m => Expr R -> TC m (Type, Expr R) +tcExpr = tc where + tc :: Monad m => Expr R -> TC m (Type, Expr R) + tc e0 = let ?loc = getLoc e0 in case e0 of + [$ex| $id:x |] -> do + tx <- find x + x' <- case view x of + Left _ -> return x + Right qu -> return (fmap Con qu) + return (tx, [$ex|+ $id:x' |]) + [$ex| $str:s |] -> return (tyString, [$ex|+ $str:s |]) + [$ex| $int:z |] -> return (tyInt, [$ex|+ $int:z |]) + [$ex| $flo:f |] -> return (tyFloat, [$ex|+ $flo:f |]) + [$ex| match $e with $list:clauses |] -> do + (t0, e') <- tc e + (t1:ts, clauses') <- liftM unzip . forM clauses $ \(N note ca) -> do + (xi', md) <- steal $ tcPatt t0 (capatt ca) + (ti, ei') <- inModule md $ tc (caexpr ca) + checkSharing "match" (caexpr ca) md + return (ti, caClause xi' ei' <<@ note) + tr <- foldM (\ti' ti -> ti' \/? ti + |! "Mismatch in match/let: " ++ show ti ++ + " and " ++ show ti') + t1 ts + return (tr, [$ex|+ match $e' with $list:clauses' |]) + [$ex| let rec $list:bsN in $e2 |] -> do + let bs = map dataOf bsN + (tfs, md) <- steal $ forM bs $ \b -> do + t' <- tcType (bntype b) + tassert (syntacticValue (bnexpr b)) $ + "Not a syntactic value in let rec: " ++ show (bnexpr b) + tassert (qualConst t' <: Qu) $ + "Affine type in let rec binding: " ++ show t' + bindVar (bnvar b) t' + return t' + (tas, e's) <- liftM unzip $ inModule md $ mapM (tc . bnexpr) bs + zipWithM_ (\tf ta -> + tassert (ta <: tf) $ + "Actual type " ++ show ta ++ + " does not agree with declared type " ++ + show tf ++ " in let rec") + tfs tas + (t2, e2') <- inModule md $ tc e2 + let b's = + zipWith3 + (\b tf e' -> newBinding b { bntype = typeToStx tf, bnexpr = e' }) + bs tfs e's + return (t2, [$ex|+ let rec $list:b's in $e2' |]) + [$ex| let $decl:d in $e2 |] -> do + (d', md) <- steal $ tcDecl d + (t2, e2') <- inModule md $ tc e2 + return (t2, [$ex|+ let $decl:d' in $e2' |]) + [$ex| ($e1, $e2) |] -> do + (t1, e1') <- tc e1 + (t2, e2') <- tc e2 + return (t1 .*. t2, [$ex|+ ($e1', $e2') |]) + [$ex| fun ($x : $t) -> $e |] -> do + t' <- tcType t + (x', md) <- steal $ tcPatt t' x + checkSharing "lambda" e md + (te, e') <- inModule md $ tc e + q <- getWorthiness e0 + return (TyFun q t' te, [$ex|+ fun ($x' : $stx:t') -> $e' |]) + [$ex| $_ $_ |] -> do + tcExApp tc e0 + [$ex| fun '$tv -> $e |] -> do + tassert (syntacticValue e) $ + "Not a syntactic value under type abstraction: " ++ show e0 + (t, e') <- tc e + return (tyAll tv t, [$ex|+ fun '$tv -> $e' |]) + [$ex| $e1 [$t2] |] -> do + (t1, e1') <- tc e1 + t2' <- tcType t2 + t1' <- tapply t1 t2' + return (t1', [$ex|+ $e1' [$stx:t2'] |]) + [$ex| Pack[$opt:mt1]($t2, $e) |] -> do + t2' <- tcType t2 + (te, e') <- tc e + t1' <- case mt1 of + Just t1 -> tcType t1 + Nothing -> return (makeExType te t2') + case t1' of + TyQu Exists tv t11' -> do + te' <- tapply (tyAll tv t11') t2' + tassert (te <: te') $ + "Could not pack type " ++ show te ++ + " (abstracting " ++ show t2 ++ + ") to get " ++ show t1' + return (t1', [$ex| Pack[$stx:t1']($stx:t2', $e') |]) + _ -> tgot "Pack[-]" t1' "ex(istential) type" + [$ex| ( $e1 : $t2 ) |] -> do + (t1, e1') <- tc e1 + t2' <- tcType t2 + tassgot (t1 <: t2') + "type ascription (:)" t1 (show t2') + return (t2', e1') + [$ex| ( $e1 :> $t2 ) |] -> do + (t1, e1') <- tc e1 + t2' <- tcType t2 + tassgot (castableType t2') + "cast (:>)" t1 "function type" + e1'' <- coerceExpression (e1' <<@ e0) t1 t2' + -- tcExpr e1'' -- re-type check the coerced expression + return (t2', e1'') + [$ex| $anti:a |] -> $antifail + [$ex| $antiL:a |] -> $antifail + -- + -- | Assert that type given to a name is allowed by its usage + checkSharing :: (Monad m, ?loc :: Loc) => + String -> Expr R -> Module -> TC m () + checkSharing name e = loop where + loop md0 = case md0 of + MdApp md1 md2 -> do loop md1; loop md2 + MdValue (Var l) t -> + tassert (qualConst t <: usage (J [] l) e) $ + "Affine variable " ++ show l ++ " : " ++ + show t ++ " duplicated in " ++ name ++ " body" + _ -> return () + -- + -- | What is the join of the qualifiers of all free variables + -- of the given expression? + getWorthiness e = + liftM bigVee . forM (M.keys (fv e)) $ \x -> do + mtx <- tryFind (fmap Var x) + return $ case mtx of + Just tx -> qualifier tx + _ -> minBound + +-- | Remove all instances of t2 from t1, replacing with +-- a new type variable +makeExType :: Type -> Type -> Type +makeExType t1 t2 = TyQu Exists tv $ everywhere (mkT erase) t1 where + tv = fastFreshTyVar (TV (lid "a") (qualConst t2)) (maxtv (t1, t2)) + erase t' = if t' == t2 then TyVar tv else t' + +-- Get the usage (sharing) of a variable in an expression: +usage :: QLid R -> Expr R -> QLit +usage x e = case M.lookup x (fv e) of + Just u | u > 1 -> Qu + _ -> Qa + +-- | Type check an application, given the type subsumption +-- relation, the appropriate type checking function, and the +-- expression to check. +-- +-- This is highly ad-hoc, as it does significant local type inference. +-- Ick. +tcExApp :: (?loc :: Loc, Monad m) => + (Expr R -> TC m (Type, Expr R)) -> + Expr R -> TC m (Type, Expr R) +tcExApp tc e0 = do + let foralls t1 ts = do + let (tvs, t1f) = vtQus Forall t1 -- peel off quantification + (tas, _) = vtFuns t1f -- peel off arg types + nargs = min (length tas) (length ts) + tup ps = foldl tyTuple tyUnit (take nargs ps) + -- try to find types to unify formals and actuals, and apply + t1' <- tryUnify tvs (tup tas) (tup ts) >>= foldM tapply t1 + arrows t1' ts + arrows tr [] = return tr + arrows t'@(view -> TyQu Forall _ _) ts = foralls t' ts + arrows (view -> TyFun _ ta tr) (t:ts) = do + b <- unifies [] t ta + tassgot b "Application (operand)" t (show ta) + arrows tr ts + arrows (view -> TyMu tv t') ts = arrows (tysubst tv (TyMu tv t') t') ts + arrows t' _ = tgot "Application (operator)" t' "function type" + unifies tvs ta tf = + case tryUnify tvs ta tf of + Just ts -> do + ta' <- foldM tapply (foldr tyAll ta tvs) ts + if (ta' <: tf) + then return True + else deeper + Nothing -> deeper + where + deeper = case ta of + TyQu Forall tv ta1 -> unifies (tvs++[tv]) ta1 tf + _ -> return False + let (es, e1) = unfoldExApp e0 -- get operator and args + (t1, e1') <- tc e1 -- check operator + (ts, es') <- unzip `liftM` mapM tc es -- check args + tr <- foralls t1 ts + return (tr, foldl exApp e1' es') + +-- | Figure out the result type of a type application, given +-- the type of the function and the argument type +tapply :: (?loc :: Loc, Monad m) => + Type -> Type -> m Type +tapply (view -> TyQu Forall tv t1') t2 = do + tassert (qualConst t2 <: tvqual tv) $ + "Type application cannot instantiate type variable " ++ + show tv ++ " with type " ++ show t2 + return (tysubst tv t2 t1') +tapply t1 _ = tgot "type application" t1 "(for)all type" + +-- Given the type of thing to match and a pattern, return +-- the type environment bound by that pattern. +tcPatt :: (?loc :: Loc, Monad m) => + Type -> Patt R -> TC m (Patt R) +tcPatt t x0 = case x0 of + [$pa| _ |] -> return x0 + [$pa| $lid:x |] -> x0 <$ bindVar x t + [$pa| $quid:u $opt:mx |] -> do + t' <- hnT t + case t' of + TyApp _ ts _ -> do + tu <- find (fmap Con u) + (params, mt, res) <- case vtQus Forall tu of + (params, TyFun _ arg res) + -> return (params, Just arg, res) + (params, res) + -> return (params, Nothing, res) + tassgot (t' <: tysubsts params ts res) + "Pattern" t' ("constructor " ++ show u) + case (mt, mx) of + (Nothing, Nothing) -> + return [$pa|+ $quid:u |] + (Just t1, Just x1) -> do + let t1' = tysubsts params ts t1 + x1' <- tcPatt t1' x1 + return [$pa|+ $quid:u $x1' |] + _ -> tgot "Pattern" t "wrong arity" + _ | isBotType t' -> case mx of + Nothing -> return x0 + Just x -> tcPatt tyBot x + | otherwise -> tgot "Pattern" t' ("constructor " ++ show u) + [$pa| ($x, $y) |] -> do + t' <- hnT t >>! mapBottom (tyApp tcTuple . replicate 2) + case t' of + TyApp tc [xt, yt] _ | tc == tcTuple -> do + x' <- tcPatt xt x + y' <- tcPatt yt y + return [$pa| ($x', $y') |] + _ -> tgot "Pattern " t' "pair type" + [$pa| $str:_ |] -> do + tassgot (t <: tyString) + "Pattern" t "string" + return x0 + [$pa| $int:_ |] -> do + tassgot (t <: tyInt) + "Pattern" t "int" + return x0 + [$pa| $flo:_ |] -> do + tassgot (t <: tyFloat) + "Pattern" t "float" + return x0 + [$pa| $x as $lid:y |] -> do + x' <- tcPatt t x + bindVar y t + return [$pa| $x' as $lid:y |] + [$pa| Pack('$tv, $x) |] -> do + t' <- hnT t >>! mapBottom (tyEx tv) + case t' of + TyQu Exists tve te -> do + tassert (tvqual tve <: tvqual tv) $ + "Cannot bind existential tyvar " ++ show tv ++ + " to " ++ show tve + let te' = tysubst tve (TyVar tv) te + x' <- tcPatt te' x + return [$pa| Pack('$tv, $x') |] + _ -> tgot "Pattern" t' "existential type" + [$pa| $antiL:a |] -> $antifail + [$pa| $anti:a |] -> $antifail + +-- | Check if type is bottom, and if so, apply the given function +-- to it +mapBottom :: (Type -> Type) -> Type -> Type +mapBottom ft t + | isBotType t = ft t + | otherwise = t + +-- Given a list of type variables tvs, a type t in which tvs +-- may be free, and a type t', tries to substitute for tvs in t +-- to produce a type that *might* unify with t' +tryUnify :: (?loc :: Loc, Monad m) => + [TyVarR] -> Type -> Type -> m [Type] +tryUnify [] _ _ = return [] +tryUnify tvs t t' = + case subtype 100 [] t' tvs t of + Left s -> giveUp (s :: String) + Right (_, ts) -> return ts + where + giveUp _ = terr $ + "\nCannot guess type" ++ + (if length tvs == 1 then " t1" else "s t1, .., t" ++ show (length tvs)) + ++ " such that\n " ++ showsPrec 10 t "" ++ + concat [ "[t" ++ show i ++ "/" ++ show tv ++ "]" + | tv <- tvs | i <- [ 1.. ] :: [Integer] ] ++ + "\n >: " ++ show t' + +-- | Convert qualset representations from a list of all tyvars and +-- list of qualifier-significant tyvars to a set of type parameter +-- indices +indexQuals :: (?loc :: Loc, Monad m) => + Lid R -> [TyVarR] -> QExp R -> TC m (QDen Int) +indexQuals name tvs qexp = do + qden <- qInterpretM qexp + numberQDenM unbound tvs qden where + unbound tv = terr $ "unbound tyvar " ++ show tv ++ + " in qualifier list for type " ++ show name + +-- BEGIN type decl checking + +-- | Run a computation in the context of type declarations +tcTyDecs :: (?loc :: Loc, Monad m) => + [TyDec R] -> TC m [TyDec R] +tcTyDecs tds0 = do + let (atds, stds, dtds) = foldr partition ([], [], []) tds0 + -- stds <- topSort getEdge stds0 + (_, stub) <- steal $ forM (atds ++ dtds ++ stds) $ \td0 -> + case dataOf td0 of + TdDat name params _ -> allocStub name (map tvqual params) + TdSyn name ((ps,_):_) -> allocStub name (map (const Qa) ps) + TdAbs name params variances quals -> do + quals' <- indexQuals name params quals + ix <- newIndex + us <- currentModulePath + let tc' = mkTC ix (J us name) quals' + [ (tvqual parm, var) + | var <- variances + | parm <- params ] + bindTycon name tc' + _ -> return () + let loop md = do + ((changed, tcs), md') <- + steal $ + inModule md $ + liftM unzip $ + mapM tcTyDec (atds ++ dtds ++ stds) + if or changed + then loop md' + else return (tcs, md') + in do + (tcs, md') <- loop stub + forM_ tcs $ \tc -> do + case tcNext tc of + Nothing -> return () + Just clauses -> forM_ clauses $ \(tps, rhs) -> + tassert (rhs /= tyPatToType (TpApp tc {tcNext = Nothing} tps)) $ + "Type synonym ‘" ++ show tc ++ "’ is not contractive." + tell (replaceTyCons tcs md') + return tds0 + where + allocStub name params = do + ix <- newIndex + us <- currentModulePath + let tc = mkTC ix (J us name) + [ (q, Omnivariant) | q <- params ] + bindTycon name tc + -- + getEdge td0 = case dataOf td0 of + TdSyn name cs -> (name, S.unions (map (tyConsOfType . snd) cs)) + TdAbs name _ _ _ -> (name, S.empty) + TdDat name _ alts -> (name, names) where + names = S.unions [ tyConsOfType t | (_, Just t) <- alts ] + TdAnti a -> $antierror + -- + partition td (atds, stds, dtds) = + case dataOf td of + TdAbs _ _ _ _ -> (td : atds, stds, dtds) + TdSyn _ _ -> (atds, td : stds, dtds) + TdDat _ _ _ -> (atds, stds, td : dtds) + TdAnti a -> $antierror + +-- tcTyDec types a type declaration, but in addition to +-- returnng a declaration, it returns a boolean that indicates +-- whether the type metadata has changed, which allows for iterating +-- to a fixpoint. +tcTyDec :: (?loc :: Loc, Monad m) => + TyDec R -> TC m (Bool, TyCon) +tcTyDec td0 = case dataOf td0 of + TdAbs name _ _ _ -> do + tc <- find (J [] name :: QLid R) + bindTycon name tc + return (False, tc) + TdSyn name cs -> do + tc <- find (J [] name :: QLid R) + let nparams = length (fst (head cs)) + tassert (all ((==) nparams . length . fst) cs) $ + "all type operator clauses have the same number of parameters" + (cs', quals, vqs) <- liftM unzip3 $ forM cs $ \(tps, rhs) -> do + rhs' <- tcType rhs + let vs1 = ftvVs rhs' + (tps', tvses, vqs) <- liftM unzip3 $ forM tps $ \tp -> do + tp' <- tcTyPat tp + let tpt = tyPatToType tp' + vs2 = ftvVs tpt + vs' = M.intersectionWith (*) vs1 vs2 + var = bigVee (M.elems vs') + qp = qualConst tpt + tvs = qDenFtv (qualifier tpt) + return (tp', tvs, (var, qp)) + let tvmap = M.unions [ M.fromDistinctAscList + [ (tv, i) | tv <- S.toAscList tvs ] + | tvs <- tvses + | i <- [ 0 .. ] ] + qual = numberQDenMap tvqual tvmap (qualifier rhs') + return ((tps', rhs'), qual, vqs) + let (arity, bounds) = unzip (map bigVee (transpose vqs)) + qual = bigVee quals + changed = arity /= tcArity tc + || qual /= tcQual tc + tc' = tc { tcArity = arity, tcQual = qual, + tcNext = Just cs', tcBounds = bounds } + bindTycon name tc' + return (changed, tc') + TdDat name params alts -> do + tc <- find (J [] name :: QLid R) + alts' <- sequence + [ case mt of + Nothing -> return (cons, Nothing) + Just t -> do + t' <- tcType t + return (cons, Just t') + | (cons, mt) <- alts ] + let t' = foldl tyTuple tyUnit [ t | (_, Just t) <- alts' ] + qual = numberQDen params (qualifier t') + arity = typeVariances params t' + changed = arity /= tcArity tc + || qual /= tcQual tc + tc' = tc { tcArity = arity, tcQual = qual, + tcCons = (params, fromList alts') } + bindTycon name tc' + bindAlts params tc' alts' + return (changed, tc') + TdAnti a -> $antifail + +-- | Build a module of datacon types from a datatype's +-- alternatives +bindAlts :: Monad m => [TyVarR] -> TyCon -> [(Uid R, Maybe Type)] -> TC m () +bindAlts params tc = mapM_ each where + each (u, Nothing) = bindCon u (alls result) + each (u, Just t) = bindCon u (alls (t .->. result)) + alls t = foldr tyAll t params + result = tyApp tc (map TyVar params) + +-- | Compute the variances at which some type variables occur +-- in an open type expression +typeVariances :: [TyVarR] -> Type -> [Variance] +typeVariances d0 = finish . ftvVs where + finish m = [ maybe 0 id (M.lookup tv m) + | tv <- d0 ] + +-- | Generic topological sort +-- +-- Uses an adjacency-list graph representation. Given a +-- function from abstract node values to comparable nodes, +-- and a list of node values, returns a list of node values (or +-- fails if there's a cycle). +topSort :: forall node m a. + (?loc :: Loc, Monad m, Ord node, Show node) => + (a -> (node, S.Set node)) -> [a] -> m [a] +topSort getEdge edges = do + (_, w) <- RWS.execRWST visitAll S.empty S.empty + return w + where + visitAll = mapM_ visit (M.keys graph) + -- + visit :: node -> RWS.RWST (S.Set node) [a] (S.Set node) m () + visit node = do + stack <- RWS.ask + tassert (not (node `S.member` stack)) $ + "unproductive cycle in type definitions, via type " ++ show node + seen <- RWS.get + if node `S.member` seen + then return () + else do + RWS.put (S.insert node seen) + case M.lookup node graph of + Just (succs, info) -> do + RWS.local (S.insert node) $ + mapM_ visit succs + RWS.tell [info] + Nothing -> + return () + -- + graph :: M.Map node ([node], a) + graph = M.fromList [ let (node, succs) = getEdge info + in (node, (S.toList succs, info)) + | info <- edges ] + +-- | The (unqualified) tycons that appear in a syntactic type +tyConsOfType :: Syntax.Type R -> S.Set (Lid R) +tyConsOfType [$ty| ($list:ts) $qlid:n |] = + case n of + J [] l -> S.singleton l + _ -> S.empty + `S.union` S.unions (map tyConsOfType ts) +tyConsOfType [$ty| '$_ |] = S.empty +tyConsOfType [$ty| $t1 -[$_]> $t2 |] = + tyConsOfType t1 `S.union` tyConsOfType t2 +tyConsOfType [$ty| $quant:_ '$_. $t |] = tyConsOfType t +tyConsOfType [$ty| mu '$_. $t |] = tyConsOfType t +tyConsOfType [$ty| $anti:a |] = $antierror + +tcTyPat :: Monad m => Syntax.TyPat R -> TC m TyPat +tcTyPat (N note (Syntax.TpVar tv var)) = do + let ?loc = getLoc note + tassert (var == Invariant) $ + "type pattern variable " ++ show tv ++ + " cannot have a variance annotation" + return (TpVar tv) +tcTyPat tp@[$tpQ| ($list:tps) $qlid:qu |] = do + let ?loc = _loc + tc <- find qu + tassert (isNothing (tcNext tc)) $ + "type operator pattern `" ++ show tp ++ + "' cannot also be a type operator" + TpApp tc <$> mapM tcTyPat tps +tcTyPat [$tpQ| $antiP:a |] = $antifail + +-- END type decl checking + +-- | Type check a module body +tcSigExp :: (?loc :: Loc, Monad m) => + SigExp R -> TC m (SigExp R) +tcSigExp [$seQ| sig $list:ds end |] = do + ds' <- tcMapM tcSigItem ds + return [$seQ| sig $list:ds' end |] +tcSigExp [$seQ| $quid:n $list:qls |] = do + (md, _) <- find (fmap SIGVAR n) + tell md + return [$seQ| $quid:n $list:qls |] +tcSigExp [$seQ| $se1 with type $list:tvs $qlid:tc = $t |] = do + (se1', md) <- steal $ tcSigExp se1 + t' <- tcType t + fibrate tvs tc t' md + return [$seQ| $se1' with type $list:tvs $qlid:tc = $t |] +tcSigExp [$seQ| $anti:a |] = $antifail + +fibrate :: (?loc :: Loc, Monad m) => + [TyVar R] -> QLid R -> Type -> Module -> TC m () +fibrate tvs ql t md = do + let Just tc = findTycon ql md + tassert (isAbstractTyCon tc) $ + "with-type: cannot update concrete type constructor `" ++ + show ql + tassert (length tvs == length (tcArity tc)) $ + "with-type: " ++ show (length tvs) ++ + " parameters for type " ++ show ql ++ + " which has " ++ show (length (tcArity tc)) + let amap = ftvVs t + arity = map (\tv -> fromJust (M.lookup tv amap)) tvs + bounds = map tvqual tvs + qual = numberQDen tvs (qualifier t) + next = Just [(map TpVar tvs, t)] + tc' = tc { + tcArity = arity, + tcBounds = bounds, + tcQual = qual, + tcNext = next + } + tell (replaceTyCon tc' md) + where + findTycon ql0 md0 = case md0 of + MdNil -> mzero + MdApp md1 md2 -> findTycon ql0 md1 `mplus` findTycon ql0 md2 + MdTycon l tc -> if J [] l == ql0 then return tc else mzero + MdModule u md1 -> case ql0 of + J (u':us) l | u == u' -> findTycon (J us l) md1 + _ -> mzero + MdSig _ _ -> mzero + MdValue _ _ -> mzero + +tcSigItem :: (?loc :: Loc, Monad m) => + SigItem R -> TC m (SigItem R) +tcSigItem sg0 = case sg0 of + [$sgQ| val $lid:l : $t |] -> do + t' <- tcType t + bindVar l t' + return [$sgQ| val $lid:l : $t |] + [$sgQ| type $list:tds |] -> do + tds' <- tcTyDecs tds + return [$sgQ| type $list:tds' |] + [$sgQ| module $uid:u : $se1 |] -> do + (se', md) <- steal $ tcSigExp se1 + bindModule u md + return [$sgQ| module $uid:u : $se' |] + [$sgQ| module type $uid:u = $se1 |] -> do + se' <- tcSig u se1 + return [$sgQ| module type $uid:u = $se' |] + [$sgQ| include $se1 |] -> do + se' <- tcSigExp se1 + return [$sgQ| include $se' |] + [$sgQ| exception $uid:u of $opt:mt |] -> do + mt' <- tcException u mt + return [$sgQ| exception $uid:u of $opt:mt' |] + [$sgQ| $anti:a |] -> $antifail + +-- | Run a computation in the context of a let declaration +tcLet :: (?loc :: Loc, Monad m) => + Patt R -> Maybe (Syntax.Type R) -> Expr R -> + TC m (Patt R, Maybe (Syntax.Type R), Expr R) +tcLet x mt e = do + tassert (S.null (dtv x)) $ + "Cannot unpack existential in top-level binding" + (te, e') <- tcExpr e + t' <- case mt of + Just t -> do + t' <- tcType t + tassert (qualConst t' == Qu) $ + "Declared type of top-level binding " ++ show x ++ " is not unlimited" + tassert (te <: t') $ + "Declared type for top-level binding " ++ show x ++ " : " ++ show t' ++ + " is not subsumed by actual type " ++ show te + return t' + Nothing -> do + tassert (qualConst te == Qu) $ + "Type of top-level binding `" ++ show x ++ "' is not unlimited" + return te + x' <- tcPatt t' x + return (x', Just (typeToStx t'), e') + +-- | Run a computation in the context of a module open declaration +tcOpen :: (?loc :: Loc, Monad m) => + ModExp R -> TC m (ModExp R) +tcOpen b = tcModExp b + +-- | Run a computation in the context of a local block (that is, after +-- the block) +tcLocal :: (?loc :: Loc, Monad m) => + [Decl R] -> [Decl R] -> + TC m ([Decl R], [Decl R]) +tcLocal ds1 ds2 = do + (ds1', md1) <- steal $ tcDecls ds1 + ds2' <- inModule md1 $ tcDecls ds2 + return (ds1', ds2') + +-- | Run a computation in the context of a new exception variant +tcException :: (?loc :: Loc, Monad m) => + Uid R -> Maybe (Syntax.Type R) -> + TC m (Maybe (Syntax.Type R)) +tcException n mt = do + mt' <- gmapM tcType mt + bindCon n (maybe tyExn (`tyArr` tyExn) mt') + return (fmap typeToStx mt') + +-- | Type check and bind a module +tcMod :: (?loc :: Loc, Monad m) => + Uid R -> ModExp R -> TC m (ModExp R) +tcMod u me0 = do + (me', md) <- steal $ enterModule u $ tcModExp me0 + bindModule u md + return me' + +-- | Type check and bind a signature +tcSig :: (?loc :: Loc, Monad m) => + Uid R -> SigExp R -> TC m (SigExp R) +tcSig u se0 = do + (se', md) <- steal $ tcSigExp se0 + bindSig u md + return se' + +{- +-- | Determine types that are no longer reachable by name +-- in a given scope, and give them an ugly printing name +hideInvisible :: Monad m => + Scope -> TC m Scope +hideInvisible (PEnv modenv level) = do + level' <- withAny level $ everywhereM (mkM repair) level + withAny level' $ do + ((), modenv') <- mapAccumM + (\scope acc -> do + scope' <- hideInvisible scope + return (acc, scope')) + () modenv + return (PEnv modenv' level') + where + repair :: Monad m => Type -> TC m Type + repair t@(TyApp tc ts cache) = do + mtc <- tryGetAny (tcName tc) + return $ if mtc == Just tc + then t + else TyApp (hide tc) ts cache + repair t = return t + -- + hide :: TyCon -> TyCon + hide tc@TyCon { tcName = J (Uid _ "?" : _) _ } = tc + hide tc@TyCon { tcName = J qs (Lid _ k), tcId = i } = + tc { tcName = J (Uid "?":qs) (Lid _ (k ++ ':' : show i)) } + +-- | Replace the printing name of each type with the shortest +-- path to access that type. (So unnecessary!) +requalifyTypes :: [Uid R] -> E -> E +requalifyTypes _uids env = map (fmap repairLevel) env where + repairLevel :: Level -> Level + repairLevel level = everywhere (mkT repair) level + -- + repair :: TypeT -> TypeT + repair t@(TyCon { }) = case tyConsInThisEnv -.- ttId (tyinfo t) of + Nothing -> t + Just name -> t `setTycon` name + repair t = t + -- + tyConsInThisEnv :: Env Integer (QLid R) + tyConsInThisEnv = uids <...> foldr addToScopeMap empty env + -- + addToScopeMap :: Scope -> Env Integer (QLid R) -> Env Integer (QLid R) + addToScopeMap (PEnv ms level) acc = + foldr (Env.unionWith chooseQLid) acc + (makeLevelMap level : + [ uid <..> addToScopeMap menv empty + | (uid, menv) <- toList ms ]) + -- + makeLevelMap (Level _ ts) = + fromList [ (ttId tag, J [] lid) + | (lid, info) <- toList ts, + tag <- tagOfTyInfo info ] + -- + tagOfTyInfo (TiAbs tag) = [tag] + tagOfTyInfo (TiSyn _ _) = [] + tagOfTyInfo (TiDat tag _ _) = [tag] + tagOfTyInfo TiExn = [tdExn] + -- + chooseQLid :: QLid R -> QLid R -> QLid R + chooseQLid q1@(J p1 _) q2@(J p2 _) + | length p1 < length p2 = q1 + | otherwise = q2 + -- + (<..>) :: Functor f => p -> f (Path p k) -> f (Path p k) + (<..>) = fmap . (<.>) + -- + (<...>) :: Functor f => [p] -> f (Path p k) -> f (Path p k) + (<...>) = flip $ foldr (<..>) +-} + +-- | Type check a module body +tcModExp :: (?loc :: Loc, Monad m) => + ModExp R -> TC m (ModExp R) +tcModExp [$me| struct $list:ds end |] = do + ds' <- tcDecls ds + return [$me| struct $list:ds' end |] +tcModExp [$me| $quid:n $list:qls |] = do + (md, _) <- find n + tell md + return [$me| $quid:n $list:qls |] +tcModExp [$me| $me1 : $se2 |] = do + (me1', md1) <- steal $ tcModExp me1 + (se2', md2) <- steal $ tcSigExp se2 + ascribeSignature md1 md2 + return [$me| $me1' : $se2' |] +tcModExp [$me| $anti:a |] = $antifail + +-- | Run a computation in the context of an abstype block +tcAbsTy :: (?loc :: Loc, Monad m) => + [AbsTy R] -> [Decl R] -> + TC m ([AbsTy R], [Decl R]) +tcAbsTy atds ds = do + (_, md1) <- steal $ tcTyDecs (map (atdecl . dataOf) atds) + (ds', md2) <- steal $ inModule md1 $ tcDecls ds + tcs <- forM atds $ \at0 -> case view at0 of + AbsTy arity quals (N _ (TdDat name params _)) -> do + let env = envify md1 + tc = fromJust (env =..= name) + qualSet <- indexQuals name params quals + tassert (length params == length (tcArity tc)) $ + "abstract-with-end: " ++ show (length params) ++ + " given for type " ++ show name ++ + " which has " ++ show (length (tcArity tc)) + tassert (all2 (<:) (tcArity tc) arity) $ + "abstract-with-end: declared arity for type " ++ show name ++ + ", " ++ show arity ++ + ", is more general than actual arity " ++ show (tcArity tc) + tassert (tcQual tc <: qualSet) $ + "abstract-with-end: declared qualifier for type " ++ show name ++ + ", " ++ show qualSet ++ + ", is more general than actual qualifier " ++ show (tcQual tc) + return $ abstractTyCon tc { + tcQual = qualSet, + tcArity = arity, + tcCons = ([], empty) + } + _ -> terr "(BUG) Can't abstract non-datatypes" + tell (replaceTyCons tcs (md1 `mappend` md2)) + return (atds, ds') + +-- | Type check a declaration +tcDecl :: Monad m => Decl R -> TC m (Decl R) +tcDecl decl = + let ?loc = getLoc decl in + case decl of + [$dc| let $x : $opt:t = $e |] -> do + (x', t', e') <- tcLet x t e + return [$dc| let $x' : $opt:t' = $e' |] + [$dc| type $list:tds |] -> do + tds' <- tcTyDecs tds + return [$dc| type $list:tds' |] + [$dc| abstype $list:at with $list:ds end |] -> do + (at', ds') <- tcAbsTy at ds + return [$dc| abstype $list:at' with $list:ds' end |] + [$dc| module $uid:x = $b |] -> do + b' <- tcMod x b + return [$dc| module $uid:x = $b' |] + [$dc| module type $uid:x = $b |] -> do + b' <- tcSig x b + return [$dc| module type $uid:x = $b' |] + [$dc| open $b |] -> do + b' <- tcOpen b + return [$dc| open $b' |] + [$dc| local $list:ds0 with $list:ds1 end |] -> do + (ds0', ds1') <- tcLocal ds0 ds1 + return [$dc| local $list:ds0' with $list:ds1' end |] + [$dc| exception $uid:n of $opt:mt |] -> do + mt' <- tcException n mt + return [$dc| exception $uid:n of $opt:mt' |] + [$dc| $anti:a |] -> $antifail + +-- | Type check a sequence of declarations +tcDecls :: Monad m => [Decl R] -> TC m [Decl R] +tcDecls = tcMapM tcDecl + +--- +--- Module sealing +--- + +-- | For mapping renamed names (from structures) into unrenamed names +-- (in signatures) +data NameMap + = NameMap { + nmValues :: Env (BIdent R) (BIdent R), + nmTycons :: Env (Lid R) (Lid R), + nmModules :: Env (Uid R) (Uid R, NameMap), + nmSigs :: Env (Uid R) (Uid R) + } + +instance Monoid NameMap where + mempty = NameMap empty empty empty empty + mappend (NameMap a1 a2 a3 a4) (NameMap b1 b2 b3 b4) = + NameMap (a1 =+= b1) (a2 =+= b2) (a3 =+= b3) (a4 =+= b4) where + +instance GenEmpty NameMap where + genEmpty = mempty +instance GenExtend NameMap NameMap where + (=+=) = mappend +instance GenLookup NameMap (BIdent R) (BIdent R) where + e =..= k = nmValues e =..= k +instance GenLookup NameMap (Lid R) (Lid R) where + e =..= k = nmTycons e =..= k +instance GenLookup NameMap (Uid R) (Uid R, NameMap) where + e =..= k = nmModules e =..= k +instance GenLookup NameMap SIGVAR (Uid R) where + e =..= k = nmSigs e =..= unSIGVAR k + +-- | Given a module, construct a 'NameMap' mapping raw versions of its +-- names to the actual renamed version. +makeNameMap :: Module -> NameMap +makeNameMap md0 = case md0 of + MdNil -> mempty + MdApp md1 md2 -> makeNameMap md1 =+= makeNameMap md2 + MdValue x _ -> mempty { nmValues = unnameBIdent x =:= x } + MdTycon x _ -> mempty { nmTycons = unnameLid x =:= x } + MdModule x md1 -> mempty { nmModules = unnameUid x =:= (x, makeNameMap md1) } + MdSig x _ -> mempty { nmSigs = unnameUid x =:= x } + where + unnameLid :: Lid R -> Lid R + unnameLid = lid . unLid + unnameUid :: Uid R -> Uid R + unnameUid = uid . unUid + unnameBIdent :: BIdent R -> BIdent R + unnameBIdent (Var l) = Var (unnameLid l) + unnameBIdent (Con u) = Con (unnameUid u) + +-- | Given a module and a signature, ascribe the signature to the module +-- and write the result. +ascribeSignature :: (?loc :: Loc, Monad m) => + Module -> Module -> TC m () +ascribeSignature md1 md2 = do + let md2' = renameSig (makeNameMap md1) md2 + onlyInModule md1 $ do + subst <- matchSigTycons md2' + subsumeSig (applyTyConSubstInSig subst md2') + let tcs = getGenTycons md2' [] + tcs' <- forM tcs $ \tc -> do + ix <- newIndex + return tc { tcId = ix } + tell (substTyCons tcs tcs' md2') + +-- | Make the names in a signature match the names from the module it's +-- being applied to. +renameSig :: NameMap -> Module -> Module +renameSig nm0 = loop where + loop md0 = case md0 of + MdNil -> MdNil + MdApp md1 md2 -> MdApp (loop md1) (loop md2) + MdValue x t -> MdValue (fromJust (nm0 =..= x)) t + MdTycon x tc -> MdTycon (fromJust (nm0 =..= x)) tc + MdModule x md1 -> + let Just (x', nm1) = nm0 =..= x + in MdModule x' (renameSig nm1 md1) + MdSig x md1 -> MdSig (fromJust (nm0 =..= SIGVAR x)) md1 + +-- | Given a signature, find the tycon substitutions necessary to +-- unify it with the module in the environment. +matchSigTycons :: Monad m => Module -> TC m TyConSubst +matchSigTycons = loop [] where + loop path md0 = case md0 of + MdNil -> return mempty + MdApp md1 md2 -> mappend <$> loop path md1 <*> loop path md2 + MdValue _ _ -> return mempty + MdTycon x tc -> do + tc' <- find (J path x) + return (makeTyConSubst [tc] [tc']) + MdModule x md1 -> loop (path++[x]) md1 + MdSig _ _ -> return mempty + +-- | Given a tycon substitution, apply it to all the values and +-- RIGHT-HAND-SIDES of type definitions in a signature. In +-- particular, don't replace any tycon bindings directly, but do +-- replace any references to other types in their definitions. +applyTyConSubstInSig :: TyConSubst -> Module -> Module +applyTyConSubstInSig subst = loop where + loop md0 = case md0 of + MdNil -> MdNil + MdApp md1 md2 -> MdApp (loop md1) (loop md2) + MdValue x t -> MdValue x (applyTyConSubst subst t) + MdTycon x tc -> MdTycon x (applyTyConSubstInTyCon subst tc) + MdModule x md1 -> MdModule x (loop md1) + MdSig x md1 -> MdSig x (loop md1) + +-- | Get a list of all the tycons that need a new index allocated +-- because they're generative. +getGenTycons :: Module -> [TyCon] -> [TyCon] +getGenTycons = loop where + loop MdNil = id + loop (MdApp md1 md2) = loop md1 . loop md2 + loop (MdValue _ _) = id + loop (MdTycon _ tc) = if varietyOf tc == OperatorType + then id + else (tc:) + loop (MdModule _ md1) = loop md1 + loop (MdSig _ _) = id + +-- | Check whether the given signature subsumes the signature +-- implicit in the environment; takes a 'NameMap' mapping un-renamed +-- signature names to renamed environment names. +subsumeSig :: (?loc :: Loc, Monad m) => + Module -> TC m () +subsumeSig = loop where + loop md0 = case md0 of + MdNil -> return () + MdApp md1 md2 -> do loop md1; loop md2 + MdValue x t -> do + t' <- find (J [] x :: Ident R) + tassgot (t' <: t) + ("in signature matching, variable `"++show x++"'") t' (show t) + MdTycon x tc -> do + tc' <- find (J [] x :: QLid R) + case varietyOf tc of + AbstractType -> do + tassert (length (tcArity tc') == length (tcArity tc)) $ + "in signature matching, cannot match type definition for " ++ + show (tcName tc) ++ " because the actual number of type " ++ + "parameters (" ++ show (length (tcArity tc')) ++ + " does not match the expected number (" ++ + show (length (tcArity tc)) ++ "(" + tassert (all2 (<:) (tcArity tc') (tcArity tc)) $ + "in signature matching, cannot match type definition for " ++ + show (tcName tc) ++ " because actual variance " ++ + show (tcArity tc') ++ + " is less general than expected variance " ++ + show (tcArity tc) + tassert (all2 (<:) (tcBounds tc') (tcBounds tc)) $ + "in signature matching, cannot match type definition for " ++ + show (tcName tc) ++ " because actual parameter bounds " ++ + show (tcBounds tc') ++ + " is less general than expected parameter bounds " ++ + show (tcBounds tc) + tassert (tcQual tc' <: tcQual tc) $ + "in signature matching, cannot match type definition for " ++ + show (tcName tc) ++ " because actual qualifier " ++ + show (tcQual tc') ++ + " is less general than expected qualifier " ++ + show (tcQual tc) + OperatorType -> matchTycons tc' tc + DataType -> matchTycons tc' tc + MdModule x md1 -> do + (md2, _) <- find (J [] x :: QUid R) + onlyInModule md2 $ subsumeSig md1 + MdSig x md1 -> do + (md2, _) <- find (J [] (SIGVAR x) :: Path (Uid R) SIGVAR) + matchSigs md2 md1 + +-- | Check that two signatures match EXACTLY. +matchSigs :: (?loc :: Loc, Monad m) => + Module -> Module -> TC m () +matchSigs md10 md20 = loop (linearize md10 []) (linearize md20 []) where + loop [] [] = return () + loop (MdValue x1 t1 : sgs1) (MdValue x2 t2 : sgs2) + | x1 == x2 && t1 == t2 = loop sgs1 sgs2 + loop (MdTycon x1 tc1 : sgs1) (MdTycon x2 tc2 : sgs2) + | x1 == x2 = do + matchTycons tc1 tc2 + loop (substTyCon tc1 tc2 sgs1) sgs2 + loop (MdModule x1 md1 : sgs1) (MdModule x2 md2 : sgs2) + | x1 == x2 = do + matchSigs md1 md2 + loop sgs1 sgs2 + loop (MdSig x1 md1 : sgs1) (MdSig x2 md2 : sgs2) + | x1 == x2 = do + matchSigs md1 md2 + loop sgs1 sgs2 + loop [] (sg : _) = do + terr $ "cannot match signature item: " ++ name sg + loop (sg : _) [] = do + terr $ "cannot match signature item: " ++ name sg + loop (sg1 : _) (sg2 : _) = do + terr $ "cannot match signature items: " ++ name sg1 ++ + " and " ++ name sg2 + -- + name (MdValue x _) = "value " ++ show x + name (MdTycon x _) = "type " ++ show x + name (MdModule x _) = "module " ++ show x + name (MdSig x _) = "module type " ++ show x + name _ = error "BUG! in Statics.matchSigs" + +-- | Extensional equality for type constructors +tyconExtEq :: TyCon -> TyCon -> Bool +tyconExtEq tc1 tc2 | tcBounds tc1 == tcBounds tc2 = + let tvs = zipWith (TyVar .) tvalphabet (tcBounds tc1) + in tyApp tc1 tvs == tyApp tc2 tvs +tyconExtEq _ _ = False + +-- | Check that two type constructors match exactly. +matchTycons :: (?loc :: Loc, Monad m) => + TyCon -> TyCon -> TC m () +matchTycons tc1 tc2 = case (varietyOf tc1, varietyOf tc2) of + (AbstractType, AbstractType) -> do + tassert (tcArity tc1 == tcArity tc2) $ + estr "the arity" (show (tcArity tc1)) (show (tcArity tc2)) + tassert (tcBounds tc1 == tcBounds tc2) $ + estr "parameter bounds" (show (tcBounds tc1)) (show (tcBounds tc2)) + tassert (tcQual tc1 == tcQual tc2) $ + estr "qualifier" (show (tcQual tc1)) (show (tcQual tc2)) + (DataType, DataType) -> do + let (tvs1, rhs1) = tcCons tc1 + (tvs2, rhs2) = tcCons tc2 + tassert (length tvs1 == length tvs2) $ + estr "number of parameters" (show (length tvs1)) (show (length tvs2)) + let mtv = maxtv (tvs1, tvs2, Env.range rhs1, Env.range rhs2) + tvs' = fastFreshTyVars tvs1 mtv + rhs1' = Env.mapVals (fmap (tysubsts tvs1 (map TyVar tvs'))) rhs1 + rhs2' = Env.mapVals (fmap (tysubsts tvs2 (map TyVar tvs'))) rhs2 + forM_ (Env.toList rhs1') $ \(k, t1) -> + let Just t2 = rhs2' =..= k + in tassert (t1 == t2) $ estr + ("constructor `" ++ show k ++ "'") + (maybe "nothing" show t1) + (maybe "nothing" show t2) + (OperatorType, _) | tyconExtEq tc1 tc2 -> return () + (_, OperatorType) | tyconExtEq tc1 tc2 -> return () + (OperatorType, OperatorType) -> do + let next1 = fromJust (tcNext tc1) + next2 = fromJust (tcNext tc2) + tassert (length next1 == length next2) $ + estr "number of clauses" (show (length next1)) (show (length next2)) + forM_ (zip3 next1 next2 [1 :: Int .. ]) $ + \((tp1, t1), (tp2, t2), ix) -> do + tassert (length tp1 == length tp2) $ + estr ("number of parameters in clause " ++ show ix) + (show (length tp1)) (show (length tp2)) + (tvs1, tvs2) <- mconcat `liftM` zipWithM matchTypats tp1 tp2 + let mtv = maxtv (tvs1, tvs2, t1, t2) + tvs' = fastFreshTyVars tvs1 mtv + t1' = tysubsts tvs1 (map TyVar tvs') t1 + t2' = tysubsts tvs2 (map TyVar tvs') t2 + tassert (t1' == t2') $ + estr ("type operator right-hand sides in clause " ++ show ix) + (show t1') (show t2') + (v1, v2) -> terr $ estr "kind of definition" (show v1) (show v2) + where + estr what which1 which2 = + "in signature matching, cannot match type definition for " ++ + show (tcName tc1) ++ " because the " ++ what ++ + " does not match (`" ++ which1 ++ "' vs. `" ++ which2 ++ "')" + +-- | Check that two type patterns match, and return the pairs of +-- type variables that line up and thus need renaming. +matchTypats :: (?loc :: Loc, Monad m) => + TyPat -> TyPat -> TC m ([TyVar R], [TyVar R]) +matchTypats (TpVar tv1) (TpVar tv2) + = return ([tv1], [tv2]) +matchTypats (TpApp tc1 tvs1) (TpApp tc2 tvs2) + | tc1 == tc2 + = mconcat `liftM` zipWithM matchTypats tvs1 tvs2 +matchTypats tp1 tp2 + = terr $ "in signature matching, cannot match type patterns `" ++ + show tp1 ++ "' and `" ++ show tp2 ++ "'" + +-- | To flatten all the 'MdNil' and 'MdApp' constructors in a module +-- into an ordinary list. +linearize :: Module -> [Module] -> [Module] +linearize MdNil = id +linearize (MdApp md1 md2) = linearize md1 . linearize md2 +linearize md1 = (md1 :) + +--- +--- END Module Sealing +--- + +-- | Add the type of a value binding +addVal :: Monad m => Lid R -> Syntax.Type R -> TC m () +addVal x t = do + let ?loc = mkBogus "" + t' <- tcType t + bindVar x t' + +-- | Add an arbitrary declaration +addDecl :: Monad m => Decl R -> TC m () +addDecl d = () <$ tcDecl d + +-- | Add a type constructor binding +addType :: Monad m => Lid R -> TyCon -> TC m () +addType n tc = () <$ bindTycon n tc + +-- | Add a nested submodule +addMod :: Monad m => Uid R -> TC m a -> TC m () +addMod u action = do + (_, md) <- steal $ enterModule u $ action + bindModule u md + +-- | Type check a program +tcProg :: Monad m => Prog R -> TC m (Type, Prog R) +tcProg [$prQ| $list:ds in $opt:e0 |] = do + (ds', md) <- steal $ tcDecls ds + (t, e0') <- case e0 of + Just e -> liftM (second Just) $ inModule md $ tcExpr e + Nothing -> return (tyUnit, Nothing) + return (t, [$prQ|+ $list:ds' in $opt:e0' |]) + +-- | The initial type-checking state +env0 :: S +env0 = S e0 0 where + e0 :: E + e0 = genEmpty =+= (Con (uid "()") -:- tyUnit :: VE) + +-- | Find out the parameter type of an exception +getExnParam :: Type -> Maybe (Maybe Type) +getExnParam (TyApp tc _ _) + | tc == tcExn = Just Nothing +getExnParam (TyFun _ t1 (TyApp tc _ _)) + | tc == tcExn = Just (Just t1) +getExnParam _ = Nothing + +-- | Reconstruct the declaration from a tycon binding, for printing +tyConToDec :: TyCon -> TyDec R +tyConToDec tc = case tc of + _ | tc == tcExn + -> tdAbs (lid "exn") [] [] maxBound + TyCon { tcName = n, tcNext = Just clauses } + -> tdSyn (jname n) [ (map tyPatToStx ps, typeToStx rhs) + | (ps, rhs) <- clauses ] + TyCon { tcName = n, tcCons = (ps, alts) } + | not (isEmpty alts) + -> tdDat (jname n) ps [ (u, fmap typeToStx mt) + | (u, mt) <- toList alts ] + TyCon { tcName = n } + -> + let tyvars = zipWith ($) tvalphabet (tcBounds tc) + in tdAbs (jname n) + (zipWith const tyvars (tcArity tc)) + (tcArity tc) + (qRepresent + (denumberQDen + (map (qInterpret . qeVar) tyvars) + (tcQual tc))) + +getVarInfo :: QLid R -> S -> Maybe Type +getVarInfo ql (S e _) = e =..= fmap Var ql + +getTypeInfo :: QLid R -> S -> Maybe TyCon +getTypeInfo ql (S e _) = e =..= ql + +-- Find out about a type constructor. If it's an exception constructor, +-- return 'Left' with its paramter, otherwise return the type construtor +-- of the result type +getConInfo :: QUid R -> S -> Maybe (Either (Maybe Type) TyCon) +getConInfo qu (S e _) = do + t <- e =..= fmap Con qu + case getExnParam t of + Just mt -> Just (Left mt) + Nothing -> + let loop (TyFun _ _ t2) = loop t2 + loop (TyQu _ _ t1) = loop t1 + loop (TyApp tc _ _) = Just (Right tc) + loop _ = Nothing + in loop t diff --git a/src/Syntax.hs b/src/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Syntax.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE + RankNTypes, + TemplateHaskell, + TypeFamilies, + TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- This module provides syntax and basic syntax operations for +-- the implementation of the language from the paper "Stateful Contracts +-- for Affine Types". +-- +----------------------------------------------------------------------------- + +module Syntax ( + -- * Identifiers + module Syntax.Anti, + module Syntax.POClass, + module Syntax.Notable, + module Syntax.Ident, + module Syntax.Kind, + module Syntax.Type, + module Syntax.Lit, + module Syntax.Patt, + module Syntax.Expr, + module Syntax.Decl, + module Syntax.SyntaxTable, + + -- * Unfold syntax to lists + unfoldExAbs, unfoldTyQu, unfoldTyMu, + unfoldExTApp, unfoldExApp, unfoldTyFun, + unfoldTupleExpr, unfoldTuplePatt, unfoldSeWith, + + -- * Miscellany + module Viewable +) where + +import Syntax.Anti +import Syntax.POClass +import Syntax.Notable +import Syntax.Ident +import Syntax.Kind +import Syntax.Type +import Syntax.Lit +import Syntax.Patt +import Syntax.Expr +import Syntax.Decl +import Syntax.SyntaxTable + +import Util +import Viewable + +deriveAntibles syntaxTable + +-- These should be generated: +instance Antible (Prog i) where + injAnti _ = error "BUG! injAnti: Cannot inject into Prog" + prjAnti = const Nothing + dictOf = const noAntis + +instance Antible (Ident i) where + injAnti = J [] . Var . injAnti + prjAnti (J [] (Var l)) = prjAnti l + prjAnti _ = Nothing + dictOf = const idAntis + +instance Antible (QLid i) where + injAnti = J [] . injAnti + prjAnti (J [] i) = prjAnti i + prjAnti _ = Nothing + dictOf = const qlidAntis + +instance Antible (QUid i) where + injAnti = J [] . injAnti + prjAnti (J [] i) = prjAnti i + prjAnti _ = Nothing + dictOf = const quidAntis + +-- Unfolding various sequences + +-- | Get the list of formal parameters and body of a +-- lambda/typelambda expression +unfoldExAbs :: Expr i -> ([Either (Patt i, Type i) (TyVar i)], Expr i) +unfoldExAbs = unscanr each where + each e = case view e of + ExAbs x t e' -> Just (Left (x, t), e') + ExTAbs tv e' -> Just (Right tv, e') + _ -> Nothing + +-- | Get the list of formal parameters and body of a qualified type +unfoldTyQu :: Quant -> Type i -> ([TyVar i], Type i) +unfoldTyQu u = unscanr each where + each (N _ (TyQu u' x t)) | u == u' = Just (x, t) + each _ = Nothing + +-- | Get the list of mu-bound tvs of a recursive type +unfoldTyMu :: Type i -> ([TyVar i], Type i) +unfoldTyMu = unscanr each where + each (N _ (TyMu x t)) = Just (x, t) + each _ = Nothing + +-- | Get the list of actual parameters and body of a type application +unfoldExTApp :: Expr i -> ([Type i], Expr i) +unfoldExTApp = unscanl each where + each e = case view e of + ExTApp e' t -> Just (t, e') + _ -> Nothing + +-- | Get the list of actual parameters and body of a value application +unfoldExApp :: Expr i -> ([Expr i], Expr i) +unfoldExApp = unscanl each where + each e = case view e of + ExApp e1 e2 -> Just (e2, e1) + _ -> Nothing + +-- | Get the list of argument types and result type of a function type +unfoldTyFun :: Type i -> ([Type i], Type i) +unfoldTyFun = unscanr each where + each (N _ (TyFun _ ta tr)) = Just (ta, tr) + each _ = Nothing + +-- | Get the elements of a tuple as a list +unfoldTupleExpr :: Expr i -> ([Expr i], Expr i) +unfoldTupleExpr = unscanl each where + each e = case view e of + ExPair e1 e2 -> Just (e2, e1) + _ -> Nothing + +-- | Get the elements of a tuple pattere as a list +unfoldTuplePatt :: Patt i -> ([Patt i], Patt i) +unfoldTuplePatt = unscanl each where + each p = case view p of + PaPair p1 p2 -> Just (p2, p1) + _ -> Nothing + +-- | Get all the "with type" clauses on a signature expression +unfoldSeWith :: SigExp i -> ([(QLid i, [TyVar i], Type i)], SigExp i) +unfoldSeWith = unscanl each where + each p = case view p of + SeWith se ql tvs t -> Just ((ql, tvs, t), se) + _ -> Nothing diff --git a/src/Syntax/Anti.hs b/src/Syntax/Anti.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Anti.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE + DeriveDataTypeable, + FlexibleContexts, + FlexibleInstances, + PatternGuards, + RankNTypes, + TemplateHaskell #-} +module Syntax.Anti ( + -- * Representation of antiquotes + Anti(..), + -- ** Raising errors when encountering antiquotes + AntiFail(..), AntiError(..), + -- * Generic anti projection/injection + Antible(..), deriveAntibles, + -- * Generic location expansion + LocAst(..), deriveLocAsts, + -- * Antiquote expansion + -- ** Generic expander construction + expandAntibles, expandAntible, expandAntibleType, + -- * Syntax classes and antiquote tables + -- ** Antiquote tables + -- *** Types + AntiDict, PreTrans, Trans(..), + -- *** Constructors + (=:), (=:!), (=:<), (&), + -- ** Syntax classs + -- *** Types + SyntaxClass(..), SyntaxTable, + -- *** Constructors + (=::), ($:), (!:), (>:) +) where + +import Loc as Loc +import Meta.THHelpers +import Syntax.Notable +import Util + +import Data.Generics (Typeable, Data, extQ) +import Data.List (elemIndex) +import qualified Data.Map as M +import Language.Haskell.TH as TH + +-- +-- Representation of antiquotes +-- + +data Anti = Anti { + anType :: String, + anName :: String + } + deriving (Eq, Ord, Typeable, Data) + +instance Show Anti where + show (Anti "" aid) = '$' : aid + show (Anti atag aid) = '$' : atag ++ ':' : aid + +class AntiFail a where + antifail :: a + +instance Monad m => AntiFail (String -> Anti -> m b) where + antifail who what = fail $ + "BUG! " ++ who ++ ": encountered antiquote " ++ show what + +instance AntiFail (Name -> TH.ExpQ) where + antifail a = do + loc <- TH.location + [| antifail $(stringE (show (fromTHLoc loc))) $(varE a) |] + +instance AntiFail (TH.Q TH.Exp) where + antifail = antifail (mkName "a") + +class AntiError a where + antierror :: a + +instance AntiError (String -> Anti -> b) where + antierror who what = error $ + "BUG! " ++ who ++ ": encountered antiquote " ++ show what + +instance AntiError (Name -> TH.ExpQ) where + antierror a = do + loc <- TH.location + [| antierror $(stringE (show (fromTHLoc loc))) $(varE a) |] + +instance AntiError (TH.Q TH.Exp) where + antierror = antierror (mkName "a") + +class Antible a where + injAnti :: Anti -> a + prjAnti :: a -> Maybe Anti + dictOf :: a -> AntiDict + + injAntiList :: Anti -> [a] + prjAntiList :: [a] -> Maybe Anti + dictOfList :: [a] -> AntiDict + + injAntiList = return . injAnti + prjAntiList [a] = prjAnti a + prjAntiList _ = Nothing + dictOfList = const listAntis + +instance Antible a => Antible [a] where + injAnti = injAntiList + prjAnti = prjAntiList + dictOf = dictOfList + +instance Antible a => Antible (Maybe a) where + injAnti = return . injAnti + prjAnti = (prjAnti =<<) + dictOf = const optAntis + +optAntis, listAntis :: AntiDict + +listAntis + = "list" =: Nothing + & "nil" =: Just (\_ -> conS '[] []) + & "list1" =: Just (\v -> listS [varS (TH.mkName v) []]) + +optAntis + = "opt" =: Nothing + & "some" =:< 'Just + & "none" =: Just (\_ -> conS 'Nothing []) + +--- +--- Deriving antiquotes +--- + +-- Given the syntax table, we need to derive instances of Antible +-- and antiquoters +deriveAntibles :: SyntaxTable -> TH.Q [TH.Dec] +deriveAntibles = concatMapM each where + each SyntaxClass { scDict = Nothing } = return [] + each sc@SyntaxClass { scDict = Just dict } = do + TH.TyConI tc <- reify (scName sc) + tvs <- case tc of + TH.DataD _ _ tvs _ _ -> return tvs + TH.NewtypeD _ _ tvs _ _ -> return tvs + TH.TySynD _ tvs _ -> return tvs + _ -> fail "deriveAntibles requires type" + a <- TH.newName "a" + let wrapper p = case scWrap sc of + Nothing -> p + Just _ -> TH.conP 'N [TH.wildP, p] + [InstanceD context hd decs] <- + [d| instance Antible $(foldl TH.appT (TH.conT (scName sc)) + (map typeOfTyVarBndr tvs)) where + injAnti = $(varE (maybe 'id id (scWrap sc))) + . $(conE (scAnti sc)) + prjAnti stx = $(caseE [| stx |] [ + match (wrapper (TH.conP (scAnti sc) [TH.varP a])) + (TH.normalB [| Just $(TH.varE a) |]) + [], + match TH.wildP + (TH.normalB [| Nothing |]) + [] + ]) + dictOf _ = $(varE dict) + injAntiList = return . injAnti + prjAntiList [b] = prjAnti b + prjAntiList _ = Nothing + dictOfList = const listAntis + |] + context' <- buildContext tvs (scCxt sc) + return [InstanceD (context' ++ context) hd decs] + +-- +-- Location expanders +-- + +class LocAst stx where + toLocAstQ :: ToSyntax ast => TH.Name -> stx -> TH.Q ast + +deriveLocAst :: Name -> SyntaxClass -> TH.Q [TH.Dec] +deriveLocAst _ SyntaxClass { scWrap = Nothing } = return [] +deriveLocAst build SyntaxClass { scName = name, scCxt = context } = do + info <- reify name + case info of + -- Located t i + TyConI (TySynD _ _ (AppT (AppT _ (ConT _)) _)) -> + thenNote ''LocNote + -- N (note i) (t i) + TyConI (TySynD _ _ (AppT (AppT _ (AppT (ConT note) _)) + (AppT (ConT _) _))) -> + thenNote note + _ -> return [] + where + -- + thenNote note = do + info <- reify note + case info of + TyConI (DataD _ _ _ [con] _) -> thenCon con + TyConI (NewtypeD _ _ _ con _) -> thenCon con + _ -> runIO (print (name, info)) >> return [] + -- + thenCon (ForallC _ _ con) = thenCon con + thenCon (InfixC st1 dcon st2) = thenDCon dcon [snd st1, snd st2] + thenCon (NormalC dcon sts) = thenDCon dcon (map snd sts) + thenCon (RecC dcon vsts) = thenDCon dcon [t | (_,_,t) <- vsts] + -- + thenDCon dcon ts + | Just ix <- elemIndex (ConT ''Loc.Loc) ts = do + i <- newName "i" + [InstanceD [] hd decls] <- + [d| instance LocAst ($(conT name) $(varT i)) where + toLocAstQ loc stx = + do + let _ignore = $(stringE (show name)) + ast <- $(varE build) stx + case ast of + VarE _ -> return ast + _ -> varS $(stringE (show 'setLoc)) + [return ast, varS loc []] + `whichS'` + do + let pat preAstQ = + conS $(stringE (show 'N)) + [ conS $(stringE (show dcon)) + $(listE [ if j == ix + then [| varS loc [] |] + else [| wildS |] + | j <- [0 .. length ts - 1] ]) + , preAstQ ] + ast <- $(varE build) stx + case ast of + VarP v -> asP v (pat wildP) + ConP _ [_, preAst] -> pat (return preAst) + _ -> fail $ + "BUG! toLocAstQ did not recognize " ++ + "expanded code: " ++ show ast + |] + context' <- buildContext [PlainTV i] ((''Data, [0]) : context) + return [InstanceD context' hd decls] + | otherwise = return [] + +deriveLocAsts :: Name -> SyntaxTable -> TH.Q [TH.Dec] +deriveLocAsts name = concatMapM (deriveLocAst name) + +-- +-- Antiquote expanders +-- + +expandAntibles :: [Name] -> Name -> SyntaxTable -> ExpQ +expandAntibles params name = foldr each [| id |] where + each sc rest = [| $(expandAntible params name sc) . $rest |] + +expandAntible :: [Name] -> Name -> SyntaxClass -> ExpQ +expandAntible params build SyntaxClass { scName = name, scWrap = wrap } = do + info <- reify name + case info of + TyConI (DataD _ _ [_] _ _) -> expandAntible1 params build wrap name + TyConI (NewtypeD _ _ [_] _ _) -> expandAntible1 params build wrap name + TyConI (TySynD _ [_] _) -> expandAntible1 params build wrap name + _ -> expandAntible0 build wrap name + +expandAntible0 :: Name -> Maybe Name -> Name -> ExpQ +expandAntible0 build maybeWrap typeName = + [| $(expandAntibleType build maybeWrap [t| $_t |]) |] + where _t = conT typeName + +expandAntible1 :: [Name] -> Name -> Maybe Name -> Name -> ExpQ +expandAntible1 params build maybeWrap typeName = + foldr (\a b -> [| $a . $b |]) [| id |] + [ expandAntibleType build maybeWrap [t| $_t $(conT _p) |] + | _p <- params ] + where _t = conT typeName + +expandAntibleType :: Name -> Maybe Name -> TypeQ -> ExpQ +expandAntibleType build maybeWrap _t = + let main = case maybeWrap of + Nothing -> + [| \x -> expandAntiFun (x:: $_t) |] + Just wrap -> + [| \x -> expandWrappedAntiFun + $(varE build) + (mkName $(stringE (show wrap))) + (x:: $_t) |] + in + [| (`extQ` $main) + . (`extQ` (\x -> expandAntiFun (x:: Maybe $_t))) + . (`extQ` (\x -> expandAntiFun (x:: [$_t]))) |] + +expandWrappedAntiFun :: (Antible (N note a), ToSyntax b) => + (a -> Q b) -> Name -> N note a -> Maybe (Q b) +expandWrappedAntiFun build wrap stx = + Just $ case prjAnti stx of + Just (Anti tag name) -> case M.lookup tag (dictOf stx) of + Just (Trans trans) -> case trans of + Just f -> doWrap (f name) + Nothing -> varS name [] + Nothing -> fail $ + "Unrecognized antiquote tag: `" ++ tag ++ "'" + Nothing -> doWrap (build (dataOf stx)) + where + doWrap preStx = varS wrap [preStx] `whichS` conS 'N [wildS, preStx] + +expandAntiFun :: (Antible a, ToSyntax b) => a -> Maybe (Q b) +expandAntiFun stx = do + Anti tag name <- prjAnti stx + case M.lookup tag (dictOf stx) of + Just trans -> return $ case unTrans trans of + Just f -> f name + Nothing -> varS name [] + Nothing -> fail $ "Unrecognized antiquote tag: `" ++ tag ++ "'" + +-- +-- Antiquote and syntax table +-- + +-- | A pat/exp-generic parser +type PreTrans = forall b. ToSyntax b => Maybe (String -> Q b) +-- | A pat/exp-generic parser, wrapped +newtype Trans = Trans { unTrans :: PreTrans } +-- | A dictionary mapping antiquote tags to parsers +type AntiDict = M.Map String Trans + +-- | A descriptor for a syntactic category, used for generating +-- antiquotes +data SyntaxClass = SyntaxClass { + scName :: Name, + -- | The name of the constructor for antiquotes + scAnti :: Name, + -- | The safe injection from the underlying type to the main type + scWrap :: Maybe Name, + -- | The dictionary of splice tags + scDict :: Maybe Name, + -- | Type class context required for wrapping + scCxt :: [(Name, [Int])] +} + +type SyntaxTable = [SyntaxClass] + +-- | Construct a single syntax class from the type name and antiquote +-- constructor +(=::) :: TH.Name -> TH.Name -> SyntaxClass +name =:: anti = SyntaxClass { + scName = name, + scAnti = anti, + scWrap = Nothing, + scDict = Nothing, + scCxt = [] +} + +-- | Extend a syntax class with the name of a function that lifts +-- from pre-syntax to syntax +(!:) :: SyntaxClass -> TH.Name -> SyntaxClass +tab !: name = tab { scWrap = Just name } + +-- | Extend a syntax class with the name of an antiquote dictionary +($:) :: SyntaxClass -> TH.Name -> SyntaxClass +tab $: dict = tab { scDict = Just dict } + +-- | Extend a syntax class with a context +(>:) :: SyntaxClass -> (Name, [Int]) -> SyntaxClass +tab >: context = tab { scCxt = context : scCxt tab } + +infixl 2 =::, !:, $:, >: + +-- | Append two antiquote dictionaries +(&) :: AntiDict -> AntiDict -> AntiDict +(&) = M.union + +infixr 1 & + +-- | Construct a singleton antiquote dictionary from a key and +-- generic parser +(=:) :: String -> PreTrans -> AntiDict +a =: b = M.singleton a (Trans b) + +-- | Create singleton dictionary with default (tagless) entry +(=:!) :: String -> PreTrans -> AntiDict +a =:! b = M.union ("" =: b) (a =: b) + +-- | Construct an antiquote dictionary for matching a +-- simple constructor +(=:<) :: String -> TH.Name -> AntiDict +a =:< n = a =: Just (\v -> conS n [varS v []]) + +infix 2 =:, =:!, =:< + diff --git a/src/Syntax/Decl.hs b/src/Syntax/Decl.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Decl.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE + DeriveDataTypeable, + FlexibleInstances, + MultiParamTypeClasses, + StandaloneDeriving, + TemplateHaskell, + TypeFamilies, + TypeSynonymInstances #-} +module Syntax.Decl ( + -- * Declarations + Decl'(..), Decl, DeclNote(..), newDecl, + -- ** Type declarations + TyDec'(..), TyDec, AbsTy'(..), AbsTy, + -- ** Modules + ModExp'(..), ModExp, newModExp, + -- ** Signature + SigExp'(..), SigExp, newSigExp, + SigItem'(..), SigItem, newSigItem, + -- ** Synthetic constructors + -- | These fill in the source location fields with a bogus location + dcLet, dcTyp, dcAbs, dcMod, dcSig, dcOpn, dcLoc, dcExn, dcAnti, + absTy, absTyAnti, + tdAbs, tdSyn, tdDat, tdAnti, + meStr, meName, meAsc, meAnti, + sgVal, sgTyp, sgMod, sgSig, sgInc, sgExn, sgAnti, + seSig, seName, seWith, seAnti, + prog, + + -- * Programs + Prog'(..), Prog, + prog2decls +) where + +import Meta.DeriveNotable +import Syntax.Notable +import Syntax.Anti +import Syntax.Kind +import Syntax.Ident +import Syntax.Type +import Syntax.Patt +import Syntax.Expr + +import Data.Generics (Typeable(..), Data(..)) +import qualified Data.Set as S +import qualified Data.Map as M + +type Decl i = N (DeclNote i) (Decl' i) +type ModExp i = N (DeclNote i) (ModExp' i) +type SigItem i = N (DeclNote i) (SigItem' i) +type SigExp i = N (DeclNote i) (SigExp' i) +type Prog i = Located Prog' i +type AbsTy i = Located AbsTy' i +type TyDec i = Located TyDec' i + +-- | A program is a sequence of declarations, maybe followed by an +-- expression +data Prog' i = Prog [Decl i] (Maybe (Expr i)) + deriving (Typeable, Data) + +-- | Declarations +data Decl' i + -- | Constant declaration + = DcLet (Patt i) (Maybe (Type i)) (Expr i) + -- | Type declaration + | DcTyp [TyDec i] + -- | Abstype block declaration + | DcAbs [AbsTy i] [Decl i] + -- | Module declaration + | DcMod (Uid i) (ModExp i) + -- | Signature declaration + | DcSig (Uid i) (SigExp i) + -- | Module open + | DcOpn (ModExp i) + -- | Local block + | DcLoc [Decl i] [Decl i] + -- | Exception declaration + | DcExn (Uid i) (Maybe (Type i)) + -- | Antiquote + | DcAnti Anti + deriving (Typeable, Data) + +-- | A module expression +data ModExp' i + -- | A module literal + = MeStr [Decl i] + -- | A module variable + | MeName (QUid i) [QLid i] + -- | A signature ascription + | MeAsc (ModExp i) (SigExp i) + -- | An antiquote + | MeAnti Anti + deriving (Typeable, Data) + +-- | A signature item +data SigItem' i + -- | A value + = SgVal (Lid i) (Type i) + -- | A type + | SgTyp [TyDec i] + -- | A module + | SgMod (Uid i) (SigExp i) + -- | A signature + | SgSig (Uid i) (SigExp i) + -- | Signature inclusion + | SgInc (SigExp i) + -- | An exception + | SgExn (Uid i) (Maybe (Type i)) + -- | An antiquote + | SgAnti Anti + deriving (Typeable, Data) + +-- | A module type expression +data SigExp' i + -- | A signature literal + = SeSig [SigItem i] + -- | A signature variable + | SeName (QUid i) [QLid i] + -- | Type-level fibration + | SeWith (SigExp i) (QLid i) [TyVar i] (Type i) + -- | An antiquote + | SeAnti Anti + deriving (Typeable, Data) + +-- | Affine language type declarations +data TyDec' i + -- | An abstract (empty) type + = TdAbs { + tdName :: Lid i, + tdParams :: [TyVar i], + -- | The variance of each parameter + tdVariances :: [Variance], + -- | Whether each parameter contributes to the qualifier + tdQual :: QExp i + } + -- | A type operator or synonym + | TdSyn { + tdName :: Lid i, + tdClauses :: [([TyPat i], Type i)] + } + -- | An algebraic datatype + | TdDat { + tdName :: Lid i, + tdParams :: [TyVar i], + tdAlts :: [(Uid i, Maybe (Type i))] + } + | TdAnti Anti + deriving (Typeable, Data) + +-- | An abstract type needs to specify variances and the qualifier +data AbsTy' i + = AbsTy { + atvariance :: [Variance], + atquals :: QExp i, + atdecl :: TyDec i + } + | AbsTyAnti Anti + deriving (Typeable, Data) + +data DeclNote i + = DeclNote { + -- | source location + dloc_ :: !Loc, + -- | free variables + dfv_ :: FvMap i, + -- | defined variables + ddv_ :: S.Set (QLid i) + } + deriving (Typeable, Data) + +instance Locatable (DeclNote i) where + getLoc = dloc_ + +instance Relocatable (DeclNote i) where + setLoc note loc = note { dloc_ = loc } + +instance Notable (DeclNote i) where + newNote = DeclNote bogus M.empty S.empty + +newDecl :: Id i => Decl' i -> Decl i +newDecl d0 = flip N d0 $ case d0 of + DcLet p1 t2 e3 -> + newNote { + dloc_ = getLoc (p1, t2, e3), + dfv_ = fv e3, + ddv_ = qdv p1 + } + DcTyp tds -> + newNote { + dloc_ = getLoc tds + } + DcAbs at1 ds2 -> + newNote { + dloc_ = getLoc (at1, ds2), + dfv_ = fv ds2, + ddv_ = S.unions (map qdv ds2) + } + DcMod u1 me2 -> + newNote { + dloc_ = getLoc me2, + dfv_ = fv me2, + ddv_ = S.mapMonotonic (\(J p n) -> J (u1:p) n) (qdv me2) + } + DcSig _ se2 -> + newNote { + dloc_ = getLoc se2 + } + DcOpn me1 -> + newNote { + dloc_ = getLoc me1, + dfv_ = fv me1, + ddv_ = qdv me1 + } + DcLoc ds1 ds2 -> + newNote { + dloc_ = getLoc (ds1, ds2), + dfv_ = fv ds1 |+| (fv ds2 |--| qdv ds1), + ddv_ = qdv ds2 + } + DcExn _ t2 -> + newNote { + dloc_ = getLoc t2 + } + DcAnti a -> + newNote { + dfv_ = antierror "fv" a, + ddv_ = antierror "dv" a + } + +newModExp :: Id i => ModExp' i -> ModExp i +newModExp me0 = flip N me0 $ case me0 of + MeStr ds -> + newNote { + dloc_ = getLoc ds, + dfv_ = fv ds, + ddv_ = qdv ds + } + MeName _ qls -> + newNote { + ddv_ = S.fromList qls + } + MeAsc me se -> + newNote { + dloc_ = getLoc (me, se), + dfv_ = fv me, + ddv_ = qdv se + } + MeAnti a -> + newNote { + dfv_ = antierror "fv" a, + ddv_ = antierror "dv" a + } + +newSigItem :: Id i => SigItem' i -> SigItem i +newSigItem d0 = flip N d0 $ case d0 of + SgVal l1 t2 -> + newNote { + dloc_ = getLoc t2, + ddv_ = S.singleton (J [] l1) + } + SgTyp tds -> + newNote { + dloc_ = getLoc tds + } + SgMod u1 se2 -> + newNote { + dloc_ = getLoc se2, + ddv_ = S.mapMonotonic (\(J p n) -> J (u1:p) n) (qdv se2) + } + SgSig _ se2 -> + newNote { + dloc_ = getLoc se2 + } + SgInc se1 -> + newNote { + dloc_ = getLoc se1, + ddv_ = qdv se1 + } + SgExn _ t2 -> + newNote { + dloc_ = getLoc t2 + } + SgAnti a -> + newNote { + dfv_ = antierror "fv" a, + ddv_ = antierror "dv" a + } + +newSigExp :: Id i => SigExp' i -> SigExp i +newSigExp se0 = flip N se0 $ case se0 of + SeSig sis -> + newNote { + dloc_ = getLoc sis, + ddv_ = qdv sis + } + SeName _ qls -> + newNote { + ddv_ = S.fromList qls + } + SeWith se1 _ _ t3 -> + newNote { + dloc_ = getLoc (se1, t3), + ddv_ = qdv se1 + } + SeAnti a -> + newNote { + dfv_ = antierror "fv" a, + ddv_ = antierror "dv" a + } + +instance Id i => Fv (N (DeclNote i) a) i where fv = dfv_ . noteOf +instance Id i => Dv (N (DeclNote i) a) i where qdv = ddv_ . noteOf + +deriveNotable 'newDecl (''Id, [0]) ''Decl +deriveNotable 'newModExp (''Id, [0]) ''ModExp +deriveNotable 'newSigItem (''Id, [0]) ''SigItem +deriveNotable 'newSigExp (''Id, [0]) ''SigExp +deriveNotable ''AbsTy +deriveNotable ''TyDec +deriveNotable ''Prog + +--- +--- Syntax Utils +--- + +-- | Turn a program into a sequence of declarations by replacing +-- the final expression with a declaration of variable 'it'. +prog2decls :: Id i => Prog i -> [Decl i] +prog2decls (N _ (Prog ds (Just e))) + = ds ++ [dcLet (paVar (lid "it")) Nothing e] +prog2decls (N _ (Prog ds Nothing)) + = ds diff --git a/src/Syntax/Decl.hs-boot b/src/Syntax/Decl.hs-boot new file mode 100644 --- /dev/null +++ b/src/Syntax/Decl.hs-boot @@ -0,0 +1,24 @@ +-- vim: ft=haskell +{-# LANGUAGE + FlexibleInstances, + MultiParamTypeClasses, + TypeFamilies, + TypeSynonymInstances #-} +{-# OPTIONS_GHC -w #-} +module Syntax.Decl where + +import Syntax.Notable +import Syntax.Ident (Id, Fv, Dv) + +import Data.Data (Data) + +data DeclNote i +data Decl' i +type Decl i = N (DeclNote i) (Decl' i) + +instance Id i => Data (DeclNote i) +instance Id i => Data (Decl' i) +instance Locatable (DeclNote i) +instance Notable (DeclNote i) +instance Id i => Fv (N (DeclNote i) a) i +instance Id i => Dv (N (DeclNote i) a) i diff --git a/src/Syntax/Expr.hs b/src/Syntax/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Expr.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE + DeriveDataTypeable, + FlexibleInstances, + MultiParamTypeClasses, + TemplateHaskell, + TypeFamilies, + TypeSynonymInstances #-} +module Syntax.Expr ( + -- * Expressions + Expr'(..), Expr, ExprNote(..), newExpr, + -- ** Letrec and case + Binding'(..), Binding, newBinding, + CaseAlt'(..), CaseAlt, newCaseAlt, + + -- * Two-level expression constructors + -- | These fill in the source location field based on the + -- subexpressions and perform the free variable analysis + exId, exLit, exCase, exLetRec, exLetDecl, exPair, + exAbs, exApp, exTAbs, exTApp, exPack, exCast, exAnti, + caClause, caAnti, + bnBind, bnAnti, + -- ** Synthetic expression constructors + exVar, exCon, exBVar, exBCon, + exStr, exInt, exFloat, + exLet, exSeq, + -- ** Optimizing expression constructors + exLet', exLetVar', exAbs', exAbsVar', exTAbs', + + -- * Expression accessors and updaters + syntacticValue +) where + +import Syntax.Notable +import Syntax.Anti +import Syntax.Ident +import Syntax.Type +import Syntax.Lit +import Syntax.Patt +import {-# SOURCE #-} Syntax.Decl +import Viewable + +import Meta.DeriveNotable + +import Data.Generics (Typeable(..), Data(..)) +import qualified Data.Map as M + +type Expr i = N (ExprNote i) (Expr' i) +type Binding i = N (ExprNote i) (Binding' i) +type CaseAlt i = N (ExprNote i) (CaseAlt' i) + +-- | The underlying expression type, which we can pattern match without +-- dealing with the common fields above. +data Expr' i + -- | variables and datacons + = ExId (Ident i) + -- | literals + | ExLit Lit + -- | case expressions (including desugared @if@ and @let@) + | ExCase (Expr i) [CaseAlt i] + -- | recursive let expressions + | ExLetRec [Binding i] (Expr i) + -- | nested declarations + | ExLetDecl (Decl i) (Expr i) + -- | pair construction + | ExPair (Expr i) (Expr i) + -- | lambda + | ExAbs (Patt i) (Type i) (Expr i) + -- | application + | ExApp (Expr i) (Expr i) + -- | type abstraction + | ExTAbs (TyVar i) (Expr i) + -- | type application + | ExTApp (Expr i) (Type i) + -- | existential construction + | ExPack (Maybe (Type i)) (Type i) (Expr i) + -- | dynamic promotion (True) or static type ascription (False) + | ExCast (Expr i) (Type i) Bool + -- | antiquotes + | ExAnti Anti + deriving (Typeable, Data) + +-- | Let-rec bindings require us to give types +data Binding' i + = BnBind { + bnvar :: Lid i, + bntype :: Type i, + bnexpr :: Expr i + } + | BnAnti Anti + deriving (Typeable, Data) + +data CaseAlt' i + = CaClause { + capatt :: Patt i, + caexpr :: Expr i + } + | CaAnti Anti + deriving (Typeable, Data) + +-- | The annotation on every expression +data ExprNote i + = ExprNote { + -- | source location + eloc_ :: !Loc, + -- | free variables + efv_ :: FvMap i + } + deriving (Typeable, Data) + +instance Locatable (ExprNote i) where + getLoc = eloc_ + +instance Relocatable (ExprNote i) where + setLoc note loc = note { eloc_ = loc } + +-- | Types with free variable analyses +instance Id i => Fv (N (ExprNote i) a) i where fv = efv_ . noteOf + +instance Notable (ExprNote i) where + newNote = ExprNote { + eloc_ = bogus, + efv_ = M.empty + } + +newExpr :: Id i => Expr' i -> Expr i +newExpr e0 = flip N e0 $ case e0 of + ExId i -> + newNote { + efv_ = case view i of + Left y -> M.singleton y 1 + _ -> M.empty + } + ExLit _ -> newNote + ExCase e1 cas -> + newNote { + efv_ = fv e1 |*| fv (ADDITIVE cas), + eloc_ = getLoc (e1, cas) + } + ExLetRec bns e2 -> + newNote { + efv_ = let vs = map (J [] . bnvar . dataOf) bns + pot = fv e2 |+| fv bns + in foldl (|-|) pot vs, + eloc_ = getLoc (bns, e2) + } + ExLetDecl d1 e2 -> + newNote { + efv_ = fv d1 |*| (fv e2 |--| qdv d1), + eloc_ = getLoc (d1, e2) + } + ExPair e1 e2 -> + newNote { + efv_ = fv e1 |*| fv e2, + eloc_ = getLoc (e1, e2) + } + ExAbs p1 _ e3 -> + newNote { + efv_ = fv e3 |--| qdv p1, + eloc_ = getLoc (p1, e3) + } + ExApp e1 e2 -> + newNote { + efv_ = fv e1 |*| fv e2, + eloc_ = getLoc (e1, e2) + } + ExTAbs _ e2 -> + newNote { + efv_ = fv e2, + eloc_ = getLoc e2 + } + ExTApp e1 t2 -> + newNote { + efv_ = fv e1, + eloc_ = getLoc (e1, t2) + } + ExPack mt1 t2 e3 -> + newNote { + efv_ = fv e3, + eloc_ = getLoc (mt1, t2, e3) + } + ExCast e1 t2 _ -> + newNote { + efv_ = fv e1, + eloc_ = getLoc (e1, t2) + } + ExAnti a -> + newNote { + efv_ = antierror "fv" a + } + +newBinding :: Id i => Binding' i -> Binding i +newBinding b0 = flip N b0 $ case b0 of + BnBind x t e -> + newNote { + efv_ = fv e |-| J [] x, + eloc_ = getLoc (t, e) + } + BnAnti a -> + newNote { + efv_ = antierror "fv" a + } + +newCaseAlt :: Id i => CaseAlt' i -> CaseAlt i +newCaseAlt ca0 = flip N ca0 $ case ca0 of + CaClause x e -> + newNote { + efv_ = fv e |--| qdv x, + eloc_ = getLoc (x, e) + } + CaAnti a -> + newNote { + efv_ = antierror "fv" a + } + +deriveNotable 'newExpr (''Id, [0]) ''Expr +deriveNotable 'newCaseAlt (''Id, [0]) ''CaseAlt +deriveNotable 'newBinding (''Id, [0]) ''Binding + +exVar :: Id i => QLid i -> Expr i +exVar = exId . fmap Var + +exCon :: Id i => QUid i -> Expr i +exCon = exId . fmap Con + +exBVar :: Id i => Lid i -> Expr i +exBVar = exId . J [] . Var + +exBCon :: Id i => Uid i -> Expr i +exBCon = exId . J [] . Con + +exStr :: Id i => String -> Expr i +exStr = exLit . LtStr + +exInt :: Id i => Integer -> Expr i +exInt = exLit . LtInt + +exFloat :: Id i => Double -> Expr i +exFloat = exLit . LtFloat + +exLet :: Id i => Patt i -> Expr i -> Expr i -> Expr i +exLet x e1 e2 = exCase e1 [caClause x e2] + +exSeq :: Id i => Expr i -> Expr i -> Expr i +exSeq e1 e2 = exCase e1 [caClause paWild e2] + +-- | Constructs a let expression, but with a special case: +-- +-- @let x = e in x == e@ +-- @let (x, y) = e in (x, y) == e@ +-- +-- This is always safe to do. +exLet' :: Id i => Patt i -> Expr i -> Expr i -> Expr i +exLet' x e1 e2 = if (x -==+ e2) then e1 else exLet x e1 e2 + +-- | Constructs a let expression whose pattern is a variable. +exLetVar' :: Id i => Lid i -> Expr i -> Expr i -> Expr i +exLetVar' = exLet' . paVar + +-- | Constructs a lambda expression, but with a special case: +-- +-- @exAbs' x t (exApp (exVar f) (exVar x)) == exVar f@ +-- +-- This eta-contraction is always safe, because f has no effect +exAbs' :: Id i => Patt i -> Type i -> Expr i -> Expr i +exAbs' x t e = case view e of + ExApp e1 e2 -> case (dataOf x, view e1, view e2) of + (PaVar y, ExId (J p (Var f)), ExId (J [] (Var y'))) | + y == y' && J [] y /= J p f + -> exVar (J p f) + _ -> exAbs x t e + _ -> exAbs x t e + +-- | Construct an abstraction whose pattern is just a variable. +exAbsVar' :: Id i => Lid i -> Type i -> Expr i -> Expr i +exAbsVar' = exAbs' . paVar + +-- | Construct a type-lambda expression, but with a special case: +-- +-- @exTAbs' tv (exTApp (exVar f) tv) == exVar f@ +-- +-- This should always be safe, because f has no effect +exTAbs' :: Id i => TyVar i -> Expr i -> Expr i +exTAbs' tv e = case view e of + ExTApp e1 t2 -> case (view e1, dataOf t2) of + (ExId (J p (Var f)), TyVar tv') | + tv == tv' -> exVar (J p f) + _ -> exTAbs tv e + _ -> exTAbs tv e + +-- | Does a pattern exactly match an expression? That is, is +-- @let p = e1 in e@ equivalent to @e1@? Note that we cannot +-- safely handle data constructors, because they may fail to match. +(-==+) :: Id i => Patt i -> Expr i -> Bool +p -==+ e = case (dataOf p, dataOf e) of + (PaVar l, ExId (J [] (Var l'))) + -> l == l' + (PaCon (J [] (Uid _ "()")) Nothing, + ExId (J [] (Con (Uid _ "()")))) + -> True + (PaPair p1 p2, ExPair e1 e2) + -> p1 -==+ e1 && p2 -==+ e2 + _ -> False +infix 4 -==+ + +-- | Is the expression conservatively side-effect free? +syntacticValue :: Expr i -> Bool +syntacticValue e = case view e of + ExId _ -> True + ExLit _ -> True + ExPair e1 e2 -> syntacticValue e1 && syntacticValue e2 + ExAbs _ _ _ -> True + ExApp e1 e2 -> syntacticConstructor e1 && syntacticValue e2 + ExTAbs _ _ -> True + ExTApp e1 _ -> syntacticValue e1 + ExAnti a -> antierror "syntacticValue" a + _ -> False + +syntacticConstructor :: Expr i -> Bool +syntacticConstructor e = case view e of + ExId (J [] (Con _)) -> True + ExTApp e1 _ -> syntacticConstructor e1 + ExApp e1 e2 -> syntacticConstructor e1 && syntacticValue e2 + ExAnti a -> antierror "syntacticConstructor" a + _ -> False + diff --git a/src/Syntax/Ident.hs b/src/Syntax/Ident.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Ident.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE + DeriveDataTypeable, + FlexibleInstances, + FunctionalDependencies, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + ScopedTypeVariables, + TypeFamilies, + TypeSynonymInstances, + UndecidableInstances #-} +module Syntax.Ident ( + -- * Identifier classes + Id(..), Raw(..), Renamed(..), renamed0, + -- ** Dirty tricks + trivialRename, trivialRename2, + -- * Identifiers + Path(..), + Lid(..), Uid(..), BIdent(..), + Ident, QLid, QUid, + TyVar(..), tvUn, tvAf, tvalphabet, + isOperator, lid, uid, qlid, quid, + -- * Free and defined vars + FvMap, Fv(..), Dv(..), ADDITIVE(..), + (|*|), (|+|), (|-|), (|--|) +) where + +import Env (Path(..), (:>:)(..)) +import Util +import Viewable +import Syntax.Anti +import Syntax.Kind (QLit(..)) + +import Data.Char (isAlpha, isDigit) +import Data.Generics (Typeable(..), Data(..), everywhere, mkT) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Unsafe.Coerce + +class Data i => Id i where + -- The trivial identity tag, used when the identity tag is + -- insufficient to distinguish different thing + trivialId :: i + -- Check for triviality + isTrivial :: i -> Bool + -- Compare two identifiers, given a secondary criterion to use if + -- necessary + compareId :: i -> i -> Ordering -> Ordering + +data Raw = Raw_ + deriving (Data, Typeable, Show) + +newtype Renamed = Ren_ Int + deriving (Data, Typeable, Enum, Eq, Ord) + +instance Show Renamed where + showsPrec p (Ren_ z) = showsPrec p z + +instance Id Raw where + trivialId = Raw_ + isTrivial = const True + compareId _ _ = id + +instance Id Renamed where + trivialId = Ren_ 0 + isTrivial (Ren_ 0) = True + isTrivial (Ren_ _) = False + compareId (Ren_ 0) (Ren_ 0) next = next + compareId (Ren_ 0) _ _ = LT + compareId _ (Ren_ 0) _ = GT + compareId (Ren_ a) (Ren_ b) _ = a `compare` b + +renamed0 :: Renamed +renamed0 = Ren_ 1 + +-- | This is super dirty +trivialRename :: forall f i j. (Id i, Id j, Data (f i)) => f i -> f j +trivialRename = Unsafe.Coerce.unsafeCoerce . everywhere (mkT each) where + each :: i -> i + each _ = Unsafe.Coerce.unsafeCoerce (trivialId :: j) + +trivialRename2 :: forall f g h i j. + (Id i, Id j, Data (f (g i) (h i))) => + f (g i) (h i) -> f (g j) (h j) +trivialRename2 = Unsafe.Coerce.unsafeCoerce . everywhere (mkT each) where + each :: i -> i + each _ = Unsafe.Coerce.unsafeCoerce (trivialId :: j) + +-- IDENTIFIERS + +-- | lowercase identifiers (variables, tycons) +data Lid i + = Lid { + lidUnique :: !i, + unLid :: !String + } + | LidAnti Anti + deriving (Typeable, Data) + +instance Id i => Eq (Lid i) where + a == b = compare a b == EQ + +instance Id i => Ord (Lid i) where + Lid u1 s1 `compare` Lid u2 s2 = compareId u1 u2 (compare s1 s2) + LidAnti a `compare` _ = antierror "Lid#compare" a + _ `compare` LidAnti a = antierror "Lid#compare" a + +-- | uppercase identifiers (modules, datacons) +data Uid i + = Uid { + uidUnique :: !i, + unUid :: !String + } + | UidAnti Anti + deriving (Typeable, Data) + +instance Id i => Eq (Uid i) where + a == b = compare a b == EQ + +instance Id i => Ord (Uid i) where + Uid u1 s1 `compare` Uid u2 s2 = compareId u1 u2 (compare s1 s2) + UidAnti a `compare` _ = antierror "Uid#compare" a + _ `compare` UidAnti a = antierror "Uid#compare" a + +-- | bare (unqualified) identifers +data BIdent i = Var { unVar :: !(Lid i) } + | Con { unCon :: !(Uid i) } + deriving (Eq, Ord, Typeable, Data) + +-- | path-qualified uppercase identifiers +type QUid i = Path (Uid i) (Uid i) +-- | path-qualified lowecase identifiers +type QLid i = Path (Uid i) (Lid i) +-- | path-qualified identifiers +type Ident i = Path (Uid i) (BIdent i) + +-- | Type variables include qualifiers +data TyVar i + = TV { + tvname :: !(Lid i), + tvqual :: !QLit + } + | TVAnti Anti + deriving (Eq, Ord, Typeable, Data) + +lid :: Id i => String -> Lid i +lid = Lid trivialId + +uid :: Id i => String -> Uid i +uid = Uid trivialId + +tvUn, tvAf :: Id i => String -> TyVar i +tvUn s = TV (lid s) Qu +tvAf s = TV (lid s) Qa + +tvalphabet :: Id i => [QLit -> TyVar i] +tvalphabet = map (TV . lid) alphabet + where + alphabet = map return ['a' .. 'z'] ++ + [ x ++ [y] | x <- alphabet, y <- ['a' .. 'z'] ] + +-- | Is the lowercase identifier an infix operator? +isOperator :: Lid i -> Bool +isOperator l = case show l of + '(':_ -> True + _ -> False + +-- | Sugar for generating AST for qualified lowercase identifers +qlid :: Id i => String -> QLid i +qlid s = case reverse (splitBy (=='.') s) of + [] -> J [] (lid "") + x:xs -> J (map uid (reverse xs)) (lid x) + +-- | Sugar for generating AST for qualified uppercase identifers +quid :: Id i => String -> QUid i +quid s = case reverse (splitBy (=='.') s) of + [] -> J [] (uid "") + x:xs -> J (map uid (reverse xs)) (uid x) + +instance Show (Lid i) where + showsPrec _ (Lid _ s) = + case s of + '_':_ -> (s++) + c :_ | isAlpha c -> (s++) + c :_ | isDigit c -> (s++) + _ :_ | head s == '*' || last s == '*' + -> ("( "++) . (s++) . (" )"++) + _ -> ('(':) . (s++) . (')':) + {- + . let z = Unsafe.Coerce.unsafeCoerce i :: Renamed in + if z == Unsafe.Coerce.unsafeCoerce Raw_ + then id + else showChar '[' . shows z . showChar ']' + -} + showsPrec p (LidAnti a) = showsPrec p a + +instance Show (Uid i) where + showsPrec _ (Uid _ s) = (s++) + showsPrec p (UidAnti a) = showsPrec p a + +instance Show (BIdent i) where + showsPrec p (Var x) = showsPrec p x + showsPrec p (Con k) = showsPrec p k + +instance Show (TyVar i) where + showsPrec _ (TV x Qu) = showChar '\'' . shows x + showsPrec _ (TV x Qa) = showChar '`' . shows x + showsPrec _ (TVAnti a) = showChar '\'' . shows a + +instance Viewable (Path (Uid i) (BIdent i)) where + type View (Ident i) = Either (QLid i) (QUid i) + view (J p (Var n)) = Left (J p n) + view (J p (Con n)) = Right (J p n) + +-- | Simple keys embed into path keyspace +instance (Ord p, (:>:) k k') => + (:>:) (Path p k) k' where liftKey = J [] . liftKey + +instance Id i => (:>:) (BIdent i) (Lid i) where liftKey = Var +instance Id i => (:>:) (BIdent i) (Uid i) where liftKey = Con + +--- +--- Identifier antiquotes +--- + +--- +--- Free variables +--- + +-- | Our free variables function returns not merely a set, +-- but a map from names to a count of maximum occurrences. +type FvMap i = M.Map (QLid i) Integer + +-- | The free variables analysis +class Id i => Fv a i | a -> i where + fv :: a -> FvMap i + +-- | The defined variables analysis +class Id i => Dv a i | a -> i where + qdv :: a -> S.Set (QLid i) + dv :: a -> S.Set (Lid i) + + qdv = S.mapMonotonic (J []) . dv + dv a = S.fromDistinctAscList [ v | J [] v <- S.toAscList (qdv a) ] + +instance Fv a i => Fv [a] i where + fv = foldr (|+|) M.empty . map fv + +instance Dv a i => Dv [a] i where + dv = S.unions . map dv + +newtype ADDITIVE a = ADDITIVE [a] + +instance Fv a i => Fv (ADDITIVE a) i where + fv (ADDITIVE a) = foldr (|+|) M.empty (map fv a) + +-- | Used by the free variables analysis +(|*|), (|+|) :: Id i => FvMap i -> FvMap i -> FvMap i +(|*|) = M.unionWith (+) +(|+|) = M.unionWith max + +(|-|) :: Id i => FvMap i -> QLid i -> FvMap i +(|-|) = flip M.delete + +(|--|) :: Id i => FvMap i -> S.Set (QLid i) -> FvMap i +(|--|) = S.fold M.delete diff --git a/src/Syntax/Ident.hs-boot b/src/Syntax/Ident.hs-boot new file mode 100644 --- /dev/null +++ b/src/Syntax/Ident.hs-boot @@ -0,0 +1,10 @@ +module Syntax.Ident where + +import Data.Data (Data) + +class Id i + +data TyVar i + +instance Data i => Data (TyVar i) +instance Id i => Ord (TyVar i) diff --git a/src/Syntax/Kind.hs b/src/Syntax/Kind.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Kind.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE + DeriveDataTypeable, + GeneralizedNewtypeDeriving, + TemplateHaskell, + TypeFamilies #-} +module Syntax.Kind ( + -- * Qualifiers, qualifiers sets, and variance + QLit(..), QExp'(..), + QExp, qeLit, qeVar, qeDisj, qeConj, qeAnti, + QDen, + Variance(..), + -- ** Qualifier operations + qConstBound, elimQLit, + qDenToLit, qDenOfTyVar, qDenFtv, + qInterpretM, qInterpret, qInterpretCanonical, qRepresent, + qSubst, + numberQDenM, numberQDen, numberQDenMap, denumberQDen +) where + +import Meta.DeriveNotable +import PDNF (PDNF) +import qualified PDNF +import Syntax.Anti +import Syntax.Notable +import Syntax.POClass +import {-# SOURCE #-} Syntax.Ident +import Util + +import Control.Monad.Identity (runIdentity) +import Data.List (elemIndex) +import Data.Generics (Typeable, Data) +import qualified Data.Map as M +import qualified Data.Set as S + +-- QUALIFIERS, VARIANCES + +-- | Usage qualifier literals +data QLit + -- | affine + = Qa + -- | unlimited + | Qu + deriving (Eq, Typeable, Data) + +-- | The syntactic version of qualifier expressions, which are +-- positive logical formulae over literals and type variables +data QExp' i + = QeLit QLit + | QeVar (TyVar i) + | QeDisj [QExp i] + | QeConj [QExp i] + | QeAnti Anti + deriving (Typeable, Data) + +type QExp i = Located QExp' i + +deriveNotable ['QeDisj, 'QeConj] ''QExp + +-- | Synthetic constructor to avoid constructing nullary or unary +-- disjunctions +qeDisj :: [QExp i] -> QExp i +qeDisj [] = newN (QeLit Qu) +qeDisj [qe] = qe +qeDisj qes = newN (QeDisj qes) + +-- | Synthetic constructor to avoid constructing nullary or unary +-- conjunctions +qeConj :: [QExp i] -> QExp i +qeConj [] = newN (QeLit Qa) +qeConj [qe] = qe +qeConj qes = newN (QeConj qes) + +-- | The meaning of qualifier expressions +newtype QDen a = QDen { unQDen :: PDNF a } + deriving (Eq, Ord, PO, Bounded, Typeable, Data, Show) + +-- | Tycon parameter variance (like sign analysis) +data Variance + -- | Z + = Invariant + -- | non-negative + | Covariant + -- | non-positive + | Contravariant + -- | { 0 } + | Omnivariant + deriving (Eq, Ord, Typeable, Data) + +--- +--- Operations +--- + +qConstBound :: Ord a => QDen a -> QLit +qConstBound (QDen qden) = + if PDNF.isUnsat qden then Qu else Qa + +elimQLit :: a -> a -> QLit -> a +elimQLit u _ Qu = u +elimQLit _ a Qa = a + +-- | Find the meaning of a qualifier expression +qInterpretM :: (Monad m, Id i) => QExp i -> m (QDen (TyVar i)) +qInterpretM (N note qe0) = case qe0 of + QeLit Qu -> return minBound + QeLit Qa -> return maxBound + QeVar v -> return (QDen (PDNF.variable v)) + QeDisj es -> bigVee `liftM` mapM qInterpretM es + QeConj es -> bigWedge `liftM` mapM qInterpretM es + QeAnti a -> antifail ("Syntax.Kind.qInterpret: " ++ show (getLoc note)) a + +-- | Find the meaning of a qualifier expression +qInterpret :: Id i => QExp i -> QDen (TyVar i) +qInterpret = runIdentity . qInterpretM + +-- | Convert a canonical representation back to a denotation. +-- (Unsafe if the representation is not actually canonical) +qInterpretCanonical :: Id i => QExp i -> QDen (TyVar i) +qInterpretCanonical (N _ (QeDisj clauses)) = QDen $ + PDNF.fromListsUnsafe $ + [ [ v ] | N _ (QeVar v) <- clauses ] ++ + [ [ v | N _ (QeVar v) <- clause ] | N _ (QeConj clause) <- clauses ] +qInterpretCanonical e = qInterpret e + +-- | Return the canonical representation of the meaning of a +-- qualifier expression +qRepresent :: Id i => QDen (TyVar i) -> QExp i +qRepresent (QDen pdnf) + | PDNF.isUnsat pdnf = newN (QeLit Qu) + | PDNF.isValid pdnf = newN (QeLit Qa) + | otherwise = + qeDisj (map (qeConj . map qeVar) + (PDNF.toLists pdnf)) + +qDenToLit :: Ord a => QDen a -> Maybe QLit +qDenToLit (QDen pdnf) + | PDNF.isUnsat pdnf = Just Qu + | PDNF.isValid pdnf = Just Qa + | otherwise = Nothing + +qDenOfTyVar :: Ord a => a -> QDen a +qDenOfTyVar = QDen . PDNF.variable + +qDenFtv :: Ord a => QDen a -> S.Set a +qDenFtv (QDen pdnf) = PDNF.support pdnf + +qSubst :: Ord tv => tv -> QDen tv -> QDen tv -> QDen tv +qSubst v (QDen pdnf1) (QDen pdnf2) = QDen (PDNF.replace v pdnf1 pdnf2) + +numberQDenM :: (Ord tv, Monad m) => + (tv -> m (QDen Int)) -> + [tv] -> QDen tv -> m (QDen Int) +numberQDenM unbound tvs (QDen pdnf) = + liftM QDen $ PDNF.mapReplaceM pdnf $ \tv -> + case tv `elemIndex` tvs of + Nothing -> liftM unQDen $ unbound tv + Just n -> return (PDNF.variable n) + +numberQDen :: Ord tv => [tv] -> QDen tv -> QDen Int +numberQDen = runIdentity <$$> numberQDenM (const (return minBound)) + +numberQDenMap :: Ord tv => + (tv -> QLit) -> + M.Map tv Int -> + QDen tv -> QDen Int +numberQDenMap lit m = runIdentity . numberQDenM get [] where + get tv = case M.lookup tv m of + Just i -> return (QDen (PDNF.variable i)) + Nothing -> return (elimQLit minBound maxBound (lit tv)) + +-- | Given a qualifier set of indices into a list of qualifier +-- expressions, build the qualifier set over the qexps. +-- Assumes that the list is long enough for all indices. +denumberQDen :: Ord tv => [QDen tv] -> QDen Int -> QDen tv +denumberQDen qds (QDen pdnf) = QDen $ + PDNF.mapReplace pdnf $ \ix -> unQDen (qds !! ix) + +instance Show QLit where + showsPrec _ Qa = ('A':) + showsPrec _ Qu = ('U':) + +instance Show Variance where + showsPrec _ Invariant = ('=':) + showsPrec _ Covariant = ('+':) + showsPrec _ Contravariant = ('-':) + showsPrec _ Omnivariant = ('*':) + +instance Bounded QLit where + minBound = Qu + maxBound = Qa + +instance Bounded (QExp' a) where + minBound = QeLit minBound + maxBound = QeLit maxBound + +instance Bounded Variance where + minBound = Omnivariant + maxBound = Invariant + +instance (Ord a, Num a) => Num (QDen a) where + fromInteger = QDen . PDNF.variable . fromInteger + (+) = error "QDen.signum: not implemented" + (*) = error "QDen.signum: not implemented" + abs = error "QDen.signum: not implemented" + signum = error "QDen.signum: not implemented" + +-- | The variance lattice: +-- +-- @ +-- (In) +-- = +-- (Co) + - (Contra) +-- * +-- (Omni) +-- @ +instance PO Variance where + Covariant \/ Covariant = Covariant + Contravariant \/ Contravariant = Contravariant + v \/ Omnivariant = v + Omnivariant \/ v = v + _ \/ _ = Invariant + + Covariant /\ Covariant = Covariant + Contravariant /\ Contravariant = Contravariant + v /\ Invariant = v + Invariant /\ v = v + _ /\ _ = Omnivariant + +-- | The qualifier lattice +-- @ +-- Qa +-- | +-- Qu +-- @ +instance PO QLit where + Qu \/ Qu = Qu + _ \/ _ = Qa + Qa /\ Qa = Qa + _ /\ _ = Qu + +instance Ord QLit where + (<=) = (<:) + +-- | Variance has a bit more structure still -- it does sign analysis: +instance Num Variance where + Covariant * Covariant = Covariant + Covariant * Contravariant = Contravariant + Contravariant * Covariant = Contravariant + Contravariant * Contravariant = Covariant + Omnivariant * _ = Omnivariant + _ * Omnivariant = Omnivariant + _ * _ = Invariant + + (+) = (\/) + negate = (* Contravariant) + abs x = x * x + signum = id + + x - y = x + negate y + + fromInteger n | n > 0 = Covariant + | n < 0 = Contravariant + | otherwise = Omnivariant + diff --git a/src/Syntax/Lit.hs b/src/Syntax/Lit.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Lit.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE + DeriveDataTypeable, + TemplateHaskell #-} +module Syntax.Lit ( + Lit(..) +) where + +import Syntax.Anti + +import Data.Generics (Typeable, Data) + +-- | Literals +data Lit + = LtInt Integer + | LtStr String + | LtFloat Double + | LtAnti Anti + deriving (Eq, Typeable, Data) diff --git a/src/Syntax/Notable.hs b/src/Syntax/Notable.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Notable.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE + DeriveDataTypeable, + FlexibleContexts, + GeneralizedNewtypeDeriving, + DeriveFunctor, + TypeFamilies #-} +module Syntax.Notable ( + Notable(..), N(..), Located, + LocNote(..), module Loc +) where + +import Loc +import Viewable + +import Data.Data + +class Notable note where + newNote :: note + newN :: a -> N note a + newN = N newNote + locN :: Relocatable note => Loc -> a -> N note a + locN loc a = newN a `setLoc` loc + +data N note a + = N { + noteOf :: !note, + dataOf :: !a + } + deriving (Typeable, Data, Functor) + +instance Eq a => Eq (N note a) where + a == b = dataOf a == dataOf b + +instance Ord a => Ord (N note a) where + a `compare` b = dataOf a `compare` dataOf b + +instance (Notable note, Bounded a) => Bounded (N note a) where + minBound = newN minBound + maxBound = newN maxBound + +instance Locatable note => Locatable (N note a) where + getLoc (N note _) = getLoc note + +instance Relocatable note => Relocatable (N note a) where + setLoc (N note val) loc = N (setLoc note loc) val + +instance Viewable (N note a) where + type View (N note a) = a + view = dataOf + +newtype LocNote i = LocNote { unLocNote :: Loc } + deriving (Eq, Ord, Data, Typeable, Locatable, Relocatable) + +instance Show (LocNote i) where + showsPrec p = showsPrec p . unLocNote + +type Located f i = N (LocNote i) (f i) + +instance Notable (LocNote i) where + newNote = LocNote bogus diff --git a/src/Syntax/POClass.hs b/src/Syntax/POClass.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/POClass.hs @@ -0,0 +1,86 @@ +module Syntax.POClass ( + -- * Partial orders + PO(..), bigVee, bigVeeM, bigWedge, bigWedgeM, +) where + +import Util + +import qualified Data.Set as S + +-- | Partial orders. +-- Minimal complete definition is one of: +-- +-- * 'ifMJ' +-- +-- * '\/', '/\' (only if it's a lattice) +-- +-- * '\/?', '/\?' (partial join and meet) +class Eq a => PO a where + -- | Takes a boolean parameter, and does join if true + -- and meet if false. This sometimes allows us to exploit duality + -- to define both at once. + ifMJ :: Monad m => Bool -> a -> a -> m a + ifMJ True x y = return (x \/ y) + ifMJ False x y = return (x /\ y) + + -- | Partial join returns in a monad, in case join DNE + (\/?) :: Monad m => a -> a -> m a + (\/?) = ifMJ True + + -- | Partial meet returns in a monad, in case meet DNE + (/\?) :: Monad m => a -> a -> m a + (/\?) = ifMJ False + + -- | Total join + (\/) :: a -> a -> a + -- | Total meet + (/\) :: a -> a -> a + x \/ y = fromJust (x \/? y) + x /\ y = fromJust (x /\? y) + + -- | The order relation (derived) + (<:) :: a -> a -> Bool + x <: y = Just x == (x /\? y) + || Just y == (x \/? y) + + -- | The complement of the order relation (derived) + (/<:) :: a -> a -> Bool + (/<:) = not <$$> (<:) + +infixl 7 /\, /\? +infixl 6 \/, \/? +infix 4 <: + +bigVee :: (Bounded a, PO a) => [a] -> a +bigVee = foldr (\/) minBound + +bigVeeM :: (Monad m, Bounded a, PO a) => [a] -> m a +bigVeeM = foldrM (\/?) minBound + +bigWedge :: (Bounded a, PO a) => [a] -> a +bigWedge = foldr (/\) maxBound + +bigWedgeM :: (Monad m, Bounded a, PO a) => [a] -> m a +bigWedgeM = foldrM (/\?) maxBound + +instance Ord a => PO (S.Set a) where + (\/) = S.union + (/\) = S.intersection + +instance PO a => PO (Maybe a) where + Just a \/? Just b = liftM Just (a \/? b) + Nothing \/? b = return b + a \/? Nothing = return a + + Just a /\? Just b = return (a /\? b) + Nothing /\? _ = return Nothing + _ /\? Nothing = return Nothing + + Just a <: Just b = a <: b + Nothing <: _ = True + _ <: Nothing = False + +instance (PO a, PO b) => PO (a, b) where + ifMJ d (a, b) (a', b') = liftM2 (,) (ifMJ d a a') (ifMJ d b b') + (a, b) <: (a', b') = a <: a' && b <: b' + diff --git a/src/Syntax/Patt.hs b/src/Syntax/Patt.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Patt.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE + DeriveDataTypeable, + FlexibleInstances, + MultiParamTypeClasses, + NoMonomorphismRestriction, + TemplateHaskell, + TypeFamilies, + TypeSynonymInstances #-} +module Syntax.Patt ( + Patt'(..), Patt, PattNote(..), newPatt, + paWild, paVar, paCon, paPair, paLit, paAs, paPack, paAnti, + dtv +) where + +import Meta.DeriveNotable +import Syntax.Notable +import Syntax.Anti +import Syntax.Ident +import Syntax.Lit + +import qualified Data.Set as S +import Data.Generics (Typeable, Data) + +type Patt i = N (PattNote i) (Patt' i) + +-- | Patterns +data Patt' i + -- | wildcard + = PaWild + -- | variable pattern + | PaVar (Lid i) + -- | datacon, possibly with parameter, possibly an exception + | PaCon (QUid i) (Maybe (Patt i)) + -- | pair pattern + | PaPair (Patt i) (Patt i) + -- | literal pattern + | PaLit Lit + -- | bind an identifer and a pattern (@as@) + | PaAs (Patt i) (Lid i) + -- | existential opening + | PaPack (TyVar i) (Patt i) + -- | antiquote + | PaAnti Anti + deriving (Typeable, Data) + +data PattNote i + = PattNote { + -- | source location + ploc_ :: !Loc, + -- | defined variables + pdv_ :: S.Set (Lid i), + -- | defined type variables + pdtv_ :: S.Set (TyVar i) + } + deriving (Typeable, Data) + +instance Locatable (PattNote i) where + getLoc = ploc_ + +instance Relocatable (PattNote i) where + setLoc note loc = note { ploc_ = loc } + +instance Notable (PattNote i) where + newNote = PattNote bogus S.empty S.empty + +newPatt :: Id i => Patt' i -> Patt i +newPatt p0 = flip N p0 $ case p0 of + PaWild -> + newNote { + pdv_ = S.empty, + pdtv_ = S.empty + } + PaVar x -> + newNote { + pdv_ = S.singleton x, + pdtv_ = S.empty + } + PaCon _ Nothing -> + newNote { + pdv_ = S.empty, + pdtv_ = S.empty + } + PaCon _ (Just x) -> + newNote { + pdv_ = dv x, + pdtv_ = dtv x + } + PaPair x y -> + newNote { + pdv_ = dv x `S.union` dv y, + pdtv_ = dtv x `S.union` dtv y + } + PaLit _ -> + newNote { + pdv_ = S.empty, + pdtv_ = S.empty + } + PaAs x y -> + newNote { + pdv_ = S.insert y (dv x), + pdtv_ = dtv x + } + PaPack tv x -> + newNote { + pdv_ = dv x, + pdtv_ = S.insert tv (dtv x) + } + PaAnti a -> + newNote { + pdv_ = antierror "dv" a, + pdtv_ = antierror "dtv" a + } + +instance Id i => Dv (N (PattNote i) a) i where + dv = pdv_ . noteOf + +dtv :: Id i => Patt i -> S.Set (TyVar i) +dtv = pdtv_ . noteOf + +deriveNotable 'newPatt (''Id, [0]) ''Patt + diff --git a/src/Syntax/SyntaxTable.hs b/src/Syntax/SyntaxTable.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/SyntaxTable.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE + RankNTypes, + TemplateHaskell #-} +module Syntax.SyntaxTable where + +import Meta.THHelpers +import Syntax.Anti +import Syntax.Notable +import Syntax.Ident +import Syntax.Kind +import Syntax.Type +import Syntax.Lit +import Syntax.Patt +import Syntax.Expr +import Syntax.Decl + +import qualified Data.Map as M +import qualified Language.Haskell.TH as TH + +litAntis, pattAntis, + exprAntis, bindingAntis, caseAltAntis, + typeAntis, tyPatAntis, quantAntis, qExpAntis, tyVarAntis, + declAntis, tyDecAntis, absTyAntis, modExpAntis, + sigExpAntis, sigItemAntis, + lidAntis, uidAntis, qlidAntis, quidAntis, idAntis, noAntis + :: AntiDict + +litAntis + = "lit" =: Nothing + & "str" =:< 'LtStr + & "int" =:< 'LtInt + & "flo" =:< 'LtFloat + & "float" =:< 'LtFloat + & "antiL" =:< 'LtAnti +pattAntis + = "patt" =:! Nothing + & "anti" =:< 'PaAnti +exprAntis + = "expr" =:! Nothing + & "anti" =:< 'ExAnti +bindingAntis + = "bind" =:! Nothing + & "antiB" =:< 'BnAnti +caseAltAntis + = "case" =: Nothing + & "antiC" =:< 'CaAnti +typeAntis + = "type" =:! Nothing + & "stx" =: appFun (TH.mkName "typeToStx'") + & "anti" =:< 'TyAnti +tyPatAntis + = "typat" =: Nothing + & "antiP" =:< 'TpAnti +quantAntis + = "quant" =: Nothing + & "antiQ" =:< 'QuantAnti +qExpAntis + = "qexp" =:! Nothing + & "qlit" =:< 'QeLit + & "qvar" =:< 'QeVar + & "qdisj" =:< 'QeDisj + & "qconj" =:< 'QeConj + & "anti" =:< 'QeAnti +tyVarAntis + = "tyvar" =:! Nothing + & "anti" =:< 'TVAnti +declAntis + = "decl" =:! Nothing + & "anti" =:< 'DcAnti +tyDecAntis + = "tydec" =:! Nothing + & "anti" =:< 'TdAnti +absTyAntis + = "absty" =:! Nothing + & "anti" =:< 'AbsTyAnti +modExpAntis + = "mod" =:! Nothing + & "anti" =:< 'MeAnti +sigExpAntis + = "sig" =:! Nothing + & "anti" =:< 'SeAnti +sigItemAntis + = "sgitem" =:! Nothing + & "anti" =:< 'SgAnti +lidAntis + = "lid" =: Nothing + & "name" =: Just (\v -> varS 'lid [varS v []] + `whichS` conS 'Lid [wildS, varS v []]) + & "antiLid"=:< 'LidAnti +uidAntis + = "uid" =: Nothing + & "uname" =: Just (\v -> varS 'uid [varS v []] + `whichS` conS 'Uid [wildS, varS v []]) + & "antiUid"=:< 'LidAnti +qlidAntis + = "qlid" =: Nothing + & "qname" =: appFun 'qlid -- error in pattern context +quidAntis + = "quid" =: Nothing + & "quname" =: appFun 'quid -- error in pattern context +idAntis + = "id" =: Nothing +noAntis + = M.empty + +appFun :: ToSyntax b => TH.Name -> Maybe (String -> TH.Q b) +appFun n = Just (\v -> varS n [varS v []]) + +syntaxTable :: SyntaxTable +syntaxTable = + [ ''Prog =:: 'Prog !: 'newN >: (''Id, [0]) + , ''Lit =:: 'LtAnti $: 'litAntis + , ''Patt =:: 'PaAnti $: 'pattAntis !: 'newPatt >: (''Id, [0]) + , ''Expr =:: 'ExAnti $: 'exprAntis !: 'newExpr >: (''Id, [0]) + , ''Binding =:: 'BnAnti $: 'bindingAntis !: 'newBinding >: (''Id, [0]) + , ''CaseAlt =:: 'CaAnti $: 'caseAltAntis !: 'newCaseAlt >: (''Id, [0]) + , ''Type =:: 'TyAnti $: 'typeAntis !: 'newN + , ''TyPat =:: 'TpAnti $: 'tyPatAntis !: 'newN + , ''Quant =:: 'QuantAnti $: 'quantAntis + , ''QExp =:: 'QeAnti $: 'qExpAntis !: 'newN + , ''TyVar =:: 'TVAnti $: 'tyVarAntis + , ''Decl =:: 'DcAnti $: 'declAntis !: 'newDecl >: (''Id, [0]) + , ''TyDec =:: 'TdAnti $: 'tyDecAntis !: 'newN + , ''AbsTy =:: 'AbsTyAnti $: 'absTyAntis !: 'newN + , ''ModExp =:: 'MeAnti $: 'modExpAntis !: 'newModExp >: (''Id, [0]) + , ''SigExp =:: 'SeAnti $: 'sigExpAntis !: 'newSigExp >: (''Id, [0]) + , ''SigItem =:: 'SgAnti $: 'sigItemAntis !: 'newSigItem >: (''Id, [0]) + , ''Lid =:: 'LidAnti $: 'lidAntis + , ''Uid =:: 'UidAnti $: 'uidAntis + , ''QLid =:: '() + , ''QUid =:: '() + , ''Ident =:: '() + ] + diff --git a/src/Syntax/Type.hs b/src/Syntax/Type.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Type.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE + DeriveDataTypeable, + FlexibleInstances, + ParallelListComp, + TemplateHaskell, + TypeFamilies #-} +module Syntax.Type ( + -- * Types + Quant(..), Type'(..), Type, TyPat'(..), TyPat, + -- ** Constructors + tyApp, tyVar, tyFun, tyQu, tyMu, tyAnti, + tpVar, tpApp, tpAnti, + + -- * Built-in types + tyNulOp, tyUnOp, tyBinOp, + tyUnit, tyTuple, tyUn, tyAf, + -- ** Convenience constructors + tyArr, tyLol, + tyAll, tyEx, + + -- * Miscellany + dumpType +) where + +import Meta.DeriveNotable +import Syntax.Notable +import Syntax.Anti +import Syntax.Kind +import Syntax.Ident + +import Data.Generics (Typeable, Data) + +-- | Type quantifers +data Quant = Forall | Exists | QuantAnti Anti + deriving (Typeable, Data, Eq, Ord) + +type Type i = Located Type' i +type TyPat i = Located TyPat' i + +-- | Types are parameterized by [@i@], the type of information +-- associated with each tycon +data Type' i + = TyApp (QLid i) [Type i] + | TyVar (TyVar i) + | TyFun (QExp i) (Type i) (Type i) + | TyQu Quant (TyVar i) (Type i) + | TyMu (TyVar i) (Type i) + | TyAnti Anti + deriving (Typeable, Data) + +-- | Type patterns for defining type operators +data TyPat' i + -- | type variables + = TpVar (TyVar i) Variance + -- | type constructor applications + | TpApp (QLid i) [TyPat i] + -- | antiquotes + | TpAnti Anti + deriving (Typeable, Data) + +deriveNotable ''Type +deriveNotable ''TyPat + +-- | Convenience constructors for qualified types +tyAll, tyEx :: TyVar i -> Type i -> Type i +tyAll = tyQu Forall +tyEx = tyQu Exists + +instance Show Quant where + show Forall = "all" + show Exists = "ex" + show (QuantAnti a) = show a + +--- +--- Built-in types +--- + +--- Convenience constructors + +tyNulOp :: Id i => String -> Type i +tyNulOp s = tyApp (qlid s) [] + +tyUnOp :: Id i => String -> Type i -> Type i +tyUnOp s a = tyApp (qlid s) [a] + +tyBinOp :: Id i => String -> Type i -> Type i -> Type i +tyBinOp s a b = tyApp (qlid s) [a, b] + +tyUnit :: Id i => Type i +tyUnit = tyNulOp "unit" + +tyTuple :: Id i => Type i -> Type i -> Type i +tyTuple = tyBinOp "*" + +tyUn :: Id i => Type i +tyUn = tyNulOp "U" + +tyAf :: Id i => Type i +tyAf = tyNulOp "A" + +tyArr :: Type i -> Type i -> Type i +tyArr = tyFun minBound + +tyLol :: Type i -> Type i -> Type i +tyLol = tyFun maxBound + +infixr 8 `tyArr`, `tyLol` + +-- | Noisy type printer for debugging +dumpType :: Id i => Int -> Type i -> IO () +dumpType i (N _ t0) = do + putStr (replicate i ' ') + case t0 of + TyApp n ps -> do + putStrLn $ show n ++ " {" + mapM_ (dumpType (i + 2)) ps + putStrLn (replicate i ' ' ++ "}") + TyFun q dom cod -> do + putStrLn $ "-[" ++ maybe "ANTI" show (qInterpretM q) ++ "]> {" + dumpType (i + 2) dom + dumpType (i + 2) cod + putStrLn (replicate i ' ' ++ "}") + TyVar tv -> print tv + TyQu u a t -> do + print $ show u ++ " " ++ show a ++ ". {" + dumpType (i + 2) t + putStrLn (replicate i ' ' ++ "}") + TyMu a t -> do + print $ "mu " ++ show a ++ ". {" + dumpType (i + 2) t + putStrLn (replicate i ' ' ++ "}") + TyAnti a -> do + print a + diff --git a/src/Type.hs b/src/Type.hs new file mode 100644 --- /dev/null +++ b/src/Type.hs @@ -0,0 +1,955 @@ +-- | The internal representation of types, created by the type checker +-- from the syntactic types in 'Syntax.Type'. +{-# LANGUAGE + DeriveDataTypeable, + DeriveFunctor, + ViewPatterns, + FlexibleInstances, + ParallelListComp, + PatternGuards, + ScopedTypeVariables, + TypeFamilies #-} +module Type ( + -- * Representation of types + Type(..), TyCon(..), TyVarR, TyPat(..), tyApp, + -- * Type reduction + ReductionState(..), + -- ** Head reduction + isHeadNormalType, headReduceType, + headNormalizeTypeK, headNormalizeTypeM, + headNormalizeType, + -- ** Deep reduction + isNormalType, normalizeTypeK, normalizeType, + -- ** Freshness + Ftv(..), freshTyVar, freshTyVars, + fastFreshTyVar, fastFreshTyVars, + -- ** Substitutions + tysubst, tysubsts, tyrename, + -- * Miscellaneous type operations + castableType, typeToStx, typeToStx', tyPatToStx, tyPatToStx', + tyPatToType, qualifier, + -- ** Type varieties + TypeVariety(..), isAbstractTyCon, varietyOf, + -- * Built-in types + -- ** Type constructors + mkTC, + tcBot, tcUnit, tcInt, tcFloat, tcString, tcExn, tcTuple, tcUn, tcAf, + -- ** Types + tyNulOp, tyUnOp, tyBinOp, + tyArr, tyLol, + tyAll, tyEx, + -- *** Convenience + tyBot, tyUnit, tyInt, tyFloat, tyString, tyExn, tyUn, tyAf, tyTop, + tyIdent, tyConst, + tyTuple, + (.*.), (.->.), (.-*.), + -- * Views + vtAppTc, isBotType, + -- ** Unfolds + vtFuns, vtQus, + -- * Re-exports + module Syntax.Ident, + module Syntax.Kind, + module Syntax.POClass, + Stx.Quant(..), + -- * Debugging and testing + dumpType, + tcSend, tcRecv, tcSelect, tcFollow, tcSemi, tcDual, + tySend, tyRecv, tyDual, tySelect, tyFollow, tySemi, (.:.), +) where + +import qualified Env +import Ppr +import Syntax.Ident +import Syntax.Kind +import Syntax.POClass +import qualified Syntax as Stx +import Util +import Viewable + +import qualified Control.Monad.Writer as CMW +import Data.Char (isDigit) +import Data.Generics (Typeable, Data, everything, mkQ) +import qualified Data.Map as M +import qualified Data.Set as S + +-- | All tyvars are renamed by this point +type TyVarR = TyVar Renamed + +-- | The internal representation of a type +data Type + -- | A type variable + = TyVar TyVarR + -- | The application of a type constructor (possibly nullary); the + -- third field caches the next head-reduction step if the type + -- is not head-normal -- note that substitution invalidates this + -- cache. Use 'tyApp' to construct a type application that + -- (re)initializes the cache. + | TyApp TyCon [Type] (ReductionState Type) + -- | An arrow type, including qualifier expression + | TyFun (QDen TyVarR) Type Type + -- | A quantified (all or ex) type + | TyQu Stx.Quant TyVarR Type + -- | A recursive (mu) type + | TyMu TyVarR Type + deriving (Typeable, Data) + +-- | Information about a type constructor +data TyCon + = TyCon { + -- | Unique ID + tcId :: Int, + -- | Printable name + tcName :: (QLid Renamed), + -- | Variances for parameters, and correct length + tcArity :: [Variance], + -- | Bounds for parameters (may be infinite) + tcBounds :: [QLit], + -- | Qualifier as a function of parameters + tcQual :: (QDen Int), + -- | For pattern-matchable types, the data constructors + tcCons :: ([TyVarR], Env.Env (Uid Renamed) (Maybe Type)), + -- | For type operators, the next head reduction + tcNext :: Maybe [([TyPat], Type)] + } + deriving (Typeable, Data) + +-- | A type pattern, for defining type operators +data TyPat + -- | A type variable, matching any type and binding + = TpVar TyVarR + -- | A type application node, matching the given constructor + -- and its parameters + | TpApp TyCon [TyPat] + deriving (Typeable, Data) + +instance Eq TyCon where + tc == tc' = tcId tc == tcId tc' + +instance Ord TyCon where + compare tc tc' = compare (tcName tc) (tcName tc') + +instance Ppr Type where pprPrec p = pprPrec p . typeToStx +instance Show Type where showsPrec = showFromPpr +instance Ppr TyPat where pprPrec p = pprPrec p . tyPatToStx +instance Show TyPat where showsPrec = showFromPpr + +-- | The different varieties of type definitions +data TypeVariety + -- | Type operators and synonyms + = OperatorType + -- | Datatype + | DataType + -- | Abstract type + | AbstractType + deriving (Eq, Ord, Typeable, Data) + +instance Show TypeVariety where + showsPrec _ OperatorType = showString "a type operator" + showsPrec _ DataType = showString "a datatype" + showsPrec _ AbstractType = showString "abstract" + +-- | What variety of type definition do we have? +varietyOf :: TyCon -> TypeVariety +varietyOf TyCon { tcNext = Just _ } = OperatorType +varietyOf TyCon { tcCons = (_, e) } = + if Env.isEmpty e then AbstractType else DataType + +-- | Find the qualifier of a type +qualifier :: Type -> QDen TyVarR +qualifier (TyApp tc ts _) = denumberQDen (map qualifier ts) (tcQual tc) +qualifier (TyFun q _ _) = q +qualifier (TyVar tv) + | tvqual tv <: Qu = minBound + | otherwise = qInterpret (qeVar tv) +qualifier (TyQu _ tv t) = qSubst tv minBound (qualifier t) +qualifier (TyMu tv t) = qSubst tv minBound (qualifier t) + +-- | Is the given type constructor abstract? +isAbstractTyCon :: TyCon -> Bool +isAbstractTyCon = (== AbstractType) . varietyOf + +--- +--- Free type variables, freshness, and substitution +--- + +-- | Class for getting free type variables (from types, expressions, +-- lists thereof, pairs thereof, etc.) +class Ftv a where + ftvVs :: a -> M.Map TyVarR Variance + ftv :: a -> S.Set TyVarR + ftv = M.keysSet . ftvVs + alltv :: a -> S.Set TyVarR + maxtv :: a -> Renamed + +instance Ftv Type where + ftv (TyApp _ ts _) = S.unions (map ftv ts) + ftv (TyVar tv) = S.singleton tv + ftv (TyFun q t1 t2) = S.unions [ftv t1, ftv t2, ftv q] + ftv (TyQu _ tv t) = S.delete tv (ftv t) + ftv (TyMu tv t) = S.delete tv (ftv t) + -- + ftvVs (TyApp tc ts _) = M.unionsWith (+) + [ M.map (* var) m + | var <- tcArity tc + | m <- map ftvVs ts ] + ftvVs (TyFun q t1 t2) = M.unionsWith (+) + [ ftvVs q + , M.map negate (ftvVs t1) + , ftvVs t2 ] + ftvVs (TyVar tv) = M.singleton tv 1 + ftvVs (TyQu _ tv t) = M.delete tv (ftvVs t) + ftvVs (TyMu tv t) = M.delete tv (ftvVs t) + -- + alltv (TyApp _ ts _) = alltv ts + alltv (TyVar tv) = alltv tv + alltv (TyFun q t1 t2) = alltv q `S.union` alltv t1 `S.union` alltv t2 + alltv (TyQu _ tv t) = tv `S.insert` alltv t + alltv (TyMu tv t) = tv `S.insert` alltv t + -- + maxtv (TyApp _ ts _) = maxtv ts + maxtv (TyVar tv) = maxtv tv + maxtv (TyFun q t1 t2) = maxtv q `max` maxtv t1 `max` maxtv t2 + maxtv (TyQu _ tv t) = maxtv tv `max` maxtv t + maxtv (TyMu tv t) = maxtv tv `max` maxtv t + +instance (Data a, Ord a, Ftv a) => Ftv (QDen a) where + ftv = everything S.union (mkQ S.empty (ftv :: a -> S.Set TyVarR)) + ftvVs = everything M.union + (mkQ M.empty (ftvVs :: a -> M.Map TyVarR Variance)) + alltv = everything S.union (mkQ S.empty (alltv :: a -> S.Set TyVarR)) + maxtv = everything max (mkQ trivialId (maxtv :: a -> Renamed)) + +instance Ftv a => Ftv [a] where + ftv = S.unions . map ftv + ftvVs = M.unionsWith (+) . map ftvVs + alltv = S.unions . map alltv + maxtv [] = trivialId + maxtv xs = maximum (map maxtv xs) + +instance (i ~ Renamed) => Ftv (TyVar i) where + ftv = S.singleton + ftvVs tv = M.singleton tv 1 + alltv = S.singleton + maxtv = lidUnique . tvname + +instance Ftv () where + ftv _ = S.empty + ftvVs _ = M.empty + alltv _ = S.empty + maxtv _ = maximum [] + +instance Ftv a => Ftv (Maybe a) where + ftv = maybe (ftv ()) ftv + ftvVs = maybe (ftvVs ()) ftvVs + alltv = maybe (alltv ()) alltv + maxtv = maybe (maxtv ()) maxtv + +instance (Ftv a, Ftv b) => Ftv (a, b) where + ftv (a, b) = ftv a `S.union` ftv b + ftvVs (a, b) = M.unionWith (+) (ftvVs a) (ftvVs b) + alltv (a, b) = alltv a `S.union` alltv b + maxtv (a, b) = maxtv a `max` maxtv b + +instance (Ftv a, Ftv b, Ftv c) => Ftv (a, b, c) where + ftv (a, b, c) = ftv (a, (b, c)) + ftvVs (a, b, c) = ftvVs (a, (b, c)) + alltv (a, b, c) = alltv (a, (b, c)) + maxtv (a, b, c) = maxtv (a, (b, c)) + +instance (Ftv a, Ftv b, Ftv c, Ftv d) => Ftv (a, b, c, d) where + ftv (a, b, c, d) = ftv ((a, b), (c, d)) + ftvVs (a, b, c, d) = ftvVs ((a, b), (c, d)) + alltv (a, b, c, d) = alltv ((a, b), (c, d)) + maxtv (a, b, c, d) = maxtv ((a, b), (c, d)) + +-- Rename a type variable, if necessary, to make its unique tag higher +-- than the one given +fastFreshTyVar :: TyVarR -> Renamed -> TyVarR +fastFreshTyVar tv@(TV (Lid i n) q) imax = + if i > imax + then tv + else TV (Lid (succ imax) n) q +fastFreshTyVar (TVAnti a) _ = Stx.antierror "Type.fastFreshTyVar" a +fastFreshTyVar (TV (LidAnti a) _) _ = Stx.antierror "Type.fastFreshTyVar" a + +-- Rename a list of type variables, if necessary, to make each unique tag +-- higher than the one given and mutually unique +fastFreshTyVars :: [TyVarR] -> Renamed -> [TyVarR] +fastFreshTyVars [] _ = [] +fastFreshTyVars (tv:tvs) imax = + let tv' = fastFreshTyVar tv imax in + tv' : fastFreshTyVars tvs (imax `max` maxtv tv') + +-- | Given a type variable, rename it (if necessary) to make it +-- fresh for a set of type variables. +freshTyVar :: TyVarR -> S.Set TyVarR -> TyVarR +freshTyVar (TV l q) set = TV l' q where + l' = if unLid l `S.member` names + then lid (loop count) + else l + names = S.map (unLid . tvname) set + loop n = + let tv' = prefix ++ show n + in if tv' `S.member` names + then loop (n + 1) + else tv' + suffix = reverse . takeWhile isDigit . reverse . unLid $ l + prefix = reverse . dropWhile isDigit . reverse . unLid $ l + count = case reads suffix of + ((n, ""):_) -> n + _ -> 1::Integer +freshTyVar (TVAnti a) _ = Stx.antierror "Type.freshTyVar" a + +-- | Given a list of type variables, rename them (if necessary) to make +-- each of them fresh for both the set of type variables and each +-- other. +freshTyVars :: [TyVarR] -> S.Set TyVarR -> [TyVarR] +freshTyVars [] _ = [] +freshTyVars (tv:tvs) set = tv' : freshTyVars tvs (S.insert tv' set) + where tv' = freshTyVar tv (set `S.union` S.fromList tvs) + +-- | Type substitution +tysubst :: TyVarR -> Type -> Type -> Type +tysubst a t = loop where + loop (TyVar a') + | a' == a = t + | otherwise = TyVar a' + loop (TyFun q t1 t2) + = TyFun (qSubst a (qualifier t) q) (loop t1) (loop t2) + loop (TyApp tc ts _) + = tyApp tc (map loop ts) + loop (TyQu u a' t') + | a' == a = TyQu u a' t' + | a'' <- fastFreshTyVar a' imax + = TyQu u a'' (loop (tysubst a' (TyVar a'') t')) + loop (TyMu a' t') + | a' == a = TyMu a' t' + | a'' <- fastFreshTyVar a' imax + = TyMu a'' (loop (tysubst a' (TyVar a'') t')) + imax = maxtv (a, t) + +-- | Given a list of type variables and types, perform all the +-- substitutions, avoiding capture between them. +tysubsts :: [TyVarR] -> [Type] -> Type -> Type +tysubsts ps ts t = + let ps' = fastFreshTyVars ps (maxtv (t:ts)) + substs tvs ts0 t0 = foldr2 tysubst t0 tvs ts0 in + substs ps' ts . + substs ps (map TyVar ps') $ + t + +-- | Rename a type variable +tyrename :: TyVarR -> TyVarR -> Type -> Type +tyrename tv = tysubst tv . TyVar + +--- +--- Type reduction +--- + +-- | As we head-reduce a type, it can be in one of four states: +data ReductionState t + -- | The type is head-normal -- that is, its head constructor is + -- not a type synonym/operator + = Done + -- | The type has a next head-reduction step + | Next t + -- | The type may reduce further in the future, but right now it + -- has a pattern match that depends on the value of a type variable + | Blocked + -- | The type's head constructor is a synonym/operator, but it + -- can never take a step, due to a failed pattern match + | Stuck + deriving (Eq, Ord, Show, Functor, Typeable, Data) + +-- | Helper type for 'tyApp' +type MatchResult t = Either (ReductionState t) ([TyVarR], [Type]) + +-- | Creates a type application, initializing the head-reduction cache +tyApp :: TyCon -> [Type] -> Type +tyApp tc0 ts0 = TyApp tc0 ts0 $ maybe Done clauses (tcNext tc0) where + clauses [] = Stuck + clauses ((tps, rhs):rest) = case patts tps ts0 of + Right (xs, us) -> Next (tysubsts xs us rhs) + Left Stuck -> clauses rest + Left rs -> fmap (tyApp tc0) rs + + patts :: [TyPat] -> [Type] -> MatchResult [Type] + patts [] [] = Right ([], []) + patts (tp:tps) (t:ts) = case patt tp t of + Right (xs, us) -> case patts tps ts of + Right (xs', us') -> Right (xs ++ xs', us ++ us') + Left rs -> Left (fmap (t:) rs) + Left Blocked -> Left (either (fmap (t:)) + (const Blocked) + (patts tps ts)) + Left rs -> Left (fmap (:ts) rs) + patts _ _ = Left Stuck + + patt :: TyPat -> Type -> MatchResult Type + patt (TpVar tv) t = Right ([tv], [t]) + patt (TpApp tc tps) t = case t of + TyApp tc' ts next + | tc == tc' -> (fmap (tyApp tc') +++ id) (patts tps ts) + | Done <- next -> Left Stuck + | otherwise -> Left next + TyMu tv t1 -> Left (Next (tysubst tv (TyMu tv t1) t1)) + TyVar _ -> Left Blocked + _ -> Left Stuck + +-- | Takes one head reduction step. Returns 'Nothing' if the type is +-- already head-normal. +headReduceType :: Type -> ReductionState Type +headReduceType (TyApp _ _ next) = next +headReduceType _ = Done + +-- | Is the type head-normal? A type is head-normal unless its +-- top-level constructor is a type operator which can currently +-- take a step. +isHeadNormalType :: Type -> Bool +isHeadNormalType t = case headReduceType t of + Next _ -> False + _ -> True + +-- | Head reduces a type until it is head-normal, given some amount of fuel +headNormalizeTypeF :: Type -> Fuel (ReductionState (), Type) Type +headNormalizeTypeF t = case headReduceType t of + Done -> pure t + Next t' -> burnFuel (Next (), t') *> headNormalizeTypeF t' + Blocked -> bailOut (Blocked, t) + Stuck -> bailOut (Stuck, t) + +-- | Head reduces a type until it is head-normal or we run out of steps +headNormalizeTypeK :: Int -> Type -> (ReductionState (), Type) +headNormalizeTypeK fuel t = case evalFuel (headNormalizeTypeF t) fuel of + Right t' -> (Done, t') + Left (rs, t') -> (rs, t') + +headNormalizeTypeM :: Monad m => Int -> Type -> m Type +headNormalizeTypeM limit t = case headNormalizeTypeK limit t of + (Next (), t') -> fail $ + "Gave up reducing type `" ++ show t' ++ + "' after " ++ show limit ++ " steps" + (_, t') -> return t' + +-- | Head reduces a type until it is head-normal +headNormalizeType :: Type -> Type +headNormalizeType = snd . headNormalizeTypeK (-1) + +-- | Is the type in normal form? +isNormalType :: Type -> Bool +isNormalType t = case t of + TyVar _ -> True + TyFun _ t1 t2 -> isNormalType t1 && isNormalType t2 + TyApp _ ts _ -> isHeadNormalType t && all isNormalType ts + TyQu _ _ t1 -> isNormalType t1 + TyMu _ t1 -> isNormalType t1 + +-- | Reduces a type until it is normal, given some amount of fuel +normalizeTypeF :: Type -> Fuel (ReductionState (), Type) Type +normalizeTypeF t0 = do + t <- headNormalizeTypeF t0 + case t of + TyVar _ -> pure t + TyFun q t1 t2 -> do + t1' <- normalizeTypeF t1 `mapError` fmap (flip (TyFun q) t2) + t2' <- normalizeTypeF t2 `mapError` fmap (TyFun q t1') + return (TyFun q t1' t2') + TyApp tc ts0 _ -> do + let loop [] = return [] + loop (t1:ts) = do + t' <- normalizeTypeF t1 `mapError` fmap (:ts) + ts' <- loop ts `mapError` fmap (t':) + return (t':ts') + tyApp tc <$> (loop ts0 `mapError` fmap (tyApp tc)) + TyQu qu tv t1 -> do + t1' <- normalizeTypeF t1 `mapError` fmap (TyQu qu tv) + return (TyQu qu tv t1') + TyMu tv t1 -> do + t1' <- normalizeTypeF t1 `mapError` fmap (TyMu tv) + return (TyMu tv t1') + +normalizeTypeK :: Int -> Type -> (ReductionState (), Type) +normalizeTypeK fuel t = case evalFuel (normalizeTypeF t) fuel of + Right t' -> (Done, t') + Left (rs, t') -> (rs, t') + +-- | Reduces a type until it is normal +normalizeType :: Type -> (ReductionState (), Type) +normalizeType = normalizeTypeK (-1) + +{- +-- | Performs one reduction step. The order of evaluation is +-- different than used by 'normalizeType', but note that type +-- reduction is not guaranteed to be confluent +reduceType :: Type -> Maybe Type +reduceType t = case t of + TyVar _ -> Nothing + TyFun q t1 t2 -> TyFun q <$> reduceType t1 <*> pure t2 + <|> TyFun q <$> pure t1 <*> reduceType t2 + TyApp tc ts _ -> headReduceType t + <|> tyApp tc <$> reduceTypeList ts + TyQu qu tv t1 -> TyQu qu tv <$> reduceType t1 + TyMu tv t1 -> TyMu tv <$> reduceType t1 + +-- | Takes the first reduction step found in a list of types, or +-- returns 'Nothing' if they're all normal +reduceTypeList :: [Type] -> Maybe [Type] +reduceTypeList [] = Nothing +reduceTypeList (t:ts) = (:) <$> reduceType t <*> pure ts + <|> (:) <$> pure t <*> reduceTypeList ts +-} + +--- +--- The Fuel monad +--- + +-- | The Fuel monad enables counting computation steps, and +-- fails if it runs out of fuel +newtype Fuel r a + = Fuel { + -- | Run a 'Fuel' computation, getting back the + -- answer and remaining fuel + runFuel :: Int -> Either r (a, Int) + } + deriving Functor + +-- | Run a 'Fuel' computation, getting back the answer only +evalFuel :: Fuel r a -> Int -> Either r a +evalFuel = fmap fst <$$> runFuel + +-- | Use up one unit of fuel +burnFuel :: r -> Fuel r () +burnFuel r = Fuel $ \fuel -> + if fuel == 0 + then Left r + else Right ((), fuel - 1) + +-- | Give up on a fuel computation +bailOut :: r -> Fuel r a +bailOut = Fuel . const . Left + +{- +-- | Catch a failed fuel computation, and potentially add more fuel +reFuel :: Fuel r a -> (r -> (Int, Fuel r a)) -> Fuel r a +reFuel f k = Fuel $ \fuel -> case runFuel f fuel of + Left r -> let (fuel', f') = k r in runFuel f' fuel' + Right (fuel', a) -> Right (fuel', a) +-} + +-- | Given a fuel computation with a given failure result, map +-- the failure result +mapError :: Fuel r a -> (r -> s) -> Fuel s a +mapError f h = Fuel $ \fuel -> case runFuel f fuel of + Left r -> Left (h r) + Right a -> Right a + +instance Applicative (Fuel r) where + pure a = Fuel $ \fuel -> Right (a, fuel) + f <*> g = Fuel $ \fuel -> case runFuel f fuel of + Right (f', fuel') -> case runFuel g fuel' of + Right (g', fuel'') -> Right (f' g', fuel'') + Left r -> Left r + Left r -> Left r + +instance Monad (Fuel r) where + return a = Fuel $ \fuel -> Right (a, fuel) + m >>= k = Fuel $ \fuel -> case runFuel m fuel of + Right (m', fuel') -> runFuel (k m') fuel' + Left r -> Left r + +--- +--- Built-in type constructors +--- + +class ExtTC r where + extTC :: TyCon -> r + +instance ExtTC TyCon where + extTC = id +instance ExtTC r => ExtTC (QLid Renamed -> r) where + extTC tc x = extTC (tc { tcName = x }) +instance (v ~ Variance, ExtTC r) => ExtTC ([(QLit, v)] -> r) where + extTC tc x = extTC (tc { tcArity = map snd x, tcBounds = map fst x }) +instance ExtTC r => ExtTC (QDen Int -> r) where + extTC tc x = extTC (tc { tcQual = x }) +instance (v ~ TyVarR, a ~ Type, i ~ Renamed, ExtTC r) => + ExtTC (([v], Env.Env (Uid i) (Maybe a)) -> r) where + extTC tc x = extTC (tc { tcCons = x }) +instance ExtTC r => ExtTC ([([TyPat], Type)] -> r) where + extTC tc x = extTC (tc { tcNext = Just x }) +instance ExtTC r => ExtTC (Maybe [([TyPat], Type)] -> r) where + extTC tc x = extTC (tc { tcNext = x }) + +mkTC :: ExtTC r => Int -> QLid Renamed -> r +mkTC i ql = extTC TyCon { + tcId = i, + tcName = ql, + tcArity = [], + tcBounds = [], + tcQual = minBound, + tcCons = ([], Env.empty), + tcNext = Nothing +} + +internalTC :: ExtTC r => Int -> String -> r +internalTC i s = extTC TyCon { + tcId = i, + tcName = J [] (Lid (Ren_ i) s), + tcArity = [], + tcBounds = [], + tcQual = minBound, + tcCons = ([], Env.empty), + tcNext = Nothing +} + +tcBot, tcUnit, tcInt, tcFloat, tcString, + tcExn, tcUn, tcAf, tcTuple, tcIdent, tcConst :: TyCon + +tcBot = internalTC (-1) "any" +tcUnit = internalTC (-2) "unit" ([], Env.fromList [(uid "()", Nothing)]) +tcInt = internalTC (-3) "int" +tcFloat = internalTC (-4) "float" +tcString = internalTC (-5) "string" +tcExn = internalTC (-6) "exn" (maxBound :: QDen Int) +tcUn = internalTC (-7) "U" +tcAf = internalTC (-8) "A" (maxBound :: QDen Int) +tcTuple = internalTC (-9) "*" (0 \/ 1 :: QDen Int) [(Qa, 1), (Qa, 1)] +tcIdent = internalTC (-10) "id" (0 :: QDen Int) [(Qa, 1)] + [([TpVar (tvAf "a")], TyVar (tvAf "a"))] +tcConst = internalTC (-11) "const" (0 :: QDen Int) [(Qa, Invariant)] + [([TpVar (tvAf "a")], tyUnit)] + +--- +--- Convenience type constructors +--- + +-- | Make a type from a nullary type constructor +tyNulOp :: TyCon -> Type +tyNulOp tc = tyApp tc [] + +-- | Make a type from a unary type constructor +tyUnOp :: TyCon -> Type -> Type +tyUnOp tc t1 = tyApp tc [t1] + +-- | Make a type from a binary type constructor +tyBinOp :: TyCon -> Type -> Type -> Type +tyBinOp tc t1 t2 = tyApp tc [t1, t2] + +-- | Constructor for unlimited arrow types +tyArr :: Type -> Type -> Type +tyArr = TyFun minBound + +-- | Constructor for affine arrow types +tyLol :: Type -> Type -> Type +tyLol = TyFun maxBound + +-- | Construct a universal type +tyAll :: TyVarR -> Type -> Type +tyAll = TyQu Stx.Forall + +-- | Construct a existential type +tyEx :: TyVarR -> Type -> Type +tyEx = TyQu Stx.Exists + +-- | Preconstructed types +tyBot, tyUnit, tyInt, tyFloat, tyString, tyExn, tyUn, tyAf :: Type +tyIdent, tyConst :: Type -> Type +tyTuple :: Type -> Type -> Type +tyTop :: QLit -> Type + +tyBot = tyNulOp tcBot +tyUnit = tyNulOp tcUnit +tyInt = tyNulOp tcInt +tyFloat = tyNulOp tcFloat +tyString = tyNulOp tcString +tyExn = tyNulOp tcExn +tyUn = tyNulOp tcUn +tyAf = tyNulOp tcAf +tyTop = elimQLit tyUn tyAf +tyTuple = tyBinOp tcTuple +tyIdent = tyUnOp tcIdent +tyConst = tyUnOp tcConst + +(.*.), (.->.), (.-*.) :: Type -> Type -> Type +(.*.) = tyTuple +(.->.) = tyArr +(.-*.) = tyLol + +infixr 6 .->., .-*., `tyArr`, `tyLol` +infixl 7 .*., `tyTuple` +infixr 8 .:., `tySemi` + +--- +--- Miscellany +--- + +-- | Represent a type value as a pre-syntactic type, for printing +typeToStx' :: Type -> Stx.Type' Renamed +typeToStx' = view . typeToStx + +-- | Represent a type value as a syntactic type, for printing; renames +-- so that scope is apparent, since internal renaming may result int +-- different identifiers that print the same +typeToStx :: Type -> Stx.Type Renamed +typeToStx = loop (S.empty, M.empty) where + loop ren t0 = case t0 of + TyVar tv -> Stx.tyVar (maybe tv id (M.lookup tv (snd ren))) + TyFun q t1 t2 -> Stx.tyFun (qRepresent q) (loop ren t1) (loop ren t2) + TyApp tc ts _ -> Stx.tyApp (tcName tc) {jpath = []} (map (loop ren) ts) + {- + (fmap (\ql -> lid ("[" ++ show (tcId tc) ++ "]" ++ unLid ql)) + (tcName tc)) + (map (loop ren) ts) + -} + TyQu qu tv t1 -> Stx.tyQu qu tv' (loop ren' t1) + where (tv', ren') = fresh tv ren + TyMu tv t1 -> Stx.tyMu tv' (loop ren' t1) + where (tv', ren') = fresh tv ren + fresh tv (seen, remap) = + let tv' = if S.member (unLid (tvname tv)) seen + then freshTyVar tv $ + M.keysSet remap `S.union` + S.fromList (M.elems remap) + else tv + in (tv', (S.insert (unLid (tvname tv')) seen, + M.insert tv tv' remap)) + +tyPatToStx' :: TyPat -> Stx.TyPat' Renamed +tyPatToStx' = view . tyPatToStx + +-- | Represent a type pattern as a syntactic type pattern, for printing +tyPatToStx :: TyPat -> Stx.TyPat Renamed +tyPatToStx tp0 = case tp0 of + TpVar tv -> Stx.tpVar tv Invariant + TpApp tc tps -> Stx.tpApp (tcName tc) (map tyPatToStx tps) + +-- | Convert a type pattern to a type; useful for quqlifier and variance +-- analysis +tyPatToType :: TyPat -> Type +tyPatToType (TpVar tv) = TyVar tv +tyPatToType (TpApp tc tps) = tyApp tc (map tyPatToType tps) + +castableType :: Type -> Bool +castableType t = case headNormalizeType t of + TyVar _ -> False + TyFun _ _ _ -> True + TyApp _ _ _ -> False + TyQu _ _ t1 -> castableType t1 + TyMu _ t1 -> castableType t1 + +{- +-- Example types and reduction + +hgo t = loop 0 where + loop 100 = putStrLn "gave up after 100 steps" + loop i = case headNormalizeTypeK i t of + (Next (), t) -> do print t; loop (i + 1) + (rs, _) -> print rs + +go t = loop 0 where + loop 100 = putStrLn "gave up after 100 steps" + loop i = case normalizeTypeK i t of + (Next (), t) -> do print t; loop (i + 1) + (rs, _) -> print rs + +a = tyApp tcDual + [tyApp tcSemi + [tyApp tcRecv [tyApp tcInt []], + tyApp tcSemi + [tyApp tcSend [tyApp tcString []], + tyUnit]]] + +b = tyApp tcIdent + [tyApp tcSemi + [tyApp tcIdent [tyApp tcRecv [tyApp tcInt []]], + tyApp tcIdent + [tyApp tcSemi + [tyApp tcSend [tyApp tcString []], + tyUnit]]]] + +c = tyApp tcIdent [tyApp tcDual [b]] + +d = tyApp tcDual [c] + +e = tyApp tcDual + [tyApp tcIdent + [tyApp tcSemi + [tyApp tcIdent [tyUnit], + tyApp tcIdent + [tyApp tcSemi + [tyApp tcSend [tyApp tcString []], + tyUnit]]]]] + +f = tyApp tcDual + [tyApp tcIdent + [tyApp tcSemi + [tyApp tcIdent [TyVar (TV (Lid "c") Qu)], + tyApp tcIdent + [tyApp tcSemi + [tyApp tcSend [tyApp tcString []], + tyUnit]]]]] + +g = tyApp tcInfiniteLoop [tyUnit] where + +tcInfiniteLoop :: TyCon + +tcInfiniteLoop = internalTC (-100) "loop" + [([TpVar (TV (Lid "a") Qu)], + tyApp tcInfiniteLoop [TyVar (TV (Lid "a") Qu)])] +-} + +instance Viewable Type where + type View Type = Type + view t = case headNormalizeTypeM 1000 t of + Just t' -> t' + Nothing -> error "view: gave up reducting type after 1000 steps" + +-- | Normalize a type enough to see if it's an application of +-- the given construtor +vtAppTc :: TyCon -> Type -> Type +vtAppTc tc t = case headNormalizeType t of + t'@(TyApp tc' _ _) | tc == tc' -> t' + _ -> t + +-- | Normalize a type enough to see if it's bottom +isBotType :: Type -> Bool +isBotType t = case view t of + TyApp tc _ _ -> tc == tcBot + _ -> False + +-- | Unfold the arguments of a function type, normalizing as +-- necessary +vtFuns :: Type -> ([Type], Type) +vtFuns t = case view t of + TyFun _ ta tr -> first (ta:) (vtFuns tr) + _ -> ([], t) + +-- | Unfold the parameters of a quantified type, normalizing as +-- necessary +vtQus :: Stx.Quant -> Type -> ([TyVarR], Type) +vtQus u t = case view t of + TyQu u' x t' | u == u' -> first (x:) (vtQus u t') + _ -> ([], t) + +-- For session types: + +tcSend, tcRecv, tcSelect, tcFollow, tcSemi, tcDual :: TyCon + +tcSend = internalTC (-31) "send" [(Qa, 1)] +tcRecv = internalTC (-32) "recv" [(Qa, -1)] +tcSelect = internalTC (-33) "select" [(Qu, 1), (Qu, 1)] +tcFollow = internalTC (-34) "follow" [(Qu, 1), (Qu, 1)] +tcSemi = internalTC (-35) ";" [(Qu, -1), (Qu, 1)] +tcDual = internalTC (-36) "dual" [(Qu, -1)] + [ ([TpApp tcSemi [TpApp tcSend [pa], pb]], + (tyApp tcSemi [tyApp tcRecv [ta], dual tb])) + , ([TpApp tcSemi [TpApp tcRecv [pa], pb]], + (tyApp tcSemi [tyApp tcSend [ta], dual tb])) + , ([TpApp tcSelect [pa, pb]], (tyApp tcFollow [dual ta, dual tb])) + , ([TpApp tcFollow [pa, pb]], (tyApp tcSelect [dual ta, dual tb])) + , ([TpApp tcUnit []], (tyApp tcUnit [])) + ] + where a = tvAf "a" + b = tvAf "b" + pa = TpVar a + pb = TpVar b + ta = TyVar a + tb = TyVar b + dual t = tyApp tcDual [t] + +tySend, tyRecv, tyDual :: Type -> Type +tySelect, tyFollow, tySemi :: Type -> Type -> Type +(.:.) :: Type -> Type -> Type + +tySend = tyUnOp tcSend +tyRecv = tyUnOp tcRecv +tySelect = tyBinOp tcSelect +tyFollow = tyBinOp tcFollow +tySemi = tyBinOp tcSemi +tyDual = tyUnOp tcDual +(.:.) = tySemi + +-- | Noisy type printer for debugging (includes type tags that aren't +-- normally pretty-printed) +dumpType :: Type -> String +dumpType = CMW.execWriter . loop 0 where + loop i t0 = do + CMW.tell (replicate i ' ') + case t0 of + TyApp tc ts _ -> do + CMW.tell $ + show (tcName tc) ++ "[" ++ + show (lidUnique (jname (tcName tc))) ++ "] {\n" + mapM_ (loop (i + 2)) ts + CMW.tell (replicate i ' ' ++ "}\n") + TyFun q dom cod -> do + CMW.tell $ "-[" ++ show q ++ "]> {\n" + loop (i + 2) dom + loop (i + 2) cod + CMW.tell (replicate i ' ' ++ "}\n") + TyVar tv -> CMW.tell $ show tv + TyQu u a t -> do + CMW.tell $ show u ++ " " ++ show a ++ ". {\n" + loop (i + 2) t + CMW.tell (replicate i ' ' ++ "}\n") + TyMu a t -> do + CMW.tell $ "mu " ++ show a ++ ". {\n" + loop (i + 2) t + CMW.tell (replicate i ' ' ++ "}\n") + +instance Ppr TyCon where + ppr tc = + -- brackets (text (show (tcId tc))) <> + case tcNext tc of + Just [(tps,t)] -> pprTyApp 0 (tcName tc) (ps (map snd tvs)) + >?> qe (map fst tvs) + >?> char '=' <+> ppr t + where + tvs = [ case tp of + TpVar tv -> (tv, ppr tv) + _ -> let tv = TV (lid (show i)) qlit + tv' = case qlit of + Qa -> ppr tv <> char '=' + Qu -> empty + in (tv, tv' <> pprPrec precEq tp) + | tp <- tps + | qlit <- tcBounds tc + | i <- [ 1 :: Integer .. ] ] + -- + Just next -> pprTyApp 0 (tcName tc) (ps tvs) + >?> (qe tvs <+> text "with" + $$ vcat (map alt next)) + where + tvs = [ TV (lid (show i)) qlit + | qlit <- tcBounds tc + | i <- [ 1 .. ] :: [Int] ] + alt (tps,t) = char '|' <+> pprPrec precApp tps <+> ppr (tcName tc) + >?> char '=' <+> ppr t + -- + Nothing -> pprTyApp 0 (tcName tc) (ps tvs) + >?> qe tvs + >?> alts + where + tvs = case fst (tcCons tc) of + [] -> [ mk qlit | qlit <- tcBounds tc | mk <- tvalphabet ] + tvs' -> tvs' + alts = sep $ + mapHead (text "=" <+>) $ + mapTail (text "|" <+>) $ + map alt (Env.toList (snd (tcCons tc))) + alt (u, Nothing) = ppr u + alt (u, Just t) = ppr u <+> text "of" <+> ppr t + where + qe :: [TyVarR] -> Doc + qe tvs = case qDenToLit (tcQual tc) of + Just Qu -> empty + _ -> colon <+> + ppr (qRepresent + (denumberQDen + (map qDenOfTyVar tvs) (tcQual tc))) + ps tvs = [ ppr var <> pprPrec precApp tv + | tv <- tvs + | var <- tcArity tc ] + +instance Show TyCon where showsPrec = showFromPpr diff --git a/src/TypeRel.hs b/src/TypeRel.hs new file mode 100644 --- /dev/null +++ b/src/TypeRel.hs @@ -0,0 +1,1043 @@ +{-# LANGUAGE + GeneralizedNewtypeDeriving, + ParallelListComp, + PatternGuards, + RankNTypes, + RelaxedPolyRec #-} +module TypeRel ( + -- * Type operations + -- ** Equality and subtyping + AType(..), subtype, jointype, + -- ** Queries and conversions + qualConst, abstractTyCon, + -- ** Tycon substitutions + TyConSubst, makeTyConSubst, + applyTyConSubst, applyTyConSubstInTyCon, + replaceTyCon, replaceTyCons, + substTyCons, substTyCon, + -- * Tests + tests, +) where + +import Env +import ErrorST +import Type +import Util +import Viewable + +import qualified Control.Monad.Reader as CMR +import Data.Generics (Data, everywhere, mkT, extT) +import Data.Monoid +import qualified Data.Map as M +import qualified Data.Set as S + +import qualified Test.HUnit as T + +-- | Remove the concrete portions of a type constructor. +abstractTyCon :: TyCon -> TyCon +abstractTyCon tc = tc { tcCons = ([], empty), tcNext = Nothing } + +-- | A substitution mapping type constructors to other type +-- constructors +newtype TyConSubst = TyConSubst { unTyConSubst :: M.Map Int TyCon } + deriving Monoid + +-- | Construct a tycon substitution from a list of tycons and a list +-- to map them to. +makeTyConSubst :: [TyCon] -> [TyCon] -> TyConSubst +makeTyConSubst tcs tcs' = + TyConSubst (M.fromList [ (tcId tc, tc') | tc <- tcs | tc' <- tcs' ]) + +-- | Apply a tycon substitution to any SYB data. +applyTyConSubst :: Data a => TyConSubst -> a -> a +applyTyConSubst subst = loop where + loop :: Data a => a -> a + loop = everywhere (mkT tycon `extT` tyapp) + -- + tycon :: TyCon -> TyCon + tycon tc + | Just tc' <- M.lookup (tcId tc) (unTyConSubst subst) + = applyTyConSubstInTyCon subst tc' + | otherwise = tc + -- + tyapp :: Type -> Type + tyapp (TyApp tc ts _) = tyApp tc ts + tyapp t = t + +-- | Apply a tycon substitution "inside" the right-hand side of +-- a tycon, but don't replace the tycon itself. +applyTyConSubstInTyCon :: TyConSubst -> TyCon -> TyCon +applyTyConSubstInTyCon subst tc = + tc { + tcNext = applyTyConSubst subst (tcNext tc), + tcCons = applyTyConSubst subst (tcCons tc) + } + +-- | Given a list of type constructors and something traversable, +-- find all constructors with the same identity as the given type one, and +-- replace them. We can use this for type abstraction by redacting +-- data constructor or synonym expansions. It also replaces within +-- the list of type constructors themselves, which ties the knot for +-- recursive type constructors. +replaceTyCons :: Data a => [TyCon] -> a -> a +replaceTyCons tcs0 = substTyCons tcs0 tcs0 + +replaceTyCon :: Data a => TyCon -> a -> a +replaceTyCon tc = replaceTyCons [tc] + +-- Give a list of tycons to replace and a list of tycons to replace them +-- with, replaces them all recursively, including knot-tying +substTyCons :: Data a => [TyCon] -> [TyCon] -> a -> a +substTyCons tcs tcs' = applyTyConSubst (makeTyConSubst tcs tcs') + +-- | Replace all occurrences of the first tycon with the second +substTyCon :: Data a => TyCon -> TyCon -> a -> a +substTyCon tc tc' = substTyCons [tc] [tc'] + +-- | The constant bound on the qualifier of a type +qualConst :: Type -> QLit +qualConst = qConstBound . qualifier + +-- | A fresh type for defining alpha equality up to mu. +newtype AType = AType { unAType :: Type } + +-- | On AType, we define simple alpha equality, up to mu and operator +-- reduction, which we then use +-- to keep track of where we've been when we define type equality +-- that understands mu and reduction. +instance Eq AType where + te1 == te2 = compare te1 te2 == EQ + +instance Ord AType where + te1 `compare` te2 = unAType te1 =?= unAType te2 + where + (=?=) :: Type -> Type -> Ordering + TyApp tc ts _ =?= TyApp tc' ts' _ + = tc `compare` tc' + `thenCmp` map AType ts `compare` map AType ts' + TyVar x =?= TyVar x' + = x `compare` x' + TyFun q t1 t2 =?= TyFun q' t1' t2' + = q `compare` q' + `thenCmp` t1 =?= t1' + `thenCmp` t2 =?= t2' + TyQu u x t =?= TyQu u' x' t' + = u `compare` u' + `thenCmp` tvqual x `compare` tvqual x' + `thenCmp` tysubst x a t =?= tysubst x' a t' + where a = TyVar (fastFreshTyVar x (maxtv (t, t'))) + TyMu x t =?= TyMu x' t' + = tvqual x `compare` tvqual x' + `thenCmp` tysubst x a t =?= tysubst x' a t' + where a = TyVar (fastFreshTyVar x (maxtv (t, t'))) + TyApp _ _ _ =?= _ = LT + _ =?= TyApp _ _ _ = GT + TyVar _ =?= _ = LT + _ =?= TyVar _ = GT + TyFun _ _ _ =?= _ = LT + _ =?= TyFun _ _ _ = GT + TyQu _ _ _ =?= _ = LT + _ =?= TyQu _ _ _ = GT + +type UT s t a = CMR.ReaderT (TCS s t) (ST t String) a + +-- | An environment mapping mu-bound type variables to their +-- definition for unrolling ('Left') or forall-bound variables +-- to a pair of lower and upper bounds, for instantiation ('Right') +type UEnv t = M.Map TyVarR (UVar t) +type UVar t = (Int, STRef t (Type, Type)) + +data TCS s t = TCS { + -- | Pairs of types previously seen, and thus considered related + -- if seen again. + tcsSeen :: STRef t (M.Map (AType, AType) s), + -- | A supply of fresh type variables + tcsSupply :: STRef t [QLit -> TyVarR], + -- | The number of instantiated foralls we are currently under + tcsLevel :: Int, + -- | The environment for the left side of the relation + tcsEnv1 :: UEnv t, + -- | The environment for the right side of the relation + tcsEnv2 :: UEnv t +} + +data Field s t = Field { + get :: TCS s t -> UEnv t, + update :: TCS s t -> UEnv t -> TCS s t +} + +env1, env2 :: Field s t +env1 = Field tcsEnv1 (\tcs e -> tcs { tcsEnv1 = e }) +env2 = Field tcsEnv2 (\tcs e -> tcs { tcsEnv2 = e }) + +lift :: (CMR.MonadTrans t, Monad m) => m a -> t m a +lift = CMR.lift + +runUT :: forall s a m. Monad m => + (forall t. UT s t a) -> S.Set TyVarR -> m a +runUT m set = + either fail return $ + runST $ do + seen <- newTransSTRef M.empty + supply <- newSTRef [ f | f <- tvalphabet + , f Qu `S.notMember` set + , f Qa `S.notMember` set ] + CMR.runReaderT m TCS { + tcsSeen = seen, + tcsSupply = supply, + tcsLevel = 1, + tcsEnv1 = M.empty, + tcsEnv2 = M.empty + } + +getVar :: TyVarR -> Field s t -> UT s t (Maybe (UVar t)) +getVar tv field = CMR.asks (M.lookup tv . get field) + +-- | To add some unification variables to the scope, run the body, +-- and return a map containing their lower and upper bounds. +-- Unification variables are assumed to be fresh with respect to +-- existing variables. In particular, the initial set of unification +-- variables precedes any other bindings, and all subsequent foralls +-- are renamed using fresh type variables. +withUVars :: [TyVarR] -> Field s t -> UT s t a -> UT s t (a, [Type]) +withUVars tvs field body = do + level <- CMR.asks tcsLevel + refs <- lift $ sequence + [ do ref <- newTransSTRef (tyBot, tyTop (tvqual tv)) + return (tv, (level, ref)) + | tv <- tvs ] + res <- CMR.local + (\st -> update field st (M.fromList refs `M.union` get field st)) + body + typs <- sequence + [ do + (lower, upper) <- lift $ readSTRef ref + if lower <: upper + then return $ + -- This is a heuristic -- we prefer to return something + -- with information, meaning not top or bottom, but if + -- the choice is between top and bottom, we go with bottom + if isBotType lower + then if upper == tyUn || upper == tyAf then lower else upper + else lower + else fail $ + "Unification cannot solve:\n" ++ + show lower ++ " <: " ++ show upper + | (_, (_, ref)) <- refs ] + return (res, typs) + +-- | Bump up the quantification nesting level +incU :: UT s t a -> UT s t a +incU = CMR.local (\st -> st { tcsLevel = tcsLevel st + 1 }) + +-- | Try to assert an upper bound on a unification variable. +upperBoundUVar :: STRef t (Type, Type) -> Type -> UT s t () +upperBoundUVar ref t = do + (lower, upper) <- lift $ readSTRef ref + unless (upper <: t) $ do + upper' <- t /\? upper + lift $ writeSTRef ref (lower, upper') + + +-- | Try to assert a lower bound on a unification variable. +lowerBoundUVar :: STRef t (Type, Type) -> Type -> UT s t () +lowerBoundUVar ref t = do + (lower, upper) <- lift $ readSTRef ref + unless (t <: lower) $ do + lower' <- t \/? lower + lift $ writeSTRef ref (lower', upper) + +-- | Get maps of the left and right uvars +getUVars :: UT s t (TyVarR -> Maybe (Int, STRef t (Type, Type)), + TyVarR -> Maybe (Int, STRef t (Type, Type))) +getUVars = do + st <- CMR.ask + return (flip M.lookup (tcsEnv1 st), flip M.lookup (tcsEnv2 st)) + +-- | Check if two types have been seen before. If so, return the +-- previously stored answer. If not, temporarily store the given +-- answer, then run a block, and finally replace the stored answer +-- with the result of the block. +chkU :: Type -> Type -> s -> UT s t s -> UT s t s +chkU t1 t2 s body = do + st <- CMR.ask + let key = (AType t2, AType t1) + ref = tcsSeen st + seen <- lift $ readSTRef ref + case M.lookup key seen of + Just s' -> return s' + Nothing -> do + lift $ modifySTRef ref (M.insert key s) + res <- body + lift $ modifySTRef ref (M.insert key res) + return res + +-- | Flip the left and right sides of the relation in the given block. +flipU :: UT s t a -> UT s t a +flipU body = CMR.local flipSt body where + flipSt (TCS seen level supply e1 e2) = + TCS seen level supply e2 e1 + +-- | Get a fresh type variable from the supply. +freshU :: QLit -> UT s t TyVarR +freshU qlit = do + ref <- CMR.ask >>! tcsSupply + f:supply <- lift $ readSTRef ref + lift $ writeSTRef ref supply + return (f qlit) + +-- | Print a debug message +-- pM :: Show b => b -> UT s t () +-- pM = lift . unsafeIOToST . print +-- pM = const $ return () + +subtype :: Monad m => + Int -> [TyVarR] -> Type -> [TyVarR] -> Type -> + m ([Type], [Type]) +subtype limit uvars1 t1i uvars2 t2i = + runUT start (S.fromList uvars1 `S.union` + S.fromList uvars2 `S.union` + alltv (t1i, t2i)) + where + start :: UT () t ([Type], [Type]) + start = liftM (first snd) $ + withUVars uvars2 env2 $ + withUVars uvars1 env1 $ + cmp t1i t2i + -- + cmp :: Type -> Type -> UT () t () + cmp t u = chkU t u () $ case (t, u) of + -- Handle top + (_ , TyApp tcu _ _) + | tcu == tcUn && qualConst t <: Qu + -> return () + (_ , TyApp tcu _ _) + | tcu == tcAf + -> return () + -- Handle bottom + (TyApp tct _ _, _) + | tct == tcBot + -> return () + -- Variables + (TyVar vt, TyVar vu) -> do + mt' <- getVar vt env1 + mu' <- getVar vu env2 + case (mt', mu') of + (Just (_, t'), Nothing) -> upperBoundUVar t' u + (Nothing, Just (_, u')) -> lowerBoundUVar u' t + (Just (lt, t'), Just (lu, u')) + | lt > lu -> upperBoundUVar t' u + | lt < lu -> lowerBoundUVar u' t + _ -> unless (vt == vu) $ giveUp t u + (TyVar vt, _) -> do + mt' <- getVar vt env1 + case mt' of + Just (_, t') -> upperBoundUVar t' u + Nothing -> giveUp t u + (_, TyVar vu) -> do + mu' <- getVar vu env2 + case mu' of + Just (_, u') -> lowerBoundUVar u' t + Nothing -> giveUp t u + -- Type applications + (TyApp tct ts _, TyApp tcu us _) + | tct == tcu, + isHeadNormalType t, isHeadNormalType u -> + cmpList (tcArity tct) ts us + (TyApp tct ts _, TyApp tcu us _) + | tct == tcu -> + cmpList (tcArity tct) ts us `catchError` \_ -> do + t' <- hn t + u' <- hn u + cmp t' u' + (TyApp _ _ _, _) + | not (isHeadNormalType t) + -> (`cmp` u) =<< hn t + (_, TyApp _ _ _) + | not (isHeadNormalType u) + -> (t `cmp`) =<< hn u + -- Arrows + (TyFun qt t1 t2, TyFun qu u1 u2) -> do + subkind qt qu $ giveUp t u + revCmp t1 u1 + cmp t2 u2 + -- Quantifiers + (TyQu Forall tvt t1, _) -> do + tv' <- freshU (tvqual tvt) + incU $ + withUVars [tv'] env1 $ + cmp (tysubst tvt (TyVar tv') t1) u + return () + (_, TyQu Exists tvu u1) -> do + tv' <- freshU (tvqual tvu) + incU $ + withUVars [tv'] env2 $ + cmp t (tysubst tvu (TyVar tv') u1) + return () + (_, TyQu Forall tvu u1) -> do + tv' <- freshU (tvqual tvu) + cmp t (tysubst tvu (TyVar tv') u1) + (TyQu Exists tvt t1, _) -> do + tv' <- freshU (tvqual tvt) + cmp (tysubst tvt (TyVar tv') t1) u + -- Recursion + (TyMu tvt t1, _) -> cmp (tysubst tvt t t1) u + (_, TyMu tvu u1) -> cmp t (tysubst tvu u u1) + -- Failure + _ -> giveUp t u + -- + giveUp t u = + fail $ + "Got type `" ++ show t ++ "' where type `" ++ + show u ++ "' expected" + -- + revCmp u t = flipU (cmp t u) + -- + hn t = headNormalizeTypeM limit t + -- + cmpList arity ts us = + sequence_ + [ case var of + 1 -> cmp tj uj + -1 -> revCmp tj uj + _ -> do cmp tj uj; revCmp tj uj + | var <- arity + | tj <- ts + | uj <- us ] + -- + subkind qd1 qd2 orElse = + if qd1 <: qd2 then return () else do + (m1, m2) <- getUVars + case (view $ qRepresent qd1, view $ qRepresent qd2) of + (QeVar tv1, QeVar tv2) + | Just (_, ref) <- m1 tv1, Nothing <- m2 tv2 + -> upperBoundUVar ref (TyVar tv2) + | Nothing <- m1 tv1, Just (_, ref) <- m2 tv2 + -> lowerBoundUVar ref (TyVar tv1) + (QeVar tv1, QeLit qlit) + | Just (_, ref) <- m1 tv1 + -> upperBoundUVar ref (tyTop qlit) + (QeLit qlit, QeVar tv2) + | Just (_, ref) <- m2 tv2 + -> lowerBoundUVar ref (tyTop qlit) + _ -> orElse + +jointype :: Monad m => Int -> Bool -> Type -> Type -> m Type +jointype limit b t1i t2i = + liftM clean $ runUT (cmp (b, True) t1i t2i) (alltv (t1i, t2i)) + where + cmp, revCmp :: (Bool, Bool) -> Type -> Type -> UT Type t Type + cmp m t u = do + let (direction, _) = m + tv <- freshU (qualConst t \/ qualConst u) + catchTop m t u $ + chkU t u (TyVar tv) $ + TyMu tv `liftM` + case (t, u) of + -- Handle top and bottom + _ | Just t' <- points direction t u -> return t' + | Just t' <- points direction u t -> return t' + -- Type applications + (TyApp tct ts _, TyApp tcu us _) + | tct == tcu, + isHeadNormalType t, isHeadNormalType u -> + tyApp tct `liftM` + cmpList (tcArity tct) (direction, True) ts us + (TyApp tct ts _, TyApp tcu us _) + | tct == tcu + -> liftM (tyApp tct) + (cmpList (tcArity tct) (direction, False) ts us) + `catchError` \_ -> do + t' <- hn t + u' <- hn u + cmp m t' u' + (TyApp _ _ _, _) + | not (isHeadNormalType t) -> do + t' <- hn t + cmp m t' u + (_, TyApp _ _ _) + | not (isHeadNormalType u) -> do + u' <- hn u + cmp m t u' + -- Variables + (TyVar vt, TyVar ut) + | vt == ut -> + return t + -- Arrows + (TyFun qt t1 t2, TyFun qu u1 u2) -> do + q' <- ifMJ direction qt qu + t1' <- revCmp m t1 u1 + t2' <- cmp m t2 u2 + return (TyFun q' t1' t2') + -- Quantifiers + (TyQu qt tvt t1, TyQu qu tvu u1) + | qt == qu -> do + q' <- ifMJ direction (tvqual tvt) (tvqual tvu) + tv' <- freshU q' + liftM (TyQu qt tv') $ + cmp m (tysubst tvt (TyVar tv') t1) + (tysubst tvu (TyVar tv') u1) + -- Recursion + (TyMu tvt t1, _) -> + cmp m (tysubst tvt t t1) u + (_, TyMu tvu u1) -> + cmp m t (tysubst tvu u u1) + -- Failure + _ -> + fail $ + "Could not " ++ (if direction then "join" else "meet") ++ + " types `" ++ show t ++ + "' and `" ++ show u ++ "'" + -- + hn t = headNormalizeTypeM limit t + -- + cmpList arity m ts us = + sequence + [ case var of + 1 -> cmp m tj uj + -1 -> revCmp m tj uj + _ -> if tj == uj + then return tj + else fail $ + "Could not unify types `" ++ show tj ++ + "' and `" ++ show uj ++ "'" + | var <- arity + | tj <- ts + | uj <- us ] + -- + points True t u@(TyApp tc _ _) + | tc == tcAf = Just u + | tc == tcUn, qualConst t <: Qu = Just u + | tc == tcBot = Just t + points False t u@(TyApp tc _ _) + | tc == tcAf = Just t + | tc == tcUn, qualConst t <: Qu = Just t + | tc == tcBot = Just u + points _ _ _ = Nothing + -- + revCmp (direction, lossy) t u = cmp (not direction, lossy) t u + -- + catchTop (True, True) t u body = body + `catchError` \_ -> return (tyTop (qualConst t \/ qualConst u)) + {- + catchTop (False, True) _ _ body = body + `catchError` \_ -> return tyBot + -} + catchTop _ _ _ body = body + -- + clean :: Type -> Type + clean (TyApp tc ts _) = tyApp tc (map clean ts) + clean (TyVar a) = TyVar a + clean (TyFun q t1 t2) = TyFun q (clean t1) (clean t2) + clean (TyQu u a t) = TyQu u a (clean t) + clean (TyMu a t) + | a `S.member` ftv t = TyMu a (clean t) + | otherwise = clean t + +-- | Helper to force 'Either' to the right type +runEither :: (String -> r) -> (a -> r) -> Either String a -> r +runEither = either + +-- | The Type partial order +instance Eq Type where + t1 == t2 = t1 <: t2 && t2 <: t1 + +instance PO Type where + t1 <: t2 = runEither (const False) (const True) + (subtype 100 [] t1 [] t2) + ifMJ b t1 t2 = jointype 100 b t1 t2 + +subtypeTests, joinTests, uvarsTests :: T.Test + +subtypeTests = T.test + [ tyUnit <:! tyUnit + , tyUnit !<: tyInt + , tyInt <:! tyInt + , tyInt .->. tyInt <:! tyInt .->. tyInt + , tyInt .->. tyInt <:! tyInt .-*. tyInt + , tyInt .-*. tyInt <:! tyInt .-*. tyInt + , tyInt .-*. tyInt !<: tyInt .->. tyInt + , tyUnit .->. tyInt !<: tyInt .->. tyInt + , (tyInt .-*. tyInt) .->. tyInt .->. tyInt <:! + (tyInt .->. tyInt) .->. tyInt .-*. tyInt + , tyInt .->. tyInt <:! tyUn + , tyInt .->. tyInt <:! tyAf + , tyInt .-*. tyInt !<: tyUn + , tyInt .-*. tyInt <:! tyAf + , tyUn <:! tyAf + , tyAf !<: tyUn + , tyRecv tyInt <:! tyRecv tyInt + , tyRecv tyInt !<: tyRecv tyUnit + , tyRecv tyInt !<: tySend tyInt + , tyRecv (tyInt .-*. tyInt) <:! tyRecv (tyInt .->. tyInt) + , tyRecv (tyInt .->. tyInt) !<: tyRecv (tyInt .-*. tyInt) + , tySend (tyInt .-*. tyInt) !<: tySend (tyInt .->. tyInt) + , tySend (tyInt .->. tyInt) <:! tySend (tyInt .-*. tyInt) + , tyIdent tyInt <:! tyIdent tyInt + , tyIdent tyInt !<: tyIdent tyUnit + , tyInt <:! tyIdent tyInt + , tyIdent tyInt <:! tyInt + , tyInt !<: tyIdent tyUnit + , tyIdent tyInt !<: tyUnit + , tyConst tyInt <:! tyConst tyInt + , tyConst tyInt <:! tyConst tyUnit + , tyConst tyInt <:! tyUnit + , tyUnit <:! tyConst tyInt + , tyUnit .->. tyInt <:! tyIdent (tyConst (tySend tyInt) .-*. tyInt) + , tyInt .->. tyInt !<: tyIdent (tyConst (tySend tyInt) .-*. tyInt) + , tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) <:! + tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) + , tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) <:! + tySend tyInt .:. tyDual (tySend tyUnit .:. tyUnit) + , tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) <:! + tySend tyInt .:. tyRecv tyUnit .:. tyUnit + , tyBot <:! tyInt .->. tyInt + , tyInt .->. tyInt !<: tyBot + , TyVar a <:! TyVar a + , TyVar a !<: TyVar b + , tyAll a (tyInt .->. TyVar a) <:! tyAll b (tyInt .->. TyVar b) + , tyAll a (tyInt .->. TyVar a) <:! tyAll b (tyInt .->. TyVar a) + , tyAll c (TyVar c .->. tyInt) <:! tyAll a (TyVar a .-*. tyInt) + , tyAll a (TyVar a .->. tyInt) !<: tyAll c (TyVar c .-*. tyInt) + , tyAll a (tyAll b (TyVar a .*. TyVar b)) <:! + tyAll b (tyAll a (TyVar b .*. TyVar a)) + , tyAll a (tyAll b (TyVar a .*. TyVar b)) <:! + tyAll b (tyAll a (TyVar a .*. TyVar b)) + , tyAll a (tyAll a (TyVar a .*. TyVar b)) !<: + tyAll b (tyAll a (TyVar a .*. TyVar b)) + , tyAll a (tyAll a (TyVar a .*. TyVar b)) <:! + tyAll a (tyAll a (TyVar a .*. TyVar b)) + , TyMu a (tyInt .->. TyVar a) <:! + TyMu b (tyInt .->. TyVar b) + , TyMu a (tyInt .->. TyVar a) <:! + TyMu b (tyInt .->. tyInt .->. TyVar b) + , TyMu a (tyInt .->. TyVar a) <:! + TyMu b (tyInt .->. tyInt .-*. TyVar b) + , TyMu a (tyInt .->. TyVar a) !<: + TyMu b (tyInt .->. tyUnit .-*. TyVar b) + , TyMu a (TyVar a .*. tyInt .*. tyInt) <:! + TyMu a (TyVar a .*. tyInt .*. tyInt) .*. tyInt + , TyMu a (TyVar a .*. tyInt .*. tyUnit) <:! + TyMu a (TyVar a .*. tyUnit .*. tyInt) .*. tyUnit + , tyAll c (TyMu a (TyVar a .*. tyInt .*. TyVar c)) <:! + tyAll d (TyMu a (TyVar a .*. TyVar d .*. tyInt) .*. TyVar d) + , tyAll c (TyMu a (TyVar a .*. tyInt .*. TyVar c)) !<: + tyAll d (TyMu a (TyVar d .*. TyVar a .*. tyInt) .*. TyVar d) + , TyMu a (tyAll c ((tyInt .-*. TyVar c) .->. TyVar a)) !<: + TyMu b (tyAll d ((tyInt .->. TyVar d) .->. TyVar c)) + , TyMu a (tyAll c (tyInt .-*. TyVar c) .->. TyVar a) <:! + TyMu b (tyAll d (tyInt .->. TyVar d) .->. TyVar b) + , TyMu a (tyAll c (TyVar a .-*. TyVar c) .->. TyVar a) <:! + TyMu b (tyAll d (TyVar b .->. TyVar d) .->. TyVar b) + , tyAll a (TyVar a .*. tyInt) .->. TyVar a <:! + tyAll b (TyVar b .*. tyInt) .->. TyVar a + , tyAll a (TyVar a .*. tyInt) .->. TyVar a !<: + tyAll b (TyVar b .*. tyInt) .->. TyVar b + -- Universal instantiation tests + , tyAll a (TyVar a .->. TyVar a) <:! tyInt .->. tyInt + , tyAll a (TyVar a .->. TyVar a) !<: tyInt .->. tyUnit + , tyInt .->. tyInt !<: tyAll a (TyVar a .->. TyVar a) + , tyAll a (TyVar a .->. tyInt) <:! tyInt .->. tyInt + , tyAll a (tyInt .->. tyInt) <:! tyInt .->. tyInt + , tyInt .->. tyAll a (TyVar a .->. TyVar a) <:! + tyInt .->. tyInt .->. tyInt + , TyMu a (TyVar a .*. (tyAll a (TyVar a .->. TyVar a))) <:! + TyMu a (TyVar a .*. (tyInt .->. tyInt)) + , TyMu a (TyVar a .*. (tyAll a (tyInt .->. TyVar a))) <:! + TyMu a (TyVar a .*. (tyInt .->. tyInt)) + , TyMu b (TyVar b .*. (tyAll a (TyVar a .->. TyVar a))) <:! + TyMu a (TyVar a .*. (tyInt .->. tyInt)) + , TyMu b (TyVar b .*. (tyAll a (tyInt .->. TyVar a))) <:! + TyMu a (TyVar a .*. (tyInt .->. tyInt)) + , TyMu a (tyAll b (TyVar b .->. TyVar a)) <:! + TyMu a (tyInt .->. TyVar a) + , tyAll a (TyVar a .*. tyInt) <:! TyMu a (TyVar a .*. tyInt) + , tyAll a (TyVar a .*. TyVar a) !<: TyMu a (TyVar a .*. tyInt) + , tyAll a (TyMu b (TyVar a .->. TyVar b)) <:! + TyMu b (tyInt .->. TyVar b) + , tyAll a (TyMu a (tyInt .->. TyVar a)) !<: + TyMu b (tyInt .->. tyInt) + , tyAll a (tyInt .->. TyVar a) .->. tyInt !<: + (tyInt .->. tyInt) .->. tyInt + , (tyInt .->. tyInt) .->. tyInt <:! + tyAll a (tyInt .->. TyVar a) .->. tyInt + , tyAll a (tyInt .->. TyVar a) !<: tyInt .->. tyInt .-*. tyInt + -- This is now true, but should it be?: + , TyMu a (tyAll c (tyInt .->. tyAll d (TyVar c .->. TyVar a))) <:! + tyAll c (tyInt .->. + TyMu a (tyAll d (TyVar c .->. + tyAll c (tyInt .->. TyVar a)))) + -- This is now true, but should it be?: + , tyAll c (tyInt .->. + TyMu a (tyAll d (TyVar c .->. + tyAll c (tyInt .->. TyVar a)))) <:! + TyMu a (tyAll c (tyInt .->. tyAll d (TyVar c .->. TyVar a))) + , tyInt <:! tyEx a (TyVar a) + , tyInt <:! tyEx a tyInt + , tyInt .*. tyInt <:! tyEx a (TyVar a .*. tyInt) + , tyInt .*. tyInt <:! tyEx a (tyInt .*. TyVar a) + , tyInt .*. tyInt <:! tyEx a (TyVar a .*. TyVar a) + , tyInt .*. tyInt <:! tyEx a (tyEx b (TyVar a .*. TyVar a)) + , tyInt .*. tyInt <:! tyEx a (tyEx b (TyVar b .*. TyVar a)) + , tyUn .->. tyUn !<: TyVar a .->. TyVar a + -- These are potentially sketchy, but useful: + , tyInt <:! tyAll a tyInt + , tyInt !<: tyAll a (TyVar a) + , tyEx a tyInt <:! tyInt + , tyEx a (TyVar a) !<: tyInt + , tyEx a (TyVar a) !<: TyVar a + ] + where + t1 <:! t2 = T.assertBool (show t1 ++ " <: " ++ show t2) (t1 <: t2) + t1 !<: t2 = T.assertBool (show t1 ++ " /<: " ++ show t2) (t1 /<: t2) + infix 4 <:!, !<: + a = tvUn "a"; b = tvUn "b"; c = tvAf "c"; d = tvAf "d" + +joinTests = T.test + [ tyUnit \/! tyUnit ==! tyUnit + , tyUnit /\! tyUnit ==! tyUnit + , tyInt /\! tyInt ==! tyInt + , tyUnit \/! tyInt ==! tyUn + , tyUnit !/\ tyInt + , tyInt .->. tyInt \/! tyInt .->. tyInt ==! tyInt .->. tyInt + , tyInt .->. tyInt \/! tyInt .-*. tyInt ==! tyInt .-*. tyInt + , tyInt .-*. tyInt \/! tyInt .-*. tyInt ==! tyInt .-*. tyInt + , tyInt .-*. tyInt \/! tyInt .->. tyInt ==! tyInt .-*. tyInt + , tyInt .->. tyInt /\! tyInt .->. tyInt ==! tyInt .->. tyInt + , tyInt .->. tyInt /\! tyInt .-*. tyInt ==! tyInt .->. tyInt + , tyInt .-*. tyInt /\! tyInt .-*. tyInt ==! tyInt .-*. tyInt + , tyInt .-*. tyInt /\! tyInt .->. tyInt ==! tyInt .->. tyInt + , tyInt .->. tyInt \/! tyInt .->. tyUnit ==! tyInt .->. tyUn + , tyInt .->. tyInt \/! tyUnit .->. tyInt ==! tyUn + , tyInt .-*. tyInt \/! tyUnit .->. tyInt ==! tyAf + , tyInt .->. tyInt !/\ tyInt .->. tyUnit + , tyInt .->. tyInt /\! tyUnit .->. tyInt ==! tyUn .->. tyInt + , tyInt .-*. tyInt /\! tyUnit .->. tyInt ==! tyUn .->. tyInt + , (tyInt .-*. tyInt) .-*. tyInt /\! tyUnit .->. tyInt + ==! tyAf .->. tyInt + , tyInt .->. tyInt \/! tyUn ==! tyUn + , tyInt .->. tyInt \/! tyAf ==! tyAf + , tyInt .-*. tyInt \/! tyUn ==! tyAf + , tyInt .-*. tyInt \/! tyAf ==! tyAf + , tyInt .->. tyInt /\! tyUn ==! tyInt .->. tyInt + , tyInt .->. tyInt /\! tyAf ==! tyInt .->. tyInt + , tyInt .-*. tyInt !/\ tyUn -- could do better + , tyInt .-*. tyInt /\! tyAf ==! tyInt .-*. tyInt + , tyRecv tyInt \/! tyRecv tyInt ==! tyRecv tyInt + , tySend tyInt \/! tySend tyUnit ==! tySend tyUn + , tyRecv tyInt \/! tySend tyInt ==! tyUn + , tyRecv (tyInt .-*. tyInt) \/! + tyRecv (tyInt .->. tyInt) ==! + tyRecv (tyInt .->. tyInt) + , tyRecv (tyInt .->. tyInt) \/! + tyRecv (tyInt .-*. tyInt) ==! + tyRecv (tyInt .->. tyInt) + , tySend (tyInt .-*. tyInt) \/! + tySend (tyInt .->. tyInt) ==! + tySend (tyInt .-*. tyInt) + , tySend (tyInt .->. tyInt) \/! + tySend (tyInt .-*. tyInt) ==! + tySend (tyInt .-*. tyInt) + , tyRecv (tyInt .-*. tyInt) /\! + tyRecv (tyInt .->. tyInt) ==! + tyRecv (tyInt .-*. tyInt) + , tyRecv (tyInt .->. tyInt) /\! + tyRecv (tyInt .-*. tyInt) ==! + tyRecv (tyInt .-*. tyInt) + , tySend (tyInt .-*. tyInt) /\! + tySend (tyInt .->. tyInt) ==! + tySend (tyInt .->. tyInt) + , tySend (tyInt .->. tyInt) /\! + tySend (tyInt .-*. tyInt) ==! + tySend (tyInt .->. tyInt) + , tyIdent tyInt \/! tyIdent tyInt ==! tyIdent tyInt + , tyIdent tyInt \/! tyIdent tyUnit ==! tyUn + , tyInt \/! tyIdent tyInt ==! tyInt + , tyInt \/! tyIdent tyUnit ==! tyUn + , tyIdent tyInt /\! tyIdent tyInt ==! tyIdent tyInt + , tyIdent tyInt !/\ tyIdent tyUnit + , tyInt /\! tyIdent tyInt ==! tyInt + , tyInt !/\ tyIdent tyUnit + , tyIdent (tyIdent tyInt) \/! tyIdent tyInt ==! tyIdent tyInt + , tyIdent (tyConst tyInt) \/! tyIdent (tyConst tyUnit) ==! tyIdent tyUnit + , tyConst tyInt \/! tyConst tyInt ==! tyConst tyInt + , tyConst tyInt \/! tyConst tyUnit ==! tyUnit + , tyConst tyInt /\! tyConst tyInt ==! tyConst tyInt + , tyConst tyInt /\! tyConst tyUnit ==! tyUnit + , tyUnit .->. tyInt \/! tyIdent (tyConst (tySend tyInt) .-*. tyInt) + ==! tyUnit .-*. tyInt + , tyInt .->. tyInt \/! tyIdent (tyConst (tySend tyInt) .-*. tyInt) + ==! tyAf + , tyUnit .->. tyInt /\! tyIdent (tyConst (tySend tyInt) .-*. tyInt) + ==! tyUnit .->. tyInt + , tyInt .->. tyInt /\! tyIdent (tyConst (tySend tyInt) .-*. tyInt) + ==! tyUn .->. tyInt + , tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) \/! + tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) ==! + tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) + , tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) \/! + tySend tyInt .:. tyDual (tySend tyUnit .:. tyUnit) ==! + tySend tyInt .:. tyDual (tySend tyUnit .:. tyUnit) + , tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) \/! + tySend tyInt .:. tyRecv tyUnit .:. tyUnit ==! + tySend tyInt .:. tyRecv tyUnit .:. tyUnit + , tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) /\! + tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) ==! + tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) + , tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) /\! + tySend tyInt .:. tyDual (tySend tyUnit .:. tyUnit) ==! + tySend tyInt .:. tyDual (tySend tyUnit .:. tyUnit) + , tyDual (tyRecv tyInt .:. tySend tyUnit .:. tyUnit) /\! + tySend tyInt .:. tyRecv tyUnit .:. tyUnit ==! + tySend tyInt .:. tyRecv tyUnit .:. tyUnit + , tyBot \/! tyInt .->. tyInt ==! tyInt .->. tyInt + , tyInt .->. tyInt /\! tyBot ==! tyAll b (TyVar b) + , TyVar a \/! TyVar a ==! TyVar a + , TyVar a \/! TyVar b ==! tyUn + , TyVar a \/! TyVar c ==! tyAf + , TyVar a /\! TyVar a ==! TyVar a + , TyVar a !/\ TyVar b + , TyVar a !/\ TyVar c + , tyAll a (tyInt .->. TyVar a) \/! tyAll b (tyInt .->. TyVar b) + ==! tyAll a (tyInt .->. TyVar a) + , tyAll a (tyInt .->. TyVar a) \/! tyAll b (tyInt .->. TyVar a) + ==! tyAll a (tyInt .->. tyUn) + , tyAll c (TyVar c .->. tyInt) \/! tyAll a (TyVar a .-*. tyInt) + ==! tyAll d (TyVar d .-*. tyInt) + , tyAll a (tyInt .->. TyVar a) /\! tyAll b (tyInt .->. TyVar b) + ==! tyAll a (tyInt .->. TyVar a) + , tyAll a (tyInt .->. TyVar a) !/\ tyAll b (tyInt .->. TyVar a) + , tyAll c (TyVar c .->. tyInt) /\! + tyAll a (TyVar a .-*. tyInt) ==! + tyAll b (TyVar b .->. tyInt) + , tyAll a (tyAll b (TyVar a .*. TyVar b)) \/! + tyAll b (tyAll a (TyVar b .*. TyVar a)) ==! + tyAll b (tyAll a (TyVar b .*. TyVar a)) + , tyAll a (tyAll b (TyVar a .*. TyVar b)) \/! + tyAll b (tyAll a (TyVar a .*. TyVar b)) ==! + tyAll b (tyAll a (tyUn .*. tyUn)) + , tyAll c (tyAll c (TyVar c .*. TyVar d)) \/! + tyAll d (tyAll c (TyVar c .*. TyVar d)) ==! + tyAll d (tyAll d (TyVar d .*. tyAf)) + , tyAll a (tyAll a (TyVar a .*. TyVar b)) \/! + tyAll a (tyAll a (TyVar a .*. TyVar b)) ==! + tyAll a (tyAll a (TyVar a .*. TyVar b)) + , tyAll a (tyAll b (TyVar a .*. TyVar b)) /\! + tyAll b (tyAll a (TyVar b .*. TyVar a)) ==! + tyAll b (tyAll a (TyVar b .*. TyVar a)) + , tyAll a (tyAll b (TyVar a .*. TyVar b)) !/\ + tyAll b (tyAll a (TyVar a .*. TyVar b)) + , tyAll c (tyAll c (TyVar c .*. TyVar d)) !/\ + tyAll d (tyAll c (TyVar c .*. TyVar d)) + , tyAll a (tyAll a (TyVar a .*. TyVar b)) /\! + tyAll a (tyAll a (TyVar a .*. TyVar b)) ==! + tyAll a (tyAll a (TyVar a .*. TyVar b)) + , TyMu a (tyInt .->. TyVar a) \/! + TyMu b (tyInt .->. TyVar b) ==! + TyMu b (tyInt .->. TyVar b) + , TyMu a (tyInt .->. TyVar a) /\! + TyMu b (tyInt .->. TyVar b) ==! + TyMu b (tyInt .->. TyVar b) + , TyMu a (tyInt .->. TyVar a) \/! + TyMu b (tyInt .->. tyInt .->. TyVar b) ==! + TyMu a (tyInt .->. TyVar a) + , TyMu a (tyInt .->. TyVar a) /\! + TyMu b (tyInt .->. tyInt .->. TyVar b) ==! + TyMu a (tyInt .->. TyVar a) + , TyMu a (tyInt .->. TyVar a) \/! + TyMu b (tyInt .->. tyInt .-*. TyVar b) ==! + TyMu b (tyInt .->. tyInt .-*. TyVar b) + , TyMu a (tyInt .->. TyVar a) /\! + TyMu b (tyInt .->. tyInt .-*. TyVar b) ==! + TyMu b (tyInt .->. TyVar b) + , TyMu a (tyInt .->. TyVar a) \/! + TyMu b (tyInt .->. tyUnit .-*. TyVar b) ==! + tyInt .->. tyAf + , TyMu a (tyInt .->. TyVar a) /\! + TyMu b (tyInt .->. tyUnit .-*. TyVar b) ==! + TyMu a (tyInt .->. tyUn .->. TyVar a) + , TyMu a (TyVar a .*. tyInt .*. tyInt) \/! + TyMu a (TyVar a .*. tyInt .*. tyInt) .*. tyInt ==! + TyMu a (TyVar a .*. tyInt) + , TyMu a (TyVar a .*. tyInt .*. tyInt) /\! + TyMu a (TyVar a .*. tyInt .*. tyInt) .*. tyInt ==! + TyMu a (TyVar a .*. tyInt) + , TyMu a (TyVar a .*. tyInt .*. tyUnit) \/! + TyMu a (TyVar a .*. tyUnit .*. tyInt) .*. tyUnit ==! + TyMu b (TyVar b .*. tyInt .*. tyUnit) + , TyMu a (TyVar a .*. tyInt .*. tyUnit) /\! + TyMu a (TyVar a .*. tyUnit .*. tyInt) .*. tyUnit ==! + TyMu b (TyVar b .*. tyInt .*. tyUnit) + , tyAll c (TyMu a (TyVar a .*. tyInt .*. TyVar c)) \/! + tyAll d (TyMu a (TyVar a .*. TyVar d .*. tyInt) .*. TyVar d) ==! + tyAll c (TyMu b (TyVar b .*. tyInt .*. TyVar c)) + , tyAll c (TyMu a (TyVar a .*. tyInt .*. TyVar c)) /\! + tyAll d (TyMu a (TyVar a .*. TyVar d .*. tyInt) .*. TyVar d) ==! + tyAll c (TyMu b (TyVar b .*. tyInt .*. TyVar c)) + , tyAll c (TyMu a (TyVar a .*. tyInt .*. TyVar c)) \/! + tyAll d (TyMu a (TyVar d .*. TyVar a .*. tyInt) .*. TyVar d) ==! + tyAll c (tyAf .*. tyAf .*. tyInt .*. TyVar c) + , tyAll c (TyMu a (TyVar a .*. tyInt .*. TyVar c)) !/\ + tyAll d (TyMu a (TyVar d .*. TyVar a .*. tyInt) .*. TyVar d) + , TyMu a (tyAll c (tyInt .-*. TyVar c) .->. TyVar a) \/! + TyMu b (tyAll d (tyInt .->. TyVar d) .->. TyVar c) ==! + tyAll d (tyInt .->. TyVar d) .->. tyAf + , TyMu a (tyAll c (tyInt .-*. TyVar c) .->. TyVar a) !/\ + TyMu b (tyAll d (tyInt .->. TyVar d) .->. TyVar c) + , TyMu a (tyAll c (tyInt .-*. TyVar c) .->. TyVar a) \/! + TyMu b (tyAll d (tyInt .->. TyVar d) .->. TyVar b) ==! + TyMu b (tyAll c (tyInt .->. TyVar c) .->. TyVar b) + , TyMu a (tyAll c (tyInt .-*. TyVar c) .->. TyVar a) /\! + TyMu b (tyAll d (tyInt .->. TyVar d) .->. TyVar b) ==! + TyMu b (tyAll c (tyInt .-*. TyVar c) .->. TyVar b) + , TyMu a (tyAll c (TyVar a .-*. TyVar c) .->. TyVar a) \/! + TyMu b (tyAll d (TyVar b .->. TyVar d) .->. TyVar b) ==! + TyMu b (tyAll d (TyVar b .->. TyVar d) .->. TyVar b) + , TyMu a (tyAll c (TyVar a .-*. TyVar c) .->. TyVar a) /\! + TyMu b (tyAll d (TyVar b .->. TyVar d) .->. TyVar b) ==! + TyMu b (tyAll d (TyVar b .-*. TyVar d) .->. TyVar b) + , tyAll a (TyVar a .*. tyInt) .->. TyVar a \/! + tyAll b (TyVar b .*. tyInt) .->. TyVar a ==! + tyAll b (TyVar b .*. tyInt) .->. TyVar a + , tyAll a (TyVar a .*. tyInt) .->. TyVar a /\! + tyAll b (TyVar b .*. tyInt) .->. TyVar a ==! + tyAll b (TyVar b .*. tyInt) .->. TyVar a + , tyAll a (TyVar a .*. tyInt) .->. TyVar a \/! + tyAll b (TyVar b .*. tyInt) .->. TyVar b ==! + tyAll b (TyVar b .*. tyInt) .->. tyUn + , tyAll a (TyVar a .*. tyInt) .->. TyVar a !/\ + tyAll b (TyVar b .*. tyInt) .->. TyVar b + , tyBot \/! TyVar b ==! TyVar b + , tyIdent tyBot \/! TyVar b ==! TyVar b + ] + where + t1 \/! t2 = Left (t1, t2) + t1 /\! t2 = Right (t1, t2) + Left (t1, t2) ==! t = + T.assertEqual (show t1 ++ " \\/ " ++ show t2 ++ " = " ++ show t) + (Just t) (t1 \/? t2) + Right (t1, t2) ==! t = + T.assertEqual (show t1 ++ " /\\ " ++ show t2 ++ " = " ++ show t) + (Just t) (t1 /\? t2) + t1 !/\ t2 = + T.assertEqual (show t1 ++ " /\\ " ++ show t2 ++ " DNE") + Nothing (t1 /\? t2) + infix 2 ==! + infix 4 \/!, /\!, !/\ + a = tvUn "a"; b = tvUn "b"; c = tvAf "c"; d = tvAf "d" + +uvarsTests = T.test + [ tyInt !<: tyUnit + , tyInt <:! tyInt ==! (noU, noU, noA, noA) + , TyVar a <:! tyInt ==! (tyInt, noU, noA, noA) + , TyVar c <:! tyInt ==! (noU, noU, tyInt, noA) + , tyInt !<: TyVar a + , TyVar a .*. TyVar a <:! tyInt .*. tyInt + ==! (tyInt, noU, noA, noA) + , TyVar a .*. TyVar a !<: tyInt .*. tyUnit + , TyVar a .*. TyVar a <:! (tyInt .->. tyInt) .*. (tyInt .-*. tyInt) + ==! (tyInt .->. tyInt, noU, noA, noA) + , TyVar a .*. TyVar a <:! (tyUnit .->. tyInt) .*. (tyInt .-*. tyInt) + ==! (tyUn .->. tyInt, noU, noA, noA) + , TyVar a .->. tyInt <:! tyInt .->. tyInt + ==! (tyInt, noU, noA, noA) + , TyVar a .->. TyVar a <:! tyInt .->. tyInt + ==! (tyInt, noU, noA, noA) + , TyVar a .->. TyVar a !<: tyFloat .->. tyInt + , TyVar a .->. TyVar a !<: (tyInt .->. tyInt) .-*. (tyInt .-*. tyInt) + , TyVar c .->. TyVar c <:! (tyInt .->. tyInt) .-*. (tyInt .-*. tyInt) + ==! (noU, noU, tyInt .->. tyInt, noA) + , TyVar c .->. TyVar c !<: (tyInt .-*. tyInt) .-*. (tyInt .->. tyInt) + , TyVar c .-*. TyVar c !<: (tyInt .->. tyInt) .->. (tyInt .-*. tyInt) + , TyVar a .*. TyVar a <:! tyDual (tyRecv tyInt .:. tyUnit) .*. + (tySend tyInt .:. tyUnit) + ==! (tySend tyInt .:. tyUnit, noU, noA, noA) + , TyVar a .*. TyVar a !<: tyDual (tyRecv tyInt .:. tyUnit) .*. + (tySend tyInt .:. tyInt) + , TyVar a .*. tyAll a (TyVar a .->. tyInt) <:! + tyInt .*. tyAll b (TyVar b .->. tyInt) + ==! (tyInt, noU, noA, noA) + , TyVar a .*. tyAll a (TyVar a .->. tyInt) <:! + tyInt .*. tyAll b (tyInt .->. tyInt) + ==! (tyInt, noU, noA, noA) + , tyAll a (TyVar a .->. tyInt) <:! + tyAll a (tyInt .->. tyInt) + ==! (noU, noU, noA, noA) + , TyVar a <:! tyInt .->. TyMu a (tyInt .->. TyVar a) + ==! (TyMu b (tyInt .->. TyVar b), noU, noA, noA) + , TyVar a .->. TyVar b <:! tyInt .->. TyMu a (tyInt .->. TyVar a) + ==! (tyInt, TyMu b (tyInt .->. TyVar b), noA, noA) + , TyVar a .->. TyVar b <:! TyMu a (tyInt .->. TyVar a) + ==! (tyInt, TyMu b (tyInt .->. TyVar b), noA, noA) + , TyVar a >:! tyInt + ==! (tyInt, noU, noA, noA) + , TyVar a .-*. TyVar a >:! tyInt .->. tyInt + ==! (tyInt, noU, noA, noA) + , TyVar a .->. TyVar a !>: tyInt .-*. tyInt + , TyVar a .-*. TyVar a >:! tyUn .->. tyInt + ==! (tyInt, noU, noA, noA) + , TyFun (qInterpret (qeVar c)) tyInt tyInt <:! tyInt .-*. tyInt + ==! (noU, noU, noA, noA) + , TyFun (qInterpret (qeVar c)) tyInt tyInt <:! tyInt .->. tyInt + ==! (noU, noU, noA, noA) + , (TyVar c .->. TyVar d .-*. TyVar d) .*. TyVar d .*. tyRecv (TyVar c) + <:! + (TyVar e .->. TyVar f .-*. TyVar f) .*. TyVar f .*. tyRecv (TyVar e) + ==! (noU, noU, TyVar e, TyVar f) + , tyConst (TyVar a) <:! tyConst (tyInt) + ==! (tyInt, noU, noA, noA) -- suboptimal + , tyConst (TyVar a .*. tyUnit) <:! tyConst (tyInt .*. tyInt) + ==! (noU, noU, noA, noA) + , tyRecv (TyVar c) .*. tyRecv (TyVar c) >:! + tyRecv (TyVar e) .*. tyAll f (tyRecv (TyVar f)) + ==! (noU, noU, TyVar e, noA) + , tyRecv (TyVar c) .*. tyRecv (TyVar c) >:! + tyRecv (TyVar e) .*. tyRecv (TyVar e) + ==! (noU, noU, TyVar e, noA) + , tyRecv (TyVar c) .*. tyRecv (TyVar c) !>: + tyRecv (TyVar e) .*. tyRecv (TyVar f) + , T.assertEqual "':! + tyFollow tyUnit (tyRecv tyInt .:. + TyMu e (tyFollow tyUnit (tyRecv tyInt .:. + TyVar e))) + ==! (tyUnit, (tyRecv tyInt .:. + TyMu e (tyFollow tyUnit (tyRecv tyInt .:. + TyVar e))), noA, noA) + , tyFollow (TyVar a) (TyVar b) >:! + TyMu e (tyFollow tyUnit (tyRecv tyInt .:. TyVar e)) + ==! (tyUnit, (tyRecv tyInt .:. + TyMu e (tyFollow tyUnit (tyRecv tyInt .:. + TyVar e))), noA, noA) + ] + where + t1 <:! t2 = Left (t1, t2) + t1 >:! t2 = Right (t1, t2) + Left (t1, t2) ==! (ta, tb, tc, td) = + T.assertEqual (show t1 ++ " `subtype` " ++ show t2) + (Right ([ta, tb, tc, td], [])) + (runEither Left Right $ subtype 100 set t1 [] t2) + Right (t1, t2) ==! (ta, tb, tc, td) = + T.assertEqual (show t1 ++ " `supertype` " ++ show t2) + (Right ([], [ta, tb, tc, td])) + (runEither Left Right $ subtype 100 [] t2 set t1) + t1 !<: t2 = + T.assertEqual (show t1 ++ " `subtype` " ++ show t2 ++ " = ERROR") + Nothing (subtype 100 set t1 [] t2) + t1 !>: t2 = + T.assertEqual (show t1 ++ " `supertype` " ++ show t2 ++ " = ERROR") + Nothing (subtype 100 [] t2 set t1) + infix 2 ==! + infix 4 <:!, !<:, >:!, !>: + noU = tyBot; noA = tyBot + set = [a, b, c, d] + a = tvUn "a"; b = tvUn "b"; c = tvAf "c"; d = tvAf "d" + e = tvAf "e"; f = tvAf "f" + +tests :: IO () +tests = do + T.runTestTT subtypeTests + T.runTestTT joinTests + T.runTestTT uvarsTests + return () diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,223 @@ +-- | Utility functions +{-# LANGUAGE FlexibleContexts #-} +module Util ( + -- * List combinators + -- ** Shallow mapping + mapCons, mapHead, mapTail, + -- ** Two-list versions + foldl2, foldr2, all2, any2, + -- ** Monadic version + foldrM, anyM, allM, anyM2, allM2, + concatMapM, + -- ** Applicative versions + mapA, + -- ** Unfold with an accumulator + unscanr, unscanl, + -- ** Map in CPS + mapCont, mapCont_, + -- ** Monad generalization of map and sequence + GSequence(..), + + -- * More convenience + -- ** Maybe functions + (?:), + -- ** Either funtions + isLeft, isRight, + -- ** List functions + splitBy, + -- ** Monomorphic @ord@ and @chr@ + char2integer, integer2char, + -- ** For defining 'Ord' + thenCmp, + -- ** Versions of fmap + (>>!), + (<$$>), (<$$$>), (<$$$$>), (<$$$$$>), + + -- * Re-exports + module Data.Maybe, + module Control.Arrow, + module Control.Monad, + module Control.Applicative +) where + +import Data.Char (chr, ord) +import Data.Maybe +import Control.Arrow hiding (loop, (<+>)) +import Control.Monad +import Control.Applicative (Applicative(..), (<$>), (<$), (<**>)) + +-- | Right-associative monadic fold +foldrM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a +foldrM _ z [] = return z +foldrM f z (b:bs) = foldrM f z bs >>= flip f b + +-- | Like 'Prelude.any' with a monadic predicate +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM p (x:xs) = do + b <- p x + if b + then return True + else anyM p xs +anyM _ _ = return False + +-- | Like 'Prelude.all' with a monadic predicate +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM p = liftM not . anyM (liftM not . p) + +-- | Two-list, monadic 'any' +anyM2 :: Monad m => (a -> b -> m Bool) -> [a] -> [b] -> m Bool +anyM2 p as bs = anyM (uncurry p) (zip as bs) + +-- | Two-list, monadic 'all' +allM2 :: Monad m => (a -> b -> m Bool) -> [a] -> [b] -> m Bool +allM2 p as bs = allM (uncurry p) (zip as bs) + +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = concat `liftM` mapM f xs + +-- | Map an applicative over a list +mapA :: Applicative t => (a -> t b) -> [a] -> t [b] +mapA _ [] = pure [] +mapA f (x:xs) = (:) <$> f x <*> mapA f xs + +-- | Apply one function to the head of a list and another to the +-- tail +mapCons :: (a -> b) -> ([a] -> [b]) -> [a] -> [b] +mapCons fh ft [] = [] +mapCons fh ft (x:xs) = fh x : ft xs + +-- | Map a function over only the first element of a list +mapHead :: (a -> a) -> [a] -> [a] +mapHead f = mapCons f id + +-- | Map a function over all but the first element of a list +mapTail :: (a -> a) -> [a] -> [a] +mapTail = mapCons id . map + +-- | Left-associative fold over two lists +foldl2 :: (c -> a -> b -> c) -> c -> [a] -> [b] -> c +foldl2 f z (x:xs) (y:ys) = foldl2 f (f z x y) xs ys +foldl2 _ z _ _ = z + +-- | Right-associative fold over two lists +foldr2 :: (a -> b -> c -> c) -> c -> [a] -> [b] -> c +foldr2 f z (x:xs) (y:ys) = f x y (foldr2 f z xs ys) +foldr2 _ z _ _ = z + +-- | Two-list 'all' +all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool +all2 p xs ys = and (zipWith p xs ys) + +-- | Two-list 'any' +any2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool +any2 p xs ys = or (zipWith p xs ys) + +-- | The ASCII value of a character +char2integer :: Char -> Integer +char2integer = fromIntegral . ord + +-- | The character of an ASCII value +integer2char :: Integer -> Char +integer2char = chr . fromIntegral + +-- | Break a list where the given preducate answers true +splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy _ [] = [] +splitBy p xs = let (ys, zs) = break p xs + in ys : splitBy p (drop 1 zs) + +-- | Maybe cons, maybe not +(?:) :: Maybe a -> [a] -> [a] +Nothing ?: xs = xs +Just x ?: xs = x : xs + +infixr 5 ?: + +isLeft, isRight :: Either a b -> Bool +isLeft (Left _) = True +isLeft _ = False +isRight (Right _) = True +isRight _ = False + +-- | Unfold a list, left-to-right, returning the final state +unscanr :: (b -> Maybe (a, b)) -> b -> ([a], b) +unscanr f b = case f b of + Just (a, b') -> (a : fst rest, snd rest) where rest = unscanr f b' + Nothing -> ([], b) + +-- | Unfold a list, right-to-left, returning the final state +unscanl :: (b -> Maybe (a, b)) -> b -> ([a], b) +unscanl f = loop [] where + loop acc b = case f b of + Just (a, b') -> loop (a : acc) b' + Nothing -> (acc, b) + +-- | To combine two 'Ordering's in lexigraphic order +thenCmp :: Ordering -> Ordering -> Ordering +thenCmp EQ k2 = k2 +thenCmp k1 _ = k1 +infixr 4 `thenCmp` + +-- | 2nd order fmap +(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +(<$$>) = (<$>) . (<$>) + +-- | 3rd order fmap +(<$$$>) :: (Functor f, Functor g, Functor h) => + (a -> b) -> f (g (h a)) -> f (g (h b)) +(<$$$>) = (<$$>) . (<$>) + +-- | 4th order fmap +(<$$$$>) :: (Functor f, Functor g, Functor h, Functor j) => + (a -> b) -> f (g (h (j a))) -> f (g (h (j b))) +(<$$$$>) = (<$$$>) . (<$>) + +-- | 5th order fmap +(<$$$$$>) :: (Functor f, Functor g, Functor h, Functor j, Functor k) => + (a -> b) -> f (g (h (j (k a)))) -> f (g (h (j (k b)))) +(<$$$$$>) = (<$$$$>) . (<$>) + +infixl 4 <$$>, <$$$>, <$$$$>, <$$$$$> + +-- | @flip fmap@ +(>>!) :: Functor f => f a -> (a -> b) -> f b +(>>!) = flip fmap + +infixl 1 >>! + +-- | CPS version of 'map' +mapCont :: (a -> (b -> r) -> r) -> [a] -> ([b] -> r) -> r +mapCont _ [] k = k [] +mapCont f (x:xs) k = f x $ \x' -> + mapCont f xs $ \xs' -> + k (x' : xs') + +-- | CPS version of 'map_' +mapCont_ :: (a -> r -> r) -> [a] -> r -> r +mapCont_ _ [] k = k +mapCont_ f (x:xs) k = f x $ mapCont_ f xs $ k + +-- | Generalize 'map' and 'sequence' to a few other monads +class GSequence m where + gsequence :: Monad m' => m (m' a) -> m' (m a) + gsequence_ :: Monad m' => m (m' a) -> m' () + gsequence_ m = gsequence m >> return () + gmapM :: (Monad m, Monad m') => (a -> m' b) -> m a -> m' (m b) + gmapM f = gsequence . liftM f + gmapM_ :: (Monad m, Monad m') => (a -> m' b) -> m a -> m' () + gmapM_ f = gsequence_ . liftM f + gforM :: (Monad m, Monad m') => m a -> (a -> m' b) -> m' (m b) + gforM = flip gmapM + gforM_ :: (Monad m, Monad m') => m a -> (a -> m' b) -> m' () + gforM_ = flip gmapM_ + +instance GSequence [] where + gsequence = sequence + gsequence_ = sequence_ + gmapM = mapM + gmapM_ = mapM_ + +instance GSequence Maybe where + gsequence = maybe (return Nothing) (liftM return) + gsequence_ = maybe (return ()) (>> return ()) + diff --git a/src/Value.hs b/src/Value.hs new file mode 100644 --- /dev/null +++ b/src/Value.hs @@ -0,0 +1,463 @@ +-- | The representation and embedding of values +{-# LANGUAGE + DeriveDataTypeable, + ExistentialQuantification, + FlexibleInstances, + MultiParamTypeClasses, + PatternGuards, + RankNTypes, + ScopedTypeVariables + #-} +module Value ( + -- * Value and function representation + Valuable(..), FunName(..), Value(..), + funNameDocs, + -- ** Common values + vaInt, vaUnit, + -- ** Some pre-defined value types + Vinj(..), VExn(..), + -- *** Exception IDs + ExnId(..), + + -- * Utilities for algebraic data types + enumTypeDecl, + vinjData, vprjDataM +) where + +import qualified Data.List as List +import qualified Data.Char as Char +import Data.Generics + +import Util +import Syntax (Uid(..), Type, Renamed, uid) +import Ppr (Doc, text, Ppr(..), hang, sep, char, (<>), (<+>), + parensIf, precCom, precApp) + +import qualified Control.Exception as Exn + +import Foreign.C.Types (CInt) +import Data.Word (Word32, Word16) + +import Control.Monad.State as M.S + +-- | The kind of identifiers used +type R = Renamed + +-- | The name of a function +data FunName + -- | An anonymous function, whose name is overwritten by binding + = FNAnonymous [Doc] + -- | An already-named function + | FNNamed Doc + +funNameDocs :: FunName -> [Doc] +funNameDocs (FNAnonymous docs) = docs +funNameDocs (FNNamed doc) = [doc] + +-- | Class for Haskell values that can be injected as object-language +-- values +-- +-- All methods have reasonable (not very useful) defaults. +class Typeable a => Valuable a where + -- | Equality (default returns 'False') + veq :: a -> a -> Bool + veq _ _ = False + + -- | Dynamic equality: attempts to coerce two 'Valuable's + -- to the same Haskell type and then compare them + veqDyn :: Valuable b => a -> b -> Bool + veqDyn a b = maybe False (veq a) (vcast b) + + -- | Pretty-print a value at the given precedence + vpprPrec :: Int -> a -> Doc + vpprPrec _ _ = text "#<->" + + -- | Pretty-print a value at top-level precedence + vppr :: a -> Doc + vppr = vpprPrec 0 + + -- | Inject a Haskell value into the 'Value' type + vinj :: a -> Value + vinj a = case cast a of + Just v -> v + Nothing -> VaDyn a + + -- | Project a Haskell value from the 'Value' type + vprjM :: Monad m => Value -> m a + vprjM = vcast + + -- | Project a Haskell value from the 'Value' type, or fail + vprj :: Value -> a + vprj = maybe (error "BUG! vprj: coercion error") id . vprjM + + -- | Pretty-print a list of values. (This is the same hack used + -- by 'Show' for printing 'String's differently than other + -- lists.) + vpprPrecList :: Int -> [a] -> Doc + vpprPrecList _ [] = text "nil" + vpprPrecList p (x:xs) = parensIf (p > precApp) $ + hang (text "cons" <+> + vpprPrec (precApp + 1) x) + 1 + (vpprPrecList (precApp + 1) xs) + + -- | Inject a list. As with the above, this lets us special-case + -- lists at some types (e.g. we inject Haskell 'String' as object + -- language @string@ rather than @char list@) + vinjList :: [a] -> Value + vinjList [] = VaCon (uid "Nil") Nothing + vinjList (x:xs) = VaCon (uid "Cons") (Just (vinj (x, xs))) + + -- | Project a list. (Same deal.) + vprjListM :: Monad m => Value -> m [a] + vprjListM (VaCon (Uid _ "Nil") Nothing) = return [] + vprjListM (VaCon (Uid _ "Cons") (Just v)) = do + (x, xs) <- vprjM v + return (x:xs) + vprjListM _ = fail "vprjM: not a list" + +-- | Cast from one 'Typeable' to another, potentially unwrapping +-- dynamic value constructors. +vcast :: (Typeable a, Typeable b, Monad m) => a -> m b +vcast a = case cast a of + Just r -> return r + Nothing -> case cast a of + Just (VaDyn r) -> vcast r + _ -> fail "BUG! vcast: coercion error" + +-- | The representation of a value. +-- +-- We have special cases for the three classes of values that +-- have special meaning in the dynamics, and push all other Haskell +-- types into a catch-all case. +data Value + -- | A function + = VaFun FunName (Value -> IO Value) + -- | A datacon, potentially applied + | VaCon (Uid R) (Maybe Value) + -- | Any other embeddable Haskell type + | forall a. Valuable a => VaDyn a + deriving Typeable + +-- | Construct an @int@ value +vaInt :: Integer -> Value +vaInt = vinj + +-- | The @unit@ value +vaUnit :: Value +vaUnit = vinj () + +-- Ppr instances + +instance Ppr FunName where + pprPrec _ fn = hang (text "# char '>' + +instance Ppr Value where + pprPrec = vpprPrec + +instance Eq Value where + (==) = veq + +instance Show Value where + showsPrec p v = shows (pprPrec p v) + +instance Valuable a => Valuable [a] where + veq a b = length a == length b && all2 veq a b + vpprPrec = vpprPrecList + vinj = vinjList + vprjM = vprjListM + +instance Valuable Int where + veq = (==) + vpprPrec _ = text . show + vinj = vinj . toInteger + vprjM v = vprjM v >>= \z -> return (fromIntegral (z :: Integer)) + +instance Valuable Word16 where + veq = (==) + vpprPrec _ = text . show + vinj = vinj . toInteger + vprjM v = vprjM v >>= \z -> return (fromIntegral (z :: Integer)) + +instance Valuable Word32 where + veq = (==) + vpprPrec _ = text . show + vinj = vinj . toInteger + vprjM v = vprjM v >>= \z -> return (fromIntegral (z :: Integer)) + +instance Valuable CInt where + veq = (==) + vpprPrec _ = text . show + vinj = vinj . toInteger + vprjM v = vprjM v >>= \z -> return (fromIntegral (z :: Integer)) + +instance Valuable Integer where + veq = (==) + vpprPrec _ = text . show + +instance Valuable Double where + veq = (==) + vpprPrec _ = text . show + +instance Valuable () where + veq = (==) + vinj () = VaCon (uid "()") Nothing + vprjM (VaCon (Uid _ "()") _) = return () + vprjM _ = fail "vprjM: not a unit" + +instance Valuable Bool where + veq = (==) + vinj True = VaCon (uid "true") Nothing + vinj False = VaCon (uid "false") Nothing + vprjM (VaCon (Uid _ "true") _) = return True + vprjM (VaCon (Uid _ "false") _) = return False + vprjM _ = fail "vprjM: not a bool" + +instance Valuable Value where + vinj v = v + veq (VaCon c v) (VaCon d w) = c == d && v == w + veq (VaDyn a) b = veqDyn a b + veq _ _ = False + vpprPrec p (VaFun n _) = pprPrec p n + vpprPrec p (VaCon c Nothing) = pprPrec p c + vpprPrec p (VaCon c (Just v)) = parensIf (p > precApp) $ + pprPrec precApp c <+> + vpprPrec (precApp + 1) v + vpprPrec p (VaDyn v) = vpprPrec p v + -- for value debugging: + {- + vpprPrec p (VaCon c Nothing) = char '[' <> pprPrec p c <> char ']' + vpprPrec p (VaCon c (Just v)) = parensIf (p > precApp) $ + char '[' <> pprPrec precApp c <+> + vpprPrec (precApp + 1) v <> char ']' + vpprPrec p (VaDyn v) = char '{' <> vpprPrec p v <> char '}' + -} + +instance Valuable Char where + veq = (==) + vpprPrec _ = text . show + vpprPrecList _ = text . show + vinjList = VaDyn + vprjListM = vcast + +instance (Valuable a, Valuable b) => Valuable (a, b) where + veq (a, b) (a', b') = veq a a' && veq b b' + vpprPrec p (a, b) = parensIf (p > precCom) $ + sep [vpprPrec precCom a <> char ',', + vpprPrec (precCom + 1) b] + vinj (a, b) = VaDyn (vinj a, vinj b) + vprjM v = case vcast v of + Just (a, b) -> do + a' <- vprjM a + b' <- vprjM b + return (a', b') + Nothing -> fail "vprjM: not a pair" + +instance (Valuable a, Valuable b) => Valuable (Either a b) where + veq (Left a) (Left a') = veq a a' + veq (Right b) (Right b') = veq b b' + veq (Left _) (Right _) = False + veq (Right _) (Left _) = False + vinj (Left v) = VaCon (uid "Left") (Just (vinj v)) + vinj (Right v) = VaCon (uid "Right") (Just (vinj v)) + vprjM (VaCon (Uid _ "Left") (Just v)) = liftM Left (vprjM v) + vprjM (VaCon (Uid _ "Right") (Just v)) = liftM Right (vprjM v) + vprjM _ = fail "vprjM: not a sum" + +instance Valuable a => Valuable (Maybe a) where + veq (Just a) (Just a') = veq a a' + veq Nothing Nothing = True + veq (Just _) Nothing = False + veq Nothing (Just _) = False + vinj (Just v) = VaCon (uid "Some") (Just (vinj v)) + vinj Nothing = VaCon (uid "None") Nothing + vprjM (VaCon (Uid _ "Some") (Just v)) = liftM Just (vprjM v) + vprjM (VaCon (Uid _ "None") Nothing) = return Nothing + vprjM _ = fail "vprjM: not an option" + +-- | Type for injection of arbitrary Haskell values with +-- minimal functionality +newtype Vinj a = Vinj { unVinj :: a } + deriving (Eq, Typeable, Data) + +instance (Eq a, Show a, Data a) => Valuable (Vinj a) where + veq = (==) + vpprPrec _ = text . show + +instance Show a => Show (Vinj a) where + showsPrec p = showsPrec p . unVinj + +-- Exceptions + +-- | The representation of exceptions +data VExn = VExn { + exnValue :: Value + } + deriving (Typeable, Eq) + +instance Valuable VExn where + veq = (==) + vpprPrec p = vpprPrec p . exnValue + +instance Show VExn where + showsPrec p e = (show (vpprPrec p e) ++) + +instance Exn.Exception VExn + +-- | Exception identity, generated dynamically +data ExnId i = ExnId { + eiName :: Uid i, + eiParam :: Maybe (Type i) + } + deriving (Typeable, Data) + +instance Eq (ExnId Renamed) where + ei == ei' = eiName ei == eiName ei' + +-- nasty syb stuff + +isString :: Data a => a -> Bool +isString a = typeOf a == typeOf "" + +-- | Use SYB to attempt to turn a Haskell data type into an object +-- language type declaration +enumTypeDecl :: Data a => a -> String +enumTypeDecl a = + case dataTypeRep ty of + IntRep -> add "int" + FloatRep -> add "float" + CharRep -> add "char" + NoRep -> name + AlgRep cs + | isString a + -> add "string" + | otherwise + -> add (unwords (List.intersperse " | " (map showConstr cs))) + where + ty = dataTypeOf a + add body = name ++ " = " ++ body + name = case last (splitBy (=='.') (dataTypeName ty)) of + c:cs -> Char.toLower c : cs + _ -> error "(BUG!) bad type name in enumTypeDecl" + +newtype Const a b = Const { unConst :: a } + +-- | Use SYB to attempt to inject a value of a Haskell data type into +-- an object language value matching the type declaration generated +-- by 'enumTypeDecl'. +vinjData :: Data a => a -> Value +vinjData = generic + `ext1Q` (vinj . map vinjData) + `ext1Q` (vinj . maybe Nothing (Just . vinjData)) + `extQ` (vinj :: String -> Value) + `extQ` (vinj :: Value -> Value) + `extQ` (vinj :: Bool -> Value) + `extQ` (vinj :: Char -> Value) + where + generic datum = case constrRep r of + IntConstr v -> vinj v + CharConstr v -> vinj v + FloatConstr v -> vinj (fromRational v :: Double) + AlgConstr _ + | Just s <- cast datum + -> vinj (s :: String) + | otherwise -> c (unConst (gfoldl k z datum)) + where + r = toConstr datum + k (Const Nothing) x = Const (Just (vinjData x)) + k (Const (Just v)) x = Const (Just (vinj (v, vinjData x))) + z = const (Const Nothing) + c f = case (showConstr r, f) of + (s, Just f') | isTuple s + -> f' + _ -> VaCon (uid (showConstr r)) f + +-- | The partial inverse of 'vinjData' +vprjDataM :: forall a m. (Data a, Monad m) => Value -> m a +vprjDataM = generic + `ext1RT` (\x -> vprjM x >>= sequence . liftM vprjDataM) + `ext1RT` (\x -> vprjM x >>= maybe (return Nothing) (liftM return) + . liftM vprjDataM) + `extRT` (vprjM :: Value -> m Int) + `extRT` (vprjM :: Value -> m CInt) + `extRT` (vprjM :: Value -> m Word32) + `extRT` (vprjM :: Value -> m Word16) + `extRT` (vprjM :: Value -> m Integer) + `extRT` (vprjM :: Value -> m String) + `extRT` (vprjM :: Value -> m Double) + `extRT` (vprjM :: Value -> m Value) + `extRT` (vprjM :: Value -> m Bool) + `extRT` (vprjM :: Value -> m Char) + where + generic (VaCon (Uid _ u) mfields0) = case readConstr ty u of + Nothing -> fail $ + "(BUG) Couldn't find constructor: " ++ u ++ + " in " ++ show ty + Just c -> M.S.evalStateT (gunfold k z c) mfields0 + where + k consmaker = do + mfields <- M.S.get + fields <- case mfields of + Just fields -> return fields + Nothing -> fail "(BUG) ran out of fields" + field <- case vprjM fields of + Just (fields', field) -> do + M.S.put (Just fields') + return field + Nothing -> do + M.S.put Nothing + return fields + make <- consmaker + mrest <- M.S.get + field' <- case mrest of + Just rest -> do + M.S.put Nothing + return (vinj (rest, field)) + Nothing -> + return field + datum <- vprjDataM field' + return (make datum) + z = return + generic v@(VaDyn _) = case dataTypeRep ty of + AlgRep (c:_) | t <- showConstr c, isTuple t + -> generic (VaCon (uid t) (Just v)) + IntRep | Just i <- vprjM v, + Just d <- cast (i :: Integer) + -> return d + -- May be broken in 6.12: + FloatRep | Just f <- vprjM v, + Just d <- cast (f :: Double) + -> return d + CharRep | Just c <- vprjM v, + Just d <- cast (c :: Char) + -> return d + -- need special case for string? + _ -> fail $ "(BUG) Can't project (VaDyn) " ++ show v ++ + " as datatype: " ++ show ty + generic v = fail $ "(BUG) Can't project " ++ show v ++ + " as datatype: " ++ show ty + ty = dataTypeOf (undefined :: a) + +isTuple :: String -> Bool +isTuple ('(':',':r) | dropWhile (== ',') r == ")" + = True +isTuple _ = False + +newtype RT r m a = RT { unRT :: r -> m a } + +extRT :: (Typeable a, Typeable b) => + (r -> m a) -> (r -> m b) -> r -> m a +m1 `extRT` m2 = unRT (maybe (RT m1) id (gcast (RT m2))) + +ext1RT :: (Data d, Typeable1 t) => + (r -> m d) -> (forall e. Data e => r -> m (t e)) -> r -> m d +m1 `ext1RT` m2 = unRT (maybe (RT m1) id (dataCast1 (RT m2))) + +{- +ext2RT :: (Data d, Typeable2 t) => + (r -> m d) -> + (forall e e'. (Data e, Data e') => r -> m (t e e')) -> + r -> m d +m1 `ext2RT` m2 = unRT (maybe (RT m1) id (dataCast2 (RT m2))) +-} diff --git a/src/Viewable.hs b/src/Viewable.hs new file mode 100644 --- /dev/null +++ b/src/Viewable.hs @@ -0,0 +1,52 @@ +-- | Quick and dirty views +{-# LANGUAGE TypeFamilies #-} +module Viewable where + +import Util + +-- | A viewable type has an associated type at which we view it, and +-- an operation to view it at that type. +-- +-- Instances map view over lists, options, sums, and products +class Viewable a where + type View a + view :: a -> View a + +-- | Wrapper type to hide from 'Viewable'. The view of +-- @HIDE a@ is @a@, rather than @View a@. +newtype HIDDEN a = HIDE { unHIDE :: a } + +instance Viewable (HIDDEN a) where + type View (HIDDEN a) = a + view (HIDE a) = a + +instance Viewable a => Viewable [a] where + type View [a] = [View a] + view = fmap view + +instance Viewable a => Viewable (Maybe a) where + type View (Maybe a) = Maybe (View a) + view = fmap view + +instance (Viewable a, Viewable b) => Viewable (Either a b) where + type View (Either a b) = Either (View a) (View b) + view = view +++ view + +instance (Viewable a, Viewable b) => Viewable (a, b) where + type View (a, b) = (View a, View b) + view = view *** view + +instance (Viewable a, Viewable b, Viewable c) => + Viewable (a, b, c) where + type View (a, b, c) = (View a, View b, View c) + view (a, b, c) = (view a, view b, view c) + +instance (Viewable a, Viewable b, Viewable c, Viewable d) => + Viewable (a, b, c, d) where + type View (a, b, c, d) = (View a, View b, View c, View d) + view (a, b, c, d) = (view a, view b, view c, view d) + +instance (Viewable a, Viewable b, Viewable c, Viewable d, Viewable e) => + Viewable (a, b, c, d, e) where + type View (a, b, c, d, e) = (View a, View b, View c, View d, View e) + view (a, b, c, d, e) = (view a, view b, view c, view d, view e)