packages feed

alms (empty) → 0.4.9

raw patch · 146 files changed

+18534/−0 lines, 146 filesdep +HUnitdep +QuickCheckdep +arraysetup-changed

Dependencies added: HUnit, QuickCheck, array, base, containers, directory, editline, filepath, haskell98, mtl, network, parsec, pretty, random, readline, syb, template-haskell

Files

+ LICENSE view
@@ -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.
+ Makefile view
@@ -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)
+ README view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++import Distribution.Simple+main = defaultMain
+ alms.cabal view
@@ -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 <tov@ccs.neu.edu>+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+
+ examples/echoServer.alms view
@@ -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 ())
+ examples/ex01-poly.alms view
@@ -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)
+ examples/ex01.alms view
@@ -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)
+ examples/ex02-poly-type-error.alms view
@@ -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)
+ examples/ex02-type-error.alms view
@@ -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)
+ examples/ex03-blame-error.alms view
@@ -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)
+ examples/ex03-poly-blame-error.alms view
@@ -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)
+ examples/ex04-poly.alms view
@@ -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)
+ examples/ex04.alms view
@@ -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)
+ examples/ex05-poly.alms view
@@ -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)
+ examples/ex05.alms view
@@ -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)
+ examples/ex06-poly-type-error.alms view
@@ -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)
+ examples/ex06-type-error.alms view
@@ -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)
+ examples/ex07-poly.alms view
@@ -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)
+ examples/ex07.alms view
@@ -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)
+ examples/ex08-blame-error.alms view
@@ -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)
+ examples/ex08-poly-blame-error.alms view
@@ -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)
+ examples/ex09-dynamic-promotion-poly.alms view
@@ -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)
+ examples/ex09-dynamic-promotion.alms view
@@ -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)
+ examples/ex10-dynamic-promotion-blame-error.alms view
@@ -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)
+ examples/ex10-dynamic-promotion-poly-blame-error.alms view
@@ -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)
+ examples/ex11-affine-type-error.alms view
@@ -0,0 +1,3 @@+(* Can't duplicate type `a (type error) *)++let dup[`a] (x: `a) = (x, x)
+ examples/ex12-affine-type-error.alms view
@@ -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)
+ examples/ex25-io.alms view
@@ -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)
+ examples/ex26-let-bang-array.alms view
@@ -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 ())+
+ examples/ex27-focusing-and-adoption.alms view
@@ -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
+ examples/ex28-focusing-and-adoption.alms view
@@ -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
+ examples/ex31-exceptions.alms view
@@ -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
+ examples/ex32-exceptions.alms view
@@ -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 _ -> ()
+ examples/ex33-session-types.alms view
@@ -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)
+ examples/ex34-session-types.alms view
@@ -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)
+ examples/ex35-session-types-type-error.alms view
@@ -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)
+ examples/ex36-session-types-type-error.alms view
@@ -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)
+ examples/ex37-session-types-type-error.alms view
@@ -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)
+ examples/ex38-session-types-type-error.alms view
@@ -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)
+ examples/ex40-signatures.alms view
@@ -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)
+ examples/ex41-signatures-type-error.alms view
@@ -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
+ examples/ex42-signatures-type-error.alms view
@@ -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
+ examples/ex43-signatures-type-error.alms view
@@ -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
+ examples/ex44-signatures-type-error.alms view
@@ -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
+ examples/ex45-signatures-type-error.alms view
@@ -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+
+ examples/ex46-signatures-type-error.alms view
@@ -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+
+ examples/ex47-signatures.alms view
@@ -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
+ examples/ex48-signatures-type-error.alms view
@@ -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
+ examples/ex49-signatures-type-error.alms view
@@ -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
+ examples/ex50-signatures.alms view
@@ -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
+ examples/ex51-signatures-type-error.alms view
@@ -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)
+ examples/ex52-signatures.alms view
@@ -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)
+ examples/ex53-signatures.alms view
@@ -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)
+ examples/ex54-signatures-type-error.alms view
@@ -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)
+ examples/ex55-signatures-type-error.alms view
@@ -0,0 +1,7 @@+(* Signature tests -- should print type error *)++module A : sig+  type `a t+end = struct+  type `a t = `a+end
+ examples/ex56-signatures-type-error.alms view
@@ -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
+ examples/ex57-signatures.alms view
@@ -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
+ examples/ex60-popl-deposit.alms view
@@ -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
+ examples/ex61-popl-AfArray.alms view
@@ -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+
+ examples/ex62-popl-AfArray-type-error.alms view
@@ -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++ *)+
+ examples/ex63-popl-CapArray.alms view
@@ -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+
+ examples/ex64-popl-CapLockArray.alms view
@@ -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+
+ examples/ex65-popl-Fractional.alms view
@@ -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
+ examples/ex66-popl-RWLock.alms view
@@ -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
+ examples/futures1.alms view
@@ -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? "
+ examples/netcat.alms view
@@ -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 ()
+ examples/run-test.sh view
@@ -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
+ examples/run-tests.sh view
@@ -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
+ examples/session-types-interactive.alms view
@@ -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 ())+
+ examples/session-types-polygons-1.in view
@@ -0,0 +1,7 @@+0x + 0y + 1z + 0 > 0++(1, 0, 1)+(1, 0, -1)+(-1, 0, -1)+(-1, 0, 1)+
+ examples/session-types-polygons-1.out view
@@ -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)
+ examples/session-types-polygons-2.in view
@@ -0,0 +1,6 @@+0x + 0y + 1z + 0 > 0++(1, 0, 1)+(1, 0, -1)+(-1, 0, -1)+
+ examples/session-types-polygons-2.out view
@@ -0,0 +1,3 @@+(1.0, 0.0, 1.0)+(1.0, 0.0, 0.0)+(0.0, 0.0, 0.0)
+ examples/session-types-polygons-3.in view
@@ -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)+
+ examples/session-types-polygons-3.out view
@@ -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)
+ examples/session-types-polygons.alms view
@@ -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 ()
+ examples/session-types-polygons2.alms view
@@ -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 ()
+ examples/skewness-dynamic-bad.alms view
@@ -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
+ examples/skewness-good.alms view
@@ -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
+ examples/skewness-static-bad.alms view
@@ -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
+ examples/threads1.alms view
@@ -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 ()
+ examples/threads2.alms view
@@ -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 ()+
+ examples/threads3.alms view
@@ -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 ()+
+ examples/threads4.alms view
@@ -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 <ENTER> to exit.";+    let stop = startStop () in+      after 4000000 stop;+      getLine ();+      stop ()++in main ()+
+ lib/libachan.alms view
@@ -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
+ lib/libarray.alms view
@@ -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
+ lib/libarraycap.alms view
@@ -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
+ lib/libbasis.alms view
@@ -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
+ lib/libqueue.alms view
@@ -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
+ lib/libsessiontype.alms view
@@ -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
+ lib/libsessiontype2.alms view
@@ -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
+ lib/libsocket.alms view
@@ -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
+ lib/libsocketcap.alms view
@@ -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+
+ lib/libsocketcap2.alms view
@@ -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+
+ lib/libthread.alms view
@@ -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
+ src/Basis.hs view
@@ -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 "#<ref>"++-- | Built-in operations implemented in the object language+srcBasis :: String+srcBasis  = "libbasis.alms"
+ src/Basis/Array.hs view
@@ -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 "#<array>"++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+  ]+
+ src/Basis/Channel.hs view
@@ -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 "#<channel>"++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)+  ]
+ src/Basis/Channel/Haskell.hs view
@@ -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+-}+
+ src/Basis/Exn.hs view
@@ -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)))) ]+  ]
+ src/Basis/Future.hs view
@@ -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)+  ]+
+ src/Basis/IO.hs view
@@ -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 "#<handle>"++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+  ]
+ src/Basis/MVar.hs view
@@ -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 "#<mvar>"++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))+  ]+
+ src/Basis/Socket.hs view
@@ -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 "#<socket>"++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+  ]+
+ src/Basis/Thread.hs view
@@ -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+  ]
+ src/BasisUtils.hs view
@@ -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 "<primitive>"++-- | 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+
+ src/Coercion.hs view
@@ -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 "<coercion>"++-- | 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))+
+ src/Dynamics.hs view
@@ -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'+
+ src/Env.hs view
@@ -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+
+ src/ErrorST.hs view
@@ -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")]+-}
+ src/Lexer.hs view
@@ -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+
+ src/Loc.hs view
@@ -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 "<bogus>"++-- | 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 "<bogus>"++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)+
+ src/Main.hs view
@@ -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
+ src/Meta/DeriveNotable.hs view
@@ -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
+ src/Meta/FileString.hs view
@@ -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)
+ src/Meta/Quasi.hs view
@@ -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+
+ src/Meta/QuoteData.hs view
@@ -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
+ src/Meta/THHelpers.hs view
@@ -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
+ src/PDNF.hs view
@@ -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
+ src/Parser.hs view
@@ -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 } "<quasi>" 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 "<string>"
+ src/Paths.hs view
@@ -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+
+ src/Ppr.hs view
@@ -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 >+>, >?>+
+ src/Prec.hs view
@@ -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
+ src/Rename.hs view
@@ -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'))+
+ src/Sigma.hs view
@@ -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+
+ src/Statics.hs view
@@ -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 "<addVal>"+  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
+ src/Syntax.hs view
@@ -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
+ src/Syntax/Anti.hs view
@@ -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 =:, =:!, =:<+
+ src/Syntax/Decl.hs view
@@ -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
+ src/Syntax/Decl.hs-boot view
@@ -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
+ src/Syntax/Expr.hs view
@@ -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+
+ src/Syntax/Ident.hs view
@@ -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
+ src/Syntax/Ident.hs-boot view
@@ -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)
+ src/Syntax/Kind.hs view
@@ -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+
+ src/Syntax/Lit.hs view
@@ -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)
+ src/Syntax/Notable.hs view
@@ -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
+ src/Syntax/POClass.hs view
@@ -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'+
+ src/Syntax/Patt.hs view
@@ -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+
+ src/Syntax/SyntaxTable.hs view
@@ -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   =:: '()+  ]+
+ src/Syntax/Type.hs view
@@ -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+
+ src/Type.hs view
@@ -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
+ src/TypeRel.hs view
@@ -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 "'<c `supertype` '<d = ERROR"+      Nothing (subtype 100 [c] (TyVar c) [d] (TyVar d))+  , tyFollow (TyVar a) (TyVar b) >:!+    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 ()
+ src/Util.hs view
@@ -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 ())+
+ src/Value.hs view
@@ -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 "#<fn") 4 $+                  sep (funNameDocs fn) <> 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)))+-}
+ src/Viewable.hs view
@@ -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)