packages feed

alms 0.5.0 → 0.6.0

raw patch · 195 files changed

+20657/−14048 lines, 195 filesdep +fgldep +incremental-sat-solverdep +stm

Dependencies added: fgl, incremental-sat-solver, stm, transformers, tuple

Files

Makefile view
@@ -2,9 +2,19 @@ GHC      = ghc EXAMPLES = examples SRC      = $(HS_SRC) $(HSBOOT_SRC)-HS_SRC      = src/*.hs src/Basis/*.hs src/Basis/Channel/*.hs \-              src/Syntax/*.hs src/Message/*.hs src/Meta/*.hs-HSBOOT_SRC  = src/Syntax/*.hs-boot+HS_SRC   = src/*.hs \+           src/Alt/*.hs \+           src/AST/*.hs \+           src/Basis/*.hs \+           src/Basis/Channel/*.hs \+           src/Data/*.hs \+           src/Message/*.hs \+           src/Meta/*.hs \+           src/Statics/*.hs \+           src/Syntax/*.hs \+           src/Type/*.hs \+           src/Util/*.hs+HSBOOT_SRC  = src/AST/*.hs-boot src/Statics/*.hs-boot  DOC      = dist/doc/html/alms/alms/ @@ -12,8 +22,11 @@ 	./Setup build 	cp dist/build/alms/alms . +alms.cabal: alms.cabal.sh Makefile src/extensions.txt $(HS_SRC)+	./alms.cabal.sh > alms.cabal+ dist/setup-config config: Setup alms.cabal-	./Setup configure --flags="$(FLAGS)"+	./Setup configure --user --flags="$(FLAGS)"  Setup: Setup.hs 	$(GHC) -o $@ --make $<@@ -50,7 +63,7 @@ 	$(RM) html  -VERSION = 0.5.0+VERSION = 0.6.0 DISTDIR = alms-$(VERSION) TARBALL = $(DISTDIR).tar.gz
alms.cabal view
@@ -1,6 +1,6 @@ Name:           alms-Version:        0.5.0-Copyright:      2010, Jesse A. Tov+Version:        0.6.0+Copyright:      2011, Jesse A. Tov Cabal-Version:  >= 1.8 License:        BSD3 License-File:   LICENSE@@ -11,7 +11,9 @@ Category:       Compilers/Interpreters Synopsis:       a practical affine language Build-type:     Simple-Data-files:     lib/*.alms examples/*.alms examples/*.sh+Extra-Source-Files:+                alms.cabal.sh src/extensions.txt+Data-Files:     lib/*.alms examples/*.alms examples/*.sh                 examples/*.in examples/*.out                 README Makefile @@ -29,6 +31,13 @@     system to naturally and directly express a variety of resource     management protocols from special-purpose type systems. +Source-Repository head+  Type:     git+  Location: git://github.com/tov/alms.git++Flag unicode+  Description: Use Unicode symbols for pretty-printing+ Flag editline   Description: Enable line editing using the editline package @@ -44,78 +53,147 @@   Hs-Source-Dirs:       src   GHC-Options:          -O3   CPP-Options:          -DALMS_CABAL_BUILD-  Build-Depends:        haskell98,+  Build-Depends:+                        haskell98,                         base == 4.*,-                        syb >= 0.1,-                        pretty >= 1,+                        HUnit >= 1.2,+                        QuickCheck >= 2,+                        array >= 0.3,                         containers >= 0.1,-                        mtl >= 1.1,+                        directory >= 1.0,+                        fgl >= 5,                         filepath >= 1.1,+                        incremental-sat-solver >= 0.1.7,+                        mtl >= 1.1,                         network >= 2.2,-                        directory >= 1.0,-                        template-haskell >= 2.0,-                        QuickCheck >= 2,-                        HUnit >= 1.2,+                        pretty >= 1,                         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,-                        Compat,-                        Dynamics,-                        Env,-                        ErrorMessage,-                        ErrorST,-                        Lexer,-                        Loc,-                        Message.AST,-                        Message.Parser,-                        Message.Quasi,-                        Message.Render,-                        Meta.DeriveNotable,-                        Meta.FileString,-                        Meta.Quasi,-                        Meta.QuoteData,-                        Meta.THHelpers,-                        PDNF,-                        Parser,-                        Paths,-                        Ppr,-                        PprClass,-                        Prec,-                        PrettyPrint,-                        Printing,-                        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,-                        Token,-                        Type,-                        TypeRel,-                        Util,-                        Value,-                        Viewable+                        stm >= 2.0,+                        syb >= 0.1,+                        template-haskell >= 2.0,+                        transformers >= 0.2,+                        tuple >= 0.2+  Other-Modules:+                        Alt.Graph+                        Alt.NodeMap+                        Alt.Parsec+                        Alt.PrettyPrint+                        Alt.Token+                        AST.Anti+                        AST.Decl+                        AST.Expr+                        AST.Ident+                        AST.Kind+                        AST.Lit+                        AST.Notable+                        AST.Patt+                        AST.SyntaxTable+                        AST.Type+                        AST.TypeAnnotation+                        AST+                        Basis.Array+                        Basis.Channel.Haskell+                        Basis.Channel+                        Basis.Exn+                        Basis.Future+                        Basis.IO+                        Basis.MVar+                        Basis.Row+                        Basis.Socket+                        Basis.Thread+                        Basis+                        BasisUtils+                        Compat+                        Data.Empty+                        Data.Lattice+                        Data.Loc+                        Data.OptionalClass+                        Data.Perhaps+                        Data.UnionFind+                        Dynamics+                        Env+                        Error+                        Main+                        Message.AST+                        Message.Parser+                        Message.Quasi+                        Message.Render+                        Meta.DeriveNotable+                        Meta.FileString+                        Meta.Quasi+                        Meta.QuoteData+                        Meta.THHelpers+                        Paths+                        Statics.Coercion+                        Statics.Constraint+                        Statics.Decl+                        Statics.Env+                        Statics.Error+                        Statics.Expr+                        Statics.InstGen+                        Statics.Patt+                        Statics.Rename+                        Statics.Sealing+                        Statics.Sig+                        Statics.Subsume+                        Statics.Type+                        Statics+                        Syntax.Construction+                        Syntax.ImplicitThreading+                        Syntax.Lexer+                        Syntax.Parser+                        Syntax.Ppr+                        Syntax.PprClass+                        Syntax.Prec+                        Syntax.Strings+                        Type.Analyses+                        Type.ArrowAnnotations+                        Type.Internal+                        Type.Ppr+                        Type.Rank+                        Type.Recursive+                        Type.Reduce+                        Type.Subst+                        Type.Syntax+                        Type.TyVar+                        Type+                        Util.Bogus+                        Util.Eq1+                        Util.MonadRef+                        Util.Trace+                        Util.UndoIO+                        Util.Viewable+                        Util+                        Value+  Extensions:+                        BangPatterns+                        CPP+                        DeriveDataTypeable+                        DeriveFunctor+                        EmptyDataDecls+                        ExistentialQuantification+                        FlexibleContexts+                        FlexibleInstances+                        FunctionalDependencies+                        GeneralizedNewtypeDeriving+                        MultiParamTypeClasses+                        ParallelListComp+                        PatternGuards+                        QuasiQuotes+                        RankNTypes+                        ScopedTypeVariables+                        StandaloneDeriving+                        TemplateHaskell+                        TupleSections+                        TypeOperators+                        TypeSynonymInstances+                        UndecidableInstances+                        UnicodeSyntax+                        ViewPatterns +  if flag(unicode)+    CPP-Options:    -DUNICODE+   if flag(readline)     Build-Depends:  readline >= 1.0     CPP-Options:    -DUSE_READLINE=System.Console.Readline@@ -130,4 +208,3 @@   else     Build-Depends:  parsec == 2.*     CPP-Options:    -DPARSEC_VERSION=2-
+ alms.cabal.sh view
@@ -0,0 +1,108 @@+#!/bin/sh++cat <<EOF+Name:           alms+Version:        `./util`+Copyright:      2011, 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+Extra-Source-Files:+                alms.cabal.sh src/extensions.txt+Data-Files:     lib/*.alms examples/*.alms examples/*.sh+                examples/*.in examples/*.out+                README Makefile++Description:+    Alms is an experimental, 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.++Source-Repository head+  Type:     git+  Location: git://github.com/tov/alms.git++Flag unicode+  Description: Use Unicode symbols for pretty-printing++Flag editline+  Description: Enable line editing using the editline package++Flag parsec3+  Description: Use version 3 of the parsec package++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.*,+                        HUnit >= 1.2,+                        QuickCheck >= 2,+                        array >= 0.3,+                        containers >= 0.1,+                        directory >= 1.0,+                        fgl >= 5,+                        filepath >= 1.1,+                        incremental-sat-solver >= 0.1.7,+                        mtl >= 1.1,+                        network >= 2.2,+                        pretty >= 1,+                        random >= 1,+                        stm >= 2.0,+                        syb >= 0.1,+                        template-haskell >= 2.0,+                        transformers >= 0.2,+                        tuple >= 0.2+  Other-Modules:+EOF++find src -name \*.hs |+    sed 's@^src/@                        @;s@\.hs$@@;s@/@.@g;/^Main$/d'++echo "  Extensions:"++sed 's/^/                        /' src/extensions.txt++cat <<EOF++  if flag(unicode)+    CPP-Options:    -DUNICODE++  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++  if flag(parsec3)+    Build-Depends:  parsec == 3.*+    CPP-Options:    -DPARSEC_VERSION=3+  else+    Build-Depends:  parsec == 2.*+    CPP-Options:    -DPARSEC_VERSION=2+EOF
examples/echoServer.alms view
@@ -7,27 +7,25 @@    (* 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 handleClient sock f cap =+    let rec loop cap =       let (str, cap) = recv sock 1024 cap in       let cap        = send sock (f str) cap in         loop cap      in try           loop cap-        with SocketError _ -> ()+        with SocketError _ → () -  let rec acceptLoop['t] (sock: 't socket) (f: string -> string)-                         (cap: 't listening) : unit =-    let (('s, clientsock, clientcap), cap) = accept sock cap in+  let rec acceptLoop sock f cap =+    let ((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");+      (Thread.fork :> (unit -A> unit) → Thread.thread)+        (λ _ → handleClient clientsock f clientcap;+               putStrLn "Closed connection");       acceptLoop sock f cap -  let serve (port: int) (f: string -> string) =-    let ('t, sock, cap) = socket () in+  let serve port f =+    let (sock, cap) = socket () in     let cap = bind sock port cap in     let cap = listen sock cap in       acceptLoop sock f cap@@ -35,9 +33,9 @@  let serverFun (s: string) = s -let main (argv: string list) =+let main argv =   match argv with-  | Cons (port, Nil) -> EchoServer.serve (int_of_string port) serverFun-  | _ -> failwith "Usage: echoServer.aff PORT\n"+  | [port] → EchoServer.serve (int_of_string port) serverFun+  | _      → failwith "Usage: echoServer.aff PORT\n"  in main (getArgs ())
examples/ex01-poly.alms view
@@ -1,10 +1,7 @@ (* Polymorphic version: A Type-Correct, Blame-Free Program *) -let ap =-  fun `a `b (f: `a -o `b) (x: `a) ->-    f x+let ap (f: `a -A> `b) x = f x -let inc =-  fun y: int -> ap (fun z:int -> z + 1) y+let inc y = ap ((+) 1) y  in print (inc 5)
examples/ex01.alms view
@@ -1,11 +1,7 @@ (* A Type-Correct, Blame-Free Program *) -let ap =-  fun f: (int -o int) ->-    fun x: int ->-      f x+let ap (f: int -A> int) x = f x -let inc =-  fun y: int -> ap (fun z:int -> z + 1) y+let inc y = ap ((+) 1) y  in print (inc 5)
examples/ex02-poly-type-error.alms view
@@ -1,15 +1,9 @@ (* 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 ap (f: `a -A> `b) x = f x -let inc2 =-  fun y: int ->-    let g = ap (fun z: int -> z + 1) in+let inc2 y =+    let g = ap ((+) 1) in       g (g y)   (* g: (int -o int) is used twice here *)  in print (inc2 5)
examples/ex02-type-error.alms view
@@ -1,13 +1,9 @@ (* An Ill-Typed Module (type error) *) -let ap =-  fun f: (int -o int) ->-    fun x: int ->-      f x+let ap (f: int -o int) x = 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 *)+let inc2 y =+  let g = ap ((+) 1) in+    g (g y)   (* g: (int -o int) is used twice here *) -in print[int] (inc2 5)+in print (inc2 5)
examples/ex03-blame-error.alms view
@@ -1,12 +1,10 @@ (* A Blameworthy Coercion *) -let ap =-  fun f: (int -o int) ->-    ( (fun x: int -> f x) :> int -> int )+let ap (f: int -o int) =+    ((fun x -> 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 *)+let inc2 y =+  let g = ap ((+) 1) in+    g (g y)   (* g is used twice here *)  in print (inc2 5)
examples/ex03-poly-blame-error.alms view
@@ -1,12 +1,10 @@ (* Polymorphic version: A Blameworthy Coercion *) -let ap =-  fun 'a 'b (f: 'a -o 'b) (x: 'a) -> f x+let ap (f: 'a -o 'b) x = f x -let inc2 =-  fun y: int ->-    let g = (ap :> all 'a 'b. ('a -A> 'b) -> 'a -U> 'b)-            (fun z: int -> z + 1) in-      g (g y)   (* g is used twice here *)+let inc2 y =+  let g = (ap :> ('a -A> 'b) -> 'a -U> 'b)+          ((+) 1) in+    g (g y)   (* g is used twice here *)  in print (inc2 5)
examples/ex04-poly.alms view
@@ -1,12 +1,10 @@ (* 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 ap : all 'a 'b. ('a -o 'b) -> 'a -o 'b = fun f x -> 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)+let inc2 y =+  let g = ap ((+) 1) in+  let h = ap ((+) 1) in+    h (g y) -in print[int] (inc2 5)+in print (inc2 5)
examples/ex04.alms view
@@ -1,14 +1,10 @@ (* Ex04 Corrected *) -let ap : (int -o int) -> int -o int =-  fun f: (int -o int) ->-    fun x: int ->-      f x+let ap : (int -o int) -> int -o int = fun f x -> 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)+let inc2 y =+  let g = ap ((+) 1) in+  let h = ap ((+) 1) in+    h (g y) -in print[int] (inc2 5)+in print (inc2 5)
examples/ex05-poly.alms view
@@ -1,10 +1,5 @@-let ap : all 'a 'b. ('a -> 'b) -> 'a -> 'b =-  fun 'a 'b ->-    fun f: ('a -> 'b) ->-      fun x: 'a ->-        f x+let ap : all 'a 'b. ('a -> 'b) -> 'a -> 'b = fun f x -> f x -let inc : int -> int =-  fun y: int -> ap[int,int] (fun z: int -> z + 1) y+let inc y = ap ((+) 1) y -in print[int] (inc 5)+in print (inc 5)
examples/ex05.alms view
@@ -1,9 +1,9 @@ let ap : (int -> int) -> int -> int =-  fun f: (int -> int) ->-    fun x: int ->+  fun (f: int -> int) ->+    fun (x: int) ->       f x  let inc : int -> int =-  fun y: int -> ap (fun z: int -> z + 1) y+  fun (y: int) -> ap (fun (z: int) -> z + 1) y -in print[int] (inc 5)+in print (inc 5)
examples/ex06-poly-type-error.alms view
@@ -1,12 +1,11 @@-let ap : all 'a 'b. ('a -> 'b) -> 'a -> 'b =-  fun 'a 'b ->-    fun f: ('a -> 'b) ->-      fun x: 'a ->+let ap : all 'c 'd. ('c -> 'd) -> 'c -> 'd =+    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) *)+  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)+in print (inc 5)
examples/ex06-type-error.alms view
@@ -1,11 +1,11 @@ let ap : (int -> int) -> int -> int =-  fun f: (int -> int) ->-    fun x: 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+  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)+in print (inc 5)
examples/ex07-poly.alms view
@@ -1,17 +1,16 @@ (* 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 ap : all 'c 'd. ('c -> 'd) -> 'c -> 'd =+  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)+  fun (y: int) ->+    (fun (g: int -o int) ->+       iap g y)+    (fun (z: int) -> z + 1) -in print[int] (inc 5)+in print (inc 5)
examples/ex07.alms view
@@ -1,16 +1,16 @@ (* An Interface Intervenes *)  let ap : (int -> int) -> int -> int =-  fun f: (int -> int) ->-    fun x: 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) ->+  fun (y: int) ->+    (fun (g: int -o int) ->        iap g y)-    (fun z: int -> z + 1)+    (fun (z: int) -> z + 1) -in print[int] (inc 5)+in print (inc 5)
examples/ex08-blame-error.alms view
@@ -1,16 +1,16 @@ (* A Lying Interface *)  let ap : (int -> int) -> int -> int =-  fun f: (int -> int) ->-    fun x: 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) ->+  fun (y: int) ->+    (fun (g: int -o int) ->        iap2 g y)-    (fun z: int -> z + 1)+    (fun (z: int) -> z + 1) -in print[int] (inc 5)+in print (inc 5)
examples/ex08-poly-blame-error.alms view
@@ -1,17 +1,16 @@ (* 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 ap : all 'c. ('c -> 'c) -> 'c -> 'c =+  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)+  fun (y: int) ->+    (fun (g: int -o int) ->+       iap2 g y)+    (fun (z: int) -> z + 1) -in print[int] (inc 5)+in print (inc 5)
examples/ex09-dynamic-promotion-poly.alms view
@@ -1,16 +1,15 @@ (* 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 ap : all 'c. ('c -> 'c) -> 'c -> 'c =+  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)+  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)+in print (inc 5)
examples/ex09-dynamic-promotion.alms view
@@ -1,15 +1,15 @@ (* A Dynamic Promotion Intervenes (like ex7.aff) *)  let ap : (int -> int) -> int -> int =-  fun f: (int -> int) ->-    fun x: int ->+  fun (f: int -> int) ->+    fun (x: int) ->       f x  let inc : int -> int =-  fun y: int ->-    (fun g: (int -o 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)+    (fun (z: int) -> z + 1) -in print[int] (inc 5)+in print (inc 5)
examples/ex10-dynamic-promotion-blame-error.alms view
@@ -1,15 +1,15 @@ (* A Lying Dynamic Promotion (like ex8.aff -- blame inc(:>)) *)  let ap : (int -> int) -> int -> int =-  fun f: (int -> int) ->-    fun x: 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) ->+  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)+    ((+) 1) -in print[int] (inc 5)+in print (inc 5)
examples/ex10-dynamic-promotion-poly-blame-error.alms view
@@ -1,16 +1,15 @@ (* 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 ap : all 'c. ('c -> 'c) -> 'c -> 'c =+  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)+  fun (y: int) ->+    (fun (g: int -o int) ->+       (ap :  (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)+in print (inc 5)
examples/ex11-affine-type-error.alms view
@@ -1,3 +1,3 @@ (* Can't duplicate type `a (type error) *) -let dup[`a] (x: `a) = (x, x)+let dup : ∀ `a. `a → `a * `a = λ x → (x, x)
+ examples/ex24-io.alms view
@@ -0,0 +1,41 @@+(* Typestate file IO *)++open IO++abstype in_channel' = InChannel of handle with+  let open_in s = InChannel (openFile s ReadMode)+  let input_char (InChannel h) = hGetChar h+  let input_line (InChannel h) = hGetLine h+  let eof_in (InChannel h)     = hIsEOF h+  let close_in (InChannel h)   = hClose h+end++abstype out_channel = OutChannel of handle with+  let open_out s = OutChannel (openFile s WriteMode)+  let output_char (OutChannel h)   = hPutChar h+  let output_string (OutChannel h) = hPutStr h+  let eof_out (OutChannel h)       = hIsEOF h+  let close_out (OutChannel h)     = hClose h+end++abstype in_channel : A = InChannel of in_channel' with+  let a_open_in s = InChannel (open_in s)+  let a_input_char (InChannel rep as ic) =+        (input_char rep, ic)+  let a_input_line (InChannel rep as ic) =+        (input_line rep, ic)+  let a_close_in (InChannel rep) =+        close_in rep+  let a_eof_in (InChannel rep as ic) =+    if eof_in rep+      then close_in rep; None+      else Some ic+end++let cat filename =+  let rec loop ic =+    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/ex25-io-type-error.alms view
@@ -0,0 +1,41 @@+(* Typestate file IO *)++open IO++abstype in_channel' = InChannel of handle with+  let open_in s = InChannel (openFile s ReadMode)+  let input_char (InChannel h) = hGetChar h+  let input_line (InChannel h) = hGetLine h+  let eof_in (InChannel h)     = hIsEOF h+  let close_in (InChannel h)   = hClose h+end++abstype out_channel = OutChannel of handle with+  let open_out s = OutChannel (openFile s WriteMode)+  let output_char (OutChannel h)   = hPutChar h+  let output_string (OutChannel h) = hPutStr h+  let eof_out (OutChannel h)       = hIsEOF h+  let close_out (OutChannel h)     = hClose h+end++abstype in_channel : A = InChannel of in_channel' with+  let a_open_in s = InChannel (open_in s)+  let a_input_char (InChannel rep as ic) =+        (input_char rep, ic)+  let a_input_line (InChannel rep as ic) =+        (input_line rep, ic)+  let a_close_in (InChannel rep) =+        close_in rep+  let a_eof_in (InChannel rep as ic) =+    if eof_in rep+      then close_in rep; None+      else Some ic+end++let cat filename =+  let rec loop ic =+    match a_eof_in ic with+    | None    -> ()+    | Some ic -> let (c, _) = a_input_char ic in+                   putChar c; loop ic+  in loop (a_open_in filename)
− examples/ex25-io.alms 
@@ -1,41 +0,0 @@-(* 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
@@ -16,8 +16,8 @@      (* 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 =+    let acquireBang (r: ('t, 'c) ureadcap_rep ref) =+      let rec loop () =         match r <- CheckedOut with         | Available c -> c         | CheckedOut  -> loop ()@@ -27,9 +27,9 @@     (* 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 letBang (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@@ -37,16 +37,15 @@         r <- Defunct;         (a, c) -    let applyBang['t,'c,`r]+    let applyBang              (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]+    let liftBang              (k: ('t, 'c) readcap -> `r * ('t, 'c) readcap)              (MkCap r: ('t, 'c) ureadcap)              : `r =@@ -54,11 +53,11 @@         r <- Available c;         result -    let getAU['a,'t,'c] (a: ('a, 't) array) (ix: int) =-      liftBang (get['a,'t,'c] a ix)+    let getAU (a: ('a, 't) array) (ix: int) =+      liftBang (get 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+    let putAU (a: ('a, 't) array) (ix: int) (new: 'a) =+      let f (cap: 't writecap) = ((), set a ix new cap) in         liftBang f   end end@@ -67,7 +66,7 @@  let test () =   let n = 10 in-  let Pack('t, a, cap) = new[int] n 0 in+  let (a, cap) = new n 0 in     let rec loop (i: int) (cap: 't writecap): 't writecap =       if i >= n         then cap
examples/ex27-focusing-and-adoption.alms view
@@ -12,74 +12,60 @@     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[[ { 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) |[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) |[a] (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 snoc x xs = append xs [x] -let rev[`a] (xs: `a list) : `a list =-  let (_, acc) = revAppN (-1) xs Nil[`a] -   in acc+let rec revAppN n xs acc =+    match n with+    | 0 → (acc, xs)+    | _ → match xs with+           | x ∷ xs → revAppN (n - 1) xs (x ∷ acc)+           | xs     → (acc, xs) -let swapN[`a] (ix: int) (y: `a) |[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)+let swapN ix y xs =+  let (x ∷ xs, acc) = revAppN ix xs [] in+    (x, revApp acc (y ∷ xs)) -module Region : sig-  type ('t, `a) region : A+module type REGION = sig+  type ('t, `a) region  : A   type ('t, `a) region1 : A   type 't ptr -  val newRgn    : unit -> ex 't. ('t,`a) region-  val mallocIn  : ('t,`a) region -> `a -o 't ptr * ('t,`a) region-  val swap      : ('t,`a) region -> 't ptr -o `a -o `a * ('t,`a) region-  val malloc    : unit -> ex 't. ('t,unit) region1 * 't ptr-  val free      : ('t,`a) region1 -> unit-  val adopt     : ('t1,`a) region -> ('t2,`a) region1 -o 't2 ptr -o+  val newRgn    : unit → ∃ 't. ('t,`a) region+  val mallocIn  : ('t,`a) region → `a -A> 't ptr * ('t,`a) region+  val swap      : ('t,`a) region → 't ptr -A> `a -A> `a * ('t,`a) region+  val malloc    : unit → ∃ 't. ('t,unit) region1 * 't ptr+  val free      : ('t,`a) region1 → unit+  val adopt     : ('t1,`a) region → ('t2,`a) region1 -A> 't2 ptr -A>                   't1 ptr * ('t1,`a) region-  val focus     : ('t,`a) region -> 't ptr -o-                  ex 't1. ('t1,`a) region1 * 't1 ptr *-                          (('t1,`a) region1 -o ('t,`a) region)-end = struct+  val focus     : ('t,`a) region → 't ptr -A>+                  ∃ 't1. ('t1,`a) region1 * 't1 ptr *+                          (('t1,`a) region1 -A> ('t,`a) region)+end++module Region : REGION = struct   type ('t, `a) region = `a list   type ('t, `a) region1 = `a   type 't ptr = int -  let newRgn () = Nil+  let newRgn () = [] : ∃ 't. ('t,`a) region    let freeRgn _ = ()    let mallocIn (xs: `a list) (a: `a) =-    let (ix, xs) = length xs in+    let (ix, xs) = lengthA xs in       (ix, snoc a xs)    let swap (xs: `a list) (ix: 't ptr) (x: `a) =     let (y, xs) = swapN ix x xs in       (y, xs) -  let malloc () = ((), 0)+  let malloc () = ((), 0) : ∃ 't. ('t,unit) region1 * 't ptr    let swap1 (x: `a) _ (y: `b) = (x, y) @@ -88,7 +74,10 @@   let adopt (rgn: `a list) (x: `a) _ =     mallocIn rgn x -  let focus (xs: `a list) (ix: 't ptr) =-     let (Cons (x, xs), acc) = revAppN ix xs Nil in-       (x, 0, fun (y: `a) -> fst (revAppN (-1) acc (Cons (y, xs))))+  let focus xs ix+        : ∃ 't1. ('t1,`a) region1 * 't1 ptr *+                 (('t1,`a) region1 -A> ('t,`a) region)+        =+     let (x ∷ xs, acc) = revAppN ix xs [] in+       (x, 0, λ y → revApp acc (y ∷ xs)) end
examples/ex28-focusing-and-adoption.alms view
@@ -6,75 +6,58 @@     '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) |[a] (xs: `a list) : `a list =-  foldr (fun (x: `a) (xs: `a list) -> Cons (x, xs))-        (Cons (x, Nil[`a])) xs+let snoc x xs = append xs [x] -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 rec revAppN n xs acc =+    match n with+    | 0 → (acc, xs)+    | _ → match xs with+           | x ∷ xs → revAppN (n - 1) xs (x ∷ acc)+           | xs     → (acc, xs) -let swapN[`a] (ix: int) (y: `a) |[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)+let swapN ix y xs =+  let (x ∷ xs, acc) = revAppN ix xs [] in+    (x, revApp acc (y ∷ 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+abstype 't tr            = Tr+    and ('t, `a) cap : A = Cap of `a * (unit -A> unit) list+    and ('t, `a) guarded =+                    Guarded of (`a * (unit -A> 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 new (x: `a) : ∃ 't. ('t, `a) cap * 't tr =+    (Cap (x, []), Tr) -  let adoptByThen[`a,'ta,`b,'tb]-      ((Cap adoptee, _)                : ('ta, `a) cap * 'ta tr) |+  let swap ((Cap (x, fs), _) : ('t, `a) cap * 't tr) (y : `b)+    : ('t, `b) cap * `a =+    (Cap (y, fs), x)++  let free (Cap (_, fs)) = map (λ f → f ()) fs; ()++  let adoptByThen+      ((Cap adoptee, _)                : ('ta, `a) cap * 'ta tr)       ((Cap (adoptor, destructors), _) : ('tb, `b) cap * 'tb tr)-      (destroy                         : ('ta, `a) cap -o unit)+      (destroy                         : ('ta, `a) cap -A> 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) |+               | None   → failwith "Can't happen"+               | Some c → destroy (Cap c) in+      (Cap (adoptor, g ∷ destructors), Guarded r)+  let adoptBy+      (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) -> ())+      = adoptByThen adoptee adoptor (λ (_: ('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))+  let focusIn+      ((guard, Guarded r) : ('t, `a) cap * ('t, `b) guarded)+      (body               : (∀ 's. ('s, `b) cap * 's tr -A>+                                   ('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])+      | None   → failwith "Can't happen"+      | Some c →+          let (Cap c, result) = body (Cap c, Tr)            in r <- Some c;               (guard, result) end
examples/ex33-session-types.alms view
@@ -7,25 +7,21 @@  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 server c =+  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 client c x y =+  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+let main x y =+  let rv : protocol rendezvous = newRendezvous () in+    AThread.fork (λ _ → server (accept rv));+    client (request rv) x y  in print (main 3 4)
examples/ex34-session-types.alms view
@@ -9,8 +9,7 @@                    |+|                    !'a; ?'a; 1 -let server =-  fun c : int protocol dual channel ->+let server (c : int protocol dual channel) =     match follow c with     | Left c ->         let (x, c) = recv c in@@ -22,19 +21,16 @@           send c (0 - x);           () -let client =-  fun c : int protocol channel ->-    fun (x : int) (y : int) ->+let client c x y =       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+let main x y =+  let rv = newRendezvous () 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
@@ -9,8 +9,8 @@                    |+|                    !'a; ?'a; 1 -let server =-  fun c : int protocol dual channel ->+(* reuses channel *)+let server (c : int protocol dual channel) =     match follow c with     | Left c ->         let (x, _) = recv c in@@ -22,19 +22,16 @@           send c (0 - x);           () -let client =-  fun c : int protocol channel ->-    fun (x : int) (y : int) ->+let client c x y =       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+let main x y =+  let rv = newRendezvous () 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
@@ -6,35 +6,32 @@ open SessionType  type 'a protocol = !'a; !'a; ?'a; 1-                    |+|+                   |+|                    !'a; ?'a; 1 -let server =-  fun c : int protocol dual channel ->+(* switched branches *)+let server (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);           ()+    | Left c ->+        let (x, c) = recv c in+          send c (0 - x);+          () -let client =-  fun c : int protocol channel ->-    fun (x : int) (y : int) ->+let client c x y =       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+let main x y =+  let rv = newRendezvous () 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
@@ -6,11 +6,10 @@ open SessionType  type 'a protocol = !'a; !'a; ?'a; 1-                       |+|+                   |+|                    !'a; ?'a; 1 -let server =-  fun c : int protocol dual channel ->+let server (c : int protocol dual channel) =     match follow c with     | Left c ->         let (x, c) = recv c in@@ -22,19 +21,17 @@           send c (0 - x);           () -let client =-  fun c : int protocol channel ->-    fun (x : int) (y : int) ->+(* sends string where int expected *)+let client c x y =       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+let main x y =+  let rv = newRendezvous () 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
@@ -9,8 +9,7 @@                    |+|                    !'a; ?'a; 1 -let server =-  fun c : int protocol dual channel ->+let server (c : int protocol dual channel) =     match follow c with     | Left c ->         let (x, c) = recv c in@@ -22,19 +21,17 @@           send c (0 - x);           () -let client =-  fun c : int protocol channel ->-    fun (x : int) (y : int) ->+(* swaps receive and send *)+let client c x y =       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+let main x y =+  let rv = newRendezvous () in+    AThread.fork (fun () -> server (accept rv));+    client (request rv) x y  in print (main 3 4)
examples/ex50-signatures.alms view
@@ -1,4 +1,4 @@-(* Signature tests -- should print type error *)+(* Signature tests *)  module type S = sig   type t
examples/ex53-signatures.alms view
@@ -4,7 +4,7 @@   type `a t qualifier a end = struct   type `a t = unit-  let f[`b] (x: `b t) = (x, x)+  let f (x: `b t) = (x, x) end -let f['b] (x: 'b A.t) = (x, x)+let f (x: 'b A.t) = (x, x)
examples/ex54-signatures-type-error.alms view
@@ -4,7 +4,7 @@   type `a t qualifier a end = struct   type `a t = unit-  let f[`b] (x: `b t) = (x, x)+  let f (x: `b t) = (x, x) end -let f[`b] (x: `b A.t) = (x, x)+let f (x: unit aref A.t) = (x, x)
examples/ex55-signatures-type-error.alms view
@@ -1,7 +1,7 @@ (* Signature tests -- should print type error *)  module A : sig-  type `a t+  type `a t             (* qualifier is U *) end = struct-  type `a t = `a+  type `a t = `a        (* qualifier is A *) end
examples/ex56-signatures-type-error.alms view
@@ -1,7 +1,7 @@ (* Signature tests -- should print type error *)  module A : sig-  type -`a t qualifier a+  type +`a t end = struct-  type `a t = `a+  type `a t = `a → `a end
+ examples/ex58-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 → unit+end
examples/ex61-popl-AfArray.alms view
@@ -38,14 +38,14 @@ module A = AfArray  (* Swap the values at the given array indices *)-let swapIndices (a: 'a A.array) (i: int) (j: int) =+let swapIndices a i j =   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 =+let inPlaceShuffle a =+  let rec loop i a =     if i == 0       then a       else let j = random_int () % (i + 1) in@@ -54,12 +54,11 @@     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 =+let inPlaceSort a =+  let rec quicksort start limit a =     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 =+           let rec loop i j a =              if i < limit                then let (ai, a) = A.get a i in                       if ai ≤ pivot@@ -75,27 +74,26 @@     quicksort 0 (n - 1) a  (* For testing: *)-let listToArray (Cons(x,xs): 'a list) =+let listToArray (x ∷ xs) =   let n = length xs + 1 in-  let rec loop (i: int) (xs: 'a list) (a: 'a A.array) : 'a A.array =+  let rec loop i xs a =     match xs with-    | Nil        → a-    | Cons(x,xs) → loop (i + 1) xs (A.set a i x)+    | []     → a+    | 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 arrayToList a =   let (n, a) = A.size a in-  let rec loop (i: int) (xs: 'a list) (a: 'a A.array)-            : 'a list * 'a A.array =+  let rec loop i xs a =         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+                 loop (i - 1) (ai ∷ xs) a+   in loop (n - 1) [] 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 unsorted  = [4, 1, 0, 3, 2]+  let sorted    = [0, 1, 2, 3, 4]   let sorted'   = fst(arrayToList(inPlaceSort(listToArray(unsorted))))   let () = if sorted == sorted'              then ()
examples/ex63-popl-CapArray.alms view
@@ -19,7 +19,8 @@   type ('a,'b) array = 'a A.array   type 'a cap = unit -  let new (size: int) (init: 'a) = (A.new size init, ())+  let new (size: int) (init: 'a) : ∃'b. ('a,'b) array × 'b cap =+    (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) _ =@@ -64,33 +65,33 @@     (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 listToArray (x ∷ xs) =+  let n        = length xs + 1 in+  let (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)+    | []     → cap+    | x ∷ xs → loop (i + 1) xs (A.set a i x cap)+   in (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+          else loop (i - 1) (A.dirtyGet a i ∷ xs)+   in loop (n - 1) []  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+      else loop (random_int () ∷ acc) (len - 1)+   in loop []  module Tests = struct   let test (size: int) =-    let ('b, a, cap)  = listToArray (randomIntList size) in+    let (a, cap)      = listToArray (randomIntList size) in     let correctsum    = dirtySumArray a in     let (_, dirtysum) = shuffleAndDirtySum a cap      in if correctsum == dirtysum
examples/ex64-popl-CapLockArray.alms view
@@ -18,14 +18,14 @@   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+    let (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 (a : ('a,'b) array) = 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)
examples/ex65-popl-Fractional.alms view
@@ -28,7 +28,8 @@   type 'c / 'd   type ('b,'c) cap = unit -  let new (size: int) (init: 'a) = (A.new size init, ())+  let new (size: int) (init: 'a) : ∃'b. ('a,'b) array × ('b,1) cap =+    (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) _ =
examples/ex66-popl-RWLock.alms view
@@ -45,9 +45,9 @@   type write   type 'β@'γ = unit -  let new (size: int) (init: 'α) =+  let new (size: int) (init: 'α) : ∃'β. ('α, 'β) array =     (A.new size init, MVar.new ((Queue.empty : queue), 0))-  let build (size: int) (builder: int → 'α) =+  let build (size: int) (builder: int → 'α) : ∃'β. ('α, 'β) array =     (A.build size builder, MVar.new ((Queue.empty : queue), 0))    (* To see what's happening, uncomment the rest of show. *)@@ -95,7 +95,7 @@   let acquireR ((rep, lock) : ('α,'t) array) =     let (q, count) = MVar.take lock in     show "acquireR" (q, count);-    let wait = MVar.newEmpty[unit] () in+    let wait = MVar.newEmpty () in       MVar.put lock (Queue.enqueue (Left wait) q, count);       wake lock;       MVar.take wait@@ -104,7 +104,7 @@   let acquireW ((rep, lock) : ('α,'β) array) =     let (q, count) = MVar.take lock in     show "acquireW" (q, count);-    let wait = MVar.newEmpty[unit] () in+    let wait = MVar.newEmpty () in       MVar.put lock (Queue.enqueue (Right wait) q, count);       wake lock;       MVar.take wait@@ -179,18 +179,18 @@           else ())    let go (iters: int) =-    let next   = makeCounter () in-    let ('β,a) = build 10 (fun x:int → x) in-    let rec start (n: int) : U Future.future list =+    let next = makeCounter () in+    let a    = build 10 (fun x → x) in+    let rec start (n: int) =       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 =+        then []+        else (if random_int () % 8 == 0+                then writer (next ()) a+                else reader (next ()) a)+             ∷ start (n - 1) in+    let rec stop fs =       match fs with-      | Nil         → ()-      | Cons(f, fs) → Future.sync f; stop fs in+      | []     → ()+      | f ∷ fs → Future.sync f; stop fs in     stop (start iters) end
examples/futures1.alms view
@@ -2,26 +2,22 @@  #load "libthread" -let prompt : unit -> string Future.future =-  fun _:unit -> Future.new getLine+let prompt () = 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 rec printDots count delay =+  if count <= 0+    then ()+    else+      putStr ".";+      flush ();+      AThread.delay (1000 * delay);+      printDots (count - 1) delay -let main : string -> unit =-  fun message: string ->-    putStrLn message;-    let future = prompt () in-      printDots 80 20;-      putStrLn "";-      putStrLn (Future.sync future)+let main message =+  putStrLn message;+  let future = prompt () in+    printDots 80 20;+    putStrLn "";+    putStrLn (Future.sync future)  in main "whadday say? "
examples/netcat.alms view
@@ -5,7 +5,7 @@ local   open IO with-  let rec sendThread (sock: socket): unit =+  let rec sendThread sock =     if hIsEOF stdin       then         shutdown sock ShutdownSend@@ -14,39 +14,37 @@           send sock (getLine () ^ "\r\n");           sendThread sock         with-          IOError _ -> ()+          IOError _ → () -  let rec recvThread (sock: socket): unit =+  let rec recvThread sock =     try-      putStr (recv sock 1024); recvThread sock+      putStr (recv sock 1024);+      recvThread sock     with-      IOError _ -> ()+      IOError _ → () end -let setupConnection (addr: sockAddr): socket =+let setupConnection addr =   let s = socket AF_INET Stream defaultProtocol in     connect s addr;     s -let teardownConnection (sock: socket): unit =-  close sock--let getAddr (): sockAddr =+let getAddr () =   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")+  | [host, port]+      → let info = AddrInfo([], AF_INET,+                            Stream, defaultProtocol,+                            SockAddrInet(PortNum 0, 0), None) in+        (match getAddrInfo (Some info) (Some host) (Some port) with+         | 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+  let wait = Future.new (λ () → recvThread sock) in     sendThread sock;     Future.sync wait;-    teardownConnection sock+    close sock  in main ()
examples/session-types-interactive.alms view
@@ -10,20 +10,18 @@ type protocol = ?int; 1 |+| !int; protocol  let server =-  let rec loop (acc : int)-               (c   : protocol dual channel)-               : unit =+  let rec loop acc (c : protocol dual channel) =       match follow c with-      | Left c ->+      | Left c →           send c acc;           ()-      | Right c ->+      | 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 rec loop (c : protocol channel) =     let s = getLine () in       if s == ""                 then@@ -36,11 +34,10 @@             loop c    in loop -let main =-  fun _ : unit ->-    let rv = newRendezvous[protocol] () in-      AThread.fork (fun _:unit -> server (accept rv));-      client (request rv)+let main () =+  let rv : protocol rendezvous = newRendezvous () in+    AThread.fork (λ () -> server (accept rv));+    client (request rv)  in print (main ())
examples/session-types-polygons.alms view
@@ -5,43 +5,41 @@  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+type point = { x, y, z : float }+type plane = [ `Plane of float * float * float * float ] --- We use the plane Plane(a, b, c, d) to represent the open half-space+-- 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_point p =+    "(" ^ string_of p.x ^ ", " ^ string_of p.y ^ ", " ^ string_of p.z ^ ")" -let string_of_plane (Plane(a, b, c, d): plane) =+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 splitWhile : ('a -> bool) -> 'a list -> 'a list * 'a list+  = fun pred ->       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'+                | []         -> (rev acc, [])+                | (x ∷ xs') -> if pred x+                                   then loop (x ∷ acc) xs'                                    else (rev acc, xs)-       in loop Nil['a]+       in loop []  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 notp (pred: 'a -> bool): 'a -> bool =+  fun a -> not (pred a) -let isSpace (c: int): bool =+let isSpace (c: char): bool =   match c with   | ' '  -> true   | '\t' -> true@@ -49,65 +47,48 @@   | '\r' -> true   | _    -> false -let dropSpace (cs : int list) : int list =+let dropSpace (cs : char list) : char 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 foil (x: char 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 ('(' ∷ cs) = dropSpace cs in+    let (x, (_ ∷ cs)) = splitWhile (notp ((==) ',')) (dropSpace cs) in+    let (y, (_ ∷ cs)) = splitWhile (notp ((==) ',')) (dropSpace cs) in+    let (z, (_ ∷ cs)) = splitWhile (notp ((==) ')')) (dropSpace cs) in+      { x = foil x, y = foil y, z = foil z }  let parsePlane (s: string) : plane =-  let foil (x: int list) = float_of_string (implode x) in+  let foil (x: char 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)+    let (a, (_ ∷ cs)) = splitWhile (notp ((==) 'x')) (dropSpace cs) in+    let ('+' ∷ cs)    = dropSpace cs in+    let (b, (_ ∷ cs)) = splitWhile (notp ((==) 'y')) (dropSpace cs) in+    let ('+' ∷ cs)    = dropSpace cs in+    let (c, (_ ∷ cs)) = splitWhile (notp ((==) 'z')) (dropSpace cs) in+    let ('+' ∷ cs)    = dropSpace cs in+    let (d, (_ ∷ cs)) = splitWhile (notp ((==) '>')) (dropSpace cs) in+    let ('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 =+let isPointAbovePlane { x, y, z } (`Plane(a, b, c, d)) =   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 =+let intersect p1 p2 (`Plane(a, b, c, d) as plane) =  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+   then None+   else let t = (a *. p1.x +. b *. p1.y +. c *. p1.z +. d) /.+                (a *. (p1.x -. p2.x) +.+                 b *. (p1.y -. p2.y) +.+                 c *. (p1.z -. p2.z)) in+        let x = p1.x +. (p2.x -. p1.x) *. t in+        let y = p1.y +. (p2.y -. p1.y) *. t in+        let z = p1.z +. (p2.z -. p1.z) *. t in+          Some { x, y, z }  -- -- In sublanguage A, our protocol is to send an unbounded@@ -123,7 +104,7 @@ --  let clipper (plane: plane)-               (ic: point stream channel)|+               (ic: point stream channel)                (oc: point stream dual channel): unit =        let finish (oc: point stream dual channel) =              sel1 oc; () in@@ -143,7 +124,7 @@          | Left _   -> finish oc          | Right ic ->              let (pt0, ic) = recv ic in-             let rec loop (ic: point stream channel)|+             let rec loop (ic: point stream channel)                           (oc: point stream dual channel)                           (pt: point) : unit =                        let oc = putVisible oc pt in@@ -189,21 +170,21 @@             match follow ic with             | Left ic  -> (rev acc, ic)             | Right ic -> let (plane, ic) = recv ic in-                            get_planes (Cons(plane,acc)) ic in+                            get_planes (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+            | []              -> ic+            | plane ∷ rest ->+                let outrv : point stream rendezvous = newRendezvous () in                   AThread.fork (fun () ->                     clipper plane ic (accept outrv));                   connect rest (request outrv) in   fun () ->-    let rv           = newRendezvous[main_prot] () in+    let rv           = newRendezvous () : main_prot rendezvous in     let _            = AThread.fork (fun () -> parser (accept rv)) in-    let (planes, ic) = get_planes Nil[plane] (request rv) in+    let (planes, ic) = get_planes [] (request rv) in     let ic           = connect planes ic in       printer ic
examples/session-types-polygons2.alms view
@@ -5,9 +5,6 @@  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: --@@ -19,26 +16,26 @@ -- 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) =+let string_of_point (Point(x, y, z)) =     "(" ^ string_of x ^ ", " ^ string_of y ^ ", " ^ string_of z ^ ")" -let string_of_plane (Plane(a, b, c, d): plane) =+let string_of_plane (Plane(a, b, c, d)) =     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 splitWhile : ('a -> bool) -> 'a list -> 'a list * 'a list+  = fun pred ->       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]+                | []     -> (rev acc, [])+                | x ∷ xs' -> if pred x+                               then loop (x ∷ acc) xs'+                               else (rev acc, xs)+       in loop [] -let notp['a] (pred: 'a -> bool) (x: 'a) = not (pred x)+let notp (pred: 'a -> bool) (x: 'a) = not (pred x) -let isSpace (c: int): bool =+let isSpace c =   match c with   | ' '  -> true   | '\t' -> true@@ -46,29 +43,28 @@   | '\r' -> true   | _    -> false -let dropSpace (cs : int list) : int list =-  let (_, result) = splitWhile isSpace cs in result+let dropSpace cs = snd (splitWhile isSpace cs)  let parsePoint (s : string) : point =-  let foil (x: int list) = float_of_string (implode x) in+  let foil (x: char 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+    let '(' ∷ cs = dropSpace cs in+    let (x, _ ∷ cs) = splitWhile (notp ((==) ',')) (dropSpace cs) in+    let (y, _ ∷ cs) = splitWhile (notp ((==) ',')) (dropSpace cs) in+    let (z, _ ∷ 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 foil (x: char 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+    let (a, _ ∷ cs) = splitWhile (notp ((==) 'x')) (dropSpace cs) in+    let '+' ∷ cs    = dropSpace cs in+    let (b, _ ∷ cs) = splitWhile (notp ((==) 'y')) (dropSpace cs) in+    let '+' ∷ cs    = dropSpace cs in+    let (c, _ ∷ cs) = splitWhile (notp ((==) 'z')) (dropSpace cs) in+    let '+' ∷ cs    = dropSpace cs in+    let (d, _ ∷ cs) = splitWhile (notp ((==) '>')) (dropSpace cs) in+    let '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)@@ -79,10 +75,10 @@ -- 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 =+              (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]+   then None    else let t = (a *. x1 +. b *. y1 +. c *. z1 +. d) /.                 (a *. (x1 -. x2) +.                  b *. (y1 -. y2) +.@@ -93,20 +89,6 @@           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: --@@ -121,44 +103,38 @@ -- 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 clipper plane+            !(ic: point stream channel, oc: point stream dual channel) =+  let finish () =+    choose Done oc in+  let put pt =+    choose Next oc;+    send pt oc in+  let putCross p1 p2 =+    match intersect p1 p2 plane with+    | Some pt -> put pt+    | None    -> () in+  let putVisible pt =+    if isPointAbovePlane pt plane+      then put pt+      else ()+   in follow ic;+      match ic with+      | Done ic -> finish ()+      | Next ic ->+        let pt0 = recv ic in+        let rec loop pt =+          putVisible pt;+          follow ic;+          match ic with+          | Done ic -> putCross pt pt0;+                       finish ()+          | Next ic -> let pt' = recv ic in+                       putCross pt pt';+                       loop pt'+         in loop pt0 -let rec printer !(ic: point stream channel): unit * 1 channel =+let rec printer !(ic: point stream channel) =   follow ic;   match ic with   | Done ic -> ()@@ -171,43 +147,42 @@     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 =+let parser (!oc: main_prot dual channel) =+  let rec plane_loop () =             match getLine () with             | "" -> choose Points oc;-                    point_loop oc+                    point_loop ()             | s  -> choose Planes oc;                     send (parsePlane s) oc;-                    plane_loop oc-      and point_loop !(oc: point stream dual channel): unit * 1 channel =+                    plane_loop ()+      and point_loop () =             match getLine () with-            | "" -> choose Done[point] oc-            | s  -> choose Next[point] oc;+            | "" -> choose Done oc+            | s  -> choose Next oc;                     send (parsePoint s) oc;-                    point_loop oc-   in plane_loop+                    point_loop ()+   in plane_loop ()  let main =-  let rec get_planes (acc: plane list) !(ic: main_prot channel)-                     : plane list * point stream channel =+  let rec get_planes (acc: plane list) !(ic: main_prot channel) =             follow ic;             match ic with             | Points ic -> rev acc-            | Planes ic -> get_planes (Cons(recv ic,acc)) ic in+            | Planes ic -> get_planes (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+            | []              -> ic+            | plane ∷ rest ->+                let outrv = newRendezvous () in                   AThread.fork                     (fun () -> clipper plane (ic, accept outrv); ());                   connect rest (request outrv) in   fun () ->-    let rv           = newRendezvous[main_prot] () in+    let rv           = newRendezvous () in     let _            = AThread.fork (fun () -> parser (accept rv); ()) in-    let (planes, ic) = get_planes Nil[plane] (request rv) in+    let (planes, ic) = get_planes [] (request rv) in     let ic           = connect planes ic in       printer ic
examples/skewness-dynamic-bad.alms view
@@ -1,4 +1,4 @@-(* Demonstrates (affine) abstract types.  Correct. *)+(* Demonstrates (affine) abstract types. Blame error. *)  (*     This program demonstrats how a dynamic promotion is prevented from@@ -12,104 +12,101 @@ open AArray  module SkewnessExample = struct-  let sum ['t,'c] (a: (float, 't) array) (c: ('t, 'c) readcap) =+  let sum (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 mean (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 stdDev (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 skewness (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)+                         (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 reduceSkewness (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+        then let (x, c) = get a i c in+             let c      = set 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+    (* Need type annotation for polymorphic recursion: *)+    let rec find :+        ∀ 'd. int → transformation list → ('t, 'd) readcap →+              float * transformation * ('t, 'd) readcap =+      λ ix ts c →+        match ts with+        | []  -> let (sk, c) = skewness a c in+                   (sk, T("identity", fun f -> f), c)+        | (T(_, ft) as t) ∷ ts+              -> let ((sk1, t1), (sk2, t2), c) =+                   par+                     (fun (c: ('t, 'c) readcap) -> find (ix + 1) ts c)+                     (fun (c: ('t, 'c) readcap) ->+                       let ((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+                     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 =+  +  let newDistribution (n: int) (T(_, gen): transformation)+                         : ex 't. (float, 't) array * 't writecap =+    let (a, c) = new n 0.0 in+      let rec loop (i: int) c =         if i < n-          then loop (i + 1) (update a i (gen (float_of_int (i + 1))) c)+          then loop (i + 1) (set 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)-+        (a, loop 0 c)+     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-+    [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))+    ]+     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 (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)
examples/skewness-good.alms view
@@ -13,14 +13,14 @@ open AArray  module SkewnessExample = struct-  let sum ['t,'c] (a: (float, 't) array) (c: ('t, 'c) readcap) =+  let sum (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 mean (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 stdDev (a: (float, 't) array) (c: ('t, 'c) readcap) =     let (mean, c) = mean a c in     let (num, c)  = fold                       (fun (x: float) (acc: float) ->@@ -28,7 +28,7 @@                       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 skewness (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@@ -40,67 +40,65 @@      type transformation = T of string * (float -> float)   -  let reduceSkewness ['t]-                         (ts: transformation list)-                         (a: (float, 't) array)-                         (c0: 't writecap) =+  let reduceSkewness (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+        then let (x, c) = get a i c in+             let c      = set 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+    (* Need type annotation for polymorphic recursion: *)+    let rec find :+        ∀ 'd. int → transformation list → ('t, 'd) readcap →+              float * transformation * ('t, 'd) readcap =+      λ ix ts c →+        match ts with+        | []  -> let (sk, c) = skewness a c in+                   (sk, T("identity", fun f -> f), c)+        | (T(_, ft) as t) ∷ ts+              -> let ((sk1, t1), (sk2, t2), c) =+                   par+                     (fun (c: ('t, 'c) readcap) -> find (ix + 1) ts c)+                     (fun (c: ('t, 'c) readcap) ->+                       let ((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 =+    let (a, c) = new n 0.0 in+      let rec loop (i: int) c =         if i < n-          then loop (i + 1) (update a i (gen (float_of_int (i + 1))) c)+          then loop (i + 1) (set 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)+        (a, loop 0 c)      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+    [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))+    ]      let testCase (n: int) (T(name, _) as t: transformation) =-    let Pack('t, a, c)       = newDistribution n t in+    let (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);
examples/skewness-static-bad.alms view
@@ -10,21 +10,22 @@ open AArray  module SkewnessExample = struct-  let sum ['t,'c] (a: (float, 't) array) (c: ('t, 'c) readcap) =+  let sum (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 mean (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 stdDev (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)+                      (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 skewness (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@@ -36,67 +37,65 @@      type transformation = T of string * (float -> float)   -  let reduceSkewness ['t]-                      (ts: transformation list)-                      (a: (float, 't) array)-                      (c0: 't writecap) =+  let reduceSkewness (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+        then let (x, c) = get a i c in+             let c      = set 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+    (* Need type annotation for polymorphic recursion: *)+    let rec find :+        ∀ 'd. int → transformation list → ('t, 'd) readcap →+              float * transformation * ('t, 'd) readcap =+      λ ix ts c →+        match ts with+        | []  -> let (sk, c) = skewness a c in+                   (sk, T("identity", fun f -> f), c)+        | (T(_, ft) as t) ∷ ts+              -> let ((sk1, t1), (sk2, t2), c) =+                   par+                     (fun (c: ('t, 'c) readcap) -> find (ix + 1) ts c)+                     (fun (c: ('t, 'c) readcap) ->+                       let ((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+    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 =+  let newDistribution (n: int) (T(_, gen): transformation)+                         : ex 't. (float, 't) array * 't writecap =+    let (a, c) = new n 0.0 in+      let rec loop (i: int) c =         if i < n-          then loop (i + 1) (update a i (gen (float_of_int (i + 1))) c)+          then loop (i + 1) (set 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)+        (a, loop 0 c)      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+    [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))+    ]      let testCase (n: int) (T(name, _) as t: transformation) =-    let Pack('t, a, c)       = newDistribution n t in+    let (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);@@ -104,7 +103,7 @@       putStrLn ("Improved skewness: " ^ string_of sk);       putStrLn ("Winning function:  " ^ name');       putStrLn ""-+     let tests (n: int) =     foldl (fun (t: transformation) () -> testCase n t)           () (functions n)
examples/threads1.alms view
@@ -1,17 +1,14 @@ (* An example with threads. *) -let printer : unit -> unit =-  let rec loop (_ : unit) : unit =-    Thread.delay 100000;-    putStr "x";-    flush ();-    loop ()-  in loop+let rec printer () =+  Thread.delay 100000;+  putStr "x";+  flush ();+  printer () -let timer : unit -> unit =-  fun _: unit ->-    let id = Thread.fork printer in-      Thread.delay 2000000;-      Thread.kill id+let timer () =+  let id = Thread.fork printer in+    Thread.delay 2000000;+    Thread.kill id  in timer ()
examples/threads2.alms view
@@ -1,25 +1,20 @@ (* Another example with threads. *) -let printer : unit -> unit =-  let rec loop (_ : unit) : unit =-    Thread.delay 100000;-    putStr "x";-    flush ();-    loop ()-  in loop+let rec printer () =+  Thread.delay 100000;+  putStr "x";+  flush ();+  printer () -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 startStop () =+  let id = Thread.fork printer in+  let id = Thread.print id in+    λ () → Thread.kill id -let timer : unit -> unit =-  fun _: unit ->-    let stop = startStop () in-      Thread.delay 2000000;-      stop ()+let timer () =+  let stop = startStop () in+    Thread.delay 2000000;+    stop ()  in timer ()
examples/threads3.alms view
@@ -1,32 +1,27 @@ (* 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+#load "libthread" -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 rec printer () =+  AThread.delay 100000;+  putStr "x";+  flush ();+  printer () -let after : int -> (unit -o unit) -> unit =-  fun delay: int ->-    fun stop: (unit -o unit) ->-      Thread.fork (fun _:unit  -> Thread.delay delay; stop ());-      ()+let startStop () =+  let id = AThread.fork printer in+  let id = AThread.print id in+    λ _ → AThread.kill id -let main : unit -> unit =-  fun _: unit ->-    let stop = startStop () in-      after 2000000 stop;-      getLine ();-      stop ()    (* stop used twice! *)+let after delay stop =+  AThread.fork (λ _ → AThread.delay delay; stop ());+  ()++let main () =+  let stop = startStop () in+    after 2000000 stop;+    getLine ();+    stop ()    (* stop used twice! *)  in main ()
examples/threads4.alms view
@@ -13,33 +13,26 @@  #load "libthread" -let printer : unit -> unit =-  let rec loop (_ : unit) : unit =-    AThread.delay 100000;-    putStr "x";-    flush ();-    loop ()-  in loop+let rec printer () =+  AThread.delay 100000;+  putStr "x";+  flush ();+  printer () -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 startStop () =+  let id = AThread.fork printer in+  let id = AThread.print id in+    (λ _ → 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 after delay stop =+  AThread.fork (λ _ → AThread.delay delay; stop ());+  () -let main : unit -> unit =-  fun _: unit ->-    putStrLn "Press <ENTER> to exit.";-    let stop = startStop () in-      after 4000000 stop;-      getLine ();-      stop ()+let main () =+  let stop = startStop () in+    after 2000000 stop;+    getLine ();+    stop ()    (* stop used twice! *)  in main ()
lib/libachan.alms view
@@ -20,46 +20,46 @@    type 'a achan = 'a repr M.mvar -  let new['a] () = M.new (Writers Q.empty['a])+  let new () = M.new (Writers Q.empty) -  let recv['a] (mv : 'a achan) =+  let recv (mv : 'a achan) =     let wait (readers : 'a mvar queue) =-      let reader = M.newEmpty['a] () in+      let reader = M.newEmpty () in         (Readers (Q.enqueue reader readers),          fun () -> M.take reader) in-    M.modify mv (fun repr : 'a repr ->+    M.modify mv (fun repr ->       match repr with       | Readers readers -> wait readers       | Writers writers ->           match Q.dequeueA writers with-          | None          -> wait Q.empty['a mvar]+          | None          -> wait Q.empty           | Some (x, xs)  -> (Writers xs, fun () -> x))       () -  let send['a] (mv : 'a achan) (x : 'a) =-    M.modify_ mv (fun repr : 'a repr ->+  let send (mv : 'a achan) (x : 'a) =+    M.modify_ mv (fun 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])+          | None -> Writers (Q.enqueue x Q.empty)           | Some (reader, readers')                  -> M.put reader x;                     Readers readers') -  let tryRecv['a] (mv : 'a achan) =-    M.modify mv (fun repr : 'a repr ->+  let tryRecv (mv : 'a achan) =+    M.modify mv (fun repr ->       match repr with-      | Readers readers -> (repr, None['a])+      | Readers readers -> (repr, None)       | Writers writers ->           match Q.dequeueA writers with-          | None          -> (repr, None['a])+          | None          -> (repr, None)           | 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 ->+  let trySend (mv : 'a achan) (x : 'a) =+    M.modify mv (fun repr ->       match repr with       | Writers writers -> (repr, false)       | Readers readers ->@@ -69,7 +69,7 @@                  -> M.put reader x;                     (Readers readers', true)) -  let size['a] (mv : 'a achan) =+  let size (mv : 'a achan) =     match M.read mv with     | Writers writers -> Q.size writers     | Readers readers -> ~(Q.size readers)
lib/libarray.alms view
@@ -20,13 +20,13 @@   exception ArrayIndex   type `a array = `a Prim.Array.array -  let new['a] (size : int) (elt : 'a) =-    build size (fun (_: int) -> elt)+  let new (size : int) (elt : 'a) =+    build size (fun _ -> elt) -  let swap[`a] (a : `a array) (ix : int) (elt : `a) =+  let swap (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) =+  let set (a : `a array) (ix : int) (elt : `a) =     swap a ix elt; () end
lib/libarraycap.alms view
@@ -12,37 +12,37 @@   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 ->+  val new    : ∀ 'a. int → 'a → ∃ 't. ('a, 't) array * 't writecap+  val build  : ∀ 'a. int → (int → 'a) →+                 ∃ 't. ('a, 't) array * 't writecap+  val split  : ∀ '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 ->+  val join   : ∀ '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 ->+  val get    : ∀ '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+  val set    : ∀ 'a 't. ('a, 't) array → int → 'a →+                 't writecap → 't writecap+  val size   : ∀ '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 ->+  val par    : ∀ 't 'c `r1 `r2.+                 (∀ 'd. ('t, 'd) readcap → `r1 * ('t, 'd) readcap) →+                 (∀ '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]>+  val fold   : ∀ '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 map    : ∀ 'a 't 'c 'b.+                 ('a → 'b) → ('a, 't) array → ('t, 'c) readcap →+                 (∃ 's. ('b, 's) array * 's writecap) * ('t, 'c) readcap   val putArray-             : all 'a 't 'c. ('a, 't) array -> ('t, 'c) readcap ->+             : ∀ 'a 't 'c. ('a, 't) array → ('t, 'c) readcap →                  ('t, 'c) readcap end = struct   module A = Array@@ -55,43 +55,39 @@     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 new size x : ∃ 't. ('a, 't) array * 't writecap =+          (A.new size x, ()) -    let build['a] (size: int) (builder : int -> 'a) =-      Pack[ex 't. ('a, 't) array * unit]-          (unit, A.build['a] size builder, ())+    let build size builder : ∃ 't. ('a, 't) array * 't writecap =+          (A.build size builder, ()) -    let split['t,'c] () = ((), ())+    let split () = ((), ()) -    let join['t,'c] (_: unit * unit) = ()+    let join (_: unit * unit) = () -    let get['a,'t,'c] (arr: ('a, 't) array) (ix: int) () =+    let get (arr: ('a, 't) array) (ix: int) () =       (A.get arr ix, ()) -    let set['a,'t] (arr: ('a, 't) array) (ix: int) (new: 'a) () =+    let set (arr: ('a, 't) array) (ix: int) (new: 'a) () =       A.set arr ix new -    let size['a,'t] (arr: ('a, 't) array) =+    let size (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)+  let par (left:  ∀ 'd. ('t, 'd) readcap → `r1 * ('t, 'd) readcap)+          (right: ∀ '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 future   = Future.new (λ () → 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)+  let fold (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)+    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@@ -99,26 +95,25 @@         else (z, c)      in loop 0 z c -  let map ['a,'t,'c,'b]-          (f: 'a -> 'b)+  let map (f: 'a → 'b)           (a: ('a, 't) array) (c: ('t, 'c) readcap)-          : (ex 's. ('b, 's) array * 's writecap) * ('t, 'c) readcap =+          : (∃ '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 ->+                     | 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)+      | None   → failwith "can't happen"+      | Some c → (res, c) -  let putArray['a,'t,'c] (a: ('a, 't) array) (c: ('t, 'c) readcap) =+  let putArray (a: ('a, 't) array) (c: ('t, 'c) readcap) =     putStr "[";     let (_, c) =-      fold (fun (x: 'a) (comma: bool) ->+      fold (λ (x: 'a) (comma: bool) →               (if comma then putStr "," else ());               putStr (string_of x);               true)
lib/libbasis.alms view
@@ -1,4 +1,6 @@ module INTERNALS = struct+  module PrimTypes = INTERNALS.PrimTypes+   module Exn = struct     open Prim.Exn @@ -11,11 +13,11 @@     let failwith (msg: string) =       raise (Failure msg) -    let tryfun[`a] (thunk: unit -o `a) : exn + `a =+    let tryfun (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)+      | Right a        -> Right a+      | Left (Left e)  -> Left e+      | Left (Right s) -> Left (IOError s)      let raiseBlame (who: string) (what: string) =       raise (Blame (who, what))@@ -23,7 +25,8 @@    local     module INTERNALS = struct-      module Exn = Exn+      module Exn       = Exn+      module PrimTypes = PrimTypes     end   with     module Contract = struct@@ -32,50 +35,50 @@       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) ->+      let flat (pred: 'a -> bool) : 'a contract =+        λ (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) ->+      let flatA (pred: `a -> bool * `a) : `a contract =+        λ (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+      let any : `a contract =+        λ (_: 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)+      let func+               (dom: (`a1, `a2) coercion)+               (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))+        λ (neg: party, pos: party) (f: `a2 -[`q]> `b1) ->+          λ (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)+      let affunc (dom: (`a1, `a2) coercion)+                 (cod: (`b1, `b2) coercion)                 : (`a2 -o `b1, `a1 -> `b2) coercion =-        fun (neg: party, pos: party) (f: `a2 -o `b1) ->+        λ (neg: party, pos: party) (f: `a2 -o `b1) ->           let rf = ref (Some f) in-            fun (a: `a1) ->-              match rf <- None[`a2 -o `b1] with+            λ (a: `a1) ->+              match rf <- None 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)+      let unfunc (dom: (`a1, `a2) coercion)+                 (cod: (`b1, `b2) coercion)                 : (`a2 -> `b1, `a1 -> `b2) coercion =-        fun (neg: party, pos: party) (f: `a2 -> `b1) ->-          fun (x: `a1) ->+        λ (neg: party, pos: party) (f: `a2 -> `b1) ->+          λ (x: `a1) ->             let x' = dom (pos, neg) x in             let y  = try f x' with                      | Exn.Blame(p, "reused one-shot function")@@ -85,84 +88,113 @@   end end -let not (b: bool) = if b then false else true-let (!=)['a] (x: 'a) (y: 'a) = not (x == y)+module Function = struct+  let id x             = x+  let const _ x        = x+  let flip f y x       = f x y+  let curry f x y      = f (x, y)+  let uncurry f (x, y) = f x y+  let compose f g x    = f (g x)+  let ($) f x          = f x+end -let flip['a,'b,'c] (f: 'a -> 'b -> 'c) (y: 'b) (x: 'a) = f x y+open Function -let (<) (x: int) (y: int) = not (y <= x)-let (>) = flip (<)-let (>=) = flip (<=)-let (>.) = flip (<.)-let (>=.) = flip (<=.)+module Bool = struct+  let not (b: bool) = if b then false else true+  let (!=) (x: 'a) (y: 'a) = not (x == y)+end -type `a × `b = `a * `b-(* These have too-tight precedences *)-let (≠)  = (!=)-let (≤)  = (<=)-let (≥)  = (>=)-let (≤.) = (<=.)-let (≥.) = (>=.)+open Bool -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-            xs-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+module Int = struct+  let (<) (x: int) (y: int) = not (y <= x)+  let (>) = flip (<)+  let (>=) = flip (<=)+  let (>.) = flip (<.)+  let (>=.) = flip (<=.) -let fst[`a,`b] (x: `a, _: `b) = x-let snd[`a,`b] (_: `a, y: `b) = y+  type `a × `b = `a * `b+  (* These have too-tight precedences *)+  let (≠)  = (!=)+  let (≤)  = (<=)+  let (≥)  = (>=)+  let (≤.) = (<=.)+  let (≥.) = (>=.)+end -let (=>!) [`a] (x: `a) [`b] (y: `b) = (y, x)+open Int++module List = struct+  let null x =+    match x with+    | [] -> true+    | _  -> false++  let anull xs =+    match xs with+    | []       -> ([], true)+    | x :: xs' -> (x :: xs', false)++  let hd (x :: _) = x++  let tl (_ :: xs) = xs++  let rec foldr f z xs =+    match xs with+    | []      -> z+    | x :: xs -> f x (foldr f z xs)++  let rec foldl f z xs =+    match xs with+    | []      -> z+    | x :: xs -> foldl f (f x z) xs++  let map f = foldr (λ x xs' -> f x :: xs') []++  let filter f xs = foldr (λ x xs' -> if f x then x :: xs' else xs') []++  let mapFilterA f =+        foldr (λ x xs' ->+                 match f x with+                 | Some y -> y :: xs'+                 | None   -> xs')+              []++  let revApp xs ys =+    let cons x acc = x :: acc in+      foldl cons ys xs++  let rev xs = revApp xs []++  let append xs = revApp (rev xs)++  let length = foldr (λ _ -> (+) 1) 0++  let lengthA xs =+    let count x (n, xs') = (1 + n, x :: xs') in+      foldr count (0, []) xs++  let rec openFoldr f z o xs = match xs with+    | #Nil         -> z+    | #Cons(x,xs') -> f x (openFoldr f z o xs')+    | other        -> o other+end++open List++let fst (x, _) = x+let snd (_, y) = y++let (=>!) x y = (y, x) let (⇒) = (=>!)  let (←) = (<-) let (⇐) = (<-!) -open INTERNALS+type (|->)  = type Prim.Row.(|->)+let rowCase = Prim.Row.rowCase++module Exn      = INTERNALS.Exn+module Contract = INTERNALS.Contract open Exn
lib/libqueue.alms view
@@ -1,19 +1,19 @@ module type QUEUE = sig-  type +`a queue qualifier `a+  type +`a queue : `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 emptyA   : unit → `a queue+  val isEmptyA : `a queue → bool * `a queue+  val sizeA    : `a queue → int * `a queue+  val dequeueA : `a queue → (`a * `a queue) option -  val enqueue  : all `a. `a -> `a queue -[a]> `a queue+  val enqueue  : `a → `a queue → `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+  val empty    : 'a queue+  val isEmpty  : 'a queue → bool+  val size     : 'a queue → int+  val first    : 'a queue → 'a+  val dequeue  : 'a queue → 'a queue end  module Queue : QUEUE = struct@@ -21,38 +21,46 @@    exception Empty -  let emptyA[`a] () = (Nil[`a], Nil[`a])-  let isEmptyA[`a] (q : `a queue) =+  let emptyA () = ([], [])++  let isEmptyA q =     match q with-    | (Nil, Nil) -> (true, (Nil[`a], Nil[`a]))-    | q                -> (false, q)-  let sizeA[`a] ((front, back) : `a queue) =+    | ([], []) → (true, ([], []))+    | q        → (false, q)++  let sizeA (front, back) =     let (lenf, front) = lengthA front in     let (lenb, back)  = lengthA back in     (lenf + lenb, (front, back))-  let dequeueA[`a] ((front, back) : `a queue) =++  let dequeueA (front, back) =     match front with-    | Cons (x, xs) -> Some (x, (xs, back))-    | Nil ->+    | x ∷ xs → Some (x, (xs, back))+    | []     →       match rev back with-      | Cons (x, xs) -> Some (x, (xs, Nil[`a]))-      | Nil -> None[`a * `a queue]+      | x ∷ xs → Some (x, (xs, []))+      | []     → None -  let empty['a] = (Nil['a], Nil['a])-  let isEmpty[`a] (q : `a queue) =+  let empty = ([], [])++  let isEmpty q =     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) =+    | ([], []) → true+    | _        → false++  let enqueue x (front, back) =+    (front, x ∷ back)++  let first q =     match dequeueA q with-    | Some (x, _) -> x-    | None        -> raise Empty-  let dequeue[`a] (q : `a queue) =+    | Some (x, _) → x+    | None        → raise Empty++  let dequeue q =     match dequeueA q with-    | Some (_, q') -> q'-    | None         -> raise Empty-  let size[`a] ((front, back) : `a queue) =+    | Some (_, q') → q'+    | None         → raise Empty++  let size (front, back) =     length front + length back end
lib/libsessiontype.alms view
@@ -4,7 +4,7 @@  module type SESSION_TYPE = sig   type 1-  type +'a ; +'s+  type +'a ; +'s rec 's   type ! -`a   type ? +`a   type +'a |+| +'b@@ -51,35 +51,33 @@   type 's channel    = rep   type 's rendezvous = rep C.channel -  let newRendezvous['s] () =-    (C.new['s channel] ())+  let newRendezvous () = C.new () -  let request['s] (r: 's rendezvous) =-    C.recv r+  let request (r: 's rendezvous) = C.recv r -  let accept['s] (r: 's rendezvous) =-    let c = C.new[bool] () in+  let accept (r: 's rendezvous) =+    let c = C.new () in       C.send r c;       c -  let send[`a, 's] (c: rep)| (a: `a) =-    C.send c (Unsafe.unsafeCoerce[bool] a);+  let send (c: rep) (a: `a) =+    C.send c (Unsafe.unsafeCoerce a);     c -  let recv[`a, 's] (c: rep) =-    (Unsafe.unsafeCoerce[`a] (C.recv c),  c)+  let recv (c: rep) =+    (Unsafe.unsafeCoerce (C.recv c),  c) -  let sel1['s1, 's2] (c: ('s1 |+| 's2) channel)+  let sel1 (c: ('s1 |+| 's2) channel)                      : 's1 channel =     C.send c true;     c -  let sel2['s1, 's2] (c: rep) =+  let sel2 (c: rep) =     C.send c false;     c -  let follow['s1, 's2] (c: rep) =+  let follow (c: rep) =     if C.recv c-      then Left [rep, rep] c-      else Right[rep, rep] c+      then Left  c+      else Right c end
lib/libsessiontype2.alms view
@@ -18,17 +18,16 @@   type 's rendezvous   type +'s channel qualifier A -  val newRendezvous : all 's. unit -> 's rendezvous+  val newRendezvous : unit → 's rendezvous -  val request   : all 's. 's rendezvous -> 's channel-  val accept    : all 's. 's rendezvous -> 's dual channel+  val request   : 's rendezvous → 's channel+  val accept    : '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 send      : `a → (!`a; 's) channel → unit * 's channel+  val recv      : (?`a; 's) channel → `a * 's channel -  val follow    : all `c. ?-> `c channel -> unit * `c-  val choose    : all 's `c. ('s channel -> `c) -> !-> `c channel ->+  val follow    : ?-> `c channel → unit * `c+  val choose    : ('s channel → `c) → !-> `c channel →                     unit * 's dual channel end @@ -47,11 +46,11 @@   type ?-> `c = ?`c; 1   type !-> `c = !`c; 1 -  type rep = any C.channel+  type rep = int C.channel   type 's channel    = rep   type 's rendezvous = rep C.channel -  let newRendezvous () = C.new[rep] ()+  let newRendezvous () = C.new ()    let request (r: unit rendezvous) = C.recv r @@ -64,16 +63,16 @@     let c = C.new () in       (c, c) -  let send[`a] (a: `a) (c: rep) =+  let send (a: `a) (c: rep) =     C.send c (Unsafe.unsafeCoerce a);     ((), c) -  let recv[`a] (c: rep) = (C.recv c, c)+  let recv (c: rep) = (Unsafe.unsafeCoerce (C.recv c), c)    let follow (c: rep) =     let (c', _) = recv c in ((), c') -  let choose[`c] (ctor: rep -> `c) (c: rep) =+  let choose (ctor: rep → `c) (c: rep) =     let (theirs, mine) = newPair () in       send (ctor theirs) c;       ((), mine)@@ -87,12 +86,13 @@               | More of (!int; ?->state2) channel               | Again of (?int; state1) channel +   let client (c: state1 channel) =-    let rec s1 !(c: state1 channel) : int * 1 channel =+    let rec s1 !c =               send 1 c;               follow c;               s2 c-        and s2 !(c: state2) : int * 1 channel =+        and s2 !c =           match c with           | Done c  -> recv c           | More c  -> send 2 c;@@ -103,7 +103,7 @@      in fst (s1 c)    let server (c: state1 dual channel) =-    let rec s1 !(c : state1 dual channel) : unit * 1 channel =+    let rec s1 !c =       match recv c with         | 0 -> choose More c;                let z' = recv c in
lib/libsocket.alms view
@@ -7,11 +7,11 @@     module S = Prim.Socket   with     let getAddrByName (host: string) (port: string) : S.sockAddr =-      let info = S.AddrInfo(Nil[S.addrInfoFlag], S.AF_INET,+      let info = S.AddrInfo([], S.AF_INET,                             S.Stream, S.defaultProtocol,-                            S.SockAddrInet(S.PortNum 0, 0), None[string]) in+                            S.SockAddrInet(S.PortNum 0, 0), None) in       match S.getAddrInfo (Some info) (Some host) (Some port) with-      | Cons (S.AddrInfo (_, _, _, _, sockAddr, _), _) -> sockAddr+      | S.AddrInfo (_, _, _, _, sockAddr, _) ∷ _ -> sockAddr       | _ -> failwith ("Could not resolve address "^host^":"^port)      type socket = S.socket
lib/libsocketcap.alms view
@@ -14,63 +14,63 @@   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+  type 't initial   : A+  type 't bound     : A+  type 't listening : A+  type 't connected : 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+  val socket  : unit → ∃ 't. 't socket × 't initial+  val bind    : 't socket → int → 't initial → 't bound+  val connect : 't socket → string → string →+                  't initial + 't bound → 't connected+  val listen  : 't socket → 't bound → 't listening+  val accept  : 't socket → 't listening →+                  (∃ 's. 's socket × 's connected) × 't listening+  val send    : 't socket → string →+                  't connected → 't connected+  val recv    : 't socket → int →+                  't connected → string × 't connected+  val close   : '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+  type frozenInitial   : A+  type frozenBound     : A+  type frozenListening : A+  type frozenConnected : A    (* Operations for reassociating frozen capabilities with their      sockets. *)-  val thawInitial   : all 't. 't socket -> frozenInitial ->+  val thawInitial   : 't socket → frozenInitial →                         frozenInitial + 't initial-  val thawBound     : all 't. 't socket -> frozenBound ->+  val thawBound     : 't socket → frozenBound →                         frozenBound + 't bound-  val thawListening : all 't. 't socket -> frozenListening ->+  val thawListening : 't socket → frozenListening →                         frozenListening + 't listening-  val thawConnected : all 't. 't socket -> frozenConnected ->+  val thawConnected : '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+  val catchInitial   : 't socket →+                         (unit -o `a) → ('t initial -o `a) -o `a+  val catchBound     : 't socket →+                         (unit -o `a) → ('t bound -o `a) -o `a+  val catchListening : 't socket →+                         (unit -o `a) → ('t listening -o `a) -o `a+  val catchConnected : '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+  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@@ -80,60 +80,70 @@   type rep        = S.socket   type 't socket  = S.socket +  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+   exception SocketError    of string-  exception StillInitial   of rep * string-  exception StillBound     of rep * string-  exception StillListening of rep * string-  exception StillConnected of rep * string+  exception StillInitial   of rep × string+  exception StillBound     of rep × string+  exception StillListening of rep × string+  exception StillConnected of rep × string -  let socket () =+  let socket () : ∃'t. 't socket × 't initial =     try (S.socket (), ())     with-      IOError s -> raise (SocketError s)+      IOError s → raise (SocketError s) -  let bind['t] (sock: rep) (port: int) () =+  let bind (sock: rep) (port: int) () =     try S.bind sock port     with-      IOError msg -> raise (StillInitial (sock, msg))+      IOError msg → raise (StillInitial (sock, msg)) -  let connect['t] (sock: rep) (host: string) (port: string)-                  (cap: unit + unit) =+  let connect (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))+      IOError msg → match cap with+        | Left _  → raise (StillInitial (sock, msg))+        | Right _ → raise (StillBound (sock, msg)) -  let listen['t] (sock: rep) () =+  let listen (sock: rep) () =     try S.listen sock     with-      IOError msg -> raise (StillBound (sock, msg))+      IOError msg → raise (StillBound (sock, msg)) -  let accept['t] (sock: rep) () =-    try (S.accept sock, (), ())+  let accept (sock: rep) () =+    try ((S.accept sock, ()) : ∃'s. 's socket × 's connected, ())     with-      IOError msg -> raise (StillListening (sock, msg))+      IOError msg → raise (StillListening (sock, msg)) -  let send['t] (sock: rep) (data: string) () =+  let send (sock: rep) (data: string) () =     try       S.send sock data;       ()     with-      IOError msg -> raise (SocketError msg)+      IOError msg → raise (SocketError msg) -  let recv['t] (sock: rep) (len: int) () =+  let recv (sock: rep) (len: int) () =     try (S.recv sock len, ())     with-      IOError msg -> raise (SocketError msg)+      IOError msg → raise (SocketError msg) -  let close['t] (sock: rep) () =+  let close (sock: rep) () =     try S.close sock     with-      IOError msg -> raise (SocketError msg)+      IOError msg → raise (SocketError msg)    (* Convenience functions for catching and thawing frozen socket    * capabilities. *)-  let thaw  ['t] (sock: rep) (sock': rep) =+  let thaw (sock: rep) (sock': rep) =     if sock == sock'       then Right ()       else Left  sock'@@ -143,47 +153,36 @@   let thawListening   = thaw   let thawConnected   = thaw -  let catchInitial['t,`a] (sock: rep) (body: unit -o `a)-                           (handler: unit -o `a) =+  let catchInitial (sock: rep) (body: unit -o `a)+                   (handler: unit -o `a) =     try body () with-    | StillInitial (frz, msg) ->+    | StillInitial (frz, msg) →         match thawInitial sock frz with-        | Left frz  -> raise (StillInitial (frz, msg))-        | Right cap -> handler cap+        | Left frz  → raise (StillInitial (frz, msg))+        | Right cap → handler cap -  let catchBound['t,`a] (sock: rep) (body: unit -o `a)-                           (handler: unit -o `a) =+  let catchBound (sock: rep) (body: unit -o `a)+                 (handler: unit -o `a) =     try body () with-    | StillBound (frz, msg) ->+    | StillBound (frz, msg) →         match thawBound sock frz with-        | Left frz  -> raise (StillBound (frz, msg))-        | Right cap -> handler cap+        | Left frz  → raise (StillBound (frz, msg))+        | Right cap → handler cap -  let catchListening['t,`a] (sock: rep) (body: unit -o `a)-                           (handler: unit -o `a) =+  let catchListening (sock: rep) (body: unit -o `a)+                     (handler: unit -o `a) =     try body () with-    | StillListening (frz, msg) ->+    | StillListening (frz, msg) →         match thawListening sock frz with-        | Left frz  -> raise (StillListening (frz, msg))-        | Right cap -> handler cap+        | Left frz  → raise (StillListening (frz, msg))+        | Right cap → handler cap -  let catchConnected['t,`a] (sock: rep) (body: unit -o `a)-                           (handler: unit -o `a) =+  let catchConnected (sock: rep) (body: unit -o `a)+                     (handler: unit -o `a) =     try body () with-    | StillConnected (frz, msg) ->+    | 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+        | Left frz  → raise (StillConnected (frz, msg))+        | Right cap → handler cap end
lib/libsocketcap2.alms view
@@ -41,7 +41,7 @@    * 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+  val thaw : all 't 's. 't socket -> 's frozen -> 's frozen + 't@@'s    (* Operations for catching the error state associated with a given      socket. *)@@ -70,6 +70,13 @@   type rep        = S.socket   type 't socket  = S.socket +  type 't @@ 's = unit+  type initial+  type bound+  type listening+  type connected+  type 's frozen = rep+   type socketError = StillInitial   of rep                    | StillBound     of rep                    | StillListening of rep@@ -81,7 +88,7 @@     raise (SocketError (se, msg))    let socket () =-    try (S.socket (), ())+    try (S.socket (), ()) : ∃ 't. 't socket × 't@@initial     with       IOError msg -> error Disconnected msg @@ -104,7 +111,7 @@       IOError msg -> error (StillBound sock) msg    let accept (sock: rep) () =-    try (S.accept sock, (), ())+    try ((S.accept sock, ()) : ∃ 't. 't socket × 't@@initial, ())     with       IOError msg -> error (StillListening sock) msg @@ -132,44 +139,36 @@       then Right ()       else Left  sock' -  let catchInitial[`a] (sock: rep) (body: unit -o `a)-                       (handler: unit -o `a) =+  let catchInitial (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) =+  let catchBound (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) =+  let catchListening (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) =+  let catchConnected (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
+ src/AST.hs view
@@ -0,0 +1,164 @@+-----------------------------------------------------------------------------+-- |+-- This module provides abstract syntax and basic syntax operations.+--+-----------------------------------------------------------------------------++module AST (+  module AST.Anti,+  module AST.Notable,+  module AST.Ident,+  module AST.Kind,+  module AST.Type,+  module AST.Lit,+  module AST.Patt,+  module AST.Expr,+  module AST.Decl,+  module AST.SyntaxTable,+  module Data.Lattice,++  -- * Unfold syntax to lists+  unfoldExAbs, unfoldTyQu, unfoldTyMu, unfoldTyRow,+  unfoldExApp, unfoldPaRec, unfoldTyFun,+  unfoldTupleExpr, unfoldTuplePatt, unfoldSeWith,+) where++import Prelude ()++import AST.Anti+import AST.Notable+import AST.Ident+import AST.Kind+import AST.Type+import AST.Lit+import AST.Patt+import AST.Expr+import AST.Decl+import AST.SyntaxTable++import Util+import Data.Lattice++deriveAntibles syntaxTable++instance Antible (Prog i) where+  injAnti _ = error "BUG! injAnti: Cannot inject into Prog"+  prjAnti   = const Nothing+  dictOf    = const noAntis++-- These should be generated:+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++instance Antible (QTypId i) where+  injAnti          = J [] . injAnti+  prjAnti (J [] i) = prjAnti i+  prjAnti _        = Nothing+  dictOf           = const qtypIdAntis++instance Antible (QVarId i) where+  injAnti          = J [] . injAnti+  prjAnti (J [] i) = prjAnti i+  prjAnti _        = Nothing+  dictOf           = const qvarIdAntis++instance Antible (QConId i) where+  injAnti          = J [] . injAnti+  prjAnti (J [] i) = prjAnti i+  prjAnti _        = Nothing+  dictOf           = const qconIdAntis++instance Antible (QModId i) where+  injAnti          = J [] . injAnti+  prjAnti (J [] i) = prjAnti i+  prjAnti _        = Nothing+  dictOf           = const qmodIdAntis++instance Antible (QSigId i) where+  injAnti          = J [] . injAnti+  prjAnti (J [] i) = prjAnti i+  prjAnti _        = Nothing+  dictOf           = const qsigIdAntis++-- Unfolding various sequences++-- | Get the list of formal parameters and body of a+--   lambda/typelambda expression+unfoldExAbs :: Expr i -> ([Patt i], Expr i)+unfoldExAbs  = unscanr each where+  each e = case view e of+    ExAbs x e' -> Just (x, 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 labels and types in a row type+unfoldTyRow :: Type i -> ([(Uid i, Type i)], Type i)+unfoldTyRow = unscanr each where+  each (N _ (TyRow i t1 t2)) = Just ((i, t1), t2)+  each _                     = 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+unfoldPaRec :: Patt i -> ([(Uid i, Patt i)], Patt i)+unfoldPaRec  = unscanr each where+  each (N _ (PaRec u π1 π2)) = Just ((u, π1), π2)+  each _                     = 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 -> ([(QTypId 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/AST/Anti.hs view
@@ -0,0 +1,404 @@+module AST.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 Data.Loc as Loc+import Meta.THHelpers+import AST.Notable+import Util++import Prelude ()+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     = $(foldl+                              (\e1 n2 -> [| $e1 . $(conE n2) |])+                              (varE (maybe 'id id (scWrap sc)))+                              (scAnti sc))+            prjAnti stx = $(caseE [| stx |] [+                              match (wrapper+                                      (foldr+                                        (TH.conP <$.> (:[]))+                                        (TH.varP a)+                                        (scAnti sc)))+                                    (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+--++-- | Show a name, and strip "Notable." from it if necessary+showNot :: Show a => a -> String+showNot a = case show a of+  'A':'S':'T':'.':rest+    -> "AST." ++ last (splitBy (== '.') rest)+  s -> s++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 (showNot name))+                  ast <- $(varE build) stx+                  case ast of+                    VarE _ -> return ast+                    _      -> varS $(stringE (showNot 'setLoc))+                                   [return ast, varS loc []]+                `whichS'`+                do+                  let pat preAstQ =+                        conS $(stringE (showNot 'N))+                            [ conS $(stringE (showNot 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 (showNot 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+class MkSyntaxClass a b where+  (=::) :: a -> b -> SyntaxClass++instance MkSyntaxClass TH.Name [TH.Name] where+  name =:: antis = SyntaxClass {+    scName   = name,+    scAnti   = antis,+    scWrap   = Nothing,+    scDict   = Nothing,+    scCxt    = []+  }++instance MkSyntaxClass TH.Name TH.Name where+  name =:: anti = name =:: [anti]++-- | 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 =:• [n]++-- | Construct an antiquote dictionary for matching a+--   composition of simple constructors+(=:•) :: String -> [TH.Name] -> AntiDict+a =:• ns = a =: Just (\v -> foldr (conS <$.> (:[])) (varS v []) ns)++-- | Construct an antiquote dictionary for matching sequences+--   of constructors, where there may be a different sequence+--   for expressions and patterns.+(=:••) :: String -> ([TH.Name], [TH.Name]) -> AntiDict+a =:•• (ins, outs) =+  a =: Just (\v -> head (foldr ((:[]) <$$> varS) [varS v []] ins)+         `whichS`  head (foldr ((:[]) <$$> conS) [wildS, varS v []] outs))++infix 2 =:, =:!, =:<, =:•, =:••+
+ src/AST/Decl.hs view
@@ -0,0 +1,343 @@+module AST.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, dcLetRec, dcTyp, dcAli, dcAbs, dcMod, dcSig, dcOpn,+  dcLoc, dcExn, dcAnti,+  absTy, absTyAnti,+  tdAbs, tdSyn, tdDat, tdAnti,+  meStr, meName, meAsc, meAnti,+  sgVal, sgTyp, sgAli, sgMod, sgSig, sgInc, sgExn, sgAnti,+  seSig, seName, seWith, seAnti,+  prog,++  -- * Programs+  Prog'(..), Prog,+  prog2decls+) where++import Util+import Meta.DeriveNotable+import AST.Notable+import AST.Anti+import AST.Kind+import AST.Ident+import AST.Type+import AST.Patt+import AST.Expr++import Prelude ()+import Data.Generics (Typeable(..), Data(..))+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) (Expr i)+  -- | Recursive value declaration+  | DcLetRec [Binding i]+  -- | Type declaration+  | DcTyp [TyDec i]+  -- | Type alias+  | DcAli (TypId i) (QTypId i)+  -- | Abstype block declaration+  | DcAbs [AbsTy i] [Decl i]+  -- | Module declaration+  | DcMod (ModId i) (ModExp i)+  -- | Signature declaration+  | DcSig (SigId i) (SigExp i)+  -- | Module open+  | DcOpn (ModExp i)+  -- | Local block+  | DcLoc [Decl i] [Decl i]+  -- | Exception declaration+  | DcExn (ConId 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 (QModId i) [QVarId 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 (VarId i) (Type i)+  -- | A type+  | SgTyp [TyDec i]+  -- | Type alias+  | SgAli (TypId i) (QTypId i)+  -- | A module+  | SgMod (ModId i) (SigExp i)+  -- | A signature+  | SgSig (SigId i) (SigExp i)+  -- | Signature inclusion+  | SgInc (SigExp i)+  -- | An exception+  | SgExn (ConId 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 (QSigId i) [QVarId i]+  -- | Type-level fibration+  | SeWith (SigExp i) (QTypId 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      :: TypId i,+      tdParams    :: [TyVar i],+      -- | The variance of each parameter+      tdVariances :: [Variance],+      -- | Which the parameters guard equirecursion?+      tdGuards    :: [TyVar i],+      -- | Whether each parameter contributes to the qualifier+      tdQual      :: QExp i+    }+  -- | A type operator or synonym+  | TdSyn {+      tdName      :: TypId i,+      tdClauses   :: [([TyPat i], Type i)]+  }+  -- | An algebraic datatype+  | TdDat {+      tdName      :: TypId i,+      tdParams    :: [TyVar i],+      tdAlts      :: [(ConId 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_   :: [QVarId 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 mempty++newDecl :: Tag i => Decl' i -> Decl i+newDecl d0 = flip N d0 $ case d0 of+  DcLet p1 e2 ->+    newNote {+      dloc_  = getLoc (p1, e2),+      dfv_   = fv e2,+      ddv_   = qdv p1+    }+  DcLetRec bns ->+    newNote {+      dloc_  = getLoc bns,+      dfv_   = fv bns,+      ddv_   = map (J [] . bnvar . dataOf) bns+    }+  DcTyp tds ->+    newNote {+      dloc_  = getLoc tds+    }+  DcAli _ _ ->+    newNote+  DcAbs at1 ds2 ->+    newNote {+      dloc_  = getLoc (at1, ds2),+      dfv_   = fv ds2,+      ddv_   = concatMap qdv ds2+    }+  DcMod u1 me2 ->+    newNote {+      dloc_  = getLoc me2,+      dfv_   = fv me2,+      ddv_   = (u1 <.>) <$> 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 :: Tag 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_  = 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 :: Tag i => SigItem' i -> SigItem i+newSigItem d0 = flip N d0 $ case d0 of+  SgVal l1 t2 ->+    newNote {+      dloc_  = getLoc t2,+      ddv_   = [J [] l1]+    }+  SgTyp tds ->+    newNote {+      dloc_  = getLoc tds+    }+  SgAli _ _ ->+    newNote+  SgMod u1 se2 ->+    newNote {+      dloc_  = getLoc se2,+      ddv_   = (u1 <.>) <$> 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 :: Tag 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_  = qls+    }+  SeWith se1 _ _ t3 ->+    newNote {+      dloc_ = getLoc (se1, t3),+      ddv_  = qdv se1+    }+  SeAnti a ->+    newNote {+      dfv_  = antierror "fv" a,+      ddv_  = antierror "dv" a+    }++instance Tag i => Fv (N (DeclNote i) a) i where fv  = dfv_ . noteOf+instance Tag i => Dv (N (DeclNote i) a) i where qdv = ddv_ . noteOf++deriveNotable 'newDecl    (''Tag, [0]) ''Decl+deriveNotable 'newModExp  (''Tag, [0]) ''ModExp+deriveNotable 'newSigItem (''Tag, [0]) ''SigItem+deriveNotable 'newSigExp  (''Tag, [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 :: Tag i => Prog i -> [Decl i]+prog2decls (N _ (Prog ds (Just e)))+  = ds ++ [dcLet (paVar (ident "it")) e]+prog2decls (N _ (Prog ds Nothing))+  = ds
+ src/AST/Decl.hs-boot view
@@ -0,0 +1,26 @@+-- vim: ft=haskell+{-# LANGUAGE+      FlexibleInstances,+      MultiParamTypeClasses,+      TypeFamilies,+      TypeSynonymInstances #-}+{-# OPTIONS_GHC -w #-}+module AST.Decl where++import AST.Notable+import AST.Ident (Tag, Fv, Dv)++import Data.Data (Data, Typeable1)++data DeclNote i+data Decl' i+type Decl i = N (DeclNote i) (Decl' i)++instance Typeable1 DeclNote+instance Typeable1 Decl'+instance Tag i => Data (DeclNote i)+instance Tag i => Data (Decl' i)+instance Locatable (DeclNote i)+instance Notable (DeclNote i)+instance Tag i => Fv (N (DeclNote i) a) i+instance Tag i => Dv (N (DeclNote i) a) i
+ src/AST/Expr.hs view
@@ -0,0 +1,403 @@+module AST.Expr (+  -- * Expressions+  Expr'(..), Expr, ExprNote(..), newExpr,+  -- ** Letrec and case+  Binding'(..), Binding, newBinding,+  CaseAlt'(..), CaseAlt, newCaseAlt,+  Field'(..), Field, newField,++  -- * Two-level expression constructors+  -- | These fill in the source location field based on the+  -- subexpressions and perform the free variable analysis+  -- | variables+  exVar, exLit, exCon, exLet, exCase, exLetRec, exLetDecl,+  exPair, exAbs, exApp, exInj, exEmb, exCast, exRec, exSel, exAnti,++  caClause, caPrj, caAnti,+  bnBind, bnAnti,+  fdField, fdAnti,+  -- ** Synthetic expression constructors+  exBVar, exBCon,+  exChar, exStr, exInt, exFloat,+  exSeq,+  exUnit, exNilRecord,+  exNil, exCons,+  ToExpr(..),++  -- * Expression accessors and updaters+  syntacticValue, isAnnotated, getExprAnnot, cafakepatt,+) where++import Util+import AST.Notable+import AST.Anti+import AST.Ident+import AST.Type+import AST.Lit+import AST.Patt+import {-# SOURCE #-} AST.Decl++import Meta.DeriveNotable++import Prelude ()+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)+type Field i   = N (ExprNote i) (Field' i)++-- | The underlying expression type, which we can pattern match without+-- dealing with the common fields above.+data Expr' i+  -- | variables+  = ExVar (QVarId i)+  -- | literals+  | ExLit Lit+  -- | data construction+  | ExCon (QConId i) (Maybe (Expr i))+  -- | let expressions+  | ExLet (Patt i) (Expr i) (Expr i)+  -- | case expressions (including desugared @if@)+  | 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) (Expr i)+  -- | application+  | ExApp (Expr i) (Expr i)+  -- | open variant construction+  | ExInj (Uid i) (Maybe (Expr i))+  -- | open variant embedding+  | ExEmb (Uid i) (Expr i)+  -- | record extension+  --   (@True@ means additive rather than multiplicative records)+  | ExRec Bool [Field i] (Expr i)+  -- | record lookup+  | ExSel (Expr i) (Uid 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  :: VarId i,+      bnexpr :: Expr i+    }+  | BnAnti Anti+  deriving (Typeable, Data)++data CaseAlt' i+  -- | Normal match clauses+  = CaClause {+      capatt :: Patt i,+      caexpr :: Expr i+    }+  -- | Open variant elimination+  | CaPrj {+      calab   :: Uid i,+      campatt :: Maybe (Patt i),+      caexpr  :: Expr i+    }+  -- | Antiquote+  | CaAnti Anti+  deriving (Typeable, Data)++data Field' i+  -- | Normal match clauses+  = FdField {+      fdsel  :: Uid i,+      fdexpr :: Expr i+    }+  -- | Antiquote+  | FdAnti 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 Tag i => Fv (N (ExprNote i) a) i where fv = efv_ . noteOf++instance Dv (N (ExprNote i) (Binding' i)) i where+  dv (N _ (BnBind f _)) = [f]+  dv (N _ (BnAnti _))   = []++instance Notable (ExprNote i) where+  newNote = ExprNote {+    eloc_  = bogus,+    efv_   = M.empty+  }++newExpr :: Tag i => Expr' i -> Expr i+newExpr e0 = flip N e0 $ case e0 of+  ExVar v ->+    newNote {+      efv_ = M.singleton v 1+    }+  ExLit _ -> newNote+  ExCon _ me2 ->+    newNote {+      efv_  = fv me2,+      eloc_ = getLoc me2+    }+  ExLet x1 e2 e3 ->+    newNote {+      efv_  = fv e2 |*| (fv e3 |--| qdv x1),+      eloc_ = getLoc (x1, e2, e3)+    }+  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 e2 ->+    newNote {+      efv_  = fv e2 |--| qdv p1,+      eloc_ = getLoc (p1, e2)+    }+  ExApp e1 e2 ->+    newNote {+      efv_  = fv e1 |*| fv e2,+      eloc_ = getLoc (e1, e2)+    }+  ExInj _ me2 ->+    newNote {+      efv_  = fv me2,+      eloc_ = getLoc me2+    }+  ExEmb _ e2 ->+    newNote {+      efv_  = fv e2,+      eloc_ = getLoc e2+    }+  ExRec True flds e2 ->+    newNote {+      efv_  = fv (ADDITIVE flds) |*| fv e2,+      eloc_ = getLoc (flds, e2)+    }+  ExRec False flds e2 ->+    newNote {+      efv_  = fv flds |*| fv e2,+      eloc_ = getLoc (flds, e2)+    }+  ExSel e1 _ ->+    newNote {+      efv_  = fv e1,+      eloc_ = getLoc e1+    }+  ExCast e1 t2 _ ->+    newNote {+      efv_  = fv e1,+      eloc_ = getLoc (e1, t2)+    }+  ExAnti a ->+    newNote {+      efv_  = antierror "fv" a+    }++newBinding :: Tag i => Binding' i -> Binding i+newBinding b0 = flip N b0 $ case b0 of+  BnBind x e ->+    newNote {+      efv_  = fv e |-| J [] x,+      eloc_ = getLoc e+    }+  BnAnti a ->+    newNote {+      efv_  = antierror "fv" a+    }++newCaseAlt :: Tag 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)+    }+  CaPrj _ mx e ->+    newNote {+      efv_  = fv e |--| qdv mx,+      eloc_ = getLoc (mx, e)+    }+  CaAnti a ->+    newNote {+      efv_  = antierror "fv" a+    }++newField :: Tag i => Field' i -> Field i+newField f0 = flip N f0 $ case f0 of+  FdField _ e ->+    newNote {+      efv_  = fv e,+      eloc_ = getLoc e+    }+  FdAnti a ->+    newNote {+      efv_  = antierror "fv" a+    }++deriveNotable 'newExpr    (''Tag, [0]) ''Expr+deriveNotable 'newCaseAlt (''Tag, [0]) ''CaseAlt+deriveNotable 'newBinding (''Tag, [0]) ''Binding+deriveNotable 'newField   (''Tag, [0]) ''Field++exBVar :: Tag i => VarId i -> Expr i+exBVar  = exVar . J []++exBCon :: Tag i => ConId i -> Maybe (Expr i) -> Expr i+exBCon  = exCon . J []++exChar :: Tag i => Char -> Expr i+exChar = exLit . LtChar++exStr :: Tag i => String -> Expr i+exStr  = exLit . LtStr++exInt :: (Tag i, Integral a) => a -> Expr i+exInt  = exLit . LtInt . toInteger++exFloat :: Tag i => Double -> Expr i+exFloat  = exLit . LtFloat++exSeq :: Tag i => Expr i -> Expr i -> Expr i+exSeq e1 e2 = exLet paWild e1 e2++exUnit, exNilRecord :: Tag i => Expr i+exUnit      = exCon idUnitVal Nothing+exNilRecord = exVar idNilRecord++exCons :: Tag i => Expr i -> Expr i -> Expr i+exCons = exCon idConsList . Just <$$> exPair++exNil :: Tag i => Expr i+exNil  = exCon idNilList Nothing++class ToExpr a i | a → i where+  toExpr ∷ a → Expr i++instance ToExpr (Expr i) i where+  toExpr = id++instance Tag i ⇒ ToExpr (QVarId i) i where+  toExpr = exVar++instance Tag i ⇒ ToExpr (VarId i) i where+  toExpr = exBVar++instance (Tag i, ToExpr a i, ToExpr b i) ⇒ ToExpr (a, b) i where+  toExpr (a, b) = exPair (toExpr a) (toExpr b)++instance Tag i ⇒ ToExpr String i where+  toExpr = exStr++instance Tag i ⇒ ToExpr Int i where+  toExpr = exInt++instance Tag i ⇒ ToExpr Char i where+  toExpr = exChar++instance Tag i ⇒ ToExpr Double i where+  toExpr = exFloat++-- | Is the expression conservatively side-effect free?+syntacticValue :: Expr i -> Bool+syntacticValue e = case view e of+  ExVar _        → True+  ExLit _        → True+  ExCon _ me     → maybe True syntacticValue me+  ExLet _ e1 e2  → syntacticValue e1 && syntacticValue e2+  ExCase _ _     → False+  ExLetRec bs e2 → all eachBinding bs && syntacticValue e2 where+    eachBinding bn = case view bn of+      BnBind { bnexpr = e' } → syntacticValue e'+      BnAnti a               → antierror "syntacticValue" a+  ExLetDecl _ _  → False+  ExPair e1 e2   → syntacticValue e1 && syntacticValue e2+  ExAbs _ _      → True+  ExApp _ _      → False+  ExInj _ me     → maybe True syntacticValue me+  ExEmb _ e1     → syntacticValue e1+  ExRec b flds e2+                 → b ||+                   (and [ syntacticValue ei | FdField _ ei ← view <$> flds ]+                    && syntacticValue e2)+  ExSel _ _      → False+  ExCast e1 _ b  → syntacticValue e1 && not b+  ExAnti a       → antierror "syntacticValue" a++-- | Is the expression annotated with a type ascription or dynamic cast?+isAnnotated ∷ Expr i → Bool+isAnnotated e = case view e of+  ExVar _        → False+  ExLit _        → False+  ExCon _ _      → False+  ExLet _ _ e2   → isAnnotated e2+  ExCase _ cs    → all eachClause cs where+    eachClause c = case view c of+      CaClause { caexpr = e' } → isAnnotated e'+      CaPrj    { caexpr = e' } → isAnnotated e'+      CaAnti a                 → antierror "isAnnotated" a+  ExLetRec _ e2  → isAnnotated e2+  ExLetDecl _ e2 → isAnnotated e2+  ExPair _ _     → False+  ExAbs _ _      → False+  ExApp _ _      → False+  ExInj _ _      → False+  ExEmb _ _      → False+  ExRec _ _ _    → False+  ExSel _ _      → False+  ExCast _ _ _   → True+  ExAnti a       → antierror "syntacticValue" a++-- | Get the (static) type annotation on an expression+getExprAnnot ∷ Expr i → Maybe (Type i)+getExprAnnot e0 = case view e0 of+  ExCast _ annot False → Just annot+  _                    → Nothing++-- | Given a case alternative, produce a (potentially fake)+--   representation of its pattern, suitable for printing.+cafakepatt ∷ Tag i ⇒ CaseAlt i → Patt i+cafakepatt ca0 = case view ca0 of+  CaClause x _ → x+  CaPrj u mx _ → paCon (qident ('#':idName u)) mx+  CaAnti a     → $antierror
+ src/AST/Ident.hs view
@@ -0,0 +1,547 @@+{-# LANGUAGE TypeFamilies #-}+module AST.Ident (+  -- * Identifier classes+  Id(..),+  -- ** Tags+  Tag(..), Raw(..), Renamed(..), renamed0, renTrivial,+  -- *** Dirty tricks+  dirtyTrivialRename,+  -- * Identifiers+  -- ** High level+  TypId(..), QTypId,+  VarId(..), QVarId,+  ConId(..), QConId,+  ModId(..), QModId,+  SigId(..), QSigId,+  TyVar(..), tvUn, tvAf,+  -- ** Low level+  Path(..), (<.>),+  Lid(..), QLid,+  Uid(..), QUid,+  BIdent(..), Ident,+  -- *** Operations+  isOperator, uidToLid, lidToUid,+  -- * Fresh names+  tvalphabet, freshName, freshNames,+  -- * Build-in names+  idUnitVal, idNilRecord, idNilList, idConsList,+  idTrueValue, idFalseValue,+  internalPath, internalName, internalIdent,+  -- * Free and defined vars+  Occurrence, occToQLit,+  FvMap, Fv(..), Dv(..), ADDITIVE(..),+  (|*|), (|+|), (|-|), (|--|),+) where++import Env (Path(..), (:>:)(..), (<.>))+import Util+import AST.Anti+import AST.Notable+import AST.Kind (QLit(..))+import qualified Syntax.Strings as Strings++import Prelude ()+import Data.Char (isAlpha, isDigit, isUpper, toUpper, toLower)+import Data.Generics (Typeable(..), Typeable1, Data(..), everywhere, mkT)+import qualified Data.List as List+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Unsafe.Coerce++class (IsBogus i, Data i) => Tag i where+  -- The trivial identity tag, used when the identity tag is+  -- insufficient to distinguish different thing+  trivialId :: i+  trivialId  = bogus+  -- Check for triviality+  isTrivial :: i -> Bool+  isTrivial  = isBogus+  -- 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 Bogus Raw where+  bogus     = Raw_++instance IsBogus Raw where+  isBogus _ = True++instance Tag Raw where+  compareId _ _ = id++instance Show Renamed where+  showsPrec p (Ren_ z) = showsPrec p z++instance Bogus Renamed where+  bogus   = Ren_ 0++instance IsBogus Renamed where+  isBogus (Ren_ 0) = True+  isBogus _        = False++instance Tag Renamed where+  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+{-# NOINLINE dirtyTrivialRename #-}+dirtyTrivialRename :: forall f i j. (Tag i, Tag j, Data (f i)) => f i -> f j+dirtyTrivialRename  = Unsafe.Coerce.unsafeCoerce . everywhere (mkT each) where+  each :: i -> i+  each _ = Unsafe.Coerce.unsafeCoerce (trivialId :: j)++---+--- Generic identifiers+---++-- | A module path to an identifier+type Q a i = Path (ModId i) (a i)++-- | Generic identifiers and operations+class (Typeable1 a,+       Data (a Raw), Eq (a Raw), Ord (a Raw), Bogus (a Raw),+       Data (a Renamed), Eq (a Renamed), Ord (a Renamed), Bogus (a Renamed))+      ⇒+      Id a where+  idTag         ∷ a i → i+  idName        ∷ a i → String+  ident         ∷ Tag i ⇒ String → a i+  identT        ∷ i → String → a i+  qident        ∷ Tag i ⇒ String → Path (ModId i) (a i)+  renId         ∷ i' → a i → a i'+  --+  ident        = identT bogus+  qident s     = case reverse (splitBy (=='.') s) of+    []   -> J [] (ident "")+    x:xs -> J (map ident (reverse xs)) (ident x)+  renId        = identT <$.> idName++renTrivial ∷ (Id a, Tag i) ⇒  a i' → a i+renTrivial = renId trivialId++---+--- LOW-LEVEL IDENTIFIERS+---++--+-- Lowercase+--++-- | lowercase identifiers (variables, tycons)+data Lid i+  = Lid {+      lidUnique :: !i,+      unLid     :: !String+    }+  | LidAnti Anti+  deriving (Typeable, Data)++-- | path-qualified lowecase identifiers+type QLid i = Q Lid i++instance Tag i => Eq (Lid i) where+  a == b = compare a b == EQ++instance Tag 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++instance Tag i => Bogus (Lid i) where+  bogus = Lid bogus "<bogus>"++instance Id Lid where+  idTag  = lidUnique+  idName = unLid+  identT = Lid++-- | Is the lowercase identifier an infix operator?+isOperator :: Lid i -> Bool+isOperator l = case show l of+    '(':_ -> True+    _     -> False++--+-- Uppercase+--++-- | uppercase identifiers (modules, datacons)+data Uid i+  = Uid {+      uidUnique :: !i,+      unUid     :: !String+    }+  | UidAnti Anti+  deriving (Typeable, Data)++-- | path-qualified uppercase identifiers+type QUid i = Q Uid i++instance Tag i => Eq (Uid i) where+  a == b = compare a b == EQ++instance Tag 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++instance Tag i => Bogus (Uid i) where+  bogus = Uid bogus "<bogus>"++instance Id Uid where+  idTag  = uidUnique+  idName = unUid+  identT = Uid++--+-- Mixed upper and lower+--++uidToLid :: Uid i -> Lid i+uidToLid (Uid ix s)  = Lid ix (mapHead toLower s)+uidToLid (UidAnti a) = antierror "uidToLid" a++lidToUid :: Lid i -> Uid i+lidToUid (Lid ix s)  = Uid ix (mapHead toUpper s)+lidToUid (LidAnti a) = antierror "lidToUid" a++-- | Bare (unqualified) identifers of unknown sort+data BIdent i = Var { unVar :: !(Lid i) }+              | Con { unCon :: !(Uid i) }+  deriving (Eq, Ord, Typeable, Data)++-- | Path-qualified identifiers+type Ident i = Q BIdent i++instance Tag i => Bogus (BIdent i) where+  bogus = Var bogus++instance Id BIdent where+  idTag (Var n) = idTag n+  idTag (Con n) = idTag n+  idName (Var n) = idName n+  idName (Con n) = idName n+  identT i s =+    if isUpperIdentifier s+      then Con (identT i s)+      else Var (identT i s)+    where+    -- | Is the string an uppercase identifier?  (Special case: @true@ and+    --   @false@ are consider uppercase.)+    --   (This code is duplicated from Syntax.Lexer!)+    isUpperIdentifier "true"  = True+    isUpperIdentifier "false" = True+    isUpperIdentifier "()"    = True+    isUpperIdentifier (c:_)   = isUpper c+    isUpperIdentifier _       = False++---+--- Specific identifiers+---++-- | Type names+newtype TypId i = TypId { unTypId ∷ Lid i }+  deriving (Typeable, Data, Eq, Ord, Bogus)++-- | Variable names+newtype VarId i = VarId { unVarId ∷ Lid i }+  deriving (Typeable, Data, Eq, Ord, Bogus)++-- | Data constructor names+newtype ConId i = ConId { unConId ∷ Uid i }+  deriving (Typeable, Data, Eq, Ord, Bogus)++-- | Module names+newtype ModId i = ModId { unModId ∷ Uid i }+  deriving (Typeable, Data, Eq, Ord, Bogus)++-- | Module type names+newtype SigId i = SigId { unSigId ∷ Uid i }+  deriving (Typeable, Data, Eq, Ord, Bogus)++-- | Qualified type names+type QTypId i = Q TypId i+-- | Qualified variable names+type QVarId i = Q VarId i+-- | Qualified data constructor names+type QConId i = Q ConId i+-- | Qualified module names+type QModId i = Q ModId i+-- | Qualified module type names+type QSigId i = Q SigId i++instance Id TypId where+  idName = idName . unTypId+  idTag  = idTag  . unTypId+  identT = TypId <$$> identT++instance Id VarId where+  idName = idName . unVarId+  idTag  = idTag  . unVarId+  identT = VarId <$$> identT++instance Id ConId where+  idName = idName . unConId+  idTag  = idTag  . unConId+  identT = ConId <$$> identT++instance Id ModId where+  idName = idName . unModId+  idTag  = idTag  . unModId+  identT = ModId <$$> identT++instance Id SigId where+  idName = idName . unSigId+  idTag  = idTag  . unSigId+  identT = SigId <$$> identT++--+-- Type variables+--++-- | Type variables include qualifiers+data TyVar i+  = TV {+      tvname :: !(Lid i),+      tvqual :: !QLit,+      tvloc  :: !Loc+    }+  | TVAnti Anti+  deriving (Typeable, Data)++tvUn, tvAf :: Tag i => String -> TyVar i+tvUn s = TV (ident s) Qu bogus+tvAf s = TV (ident s) Qa bogus++instance Tag i => Eq (TyVar i) where+  a == b = tvname a == tvname b && tvqual a == tvqual b++instance Tag i => Ord (TyVar i) where+  a `compare` b = tvname a `compare` tvname b+        `thenCmp` tvqual a `compare` tvqual b++instance Locatable (TyVar i) where+  getLoc TV { tvloc = loc } = loc+  getLoc _                  = bogus++instance Relocatable (TyVar i) where+  setLoc tv@TV { } loc = tv { tvloc = loc }+  setLoc tv        _   = tv++instance Tag i => Bogus (TyVar i) where+  bogus = TV bogus Qa bogus++instance Id TyVar where+  idName (TV n _ _)  = idName n+  idName (TVAnti a)  = antierror "idName" a+  idTag (TV n _ _)   = idTag n+  idTag (TVAnti a)   = antierror "idTag" a+  identT i n         = TV (identT i n) Qa bogus+  renId i (TV n q l) = TV (renId i n) q l+  renId _ (TVAnti a) = antierror "renId" a++---+--- 'Show' INSTANCES+---++instance Show (Lid i) where+  showsPrec _ (Lid _ s)   = showsIdent s+  showsPrec p (LidAnti a) = showsPrec p a++instance Show (Uid i) where+  showsPrec _ (Uid _ s@('?':_)) = showString s+  showsPrec _ (Uid _ s)         = showsIdent s+  showsPrec p (UidAnti a)       = showsPrec p a++-- | Show an identifier with parens if necessary+showsIdent ∷ String → ShowS+showsIdent s = case s of+  '_':_             -> (s++)+  c  :_ | isAlpha c -> (s++)+  c  :_ | isDigit c -> (s++)+  _  :_ | head s == '*' || last s == '*'+                    -> ("( "++) . (s++) . (" )"++)+  _                 -> ('(':) . (s++) . (')':)++instance Show (BIdent i) where+  showsPrec p (Var x) = showsPrec p x+  showsPrec p (Con k) = showsPrec p k++instance Show (TypId i) where showsPrec p = showsPrec p . unTypId+instance Show (VarId i) where showsPrec p = showsPrec p . unVarId+instance Show (ConId i) where showsPrec p = showsPrec p . unConId+instance Show (ModId i) where showsPrec p = showsPrec p . unModId+instance Show (SigId i) where showsPrec p = showsPrec p . unSigId++instance Show (TyVar i) where+  showsPrec _ (TV x Qu _)  = showString Strings.unlimited . showString (unLid x)+  showsPrec _ (TV x Qa _)  = showString Strings.affine . showString (unLid x)+  showsPrec _ (TVAnti a)   = showString Strings.affine . shows a++instance Viewable (Path (ModId i) (BIdent i)) where+  type View (Path (ModId i) (BIdent 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 Tag i => (:>:) (BIdent i) (Lid i) where liftKey = Var+instance Tag i => (:>:) (BIdent i) (Uid i) where liftKey = Con++---+--- Name generation+---++-- | Given a base name, produces the list of names starting with the+--   base name, then with a prime added, and then with numeric+--   subscripts increasing from 1.+namesFrom ∷ String → [String]+namesFrom s = [ c:n | n ← "" : map numberSubscript [0 ..], c ← s ]++-- | Given a natural number, represent it as a string of number+--   subscripts.+numberSubscript ∷ Int → String+numberSubscript 0  = [head Strings.digits]+numberSubscript n0+  | n0 < 0         = error "BUG! numberSubscript requires non-negative Int"+  | otherwise      = reverse $ List.unfoldr each n0 where+  each 0 = Nothing+  each n = Just (Strings.digits !! ones, rest)+             where (rest, ones) = n `divMod` 10++-- | Clear the primes and subscripts from the end of a name+clearScripts ∷ String → String+clearScripts n = case reverse (dropWhile (`elem` scripts) (reverse n)) of+  [] → n+  n' → n'+  where scripts = "'′" ++ Strings.unicodeDigits ++ Strings.asciiDigits++tvalphabet ∷ [String]+tvalphabet = namesFrom Strings.tvNames++-- | @freshName sugg qlit avoid cands@ attempts to generate a fresh+--   type variable name as follows:+--+--   * if @sugg@ is @Here n@, then it returns @n@ if @n@ is not in+--     @avoid@, and otherwise subscripts @n@ until if finds a fresh+--     name.+--+--   * Otherwise, return the first name from @cands@ that isn't in+--     @avoid@.+--+freshName ∷ Optional t ⇒ t String → [String] → [String] → String+freshName pn avoid cands = case coerceOpt pn of+  Just n+    | okay n    → n+    | otherwise → takeFrom (namesFrom (clearScripts n))+  Nothing       → takeFrom (cands ++ namesFrom "a")+  where+    avoidSet = S.fromList (Strings.normalizeChar <$$> avoid)+    takeFrom = head . filter okay+    okay n   = S.notMember (Strings.normalizeChar <$> n) avoidSet++-- | Like 'freshName', but produces a list of fresh names+freshNames ∷ Optional t ⇒ [t String] → [String] → [String] → [String]+freshNames []       _     _     = []+freshNames (pn:pns) avoid cands =+  let n' = freshName pn avoid cands+   in n' : freshNames pns (n':avoid) cands++---+--- SOME BUILT-IN NAMES+---++{-# INLINE internalPath #-}+internalPath  ∷ String+internalPath  = "INTERNALS.PrimTypes"++{-# INLINE internalName #-}+internalName  ∷ String → String+internalName  = (internalPath ++) . ('.':)++{-# INLINE internalIdent #-}+internalIdent ∷ (Id a, Tag i) ⇒ String → Q a i+internalIdent = qident . internalName++idUnitVal, idNilList, idConsList, idTrueValue, idFalseValue+            ∷ Tag i ⇒ QConId i+idNilRecord ∷ Tag i ⇒ QVarId i++idUnitVal    = internalIdent "()"+idNilRecord  = internalIdent "nilRecord"+idNilList    = internalIdent "[]"+idConsList   = internalIdent "::"+idTrueValue  = internalIdent "true"+idFalseValue = internalIdent "false"++---+--- FREE VARIABLES and OCCURRENCE ANALYSIS+---++-- | A count of maximum variables occurrences+type Occurrence = Int++-- | The qualifier bound for a given number of occurrences+occToQLit ∷ Occurrence → QLit+occToQLit n = if n > 1 then Qu else Qa++-- | 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 (QVarId i) Occurrence++-- | The free variables analysis+class Tag i => Fv a i | a -> i where+  fv :: a -> FvMap i++-- | The defined variables analysis+class Dv a i | a -> i where+  qdv :: a -> [QVarId i]+  dv  :: a -> [VarId i]++  qdv  = J [] <$$> dv+  dv a = [ v | J [] v <- qdv a ]++instance Dv (VarId i) i  where dv a = [a]+instance Dv (QVarId i) i where qdv a = [a]++instance Fv a i => Fv [a] i where+  fv = foldr (|*|) M.empty . map fv++instance Dv a i => Dv [a] i where+  qdv = concatMap qdv++instance Fv a i => Fv (Maybe a) i where+  fv = maybe mempty fv++instance Dv a i => Dv (Maybe a) i where+  qdv = maybe [] qdv++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+(|*|), (|+|) :: Tag i => FvMap i -> FvMap i -> FvMap i+(|*|) = M.unionWith (+)+(|+|) = M.unionWith max++(|-|) :: Tag i => FvMap i -> QVarId i -> FvMap i+(|-|)  = flip M.delete++(|--|) :: (Foldable f, Tag i) => FvMap i -> f (QVarId i) -> FvMap i+(|--|)  = foldr' M.delete+
+ src/AST/Ident.hs-boot view
@@ -0,0 +1,12 @@+module AST.Ident where++import Data.Data (Data, Typeable1)++class Tag i++data TyVar i++instance Typeable1 TyVar+instance Data i => Data (TyVar i)+instance Tag i   => Ord (TyVar i)+instance Tag i   => Eq (TyVar i)
+ src/AST/Kind.hs view
@@ -0,0 +1,261 @@+module AST.Kind (+  -- * Qualifiers and variance+  QLit(..), Variance(..),+  -- ** Qualifier expressions+  QExp, QExp'(..), qeLit, qeVar, qeAnti, qeJoin,+  -- ** Qualifier operations+  (\-\), elimQLit, qLitSigil,+  -- ** Variance operations+  isQVariance,++  -- * Modules+) where++import Util+import Meta.DeriveNotable+import Data.Lattice+import AST.Anti+import AST.Notable+import {-# SOURCE #-} AST.Ident+import qualified Syntax.Strings as Strings++import Prelude ()+import Data.Generics (Typeable, Data)++---+--- QUALIFIERS, VARIANCES+---++{- | Usage qualifier literals++  A+  |+  U++-}+data QLit+  -- | unlimited+  = Qu+  -- | affine+  | Qa+  deriving (Eq, Ord, Bounded, Typeable, Data)++type QExp i = Located QExp' i++-- | Usage qualifier expressions+data QExp' i+  -- | qualifier literal+  = QeLit QLit+  -- | type variable+  | QeVar (TyVar i)+  -- | join+  | QeJoin (QExp i) (QExp i)+  -- | antiquote+  | QeAnti Anti+  deriving (Typeable, Data)++deriveNotable ''QExp++{- |+Type constructor variance forms a seven point lattice, which keeps track+of both polarity and parameters that should be treated as qualifiers.+In particular, given a unary type constructor T with variance +, T S <:+T U when S <: U; but if T has variance Q+, then T S <: T U when+|S| ≤ |U|, where |⋅| gives the qualifier of a type.++       =+      /|\+     / | \+    /  |  \+   +  Q=   -+   | /  \  |+   |/    \ |+  Q+      Q-+    \     /+     \   /+      \ /+       0++-}+data Variance+  -- | 0+  = Omnivariant+  -- | Q++  | QCovariant+  -- | Q-+  | QContravariant+  -- | Q=+  | QInvariant+  -- | ++  | Covariant+  -- | -+  | Contravariant+  -- | =+  | Invariant+  deriving (Eq, Ord, Typeable, Data)++---+--- Order instances+---++instance Lattice QLit where+  Qa ⊔ _  = Qa+  Qu ⊔ ql = ql+  Qu ⊓ _  = Qu+  Qa ⊓ ql = ql+  Qa ⊑ Qu = False+  _  ⊑ _  = True++-- | Variances are a four point lattice with 'Invariant' on top and+--   'Omnivariant' on the bottom+instance Bounded Variance where+  minBound = Omnivariant+  maxBound = Invariant++instance Lattice Variance where+  Omnivariant    ⊔ v2             = v2+  v1             ⊔ Omnivariant    = v1+  QCovariant     ⊔ Covariant      = Covariant+  Covariant      ⊔ QCovariant     = Covariant+  QContravariant ⊔ Contravariant  = Contravariant+  Contravariant  ⊔ QContravariant = Contravariant+  v1             ⊔ v2+    | v1 == v2                    = v1+    | isQVariance v1 && isQVariance v2+                                  = QInvariant+    | otherwise                   = Invariant+  --+  Invariant      ⊓ v2             = v2+  v1             ⊓ Invariant      = v1+  QCovariant     ⊓ Covariant      = QCovariant+  Covariant      ⊓ QCovariant     = QCovariant+  QInvariant     ⊓ Covariant      = QCovariant+  Covariant      ⊓ QInvariant     = QCovariant+  QContravariant ⊓ Contravariant  = QContravariant+  Contravariant  ⊓ QContravariant = QContravariant+  QInvariant     ⊓ Contravariant  = QContravariant+  Contravariant  ⊓ QInvariant     = QContravariant+  QInvariant     ⊓ QCovariant     = QCovariant+  QCovariant     ⊓ QInvariant     = QCovariant+  QInvariant     ⊓ QContravariant = QContravariant+  QContravariant ⊓ QInvariant     = QContravariant+  v1             ⊓ v2+    | v1 == v2                    = v1+    | otherwise                   = Omnivariant+  --+  Omnivariant    ⊑ _              = True+  QCovariant     ⊑ Covariant      = True+  QContravariant ⊑ Contravariant  = True+  QCovariant     ⊑ QInvariant     = True+  QContravariant ⊑ QInvariant     = True+  _              ⊑ Invariant      = True+  v1             ⊑ v2             = v1 == v2++instance Bounded (QExp' i) where+  minBound = QeLit Qu+  maxBound = QeLit Qa++---+--- Other instances+---++instance Show QLit where+  showsPrec _ Qu = ('U':)+  showsPrec _ Qa = ('A':)++instance Show Variance where+  show Invariant      = Strings.invariant+  show Covariant      = Strings.covariant+  show Contravariant  = Strings.contravariant+  show Omnivariant    = Strings.omnivariant+  show QInvariant     = Strings.qinvariant+  show QCovariant     = Strings.qcovariant+  show QContravariant = Strings.qcontravariant++instance Monoid QLit where+  mempty  = minBound+  mappend = (⊔)++instance Monoid Variance where+  mempty  = minBound+  mappend = (⊔)++-- | Variances work like abstract sign arithmetic, where:+--    Omnivariant    = { 0 }+--    Covariant      = ℤ₊  = { 0, 1, 2, ... }+--    Contravariant  = ℤ₋  = { ..., -2, -1, 0 }+--    Invariant      = ℤ+--    QCovariant     = 2ℤ₊ = { 0, 2, 4, ... }+--    QContravariant = 2ℤ₋ = { ..., -4, -2, 0 }+--    QInvariant     = 2ℤ  = { ..., -4, -2, 0, 2, 4, ... }+--- In this view, addition gives the join for the variance lattice,+--  and multiplication gives the variance of composing type constructors+--  of the given variances (more or less).+instance Num Variance where+  (+) = (⊔)+  --+  Omnivariant    * _              = Omnivariant+  Covariant      * v2             = v2+  v1             * Covariant      = v1+  Contravariant  * v2             = negate v2+  v1             * Contravariant  = negate v1+  QCovariant     * v2             = v2 ⊓ QInvariant+  v1             * QCovariant     = v1 ⊓ QInvariant+  QContravariant * v2             = negate v2 ⊓ QInvariant+  v1             * QContravariant = negate v1 ⊓ QInvariant+  QInvariant     * _              = QInvariant+  _              * QInvariant     = QInvariant+  _              * _              = Invariant+  --+  abs Omnivariant               = Omnivariant+  abs v | isQVariance v         = QCovariant+        | otherwise             = Covariant+  --+  signum QCovariant             = Covariant+  signum QContravariant         = Contravariant+  signum QInvariant             = Invariant+  signum v                      = v+  --+  negate Covariant              = Contravariant+  negate Contravariant          = Covariant+  negate QCovariant             = QContravariant+  negate QContravariant         = QCovariant+  negate v                      = v+  --+  fromInteger i+    | i > 0     = if even i then QCovariant else Covariant+    | i < 0     = if even i then QContravariant else Contravariant+    | otherwise = Omnivariant++---+--- Operations+---++--+-- Qualifiers+--++-- | @a \-\ b@ is the least @c@ such that+--   @a ⊑ b ⊔ c@.  (This is sort of dual to a pseudocomplement.)+(\-\) ∷ QLit → QLit → QLit+Qa \-\ Qu = Qu+_  \-\ _  = Qu++elimQLit ∷ a → a → QLit → a+elimQLit u _ Qu = u+elimQLit _ a Qa = a++qLitSigil ∷ QLit → String+qLitSigil Qu = Strings.unlimited+qLitSigil Qa = Strings.affine++--+-- Variances+--++isQVariance ∷ Variance → Bool+isQVariance QCovariant     = True+isQVariance QContravariant = True+isQVariance QInvariant     = True+isQVariance _              = False+
+ src/AST/Lit.hs view
@@ -0,0 +1,16 @@+module AST.Lit (+  Lit(..)+) where++import AST.Anti++import Data.Generics (Typeable, Data)++-- | Literals+data Lit+  = LtInt Integer+  | LtChar Char+  | LtStr String+  | LtFloat Double+  | LtAnti Anti+  deriving (Eq, Typeable, Data)
+ src/AST/Notable.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TypeFamilies #-}+module AST.Notable (+  Notable(..), N(..), Located,+  LocNote(..), module Data.Loc+) where++import Data.Data++import Data.Loc+import Util.Viewable++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/AST/Patt.hs view
@@ -0,0 +1,165 @@+module AST.Patt (+  -- * Patterns+  Patt'(..), Patt, PattNote(..), newPatt,+  -- ** Constructors+  paWild, paVar, paCon, paPair, paLit, paAs, paInj, paAnn,+  paBang, paRec, paAnti,+  -- ** Synthetic pattern constructors+  paChar, paStr, paInt, paFloat, paUnit, paCons, paNil,+  ToPatt(..),+) where++import Util+import Meta.DeriveNotable+import AST.Notable+import AST.Anti+import AST.Ident+import AST.Lit+import AST.Type++import Prelude ()+import Data.Generics (Typeable, Data)++type Patt i = N (PattNote i) (Patt' i)++-- | Patterns+data Patt' i+  -- | wildcard+  = PaWild+  -- | variable pattern+  | PaVar (VarId i)+  -- | datacon, possibly with parameter, possibly an exception+  | PaCon (QConId 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) (VarId i)+  -- | open variant+  | PaInj (Uid i) (Maybe (Patt i))+  -- | type annotation on a pattern+  | PaAnn (Patt i) (Type i)+  -- | record pattern+  | PaRec (Uid i) (Patt i) (Patt i)+  -- | imperative/threaded binding+  | PaBang (Patt i)+  -- | antiquote+  | PaAnti Anti+  deriving (Typeable, Data)++data PattNote i+  = PattNote {+      -- | source location+      ploc_  :: !Loc,+      -- | defined variables+      pdv_   :: [VarId 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 mempty++newPatt :: Tag i => Patt' i -> Patt i+newPatt p0 = flip N p0 $ case p0 of+  PaWild           ->+    newNote {+      pdv_    = mempty+    }+  PaVar x          ->+    newNote {+      pdv_    = [x]+    }+  PaCon _ mx       ->+    newNote {+      pdv_    = maybe mempty dv mx+    }+  PaPair x y       ->+    newNote {+      pdv_    = dv x `mappend` dv y+    }+  PaLit _          ->+    newNote {+      pdv_    = mempty+    }+  PaAs x y         ->+    newNote {+      pdv_    = dv x ++ [y]+    }+  PaInj _ my       ->+    newNote {+      pdv_    = maybe mempty dv my+    }+  PaAnn x _        ->+    newNote {+      pdv_    = dv x+    }+  PaRec _ x y      ->+    newNote {+      pdv_    = dv x `mappend` dv y+    }+  PaBang x         ->+    newNote {+      pdv_    = dv x+    }+  PaAnti a         ->+    newNote {+      pdv_    = antierror "dv" a+    }++instance Dv (N (PattNote i) a) i where+  dv = pdv_ . noteOf++deriveNotable 'newPatt (''Tag, [0]) ''Patt++paChar :: Tag i => Char -> Patt i+paChar = paLit . LtChar++paStr :: Tag i => String -> Patt i+paStr  = paLit . LtStr++paInt :: (Tag i, Integral a) => a -> Patt i+paInt  = paLit . LtInt . toInteger++paFloat :: Tag i => Double -> Patt i+paFloat  = paLit . LtFloat++paUnit :: Tag i => Patt i+paUnit  = paCon idUnitVal Nothing++paCons :: Tag i => Patt i -> Patt i -> Patt i+paCons  = paCon idConsList . Just <$$> paPair++paNil  :: Tag i => Patt i+paNil   = paCon idNilList Nothing++class ToPatt a i | a → i where+  toPatt ∷ a → Patt i++instance ToPatt (Patt i) i where+  toPatt = id++instance Tag i ⇒ ToPatt (VarId i) i where+  toPatt = paVar++instance (Tag i, ToPatt a i, ToPatt b i) ⇒ ToPatt (a, b) i where+  toPatt (a, b) = paPair (toPatt a) (toPatt b)++instance Tag i ⇒ ToPatt String i where+  toPatt = paStr++instance Tag i ⇒ ToPatt Int i where+  toPatt = paInt++instance Tag i ⇒ ToPatt Char i where+  toPatt = paChar++instance Tag i ⇒ ToPatt Double i where+  toPatt = paFloat+
+ src/AST/SyntaxTable.hs view
@@ -0,0 +1,185 @@+module AST.SyntaxTable where++import Meta.THHelpers+import AST.Anti+import AST.Notable+import AST.Ident+import AST.Kind+import AST.Type+import AST.Lit+import AST.Patt+import AST.Expr+import AST.Decl++import qualified Data.Map as M+import qualified Language.Haskell.TH as TH++litAntis, pattAntis,+  exprAntis, bindingAntis, caseAltAntis, fieldAntis,+  typeAntis, tyPatAntis, quantAntis, qExpAntis, tyVarAntis,+  declAntis, tyDecAntis, absTyAntis, modExpAntis,+  sigExpAntis, sigItemAntis,+  lidAntis, uidAntis,+  typIdAntis, varIdAntis, conIdAntis, modIdAntis, sigIdAntis,+  qlidAntis, quidAntis,+  qtypIdAntis, qvarIdAntis, qconIdAntis, qmodIdAntis, qsigIdAntis,+  idAntis, noAntis+    :: AntiDict++litAntis+  = "lit"    =:  Nothing+  & "str"    =:< 'LtStr+  & "int"    =:< 'LtInt+  & "flo"    =:< 'LtFloat+  & "float"  =:< 'LtFloat+  & "char"   =:< 'LtChar+  & "antiL"  =:< 'LtAnti+pattAntis+  = "patt"   =:! Nothing+  & "anti"   =:< 'PaAnti+exprAntis+  = "expr"   =:! Nothing+  & "anti"   =:< 'ExAnti+bindingAntis+  = "bind"   =:! Nothing+  & "antiB"  =:< 'BnAnti+caseAltAntis+  = "case"   =:  Nothing+  & "antiC"  =:< 'CaAnti+fieldAntis+  = "field"  =:  Nothing+  & "antiF"  =:< 'FdAnti+typeAntis+  = "type"   =:! Nothing+  & "anti"   =:< 'TyAnti+tyPatAntis+  = "typat"  =:! Nothing+  & "antiP"  =:< 'TpAnti+quantAntis+  = "quant"  =:  Nothing+  & "antiQ"  =:< 'QuantAnti+qExpAntis+  = "qexp"   =:! Nothing+  & "qlit"   =:< 'QeLit+  & "qvar"   =:< 'QeVar+  & "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"   =:•• (['ident], ['Lid])+  & "antiLid"=:< 'LidAnti+uidAntis+  = "uid"    =:  Nothing+  & "uname"  =:•• (['ident], ['Uid])+  & "antiUid"=:< 'LidAnti+typIdAntis+  = "tid"    =:  Nothing+  & "lid"    =:< 'TypId+  & "lname"  =:•• (['ident], ['TypId, 'Lid])+  & "antiTI" =:• ['TypId, 'LidAnti]+varIdAntis+  = "vid"    =:  Nothing+  & "lid"    =:< 'VarId+  & "lname"  =:•• (['ident], ['VarId, 'Lid])+  & "antiVI" =:• ['VarId, 'LidAnti]+conIdAntis+  = "cid"    =:  Nothing+  & "uid"    =:< 'ConId+  & "uname"  =:•• (['ident], ['ConId, 'Uid])+  & "antiCI" =:• ['ConId, 'UidAnti]+modIdAntis+  = "mid"    =:  Nothing+  & "uid"    =:< 'ModId+  & "uname"  =:•• (['ident], ['SigId, 'Uid])+  & "antiMI" =:• ['ModId, 'UidAnti]+sigIdAntis+  = "sid"    =:  Nothing+  & "uid"    =:< 'SigId+  & "uname"  =:•• (['ident], ['SigId, 'Uid])+  & "antiSI" =:• ['SigId, 'UidAnti]+qlidAntis+  = "qlid"   =:  Nothing+  & "qname"  =:  appFun 'qident -- error in pattern context+quidAntis+  = "quid"   =:  Nothing+  & "quname" =:  appFun 'qident -- error in pattern context+qtypIdAntis+  = "qtid"   =:  Nothing+  & "qname"  =:  appFun 'qident -- error in pattern context+qvarIdAntis+  = "qvid"   =:  Nothing+  & "qname"  =:  appFun 'qident -- error in pattern context+qconIdAntis+  = "qcid"   =:  Nothing+  & "quname" =:  appFun 'qident -- error in pattern context+qmodIdAntis+  = "qmid"   =:  Nothing+  & "quname" =:  appFun 'qident -- error in pattern context+qsigIdAntis+  = "qsid"   =:  Nothing+  & "quname" =:  appFun 'qident -- 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       >: (''Tag, [0])+  , ''Lit     =:: 'LtAnti    $: 'litAntis+  , ''Patt    =:: 'PaAnti    $: 'pattAntis    !: 'newPatt    >: (''Tag, [0])+  , ''Expr    =:: 'ExAnti    $: 'exprAntis    !: 'newExpr    >: (''Tag, [0])+  , ''Binding =:: 'BnAnti    $: 'bindingAntis !: 'newBinding >: (''Tag, [0])+  , ''CaseAlt =:: 'CaAnti    $: 'caseAltAntis !: 'newCaseAlt >: (''Tag, [0])+  , ''Field   =:: 'FdAnti    $: 'fieldAntis   !: 'newField   >: (''Tag, [0])+  , ''Type    =:: 'TyAnti    $: 'typeAntis    !: 'newN+  , ''TyPat   =:: 'TpAnti    $: 'tyPatAntis   !: 'newN+  , ''Quant   =:: 'QuantAnti $: 'quantAntis+  , ''QExp    =:: 'QeAnti    $: 'qExpAntis    !: 'newN+  , ''TyVar   =:: 'TVAnti    $: 'tyVarAntis+  , ''Decl    =:: 'DcAnti    $: 'declAntis    !: 'newDecl    >: (''Tag, [0])+  , ''TyDec   =:: 'TdAnti    $: 'tyDecAntis   !: 'newN+  , ''AbsTy   =:: 'AbsTyAnti $: 'absTyAntis   !: 'newN+  , ''ModExp  =:: 'MeAnti    $: 'modExpAntis  !: 'newModExp  >: (''Tag, [0])+  , ''SigExp  =:: 'SeAnti    $: 'sigExpAntis  !: 'newSigExp  >: (''Tag, [0])+  , ''SigItem =:: 'SgAnti    $: 'sigItemAntis !: 'newSigItem >: (''Tag, [0])+  , ''Lid     =:: 'LidAnti   $: 'lidAntis+  , ''Uid     =:: 'UidAnti   $: 'uidAntis+  , ''TypId   =:: ['TypId, 'LidAnti] $: 'typIdAntis+  , ''VarId   =:: ['VarId, 'LidAnti] $: 'varIdAntis+  , ''ConId   =:: ['ConId, 'UidAnti] $: 'conIdAntis+  , ''ModId   =:: ['ModId, 'UidAnti] $: 'modIdAntis+  , ''SigId   =:: ['SigId, 'UidAnti] $: 'sigIdAntis+  , ''QLid    =:: '()+  , ''QUid    =:: '()+  , ''QTypId  =:: '()+  , ''QVarId  =:: '()+  , ''QConId  =:: '()+  , ''QModId  =:: '()+  , ''QSigId  =:: '()+  , ''Ident   =:: '()+  ]+
+ src/AST/Type.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE TypeFamilies #-}+module AST.Type (+  -- * Types+  Quant(..), Type'(..), Type, TyPat'(..), TyPat,+  -- ** Constructors+  tyApp, tyVar, tyFun, tyQu, tyMu, tyRow, tyAnti,+  tpVar, tpApp, tpRow, tpAnti,+  TyAppN(..),++  -- * Built-in types+  tyUnit, tyRowEnd, tyVariant, tyRecord, tyRowDots, tyRowMap, tyRowHole,+  tyTuple, tyUn, tyAf,+  -- ** Type construtor names+  tnUnit, tnRowEnd, tnVariant, tnRecord, tnRowDots, tnRowMap, tnRowHole,+  tnTuple, tnUn, tnAf,+  -- ** Convenience constructors+  tyArr, tyLol,+  tyAll, tyEx,+  tyRecordAdditive, tyRecordMultiplicative,++  -- * Miscellany+  dumpType+) where++import Util+import Meta.DeriveNotable+import AST.Notable+import AST.Anti+import AST.Kind+import AST.Ident+import qualified Syntax.Strings as Strings++import Prelude ()+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  (QTypId i) [Type i]+  | TyVar  (TyVar i)+  | TyFun  (Type i) (Maybe (QExp i)) (Type i)+  | TyQu   Quant (TyVar i) (Type i)+  | TyMu   (TyVar i) (Type i)+  | TyRow  (Uid i) (Type 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 (QTypId i) [TyPat i]+  -- | each element of a row+  | TpRow (TyVar i) Variance+  -- | 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++tyArr         :: Type i -> Type i -> Type i+tyArr          = tyFun <-> Nothing++tyLol         :: Type i -> Type i -> Type i+tyLol          = tyFun <-> Just maxBound++infixr 8 `tyArr`, `tyLol`++instance Show Quant where+  show Forall        = Strings.all+  show Exists        = Strings.ex+  show (QuantAnti a) = show a++---+--- Built-in types+---++-- | Names of built-in types+tnUnit, tnRowEnd, tnVariant, tnRecord, tnRowDots, tnRowMap, tnRowHole,+  tnTuple, tnUn, tnAf :: String++tnUnit         = "INTERNALS.PrimTypes.unit"+tnRowEnd       = "INTERNALS.PrimTypes.rowend"+tnVariant      = "INTERNALS.PrimTypes.variant"+tnRecord       = "INTERNALS.PrimTypes.record"+tnRowDots      = "rowdots#"+tnRowMap       = "rowmap#"+tnRowHole      = "rowhole#"+tnTuple        = "INTERNALS.PrimTypes.*"+tnUn           = "INTERNALS.PrimTypes.unlimited"+tnAf           = "INTERNALS.PrimTypes.affine"++--- Convenience constructors++-- Types++-- | Class defining variadic function 'tyAppN' for constructing+--   type constructor applications.+class TyApp' r i ⇒ TyAppN n r i | r → i where+  tyAppN ∷ n → r++instance TyApp' r i ⇒ TyAppN (Path (ModId i) (TypId i)) r i where+  tyAppN ql = tyApp' ql []++instance TyApp' r i ⇒ TyAppN (TypId i) r i where+  tyAppN l = tyApp' (J [] l) []++instance (Tag i, TyApp' r i) ⇒ TyAppN String r i where+  tyAppN s = tyApp' (qident s) []++-- | Helper class for @TyApp'@.+class TyApp' r i | r → i where+  tyApp' ∷ QTypId i → [Type i] → r++instance TyApp' (Type i) i where+  tyApp' = tyApp++instance (TyApp' r i, a ~ Type i) ⇒ TyApp' (a → r) i where+  tyApp' ql ts t = tyApp' ql (ts++[t])++tyUnit        :: Tag i => Type i+tyUnit         = tyAppN tnUnit++tyRowEnd      :: Tag i => Type i+tyRowEnd       = tyAppN tnRowEnd++tyVariant     :: Tag i => Type i -> Type i+tyVariant      = tyAppN tnVariant++tyRecord      :: Tag i => Type i -> Type i -> Type i+tyRecord       = tyAppN tnRecord++tyRowDots     :: Tag i => Type i -> Type i+tyRowDots      = tyAppN tnRowDots++tyRowMap      :: Tag i => Type i -> Type i -> Type i+tyRowMap       = tyAppN tnRowMap++tyRowHole     :: Tag i => Type i -> Type i+tyRowHole      = tyAppN tnRowHole++tyTuple       :: Tag i => Type i -> Type i -> Type i+tyTuple        = tyAppN tnTuple++tyUn          :: Tag i => Type i+tyUn           = tyAppN tnUn++tyAf          :: Tag i => Type i+tyAf           = tyAppN tnAf++tyRecordAdditive, tyRecordMultiplicative :: Tag i => Type i -> Type i+tyRecordAdditive       = tyRecord tyAf+tyRecordMultiplicative = tyRecord tyUn++---+--- Debugging+---++-- | Noisy type printer for debugging+dumpType :: Tag i => Int -> Type i -> IO ()+dumpType i0 nt0 = do+  putStr (replicate i0 ' ')+  noIndent i0 nt0+  where+  noIndent i nt@(N _ t0) =+    case t0 of+      TyApp n ps -> do+        putStrLn $ show n ++ " {"+        mapM_ (dumpType (i + 2)) ps+        putStrLn (replicate i ' ' ++ "}")+      TyFun dom mq cod -> do+        putStrLn $ case mq of+          Just q  -> "-[" ++ dumpQExp q ++ "]> {"+          Nothing -> "-> {"+        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 ' ' ++ "}")+      TyRow _ _ _ -> do+        putStr "ro"+        dumpRow (i + 2) 'w' nt+      TyAnti a -> do+        print a+  --+  dumpRow i c (N _ (TyRow n t1 t2)) = do+    let lab = show n+    putStr (c:' ':lab++": ")+    noIndent (i + length lab + 4) t1+    putStr (replicate i ' ')+    dumpRow i '|' t2+  dumpRow i c t = do+    putStr (c:" ")+    noIndent (i + 2) t+  --+  dumpQExp (N _ q0) = case q0 of+    QeLit ql       → show ql+    QeVar tv       → show tv+    QeJoin qe1 qe2 → dumpQExp qe1 ++ ',' : dumpQExp qe2+    QeAnti _       → "ANTI"+
+ src/AST/TypeAnnotation.hs view
@@ -0,0 +1,148 @@+-- | For treating syntactic types as type annotations.+module AST.TypeAnnotation (+  Annot, HasAnnotations(..),+) where++import Util+import AST+import Meta.Quasi++import Prelude ()+import qualified Data.Map as M+import qualified Data.Set as S++-- | A type annotation is merely a syntactic type+type Annot i = Type i++-- | Find out the free variables of a type annotation.  Minimal+--   definition: @annotFtvMap@+class Tag i ⇒ HasAnnotations a i | a → i where+  -- | Accumulate information about type variables.+  annotFtvMap   ∷ (TyVar i → r) →+                  (QTypId i → Int → r → r) →+                  (r → r → r) →+                  a →+                  M.Map (TyVar i) r+  -- | Just the set of type variables, please.+  annotFtvSet   ∷ a → S.Set (TyVar i)+  annotFtvSet   = M.keysSet . annotFtvMap (\_ → ()) (\_ _ () → ()) (\_ _ → ())++-- | Shorter-named alias+afm ∷ HasAnnotations a i ⇒+      (TyVar i → r) →+      (QTypId i → Int → r → r) →+      (r → r → r) →+      a →+      M.Map (TyVar i) r+afm = annotFtvMap++--+-- Generic instances+--++instance (HasAnnotations a i, HasAnnotations b i) ⇒+         HasAnnotations (a, b) i where+  annotFtvMap var con cmb (a, b) =+    M.unionWith cmb (afm var con cmb a) (afm var con cmb b)++instance (HasAnnotations a i, HasAnnotations b i, HasAnnotations c i) ⇒+         HasAnnotations (a, b, c) i where+  annotFtvMap var con cmb (a, b, c) = afm var con cmb (a, (b, c))++instance HasAnnotations a i ⇒ HasAnnotations [a] i where+  annotFtvMap var con cmb = M.unionsWith cmb . map (afm var con cmb)++instance HasAnnotations a i ⇒ HasAnnotations (Maybe a) i where+  annotFtvMap var con cmb = maybe mempty (afm var con cmb)++instance HasAnnotations a i ⇒ HasAnnotations (N note a) i where+  annotFtvMap = afm <$$$.> dataOf++--+-- Specific instances for syntax.+--++instance Tag i ⇒ HasAnnotations (TyVar i) i where+  annotFtvMap _   _ _ (TVAnti a) = $antierror+  annotFtvMap var _ _ tv         = M.singleton tv (var tv)++instance Tag i ⇒ HasAnnotations (QExp' i) i where+  annotFtvMap var con cmb qe0 = case qe0 of+    [qeQ|' $qlit:_   |]           → mempty+    [qeQ|'  '$tv |]               → afm var con cmb tv+    [qeQ|' $qe1 ⋁ $qe2 |]         → afm var con cmb (qe1, qe2)+    [qeQ|' $anti:a |]             → $antierror++instance Tag i ⇒ HasAnnotations (Type' i) i where+  annotFtvMap var con cmb t0 = case t0 of+    [ty|' ($list:ts) $qtid:ql |]  →+      M.unionsWith cmb+        [ con ql ix <$> afm var con cmb t+        | t  ← ts+        | ix ← [ 0 .. ] ]+    [ty|'  '$tv |]                → afm var con cmb tv+    [ty|' $t1 -[$opt:qe]> $t2 |]  →+      let t1m = con (qident "->") 0 <$> afm var con cmb t1+          qem = con (qident "->") 1 <$> afm var con cmb qe+          t2m = con (qident "->") 2 <$> afm var con cmb t2+       in M.unionsWith cmb [t1m, qem, t2m]+    [ty|' $quant:_ `$tv. $t |]    → M.delete tv $ afm var con cmb t+    [ty|' μ `$tv. $t |]           → M.delete tv $ afm var con cmb t+    [ty|' `$uid:_ of $t1 | $t2 |] → afm var con cmb (t1, t2)+    [ty|' $anti:a |]              → $antierror++instance Tag i => HasAnnotations (Patt' i) i where+  annotFtvMap var con cmb x0 = case x0 of+    [pa|' _ |]                  → mempty+    [pa|' $lid:_ |]             → mempty+    [pa|' $qcid:_ $opt:mx |]    → afm var con cmb mx+    [pa|' ($x, $y) |]           → afm var con cmb (x, y)+    [pa|' $lit:_ |]             → mempty+    [pa|' $x as $vid:_ |]       → afm var con cmb x+    [pa|' `$uid:_ $opt:mx |]    → afm var con cmb mx+    [pa|' $x : $t |]            → afm var con cmb (x, t)+    [pa|' {$uid:_ = $x | $y} |] → afm var con cmb (x, y)+    [pa|' ! $x |]               → afm var con cmb x+    [pa|' $anti:a |]            → $antierror++instance Tag i ⇒ HasAnnotations (Expr' i) i where+  annotFtvMap var con cmb e0 = case e0 of+    [ex|' $qvid:_ |]            → mempty+    [ex|' $lit:_ |]             → mempty+    [ex|' $qcid:_ $opt:me |]    → afm var con cmb me+    [ex|' let $x = $e in $e' |] → afm var con cmb (x, e, e')+    [ex|' match $e with $list:cas |]+                                → afm var con cmb (e, cas)+    [ex|' let rec $list:bns in $e |]+                                → afm var con cmb (bns, e)+    [ex|' let $decl:_ in $e |]  → afm var con cmb e+    [ex|' ($e1, $e2) |]         → afm var con cmb (e1, e2)+    [ex|' λ $x → $e |]          → afm var con cmb (x, e)+    [ex|' $e1 $e2 |]            → afm var con cmb (e1, e2)+    [ex|' `$uid:_ $opt:me |]    → afm var con cmb me+    [ex|' #$uid:_ $e |]         → afm var con cmb e+    [ex|' { $list:flds | $e2 } |]+                                → afm var con cmb (flds, e2)+    [ex|' {+ $list:flds | $e2 +} |]+                                → afm var con cmb (flds, e2)+    [ex|' $e1.$uid:_ |]         → afm var con cmb e1+    [ex|' $e : $t |]            → afm var con cmb (e, t)+    [ex|' $e :> $t |]           → afm var con cmb (e, t)+    [ex|' $anti:a |]            → $antierror++instance Tag i ⇒ HasAnnotations (CaseAlt' i) i where+  annotFtvMap var con cmb ca0 = case ca0 of+    [caQ|' $x → $e |]           → afm var con cmb (x, e)+    [caQ|' #$uid:_ $opt:mx → $e |]+                                → afm var con cmb (mx, e)+    [caQ|' $antiC:a |]          → $antierror++instance Tag i ⇒ HasAnnotations (Binding' i) i where+  annotFtvMap var con cmb bn0 = case bn0 of+    [bnQ|' $lid:_ = $e |]       → afm var con cmb  e+    [bnQ|' $antiB:a |]          → $antierror++instance Tag i ⇒ HasAnnotations (Field' i) i where+  annotFtvMap var con cmb bn0 = case bn0 of+    [fdQ|' $uid:_ = $e |]       → afm var con cmb  e+    [fdQ|' $antiF:a |]          → $antierror
+ src/Alt/Graph.hs view
@@ -0,0 +1,147 @@+-- | A wrapper around the fgs graph library.+module Alt.Graph (+  Gr, ShowGraph(..),+  trcnr, untransitive, nmLab, labelNode, labScc,+  pathScc, erdffWith, xpdffWith, xpdfWith,+  labComponents, labNodeEdges,+  module Data.Graph.Inductive.Basic,+  module Data.Graph.Inductive.Graph,+  module Data.Graph.Inductive.Query.DFS,+  module Data.Graph.Inductive.Query.TransClos,+  module NM,+) where+++-- Mine:+import Util+import Alt.NodeMap as NM++import Prelude ()+import qualified Data.List as List+import qualified Data.Tree as Tree++-- From fgs:+import Data.Graph.Inductive.PatriciaTree (Gr)+import Data.Graph.Inductive.Basic+import Data.Graph.Inductive.Graph+import Data.Graph.Inductive.Query.DFS+import Data.Graph.Inductive.Query.TransClos++-- | Transitive, non-reflexive closure+trcnr ∷ DynGraph gr ⇒ gr a b → gr a ()+trcnr g = insEdges newEdges (insNodes lns empty) where+  lns      = labNodes g+  newEdges = [ (n, n', ())+             | (n, _) ← lns+             , n'     ← reachable n g+             , n /= n' ]++-- | Compute the transitive reduction of a transitive, acyclic graph.+untransitive ∷ DynGraph gr ⇒ gr a b → gr a b+untransitive g = foldl' eachEdge g (edges g) where+  eachEdge g' (n1, n2) = foldl' eachSuc g' (suc g' n1) where+    eachSuc g'' n' =+      if n' /= n1 && n' /= n2 && n2 `elem` suc g'' n'+        then delEdge (n1, n2) g''+        else g''++-- | Look up the node index of a node label+nmLab ∷ Ord a ⇒ NM.NodeMap a → a → Node+nmLab = fst <$$> NM.mkNode_++labelNode ∷ Graph gr ⇒ gr a b → Node → LNode a+labelNode g n = case lab g n of+  Just ln → (n, ln)+  Nothing → error "labelNode: node not found"++labScc ∷ Graph gr ⇒ gr a b → [[LNode a]]+labScc g = map preorder (rdffWith labNode' (topsort g) g)++pathScc ∷ Graph gr ⇒ gr a b → [Either (LNode a) [(LNode a, b)]]+pathScc g = map (addCycle . preorder) (erdffWith labNode' (topsort g) g)+  where+  addCycle [((n, a), Nothing)] =+    case lookup n (lpre g n) of+      Just b  → Right [((n, a), b)]+      Nothing → Left (n, a)+  addCycle (((n, a), Nothing):rest) =+    case catMaybes [ lookup n' (lsuc g n) | ((n', _), _) ← rest ] of+      b:_  → Right (((n, a), b) : map (second fromJust) rest)+      []   → error "pathScc: bug!"+  addCycle _ = error "pathScc: bug!"++erdffWith ∷ Graph gr ⇒+            CFun a b c → [Node] → gr a b → [Tree.Tree (c, Maybe b)]+erdffWith = xpdffWith (map (second Just) . lpre') <$.> map (\n → (n, Nothing))++rdffWith ∷ Graph gr ⇒ CFun a b c → [Node] → gr a b → [Tree.Tree c]+rdffWith = xdffWith pre'++_g ∷ Gr Int String+_g = mkGraph ns es where+  ns = (id &&& id) <$> [0 .. 20]+  es = map addLab $+         [ (0,5), (1,5), (2,5), (3,5), (4,5),+           (0,6), (1,6), (2,6), (3,6), (4,6),+           (5,7), (6,7), (5,8), (6,8),+           (7,9), (8,9), (7,10), (8,10),+           (9,0), (9,1), (9,2), (9,3), (9,4),+           (10,0), (10,1), (10,2), (10,3), (10,4)+         ]+  addLab (i, j) = (i, j, show i ++ "->" ++ show j)++-- | A generalized, path-sensitive depth-first forest.  Along with+--   each starting node, it takes a value to associate with that node,+--   and the next-finding function produces new values to go with+--   each node as well.+xpdffWith ∷ Graph gr ⇒+           CFun a b [(Node, d)] → CFun a b c →+           [(Node, d)] → gr a b → [Tree.Tree (c, d)]+xpdffWith = fst <$$$$> xpdfWith++xpdfWith ∷ Graph gr ⇒+           CFun a b [(Node, d)] → CFun a b c →+           [(Node, d)] → gr a b → ([Tree.Tree (c, d)], gr a b)+xpdfWith _ _ []     g             = ([],g)+xpdfWith _ _ _      g | isEmpty g = ([],g)+xpdfWith d f ((v,e):vs) g =+  case match v g of+    (Nothing, g1) → xpdfWith d f vs g1+    (Just c, g1)  → (Tree.Node (f c, e) ts:ts', g3)+      where (ts, g2)  = xpdfWith d f (d c) g1+            (ts', g3) = xpdfWith d f vs g2++-- | Partition a graph into components of /labeled/ nodes+labComponents ∷ Graph gr ⇒ gr a b → [[LNode a]]+labComponents = componentsWith labNode'+  where+  udffWith ∷ Graph gr ⇒ CFun a b c → [Node] → gr a b → [Tree.Tree c]+  udffWith = xdffWith neighbors'+  --+  udffWith' ∷ Graph gr ⇒ CFun a b c → gr a b → [Tree.Tree c]+  udffWith' f g = udffWith f (nodes g) g+  --+  componentsWith ∷ Graph gr ⇒ CFun a b c → gr a b → [[c]]+  componentsWith = preorder <$$$> udffWith'++-- | Get the edges of a graph as pairs of node labels+labNodeEdges ∷ Graph gr ⇒ gr n e → [(n, n)]+labNodeEdges g =+  [ (α, β)+  | (n1, n2) ← edges g+  , let Just α = lab g n1+  , let Just β = lab g n2+  ]++-- | For showing graphs+newtype ShowGraph gr v = ShowGraph { unShowGraph ∷ gr v () }++instance (Graph gr, Show v) ⇒ Show (ShowGraph gr v) where+  showsPrec _ (ShowGraph gr) =+    showChar '{' .+    foldr (.) id+      (List.intersperse (showString ", ")+         [ shows n1 . showString "<" . shows n2+         | (n1, n2) ← labNodeEdges gr ])+    . showChar '}'+
+ src/Alt/NodeMap.hs view
@@ -0,0 +1,151 @@+-- | A generalization of @Data.Graph.Inductive.NodeMap@ from the fgs package+module Alt.NodeMap (+  MonadNM(..),+  module Data.Graph.Inductive.NodeMap,+) where++import Data.Graph.Inductive (DynGraph, LNode, LEdge, insNode, lab)+import Data.Graph.Inductive.NodeMap+  hiding (mkNodeM, mkNodesM, mkEdgeM, mkEdgesM,+          insMapNodeM, insMapEdgeM, delMapNodeM, delMapEdgeM,+          insMapNodesM, insMapEdgesM, delMapNodesM, delMapEdgesM)+import Control.Monad.State.Lazy as Lazy+import Control.Monad.State.Strict as Strict+import Control.Monad.Reader+import Control.Monad.Writer.Lazy as Lazy+import Control.Monad.Writer.Strict as Strict+import Control.Monad.RWS.Lazy as Lazy+import Control.Monad.RWS.Strict as Strict+import Control.Arrow++insNewMapNode ∷ (Ord a, DynGraph gr) ⇒+                NodeMap a → a → gr a b → (gr a b, NodeMap a, LNode a)+insNewMapNode nm a gr = (gr', nm', node) where+  (node@(n, _), nm') = mkNode nm a+  gr'                = maybe (insNode node gr) (const gr) (lab gr n)++insNewMapNodes ∷ (Ord a, DynGraph gr) ⇒+                 NodeMap a → [a] → gr a b → (gr a b, NodeMap a, [LNode a])+insNewMapNodes nm []     gr = (gr, nm, [])+insNewMapNodes nm (a:as) gr = (gr'', nm'', node:nodes) where+  (gr',  nm',  node)  = insNewMapNode nm a gr+  (gr'', nm'', nodes) = insNewMapNodes nm' as gr'++class (Ord a, DynGraph g, Monad m) ⇒+      MonadNM a b g m | m → a b g where+  putNMState    ∷ (NodeMap a, g a b) → m ()+  putNodeMap    ∷ NodeMap a → m ()+  putGraph      ∷ g a b → m ()+  getNMState    ∷ m (NodeMap a, g a b)+  getNodeMap    ∷ m (NodeMap a)+  getGraph      ∷ m (g a b)+  --+  modifyNMState ∷ ((NodeMap a, g a b) → (NodeMap a, g a b)) → m ()+  modifyNodeMap ∷ (NodeMap a → NodeMap a) → m ()+  modifyGraph   ∷ (g a b → g a b) → m ()+  getsNMState   ∷ ((NodeMap a, g a b) → r) → m r+  getsNodeMap   ∷ (NodeMap a → r) → m r+  getsGraph     ∷ (g a b → r) → m r+  --+  putNMState (nm, g) = putNodeMap nm >> putGraph g+  putNodeMap nm = modifyNMState (first (const nm))+  putGraph gr   = modifyNMState (second (const gr))+  getNMState    = liftM2 (,) getNodeMap getGraph+  getNodeMap    = getsNMState fst+  getGraph      = getsNMState snd+  modifyNMState = getsNMState >=> putNMState+  modifyNodeMap = getsNMState . first >=> putNMState+  modifyGraph   = getsNMState . second >=> putNMState+  getsNMState f = liftM f getNMState+  getsNodeMap f = liftM (f . fst) getNMState+  getsGraph f   = liftM (f . snd) getNMState+  --+  modifyNMG   ∷ (NodeMap a → g a b → (g a b, NodeMap a, r)) → m r+  modifyNMG f = do+    (nm, g) ← getNMState+    let (g', nm', r) = f nm g+    putNMState (nm', g')+    return r+  --+  modifyG     ∷ (NodeMap a → g a b → g a b) → m ()+  modifyG f   = do+    (nm, g) ← getNMState+    putGraph (f nm g)+  --+  modifyNM    ∷ (NodeMap a → (r, NodeMap a)) → m r+  modifyNM f  = do+    nm ← getNodeMap+    let (r, nm') = f nm+    putNodeMap nm'+    return r+  --+  mkNodeM         ∷ a → m (LNode a)+  mkNodesM        ∷ [a] → m [LNode a]+  mkEdgeM         ∷ (a, a, b) → m (Maybe (LEdge b))+  mkEdgesM        ∷ [(a, a, b)] → m (Maybe [LEdge b])+  insMapNodeM     ∷ a → m (LNode a)+  insNewMapNodeM  ∷ a → m (LNode a)+  insMapEdgeM     ∷ (a, a, b) → m ()+  delMapNodeM     ∷ a → m ()+  delMapEdgeM     ∷ (a, a) → m ()+  insMapNodesM    ∷ [a] → m [LNode a]+  insNewMapNodesM ∷ [a] → m [LNode a]+  insMapEdgesM    ∷ [(a, a, b)] → m ()+  delMapNodesM    ∷ [a] → m ()+  delMapEdgesM    ∷ [(a, a)] → m ()+  mkNodeM         = modifyNM . flip mkNode+  mkNodesM        = modifyNM . flip mkNodes+  mkEdgeM e       = getsNMState (flip mkEdge e . fst)+  mkEdgesM es     = getsNMState (flip mkEdges es . fst)+  insMapNodeM     = modifyNMG . flip insMapNode+  insNewMapNodeM  = modifyNMG . flip insNewMapNode+  insMapEdgeM     = modifyG . flip insMapEdge+  delMapNodeM     = modifyG . flip delMapNode+  delMapEdgeM     = modifyG . flip delMapEdge+  insMapNodesM    = modifyNMG . flip insMapNodes+  insNewMapNodesM = modifyNMG . flip insNewMapNodes+  insMapEdgesM    = modifyG . flip insMapEdges+  delMapNodesM    = modifyG . flip delMapNodes+  delMapEdgesM    = modifyG . flip delMapEdges++instance MonadNM a b g m ⇒ MonadNM a b g (ReaderT r m) where+  getNMState = lift getNMState+  putNMState = lift . putNMState++instance (MonadNM a b g m, Monoid w) ⇒ MonadNM a b g (Strict.WriterT w m) where+  getNMState = lift getNMState+  putNMState = lift . putNMState++instance (MonadNM a b g m, Monoid w) ⇒ MonadNM a b g (Lazy.WriterT w m) where+  getNMState = lift getNMState+  putNMState = lift . putNMState++instance MonadNM a b g m ⇒ MonadNM a b g (Strict.StateT s m) where+  getNMState = lift getNMState+  putNMState = lift . putNMState++instance MonadNM a b g m ⇒ MonadNM a b g (Lazy.StateT s m) where+  getNMState = lift getNMState+  putNMState = lift . putNMState++instance (MonadNM a b g m, Monoid w) ⇒ MonadNM a b g (Strict.RWST r w s m) where+  getNMState = lift getNMState+  putNMState = lift . putNMState++instance (MonadNM a b g m, Monoid w) ⇒ MonadNM a b g (Lazy.RWST r w s m) where+  getNMState = lift getNMState+  putNMState = lift . putNMState++---+--- Instances+---++instance (Ord a, DynGraph g, Monad m) ⇒+         MonadNM a b g (Strict.StateT (NodeMap a, g a b) m) where+  getNMState = get+  putNMState = put++instance (Ord a, DynGraph g, Monad m) ⇒+         MonadNM a b g (Lazy.StateT (NodeMap a, g a b) m) where+  getNMState = get+  putNMState = put
+ src/Alt/Parsec.hs view
@@ -0,0 +1,21 @@+module Alt.Parsec (+  module Text.ParserCombinators.Parsec,+) where++import Text.ParserCombinators.Parsec hiding ((<|>), many, optional)++#if PARSEC_VERSION == 2+import qualified Text.ParserCombinators.Parsec as Parsec+import Control.Applicative+import Control.Monad++-- | Parsec parsers are Applicatives, which lets us write slightly+--   more pleasant, non-monadic-looking parsers+instance Applicative (GenParser a b) where+  pure  = return+  (<*>) = ap++instance Alternative (GenParser a b) where+  empty = pzero+  (<|>) = (Parsec.<|>)+#endif
+ src/Alt/PrettyPrint.hs view
@@ -0,0 +1,189 @@+{- | A layer over 'P.Doc' for propagating context information.  (I think+     Template Haskell has a version of this.) -}+module Alt.PrettyPrint (+  -- * Environment-parameterized pretty-printing document+  Doc(..),+  -- ** Environment operations+  mapD, askD, asksD, localD,+  -- * Document combinators+  -- ** Binary operations+  ($$), ($+$), (<+>), (<>),+  -- ** Unary operations+  braces, brackets, doubleQuotes, quotes, parens,+  -- ** List operations+  cat, fcat, fsep, hcat, hsep, sep, vcat,+  -- ** Miscellaneous operations+  nest, hang, punctuate,+  -- ** Nullary operations (documents)+  colon, comma, equals, lbrace, lbrack,+  lparen, rbrace, rbrack, rparen, semi, space,+  -- *** Unary functions returning documents+  char, double, float, int, integer, ptext, rational, text, zeroWidthText,+  -- * Rendering and queries+  toDocIn, isEmptyIn, renderIn, renderStyleIn, fullRenderIn,+  toDoc, isEmpty, render, renderStyle, fullRender,+  -- ** Rendering constants+  P.Mode(..), P.Style(..), P.TextDetails(..), P.style,+  -- * Module exports+  module Data.Monoid,+) where++import qualified Text.PrettyPrint as P+import Control.Applicative+import Data.Monoid++-- Document parameterized by type @e@.+newtype Doc e = Doc { unDoc :: e -> P.Doc }++--+-- Environment manipulation+--++mapD     :: (e' -> e) -> Doc e -> Doc e'+mapD f d  = Doc (unDoc d . f)++askD     :: (e -> Doc e) -> Doc e+askD f    = Doc (unDoc <$> f <*> id)++asksD    :: (e -> a) -> (a -> Doc e) -> Doc e+asksD g f = askD (f . g)++localD   :: e' -> Doc e' -> Doc e+localD    = mapD . const++--+-- Lifts+--++liftD0   :: P.Doc -> Doc e+liftD0    = Doc . const++liftD    :: (P.Doc -> P.Doc) -> Doc e -> Doc e+liftD f d = Doc (f <$> unDoc d)++liftD2 :: (P.Doc -> P.Doc -> P.Doc) ->+            Doc e -> Doc e -> Doc e+liftD2 f d1 d2 = Doc (f <$> unDoc d1 <*> unDoc d2)++liftDList :: ([P.Doc] -> P.Doc) -> [Doc e] -> Doc e+liftDList f ds = Doc (\e -> f [ d e | Doc d <- ds ])++--+-- Pretty-printing combinators+--++($$), ($+$), (<+>), (<>) :: Doc e -> Doc e -> Doc e+($$)   = liftD2 (P.$$)+($+$)  = liftD2 (P.$+$)+(<+>)  = liftD2 (P.<+>)+(<>)   = liftD2 (P.<>)++infixl 5 $$, $+$+infixl 6 <+>, <>++braces, brackets, doubleQuotes, parens, quotes :: Doc e -> Doc e+braces       = liftD P.braces+brackets     = liftD P.brackets+doubleQuotes = liftD P.doubleQuotes+quotes       = liftD P.quotes+parens       = liftD P.parens++nest      :: Int -> Doc e -> Doc e+nest         = liftD . P.nest++hang      :: Doc e -> Int -> Doc e -> Doc e+hang d1 n    = liftD2 (flip P.hang n) d1++punctuate :: Doc e -> [Doc e] -> [Doc e]+punctuate _  []     = []+punctuate _  [d]    = [d]+punctuate d1 (d:ds) = d<>d1 : punctuate d1 ds++cat, fcat, fsep, hcat, hsep, sep, vcat :: [Doc e] -> Doc e+cat   = liftDList P.cat+fcat  = liftDList P.fcat+fsep  = liftDList P.fsep+hcat  = liftDList P.hcat+hsep  = liftDList P.hsep+sep   = liftDList P.sep+vcat  = liftDList P.vcat++char            :: Char -> Doc e+double          :: Double -> Doc e+float           :: Float -> Doc e+int             :: Int -> Doc e+integer         :: Integer -> Doc e+ptext           :: String -> Doc e+rational        :: Rational -> Doc e+text            :: String -> Doc e+zeroWidthText   :: String -> Doc e++char             = liftD0 . P.char+double           = liftD0 . P.double+float            = liftD0 . P.float+int              = liftD0 . P.int+integer          = liftD0 . P.integer+ptext            = liftD0 . P.ptext+rational         = liftD0 . P.rational+text             = liftD0 . P.text+zeroWidthText    = liftD0 . P.zeroWidthText++colon, comma, equals, lbrace, lbrack, lparen, rbrace,+  rbrack, rparen, semi, space :: Doc e+colon   = liftD0 P.colon+comma   = liftD0 P.comma+equals  = liftD0 P.equals+lbrace  = liftD0 P.lbrace+lbrack  = liftD0 P.lbrack+lparen  = liftD0 P.lparen+rbrace  = liftD0 P.rbrace+rbrack  = liftD0 P.rbrack+rparen  = liftD0 P.rparen+semi    = liftD0 P.semi+space   = liftD0 P.space++--+-- Rendering and queries+--++toDocIn :: e -> Doc e -> P.Doc+toDocIn  = flip unDoc++isEmptyIn :: e -> Doc e -> Bool+isEmptyIn e = P.isEmpty . toDocIn e++renderIn :: e -> Doc e -> String+renderIn e  = P.render . toDocIn e++renderStyleIn :: e -> P.Style -> Doc e -> String+renderStyleIn e sty = P.renderStyle sty . toDocIn e++fullRenderIn :: e ->+                P.Mode -> Int -> Float ->+                (P.TextDetails -> a -> a) -> a ->+                Doc e -> a+fullRenderIn e mode cols ribbon f z =+  P.fullRender mode cols ribbon f z . toDocIn e++toDoc    :: Monoid e => Doc e -> P.Doc+toDoc     = toDocIn mempty++isEmpty :: Monoid e => Doc e -> Bool+isEmpty  = isEmptyIn mempty++render :: Monoid e => Doc e -> String+render  = renderIn mempty++renderStyle :: Monoid e => P.Style -> Doc e -> String+renderStyle = renderStyleIn mempty++fullRender :: Monoid e =>+              P.Mode -> Int -> Float ->+              (P.TextDetails -> a -> a) -> a ->+              Doc e -> a+fullRender = fullRenderIn mempty++instance Monoid (Doc e) where+  mempty   = liftD0 P.empty+  mappend  = (<>)+  mconcat  = hcat
+ src/Alt/Token.hs view
@@ -0,0 +1,493 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-+  This is a modified version of the Parsec module whose copyright is+  below, which supports figuring out where a token has ended *before*+  ensuing whitespace.++  In particular, it defines a type class for functionally updating the+  state with a SourcePos, and then lexeme always stashes the position+  there before discarding whitespace.+-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec.Token+-- Copyright   :  (c) Daan Leijen 1999-2001+-- License     :  BSD-style (see the file libraries/parsec/LICENSE)+--+-- Maintainer  :  daan@cs.uu.nl+-- Stability   :  provisional+-- Portability :  non-portable (uses existentially quantified data constructors)+--+-- A helper module to parse lexical elements (tokens).+--+-----------------------------------------------------------------------------++module Alt.Token+                  ( TokenEnd (..)+                  , LanguageDef (..)+                  , TokenParser (..)+                  , makeTokenParser+                  ) where++import Data.Char (isAlpha,toLower,toUpper,isSpace,digitToInt)+import Data.List (nub,sort)+import Text.ParserCombinators.Parsec++class TokenEnd st where+  saveTokenEnd :: CharParser st ()++instance TokenEnd () where+  saveTokenEnd  = return ()++-----------------------------------------------------------+-- Language Definition+-----------------------------------------------------------+data LanguageDef st+    = LanguageDef+    { commentStart   :: String+    , commentEnd     :: String+    , commentLine    :: String+    , nestedComments :: Bool+    , identStart     :: CharParser st Char+    , identLetter    :: CharParser st Char+    , opStart        :: CharParser st Char+    , opLetter       :: CharParser st Char+    , reservedNames  :: [String]+    , reservedOpNames:: [String]+    , caseSensitive  :: Bool+    }++-----------------------------------------------------------+-- A first class module: TokenParser+-----------------------------------------------------------+data TokenParser st+    = TokenParser{ identifier       :: CharParser st String+                 , reserved         :: String -> CharParser st ()+                 , operator         :: CharParser st String+                 , reservedOp       :: String -> CharParser st ()++                 , charLiteral      :: CharParser st Char+                 , stringLiteral    :: CharParser st String+                 , natural          :: CharParser st Integer+                 , integer          :: CharParser st Integer+                 , float            :: CharParser st Double+                 , naturalOrFloat   :: CharParser st (Either Integer Double)+                 , decimal          :: CharParser st Integer+                 , hexadecimal      :: CharParser st Integer+                 , octal            :: CharParser st Integer++                 , symbol           :: String -> CharParser st String+                 , lexeme           :: forall a. CharParser st a -> CharParser st a+                 , whiteSpace       :: CharParser st ()++                 , parens           :: forall a. CharParser st a -> CharParser st a+                 , braces           :: forall a. CharParser st a -> CharParser st a+                 , angles           :: forall a. CharParser st a -> CharParser st a+                 , brackets         :: forall a. CharParser st a -> CharParser st a+                 -- "squares" is deprecated+                 , squares          :: forall a. CharParser st a -> CharParser st a++                 , semi             :: CharParser st String+                 , comma            :: CharParser st String+                 , colon            :: CharParser st String+                 , dot              :: CharParser st String+                 , semiSep          :: forall a . CharParser st a -> CharParser st [a]+                 , semiSep1         :: forall a . CharParser st a -> CharParser st [a]+                 , commaSep         :: forall a . CharParser st a -> CharParser st [a]+                 , commaSep1        :: forall a . CharParser st a -> CharParser st [a]+                 }++-----------------------------------------------------------+-- Given a LanguageDef, create a token parser.+-----------------------------------------------------------+makeTokenParser :: TokenEnd st => LanguageDef st -> TokenParser st+makeTokenParser languageDef+    = TokenParser{ identifier = identifier+                 , reserved = reserved+                 , operator = operator+                 , reservedOp = reservedOp++                 , charLiteral = charLiteral+                 , stringLiteral = stringLiteral+                 , natural = natural+                 , integer = integer+                 , float = float+                 , naturalOrFloat = naturalOrFloat+                 , decimal = decimal+                 , hexadecimal = hexadecimal+                 , octal = octal++                 , symbol = symbol+                 , lexeme = lexeme+                 , whiteSpace = whiteSpace++                 , parens = parens+                 , braces = braces+                 , angles = angles+                 , brackets = brackets+                 , squares = brackets+                 , semi = semi+                 , comma = comma+                 , colon = colon+                 , dot = dot+                 , semiSep = semiSep+                 , semiSep1 = semiSep1+                 , commaSep = commaSep+                 , commaSep1 = commaSep1+                 }+    where++    -----------------------------------------------------------+    -- Bracketing+    -----------------------------------------------------------+    parens p        = between (symbol "(") (symbol ")") p+    braces p        = between (symbol "{") (symbol "}") p+    angles p        = between (symbol "<") (symbol ">") p+    brackets p      = between (symbol "[") (symbol "]") p++    semi            = symbol ";"+    comma           = symbol ","+    dot             = symbol "."+    colon           = symbol ":"++    commaSep p      = sepBy p comma+    semiSep p       = sepBy p semi++    commaSep1 p     = sepBy1 p comma+    semiSep1 p      = sepBy1 p semi+++    -----------------------------------------------------------+    -- Chars & Strings+    -----------------------------------------------------------+    -- charLiteral :: CharParser st Char+    charLiteral     = lexeme (between (char '\'')+                                      (char '\'' <?> "end of character")+                                      characterChar )+                    <?> "character"++    characterChar   = charLetter <|> charEscape+                    <?> "literal character"++    charEscape      = do{ char '\\'; escapeCode }+    charLetter      = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))++++    -- stringLiteral :: CharParser st String+    stringLiteral   = lexeme (+                      do{ str <- between (char '"')+                                         (char '"' <?> "end of string")+                                         (many stringChar)+                        ; return (foldr (maybe id (:)) "" str)+                        }+                      <?> "literal string")++    -- stringChar :: CharParser st (Maybe Char)+    stringChar      =   do{ c <- stringLetter; return (Just c) }+                    <|> stringEscape+                    <?> "string character"++    stringLetter    = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))++    stringEscape    = do{ char '\\'+                        ;     do{ escapeGap  ; return Nothing }+                          <|> do{ escapeEmpty; return Nothing }+                          <|> do{ esc <- escapeCode; return (Just esc) }+                        }++    escapeEmpty     = char '&'+    escapeGap       = do{ many1 space+                        ; char '\\' <?> "end of string gap"+                        }++++    -- escape codes+    escapeCode      = charEsc <|> charNum <|> charAscii <|> charControl+                    <?> "escape code"++    -- charControl :: CharParser st Char+    charControl     = do{ char '^'+                        ; code <- upper+                        ; return (toEnum (fromEnum code - fromEnum 'A'))+                        }++    -- charNum :: CharParser st Char+    charNum         = do{ code <- decimal+                                  <|> do{ char 'o'; number 8 octDigit }+                                  <|> do{ char 'x'; number 16 hexDigit }+                        ; return (toEnum (fromInteger code))+                        }++    charEsc         = choice (map parseEsc escMap)+                    where+                      parseEsc (c,code)     = do{ char c; return code }++    charAscii       = choice (map parseAscii asciiMap)+                    where+                      parseAscii (asc,code) = try (do{ string asc; return code })+++    -- escape code tables+    escMap          = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")+    asciiMap        = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)++    ascii2codes     = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",+                       "FS","GS","RS","US","SP"]+    ascii3codes     = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",+                       "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",+                       "CAN","SUB","ESC","DEL"]++    ascii2          = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',+                       '\EM','\FS','\GS','\RS','\US','\SP']+    ascii3          = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',+                       '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',+                       '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']+++    -----------------------------------------------------------+    -- Numbers+    -----------------------------------------------------------+    -- naturalOrFloat :: CharParser st (Either Integer Double)+    naturalOrFloat  = lexeme (natFloat) <?> "number"++    float           = lexeme floating   <?> "float"+    integer         = lexeme int        <?> "integer"+    natural         = lexeme nat        <?> "natural"+++    -- floats+    floating        = do{ n <- decimal+                        ; fractExponent n+                        }+++    natFloat        = do{ char '0'+                        ; zeroNumFloat+                        }+                      <|> decimalFloat++    zeroNumFloat    =  do{ n <- hexadecimal <|> octal+                         ; return (Left n)+                         }+                    <|> decimalFloat+                    <|> fractFloat 0+                    <|> return (Left 0)++    decimalFloat    = do{ n <- decimal+                        ; option (Left n)+                                 (fractFloat n)+                        }++    fractFloat n    = do{ f <- fractExponent n+                        ; return (Right f)+                        }++    fractExponent n = do{ fract <- fraction+                        ; expo  <- option 1.0 exponent'+                        ; return ((fromInteger n + fract)*expo)+                        }+                    <|>+                      do{ expo <- exponent'+                        ; return ((fromInteger n)*expo)+                        }++    fraction        = do{ char '.'+                        ; digits <- many1 digit <?> "fraction"+                        ; return (foldr op 0.0 digits)+                        }+                      <?> "fraction"+                    where+                      op d f    = (f + fromIntegral (digitToInt d))/10.0++    exponent'       = do{ oneOf "eE"+                        ; f <- sign+                        ; e <- decimal <?> "exponent"+                        ; return (power (f e))+                        }+                      <?> "exponent"+                    where+                       power e  | e < 0      = 1.0/power(-e)+                                | otherwise  = fromInteger (10^e)+++    -- integers and naturals+    int             = do{ f <- lexeme sign+                        ; n <- nat+                        ; return (f n)+                        }++    -- sign            :: CharParser st (Integer -> Integer)+    sign            =   (char '-' >> return negate)+                    <|> (char '+' >> return id)+                    <|> return id++    nat             = zeroNumber <|> decimal++    zeroNumber      = do{ char '0'+                        ; hexadecimal <|> octal <|> decimal <|> return 0+                        }+                      <?> ""++    decimal         = number 10 digit+    hexadecimal     = do{ oneOf "xX"; number 16 hexDigit }+    octal           = do{ oneOf "oO"; number 8 octDigit  }++    -- number :: Integer -> CharParser st Char -> CharParser st Integer+    number base baseDigit+        = do{ digits <- many1 baseDigit+            ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits+            ; seq n (return n)+            }++    -----------------------------------------------------------+    -- Operators & reserved ops+    -----------------------------------------------------------+    reservedOp name =+        lexeme $ try $+        do{ string name+          ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)+          }++    operator =+        lexeme $ try $+        do{ name <- oper+          ; if (isReservedOp name)+             then unexpected ("reserved operator " ++ show name)+             else return name+          }++    oper =+        do{ c <- (opStart languageDef)+          ; cs <- many (opLetter languageDef)+          ; return (c:cs)+          }+        <?> "operator"++    isReservedOp name =+        isReserved (sort (reservedOpNames languageDef)) name+++    -----------------------------------------------------------+    -- Identifiers & Reserved words+    -----------------------------------------------------------+    reserved name =+        lexeme $ try $+        do{ caseString name+          ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)+          }++    caseString name+        | caseSensitive languageDef  = string name+        | otherwise               = do{ walk name; return name }+        where+          walk []     = return ()+          walk (c:cs) = do{ caseChar c <?> msg; walk cs }++          caseChar c  | isAlpha c  = char (toLower c) <|> char (toUpper c)+                      | otherwise  = char c++          msg         = show name+++    identifier =+        lexeme $ try $+        do{ name <- ident+          ; if (isReservedName name)+             then unexpected ("reserved word " ++ show name)+             else return name+          }+++    ident+        = do{ c <- identStart languageDef+            ; cs <- many (identLetter languageDef)+            ; return (c:cs)+            }+        <?> "identifier"++    isReservedName name+        = isReserved theReservedNames caseName+        where+          caseName      | caseSensitive languageDef  = name+                        | otherwise               = map toLower name+++    isReserved names name+        = scan names+        where+          scan []       = False+          scan (r:rs)   = case (compare r name) of+                            LT  -> scan rs+                            EQ  -> True+                            GT  -> False++    theReservedNames+        | caseSensitive languageDef  = sortedNames+        | otherwise               = map (map toLower) sortedNames+        where+          sortedNames   = sort (reservedNames languageDef)++++    -----------------------------------------------------------+    -- White space & symbols+    -----------------------------------------------------------+    symbol name+        = lexeme (string name)++    lexeme p+        = do+            x <- p+            saveTokenEnd+            whiteSpace+            return x+++    --whiteSpace+    whiteSpace+        | noLine && noMulti  = skipMany (simpleSpace <?> "")+        | noLine             = skipMany (simpleSpace <|> multiLineComment <?> "")+        | noMulti            = skipMany (simpleSpace <|> oneLineComment <?> "")+        | otherwise          = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")+        where+          noLine  = null (commentLine languageDef)+          noMulti = null (commentStart languageDef)+++    simpleSpace =+        skipMany1 (satisfy isSpace)++    oneLineComment =+        do{ try (string (commentLine languageDef))+          ; skipMany (satisfy (/= '\n'))+          ; return ()+          }++    multiLineComment =+        do { try (string (commentStart languageDef))+           ; inComment+           }++    inComment+        | nestedComments languageDef  = inCommentMulti+        | otherwise                = inCommentSingle++    inCommentMulti+        =   do{ try (string (commentEnd languageDef)) ; return () }+        <|> do{ multiLineComment                     ; inCommentMulti }+        <|> do{ skipMany1 (noneOf startEnd)          ; inCommentMulti }+        <|> do{ oneOf startEnd                       ; inCommentMulti }+        <?> "end of comment"+        where+          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)++    inCommentSingle+        =   do{ try (string (commentEnd languageDef)); return () }+        <|> do{ skipMany1 (noneOf startEnd)         ; inCommentSingle }+        <|> do{ oneOf startEnd                      ; inCommentSingle }+        <?> "end of comment"+        where+          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)+
src/Basis.hs view
@@ -1,21 +1,15 @@ -- | 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 Value (Valuable(..), Value(..), VRecord(..))+import AST import Type -import qualified Loc-import qualified Syntax.Notable-import qualified Syntax.Decl+import qualified Data.Loc  import qualified Basis.IO import qualified Basis.Socket@@ -25,11 +19,13 @@ import qualified Basis.MVar import qualified Basis.Future import qualified Basis.Array+import qualified Basis.Row  import qualified IO import qualified System.Environment as Env import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef) import System.Random (randomIO)+import System.Exit (exitWith, ExitCode(..)) import Data.Typeable  -- Primitive operations implemented in Haskell@@ -42,145 +38,170 @@     --- 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,+    "unit"      `primtype` tcUnit,+    "exn"       `primtype` tcExn,+    "int"       `primtype` tcInt,+    "char"      `primtype` tcChar,+    "float"     `primtype` tcFloat,+    "string"    `primtype` tcString,+    "unlimited" `primtype` tcUn,+    "affine"    `primtype` tcAf,+    "*"         `primtype` tcTuple,+    "record"    `primtype` tcRecord,+    "variant"   `primtype` tcVariant,+    "rowend"    `primtype` tcRowEnd,+    "rowdots#"  `primtype` tcRowDots, -- Needed by renamer+    "\\/"       `primtype` tcJoin,+    "->"        `primtype` tcFun, -    -- Sums-    dec [$dc| type `a option = None | Some of `a |],-    dec [$dc| type `a + `b = Left of `a | Right of `b |],+    -- Bool needs to be known to the parser for if expression+    dec [sgQ| type bool = false | true |], -    -- Lists-    dec [$dc| type `a list = Nil | Cons of `a * `a list |],+    -- Lists need to be known by the parser for list syntax+    dec [sgQ| type `a list = [] | (::) of `a * `a list |], +    submod "INTERNALS" [+      submod "PrimTypes" [+        dec [sgQ| type unit      = type unit |],+        dec [sgQ| type variant   = type variant |],+        dec [sgQ| type record    = type record |],+        dec [sgQ| type rowend    = type rowend |],+        dec [sgQ| type unlimited = type unlimited |],+        dec [sgQ| type affine    = type affine |],+        dec [sgQ| type bool      = type bool |],+        dec [sgQ| type list      = type list |],+        val "nilRecord" -: [ty| (unlimited, rowend) record |]+          -= MultiplicativeRecord []+      ]+    ],++    -- Sums+    dec [sgQ| type `a option = None | Some of `a |],+    dec [sgQ| type `a + `b = Left of `a | Right of `b |],+     -- Arithmetic     binArith "+" (+),     binArith "-" (-),     binArith "*" (*),     binArith "/" div,     binArith "%" mod,-    fun "~" -: [$ty| int -> int |]+    fun "~" -: [ty| int -> int |]       -= (negate :: Integer -> Integer),-    fun "abs" -: [$ty| int -> int |]+    fun "abs" -: [ty| int -> int |]       -= (abs :: Integer -> Integer) ,-    fun "<=" -: [$ty| int -> int -> bool |]+    fun "<=" -: [ty| int -> int -> bool |]       -= ((<=) :: Integer -> Integer -> Bool),-    fun "string_of_int" -: [$ty| int -> string |]+    fun "string_of_int" -: [ty| int -> string |]       -= (show :: Integer -> String),-    fun "int_of_string" -: [$ty| string -> int |]+    fun "int_of_string" -: [ty| string -> int |]       -= (read :: String -> Integer),-    fun "random_int" -: [$ty| unit -> int |]+    fun "random_int" -: [ty| unit -> int |]       -= \() -> (randomIO :: IO Int),      -- Floating point arithmetic-    fun "<=." -: [$ty| float -> float -> bool |]+    fun "<=." -: [ty| float -> float -> bool |]       -= ((<=) :: Double -> Double -> Bool),-    fun "<." -: [$ty| float -> float -> bool |]+    fun "<." -: [ty| float -> float -> bool |]       -= ((<) :: Double -> Double -> Bool),-    fun "+." -: [$ty| float -> float -> float |]+    fun "+." -: [ty| float -> float -> float |]       -= ((+) :: Double -> Double -> Double),-    fun "-." -: [$ty| float -> float -> float |]+    fun "-." -: [ty| float -> float -> float |]       -= ((-) :: Double -> Double -> Double),-    fun "*." -: [$ty| float -> float -> float |]+    fun "*." -: [ty| float -> float -> float |]       -= ((*) :: Double -> Double -> Double),-    fun "/." -: [$ty| float -> float -> float |]+    fun "/." -: [ty| float -> float -> float |]       -= ((/) :: Double -> Double -> Double),-    fun "**" -: [$ty| float -> float -> float |]+    fun "**" -: [ty| float -> float -> float |]       -= ((**) :: Double -> Double -> Double),-    fun "~." -: [$ty| float -> float |]+    fun "~." -: [ty| float -> float |]       -= (negate :: Double -> Double),-    fun "sqrt" -: [$ty| float -> float |]+    fun "sqrt" -: [ty| float -> float |]       -= (sqrt :: Double -> Double),-    fun "log" -: [$ty| float -> float |]+    fun "log" -: [ty| float -> float |]       -= (log :: Double -> Double),-    fun "absf" -: [$ty| float -> float |]+    fun "absf" -: [ty| float -> float |]       -= (abs :: Double -> Double),-    fun "float_of_int" -: [$ty| int -> float |]+    fun "float_of_int" -: [ty| int -> float |]       -= (fromIntegral :: Integer -> Double),-    fun "int_of_float" -: [$ty| float -> int |]+    fun "int_of_float" -: [ty| float -> int |]       -= (round :: Double -> Integer),-    fun "string_of_float" -: [$ty| float -> string |]+    fun "string_of_float" -: [ty| float -> string |]       -= (show :: Double -> String),-    fun "float_of_string" -: [$ty| string -> float |]+    fun "float_of_string" -: [ty| string -> float |]       -= (read :: String -> Double),      -- Strings-    fun "explode"  -: [$ty| string -> char list |]-      -= map char2integer,-    fun "implode"  -: [$ty| char list -> string |]-      -= map integer2char,-    fun "^" -: [$ty| string -> string -> string |]+    fun "explode"  -: [ty| string -> char list |]+      -= (map vinj ∷ String → [Value]),+    fun "implode"  -: [ty| char list -> string |]+      -= (map vprj ∷ [Value] → String),+    fun "^" -: [ty| string -> string -> string |]       -= ((++) :: String -> String -> String),-    fun "string_of" -: [$ty| all 'a. 'a -> string |]+    fun "string_of" -: [ty| all 'a. 'a -> string |]       -= (return . show :: Value -> IO String),-    fun "string_length" -: [$ty| string -> int |]+    fun "string_length" -: [ty| string -> int |]       -= \s -> toInteger (length (s :: String)),      -- "Magic" equality and print; failure-    fun "==" -: [$ty| all 'a. 'a -> 'a -> bool |]+    fun "==" -: [ty| all 'a. 'a -> 'a -> bool |]       -= ((==) :: Value -> Value -> Bool),-    fun "print" -: [$ty| all 'a. 'a -> unit |]+    fun "print" -: [ty| all 'a. 'a -> unit |]       -= (print :: Value -> IO ()),      -- I/O-    fun "putChar"  -: [$ty| char -> unit |]+    fun "putChar"  -: [ty| char -> unit |]       -= putChar . integer2char,-    fun "getChar"  -: [$ty| unit -> char |]+    fun "getChar"  -: [ty| unit -> char |]       -= \() -> fmap char2integer getChar,-    fun "flush"    -: [$ty| unit -> unit |]+    fun "flush"    -: [ty| unit -> unit |]       -= \() -> IO.hFlush IO.stdout,-    fun "putStr"   -: [$ty| string -> unit |]+    fun "putStr"   -: [ty| string -> unit |]       -= putStr,-    fun "putStrLn" -: [$ty| string -> unit |]+    fun "putStrLn" -: [ty| string -> unit |]       -= putStrLn,-    fun "getLine"  -: [$ty| unit -> string |]+    fun "getLine"  -: [ty| unit -> string |]       -= \() -> getLine, -    -- The environment-    fun "getArgs" -: [$ty| unit -> string list |]+    -- System and the environment+    fun "getArgs" -: [ty| unit -> string list |]       -= \() -> Env.getArgs,-    fun "getProgName" -: [$ty| unit -> string |]+    fun "getProgName" -: [ty| unit -> string |]       -= \() -> Env.getProgName,-    fun "getEnv" -: [$ty| string -> string |]+    fun "getEnv" -: [ty| string -> string |]       -= Env.getEnv,-    fun "getEnvironment" -: [$ty| unit -> (string * string) list |]+    fun "getEnvironment" -: [ty| unit -> (string * string) list |]       -= \() -> Env.getEnvironment,+    fun "exit" -: [ty| ∀ `a. int -> `a |]+      -= \z ->+           exitWith (if z == 0 then ExitSuccess else ExitFailure z) ∷ IO (),      -- References-    dec [$dc| type `a ref qualifier U |],-    dec [$dc| type `a aref qualifier A |],-    fun "ref" -: [$ty| all `a. `a -> `a ref |]+    dec [sgQ| type `a ref qualifier U |],+    dec [sgQ| 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 |]+    fun "aref" -: [ty| all `a. `a -> `a aref |]       -= (\v -> Ref `fmap` newIORef v), -    fun "!" -: [$ty| all 'a. 'a ref -> 'a |]+    fun "!" -: [ty| all 'a. 'a ref -> 'a |]       -= (\r -> readIORef (unRef r)),-    fun "!!" -: [$ty| all 'a. 'a aref -> 'a aref * 'a |]+    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 -> `a |]+    fun "<-" -: [ty| all `a. `a ref -> `a -> `a |]       -= (\r v -> do            atomicModifyIORef (unRef r) (\v' -> (v, v'))),-    fun "<-!" -: [$ty| all `a `b. `a aref ->+    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 |]+      fun "unsafeCoerce" -: [ty| all `b `a. `a -> `b |]         -= (id :: Value -> Value),-      fun "unsafeDup" -: [$ty| all `a. `a -> `a * `a |]+      fun "unsafeDup" -: [ty| all `a. `a -> `a * `a |]         -= ((\v -> (v, v)) :: Value -> (Value, Value))     ], @@ -193,7 +214,8 @@     submod "Prim" [       submod "Socket" Basis.Socket.entries,       submod "Exn"    Basis.Exn.entries,-      submod "Array"  Basis.Array.entries+      submod "Array"  Basis.Array.entries,+      submod "Row"     Basis.Row.entries     ]   ]
src/Basis/Array.hs view
@@ -1,17 +1,12 @@-{-# LANGUAGE-      DeriveDataTypeable,-      QuasiQuotes #-} module Basis.Array (entries) where  import Data.Typeable (Typeable) import BasisUtils-import Syntax+import AST import Util import Value (Value, Valuable(..)) -import qualified Loc-import qualified Syntax.Notable-import qualified Syntax.Decl+import qualified Data.Loc  import qualified Data.Array.IO as A @@ -27,23 +22,23 @@  entries :: [Entry Raw] entries  = [-    dec [$dc| type `a array |],-    fun "build" -: [$ty| all `a. int -> (int -> `a) -> `a array |]+    dec [sgQ| 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 |]+    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 |]+    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 |]+    fun "get" -: [ty| all 'a. 'a array -> int -> 'a |]       -= \(Array a) ix -> io $ A.readArray a ix   ]
src/Basis/Channel.hs view
@@ -1,16 +1,11 @@-{-# LANGUAGE-      DeriveDataTypeable,-      QuasiQuotes #-} module Basis.Channel (Channel, entries) where  import Data.Typeable (Typeable) import BasisUtils-import Syntax+import AST import Value (Value, Valuable(..)) -import qualified Loc-import qualified Syntax.Notable-import qualified Syntax.Decl+import qualified Data.Loc  import qualified Basis.Channel.Haskell as C @@ -23,13 +18,13 @@  entries :: [Entry Raw] entries  = [-    dec [$dc| type 'a channel |],-    fun "new"  -: [$ty| all 'a. unit -> 'a channel |]+    dec [sgQ| type 'a channel |],+    fun "new"  -: [ty| all 'a. unit -> 'a channel |]         -= \() -> Channel `fmap` C.newChan,-    fun "send" -: [$ty| all 'a. 'a channel -> 'a -> unit |]+    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 |]+    fun "recv" -: [ty| all 'a. 'a channel -> 'a |]         -= \c -> C.readChan (unChannel c)   ]
src/Basis/Exn.hs view
@@ -1,25 +1,22 @@-{-# LANGUAGE-      QuasiQuotes #-} module Basis.Exn ( entries ) where  import BasisUtils import Value-import Syntax+import AST -import qualified Loc-import qualified Syntax.Notable+import qualified Data.Loc  import Control.Exception  entries :: [Entry Raw] entries = [-    fun "raise" -: [$ty| all `a. exn -> `a |]+    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`+                -: [ty| all `a. (unit -o `a) -> (exn + string) + `a |]+      -= \f -> do+           fmap Right (vapp f vaUnit) `catches`              [ Handler $ \(VExn v) -> return (Left (Left v))              , Handler $ \e -> return (Left (Right (show (e:: IOError)))) ]   ]
src/Basis/Future.hs view
@@ -1,16 +1,11 @@-{-# LANGUAGE-      DeriveDataTypeable,-      QuasiQuotes #-} module Basis.Future (entries) where  import Data.Typeable (Typeable) import BasisUtils-import Syntax+import AST import Value (Value, Valuable(..)) -import qualified Loc-import qualified Syntax.Notable-import qualified Syntax.Decl+import qualified Data.Loc  import qualified Control.Concurrent as CC import qualified Control.Concurrent.MVar as MV@@ -26,24 +21,24 @@ entries :: [Entry Raw] entries  = [     -- Futures-    dec [$dc| type +`a future qualifier A |],-    dec [$dc| type -`a cofuture qualifier A |],+    dec [sgQ| type +`a future qualifier A |],+    dec [sgQ| type -`a cofuture qualifier A |], -    fun "new" -: [$ty| all `a. (unit -o `a) -> `a future |]+    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 |]+    fun "sync" -: [ty| all `a. `a future -> `a |]       -= (MV.takeMVar . unFuture),-    fun "coNew" -: [$ty| all `a. (`a future -o unit) -> `a cofuture |]+    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 |]+    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 |]+    fun "newPair" -: [ty| all `a. unit -> `a future * `a cofuture |]       -= \() -> do             future <- MV.newEmptyMVar             return (Future future, Future future)
src/Basis/IO.hs view
@@ -1,21 +1,13 @@-{-# LANGUAGE-      DeriveDataTypeable,-      QuasiQuotes,-      StandaloneDeriving-  #-} module Basis.IO ( entries ) where -import qualified IO--import Data.Data (Typeable, Data)+import qualified Data.Loc import BasisUtils-import Syntax+import AST import Util import Value (Valuable(..), vinjData, vprjDataM) -import qualified Loc-import qualified Syntax.Notable-import qualified Syntax.Decl+import qualified IO+import Data.Data (Typeable, Data)  instance Valuable IO.Handle where   veq = (==)@@ -31,30 +23,30 @@  entries :: [Entry Raw] entries = [-    dec [$dc| type handle |],-    dec [$dc| type ioMode = ReadMode+    dec [sgQ| type handle |],+    dec [sgQ| type ioMode = ReadMode                            | WriteMode                            | AppendMode                            | ReadWriteMode |],     -- File operations-    fun "openFile"        -: [$ty| string -> ioMode -> handle |]+    fun "openFile"        -: [ty| string -> ioMode -> handle |]       -= IO.openFile,-    fun "hGetChar"        -: [$ty| handle -> char |]+    fun "hGetChar"        -: [ty| handle -> char |]       -= fmap char2integer . IO.hGetChar,-    fun "hGetLine"        -: [$ty| handle -> string |]+    fun "hGetLine"        -: [ty| handle -> string |]       -= IO.hGetLine,-    fun "hIsEOF"          -: [$ty| handle -> bool |]+    fun "hIsEOF"          -: [ty| handle -> bool |]       -= IO.hIsEOF,-    fun "hPutChar"        -: [$ty| handle -> char -> unit |]+    fun "hPutChar"        -: [ty| handle -> char -> unit |]       -= \h -> IO.hPutChar h . integer2char,-    fun "hPutStr"         -: [$ty| handle -> string -> unit |]+    fun "hPutStr"         -: [ty| handle -> string -> unit |]       -= IO.hPutStr,-    fun "hClose"          -: [$ty| handle -> unit |]+    fun "hClose"          -: [ty| handle -> unit |]       -= IO.hClose,-    fun "hFlush"          -: [$ty| handle -> unit |]+    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+    val "stdin"  -: [ty| handle |] -= IO.stdin,+    val "stdout" -: [ty| handle |] -= IO.stdout,+    val "stderr" -: [ty| handle |] -= IO.stderr   ]
src/Basis/MVar.hs view
@@ -1,17 +1,12 @@-{-# LANGUAGE-      DeriveDataTypeable,-      QuasiQuotes #-} module Basis.MVar (entries) where  import Data.Typeable (Typeable) import BasisUtils-import Syntax+import AST import Util import Value (Value, Valuable(..)) -import qualified Loc-import qualified Syntax.Notable-import qualified Syntax.Decl+import qualified Data.Loc  import qualified Control.Concurrent.MVar as MV @@ -24,41 +19,41 @@  entries :: [Entry Raw] entries  = [-    dec [$dc| type `a mvar qualifier U |],-    fun "new" -: [$ty| all `a. `a -> `a mvar |]+    dec [sgQ| 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 |]+                 -: [ty| all `a. unit -> `a mvar |]       -= \() -> MVar `liftM` MV.newEmptyMVar,     fun "take"-                 -: [$ty| all `a. `a mvar -> `a |]+                 -: [ty| all `a. `a mvar -> `a |]       -= MV.takeMVar . unMVar,     fun "put"-                 -: [$ty| all `a. `a mvar -> `a -> unit |]+                 -: [ty| all `a. `a mvar -> `a -> unit |]       -= MV.putMVar . unMVar,     fun "read"-                 -: [$ty| all 'a. 'a mvar -> 'a |] -- important!+                 -: [ty| all 'a. 'a mvar -> 'a |] -- important!       -= MV.readMVar . unMVar,     fun "swap"-                 -: [$ty| all `a. `a mvar -> `a -> `a |]+                 -: [ty| all `a. `a mvar -> `a -> `a |]       -= MV.swapMVar . unMVar,     fun "tryTake"-                 -: [$ty| all `a. `a mvar -> `a option |]+                 -: [ty| all `a. `a mvar -> `a option |]       -= MV.tryTakeMVar . unMVar,     fun "tryPut"-                 -: [$ty| all `a. `a mvar -> `a -> bool |]+                 -: [ty| all `a. `a mvar -> `a -> bool |]       -= MV.tryPutMVar . unMVar,     fun "isEmpty"-                 -: [$ty| all `a. `a mvar -> bool |]+                 -: [ty| all `a. `a mvar -> bool |]       -= MV.isEmptyMVar . unMVar,     fun "callWith"-                 -: [$ty| all `a `b. `a mvar -> (`a -> `b) -> `b |]+                 -: [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 |]+                 -: [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 |]+                 -: [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/Row.hs view
@@ -0,0 +1,113 @@+module Basis.Row ( entries ) where++import Util+import BasisUtils+import Value+import AST++import qualified Data.Loc++entries :: [Entry Raw]+entries = [+    dec [sgQ| type `a ... |-> `b = {+ (`a -A> `b) ... +} |],+    fun "rowCase" -: [ty| ∀ `a `b. [ `a ] → (`a |-> `b) → `b |]+      -= \variant record → case variant of+           VaLab ix lab v → do+             f ← getField ix lab record+             vapp f v+           _ → throwFailure "case: expected variant",++    fun "isVariant"             -: [ty| ∀ `a. `a → bool |]+      -= \variant → case variant of+           VaLab _ _ _ → True+           _           → False,+    fun "variantLabel"          -: [ty| ∀ `a. [ `a ] → int * string |]+      -= \variant → case variant of+           VaLab ix lab _ → return (ix, show lab)+           _              → throwFailure "variantLabel: not a variant",+    fun "unsafeVariantValue"    -: [ty| ∀ `a `b. [ `a ] → `b |]+      -= \variant → case variant of+           VaLab _ _ v → return v+           _           → throwFailure "variantValue: not a variant",+    fun "unsafeMakeVariant"     -: [ty| ∀ `a `b. int → string → `a → [ `b ] |]+      -= \ix lab v → VaLab ix (ident lab) v,++    fun "isRecord"              -: [ty| ∀ `a. `a → bool |]+      -= \v → do+           case vprjM v of+             Just (AdditiveRecord _)       → True+             Just (MultiplicativeRecord _) → True+             _                             → False,+    fun "isAddRecord"      -: [ty| ∀ `a. `a → bool |]+      -= \v → do+           case vprjM v of+             Just (AdditiveRecord _)       → True+             _                             → False,+    fun "isMulRecord"      -: [ty| ∀ `a. `a → bool |]+      -= \v → do+           case vprjM v of+             Just (MultiplicativeRecord _) → True+             _                             → False,+    fun "recordLabels"          -: [ty| ∀ `a. {+ `a +} → string list |]+      -= \v → do+           record ← vprjM v+           case record of+             AdditiveRecord fields       → map (show . uidToLid . fst) fields+             MultiplicativeRecord fields → map (show . uidToLid . fst) fields,+    fun "unsafeGetRecordField"+          -: [ty| ∀ `a `b. int → string → { `a } → `b |]+      -= \ix lab v → getField ix (lidToUid (ident lab)) v,+    fun "unsafeGetRecordFieldThunk"+          -: [ty| ∀ `a `b. int → string → {+ `a +} → unit → `b |]+      -= \ix lab v → do+           io ← getFieldThunk ix (lidToUid (ident lab)) v+           return (VaFun (FNAnonymous []) (\_ → io)),+    fun "unsafeRecordAddField"+          -: [ty| ∀ `a `b `c. string → `a → { `b } → { `c } |]+      -= \lab v1 v2 → do+           MultiplicativeRecord fields ← vprjM v2+           return . vinj . MultiplicativeRecord $+             (lidToUid (ident lab), v1) : fields+             ∷ IO Value,+    fun "unsafeRecordAddFieldThunk"+          -: [ty| ∀ `a `b `c. string → (unit -A> `a) → {+ `b +} → {+ `c +} |]+      -= \lab thunk v2 → do+           AdditiveRecord fields ← vprjM v2+           return . vinj . AdditiveRecord $+             (lidToUid (ident lab),+              (vapp thunk (vinj ()), vppr thunk)) : fields+             ∷ IO Value,+    fun "unsafeRecordRemoveField"+          -: [ty| ∀ `a `b `q. string → (`q, `a) record → (`q, `b) record |]+      -= \lab v → do+           record ← vprjM v+           return . vinj $ case record of+             AdditiveRecord fields       →+              AdditiveRecord (remField (lidToUid (ident lab)) fields)+             MultiplicativeRecord fields →+              MultiplicativeRecord (remField (lidToUid (ident lab)) fields)+           ∷ IO Value+  ]++getField ∷ Int → Uid Renamed → Value → IO Value+getField = join <$$$> getFieldThunk++getFieldThunk ∷ Int → Uid Renamed → Value → IO (IO Value)+getFieldThunk ix0 lab v = do+  record ← vprjM v+  case record of+    AdditiveRecord fields       → fst <$> findNth ix0 fields+    MultiplicativeRecord fields → return <$> findNth ix0 fields+  where+  findNth _  []         = throwFailure "record field not found"+  findNth ix ((lab', v'):fields')+    | lab == lab'       = if ix == 0+                            then return v'+                            else findNth (ix - 1) fields'+    | otherwise         = findNth ix fields'++remField ∷ Uid Renamed → [(Uid Renamed, v)] → [(Uid Renamed, v)]+remField _ []           = []+remField k ((k',v'):kvs)+  | k == k'             = kvs+  | otherwise           = (k',v') : remField k kvs
src/Basis/Socket.hs view
@@ -1,8 +1,3 @@-{-# LANGUAGE-      DeriveDataTypeable,-      QuasiQuotes,-      StandaloneDeriving-  #-} module Basis.Socket ( entries ) where  import Data.Data as Data@@ -11,12 +6,9 @@  import Basis.IO () import BasisUtils-import Syntax+import AST import Value--import qualified Loc-import qualified Syntax.Notable-import qualified Syntax.Decl+import qualified Data.Loc  instance Valuable S.Socket where   veq = (==)@@ -102,68 +94,68 @@  entries :: [Entry Raw] entries  = [-    dec [$dc| type portNumber = PortNum of int |],-    dec [$dc| type socket |],+    dec [sgQ| type portNumber = PortNum of int |],+    dec [sgQ| 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+    dec [sgQ| type protocolNumber = int |],+    dec [sgQ| type hostAddress  = int |],+    dec [sgQ| type flowInfo     = int |],+    dec [sgQ| type hostAddress6 = int * int * int * int |],+    dec [sgQ| type scopeID      = int |],+    dec [sgQ| 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+    dec [sgQ| type addrInfo                 = AddrInfo of                     addrInfoFlag list * family * socketType *                     protocolNumber * sockAddr * string option |],-    dec [$dc| type hostName = string |],-    dec [$dc| type serviceName = string |],+    dec [sgQ| type hostName = string |],+    dec [sgQ| type serviceName = string |], -    val "inaddr_any" -: [$ty| hostAddress |]+    val "inaddr_any" -: [ty| hostAddress |]       -= S.iNADDR_ANY,-    val "defaultProtocol" -: [$ty| protocolNumber |]+    val "defaultProtocol" -: [ty| protocolNumber |]       -= S.defaultProtocol,-    val "defaultHints" -: [$ty| addrInfo |]+    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 ->+      -: [ty| addrInfo option -> hostName option ->                 serviceName option -> addrInfo list |]       -= S.getAddrInfo,-    fun "inet_addr" -: [$ty| string -> hostAddress |]+    fun "inet_addr" -: [ty| string -> hostAddress |]       -= S.inet_addr, -    fun "socket" -: [$ty| family -> socketType -> protocolNumber -> socket |]+    fun "socket" -: [ty| family -> socketType -> protocolNumber -> socket |]       -= S.socket,-    fun "bind"   -: [$ty| socket -> sockAddr -> unit |]+    fun "bind"   -: [ty| socket -> sockAddr -> unit |]       -= S.bindSocket,-    fun "connect"   -: [$ty| socket -> sockAddr -> unit |]+    fun "connect"   -: [ty| socket -> sockAddr -> unit |]       -= S.connect,-    fun "listen" -: [$ty| socket -> int -> unit |]+    fun "listen" -: [ty| socket -> int -> unit |]       -= S.listen,-    fun "accept" -: [$ty| socket -> socket * sockAddr |]+    fun "accept" -: [ty| socket -> socket * sockAddr |]       -= S.accept,-    fun "send" -: [$ty| socket -> string -> int |]+    fun "send" -: [ty| socket -> string -> int |]       -= \sock str -> S.send sock str,-    fun "recv" -: [$ty| socket -> int -> string |]+    fun "recv" -: [ty| socket -> int -> string |]       -= \sock len -> S.recv sock len,-    fun "shutdown" -: [$ty| socket -> shutdownCmd -> unit |]+    fun "shutdown" -: [ty| socket -> shutdownCmd -> unit |]       -= S.shutdown,-    fun "close" -: [$ty| socket -> unit |]+    fun "close" -: [ty| socket -> unit |]       -= S.sClose, -    fun "isReadable" -: [$ty| socket -> bool |]+    fun "isReadable" -: [ty| socket -> bool |]       -= S.sIsReadable,-    fun "isWritable" -: [$ty| socket -> bool |]+    fun "isWritable" -: [ty| socket -> bool |]       -= S.sIsWritable   ]
src/Basis/Thread.hs view
@@ -1,28 +1,23 @@-{-# LANGUAGE-      DeriveDataTypeable,-      QuasiQuotes #-} module Basis.Thread (entries) where  import BasisUtils-import Syntax+import AST import Value (Vinj(..)) -import qualified Loc-import qualified Syntax.Notable-import qualified Syntax.Decl+import qualified Data.Loc  import qualified Control.Concurrent as CC  entries :: [Entry Raw] entries =  [     -- Threads-    dec [$dc| type thread |],-    fun "fork"  -: [$ty| (unit -> unit) -> thread |]+    dec [sgQ| type thread |],+    fun "fork"  -: [ty| (unit -> unit) -> thread |]       -= \f -> Vinj `fmap` CC.forkIO (vapp f () >> return ()),-    fun "kill"  -: [$ty| thread -> unit |]+    fun "kill"  -: [ty| thread -> unit |]       -= CC.killThread . unVinj,-    fun "delay" -: [$ty| int -> unit |]+    fun "delay" -: [ty| int -> unit |]       -= CC.threadDelay . (fromIntegral :: Integer -> Int),-    fun "print" -: [$ty| thread -> thread |]+    fun "print" -: [ty| thread -> thread |]       -= \t -> do print (t :: Vinj CC.ThreadId); return t   ]
src/BasisUtils.hs view
@@ -1,8 +1,5 @@ -- | Tools for implementing primitive operations -- essentially an --   object-language/meta-language FFI.-{-# LANGUAGE-      FlexibleInstances,-      QuasiQuotes #-} module BasisUtils (   -- | * Initial environment entries   Entry,@@ -17,61 +14,62 @@   (-:), (-=),   -- ** Default location for entries   _loc,-  module Loc,+  module Data.Loc,   -- ** Environment construction-  basis2venv, basis2tenv, basis2renv,+  basis2renv, basis2tenv, basis2venv,    -- * Function embedding   MkFun(..), baseMkFun, vapp,    -- * Re-exports-  text, Uid(..),+  text, Id(..), throwFailure,   module Meta.Quasi, ) where -import Dynamics (E, addVal, addMod)-import Env (GenEmpty(..))-import ErrorMessage (AlmsMonad)-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 Util.MonadRef+import Dynamics (E, addVal, addMod, throwFailure)+import Env (GenEmpty(..), domain)+import Error (MonadAlmsError, almsBug, throwAlms, Phase(DynamicsPhase))+import Meta.Quasi+import Syntax.Parser (ptd)+import Syntax.Ppr (ppr, pprPrec, text, precApp)+import Statics+import Statics.Rename as Rename+import AST+import Type (TyCon, tcName, tcCons)+import Data.Loc (Loc(Loc), mkBogus, setLoc) import Value (Valuable(..), FunName(..), funNameDocs, Value(..)) +import Prelude ()+ -- | Kind of identifier used in this module type R = Raw --- | Default source location for primitives-_loc :: Loc-_loc  = mkBogus "<primitive>"+-- | The default location for primitive bindings+_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+    enVarName :: VarId i,+    enType    :: Type i,+    enValue   :: Value   }   -- | A declaration entry   | DecEn {-    enSrc   :: Decl i+    enSrc     :: SigItem i   }   -- | A type entry associates a tycon name with information about it   | TypEn {-    enName  :: Lid i,-    enTyCon :: TyCon+    enTypName :: TypId i,+    enTyCon   :: TyCon   }   -- | A module entry associates a module name with a list of entries   | ModEn {-    enModName :: Uid i,+    enModName :: ModId i,     enEnts    :: [Entry i]   } @@ -113,31 +111,31 @@  -- | 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)+val name t v = ValEn (ident 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)+fun name t f = ValEn vid t (mkFun (FNNamed (ppr vid)) f)+  where vid = ident name  typ :: String -> Entry Raw-typ s = DecEn [$dc| type $tydec:td |] where td = ptd s+typ s = DecEn [sgQ| type $tydec:td |] where td = ptd s  -- | Creates a declaration entry-dec :: Decl R -> Entry Raw+dec :: SigItem R -> Entry Raw dec  = DecEn  -- | Creates a module entry submod :: String -> [Entry Raw] -> Entry Raw-submod  = ModEn . uid+submod  = ModEn . ident --- | Creates a primitve type entry, binding a name to a type tag---   (which is usually defined in Syntax.hs)+-- | Creates a primitive type entry, binding a name to a type tag+--   (which is usually defined in AST.hs) primtype  :: String -> TyCon -> Entry Raw-primtype   = TypEn . lid+primtype   = TypEn . ident  -- | Application (-:), (-=) :: (a -> b) -> a -> b@@ -149,51 +147,67 @@  -- | Instance of 'fun' for making binary arithmetic functions binArith :: String -> (Integer -> Integer -> Integer) -> Entry Raw-binArith name = fun name [$ty| int -> int -> int |]+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)+vapp (VaFun _ f) x = f (vinj x)+vapp _           _ = throwAlms+  $ almsBug DynamicsPhase "vapp" "applied non-function" infixr 0 `vapp`  -- | Build the renaming environment and rename the entries-basis2renv :: AlmsMonad m =>+basis2renv :: MonadAlmsError m =>               [Entry Raw] -> m ([Entry Renamed], RenameState) basis2renv =   runRenamingM False _loc renameState0 . renameMapM each where-  each ValEn { enName = u, enType = t, enValue = v } = do+  each ValEn { enVarName = u, enType = t, enValue = v } = do     u' <- Rename.addVal u     t' <- renameType t-    return ValEn { enName = u', enType = t', enValue = v }+    return ValEn { enVarName = u', enType = t', enValue = v }   each DecEn { enSrc = d } = do-    d' <- renameDecl d+    d' <- renameSigItem 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 TypEn { enTypName = l, enTyCon = tc } = do+    l' <- Rename.addType l (idTag (jname (tcName tc)))+                           (dirtyTrivialRename <$> domain (tcCons tc))+    return TypEn { enTypName = 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 static environment+basis2tenv :: (MonadAlmsError m, MonadRef r m) =>+              StaticsState r -> [Entry Renamed] -> m (StaticsState r)+basis2tenv ss0 entries = addSignature ss1 sigexp+  where+    ss1             = foldl' (uncurry . addPrimType) ss0 prims+    (sigexp, prims) = evalRWS (eachEntries entries) [] (0 :: Int)+    eachEntries es  = do+      sigitems <- mapM eachEntry es+      return [seQ|+ sig $list:sigitems end |]+    eachEntry ValEn { enVarName = n, enType = t }+      = return [sgQ|+ val $vid:n : $t |]+    eachEntry DecEn { enSrc = sigitem }+      = return sigitem+    eachEntry TypEn { enTypName = n, enTyCon = tc }+      = do+        ix <- get+        put (ix + 1)+        tell [(n, tc)]+        return [sgQ|+ type $tid:n = type $tid:n |]+    eachEntry ModEn { enModName = n, enEnts = es }+      = do+        sig <- eachEntries es+        return [sgQ|+ module $mid:n : $sig |]+ -- | Build the dynamic environment-basis2venv :: AlmsMonad m => [Entry Renamed] -> m E+basis2venv :: MonadAlmsError m => [Entry Renamed] -> m E basis2venv es = foldM add genEmpty es where-  add :: AlmsMonad m => E -> Entry Renamed -> m E-  add e (ValEn { enName = n, enValue = v })+  add :: MonadAlmsError m => E -> Entry Renamed -> m E+  add e (ValEn { enVarName = 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 :: AlmsMonad 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 
@@ -1,145 +0,0 @@--- | 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 ErrorMessage--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 :: AlmsMonad 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 :: AlmsMonad 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 <- instContract `liftM` build b recs' t t'-  let tv''  = freshTyVar tv (ftv (tv, tv'))-      tstx  = typeToStx' t-      tstx' = typeToStx' t'-  return $-    absContract $-      [$ex|+ fun (Pack('$tv'', e) : ex '$tv. $tstx) ->-               Pack[ex '$tv'. $tstx']('$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'-  let tstx  = typeToStx' t-      tstx' = typeToStx' t'-  return $-    [$ex|+-      let rec $lid:l-              (parties : string * string)-                       : (mu '$tv. $tstx) -> mu '$tv'. $tstx'-          = $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 let tstx' = typeToStx' t' in-         return [$ex|+ INTERNALS.Contract.any [$tstx'] |]-    else CMS.lift . throwAlms $ AlmsException StaticsPhase bogus [$msg|-        <dl>-          <dt>from type: <dd>$t-          <dt>to type:   <dd>$t'.-        </dl>-    |]--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/Compat.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE-      TemplateHaskell #-} -- | Compatibility layer for different GHC and library versions module Compat (   mask, newQuasi,
+ src/Data/Empty.hs view
@@ -0,0 +1,25 @@+-- | An uninhabited type+module Data.Empty (+  Empty, elimEmpty, elimEmptyF,+) where++import Data.Generics (Typeable, Data)+import Unsafe.Coerce (unsafeCoerce)++-- | An uninhabited type+data Empty deriving Typeable++deriving instance Data Empty++-- | Elimination for 'Empty'+elimEmpty  ∷ Empty → a+elimEmpty  = const undefined++-- | Elimination for 'Empty' under any functor, implemented as a no-op.+elimEmptyF ∷ Functor f ⇒ f Empty → f a+elimEmptyF = unsafeCoerce++instance Eq Empty where _ == _ = True+instance Ord Empty where _ `compare` _ = EQ+instance Show Empty where show = elimEmpty+
+ src/Data/Lattice.hs view
@@ -0,0 +1,69 @@+module Data.Lattice (+  -- * Lattices+  Lattice(..), BoundedLattice(..),+  -- ** Dual lattices+  DUAL(..),+) where++import Util++import Prelude ()+import qualified Data.Set as S++-- | Lattices.+--  Minimal complete definition is '(⊔)' and '(⊓)'.+class Eq a ⇒ Lattice a where+  (⊔), (⊓) ∷ a → a → a+  (⊑), (⊒) ∷ a → a → Bool+  a ⊑ b = a ⊔ b == b+  a ⊒ b = b ⊑ a++infixl 6 ⊔+infixl 7 ⊓+infix 4 ⊑, ⊒++-- | Bounded lattices are 'Lattice's that are 'Bounded'.+class (Bounded a, Lattice a) ⇒ BoundedLattice a where+  bigJoin, bigMeet ∷ [a] → a++instance (Bounded a, Lattice a) ⇒ BoundedLattice a where+  bigJoin = foldr (⊔) minBound+  bigMeet = foldr (⊓) maxBound++-- 'Nothing' is a new point.+instance Lattice a ⇒ Lattice (Maybe a) where+  Just a  ⊔ Just b  = Just (a ⊔ b)+  Nothing ⊔ b       = b+  a       ⊔ Nothing = a+  Just a  ⊓ Just b  = Just (a ⊓ b)+  Nothing ⊓ _       = Nothing+  _       ⊓ Nothing = Nothing++instance Ord a ⇒ Lattice (S.Set a) where+  (⊔) = S.union+  (⊓) = S.intersection+  (⊑) = S.isSubsetOf++instance (Lattice a, Lattice b) ⇒ Lattice (a, b) where+  (a, b) ⊔ (a', b') = (a ⊔ a', b ⊔ b')+  (a, b) ⊓ (a', b') = (a ⊓ a', b ⊓ b')+  (a, b) ⊑ (a', b') = a ⊑ a' && b ⊑ b'++instance (Lattice a, Lattice b, Lattice c) ⇒ Lattice (a, b, c) where+  (a, b, c) ⊔ (a', b', c') = (a ⊔ a', b ⊔ b', c ⊔ c')+  (a, b, c) ⊓ (a', b', c') = (a ⊓ a', b ⊓ b', c ⊓ c')+  (a, b, c) ⊑ (a', b', c') = a ⊑ a' && b ⊑ b' && c ⊑ c'++-- | Injection for the dual lattice.+newtype DUAL a = DUAL { dual ∷ a } deriving (Eq, Show)++instance Lattice a ⇒ Lattice (DUAL a) where+  DUAL a ⊔ DUAL b = DUAL (a ⊓ b)+  DUAL a ⊓ DUAL b = DUAL (a ⊔ b)++instance Bounded a ⇒ Bounded (DUAL a) where+  minBound = DUAL maxBound+  maxBound = DUAL minBound++instance Ord a ⇒  Ord (DUAL a) where+  DUAL a `compare` DUAL b = b `compare` a
+ src/Data/Loc.hs view
@@ -0,0 +1,187 @@+-- | Source locations+module Data.Loc (+  -- * Type and constructors+  Loc(..),+  initial, spanLocs, mkBogus, bogus,+  -- * Destructors+  isBogus, startOfLoc, endOfLoc,++  -- * Generic function for clearing source locations everywhere+  scrub, scrubWhen,++  -- ** Type class interface+  Locatable(..), Relocatable(..), (<<@),++  -- * Interface to 'Parsec' and 'TH' source positions+  toSourcePos, fromSourcePos, fromSourcePosSpan, fromTHLoc+) where++import Util.Bogus++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++-- | 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)++-- | The bogus location.+--   (Avoids need for @Maybe Loc@ and lifting)+instance Bogus Loc where+  bogus    = mkBogus "<bogus>"++instance IsBogus Loc where+  isBogus (Loc _ (-1) _ _ _) = True+  isBogus _                  = False++-- | 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 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 = scrubWhen (const True)++-- | Bogosify all source locations satisfying a predicate+--   (as far as SYB can find them)+scrubWhen :: Data a => (Loc -> Bool) -> a -> a+scrubWhen p a = everywhere (mkT bogosify) a where+  bogosify loc | p loc     = bogus+               | otherwise = loc++instance Show Loc where+  showsPrec _ loc+    | isBogus loc = showString (showFile (file loc))+    | otherwise   =+        showString (showFile (file loc)) . showChar ':' . showCoords+    where+    showCoords =+      if line1 loc == line2 loc then+        shows (line1 loc) . showChar ':' . shows (col1 loc) .+        if col1 loc + 1 >= col2 loc then+          id+        else+          showChar '-' . shows (col2 loc)+      else+        shows (line1 loc) .+        showChar ':' . shows (col1 loc) .+        showChar '-' . shows (line2 loc) .+        showChar ':' . shows (col2 loc)+    showFile "-" = "<stdin>"+    showFile s   =+      let shown = show s+       in if shown == '"' : s ++ "\""+            then s+            else shown+
+ src/Data/OptionalClass.hs view
@@ -0,0 +1,43 @@+-- | A generalization of 'Maybe'+module Data.OptionalClass (+  Optional(..),+  coerceOpt, catOpt, fromOptSome, fromOpt,+  isOptSome, isOptNone,+  mapOpt,+) where++class Functor f ⇒ Optional f where+  foldOpt ∷ b → (a → b) → f a → b+  optSome ∷ a → f a+  optNone ∷ f a++instance Optional Maybe where+  foldOpt = maybe+  optSome = Just+  optNone = Nothing++instance Optional [] where+  foldOpt z f = foldr (const . f) z+  optSome     = return+  optNone     = []++-- | Coerce between optional types+coerceOpt ∷ (Optional f, Optional g) ⇒ f a → g a+coerceOpt  = foldOpt optNone optSome++catOpt ∷ Optional f ⇒ [f a] → [a]+catOpt = foldr (foldOpt id (:)) []++fromOptSome ∷ Optional f ⇒ f a → a+fromOptSome = foldOpt (error "fromOptSome: got optNone") id++fromOpt ∷ Optional f ⇒ a → f a → a+fromOpt = flip foldOpt id++isOptSome, isOptNone ∷ Optional f ⇒ f a → Bool+isOptSome = foldOpt False (const True)+isOptNone = not . isOptSome++mapOpt ∷ Optional f ⇒ (a → f b) → [a] → [b]+mapOpt f = foldr (foldOpt id (:) . f) []+
+ src/Data/Perhaps.hs view
@@ -0,0 +1,105 @@+-- | Like maybe, but 'Eq' and 'Ord' instances are collapsed so that all+--   values of type @Perhaps a@ are equal. Useful for hiding optional+--   information from derived instances in other datatypes.+module Data.Perhaps (+  Perhaps(..),+  catPerhaps, mapPerhaps,+  fromHere, fromPerhaps, isHere, isNope,+  listToPerhaps, perhapsToList, perhapsToMaybe, maybeToPerhaps,+) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Monad.Fix+import Data.Monoid++import Data.OptionalClass+import Data.Generics (Typeable, Data)++-- | This is like @Maybe@, except all values of the type compare as+--   equal, which is useful for “suggestions” in the syntax that have+--   no semantic significance.+data Perhaps a+  = Nope+  | Here a+  deriving (Functor, Typeable, Data)++instance Optional Perhaps where+  foldOpt = perhaps+  optSome = Here+  optNone = Nope++perhaps ∷ b → (a → b) → Perhaps a → b+perhaps nope _    Nope     = nope+perhaps _    here (Here x) = here x++catPerhaps ∷ [Perhaps a] → [a]+catPerhaps = foldr (perhaps id (:)) []++fromHere ∷ Perhaps a → a+fromHere = perhaps (error "fromHere: got Nope") id++fromPerhaps ∷ a → Perhaps a → a+fromPerhaps = flip perhaps id++isHere, isNope ∷ Perhaps a → Bool+isHere = perhaps False (const True)+isNope = not . isHere++listToPerhaps ∷ [a] → Perhaps a+listToPerhaps = foldr (const . Here) Nope++mapPerhaps ∷ (a → Perhaps b) → [a] → [b]+mapPerhaps f = foldr (perhaps id (:) . f) []++perhapsToList ∷ Perhaps a → [a]+perhapsToList = perhaps [] (:[])++perhapsToMaybe ∷ Perhaps a → Maybe a+perhapsToMaybe = perhaps Nothing Just++maybeToPerhaps ∷ Maybe a → Perhaps a+maybeToPerhaps = maybe Nope Here++instance Eq (Perhaps a) where+  _ == _ = True++instance Monad Perhaps where+  return = Here+  (>>=)  = perhaps (const Nope) (flip ($))++instance Ord (Perhaps a) where+  _ `compare` _ = EQ++instance Read a ⇒ Read (Perhaps a) where+  readsPrec p s = case readsPrec p s of+    [] → [ (Nope, s) ]+    xs → map (first Here) xs++instance Show a ⇒ Show (Perhaps a) where+  showsPrec = perhaps id . showsPrec++instance MonadFix Perhaps where+  mfix f = let a = f (unHere a) in a+     where unHere (Here x) = x+           unHere Nope     = error "mfix Perhaps: Nope"++instance MonadPlus Perhaps where+  mzero = Nope+  mplus = perhaps id (const . Here)++instance Applicative Perhaps where+  pure  = return+  (<*>) = ap++instance Monoid a ⇒ Monoid (Perhaps a) where+  mempty  = Nope+  Here x1 `mappend` Here x2 = Here (x1 `mappend` x2)+  p1      `mappend` Nope    = p1+  Nope    `mappend` p2      = p2++instance Alternative Perhaps where+  empty  = mzero+  (<|>)  = mplus+
+ src/Data/UnionFind.hs view
@@ -0,0 +1,95 @@+{- | Based on Simonet's Dalton constraint solver -}+module Data.UnionFind (+  -- * An implementation on top of 'MonadRef'+  Proxy,+  create, desc, setDesc, repr,+  sameRepr, isRepr, coalesce, coalesce_, linkto,+) where++import Util+import Util.Eq1+import Util.MonadRef++import Prelude ()++---+--- Representaiton and basic, low-level operations+---++newtype Proxy p a = Proxy { unProxy ∷ p (Either a (Proxy p a)) }++instance Eq1 p ⇒ Eq1 (Proxy p) where+  Proxy p1 `eq1` Proxy p2 = p1 `eq1` p2++-- | To create a new set with the given representative+create  ∷ MonadRef p m ⇒ a → m (Proxy p a)+create   = liftM Proxy . newRef . Left++-- | To follow a link, either to the end or to another link+follow  ∷ MonadRef p m ⇒ Proxy p a → m (Either a (Proxy p a))+follow   = readRef . unProxy++-- | To replace the contents of a link with a representative+--   or another link+replace ∷ MonadRef p m ⇒ Proxy p a → Either a (Proxy p a) → m ()+replace  = writeRef . unProxy++-- | Find the representative of a set+repr    ∷ MonadRef p m ⇒ Proxy p a → m (Proxy p a)+repr    = liftM fst . loop where+  loop proxy = do+    link ← follow proxy+    case link of+      Left _       → return (proxy, False)+      Right proxy' → do+        (proxy'', changed) ← loop proxy'+        when changed $ replace proxy (Right proxy'')+        return (proxy'', True)++-- | Find the descriptor of a set+desc     ∷ MonadRef p m ⇒ Proxy p a → m a+desc proxy = do+  link ← follow proxy+  case link of+    Left a       → return a+    Right proxy' → desc =<< repr proxy'++-- | Change the descriptor of a set+setDesc ∷ MonadRef p m ⇒ Proxy p a → a → m ()+setDesc proxy a = flip replace (Left a) =<< repr proxy++-- | Join two proxies, using the given function to combine their+--   descriptors.+coalesce ∷ MonadRef p m ⇒+           (a → a → m (a, b)) → Proxy p a → Proxy p a → m (Maybe b)+coalesce combine proxy1 proxy2 = do+  proxy1' ← repr proxy1+  proxy2' ← repr proxy2+  if (proxy1' `eq1` proxy2')+    then return Nothing+    else do+      a1      ← desc proxy1'+      a2      ← desc proxy2'+      (a', b) ← combine a1 a2+      replace proxy1' (Right proxy2')+      replace proxy2' (Left a')+      return (Just b)++coalesce_ ∷ MonadRef p m ⇒ (a → a → m a) → Proxy p a → Proxy p a → m ()+coalesce_ combine proxy1 proxy2 = do+  coalesce (liftM (,()) <$$> combine) proxy1 proxy2+  return ()++-- | Make the first proxy point to the second, keeping the second+--   proxy's descriptor+linkto ∷ MonadRef p m ⇒ Proxy p a → Proxy p a → m ()+linkto = coalesce_ (const . return)++-- | Is the given proxy object the representative of its set?+isRepr ∷ MonadRef p m ⇒ Proxy p a → m Bool+isRepr = liftM (either (const True) (const False)) . follow++-- | Are two proxy objects from the same set?+sameRepr ∷ MonadRef p m ⇒ Proxy p a → Proxy p a → m Bool+sameRepr proxy1 proxy2 = liftM2 eq1 (repr proxy1) (repr proxy2)+
src/Dynamics.hs view
@@ -1,14 +1,11 @@-{-# LANGUAGE-      FlexibleInstances,-      MultiParamTypeClasses,-      QuasiQuotes,-      TemplateHaskell #-} -- | The dynamics of the interpreter module Dynamics (   -- * Static API   E, addVal, addMod, NewValues,   -- * Dynamic API   eval, addDecls, Result,+  -- * Throwing exceptions+  throwFailure,   -- * 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.@@ -18,17 +15,13 @@ 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 AST import Env-import Ppr (Ppr(..), Doc, text, precApp)-import ErrorMessage+import Syntax.Ppr (Ppr(..), Doc, text, precApp)+import Error +import Prelude () import Data.IORef (newIORef, readIORef, writeIORef)-import Control.Exception (throw)  -- -- Our semantic domains@@ -46,26 +39,22 @@ type E        = [Scope] -- | Each scope binds paths of uppercase identifiers to flat value --   and exn environments-type Scope    = PEnv (Uid R) Level+type Scope    = PEnv (ModId 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)+type VE       = Env (VarId R) (IO Value)  instance GenEmpty Level where-  genEmpty = Level empty-instance GenLookup Level (Lid R) (IO Value) where+  genEmpty = Level Env.empty+instance GenLookup Level (VarId 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+instance GenExtend Level (Env (VarId R) (IO Value)) where   level =+= ve' = level =+= Level ve'  -- | Domain for the meaning of an expression:@@ -86,15 +75,17 @@ 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+evalDecl [dc| let $x = $e |]                       = evalLet x e+evalDecl [dc| let rec $list:bns |]                 = evalLetRec bns+evalDecl [dc| type $list:_ |]                      = return+evalDecl [dc| type $tid:_ = type $qtid:_ |]        = return+evalDecl [dc| abstype $list:_ with $list:ds end |] = evalDecls ds+evalDecl [dc| open $b |]                           = evalOpen b+evalDecl [dc| module $mid:n = $b |]                = evalMod n b+evalDecl [dc| module type $sid:_ = $_ |]           = return+evalDecl [dc| local $list:d0 with $list:d1 end |]  = evalLocal d0 d1+evalDecl [dc| exception $cid:n of $opt:mt |]       = evalExn n mt+evalDecl [dc| $anti:a |]                           = $antifail  evalLet :: Patt R -> Expr R -> DDecl evalLet x e env = do@@ -103,12 +94,28 @@     Just env' -> return env'     Nothing   -> throwPatternMatch v [show x] env +evalLetRec :: [Binding R] -> DDecl+evalLetRec bs env = do+  let extend (envI, rs) (N _ b) = do+        r <- newIORef $ throwBadLetRec (idName (bnvar b))+        return (envI =+=+                  bnvar b =:= (nameFun (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+  return env'+ evalOpen :: ModExp R -> DDecl evalOpen b env = do   e <- evalModExp b env   return (env =+= e) -evalMod :: Uid R -> ModExp R -> DDecl+evalMod :: ModId R -> ModExp R -> DDecl evalMod x b env = do   e <- evalModExp b env   return (env =+= x =:= e)@@ -120,150 +127,230 @@   return (env2 =+= scope)  evalModExp :: ModExp R -> E -> IO Scope-evalModExp [$me| struct $list:ds end |]  env = do+evalModExp [meQ| struct $list:ds end |]  env = do   scope:_ <- evalDecls ds (genEmpty:env)   return scope-evalModExp [$me| $quid:n $list:_ |]      env = do+evalModExp [meQ| $qmid:n $list:_ |]      env = do   case env =..= n of     Just scope -> return scope-    Nothing    -> runtimeBug _loc "evalModExp" $+    Nothing    -> runtimeBug "evalModExp" $       "Unknown module: ‘" ++ show n ++ "’"-evalModExp [$me| $me1 : $_ |]            env = do+evalModExp [meQ| $me1 : $_ |]            env = do   evalModExp me1 env-evalModExp [$me| $anti:a |]              _   = $antifail+evalModExp [meQ| $anti:a |]              _   = $antifail -evalExn :: Uid R -> Maybe (Type R) -> DDecl+evalExn :: ConId 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 ())+eval env0 [prQ| $list:ds in $e0 |] = evalDecls ds env0 >>= valOf e0+eval env0 [prQ| $list:ds        |] = evalDecls ds env0 >>  return vaUnit  -- 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+  [ex| $qvid:n |] -> case env =..= n of       Just v     -> v-      Nothing    -> runtimeBug _loc "valOf" $-        "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+      Nothing    -> runtimeBug "valOf" $+        "unbound identifier: ‘" ++ show n ++ "’"+  [ex| $str:s |]    -> return (vinj s)+  [ex| $int:z |]    -> return (vinj z)+  [ex| $flo:f |]    -> return (vinj f)+  [ex| $char:c |]   -> return (vinj c)+  [ex| $antiL:a |]  -> $antifail+  [ex| $qcid:n $opt:me1 |]+                    -> do+    mv1 <- mapM (valOf <-> env) me1+    return (VaCon (jname n) mv1)+  [ex| `$uid:lab $opt:me1 |] -> do+    v1 <- maybe (return vaUnit) (valOf <-> env) me1+    return (VaLab 0 lab v1)+  [ex| #$uid:lab $e1 |] -> 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 $ throwBadLetRec (unLid (bnvar b))-          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+    case v1 of+      VaLab n lab' v1' | lab == lab' -> return (VaLab (n + 1) lab v1')+      _                              -> return v1+  [ex| match $e1 with $list:clauses |] -> do+    let loop ([caQ| $xi → $ei |]:rest)                  v1 =+          case bindPatt xi v1 env of+            Just env' -> valOf ei env'+            Nothing   -> loop rest v1+        loop ([caQ| #$uid:lab $opt:mxi → $ei |]:rest)   v1 =+          case v1 of+            VaLab 0 lab' v1'+              | lab == lab'  -> case mxi of+                Nothing         -> valOf ei env+                Just xi         -> case bindPatt xi v1' env of+                  Just env'       -> valOf ei env'+                  Nothing         -> loop [] v1+            VaLab n lab' v1'+              | lab == lab'  -> loop rest (VaLab (n - 1) lab' v1')+            _                -> loop rest v1+        loop []                                         v1 =+          throwPatternMatch v1 (map (show . cafakepatt) clauses) env+        loop ([caQ| $antiC:a |]:_)                      _  = $antifail+    loop clauses =<< valOf e1 env+  [ex| let $x = $e1 in $e2 |]     -> do+    v1   <- valOf e1 env+    env' <- case bindPatt x v1 env of+      Just env' -> return env'+      Nothing   -> throwPatternMatch v1 [show x] env     valOf e2 env'-  [$ex| let $decl:d in $e2 |] -> do+  [ex| let rec $list:bs in $e2 |] -> do+    env' <- evalLetRec bs env+    valOf e2 env'+  [ex| let $decl:d in $e2 |] -> do     env' <- evalDecl d env     valOf e2 env'-  [$ex| ($e1, $e2) |] -> do+  [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+  [ex| fun $x -> $e' |] ->+    return .+      VaFun (FNAnonymous [pprPrec (precApp + 1) e]) $ \v ->+        case bindPatt x v env of+          Just env' -> valOf e' env'+          Nothing   -> throwPatternMatch v [show x] env+  [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))-      _         -> runtimeBug _loc "valOf" $+      _         -> runtimeBug "valOf" $         "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+  [ex| { $list:flds | $e2 } |] -> do+    newFields ← sequence+      [ (ui,) <$> valOf ei env+      | [fdQ|! $uid:ui = $ei |] ← flds ]+    v2 ← valOf e2 env+    MultiplicativeRecord oldFields ← vprjM v2+    return . vinj $ MultiplicativeRecord (newFields ++ oldFields)+  [ex| {+ $list:flds | $e2 +} |] -> do+    let newFields = [ (ui, (valOf ei env, ppr ei))+                    | [fdQ|! $uid:ui = $ei |] ← flds ]+    v2     ← valOf e2 env+    record ← vprjM v2+    let oldFields = case record of+          AdditiveRecord olds       → olds+          MultiplicativeRecord olds →+            [ (ui, (return vi, ppr vi)) | (ui, vi) ← olds ]+    return . vinj $ AdditiveRecord (newFields ++ oldFields)+  [ex| $e1.$uid:u |]             -> do+    v1     ← valOf e1 env+    record ← vprjM v1+    case record of+      AdditiveRecord flds       → case lookup u flds of+        Just (mv, _) → mv+        Nothing      → runtimeBug "valOf" "missing record field (&)"+      MultiplicativeRecord flds → case lookup u flds of+        Just v  → return v+        Nothing → runtimeBug "valOf" "missing record field (⊗)"+  [ex| ( $e1 : $_ ) |]           -> valOf e1 env+  [ex| ( $_ :> $_ ) |]           -> runtimeBug "valOf" "encountered cast"+  [ex| $anti:a |]                -> $antifail  bindPatt :: Monad m => Patt R -> Value -> E -> m E bindPatt x0 v env = case x0 of-  [$pa| _ |] +  [pa| _ |]     -> return env-  [$pa| $lid:l |]+  [pa| $vid:l |]     -> return (env =+= l =:!= (l `nameFun` v))-  [$pa| $quid:qu $opt:mx |]+  [pa| $qcid: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) |]+  [pa| `$uid:lab $opt:mx |]+    -> case v of+         VaLab 0 lab' v' | lab' == lab ->+             case mx of+              Nothing -> return env+              Just x  -> 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 |]+  [pa| $str:s |]     -> if v == vinj s          then return env          else perr-  [$pa| $int:z |]+  [pa| $int:z |]     -> if v == vinj z          then return env          else perr-  [$pa| $float:f |]+  [pa| $float:f |]     -> if v == vinj f          then return env          else perr-  [$pa| Pack('$_, $x) |]-    -> bindPatt x v env-  [$pa| $x as $lid:l |]+  [pa| $char:c |]+    -> if v == vinj c+         then return env+         else perr+  [pa| $x as $vid:l |]     -> do       env' <- bindPatt x v env       return (env' =+= l =:!= v)-  [$pa| $anti:a |]+  [pa| $x : $_ |]+    -> bindPatt x v env+  [pa| { $uid:u = $x | $y } |]+    -> do+       MultiplicativeRecord fields <- vprjM v+       (v', fields') <- extractField u fields+       env' <- bindPatt x v' env+       bindPatt y (vinj (MultiplicativeRecord fields')) env'+  [pa| ! $x |]+    -> bindPatt x v env+  [pa| $anti:a |]     -> antifail "dynamics" a-  [$pa| $antiL:a |]+  [pa| $antiL:a |]     -> antifail "dynamics" a   where perr = fail $                  "BUG! In bindPat, pattern match failure should " ++                  "raise PatternMatch exception, but didn’t!" +-- | Extract the first matching field from an associating list,+-- returning the remaining list as well.+extractField ∷ (Eq k, Monad m) =>+             k -> [(k, v)] -> m (v, [(k, v)])+extractField _ [] = fail "BUG! missing record field in pattern match"+extractField k ((k',v):kvs)+  | k == k'     = return (v, kvs)+  | otherwise   = second ((k',v):) `liftM` extractField k kvs+ throwPatternMatch :: Value -> [String] -> E -> IO a throwPatternMatch v ps _ =   throw VExn {-    exnValue = VaCon (uid "PatternMatch") (Just (vinj (show v, ps)))+    exnValue = VaCon (ident "PatternMatch") (Just (vinj (show v, ps)))   }  throwBadLetRec :: String -> IO a throwBadLetRec v =   throw VExn {-    exnValue = VaCon (uid "UninitializedLetRec") (Just (vinj v))+    exnValue = VaCon (ident "UninitializedLetRec") (Just (vinj v))   } -runtimeBug :: Loc -> String -> String -> IO a-runtimeBug  = throwAlms <$$$> almsBug DynamicsPhase+throwFailure :: String -> IO a+throwFailure v =+  throw VExn {+    exnValue = VaCon (ident "Failure") (Just (vinj v))+  } +runtimeBug :: String -> String -> IO a+runtimeBug  = throwAlms <$$> almsBug DynamicsPhase+ --- --- 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 :: VarId R -> Value -> Value+nameFun n (VaFun (FNAnonymous _) lam)+  | idName n /= "it"+                 = VaFun (FNNamed (text (idName n))) lam nameFun _ value  = value  -- Get the name of an applied function@@ -279,7 +366,7 @@  -- | For printing in the REPL, 'addDecls' returns an environment --   mapping any newly bound names to their values-type NewValues = Env (Lid R) Value+type NewValues = Env (VarId R) Value  -- | Interpret declarations by adding to the environment, potentially --   with side effects@@ -291,11 +378,11 @@   return (env', vl')  -- | Bind a name to a value-addVal :: E -> Lid R -> Value -> E+addVal :: E -> VarId 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 -> ModId R -> E -> E addMod e n e' = e =+= n =:= collapse e'
src/Env.hs view
@@ -1,42 +1,37 @@+{-# LANGUAGE OverlappingInstances #-} -- | 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, (-:-), (-::-),+  Env.empty, (-:-), (-::-),   (-:+-), (-+-), (-\-), (-\\-), (-|-),   -- ** Destructors-  isEmpty, (-.-),+  isEmpty, numberOfKeys, (-.-),   -- ** Higher-order constructors   unionWith, unionSum, unionProduct,   -- ** Higher-order destructors   mapVals, mapValsM, mapAccum, mapAccumM,   -- ** List conversions-  toList, fromList, domain, range,+  Env.toList, fromList, domain, range,    -- * Deep environments   PEnv(..), Path(..), ROOT(..), (<.>),    -- * Generalized environments   GenEmpty(..),-  GenExtend(..), (=++=), GenModify(..), GenRemove(..),+  GenExtend(..), (=++=),   GenLookup(..),+  GenNewEnv(..),    -- * Aliases (why?)-  (=:=), (=::=), (=:+=)+  (=:=), (=:*=), (=::=), (=:+=) ) where +import Prelude ()+ import Util import qualified Data.Map as M import qualified Data.Set as S@@ -45,7 +40,7 @@  infix 6 -:-, -::-, -:+- infixl 6 -.--infixr 5 -+-+infixl 5 -+- infixl 5 -\-, -\\-, -|-  -- | The basic type, mapping keys @k@ to values @v@@@ -73,6 +68,10 @@ isEmpty  :: Env k v -> Bool isEmpty   = M.null . unEnv +-- | The number of bindings in the environment+numberOfKeys  :: Env k v -> Int+numberOfKeys   = M.size . unEnv+ -- | Create a singleton environment (-:-)    :: Ord k => k -> v -> Env k v k -:- v   = Env (M.singleton k v)@@ -125,7 +124,7 @@  infix 5 `unionSum`, `unionProduct` -instance Ord k => Functor (Env k) where+instance Functor (Env k) where   fmap f = Env . M.map f . unEnv  -- | Map over the values of an environment@@ -158,7 +157,7 @@       helper a' ((k, w) : acc) rest  -- | Get an association list-toList   :: Ord k => Env k v -> [(k, v)]+toList   :: Env k v -> [(k, v)] toList    = M.toList . unEnv  -- | Make an environment from an association list@@ -166,18 +165,18 @@ fromList  = Env . M.fromList  -- | The keys-domain   :: Ord k => Env k v -> [k]+domain   :: Env k v -> [k] domain    = M.keys . unEnv  -- | The values-range    :: Ord k => Env k v -> [v]+range    :: Env k v -> [v] range     = M.elems . unEnv  instance Ord k => Monoid (Env k v) where-  mempty      = empty+  mempty      = Env.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+instance (Show k, Show v) => Show (Env k v) where   showsPrec _ env = foldr (.) id     [ shows k . (" : "++) . shows v . ('\n':)     | (k, v) <- M.toList (unEnv env) ]@@ -191,17 +190,11 @@  infix 6 =:=, =::=, =:+= infixl 6 =.=, =..=-infixr 5 =+=, =++=-infixl 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+instance GenEmpty (Env k v) where genEmpty = Env.empty  -- | A path environment maps paths of @p@ components to @e@. data PEnv p e = PEnv {@@ -234,6 +227,9 @@ instance Ord p => Functor (PEnv p) where   fmap f (PEnv envs vals) = PEnv (fmap (fmap f) envs) (f vals) +instance Bogus k => Bogus (Path p k) where+  bogus = J [] bogus+ instance (Show p, Show k) => Show (Path p k) where   showsPrec _ (J ps k) = foldr (\p r -> shows p . ('.':) . r) (shows k) ps @@ -263,9 +259,6 @@ 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.@@ -286,7 +279,7 @@   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+  penv =+= e = penv =+= fmap (PEnv (Env.empty :: Env p (PEnv p e))) e  instance GenExtend e e' =>          GenExtend (PEnv p e) e' where@@ -298,7 +291,7 @@  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)+  penv =+= env = foldr (flip (=+=)) penv (Env.toList env)  instance (Ord p, Ord k, GenEmpty e, GenExtend e (Env k v)) =>          GenExtend (PEnv p e) (Path p k, v) where@@ -343,86 +336,13 @@   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    +  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@@ -431,3 +351,16 @@ instance GenEmpty e => GenEmpty (PEnv p e) where   genEmpty = PEnv genEmpty genEmpty +-- Make new environments from a variety of things+class GenNewEnv k' v' k v | k' v' → k v where+  (-:*-)  ∷ k' → v' → Env k v+  (-::*-) ∷ Monad m ⇒ k' → v' → Env k (m v)+  k' -::*- v' = return <$> (k' -:*- v')++instance Ord k ⇒ GenNewEnv [k] [v] k v where+  ks -:*- vs = fromList (zip ks vs)++(=:*=) :: GenNewEnv k' v' k v ⇒ k' → v' → Env k v+(=:*=)  = (-:*-)++infix 6 -:*-, -::*-, =:*=
+ src/Error.hs view
@@ -0,0 +1,449 @@+module Error (+  AlmsError(..), Phase(..),+  almsBug, (!::),+  wordsMsg, quoteMsg, pprMsg, showMsg, emptyMsg,+  throw,++  MonadAlmsError(..),+  unTryAlms, finallyAlms,+  addErrorContext,+  bailoutIfError,++  AlmsErrorT(..), runAlmsErrorT,+  mapAlmsErrorT, liftCallCC, liftCatch, liftListen, liftPass,++  AlmsErrorIO(..), runAlmsErrorIO,++  module Message.Quasi,+) where++import Util+import Util.MonadRef+import Util.Trace+import Data.Loc+import Syntax.PprClass+import Message.AST+import Message.Render ()+import Message.Quasi++import Prelude ()+import Data.Typeable (Typeable)+import Control.Applicative+import Control.Exception (Exception, throwIO, throw, catch)++import qualified Control.Monad.Cont as Cont+import qualified Control.Monad.Trans.Identity as Identity+import qualified Control.Monad.Trans.Maybe as Maybe+import qualified Control.Monad.Trans.List as List+import qualified Control.Monad.Error as Error+import qualified Control.Monad.Trans.Reader as Reader+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS+import qualified Control.Monad.Trans.RWS.Lazy   as LazyRWS+import qualified Control.Monad.Trans.State.Strict as StrictState+import qualified Control.Monad.Trans.State.Lazy   as LazyState+import qualified Control.Monad.Trans.Writer.Strict as StrictWriter+import qualified Control.Monad.Trans.Writer.Lazy   as LazyWriter++--+-- Representation of Alms errors+--++-- | Alms internal exceptions+data AlmsError+  = AlmsError {+      exnPhase   :: Phase,    -- | When did it happen?+      exnLoc     :: Loc,      -- | Where in the source did it happen?+      exnMessage :: Message V -- | What happened?+  }+  deriving (Typeable, Eq)++-- | The phases in which an error might occur:+data Phase+  = ParserPhase+  | RenamerPhase+  | StaticsPhase+  | DynamicsPhase+  | OtherError String+  deriving (Eq, Ord, Show)++-- | Error constructors++almsBug :: Phase -> String -> String -> AlmsError+almsBug phase culprit0 msg0 =+  let culprit = if null culprit0+                  then "unknown"+                  else culprit0 in+  AlmsError (OtherError "BUG! in Alms implementation")+                bogus+                [msg|+                  This shouldn’t happen, so it probably+                  indicates a bug in the Alms implementation.+                  <p>+                  Details:+                  <dl>+                    <dt>who:  <dd>$words:culprit+                    <dt>what: <dd>$words:msg0+                    <dt>when: <dd>$show:phase+                  </dl>+                  <p>+                  Please report to <exact><tov@ccs.neu.edu></exact>.+                |]++(!::) :: Ppr a => String -> a -> Message d+msg0 !:: thing = [msg| $words:msg0 <q>$thing</q> |]+infix 1 !::++---+--- 'AlmsError' Instances+---++instance Ppr AlmsError where+  ppr (AlmsError phase loc msg0) =+     (text phaseString <+> locString <> colon)+     $$+     ppr (Indent msg0)+     where locString   = if isBogus loc+                           then mempty+                           else text "at" <+> text (show loc)+           phaseString = case phase of+             ParserPhase   -> "Syntax error"+             RenamerPhase  -> "Type error"+             StaticsPhase  -> "Type error"+             DynamicsPhase -> "Run-time error"+             OtherError s  -> s++instance Show AlmsError where showsPrec = showFromPpr++instance Exception AlmsError++instance Error AlmsError where+  strMsg = AlmsError (OtherError "Error") bogus . Words++---+--- The MonadAlmsError class for carrying alms errors+---++-- | A class for managing multiple errors with messages and source+--   locations.  Minimal complete definition: @getLocation@,+--   @withLocation_@, @bailoutAlms_@, @reportAlms_@, and @catchAlms@.+class Monad m => MonadAlmsError m where+  -- | Find out the current source location.+  getLocation   :: m Loc+  -- | Run a computation in the context of the given source location.+  withLocation  :: Locatable loc ⇒ loc -> m a -> m a+  -- | Add an error to the collection of errors, but keep running.+  reportAlms    :: AlmsError -> m ()+  -- | Report an error and give up running.+  throwAlms     :: AlmsError -> m a+  -- | Report some errors and give up running.+  throwAlmsList :: [AlmsError] -> m a+  -- | If any errors have occurred, collect them and give them to+  --   a handler.  The list should be non-empty.+  catchAlms     :: m a -> ([AlmsError] -> m a) -> m a+  -- | Map any errors propagating upward+  mapAlmsErrors :: (AlmsError -> AlmsError) -> m a -> m a+  --+  -- Low-level methods (not intended for client use)+  --+  withLocation_ :: Loc -> m a -> m a+  bailoutAlms_  :: m a+  reportAlms_   :: AlmsError -> m ()+  --+  -- Default implementations+  --+  withLocation locatable =+    let loc = getLoc locatable+     in if isBogus loc+          then id+          else withLocation_ loc+  reportAlms e      = do+    if isBogus (exnLoc e)+      then do+        loc <- getLocation+        reportAlms_ e { exnLoc = loc }+      else reportAlms_ e+  throwAlms e      = reportAlms e >> bailoutAlms_+  throwAlmsList es = mapM reportAlms es >> bailoutAlms_++unTryAlms :: MonadAlmsError m =>+             m (Either [AlmsError] a) -> m a+unTryAlms  = (either throwAlmsList return =<<)++infixl 1 `catchAlms`++finallyAlms :: MonadAlmsError m =>+               m a -> m () -> m a+finallyAlms action cleanup = do+  result <- action `catchAlms` (>>) cleanup . throwAlmsList+  cleanup+  return result++infixl 1 `finallyAlms`++addErrorContext :: MonadAlmsError m =>+                 m a ->+                 Message d ->+                 m a+addErrorContext action message =+  mapAlmsErrors eachError action+  where+  eachError exn = +    exn { exnMessage = [msg| $1 <br> $2 |] message (exnMessage exn) }++infixl 1 `addErrorContext`++bailoutIfError :: MonadAlmsError m => m a -> m a+bailoutIfError action = action `catchAlms` throwAlmsList++--+-- Instances+--++-- | This doesn't work very well+instance MonadAlmsError IO where+  getLocation     = return bogus+  withLocation_ _ = id+  bailoutAlms_    = fail ""+  reportAlms_     = throwIO+  catchAlms action handler = Control.Exception.catch action handler'+    where handler' e = handler [e]+  mapAlmsErrors f action = Control.Exception.catch action (throwIO . f)++--+-- A monad transformer+--++newtype AlmsErrorT m a+  = AlmsErrorT {+      unAlmsErrorT :: Maybe.MaybeT (StrictRWS.RWST LocMap [AlmsError] () m) a+    }+type LocMap = (Loc, AlmsError -> AlmsError)++instance Monad m => Functor (AlmsErrorT m) where+  fmap  = liftM++instance Monad m => Applicative (AlmsErrorT m) where+  pure  = return+  (<*>) = ap++instance Monad m => Monad (AlmsErrorT m) where+  return  = AlmsErrorT . return+  m >>= k = AlmsErrorT (unAlmsErrorT m >>= (unAlmsErrorT . k))+  fail s  = throwAlms (strMsg s)++instance MonadTrans AlmsErrorT where+  lift = AlmsErrorT . lift . lift++instance Monad m => MonadAlmsError (AlmsErrorT m) where+  getLocation       = AlmsErrorT (lift (asks fst))+  withLocation_ loc =+    AlmsErrorT . local (first (const loc)) . unAlmsErrorT+  bailoutAlms_      = AlmsErrorT (Maybe.MaybeT (return Nothing))+  reportAlms_ e     = AlmsErrorT . lift $ do+    f <- asks snd+    tell [f e]+  catchAlms action handler+                    = either handler return =<< lift (runAlmsErrorT action)+  mapAlmsErrors f   =+    AlmsErrorT . local (second (. f)) . unAlmsErrorT++runAlmsErrorT :: Monad m =>+                 AlmsErrorT m a -> m (Either [AlmsError] a)+runAlmsErrorT (AlmsErrorT action) = do+  (mresult, es) <- StrictRWS.evalRWST (Maybe.runMaybeT action) (bogus, id) ()+  case (mresult, es) of+    (Just a, [])  -> return (Right a)+    (_,      [])  -> return $+      Left [almsBug (OtherError "Unknown")+                    "AlmsErrorT" "got empty error list"]+    (_,      _)   -> return (Left es)++-- | Map a higher order operation through the 'AlmsErrorT' monad+mapAlmsErrorT ∷ (m (Maybe a, (), [AlmsError]) →+                 n (Maybe b, (), [AlmsError])) →+                AlmsErrorT m a → AlmsErrorT n b+mapAlmsErrorT f =+  AlmsErrorT . Maybe.mapMaybeT (StrictRWS.mapRWST f) . unAlmsErrorT++-- | Lift a @callCC@ operation through the 'AlmsErrorT' monad+liftCallCC ∷+  ((((Maybe a, (), [AlmsError]) → m (Maybe b, (), [AlmsError])) →+    m (Maybe a, (), [AlmsError])) → m (Maybe a, (), [AlmsError])) →+  ((a → AlmsErrorT m b) → AlmsErrorT m a) →+  AlmsErrorT m a+liftCallCC callCC0 kont =+  AlmsErrorT $+    Maybe.liftCallCC (StrictRWS.liftCallCC callCC0)+                     (unAlmsErrorT . kont . (AlmsErrorT .))++-- | Lift a @catch@ operation through the 'AlmsErrorT' monad+liftCatch ∷ (∀ s. m s → (e → m s) → m s) →+            AlmsErrorT m a → (e → AlmsErrorT m a) →+            AlmsErrorT m a+liftCatch catch0 action handle =+  AlmsErrorT $+    Maybe.liftCatch (StrictRWS.liftCatch catch0)+                    (unAlmsErrorT action)+                    (unAlmsErrorT . handle)++-- | Lift a @listen@ operation through the 'AlmsErrorT' monad+liftListen ∷ Monad m ⇒+             (∀ s. m s → m (s, w)) →+             AlmsErrorT m a → AlmsErrorT m (a, w)+liftListen listen' = mapAlmsErrorT $ \action → do+  ((mresult, st, es), w) ← listen' action+  return $! case mresult of+    Nothing → (Nothing, st, es)+    Just v  → (Just (v, w), st, es)++-- | Lift a @pass@ operation through the 'AlmsErrorT' monad+liftPass ∷ Monad m ⇒+           (∀ s. m (s, w → w) → m s) →+           AlmsErrorT m (a, w → w) → AlmsErrorT m a+liftPass pass' = mapAlmsErrorT $ \action → pass' $ do+  (mresult, st, es) ← action+  return $! case mresult of+    Nothing     → ((Nothing, st, es), id)+    Just (v, f) → ((Just v, st, es), f)++---+--- Running in IO+---++newtype AlmsErrorIO = AlmsErrorIO { unAlmsErrorIO ∷ [AlmsError] }+  deriving (Typeable)++instance Show AlmsErrorIO where+  show = concatMap ((++ "\n") . ('\n' :) . show) . unAlmsErrorIO++instance Exception AlmsErrorIO++-- | Run in the IO monad, accumulating all errors.+runAlmsErrorIO ∷ MonadIO m ⇒ AlmsErrorT m a → m a+runAlmsErrorIO = either (liftIO . throwIO . AlmsErrorIO) return <=< runAlmsErrorT++--+-- AlmsErrorT Pass-through instances+--++instance MonadReader r m ⇒ MonadReader r (AlmsErrorT m) where+  ask   = lift ask+  local = mapAlmsErrorT . local++instance MonadState s m ⇒ MonadState s (AlmsErrorT m) where+  get   = lift get+  put   = lift . put++instance MonadWriter w m ⇒ MonadWriter w (AlmsErrorT m) where+  tell   = lift . tell+  listen = liftListen listen+  pass   = liftPass pass++instance MonadError e m ⇒ MonadError e (AlmsErrorT m) where+  throwError = lift . throwError+  catchError = liftCatch catchError++instance Cont.MonadCont m ⇒ Cont.MonadCont (AlmsErrorT m) where+  callCC = liftCallCC Cont.callCC++instance MonadRef r m ⇒ MonadRef r (AlmsErrorT m) where+  newRef        = lift <$> newRef+  readRef       = lift <$> readRef+  writeRef      = lift <$$> writeRef++instance MonadTrace m ⇒ MonadTrace (AlmsErrorT m) where+  getTraceIndent = lift getTraceIndent+  putTraceIndent = lift <$> putTraceIndent+  putTraceString = lift <$> putTraceString++instance MonadIO m ⇒ MonadIO (AlmsErrorT m) where+  liftIO = lift . liftIO++--+-- MonadAlmsError Pass-through instances+--++instance MonadAlmsError m => MonadAlmsError (Identity.IdentityT m) where+  getLocation    = lift getLocation+  withLocation_  = Identity.mapIdentityT . withLocation_+  bailoutAlms_   = lift bailoutAlms_+  reportAlms_    = lift . reportAlms_+  catchAlms      = Identity.liftCatch catchAlms+  mapAlmsErrors  = Identity.mapIdentityT . mapAlmsErrors++instance MonadAlmsError m => MonadAlmsError (Maybe.MaybeT m) where+  getLocation    = lift getLocation+  withLocation_  = Maybe.mapMaybeT . withLocation_+  bailoutAlms_   = lift bailoutAlms_+  reportAlms_    = lift . reportAlms_+  catchAlms      = Maybe.liftCatch catchAlms+  mapAlmsErrors  = Maybe.mapMaybeT . mapAlmsErrors++instance MonadAlmsError m => MonadAlmsError (ListT m) where+  getLocation    = lift getLocation+  withLocation_  = mapListT . withLocation_+  bailoutAlms_   = lift bailoutAlms_+  reportAlms_    = lift . reportAlms_+  catchAlms      = List.liftCatch catchAlms+  mapAlmsErrors  = mapListT . mapAlmsErrors++instance MonadAlmsError m => MonadAlmsError (ReaderT r m) where+  getLocation    = lift getLocation+  withLocation_  = mapReaderT . withLocation_+  bailoutAlms_   = lift bailoutAlms_+  reportAlms_    = lift . reportAlms_+  catchAlms      = Reader.liftCatch catchAlms+  mapAlmsErrors  = mapReaderT . mapAlmsErrors++instance (MonadAlmsError m, Monoid w) =>+         MonadAlmsError (StrictRWS.RWST r w s m) where+  getLocation    = lift getLocation+  withLocation_  = StrictRWS.mapRWST . withLocation_+  bailoutAlms_   = lift bailoutAlms_+  reportAlms_    = lift . reportAlms_+  catchAlms      = StrictRWS.liftCatch catchAlms+  mapAlmsErrors  = StrictRWS.mapRWST . mapAlmsErrors++instance (MonadAlmsError m, Monoid w) =>+         MonadAlmsError (LazyRWS.RWST r w s m) where+  getLocation    = lift getLocation+  withLocation_  = LazyRWS.mapRWST . withLocation_+  bailoutAlms_   = lift bailoutAlms_+  reportAlms_    = lift . reportAlms_+  catchAlms      = LazyRWS.liftCatch catchAlms+  mapAlmsErrors  = LazyRWS.mapRWST . mapAlmsErrors++instance (MonadAlmsError m, Monoid w) =>+         MonadAlmsError (StrictWriter.WriterT w m) where+  getLocation    = lift getLocation+  withLocation_  = StrictWriter.mapWriterT . withLocation_+  bailoutAlms_   = lift bailoutAlms_+  reportAlms_    = lift . reportAlms_+  catchAlms      = StrictWriter.liftCatch catchAlms+  mapAlmsErrors  = StrictWriter.mapWriterT . mapAlmsErrors++instance (MonadAlmsError m, Monoid w) =>+         MonadAlmsError (LazyWriter.WriterT w m) where+  getLocation    = lift getLocation+  withLocation_  = LazyWriter.mapWriterT . withLocation_+  bailoutAlms_   = lift bailoutAlms_+  reportAlms_    = lift . reportAlms_+  catchAlms      = LazyWriter.liftCatch catchAlms+  mapAlmsErrors  = LazyWriter.mapWriterT . mapAlmsErrors++instance MonadAlmsError m => MonadAlmsError (StrictState.StateT s m) where+  getLocation    = lift getLocation+  withLocation_  = StrictState.mapStateT . withLocation_+  bailoutAlms_   = lift bailoutAlms_+  reportAlms_    = lift . reportAlms_+  catchAlms      = StrictState.liftCatch catchAlms+  mapAlmsErrors  = StrictState.mapStateT . mapAlmsErrors++instance MonadAlmsError m => MonadAlmsError (LazyState.StateT s m) where+  getLocation    = lift getLocation+  withLocation_  = LazyState.mapStateT . withLocation_+  bailoutAlms_   = lift bailoutAlms_+  reportAlms_    = lift . reportAlms_+  catchAlms      = LazyState.liftCatch catchAlms+  mapAlmsErrors  = LazyState.mapStateT . mapAlmsErrors+
− src/ErrorMessage.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE-      DeriveDataTypeable,-      FlexibleInstances,-      MultiParamTypeClasses,-      QuasiQuotes-      #-}-module ErrorMessage (-  AlmsException(..), Phase(..), AlmsMonad(..),-  almsBug, (!::),-  wordsMsg, quoteMsg, pprMsg, showMsg, emptyMsg,-  module Message.Quasi,-) where--import Loc-import PprClass-import Message.AST-import Message.Render ()-import Message.Quasi--import Data.Typeable (Typeable)-import Control.Exception (Exception, throwIO, catch)-import Control.Monad.Error (Error(..))------- Representation of Alms errors------- | Alms internal exceptions-data AlmsException-  = AlmsException {-      exnPhase   :: Phase,    -- | When did it happen?-      exnLoc     :: Loc,      -- | Where in the source did it happen?-      exnMessage :: Message V -- | What happened?-  }-  deriving Typeable---- | The phases in which an error might occur:-data Phase-  = ParserPhase-  | RenamerPhase-  | StaticsPhase-  | DynamicsPhase-  | OtherError String-  deriving Show---- | Error constructors--almsBug :: Phase -> Loc -> String -> String -> AlmsException-almsBug phase loc culprit0 msg0 =-  let culprit = if null culprit0-                  then "unknown"-                  else culprit0 in-  AlmsException (OtherError "BUG! in Alms implementation")-                bogus-                [$msg|-                  This shouldn’t happen, so it probably-                  indicates a bug in the Alms implementation.-                  <p>-                  Details:-                  <dl>-                    <dt>who:  <dd>$words:culprit-                    <dt>what: <dd>$words:msg0-                    <dt>where:<dd>$show:loc-                    <dt>when: <dd>$show:phase-                  </dl>-                  <p>-                  Please report to <exact><tov@ccs.neu.edu></exact>.-                |]--(!::) :: Ppr a => String -> a -> Message d-msg0 !:: thing = [$msg| $words:msg0 <q>$thing</q> |]-infix 1 !::--------- The AlmsMonad class for carrying alms errors------class Monad m => AlmsMonad m where-  throwAlms :: AlmsException -> m a-  catchAlms :: m a -> (AlmsException -> m a) -> m a-  unTryAlms :: m (Either AlmsException a) -> m a-  unTryAlms  = (>>= either throwAlms return)--instance AlmsMonad IO where-  throwAlms = throwIO-  catchAlms = Control.Exception.catch--instance AlmsMonad (Either AlmsException) where-  throwAlms = Left-  catchAlms (Right a) _ = Right a-  catchAlms (Left e)  k = k e--------- Instances------instance Ppr AlmsException where-  ppr (AlmsException phase loc msg0) =-     (text phaseString <+> locString <> colon)-     $$-     ppr (Indent msg0)-     where locString   = if isBogus loc-                           then empty-                           else text "at" <+> text (show loc)-           phaseString = case phase of-             ParserPhase   -> "Syntax error"-             RenamerPhase  -> "Type error"-             StaticsPhase  -> "Type error"-             DynamicsPhase -> "Run-time error"-             OtherError s  -> s--instance Show AlmsException where showsPrec = showFromPpr--instance Exception AlmsException--instance Error AlmsException where-  strMsg = AlmsException (OtherError "Error") bogus . Words-
− src/ErrorST.hs 
@@ -1,143 +0,0 @@--- | 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, MonadError e m) => (forall s. ST s e a) -> m a-runST block =-  either throwError return $-    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 
@@ -1,295 +0,0 @@--- | Lexer setup for parsec-module Lexer (-  -- * Class for saving pre-whitespace position-  T.TokenEnd(..),-  -- * Identifier tokens-  isUpperIdentifier, lid, uid,--  -- * Operators-  semis, bang, star, slash, plus,-  sharpLoad, sharpInfo, sharpPrec,-  lolli, arrow, funbraces,-  lambda, forall, exists, mu,-  qualbox,-  qualU, qualA, qdisj, qconj,-  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 Util--import Data.Char-import Text.ParserCombinators.Parsec-import qualified Token as T--tok :: T.TokenEnd st => 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        = satisfy isOpStart,-    T.opLetter       = satisfy isOpLetter,-    T.reservedNames  = ["fun", "λ",-                        "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-  }--isOpStart, isOpLetter :: Char -> Bool-isOpStart c-  | isAscii c = c `elem` "!$%&*+-/<=>?@^|~"-  | otherwise = case generalCategory c of-      ConnectorPunctuation  -> True-      DashPunctuation       -> True-      OtherPunctuation      -> True-      MathSymbol            -> True-      CurrencySymbol        -> True-      OtherSymbol           -> True-      _                     -> False-isOpLetter c-  | isAscii c = c `elem` "!$%&*+-/<=>?@^|~.:"-  | otherwise = case generalCategory c of-      ConnectorPunctuation  -> True-      DashPunctuation       -> True-      OtherPunctuation      -> True-      MathSymbol            -> True-      CurrencySymbol        -> True-      OtherSymbol           -> True-      ModifierSymbol        -> True -- not in OpStart-   -- OpenPunctuation-   -- ClosePunctuation-   -- InitialQuote-   -- FinalQuote-      _                     -> False--identifier      :: T.TokenEnd st => CharParser st String-identifier       = T.identifier tok-reserved        :: T.TokenEnd st => String -> CharParser st ()-reserved         = T.reserved tok-operator        :: T.TokenEnd st => CharParser st String-operator         = T.operator tok-reservedOp      :: T.TokenEnd st => String -> CharParser st ()-reservedOp       = T.reservedOp tok-charLiteral     :: T.TokenEnd st => CharParser st Char-charLiteral      = T.charLiteral tok-stringLiteral   :: T.TokenEnd st => CharParser st String-stringLiteral    = T.stringLiteral tok-natural         :: T.TokenEnd st => CharParser st Integer-natural          = T.natural tok-integer         :: T.TokenEnd st => CharParser st Integer-integer          = lexeme $ try $ do-  sign <- choice [-            char '+' >> return id,-            char '-' >> return negate,-            return id-          ]-  nat  <- natural-  return (sign nat)-integerOrFloat  :: T.TokenEnd st => 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           :: T.TokenEnd st => CharParser st Double-float            = T.float tok-naturalOrFloat  :: T.TokenEnd st => CharParser st (Either Integer Double)-naturalOrFloat   = T.naturalOrFloat tok-decimal         :: T.TokenEnd st => CharParser st Integer-decimal          = T.decimal tok-hexadecimal     :: T.TokenEnd st => CharParser st Integer-hexadecimal      = T.hexadecimal tok-octal           :: T.TokenEnd st => CharParser st Integer-octal            = T.octal tok-symbol          :: T.TokenEnd st => String -> CharParser st String-symbol           = T.symbol tok-lexeme          :: T.TokenEnd st => CharParser st a -> CharParser st a-lexeme           = T.lexeme tok-whiteSpace      :: T.TokenEnd st => CharParser st ()-whiteSpace       = T.whiteSpace tok-parens          :: T.TokenEnd st => CharParser st a -> CharParser st a-parens           = T.parens tok-braces          :: T.TokenEnd st => CharParser st a -> CharParser st a-braces           = T.braces tok-angles          :: T.TokenEnd st => CharParser st a -> CharParser st a-angles           = T.angles tok-brackets        :: T.TokenEnd st => CharParser st a -> CharParser st a-brackets         = T.brackets tok-squares         :: T.TokenEnd st => CharParser st a -> CharParser st a-squares          = T.squares tok-semi            :: T.TokenEnd st => CharParser st String-semi             = T.semi tok-comma           :: T.TokenEnd st => CharParser st String-comma            = T.comma tok-colon           :: T.TokenEnd st => CharParser st String-colon            = T.reservedOp tok ":" >> return ":"-dot             :: T.TokenEnd st => CharParser st String-dot              = T.dot tok-semiSep         :: T.TokenEnd st => CharParser st a -> CharParser st [a]-semiSep          = T.semiSep tok-semiSep1        :: T.TokenEnd st => CharParser st a -> CharParser st [a]-semiSep1         = T.semiSep1 tok-commaSep        :: T.TokenEnd st => CharParser st a -> CharParser st [a]-commaSep         = T.commaSep tok-commaSep1       :: T.TokenEnd st => CharParser st a -> CharParser st [a]-commaSep1        = T.commaSep1 tok---- | The @#load@ pragma-sharpLoad       :: T.TokenEnd st => CharParser st ()-sharpLoad        = reserved "#l" <|> reserved "#load"---- | The @#info@ pragma-sharpInfo       :: T.TokenEnd st => CharParser st ()-sharpInfo        = reserved "#i" <|> reserved "#info"---- | The @#prec@ pragma-sharpPrec       :: T.TokenEnd st => CharParser st ()-sharpPrec        = reserved "#p" <|> reserved "#prec"---- | @!@, which has special meaning in let patterns-bang            :: T.TokenEnd st => CharParser st String-bang             = symbol "!"---- | The @-o@ type operator, which violates our other lexer rules-lolli           :: T.TokenEnd st => CharParser st ()-lolli            = reserved "-o" <|> reservedOp "⊸"---- | The @->@ type operator-arrow           :: T.TokenEnd st => CharParser st ()-arrow            = reservedOp "->" <|> reservedOp "→"---- | The left part of the $-_>$ operator-funbraceLeft    :: T.TokenEnd st => CharParser st ()-funbraceLeft     = try (symbol "-") >> return ()---- | The right part of the $-_>$ operator-funbraceRight   :: T.TokenEnd st => CharParser st ()-funbraceRight    = try (symbol ">") >> return ()---- | The left part of the $-[_]>$ operator-oldFunbraceLeft    :: T.TokenEnd st => CharParser st ()-oldFunbraceLeft     = try (symbol "-[") >> return ()---- | The right part of the $-[_]>$ operator-oldFunbraceRight   :: T.TokenEnd st => CharParser st ()-oldFunbraceRight    = try (symbol "]>") >> return ()--funbraces       :: T.TokenEnd st => CharParser st a -> CharParser st a-funbraces        = liftM2 (<|>) (between oldFunbraceLeft oldFunbraceRight)-                                (between funbraceLeft funbraceRight)---- | The left part of the $|[_]$ annotation-qualboxLeft     :: T.TokenEnd st => CharParser st ()-qualboxLeft      = try (symbol "|[") >> return ()---- | The right part of the $|[_]$ annotation-qualboxRight    :: T.TokenEnd st => CharParser st ()-qualboxRight     = try (symbol "]") >> return ()--qualbox         :: T.TokenEnd st => CharParser st a -> CharParser st a-qualbox          = between qualboxLeft qualboxRight---- | The function keyword-lambda          :: T.TokenEnd st => CharParser st ()-lambda           = reserved "fun" <|> reservedOp "λ" <|> reservedOp "Λ"---- | The universal quantifier keyword-forall          :: T.TokenEnd st => CharParser st ()-forall           = reserved "all" <|> reservedOp "∀"---- | The existential quantifier keyword-exists          :: T.TokenEnd st => CharParser st ()-exists           = reserved "ex" <|> reservedOp "∃"---- | The recursive type binder-mu              :: T.TokenEnd st => CharParser st ()-mu               = reserved "mu" <|> reservedOp "μ"---- | @;@, @;;@, ...-semis           :: T.TokenEnd st => CharParser st String-semis            = lexeme (many1 (char ';'))---- | @*@, which is reserved in types but not in expressions-star            :: T.TokenEnd st => CharParser st String-star             = symbol "*" <|> symbol "×"---- | @/@, which is reserved in types but not in expressions-slash           :: T.TokenEnd st => CharParser st String-slash            = symbol "/"---- | @+@, which is reserved in types but not in expressions-plus            :: T.TokenEnd st => CharParser st String-plus             = symbol "+"---- | Qualifier @U@ (not reserved)-qualU    :: T.TokenEnd st => CharParser st ()-qualU     = reserved "U"--- | Qualifier @A@ (not reserved)-qualA    :: T.TokenEnd st => CharParser st ()-qualA     = reserved "A"---- | Infix operator for qualifier disjunction-qdisj           :: T.TokenEnd st => CharParser st ()-qdisj            = reservedOp "," <|> reservedOp "\\/" <|> reservedOp "⋁"---- | Infix operator for qualifier conjunction-qconj           :: T.TokenEnd st => CharParser st ()-qconj            = reservedOp "/\\" <|> reservedOp "⋀"---- | 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        :: T.TokenEnd st => CharParser st String-lid              = try $ do-  s <- identifier-  if isUpperIdentifier s-    then pzero <?> "lowercase identifier"-    else return s--- | Lex an uppercase identifer-uid        :: T.TokenEnd st => 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 :: T.TokenEnd st => Prec -> CharParser st String-opP p = try $ do-  op <- operator-  if precOp op == p-    then return op-    else pzero-
− src/Loc.hs 
@@ -1,222 +0,0 @@--- | 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 = showString (showFile (file loc))-    | otherwise   =-        showString (showFile (file loc)) . showString " (" .-        showCoords . showString ")"-    where-    showCoords =-      if line1 loc == line2 loc then-        showString "line " . shows (line1 loc) . showString ", " .-        if col1 loc + 1 >= col2 loc 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)-    showFile "-" = "<stdin>"-    showFile s   =-      let shown = show s-       in if shown == '"' : s ++ "\""-            then shown-            else s-
src/Main.hs view
@@ -1,37 +1,40 @@ -- | The main driver program, which performs all manner of unpleasant --   tasks to tie everything together-{-# LANGUAGE CPP #-} module Main (-  main+  main,+  -- * For interactive exploration from GHCi+  makeRS0, check, ) where  import Util-import Ppr (Doc, Ppr(..), (<+>), (<>), text, char, hang,-            ($$), nest, printDoc, hPrintDoc)-import qualified Ppr-import Parser (parseFile, REPLCommand(..), parseCommand)-import Prec (precOp)+import Util.MonadRef+import Util.UndoIO+import Syntax.ImplicitThreading+import Syntax.Ppr (Doc, Ppr(..), (<+>), (<>), text, char, hang,+                   printDoc, hPrintDoc)+import qualified Syntax.Ppr as Ppr+import Syntax.Parser (parseFile, REPLCommand(..), parseCommand)+import Syntax.Prec (precOp) import Paths (findAlmsLib, findAlmsLibRel, versionString, shortenPath)-import Printing (addTyNameContext)-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 Meta.Quasi+import Statics 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,+import qualified AST+import AST (Prog, Decl, SigItem, prog2decls,                Ident, Raw, Renamed) import Env (empty, (=..=))-import Loc (isBogus, initial, bogus)-import qualified ErrorMessage as EM+import Error import qualified Message.AST  as Msg+import Type.Ppr (TyConInfo(..)) +import Prelude () import Data.Char (isSpace)-import System.Exit (exitFailure)+import Data.List (nub)+import Data.IORef (IORef)+import System.Exit (exitFailure, exitSuccess, ExitCode) import System.Environment (getArgs, getProgName, withProgName, withArgs) import System.IO.Error (ioeGetErrorString, isUserError) import IO (hPutStrLn, hFlush, stdout, stderr)@@ -42,7 +45,6 @@ #endif  data Option = Don'tExecute-            | Don'tCoerce             | NoBasis             | Verbose             | Quiet@@ -50,23 +52,29 @@             | NoLineEdit   deriving Eq +data ReplState = RS {+  rsStatics     :: StaticsState IORef,+  rsDynamics    :: E+}++instance Show ReplState where showsPrec = showsPrec <$.> rsStatics+ -- | 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'+  st0 <- makeRS0   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+  st1 <- (if NoBasis `elem` opts+            then return st0+            else findAlmsLib srcBasis >>= tryLoadFile st0 srcBasis)+    `handleExns` (st0, exitFailure)   st2 <- foldM (\st n -> findAlmsLibRel n "." >>= tryLoadFile st n)                st1 (reverse [ name | LoadFile name <- opts ])+    `handleExns` (st1, exitFailure)   maybe interactive (batch filename) mmsrc (`elem` opts) st2     `handleExns` (st2, exitFailure) @@ -83,112 +91,102 @@     name' <- shortenPath name     loadString st name' src +makeRS0 :: IO ReplState+makeRS0  = do+  (primBasis', r0) <- basis2renv primBasis+  g0 <- basis2tenv (staticsState0 r0) primBasis'+  e0 <- basis2venv primBasis'+  return (RS g0 e0)++-- For trying things from GHCi+check :: ReplState -> String -> IO ReplState+check rs = loadString rs "<check>"+ loadString :: ReplState -> String -> String -> IO ReplState loadString st name src = do   case parseFile name src of     Left e     -> Exn.throwIO 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+    Right ast  -> do+      ast1           <- runAlmsErrorIO (mapM threadDecl (prog2decls ast))+      (st2, _, ast2) <- runAlmsErrorIO (statics (st, ast1))+      (st3, _)       <- dynamics (st2, ast2)+      return st3  batch :: String -> IO String -> (Option -> Bool) -> ReplState -> IO ()-batch filename msrc opt st0 = do+batch filename msrc opt st = do       src <- msrc       case parseFile filename src of         Left e    -> Exn.throwIO 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+        Right ast -> thread ast where+          thread    :: Prog Raw -> IO ()+          typecheck :: Prog Raw -> IO ()+          execute   :: Prog Renamed -> IO () -          check ast0 = do-            ((t, ast1), _) <- runTC (rsStatics st0) (tcProg ast0)+          thread ast0 = do+            ast1 <- runAlmsErrorIO (threadProg ast0)             when (opt Verbose) $-              mumble "TYPE" t-            coerce ast1+              mumble "THREADING" ast1+            typecheck 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+          typecheck ast1 = do+            (ast2, mt) <- runAlmsErrorIO (typeCheckProg (rsStatics st) ast1)+            when (opt Verbose) $+              mumble "TYPE" mt+            execute ast2            execute ast2 =             unless (opt Don'tExecute) $ do-              v <- eval (rsDynamics st0) ast2+              v <- eval (rsDynamics st) 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])+statics     :: (MonadRef IORef m, MonadAlmsError m) ⇒+               (ReplState, [Decl Raw]) ->+               m (ReplState, [SigItem Renamed], [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')+statics (rs, ast) = do+  (ast', sig, s') <- typeCheckDecls (rsStatics rs) ast+  return (rs { rsStatics = s' }, sig, ast')  dynamics (rs, ast) = do   (e', new) <- addDecls (rsDynamics rs) ast   return (rs { rsDynamics = e' }, new)  carp :: String -> IO ()-carp msg = do+carp message = do   prog <- getProgName-  hPutStrLn stderr (prog ++ ": " ++ msg)+  hPutStrLn stderr (prog ++ ": " ++ message)  handleExns :: IO a -> (ReplState, IO a) -> IO a handleExns body (st, handler) =   body     `Exn.catches`-    [ Exn.Handler $ \e@(VExn { }) -> do+    [ Exn.Handler $ \(e ∷ ExitCode) -> Exn.throwIO e,+      Exn.Handler $ \e@(VExn { }) -> do         prog <- getProgName-        continue $ EM.AlmsException-                     (EM.OtherError ("Uncaught exception"))-                     bogus-                     (Msg.Table [-                        ("in program:", Msg.Exact prog),-                        ("exception:", Msg.Printable (-1) (vppr e))-                     ]),+        continue1 $+          AlmsError+            (OtherError ("Uncaught exception"))+            bogus+            (Msg.Table [+               ("in program:", Msg.Exact prog),+               ("exception:", Msg.Printable (-1) (vppr e))+          ]),+      Exn.Handler continue1,       Exn.Handler continue,       Exn.Handler $ \err ->-        continue $ EM.AlmsException EM.DynamicsPhase bogus $+        continue1 $ AlmsError DynamicsPhase bogus $           Msg.Flow [Msg.Words (errorString err)],       Exn.Handler $ \(Exn.SomeException err) ->-        continue $ EM.AlmsException EM.DynamicsPhase bogus $+        continue1 $ AlmsError DynamicsPhase bogus $           Msg.Flow [Msg.Words (show err)] ]   where-    continue err = do-      hPrintDoc stderr (withRS st (ppr (err :: EM.AlmsException)))+    continue1 err = continue (AlmsErrorIO [err])+    continue errs = do+      for (nub (unAlmsErrorIO errs)) $ \err -> do+        hPrintDoc stderr (withRS st (ppr err))+        hPutStrLn stderr ""       handler  interactive :: (Option -> Bool) -> ReplState -> IO ()@@ -201,53 +199,26 @@       case mres of         Nothing  -> return ()         Just (row', ast) -> do-          st' <- doLine st ast-                   `handleExns` (st, return st)+          st' <- doLine st ast `handleExns` (st, 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 st3 newDefs newVals-                               return st3--      in rename (st, ast)-    getln  = if opt NoLineEdit then getline else readline+    doLine st ast = do+      ast1                 <- runAlmsErrorIO (threadDecls ast)+      when (opt Verbose) (mumble "THREADING" ast1)+      (st2, newDefs, ast2) <- runUndoIO (runAlmsErrorIO (statics (st, ast1)))+      (st3, newVals)       <- if opt Don'tExecute+                              then return (st2, empty)+                              else dynamics (st2, ast2)+      printResult newDefs newVals+      return st3     say    = if opt Quiet then const (return ()) else printDoc-    get    = if opt Quiet then const (getln "") else getln+    getln' = if opt NoLineEdit then getline else readline+    getln  = if opt Quiet then const (getln' "") else getln'     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 "#= ")+          mline <- getln (if null acc then "#- " else "#= ")           case (mline, acc) of             (Nothing, [])        -> return Nothing             (Nothing, (_,err):_) -> do@@ -268,70 +239,59 @@                   mapM_ printPrec lids                   addHistory line                   loop (count + 1) acc+                GetConstraintCmd -> do+                  say (getConstraint (rsStatics st))+                  addHistory line+                  loop (count + 1) acc+                QuitCmd -> exitSuccess                 DeclsCmd ast -> do                   addHistory cmd                   return (Just (row + count, ast))                 ParseError derr ->                    loop (count + 1) ((line, derr) : acc)-    printResult :: ReplState -> Module -> NewValues -> IO ()-    printResult st md00 values = say (withRS st (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.askTyNames (\tn -> ppr (tyConToDec tn tc :: TyDec Renamed))-        MdModule u md1      -> Ppr.enterTyNames u $-          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)+    printResult :: [SigItem Renamed] -> NewValues -> IO ()+    printResult types values = mapM_ (say . eachItem) types+      where+      eachItem sigitem = case sigitem of+        [sgQ| val $vid:n : $t |]+          → addHang '=' (ppr <$> values =..= n) $+              addHang ':' (Just (ppr t)) $+                ppr n+        _ → ppr sigitem       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+printInfo st ident = case getRenamingInfo ident s of     []  -> putStrLn $ "Not bound: ‘" ++ show ident ++ "’"     ris -> mapM_ each ris   where     each (SigAt      loc x') =-      mention "module type" (ppr x') Ppr.empty loc+      mention "module type" (ppr x') mempty loc     each (ModuleAt   loc x') =-      mention "module" (ppr x') Ppr.empty loc+      mention "module" (ppr x') mempty loc     each (VariableAt loc x') =       case getVarInfo x' s of-        Nothing  -> mention "val" (ppr x') Ppr.empty loc+        Nothing  -> mention "val" (ppr x') mempty 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+        Nothing  -> mention "type" (ppr x') mempty loc+        Just tc  -> mention "type" mempty (ppr (TyConInfo tc)) loc     each (DataconAt  loc x') =       case getConInfo x' s of-        Nothing -> mention "val" (ppr x') Ppr.empty loc-        Just (Left mt) ->+        Nothing -> mention "val" (ppr x') mempty loc+        Just (Left tc) ->+          mention "type" mempty (ppr (TyConInfo tc)) loc+        Just (Right mt) ->           mention "type" (text "exn")                   (Ppr.sep [ text "= ...",                              char '|' <+> ppr x' <+>                              case mt of-                               Nothing -> Ppr.empty+                               Nothing -> mempty                                Just t  -> text "of" <+> ppr t ])                   loc-        Just (Right tc) ->-          mention "type" Ppr.empty (ppr tc) loc     --     s = rsStatics st     --@@ -347,7 +307,7 @@  -- Add the ReplState to the pretty-printing context. withRS :: ReplState -> Doc -> Doc-withRS rs = addTyNameContext (rsRenaming rs) (rsStatics rs)+withRS = addTyNameContext . rsStatics  printPrec :: String -> IO () printPrec oper = printDoc $@@ -358,9 +318,6 @@ 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@@ -380,7 +337,6 @@                         = 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 ("-e":r)    = loop (NoLineEdit:opts) r@@ -405,9 +361,8 @@   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)"+  hPutStrLn stderr "  -v       Verbose (show results, types)"   exitFailure  initialize :: IO ()
src/Makefile view
@@ -2,33 +2,60 @@ ## preferred way to build, but sometimes this is convenient.  GHC      = ghc+GHCI     = ghci EXE      = alms EXAMPLES = ../examples SRC      = $(HS_SRC) $(HSBOOT_SRC)-HS_SRC      = *.hs Basis/*.hs Basis/Channel/*.hs Syntax/*.hs \-              Message/*.hs Meta/*.hs-HSBOOT_SRC  = Syntax/*.hs-boot+HS_SRC   = *.hs \+           Alt/*.hs \+           AST/*.hs \+           Basis/*.hs \+           Basis/Channel/*.hs \+           Data/*.hs \+           Message/*.hs \+           Meta/*.hs \+           Statics/*.hs \+           Syntax/*.hs \+           Type/*.hs \+           Util/*.hs+HSBOOT_SRC  = AST/*.hs-boot Statics/*.hs-boot -HCOPTS  = -W -Wall -O0 $(EDITING) $(PARSEC) $(NOWARN) $(IMPARR)+HCOPTS  = -W -Wall -O0 $(EDITING) $(PARSEC) $(HIOPTS)+HIOPTS  = $(NOWARN) $(IMPARR) $(UNICODE) $(LANGUAGE) EDITING = -DUSE_READLINE=System.Console.Editline.Readline PARSEC  = -DPARSEC_VERSION=3 # IMPARR  = -DANNOTATION_PRINTING_RULE=Rule0 NOWARN  = -fno-warn-unused-do-bind -fno-warn-orphans+UNICODE = -DUNICODE+LANGUAGE= `sed 's/^/-X/' extensions.txt`  $(EXE) $(EXE)-%: $(SRC) 	$(GHC) -o $@ --make Main.hs $(HCOPTS) +%.hi: $(HS_SRC) $(HSBOOT_SRC)+	$(GHC) --make `echo "$*" | sed 's@\.@/@g'`.hs $(HCOPTS)++%.i:+	$(GHCI) \*`echo "$*" | sed 's@\.@/@g'` $(HIOPTS)+ $(EXE)-%:     GHC     = ghc-$* $(EXE)-6.8.%: EDITING = -DUSE_READLINE=System.Console.Readline $(EXE)-6.%:   PARSEC  = -DPARSEC_VERSION=2 +not-compiled:+	@find . -name \*.hs | sed 's@^\./@@' | while read hs; do \+		hi=`echo $$hs | sed 's/hs$$/hi/'`; \+		test -f $$hi || echo $$hs; \+	done+ clean: 	$(RM) $(HS_SRC:.hs=.hi) $(HS_SRC:.hs=.o) 	$(RM) $(HSBOOT_SRC:.hs-boot=.hi-boot) $(HSBOOT_SRC:.hs-boot=.o-boot) 	$(RM) $(EXE) $(EXE)-6.*  wc.%:-	find .. -name \*."$*" | xargs wc -l+	find .. -name \*."$*" | xargs wc -l | sed 's/$$/ lines/'+	@find .. -name \*."$*" | wc -l | sed 's/$$/ total .$* files/'  test tests: $(EXE) 	@$(EXAMPLES)/run-tests.sh ./$(EXE) $(EXAMPLES)
src/Message/AST.hs view
@@ -1,14 +1,11 @@-{-# LANGUAGE-      EmptyDataDecls,-      GADTs-      #-}+{-# LANGUAGE GADTs #-} module Message.AST (   Message(..),   H, V, StackStyle(..),   wordsMsg, quoteMsg, pprMsg, showMsg, emptyMsg, ) where -import PprClass+import Syntax.PprClass  -- | Simple message markup data Message d where@@ -24,8 +21,15 @@   Showable  :: Show a => a -> Message d   AntiMsg   :: String -> String -> Message d -data H-data V+-- | 'H' and 'V' need constructors or pattern matching on+--   @'Message' 'H'@ gives non-exhaustiveness warnings for unreachable+--   cases.+data H = H+data V = V++-- | Don't warn about the fact that 'H' and 'V' aren't used.+_don'tWarnAbout :: (H, V)+_don'tWarnAbout  = (H, V)  -- | Types of lists data StackStyle
src/Message/Parser.hs view
@@ -2,13 +2,14 @@   parseMessageQ, tokensT, messageP, ) where -import Loc+import Data.Loc import Message.AST import Util+import Alt.Parsec +import Prelude () import Data.Char import Language.Haskell.TH-import Text.ParserCombinators.Parsec  -- | Given the string representation of a message, parse it, --   using the Template Haskell monad to get an initial source
src/Message/Quasi.hs view
@@ -1,11 +1,4 @@-{-# LANGUAGE-      FlexibleInstances,-      GADTs,-      GeneralizedNewtypeDeriving,-      MultiParamTypeClasses,-      PatternGuards,-      TemplateHaskell-      #-}+{-# LANGUAGE GADTs #-} module Message.Quasi (   msg, Message(), H, V, ) where@@ -13,9 +6,10 @@ import Message.AST import Message.Parser import Meta.THHelpers-import PprClass-import Util+import Syntax.PprClass+import Util hiding (lift) +import Prelude () import qualified Data.Map as M import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter(..))@@ -69,7 +63,7 @@         where each (s,msg') = [| ($(lift s), $(loop msg')) |]       Indent msg' -> [| Indent $(loop msg') |]       Printable d a-                  -> [| Exact $(lift (show (PprClass.pprDepth d a))) |]+                  -> [| Exact $(lift (show (pprDepth d a))) |]       Showable a  -> [| Exact $(lift (show a)) |]       AntiMsg tag name -> case tag of         "words"   -> [| Words $var |]
src/Message/Render.hs view
@@ -1,14 +1,9 @@-{-# LANGUAGE-      FlexibleInstances,-      GADTs,-      ParallelListComp,-      QuasiQuotes-      #-}+{-# LANGUAGE GADTs #-} module Message.Render (-  module PprClass+  module Syntax.PprClass ) where -import PprClass+import Syntax.PprClass import Message.AST  -- | Context for message rendering@@ -21,20 +16,33 @@     }  rc0 :: RenderContext-rc0  = RenderContext (-1) 0 empty empty+rc0  = RenderContext (-1) 0 mempty mempty  getQuotes :: RenderContext -> (String, String) getQuotes cxt =   if even (rcQtLevel cxt)+#ifdef UNICODE     then ("‘", "’")     else ("“", "”")+#else+    then ("'", "'")+    else ("\"", "\"")+#endif +bullet :: Char+#if UNICODE+bullet  = '•'+#else+bullet  = '-'+#endif++ incQuotes :: RenderContext -> RenderContext incQuotes cxt = cxt { rcQtLevel = rcQtLevel cxt + 1 }  clearLeft, clearRight :: RenderContext -> RenderContext-clearLeft cxt  = cxt { rcLeft = empty }-clearRight cxt = cxt { rcRight = empty }+clearLeft cxt  = cxt { rcLeft = mempty }+clearRight cxt = cxt { rcRight = mempty }  addQuotes :: RenderContext -> Doc -> Doc addQuotes cxt doc = rcLeft cxt <> doc <> rcRight cxt@@ -46,7 +54,7 @@ renderMessageH cxt msg0 = case msg0 of   Words s     -> renderMessageH cxt (Flow (map Exact (words s)))   Exact s     -> [addQuotes cxt (text s)]-  Flow []     -> [addQuotes cxt empty]+  Flow []     -> [addQuotes cxt mempty]   Flow [msg'] -> renderMessageH cxt msg'   Flow (m:ms) -> renderMessageH (clearRight cxt) m ++                  concatMap (renderMessageH cxt') (init ms) ++@@ -84,7 +92,7 @@                       | i    <- [ 1 .. ] ]       where len  = length msgs             dent = length (show len)-    Bulleted  -> vcat [ text " •" <+> nest 3 (renderMessage cxt msg')+    Bulleted  -> vcat [ space <> char bullet <+> nest 3 (renderMessage cxt msg')                       | msg' <- msgs ]     Separated -> vcat (punctuate (char '\n')                                  (map (renderMessage cxt) msgs))@@ -104,3 +112,5 @@ instance Ppr (Message d)  where ppr = renderMessage rc0 instance Show (Message d) where showsPrec = showFromPpr +instance Eq (Message d) where+  msg1 == msg2 = show msg1 == show msg2
src/Meta/DeriveNotable.hs view
@@ -1,13 +1,9 @@-{-# LANGUAGE-      FlexibleInstances,-      MultiParamTypeClasses,-      TemplateHaskell,-      TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} module Meta.DeriveNotable (   deriveNotable ) where -import Syntax.Notable+import AST.Notable import Meta.THHelpers  import Data.Char (toLower)
src/Meta/Quasi.hs view
@@ -1,20 +1,12 @@-{-# 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,+  pa, ty, ex, dc,+  prQ, tdQ, atQ, caQ, bnQ, fdQ, meQ, qeQ, tpQ, seQ, sgQ, ) where  import Meta.QuoteData import Meta.THHelpers-import Parser-import Syntax+import Syntax.Parser+import AST import Util  import Data.Generics@@ -22,16 +14,31 @@ import Language.Haskell.TH.Quote (QuasiQuoter(..))  toAstQ :: (Data a, ToSyntax b) => a -> TH.Q b-toAstQ x = whichS' (toExpQ x) (toPatQ x)+toAstQ x = whichS' (toExpQ False x) (toPatQ False x) -toExpQ :: Data a => a -> TH.ExpQ-toExpQ  = dataToExpQ antiExp moduleQuals+toAstQ' :: (Data a, ToSyntax b) => a -> TH.Q b+toAstQ' x = whichS' (toExpQ True x) (toPatQ True x) -toPatQ :: Data a => a -> TH.PatQ-toPatQ  = dataToPatQ antiPat moduleQuals+toExpQ :: Data a => Bool -> a -> TH.ExpQ+toExpQ False x = dataToExpQ antiExp moduleQuals x+toExpQ True  x = do+  TH.AppE _ stx <- dataToExpQ antiExp moduleQuals x+  return stx +toPatQ :: Data a => Bool -> a -> TH.PatQ+toPatQ False x = dataToPatQ antiPat moduleQuals x+toPatQ True  x = do+  TH.ConP _ [_, stx] <- dataToPatQ antiPat moduleQuals x+  return stx+ moduleQuals :: [(String, String)]-moduleQuals  = [ ("Syntax.Type", "Syntax") ]+moduleQuals  = [ ("AST.Type",        "AST"),+                 ("AST.Kind",        "AST"),+                 ("AST.Patt",        "AST"),+                 ("AST.Ident",       "AST"),+                 ("AST.Expr",        "AST"),+                 ("AST.Decl",        "AST"),+                 ("AST.Notable",     "AST") ]  antiExp :: Data a => a -> Maybe TH.ExpQ antiExp  = antiGen@@ -70,19 +77,20 @@ --- Quasiquoters --- -pa, ty, ex, dc, me, prQ, tdQ, atQ, caQ, bnQ, qeQ, tpQ, seQ, sgQ+pa, ty, ex, dc, meQ, prQ, tdQ, atQ, caQ, bnQ, fdQ, qeQ, tpQ, seQ, sgQ   :: QuasiQuoter  ex  = mkQuasi "ex" parseExpr dc  = mkQuasi "dc" parseDecl-ty  = mkQuasi "ty" parseType-me  = mkQuasi "me" parseModExp+ty  = mkQuasi "ty" (withDots True parseType) pa  = mkQuasi "pa" parsePatt+meQ = mkQuasi "meQ" parseModExp prQ = mkQuasi "prQ" parseProg tdQ = mkQuasi "tdQ" parseTyDec atQ = mkQuasi "atQ" parseAbsTy caQ = mkQuasi "caQ" parseCaseAlt bnQ = mkQuasi "bnQ" parseBinding+fdQ = mkQuasi "fdQ" parseField qeQ = mkQuasi "qeQ" parseQExp tpQ = mkQuasi "tpQ" parseTyPat seQ = mkQuasi "seQ" parseSigExp@@ -94,21 +102,31 @@             Data (note Renamed), Data (stx Renamed),             LocAst (N (note Renamed) (stx Renamed))) =>            String ->-           (forall i. Id i => P (N (note i) (stx i))) ->+           (forall i. Tag i => P (N (note i) (stx i))) ->            QuasiQuoter mkQuasi name parser = (newQuasi name) { quoteExp = qast, quotePat = qast }   where   qast s =     join $-      parseQuasi s $ \iflag lflag ->+      parseQuasi s $ \filename iflag lflag ->         case iflag of-          Just '+' -> do+          "+'" -> do             stx <- parser :: P (N (note Renamed) (stx Renamed))-            convert lflag stx+            convert' filename stx+          "+" -> do+            stx <- parser :: P (N (note Renamed) (stx Renamed))+            convert filename lflag stx+          "'" -> do+            stx <- parser :: P (N (note Raw) (stx Raw))+            convert' filename stx           _        -> do             stx <- parser :: P (N (note Raw) (stx Raw))-            convert lflag stx-  convert flag stx = return $ maybe toAstQ toLocAstQ flag (scrub stx)+            convert filename lflag stx+  convert filename flag stx =+    return . maybe toAstQ toLocAstQ flag $+               scrubWhen (\loc -> file loc == filename) stx+  convert' filename stx = do+    return . toAstQ' $ scrubWhen (\loc -> file loc == filename) stx  deriveLocAsts 'toAstQ syntaxTable
src/Meta/QuoteData.hs view
@@ -1,11 +1,6 @@ --- --- My verson of Language.Haskell.TH.Quote ----{-# LANGUAGE-      RankNTypes,-      RelaxedPolyRec,-      PatternGuards,-      ScopedTypeVariables #-} module Meta.QuoteData (dataToExpQ, dataToPatQ) where  import Language.Haskell.TH
src/Meta/THHelpers.hs view
@@ -1,9 +1,3 @@-{-# LANGUAGE-      CPP,-      DeriveDataTypeable,-      RankNTypes,-      TemplateHaskell,-      TypeSynonymInstances #-} module Meta.THHelpers (   -- * Simplified TH quasiquote   th,@@ -15,14 +9,15 @@   buildContext, typeOfTyVarBndr, conName, ) where -import Lexer (lid, uid)+import Syntax.Lexer (lid, uid) import Util import Compat (newQuasi)+import Alt.Parsec +import Prelude () 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 @@ -93,7 +88,7 @@  -- | Qualify a string literal with  qstringL :: String -> Lit-qstringL s = stringL ("Syntax." ++ s)+qstringL s = stringL ("AST." ++ s)  -- | Does the given AST contain an antiquote named '_'?  If so, we --   create an implicit parameter and fill it in there.
− src/PDNF.hs 
@@ -1,242 +0,0 @@-{-# 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 
@@ -1,1310 +0,0 @@-{-# LANGUAGE-      PatternGuards,-      ScopedTypeVariables,-      TypeFamilies,-      TypeSynonymInstances #-}--- | Parser-module Parser (-  -- * The parsing monad-  P, parse,-  -- ** Errors-  ParseError,-  -- ** Quasiquote parsing-  parseQuasi,-  -- ** File and REPL command parsing-  parseFile,-  REPLCommand(..), parseCommand,-  -- ** 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 ErrorMessage (AlmsException(..), Phase(ParserPhase))-import qualified Message.AST as Msg--import qualified Data.Map as M-import qualified Data.List as L-import qualified Language.Haskell.TH as TH-import Text.ParserCombinators.Parsec hiding (parse)-import qualified Text.ParserCombinators.Parsec.Error as PE-import System.IO.Unsafe (unsafePerformIO)--data St   = St {-              stSigma :: Bool,-              stAnti  :: Bool,-              stPos   :: SourcePos-            }--instance TokenEnd St where-  saveTokenEnd = do-    pos <- getPosition-    updateState $ \st -> st { stPos = pos }---- | A 'Parsec' character parser, with abstract state-type P a  = CharParser St a--state0 :: St-state0 = St {-           stSigma = False,-           stAnti  = False,-           stPos   = toSourcePos bogus-         }---- | 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---- | REPL-level commands-data REPLCommand-  = GetInfoCmd [Ident Raw]-  | GetPrecCmd [String]-  | DeclsCmd [Decl Raw]-  | ParseError AlmsException---- | Parse a line typed into the REPL-parseCommand :: Int -> String -> String -> REPLCommand-parseCommand row line cmd =-  case parseGetInfo line of-    Just ids -> GetInfoCmd ids-    _ -> case parseGetPrec line of-      Just lids -> GetPrecCmd lids-      _ -> case parseInteractive row cmd of-        Right ast -> DeclsCmd ast-        Left err  -> ParseError (almsParseError err)---- | Given a file name and source, parse it-parseFile :: Id i => String -> String -> Either AlmsException (Prog i)-parseFile  = (almsParseError +++ id) <$$> parse parseProg--almsParseError :: ParseError -> AlmsException-almsParseError e =-  AlmsException ParserPhase (fromSourcePos (errorPos e)) message-  where-    message =-      Msg.Stack Msg.Broken [-        flow ";" messages,-        (if null messages then id else Msg.Indent)-           (Msg.Table (unlist ++ explist))-      ]-    unlist  = case unexpects of-      []  -> []-      s:_ -> [("unexpected:", Msg.Words s)]-    explist = case expects of-      []  -> []-      _   -> [("expected:", flow "," expects)]-    messages  = [ s | PE.Message s     <- PE.errorMessages e, not$null s ]-    unexpects = [ s | PE.UnExpect s    <- PE.errorMessages e, not$null s ]-             ++ [ s | PE.SysUnExpect s <- PE.errorMessages e, not$null s ]-    expects   = [ s | PE.Expect s      <- PE.errorMessages e, not$null s ]-    flow c         = Msg.Flow . map Msg.Words . punct c . L.nub-    punct _ []     = []-    punct _ [s]    = [s]-    punct c (s:ss) = (s++c) : punct c ss--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))--parseGetPrec :: String -> Maybe [String]-parseGetPrec = (const Nothing ||| Just) . runParser parser state0 "-"-  where-    parser = finish $-      sharpPrec *>-        many1 (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---- | Get the ending position of the last token, before trailing whitespace-getEndPosition :: P SourcePos-getEndPosition  = stPos <$> getState---- | Parse something and return the span of its location-withLoc :: P a -> P (a, Loc)-withLoc p = do-  before <- getPosition-  a      <- p-  after  <- getEndPosition-  return (a, fromSourcePosSpan before after)--addLoc :: Relocatable a => P a -> P a-addLoc  = uncurry (<<@) <$$> withLoc--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 <$ forall-      <|> Exists <$ exists-      <|> 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 <$  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 <$> (antiblep <|> Just <$> 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 qdisj-  qterm = addLoc $ qeConj <$> sepBy1 qfact qconj-  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-           arrow-           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 lambda-         (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-    arrow-    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 = choice-  [ do (tvt, tve) <- tyargp-       (b, ft, fe) <- afargsp-       return (b, tvt . ft, tve . fe),-    do arrcon <- arrconp-       (b, ft, fe) <- vargp arrcon-       if b-          then return (b, ft, fe)-          else do-            (b', fts, fes) <- afargsp-            return (b', ft . fts, fe . fes),-    return (False, id, id) ]-  where-    arrconp = option tyArr $ choice-      [ tyFun . Just <$> qualbox qExpp,-        do-          reservedOp "|"-          return tyLol ]---- 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-  ((p, t), loc) <- withLoc 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 (\(tv, loc) -> exTAbs tv <<@ loc) e tvs)-    where-  loctv = withLoc 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 :: P a -> P 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
@@ -1,6 +1,3 @@-{-# LANGUAGE-      CPP,-      TemplateHaskell #-} module Paths (   findFirstInPath, findInPath,   almsLibPath, findAlmsLib, findAlmsLibRel,@@ -10,6 +7,7 @@  import Util +import Prelude () import Language.Haskell.TH import System.FilePath import System.Directory (doesFileExist, getCurrentDirectory)@@ -73,7 +71,7 @@ findAlmsLib :: FilePath -> IO (Maybe FilePath) findAlmsLib name = do   path <- almsLibPath-  findFirstInPath [ name, name <.> "alms" ] path+  findFirstInPath (nameAdjustments name) path  -- | Find an Alms library with the given name, first looking --   relative to the given path@@ -84,7 +82,15 @@                "."  -> "."                "-"  -> "."                _    -> dropFileName rel-  findFirstInPath [ name, name <.> "alms" ] (rel' : path)+  findFirstInPath (nameAdjustments name) (rel' : path)++-- | Produce a sequence of names to try to load based on a base name+nameAdjustments ∷ FilePath -> [FilePath]+nameAdjustments name =+  [ name , name <.> "alms" ]+  ++ if pathSeparator `elem` name+       then []+       else [ "lib" ++ name <.> "alms" ]  shortenPath :: FilePath -> IO FilePath shortenPath fp = do
− src/Ppr.hs 
@@ -1,514 +0,0 @@--- | Pretty-printing-{-# LANGUAGE-      PatternGuards,-      QuasiQuotes,-      TypeSynonymInstances-    #-}-module Ppr (-  pprTyApp,-  -- * Re-exports-  module PprClass,-  module Prec-) where--import Meta.Quasi-import PprClass-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 Data.List (intersperse)--instance IsInfix (Type i) where-  isInfix [$ty| ($_, $_) $lid:n |] = isOperator n-  isInfix [$ty| $_ -[$_]> $_ |]    = True-  isInfix _                        = False---- | For printing infix expressions.  Given a splitter function that---   splits expressions into a left operand, operator name, and right---   operand (if possible), and an expression to print, pretty-prints---   the expression, but only if there is one level of infix to be---   done.-pprInfix :: Ppr a =>-            (a -> Maybe (a, String, Maybe a)) ->-            a -> Maybe Doc-pprInfix inspect x0-  | Just (x1, op, Nothing) <- inspect x0-  , precOp op == Right precBang-    = let rloop x'-            | Just (x1', op', Nothing) <- inspect x'-            , precOp op == Right precBang-            = first (op':) (rloop x1')-            | otherwise-            = ([], x')-          (ops, x) = first (op:) (rloop x1)-       in Just $-            fsep (mapTail (nest 2) $ map text ops)-            <> pprPrec precBang x-  | Just (_, op, Just _) <- inspect x0-  , isOperator (lid op :: Lid Raw)-  , p <- precOp op-  , p /= Right precBang-    = Just $-        prec (id|||id $ p) $-          fcat $ mapTail (nest 2) $ loop p empty x0-  | otherwise-    = Nothing-  where-  loop p suf x-    | Just (x1, op, Just x2) <- inspect x-    , precOp op == p-    = case precOp op of-        Left _  -> loop p (oper op) x1 ++ [ppr1 x2 <> suf]-        Right _ -> ppr1 x1 <> oper op : loop p suf x2-  loop _ suf x = [ ppr x <> suf ]-  oper s = case s of-    '@':_ -> text s-    ';':_ -> text s <> space-    _     -> space <> text s <> space--instance Ppr (Type i) where-  -- pprPrec p (TyFun q t1 t2)-  ppr [$ty| $t1 -> $t2 |]-            = prec precArr $-              sep [ ppr1 t1, text "->" <+> pprRight t2 ]-  ppr [$ty| $t1 -[$q]> $t2 |]-            = prec precArr $-              sep [ ppr1 t1,-                    text "-" <> ppr0 q <> text ">" <+> pprRight t2 ]-  ppr t@[$ty| ($list:ts) $qlid:n |]-    | Just doc <- pprInfix unfoldType t-                    = doc-    | null ts       = ppr n-    | otherwise     = prec precApp $ sep [ ppr ts, ppr n ]-    -- debugging: <> text (show (ttId (unsafeCoerce tag :: TyTag)))-  ppr [$ty| '$x |]  = ppr x-  ppr [$ty| $quant:qu '$x. $t |]-                    = prec precDot $-                        ppr qu <+>-                        fsep (map ppr1 tvs) <>-                        char '.'-                          >+> ppr body-      where (tvs, body) = unfoldTyQu qu [$ty| $quant:qu '$x. $t |]-  ppr [$ty| mu '$x. $t |]-                    = prec precDot $-                        text "mu" <+>-                        ppr1 x <>-                        char '.'-                          >+> ppr t-  ppr [$ty| $anti:a |] = ppr a--unfoldType :: Type i -> Maybe (Type i, String, Maybe (Type i))-unfoldType [$ty| ($t1, $t2) $name:n |] = Just (t1, n, Just t2)-unfoldType [$ty| $t1 $name:n |]        = Just (t1, n, Nothing)-unfoldType _                           = Nothing--instance Ppr (TyPat i) where-  ppr tp0 = case tp0 of-    _ | Just doc <- pprInfix unfoldTyPat tp0-                       -> doc-    N _ (TpVar tv var) -> pprParamV var tv-    [$tpQ| $qlid:ql |] -> ppr ql-    [$tpQ| ($list:tps) $qlid:ql |]-                       -> prec precApp $ sep [ppr tps, ppr ql]-    [$tpQ| $antiP:a |] -> ppr a--unfoldTyPat :: TyPat i -> Maybe (TyPat i, String, Maybe (TyPat i))-unfoldTyPat [$tpQ| ($t1, $t2) $name:n |] = Just (t1, n, Just t2)-unfoldTyPat [$tpQ| $t1 $name:n |]        = Just (t1, n, Nothing)-unfoldTyPat _                            = Nothing--instance Ppr (QExp i) where-  ppr [$qeQ| $qlit:qu |] = ppr qu-  ppr [$qeQ| $qvar:v |]  = ppr (tvname v)-  ppr [$qeQ| $qdisj:qes |] = case qes of-    []    -> ppr Qu-    [qe]  -> ppr qe-    _     -> prec precPlus $-               hcat $-                 intersperse (text ",") $-                   map ppr1 qes-  ppr [$qeQ| $qconj:qes |] = case qes of-    []    -> ppr Qa-    [qe]  -> ppr qe-    _     -> prec precStar $-               hcat $-                 intersperse (text "/\\") $-                   map ppr1 qes-  ppr [$qeQ| $anti:a |] = ppr a--instance Ppr (Prog i) where-  ppr [$prQ| $list:ms |]       = vcat (map ppr0 ms)-  ppr [$prQ| $expr:e |]        = ppr e-  ppr [$prQ| $list:ms in $e |] = vcat (map ppr0 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 ppr0 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 ppr0 sgs))-      $$ text "end"-    [$seQ| $_ with type $list:_ $qlid:_ = $_ |] ->-      error "BUG! can't happen in pprSigExp"-    [$seQ| $anti:a |] -> add (ppr a)-  withs      =-    atPrec 0 $ sep $-      mapHead (text "with type" <+>) $-        mapTail ((nest 6) . (text "and" <+>)) $-          [ pprTyApp 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-  ppr e0 = case e0 of-    _ | Just doc <- pprInfix unfoldExpr e0-                     -> doc-    [$ex| $id:x |]   -> ppr x-    [$ex| $lit:lt |] -> ppr lt-    [$ex| if $ec then $et else $ef |] ->-      prec precDot $-        sep [ text "if" <+> ppr ec,-              nest 2 $ text "then" <+> ppr0 et,-              nest 2 $ text "else" <+> ppr ef ]-    [$ex| $_; $_ |] ->-      prec precDot $-        sep (unfold e0)-      where unfold [$ex| $e1; $e2 |] = ppr1 e1 <> semi : unfold e2-            unfold e                 = [ ppr0 e ]-    [$ex| let $x = $e1 in $e2 |] ->-      pprLet (ppr x) e1 e2-    [$ex| match $e1 with $list:clauses |] ->-      prec precDot $-        vcat (sep [ text "match",-                    nest 2 $ ppr0 e1,-                    text "with" ] : map alt clauses)-      where-        alt (N _ (CaClause xi ei)) =-          hang (char '|' <+> ppr xi <+> text "->")-                4-                (ppr ei)-        alt (N _ (CaAnti a))      = char '|' <+> ppr a-    [$ex| let rec $list:bs in $e2 |] ->-      prec precDot $-        text "let" <+>-        vcat (zipWith each ("rec" : repeat "and") bs) $$-        text "in" <+> ppr 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 |] ->-      prec precDot $-        text "let" <+> ppr0 d $$-        (text "in" >+> ppr e2)-    [$ex| ($e1, $e2) |] ->-      prec precCom $-        sep [ ppr e1 <> comma, ppr1 e2 ]-    [$ex| fun $_ : $_ -> $_ |] -> pprAbs e0-    [$ex| $e1 $e2 |]-          -> prec precApp $-               sep [ ppr e1, ppr1 e2 ]-    [$ex| fun '$_ -> $_ |] -> pprAbs e0-    [$ex| $_ [$_] |] ->-      prec precTApp $-        cat [ ppr op,-              brackets . fsep . punctuate comma $-                map (pprPrec precCom) args ]-      where -        (args, op) = unfoldExTApp e0-    [$ex| Pack[$opt:t1]($t2, $e) |] ->-      prec precApp $-        text "Pack" <> maybe empty (brackets . ppr0) t1 <+>-        prec precCom (sep [ ppr1 t2 <> comma, ppr e ])-    [$ex| ( $e : $t1 :> $t2 ) |] ->-      prec precCast $-        atPrec (precCast + 2) $-          sep [ ppr e,-                colon     <+> ppr t1,-                text ":>" <+> ppr t2 ]-    [$ex| ( $e : $t1 ) |] ->-      prec precCast $-        atPrec (precCast + 2) $-          sep [ ppr e,-                colon <+> ppr t1 ]-    [$ex| ( $e :> $t1 ) |] ->-      prec precCast $-        atPrec (precCast + 2) $-          sep [ ppr e,-                text ":>" <+> ppr t1 ]-    [$ex| $anti:a |] -> ppr a-    where-    unfoldExpr [$ex| ($name:x $e1) $e2 |] = Just (e1, x, Just e2)-    unfoldExpr [$ex| $name:x $e1 |]       = Just (e1, x, Nothing)-    unfoldExpr _                          = Nothing--pprLet :: Doc -> Expr i -> Expr i -> Doc-pprLet pat e1 e2 = prec precDot $-  hang (text "let" <+> pat <+> pprArgList args <+> equals-          >+> ppr body <+> text "in")-       (if isLet (view e2)-          then 0-          else 2)-       (ppr e2)-  where-    (args, body) = unfoldExAbs e1-    isLet (ExCase _ [_]) = True-    isLet _              = False--pprAbs :: Expr i -> Doc-pprAbs e = prec precDot $-    text "fun" <+> argsDoc <+> text "->"-      >+> ppr 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 $-                              ppr0 x-                                >+> colon <+> ppr0 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-  ppr [$pa| _ |]             = text "_"-  ppr [$pa| $lid:l |]        = ppr l-  ppr [$pa| $quid:qu |]      = ppr qu-  ppr [$pa| $quid:qu $x |]   = prec precApp $-                                 ppr qu <+> ppr1 x-  ppr [$pa| ($x, $y) |]      = prec precCom $-                                 ppr x <> comma <+> ppr1 y-  ppr [$pa| $lit:lt |]       = ppr lt-  ppr [$pa| $x as $lid:l |]  = prec precDot $-                                 ppr1 x <+> text "as" <+> ppr l-  ppr [$pa| Pack('$tv,$x) |] = prec precApp $-                                 text "Pack" <+> pprPrec precCom (sep pair)-    where pair = [ ppr1 tv <> comma, ppr x ]-  ppr [$pa| $anti:a |]       = ppr 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------- Helper for pretty-printing type-like things -- doesn't require--- underlying types, but does need to see the operator name.-----data PprTyAppHelper i a-  = PTAHBranch (QLid i) [a]-  | PTAHLeaf   a--instance Ppr a => Ppr (PprTyAppHelper i a) where-  ppr (PTAHLeaf a) = ppr a-  ppr _            = error "BUG! in PprTyAppHelper.ppr"--unfoldPTAH :: PprTyAppHelper i a ->-              Maybe (PprTyAppHelper i a, String, Maybe (PprTyAppHelper i a))-unfoldPTAH (PTAHBranch (J [] l) [a, b])-  = Just (PTAHLeaf a, unLid l, Just (PTAHLeaf b))-unfoldPTAH (PTAHBranch (J [] l) [a])-  = Just (PTAHLeaf a, unLid l, Nothing)-unfoldPTAH _-  = Nothing--pprTyApp :: Ppr a => QLid i -> [a] -> Doc-pprTyApp ql ts-  | Just doc <- pprInfix unfoldPTAH (PTAHBranch ql ts)-               = doc-pprTyApp ql [] = ppr ql-pprTyApp ql ts = prec precApp $ sep [ ppr ts, ppr ql ]------- Instances-----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 Loc       where pprPrec = pprFromShow-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-
− src/PprClass.hs 
@@ -1,301 +0,0 @@-{-# LANGUAGE-      FlexibleInstances-      #-}-module PprClass (-  -- * Documents-  Doc,-  -- * Pretty-printing class-  Ppr(..), IsInfix(..), ListStyle(..),-  -- ** Helpers-  ppr0, ppr1, pprDepth,-  -- ** Context operations-  prec, mapPrec, prec1, descend, atPrec, atDepth,-  askPrec, askDepth,-  trimList, trimCat,-  -- *** For type name shortening-  TyNames(..), tyNames0,-  setTyNames, askTyNames, enterTyNames, lookupTyNames,-  -- * Pretty-printing combinators-  (>+>), (>?>), ifEmpty,-  vcat, sep, cat, fsep, fcat,-  -- * Renderers-  render, renderS, printDoc, printPpr, hPrintDoc, hPrintPpr,-  -- ** Instance helpers-  showFromPpr, pprFromShow,-  -- * Re-exports-  module PrettyPrint-) where--import PrettyPrint hiding (Doc(..), render, vcat, sep, cat, fsep, fcat)-import qualified PrettyPrint as P--import Syntax.Ident (QLid, Uid, Renamed)--import System.IO (Handle, stdout, hPutChar, hPutStr)---- | Context for pretty-printing.-data PprContext-  = PprContext {-      pcPrec   :: !Int,-      pcDepth  :: !Int,-      pcTyName :: !TyNames-  }--data TyNames =-  TyNames {-    tnLookup   :: Int -> QLid Renamed -> QLid Renamed,-    tnEnter    :: Uid Renamed -> TyNames-  }---- | Default context-pprContext0 :: PprContext-pprContext0  = PprContext {-  pcPrec   = 0,-  pcDepth  = -1,-  pcTyName = tyNames0-}--tyNames0 :: TyNames-tyNames0  = TyNames {-  tnLookup = const id,-  tnEnter  = const tyNames0-}--type Doc = P.Doc PprContext--data ListStyle -  = ListStyle {-    listStyleBegin, listStyleEnd, listStylePunct :: Doc,-    listStyleDelimitEmpty, listStyleDelimitSingleton :: Bool,-    listStyleJoiner :: [Doc] -> Doc-  }---- | Class for pretty-printing at different types------ Minimal complete definition is one of:------ * 'pprPrec'------ * 'ppr'-class Ppr p where-  -- | Print current precedence-  ppr     :: p -> Doc-  -- | Print at the specified enclosing precedence-  pprPrec :: Int -> p -> Doc-  -- | Print a list in the default style-  pprList :: [p] -> Doc-  -- | Print a list in the specified style-  pprStyleList :: ListStyle -> [p] -> Doc-  -- | Style for printing lists-  listStyle   :: [p] -> ListStyle-  ---  ---  ppr         = asksD pcPrec . flip pprPrec-  pprPrec p   = prec p . ppr-  pprList xs  = pprStyleList (listStyle xs) xs-  ---  pprStyleList st [] =-    if listStyleDelimitEmpty st-      then listStyleBegin st <> listStyleEnd st-      else empty-  pprStyleList st [x] =-    if listStyleDelimitSingleton st-      then listStyleBegin st <> ppr x <> listStyleEnd st-      else ppr x-  pprStyleList st xs  =-    listStyleBegin st <>-      listStyleJoiner st (punctuate (listStylePunct st) (map ppr xs))-    <> listStyleEnd st-  ---  listStyle _ = ListStyle {-    listStyleBegin            = lparen,-    listStyleEnd              = rparen,-    listStylePunct            = comma,-    listStyleDelimitEmpty     = False,-    listStyleDelimitSingleton = False,-    listStyleJoiner           = fsep-  }---- | Print at top level.-ppr0      :: Ppr p => p -> Doc-ppr0       = atPrec 0 . ppr---- | Print at next level.-ppr1      :: Ppr p => p -> Doc-ppr1       = prec1 . ppr---- | Print to the given depth.-pprDepth  :: Ppr p => Int -> p -> Doc-pprDepth d = atDepth d . ppr---- | Enter the given precedence level, drawing parentheses if necessary,---   and count it as a descent in depth as well.-prec :: Int -> Doc -> Doc-prec p doc = asksD pcPrec $ \p' ->-  if p' > p-    then descend $ parens (atPrec (min p 0) doc)-    else atPrec p doc---- | Adjust the precedence with the given function.-mapPrec :: (Int -> Int) -> Doc -> Doc-mapPrec f doc = askPrec (\p -> prec (f p) doc)---- | Go to the next (tigher) precedence level.-prec1 :: Doc -> Doc-prec1  = mapD (\e -> e { pcPrec = pcPrec e + 1 })---- | Descend a level, elliding if the level counter runs out-descend :: Doc -> Doc-descend doc = askD $ \e ->-  case pcDepth e of-    -1 -> doc-    0  -> text "..."-    k  -> localD e { pcDepth = k - 1 } doc---- | Set the precedence, but check or draw parentheses-atPrec   :: Int -> Doc -> Doc-atPrec p  = mapD (\e -> e { pcPrec = p })---- | Set the precedence, but check or draw parentheses-atDepth  :: Int -> Doc -> Doc-atDepth k = mapD (\e -> e { pcDepth = k })---- | Find out the precedence-askPrec :: (Int -> Doc) -> Doc-askPrec  = asksD pcPrec---- | Find out the depth-askDepth :: (Int -> Doc) -> Doc-askDepth  = asksD pcDepth---- | Change the type name lookup function-setTyNames   :: TyNames -> Doc -> Doc-setTyNames f  = mapD (\e -> e { pcTyName = f })---- | Retrieve the type name lookup function-askTyNames   :: (TyNames -> Doc) -> Doc-askTyNames    = asksD pcTyName---- | Render a document with a module opened-enterTyNames :: Uid Renamed -> Doc -> Doc-enterTyNames u doc = askTyNames $ \tn ->-  setTyNames (tnEnter tn u) doc---- | Look up a type name in the rendering context-lookupTyNames :: Int -> QLid Renamed -> (QLid Renamed -> Doc) -> Doc-lookupTyNames tag ql kont = askTyNames $ \tn ->-  kont (tnLookup tn tag ql)---- | Trim a list to (about) the given number of elements, with---   "..." in the middle.-trimList :: Int -> [Doc] -> [Doc]-trimList (-1) ds = ds-trimList n2   ds = if k <= 2 * n-                     then ds-                     else take n ds ++ text "... " : drop (k - n) ds-  where-    n = (n2 + 1) `div` 2-    k = length ds---- | Lift a concatenation function to respect depth.-trimCat :: ([Doc] -> Doc) -> [Doc] -> Doc-trimCat xcat docs = asksD pcDepth $ \d -> case d of-  -1 -> xcat docs-  _  -> atDepth ((d + 1) `div` 2) (xcat (trimList d docs))--vcat, sep, cat, fsep, fcat :: [Doc] -> Doc-vcat = trimCat P.vcat-sep  = trimCat P.sep-cat  = trimCat P.cat-fsep = trimCat P.fsep-fcat = trimCat P.fcat--instance Ppr a => Ppr [a] where-  ppr = pprList--instance Ppr a => Ppr (Maybe a) where-  pprPrec _ Nothing  = empty-  pprPrec p (Just a) = pprPrec p a---- | Class to check if a particular thing will print infix.  Adds---   an operation to print at the given precedence only if the given---   thing is infix.  (We use this for printing arrows without too---   many parens.)-class Ppr a => IsInfix a where-  isInfix  :: a -> Bool-  pprRight :: a -> Doc-  pprRight a =-    if isInfix a-      then ppr a-      else ppr0 a--instance Ppr Int       where ppr = int-instance Ppr Integer   where ppr = integer-instance Ppr Double    where ppr = double--instance Ppr Char where-  ppr            = text . show-  pprStyleList _ = text--instance Ppr (P.Doc PprContext)  where ppr = id-instance Show (P.Doc PprContext) where showsPrec = showFromPpr---- Render a document in the preferred style, given a string continuation-renderS :: Doc -> ShowS-renderS doc rest = fullRenderIn pprContext0 PageMode 80 1.1 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  = hPrintDoc stdout---- Pretty-print, render and display in the preferred style-printPpr :: Ppr a => a -> IO ()-printPpr  = hPrintPpr stdout---- Render and display a document in the preferred style-hPrintDoc :: Handle -> Doc -> IO ()-hPrintDoc h = fullRenderIn pprContext0 PageMode 80 1.1 each (putChar '\n')-  where each (Chr c) io  = hPutChar h c >> io-        each (Str s) io  = hPutStr h s >> io-        each (PStr s) io = hPutStr h s >> io--hPrintPpr :: Ppr a => Handle -> a -> IO ()-hPrintPpr h = hPrintDoc h . 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 "")------- Some indentation operations-----liftEmpty :: (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc-liftEmpty joiner d1 d2 = askD f where-  f e | isEmptyIn e d1 = d2-      | isEmptyIn e d2 = d1-      | otherwise      = joiner d1 d2--ifEmpty :: Doc -> Doc -> Doc -> Doc-ifEmpty dc dt df = askD $ \e ->-  if isEmptyIn e dc-    then dt-    else df--(>+>) :: Doc -> Doc -> Doc-(>+>) = flip hang 2--(>?>) :: Doc -> Doc -> Doc-(>?>)  = liftEmpty (>+>)--infixr 5 >+>, >?>-
− src/Prec.hs 
@@ -1,75 +0,0 @@--- | 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--import Data.Char---- | 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-  | otherwise = case generalCategory c of-      CurrencySymbol        -> Left precEq-      MathSymbol            -> Left precStar-      DashPunctuation       -> Left precPlus-      OtherSymbol           -> Left precPlus-      ConnectorPunctuation  -> Right precCaret-      OtherPunctuation      -> Right precAt-      _                     -> Left precApp -- defaulty-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/PrettyPrint.hs 
@@ -1,180 +0,0 @@-{- | A layer over 'P.Doc' for propagating context information.  (I think-     Template Haskell has a version of this. -}-module PrettyPrint (-  -- * Environment-parameterized pretty-printing document-  Doc(..),-  -- ** Environment operations-  mapD, askD, asksD, localD,-  -- * Document combinators-  -- ** Binary operations-  ($$), ($+$), (<+>), (<>),-  -- ** Unary operations-  braces, brackets, doubleQuotes, quotes, parens,-  -- ** List operations-  cat, fcat, fsep, hcat, hsep, sep, vcat,-  -- ** Miscellaneous operations-  nest, hang, punctuate,-  -- ** Nullary operations (documents)-  colon, comma, empty, equals, lbrace, lbrack,-  lparen, rbrace, rbrack, rparen, semi, space,-  -- *** Unary functions returning documents-  char, double, float, int, integer, ptext, rational, text, zeroWidthText,-  -- * Rendering and queries-  toDocIn, isEmptyIn, renderIn, renderStyleIn, fullRenderIn,-  toDoc, isEmpty, render, renderStyle, fullRender,-  -- ** Rendering constants-  P.Mode(..), P.Style(..), P.TextDetails(..), P.style-) where--import qualified Text.PrettyPrint as P-import Control.Applicative hiding (empty)-import Data.Monoid---- Document parameterized by type @e@.-newtype Doc e = Doc { unDoc :: e -> P.Doc }------- Environment manipulation-----mapD     :: (e' -> e) -> Doc e -> Doc e'-mapD f d  = Doc (unDoc d . f)--askD     :: (e -> Doc e) -> Doc e-askD f    = Doc (unDoc <$> f <*> id)--asksD    :: (e -> a) -> (a -> Doc e) -> Doc e-asksD g f = askD (f . g)--localD   :: e' -> Doc e' -> Doc e-localD    = mapD . const------- Lifts-----liftD0   :: P.Doc -> Doc e-liftD0    = Doc . const--liftD    :: (P.Doc -> P.Doc) -> Doc e -> Doc e-liftD f d = Doc (f <$> unDoc d)--liftD2 :: (P.Doc -> P.Doc -> P.Doc) ->-            Doc e -> Doc e -> Doc e-liftD2 f d1 d2 = Doc (f <$> unDoc d1 <*> unDoc d2)--liftDList :: ([P.Doc] -> P.Doc) -> [Doc e] -> Doc e-liftDList f ds = Doc (\e -> f [ d e | Doc d <- ds ])------- Pretty-printing combinators-----($$), ($+$), (<+>), (<>) :: Doc e -> Doc e -> Doc e-($$)   = liftD2 (P.$$)-($+$)  = liftD2 (P.$+$)-(<+>)  = liftD2 (P.<+>)-(<>)   = liftD2 (P.<>)--braces, brackets, doubleQuotes, parens, quotes :: Doc e -> Doc e-braces       = liftD P.braces-brackets     = liftD P.brackets-doubleQuotes = liftD P.doubleQuotes-quotes       = liftD P.quotes-parens       = liftD P.parens--nest      :: Int -> Doc e -> Doc e-nest         = liftD . P.nest--hang      :: Doc e -> Int -> Doc e -> Doc e-hang d1 n    = liftD2 (flip P.hang n) d1--punctuate :: Doc e -> [Doc e] -> [Doc e]-punctuate _  []     = []-punctuate _  [d]    = [d]-punctuate d1 (d:ds) = d<>d1 : punctuate d1 ds--cat, fcat, fsep, hcat, hsep, sep, vcat :: [Doc e] -> Doc e-cat   = liftDList P.cat-fcat  = liftDList P.fcat-fsep  = liftDList P.fsep-hcat  = liftDList P.hcat-hsep  = liftDList P.hsep-sep   = liftDList P.sep-vcat  = liftDList P.vcat--char            :: Char -> Doc e-double          :: Double -> Doc e-float           :: Float -> Doc e-int             :: Int -> Doc e-integer         :: Integer -> Doc e-ptext           :: String -> Doc e-rational        :: Rational -> Doc e-text            :: String -> Doc e-zeroWidthText   :: String -> Doc e--char             = liftD0 . P.char-double           = liftD0 . P.double-float            = liftD0 . P.float-int              = liftD0 . P.int-integer          = liftD0 . P.integer-ptext            = liftD0 . P.ptext-rational         = liftD0 . P.rational-text             = liftD0 . P.text-zeroWidthText    = liftD0 . P.zeroWidthText--colon, comma, empty, equals, lbrace, lbrack, lparen, rbrace,-  rbrack, rparen, semi, space :: Doc e-colon   = liftD0 P.colon-comma   = liftD0 P.comma-empty   = liftD0 P.empty-equals  = liftD0 P.equals-lbrace  = liftD0 P.lbrace-lbrack  = liftD0 P.lbrack-lparen  = liftD0 P.lparen-rbrace  = liftD0 P.rbrace-rbrack  = liftD0 P.rbrack-rparen  = liftD0 P.rparen-semi    = liftD0 P.semi-space   = liftD0 P.space------- Rendering and queries-----toDocIn :: e -> Doc e -> P.Doc-toDocIn  = flip unDoc--isEmptyIn :: e -> Doc e -> Bool-isEmptyIn e = P.isEmpty . toDocIn e--renderIn :: e -> Doc e -> String-renderIn e  = P.render . toDocIn e--renderStyleIn :: e -> P.Style -> Doc e -> String-renderStyleIn e sty = P.renderStyle sty . toDocIn e--fullRenderIn :: e ->-                P.Mode -> Int -> Float ->-                (P.TextDetails -> a -> a) -> a ->-                Doc e -> a-fullRenderIn e mode cols ribbon f z =-  P.fullRender mode cols ribbon f z . toDocIn e--toDoc    :: Monoid e => Doc e -> P.Doc-toDoc     = toDocIn mempty--isEmpty :: Monoid e => Doc e -> Bool-isEmpty  = isEmptyIn mempty--render :: Monoid e => Doc e -> String-render  = renderIn mempty--renderStyle :: Monoid e => P.Style -> Doc e -> String-renderStyle = renderStyleIn mempty--fullRender :: Monoid e =>-              P.Mode -> Int -> Float ->-              (P.TextDetails -> a -> a) -> a ->-              Doc e -> a-fullRender = fullRenderIn mempty
− src/Printing.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE-      PatternGuards #-}--- Miscellaneous high-level printing routines.  These can't go in, say,--- Ppr, because they depend on Rename and Statics.-module Printing (-  addTyNameContext-) where--import Data.List (tails)-import PprClass-import Rename (RenameState, RenamingInfo(..),-               getRenamingInfo, renamingEnterScope)-import Statics (S, getTypeInfo, staticsEnterScope)-import Syntax.Ident-import Type-import Util---- | The status of a type name in an environment-data NameStatus- -- | Bound to the expected type- = Match- -- | Not bound- | NoMatch- -- | Shadowed- | Interfere- deriving Eq---- | In the given environment, what is the status of the given---   type name?-getNameStatus :: RenameState -> S -> Int -> QLid i -> NameStatus-getNameStatus r s tag ql =-  case [ ql' | TyconAt _ ql' <- getRenamingInfo ident r ] of-    ql':_ ->-      case getTypeInfo ql' s of-        Just tc | tcId tc == tag  -> Match-                | otherwise       -> Interfere-        _                         -> NoMatch-    _     -> NoMatch-  where ident = J (map (uid . unUid) (jpath ql))-                  (Var (lid (unLid (jname ql))))---- | Find the best name to refer to a type constructor.---   The goal here is to get the shortest unambiguous name.---    1. If the first parameter is True, we want an accurate name, so---       skip to step 3.---    2. If the unqualified name is bound to either the same type---       or to nothing, then use the unqualified name.---    3. Try qualifiying the name, starting with the last segment---       and adding one at a time, and if any of these match, then---       use that.---    4. Otherwise, uglify the name, because it's probably gone---       out of scope.-getBestName :: RenameState -> S ->-               Int -> QLid Renamed -> QLid Renamed-getBestName r s tag ql =-  case tryQuals (jpath ql) (jname ql) of-    Just ql' -> ql'-    _ | isTrivial (lidUnique (jname ql)),-        NoMatch <- getNameStatus r s tag ql-             -> ql-    _        -> uglify-  where-    tryQuals us l = msum-      [ case getNameStatus r s tag (J us' l) of-          Match     -> Just (J us' l)-          _         -> Nothing-      | us' <- reverse (tails us) ]-    uglify = ql { jpath = uid ('?':show tag) : jpath ql }--makeTyNames :: RenameState -> S -> TyNames-makeTyNames r s = TyNames {-  tnLookup = getBestName r s,-  tnEnter  = \u -> makeTyNames (renamingEnterScope u r)-                               (staticsEnterScope u s)-}--addTyNameContext :: RenameState -> S -> Doc -> Doc-addTyNameContext  = setTyNames <$$> makeTyNames
− src/Rename.hs 
@@ -1,974 +0,0 @@-{-# LANGUAGE-      FlexibleContexts,-      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(..),-  renamingEnterScope,-) where--import ErrorMessage--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 Ppr (Ppr(..))--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-}---- | Generate a renamer error.-renameError :: Message V -> R a-renameError msg0 = do-  loc <- R (asks location)-  throwAlms (AlmsException RenamerPhase loc msg0)--renameBug :: String -> String -> R a-renameBug culprit msg0 = do-  loc <- R (asks location)-  throwAlms (almsBug RenamerPhase loc culprit msg0)---- | 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 AlmsException) a-} deriving Functor--instance Monad Renaming where-  return  = R . return-  m >>= k = R (unR m >>= unR . k)-  fail    = renameError . [$msg| $words:1 |]--instance Applicative Renaming where-  pure  = return-  (<*>) = ap--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 AlmsException Renaming where-  throwError = R . throwError-  catchError body handler =-    R (catchError (unR body) (unR . handler))--instance AlmsMonad Renaming where-  throwAlms = throwError-  catchAlms = catchError---- | 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 AlmsException (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 :: AlmsMonad m =>-                Bool -> Loc -> RenameState -> Renaming a ->-                m (a, RenameState)-runRenamingM = unTryAlms . 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 :: Ppr a => String -> a -> R b-unbound ns a =-  renameError [$msg| $words:ns not in scope: $q:a |]---- | Generate an error about a name declared twice-repeated :: Ppr a => String -> a -> String -> [Loc] -> R b-repeated what a inwhat locs =-  renameError [$msg|-    $words:what $q:a-    repeated $words:times in $words:inwhat $words:at-    $ul:slocs-  |]-  where-    times = case length locs of-      0 -> ""-      1 -> ""-      2 -> "twice"-      3 -> "thrice"-      _ -> show (length locs) ++ " times"-    at    = if length locs > 1 then "at:" else ""-    slocs = map [$msg| $show:1 |] locs---- | 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              -> unbound "Type variable" tv-    Just (tv', _, True)  -> return tv'-    Just (_, loc, False) -> renameError [$msg|-      Type variable $tv not in scope.-      <indent>-         (It was bound at $loc, but a nested declaration-          cannot see type variables from its parent expression.)-      </indent>-      |]---- | 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)) ->-        repeated "Type declaration for" l "abstype group" [loc1, 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)) ->-      repeated "Type declaration for" l "type group" [loc1, 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 _  ->-      renameBug "renameTyDec" "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, _) ->-      repeated "Type variable" tv "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 _ _ -> renameBug "renameTyDec" "unexpected TdSyn"-      TdDat _ _ cons -> do-        case unique fst cons of-          Nothing -> return ()-          Just ((u, _), (_, _)) ->-            repeated "Data constructor" u "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, _) -> repeated "Type variable" tv "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 $-          repeated kind which "signature" []--sealWith :: Module -> R ()-sealWith = loop Nothing where-  loop b md = case md of-    MdNil              -> return ()-    MdApp md1 md2      -> do loop b md1; loop b md2-    MdTycon   _ l _   -> do-      (l', loc, _) <- find b "type constructor" tycons l-      tell (MdTycon loc l l')-    MdVar     _ l _   -> do-      (l', loc, _) <- find b "variable" vars l-      tell (MdVar loc l l')-    MdDatacon _ u _   -> do-      (u', loc, _) <- find b "data constructor" datacons u-      tell (MdDatacon loc u u')-    MdModule  _ u _ md2 -> do-      (u', loc, (md1, _)) <- find b "module" modules u-      ((), md1') <- steal $ onlyInModule md1 $ loop b md2-      tell (MdModule loc u u' md1')-    MdSig     _ u _ md2 -> do-      (u', loc, (md1, _)) <- find b "module type" sigs u-      ((), _   ) <- steal $ onlyInModule md2 $ loop (Just (Left u)) md1-      ((), md1') <- steal $ onlyInModule md1 $ loop (Just (Right u)) md2-      tell (MdSig loc u u' md1')-    MdTyvar   _ _ _   ->-      renameBug "sealWith" "signature can’t declare type variable"-  find b what prj ident = do-    m <- asks prj-    case M.lookup ident m of-      Just ident' -> return ident'-      Nothing     -> renameError $-        case b of-          Nothing -> [$msg|-            In signature matching, structure is missing-            $words:what $q:ident,-            which is present in ascribed signature.-          |]-          Just (Left u) -> [$msg|-            In exact signature matching (for nested signature $u)-            found unexpected $words:what $q:ident.-          |]-          Just (Right u) -> [$msg|-            In exact signature matching (for nested signature $u)-            missing expected $words:what $q:ident.-          |]---- | 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,_,_,_)) ->-      repeated "Variable binding for" x "let-rec" [l1, 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 -[$opt:mqe]> $t2 |] -> do-    t1'  <- renameType t1-    mqe' <- gmapM renameQExp mqe-    t2'  <- renameType t2-    return [$ty|+ $t1' -[$opt:mqe']> $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 ->-        lift (repeated "Type variable" tv "type pattern" [loc1, 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 -> lift (repeated "Variable" l "pattern" [loc1, 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 -> lift (repeated "Type variable" tv "pattern" [loc1, 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 -[$opt:mqe]> $t2 |]    ->-      ftvList t1 `List.union` ftvList mqe `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'))---- Open the given module, if it exists.-renamingEnterScope    :: Uid i -> RenameState -> RenameState-renamingEnterScope u r =-  let e  = savedEnv r in-  case M.lookup (uid (unUid u)) (modules e) of-    Nothing -> r-    Just (_, _, (_, e'))-            -> r { savedEnv = e `mappend` e' }-
− src/Sigma.hs 
@@ -1,519 +0,0 @@-{-# 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
@@ -1,1682 +1,248 @@--- | The type checker-{-# LANGUAGE-      DeriveDataTypeable,-      FlexibleContexts,-      FlexibleInstances,-      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,-  staticsEnterScope,-) 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 (Ppr, TyNames)-import Type-import TypeRel-import Coercion (coerceExpression)-import ErrorMessage-import Message.AST--import Control.Monad.RWS    as RWS-import Control.Monad.Error  as Error-import System.IO (hPutStrLn, stderr)-import Data.Data (Typeable, Data)-import Data.Generics (everywhere, mkT)-import Data.List (transpose, tails)-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"-ioM :: Monad m => IO a -> m ()-ioM a = if unsafePerformIO a `seq` 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 (ErrorT AlmsException m) a-}--instance Monad m => Monad (TC m) where-  return  = TC . return-  m >>= k = TC (unTC m >>= unTC . k)-  fail    = let ?loc = bogus in typeError . [$msg| $words:1 |]--instance Monad m => Functor (TC m) where-  fmap = liftM--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--instance Monad m => MonadError AlmsException (TC m) where-  throwError = TC . throwError-  catchError body handler =-    TC (catchError (unTC body) (unTC . handler))--instance Monad m => AlmsMonad (TC m) where-  throwAlms = throwError-  catchAlms = catchError---- | Generate a type error.-typeError :: (AlmsMonad m, ?loc :: Loc) => Message V -> m a-typeError msg0 = throwAlms (AlmsException StaticsPhase ?loc msg0)---- | Indicate a type checker bug.-typeBug :: AlmsMonad m => String -> String -> m a-typeBug culprit msg0 = throwAlms (almsBug StaticsPhase bogus culprit msg0)---- | 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 :: AlmsMonad 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 :: AlmsMonad m => S -> TC m a -> m (a, Module, S)-runTCNew s action = unTryAlms . runErrorT $ 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 }---- | Forget the module path (for type checking signatures)-forgetModulePath :: Monad m => TC m a -> TC m a-forgetModulePath  = local $ \cxt -> cxt { modulePath = [] }---- | Find out the current module path-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 -> typeBug "find" ("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-------- | A type checking "assertion" raises a type error if the---   asserted condition is false.-tassert :: (?loc :: Loc, AlmsMonad m) =>-            Bool -> Message V -> m ()-tassert True  _ = return ()-tassert False m = typeError m---- | A common form of type error: A got B where C expected-terrgot :: (?loc :: Loc, AlmsMonad m) =>-        String -> Type -> String -> m a-terrgot who got expected = typeError-  [$msg| $words:who got $q:got where $words:expected expected. |]---- | Combination of 'tassert and 'terrgot'-tassgot :: (?loc :: Loc, AlmsMonad m) =>-           Bool -> String -> Type -> String -> m ()-tassgot False = terrgot-tassgot True  = \_ _ _ -> return ()---- | Common message pattern, actual vs. expected-terrexp :: (?loc :: Loc, AlmsMonad m) =>-           Message V -> Message V -> Message V -> m a-terrexp  = typeError <$$$> [$msg|-  $msg:1-  <dl>-    <dt>actual:   <dd>$msg:2-    <dt>expected: <dd>$msg:3-  </dl>-|]---- | Common message pattern, actual vs. expected-tassexp :: (?loc :: Loc, AlmsMonad m) =>-           Bool -> Message V -> Message V -> Message V -> m ()-tassexp False = terrexp-tassexp True  = \_ _ _ -> return ()---- | 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 stxtype0 = do-  t <- tc iaeInit stxtype0-  return t-  where-  tc :: Monad m => CurrentImpArrRule -> Syntax.Type R -> TC m Type-  tc iae [$ty| '$tv |] = do-    return (TyVar tv)-  tc iae [$ty| $t1 -[$opt:mq]> $t2 |] = do-    qd  <- iaeInterpret iae mq-    t1' <- tc (iaeLeft iae) t1-    t2' <- tc (iaeRight iae qd t1') t2-    return (TyFun qd t1' t2')-  tc iae [$ty| ($list:ts) $qlid:n |] = do-    tc'  <- find n-    ts'  <- zipWithM (tc . iaeUnder iae) (tcArity tc') ts-    checkLength (length (tcArity tc'))-    checkBound (tcBounds tc') ts'-    return (tyApp tc' ts')-    where-      actualLen = length ts-      checkLength len =-        tassexp (actualLen == len)-          [$msg| Type constructor $q:n got wrong number of parameters: |]-          [$msg| $actualLen |]-          [$msg| $len |]-      checkBound quals ts' =-        tassexp (all2 (\qlit t -> qualConst t <: qlit) quals ts')-          [$msg| Type constructor $q:n used on higher-                 qualifiers than permitted: |]-          ([$msg| $1 |] (map (qRepresent . qualifier) ts'))-          [$msg| $quals (or less) |]-  tc iae [$ty| $quant:u '$tv . $t |] =-    TyQu u tv <$> tc iae t-  tc iae t0@[$ty| mu '$tv . $t |] = do-    case unfoldTyMu t of-      (_, N _ (Syntax.TyVar tv')) | tv == tv' ->-        typeError [$msg| Recursive type is not contractive: $t0 |]-      _ -> return ()-    t' <- tc iae t-    let actqual = qualConst t'-        expqual = tvqual tv-    tassert (actqual == expqual)-       [$msg| Recursive type has qualifier that does-              not match its own bound type variable:-              <dl>-                <dt>actual qualifier:   <dd>$actqual-                <dt>expected qualifier: <dd>$expqual-                <dt>in type:            <dd>$5:t0-              </dl> |]-    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 or let" (caexpr ca) md-        return (ti, caClause xi' ei' <<@ note)-      tr <- foldM (\ti' ti -> case ti' \/? ti of-        Right tr'          -> return tr'-        Left (_ :: String) -> typeError [$msg|-          Mismatch in branches of match or let.  Cannot unify:-          <ul>-            <li>$ti-            <li>$ti'-          </ul>-        |]) 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:" !:: bnexpr b-        tassgot (qualConst t' <: Qu)-          "Let rec binding" t' "unlimited type"-        bindVar (bnvar b) t'-        return t'-      (tas, e's) <- liftM unzip $ inModule md $ mapM (tc . bnexpr) bs-      zipWithM_ (\tf ta ->-                   tassexp (ta <: tf)-                      [$msg| In let rec, actual type does not-                             agree with declared type: |]-                      [$msg| $ta |]-                      [$msg| $tf |])-                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 "function body" e md-      (te, e') <- inModule md $ tc e-      q <- getWorthiness e0-      let stxt' = typeToStx' t'-      return (TyFun q t' te, [$ex|+ fun ($x' : $stxt') -> $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'-      let stxt2' = typeToStx' t2'-      return (t1', [$ex|+ $e1' [$stxt2'] |])-    [$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')-            [$msg| Could not pack existential:-                   <dl>-                     <dt>concrete type: <dd>$te-                     <dt>hiding:        <dd>$t2-                     <dt>to get:        <dd>$t1'-                   </dl> |]-          let stxt1' = typeToStx' t1'-              stxt2' = typeToStx' t2'-          return (t1', [$ex| Pack[$stxt1']($stxt2', $e') |])-        _ -> terrgot "Pack[-]" t1' "existential type"-    [$ex| ( $e1 : $t2 ) |] -> do-      (t1, e1') <- tc e1-      t2'       <- tcType t2-      tassexp (t1 <: t2')-        [$msg| Type ascription mismatch: |]-        [$msg| $t1 |]-        [$msg| $t2' |]-      return (t2', e1')-    [$ex| ( $e1 :> $t2 ) |] -> do-      (t1, e1') <- tc e1-      t2'       <- tcType t2-      tassgot (castableType t2')-        "Coercion (:>)" t1 "function type"-      e1'' <- coerceExpression (e1' <<@ e0) t1 t2'-        `catchAlms` \AlmsException { exnMessage = m } ->-          typeError [$msg|-            Cannot constructor coercion-            <dl>-              <dt>from type: <dd>$t1-              <dt>to type:   <dd>$t2',-            </dl>-            because there is no coercion available-            $vmsg:m-          |]-      -- 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)-            [$msg| Affine variable $q:l of type $q:t-                   duplicated in $words:name. |]-      _                 -> 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-        tassexp b-          [$msg| In application, operand type not in operator’s domain: |]-          [$msg| $t |]-          [$msg| $ta |]-        arrows tr ts-      arrows (view -> TyMu tv t') ts = arrows (tysubst tv (TyMu tv t') t') ts-      arrows t' (t:_) =-        terrexp-          [$msg| In application, operator is not a function: |]-          [$msg| $t' |]-          [$msg| $t -[...]> ... |]-      unifies tvs ta tf = do-          ts <- tryUnify tvs ta tf-          ta' <- foldM tapply (foldr tyAll ta tvs) ts-          if (ta' <: tf)-            then return True-            else deeper-        `catchAlms` \_ -> 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, AlmsMonad m) =>-          Type -> Type -> m Type-tapply (view -> TyQu Forall tv t1') t2 = do-  tassert (qualConst t2 <: tvqual tv) $-    [$msg| Type application cannot instantiate type variable:-           <dl>-             <dt>type variable:     <dd>$tv-             <dt>expected qualifier:<dd>$1-             <dt>type given:        <dd>$t2-             <dt>actual qualifier:  <dd>$2-           </dl> |] (tvqual tv) (qRepresent (qualifier t2))-  return (tysubst tv t2 t1')-tapply t1 _ = terrgot "Type application" t1 "forall 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)-        let te = tysubsts params ts res-        tassert (t' <: te)-          [$msg| Pattern got wrong type:-                 <dl>-                   <dt>actual:     <dd>$t'-                   <dt>expected:   <dd>$te-                   <dt>in pattern: <dd>$x0-                 </dl> |]-        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' |]-          (Nothing, Just _)  -> typeError $-            "Pattern has parameter where none expected:" !:: x0-          (Just _,  Nothing) -> typeError $-            "Pattern has no parameter but expects one of type" !:: t-      _ | isBotType t' -> case mx of-            Nothing -> return x0-            Just x  -> tcPatt tyBot x-        | otherwise ->-            typeError [$msg| Pattern got wrong type:-                             <dl>-                               <dt>type:    <dd>$t'-                               <dt>pattern: <dd>$x0-                             </dl> |]-  [$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') |]-      _ -> terrgot "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-        let qexp = tvqual tv-            qact = tvqual tve-        tassert (qact <: qexp)-          [$msg| Existential unpacking pattern cannot-                 instantiate type variable:-                 <dl>-                   <dt>pattern type variable: <dd>$tv-                   <dt>expected qualifier:    <dd>$qexp-                   <dt>actual type variable:  <dd>$tve-                   <dt>actual qualifier:      <dd>$qact-                 </dl> |]-        let te' = tysubst tve (TyVar tv) te-        x' <- tcPatt te' x-        return [$pa| Pack('$tv, $x') |]-      _ -> terrgot "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, AlmsMonad 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 _ = typeError $-    [$msg| In application, cannot find substitution for type-           $msg:1 to unify types:-           <dl>-             <dt>actual:  <dd>$t'-             <dt>expected:<dd>$t-           </dl> |] $-      case tvs of-        [tv]      -> [$msg| variable $tv |]-        [tv1,tv2] -> [$msg| variables $tv1 and $tv2 |]-        _         -> [$msg| variables $flow:1 |]-                     (map [$msg| $1 |] tvs)---- | 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 = typeError-    [$msg| Unbound type variable $tv in qualifier list-           for type $q: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')-  (tcs, md') <- loop stub-  forM_ tcs $ \tc -> do-    case tcNext tc of-      Nothing      -> return ()-      Just clauses -> forM_ clauses $ \(tps, rhs) -> do-        tassert (rhs /= tyPatToType (TpApp tc {tcNext = Nothing} tps)) $-          "Recursive type synonym is not contractive:" !:: tc-  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) $-      [$msg| In definition of type operator $q:name, not all-             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, AlmsMonad m, Ord node, Ppr 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-      lift $-        tassert (not (node `S.member` stack)) $-          "Unproductive cycle in type definitions via type" !:: 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 -[$opt:_]> $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)-    [$msg| Type pattern variable $tv has a variance annotation-           $q:var.  Variances may not be specified for parameters-           of type operators, but are inferred. |]-  return (TpVar tv)-tcTyPat tp@[$tpQ| ($list:tps) $qlid:qu |] = do-  let ?loc = _loc-  tc <- find qu-  tassert (isNothing (tcNext tc)) $-    "Type operator pattern is also a type operator:" !:: tp-  TpApp tc <$> mapM tcTyPat tps-tcTyPat [$tpQ| $antiP:a |]             = $antifail---- END type decl checking---- | Type check a signature-tcSigExp :: (?loc :: Loc, Monad m) =>-            SigExp R -> TC m (SigExp R)-tcSigExp [$seQ| sig $list:ds end |] = do-  ds' <- forgetModulePath $ 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) $-      "Signature fibration (with-type) cannot update concrete" ++-      "type constructor:" !:: ql-    let actlen = length tvs-        explen = length (tcArity tc)-    tassert (actlen == explen)-      [$msg| In signature fibration (with type), wrong number of-             parameters to type:-             <dl>-               <dt>actual count:   <dd>$actlen-               <dt>expected count: <dd>$explen-               <dt>for type:       <dd>$ql-             </dl> |]-    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)) $-    "Attempt to unpack existential in top-level binding:" !:: x-  (te, e') <- tcExpr e-  t' <- case mt of-    Just t  -> do-      t' <- tcType t-      tassert (qualConst t' == Qu) $-        [$msg| Declared type of let declaration of $q:x is not unlimited |]-      tassert (te <: t')-        [$msg| Mismatch in declared type for let declaration:-               <dl>-                 <dt>actual:     <dd>$te-                 <dt>expected:   <dd>$t'-                 <dt>in pattern: <dd>$x-               </dl> |]-      return t'-    Nothing -> do-      tassert (qualConst te == Qu) $-        [$msg| Type of let declaration binding is not unlimited:-               <dl>-                 <dt>type:       <dd>$te-                 <dt>qualifier:  <dd>$1-                 <dt>in pattern: <dd>$x-               </dl> |] (qRepresent (qualifier te))-      return te-  x' <- tcPatt t' x-  -- ioM (hPutStrLn stderr (show te))-  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'---- | 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-      if length params == length (tcArity tc)-        then return ()-        else typeBug "tcAbsTy" $-        "in abstype declaration " ++ show (length params) ++-        " parameters given for type " ++ show name ++-        " which has " ++ show (length (tcArity tc))-      let actualArity = tcArity tc-          actualQual  = tcQual tc-      tassexp (all2 (<:) actualArity arity)-        [$msg| In abstype declaration, declared parameter variance for-               type $q:name is more permissive than actual variance: |]-        (pprMsg actualArity)-        (pprMsg arity)-      tassexp (actualQual <: qualSet)-        [$msg| In abstype declaration, declared qualifier for-               type $q:name is more permissive than actual qualifier: |]-        (showMsg actualQual)-        (showMsg qualSet)-      return $ abstractTyCon tc {-        tcQual  = qualSet,-        tcArity = arity,-        tcCons  = ([], empty)-      }-    _ -> typeBug "tcAbsTy" "Can’t do abstype with 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-  us <- currentModulePath-  let md2'   = renameSig (makeNameMap md1) us 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 -> [Uid Renamed] -> Module -> Module-renameSig nm0 us = 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'-      where tc' = tc { tcName = J us (jname (tcName tc)) }-    MdModule x md1 ->-      let Just (x', nm1) = nm0 =..= x-       in MdModule x' (renameSig nm1 (us++[x']) 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.-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)-      tassexp (t' <: t)-        [$msg| In signature matching, type mismatch for $q:x: |]-        [$msg| $t' |]-        [$msg| $t |]-    MdTycon x tc   -> do-      tc' <- find (J [] x :: QLid R)-      case varietyOf tc of-        AbstractType -> do-          let sigass assertion thing getter =-                tassexp assertion-                  ([$msg| In signature matching, cannot match the-                          definition for type $q:1 because the-                          $words:thing does not match: |] (tcName tc))-                  (showMsg (getter tc'))-                  (showMsg (getter tc))-          sigass (length (tcArity tc') == length (tcArity tc))-            "number of type parameters" (length . tcArity)-          sigass (all2 (<:) (tcArity tc') (tcArity tc))-            "variance" tcArity-          sigass (all2 (<:) (tcBounds tc') (tcBounds tc))-            "parameter bounds" tcBounds-          sigass (tcQual tc' <: tcQual tc)-            "qualifier" tcQual-        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.---   First signature is what we have, and second is what we want.-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-    (x, what) <- whatIs sg-    typeError [$msg|-      In exact signature matching, missing expected $what $qmsg:x.-    |]-  loop (sg : _) []          = do-    (x, what) <- whatIs sg-    typeError [$msg|-      In exact signature matching, found unexpected $what $qmsg:x.-    |]-  loop (sg1 : _) (sg2 : _)  = do-    (x1, what1) <- whatIs sg1-    (x2, what2) <- whatIs sg2-    typeError [$msg|-      In exact signature matching (for signatures as entries in-      signatures being matched), got signature items didn’t match:-      <dl>-        <dt>actual:   <dd>$what1 $qmsg:x1-        <dt>expected: <dd>$what2 $qmsg:x2-      </dl>-    |]-  ---  whatIs (MdValue x _)  = return (pprMsg x, "value")-  whatIs (MdTycon x _)  = return (pprMsg x, "type")-  whatIs (MdModule x _) = return (pprMsg x, "module")-  whatIs (MdSig x _)    = return (pprMsg x, "module type")-  whatIs _              = typeBug "matchSigs" "weird signature item"---- | 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 or variance"-           (show (tcArity tc1)) (show (tcArity tc2))-    tassert (tcBounds tc1 == tcBounds tc2) $-      estr "parameter bound" (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) -> typeError $ estr "kind of definition" (show v1) (show v2)-  where-    estr what which1 which2 =-      [$msg|-        In signature matching, cannot match definition for type-        $q:tc1 because the $words:what does not match:-        <dl>-          <dt>actual:   <dd>$which1-          <dt>expected: <dd>$which2-        </dl>-      |]---- | To 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-  = terrexp-      [$msg| In signature matching, cannot match type patterns: |]-      (pprMsg tp1) (pprMsg 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 :: TyNames -> TyCon -> TyDec R-tyConToDec tn tc = case tc of-  _ | tc == tcExn-    -> tdAbs (lid "exn") [] [] maxBound-  TyCon { tcName = n, tcNext = Just clauses }-    -> tdSyn (jname n) [ (map (tyPatToStx tn) ps, typeToStx tn rhs)-                       | (ps, rhs) <- clauses ]-  TyCon { tcName = n, tcCons = (ps, alts) }-    | not (isEmpty alts)-    -> tdDat (jname n) ps [ (u, fmap (typeToStx tn) 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 data 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---- Open the given module, if it exists.-staticsEnterScope    :: Uid R -> S -> S-staticsEnterScope u s =-  let e = sEnv s in-  case e =..= u of-    Just (_, e') -> s { sEnv = e =+= e' }-    Nothing      -> s+-- | The external interface to the type checker+module Statics (+  -- * Type checking state+  StaticsState, staticsState0, staticsState0',+  -- ** Initial state+  addSignature, addPrimType,++  -- * Type checking operations+  typeCheckDecls, typeCheckProg,++  -- * Renaming and typing info+  -- ** Renaming+  Statics.getRenamingInfo, RenamingInfo(..),+  -- ** Constraint solving+  getConstraint,+  -- ** Type checking+  getVarInfo, getTypeInfo, getConInfo,+  -- ** Printing nice type names+  addTyNameContext, makeTyNames, makeT2SContext, staticsEnterScope,+) where++import Util+import Util.MonadRef+import AST.Ident (Raw, Renamed, Id(..))+import qualified AST+import Syntax.PprClass (Doc, setTyNames)+import Type+import Statics.Env+import Statics.Error+import Statics.Constraint+import Statics.Rename+import Statics.Decl++import Prelude ()+import qualified Data.List as List++---+--- TYPE CHECKING STATE+---++-- | The state of the renamer and type checker, parameterized by+--   a reference type.+data StaticsState r+  = StaticsState {+      ssRen     ∷ !RenameState,+      ssCon     ∷ !(ConstraintState (TV r) r),+      ssEnv     ∷ !(Γ (TV r))+    }+    deriving Show++-- | The initial state of the type checker, parameterized by the+--   initial renaming state.+staticsState0 ∷ RenameState → StaticsState r+staticsState0 rs+  = StaticsState {+      ssRen     = rs,+      ssCon     = constraintState0,+      ssEnv     = mempty+    }++-- | The initial state of the type checker with no initial renaming+--   state.+staticsState0' ∷ StaticsState r+staticsState0' = staticsState0 renameState0++---+--- TYPE CHECKING OPERATIONS+---++-- | Type check a sequence of declarations.+typeCheckDecls ∷ (MonadAlmsError m, MonadRef r m) ⇒+                 StaticsState r →+                 [AST.Decl Raw] →+                 m ([AST.Decl Renamed],+                    [AST.SigItem R],+                    StaticsState r)+typeCheckDecls ss ds = do+  (ds', rs)             ← bailoutIfError $+    runRenamingM True bogus (ssRen ss) (renameDecls ds)+  ((ds'', γ', sig), cs) ← bailoutIfError . runConstraintT (ssCon ss) $ do+    tcDecls [] (ssEnv ss) ds' <* ensureSatisfiability+  let ss' = ss {+              ssRen     = rs,+              ssCon     = cs,+              ssEnv     = γ'+            }+  return (ds'', sigItemToStx (makeTyNames ss') <$> sig, ss')++-- | Type check a program.+typeCheckProg ∷ (MonadAlmsError m, MonadRef r m) ⇒+                StaticsState r →+                AST.Prog Raw →+                m (AST.Prog Renamed, Maybe (AST.Type Renamed))+typeCheckProg ss p = do+  (p', _)         ← bailoutIfError $+    runRenamingM True bogus (ssRen ss) (renameProg p)+  ((p'', mσ), _)  ← bailoutIfError . runConstraintT (ssCon ss) $ do+    tcProg (ssEnv ss) p' <* ensureSatisfiability+  return (p'', typeToStx' <$> mσ)++---+--- ADDING INITIAL BINDINGS+---++-- | Bind the contents of a signature in the environment.  This is used+--   for setting up some primitive types and values.+addSignature ∷ (MonadAlmsError m, MonadRef r m) ⇒+               StaticsState r →+               AST.SigExp Renamed →+               m (StaticsState r)+addSignature ss sigexp = do+  (sig, cs') ← runConstraintT (ssCon ss) (tcSigExp (ssEnv ss) sigexp)+  return ss {+    ssCon       = cs',+    ssEnv       = ssEnv ss =+= sigToEnv sig+  }++-- | Bind a primitive type constructor at top level.+addPrimType ∷ StaticsState r → TypId → TyCon → StaticsState r+addPrimType ss tid tc = ss { ssEnv = ssEnv ss =+= tid =:= tc }++---+--- INTERFACE FOR GETTING TYPE INFO+---++-- | Find out the renamed name of an identifier and where it was defined.+getRenamingInfo ∷ AST.Ident Raw → StaticsState r → [RenamingInfo]+getRenamingInfo = Statics.Rename.getRenamingInfo <$.> ssRen++-- | Find out the type of a variable+getVarInfo :: QVarId -> StaticsState r -> Maybe (AST.Type R)+getVarInfo vid ss = typeToStx (makeT2SContext ss) <$> ssEnv ss =..= vid++-- | Find out about a type+getTypeInfo :: QTypId -> StaticsState r -> Maybe TyCon+getTypeInfo tid ss = ssEnv ss =..= tid++-- Find out about a data constructor.  If it's an exception constructor,+-- return 'Right' with its parameter, otherwise return the type construtor+-- of the result type+getConInfo :: QConId -> StaticsState r ->+              Maybe (Either TyCon (Maybe (AST.Type R)))+getConInfo cid ss = typeToStx (makeT2SContext ss) <$$$> ssEnv ss =..= cid++-- | Get a printable representation of the current constraint-solving+--   state.+getConstraint ∷ StaticsState r → Doc+getConstraint = pprConstraintState . ssCon++-- Open the given module, if it exists.+staticsEnterScope       :: ModId -> StaticsState r -> StaticsState r+staticsEnterScope mid ss =+  case ssEnv ss =..= mid of+    Just (_, e') -> ss { ssEnv = ssEnv ss =+= e' }+    Nothing      -> ss++---+--- CHOOSING BEST TYPE NAMES+---++-- | Given the type checker state, add it to the context of a document+--   for printing type names in that document.+addTyNameContext :: StaticsState r → Doc → Doc+addTyNameContext  = setTyNames . makeTyNames++-- | Get the type name lookup gadget from the type checker state+makeTyNames :: StaticsState r → TyNames+makeTyNames ss+  = TyNames {+      tnLookup = getBestName ss,+      tnEnter  = \mid → makeTyNames (staticsEnterScope mid ss)+    }++-- | Make the type-syntactifying context from the type checker state+makeT2SContext :: StaticsState r →+                  T2SContext CurrentImpArrPrintingRule tv+makeT2SContext ss = t2sContext0 { t2sTyNames = makeTyNames ss }++-- | The status of a type name in an environment+data NameStatus+ -- | Bound to the expected type+ = Match+ -- | Not bound+ | NoMatch+ -- | Shadowed+ | Interfere+ deriving Eq++-- | In the given environment, what is the status of the given+--   type name?+getNameStatus :: StaticsState r → Int → QTypId → NameStatus+getNameStatus ss tag tid =+  case [ tid'+       | TyconAt _ tid' <- Statics.getRenamingInfo ql ss ] of+    tid':_ ->+      case getTypeInfo tid' ss of+        Just tc | tcId tc == tag  -> Match+                | otherwise       -> Interfere+        _                         -> NoMatch+    _     -> NoMatch+  where ql = J (map (AST.renId bogus) (jpath tid))+               (AST.ident (AST.idName (jname tid)))++-- | Names known to the pretty-printer that should always be used+--   exactly like this so that things print nicely.+intrinsicNames ∷ [(Int, String)]+intrinsicNames = first tcId <$>+  [ (tcVariant,  AST.tnVariant),+    (tcRecord,   AST.tnRecord),+    (tcRowEnd,   AST.tnRowEnd),+    (tcRowHole,  AST.tnRowHole),+    (tcRowMap,   AST.tnRowMap),+    (tcUn,       AST.tnUn),+    (tcAf,       AST.tnAf) ]++-- | Find the best name to refer to a type constructor.+--   The goal here is to get the shortest unambiguous name.+--    1. If the first parameter is True, we want an accurate name, so+--       skip to step 3.+--    2. If the unqualified name is bound to either the same type+--       or to nothing, then use the unqualified name.+--    3. Try qualifiying the name, starting with the last segment+--       and adding one at a time, and if any of these match, then+--       use that.+--    4. Otherwise, uglify the name, because it's probably gone+--       out of scope.+getBestName :: StaticsState r -> Int -> QTypId -> QTypId++getBestName ss tag qtid+  | Just str ← lookup tag intrinsicNames = qident str+  | otherwise                            =+    case tryQuals (jpath qtid) (jname qtid) of+      Just qtid'    → qtid'+      Nothing+        | AST.isTrivial (idTag (jname qtid))+        , NoMatch ← getNameStatus ss tag qtid+                    → qtid+        | otherwise → uglify+  where+    tryQuals mids tid = msum+      [ case getNameStatus ss tag (J mids' tid) of+          Match     -> Just (J mids' tid)+          _         -> Nothing+      | mids' <- reverse (List.tails mids) ]+    uglify+      | '?':_ ← show qtid = qtid+      | otherwise         = qtid { jpath = ident ('?':show tag) : jpath qtid }
+ src/Statics/Coercion.hs view
@@ -0,0 +1,134 @@+-- | Converts coercion expressions to dynamic checks.+module Statics.Coercion  (+  coerceExpression,+) where++import Util+import Util.MonadRef+import qualified AST+import AST.Ident+import Data.Loc+import Meta.Quasi+import Error+import Type+import Statics.Constraint++import Prelude ()+import qualified Data.Map as M++-- | Location to use for constructed code+_loc :: Loc+_loc  = mkBogus "<coercion>"++type R = AST.Renamed++-- | Coerce an expression from one type to another, if possible.+coerceExpression :: MonadConstraint tv r m ⇒+                    AST.Expr R → Type tv → Type tv → m (AST.Expr R)+coerceExpression e σfrom σto = do+  σfrom' ← subst σfrom+  σto'   ← subst σto+  prj    ← evalStateT (build mempty σfrom' σto') 0 `catchAlms` handler+  return [ex|+ $prj ($str:neg, $str:pos) $e |]+  where+  neg = "context at " ++ show (getLoc e)+  pos = "value at " ++ show (getLoc e)+  mapMsg f exn = exn { exnMessage = f (exnMessage exn) }+  handler =+    throwAlmsList .+    map (mapMsg [msg| While constructing coercion (:>): <br> $1 |]) .+    mapHead (mapMsg+      [msg|+        $1+        <p>+        Could not construct coercion+        <dl>+          <dt>from type: <dd>$σfrom+          <dt>to type:   <dd>$σto.+        </dl>+        <p>+        Hints:+        <ul>+          <li>+            Coercions may be constructed only between (possibly+            quantified) arrow types.  All other types must be+            unifiable as subtypes.+          <li>+            Coercion construction may fail if either the type of+            the expression or the requested coercion type is+            incomplete due to type inference, so it may help to+            add a non-coercing type annotation to the term+            inside the coercion, like <q>(e : τfrom :> τto)</q>.+        </ul>+      |])++type RecMap tv r = M.Map (Type tv, Type tv) (VarId R, r Bool)++build :: (MonadConstraint tv r m, MonadState Integer m) ⇒+         RecMap tv r → Type tv → Type tv → m (AST.Expr R)++build μ σfrom σto+  | Just (x, used) ← M.lookup (σfrom, σto) μ+  = do+    writeRef used True+    return [ex| $vid:x |]++build μ σfrom@(TyMu _ σfrom') σto+  = remember μ σfrom σto $ \μ' →+      build μ' (openTy 0 [σfrom] σfrom') σto++build μ σfrom σto@(TyMu _ σto')+  = remember μ σfrom σto $ \μ' →+      build μ' σfrom (openTy 0 [σto] σto')++build μ (TyQu Forall tvs1 σfrom) (TyQu Forall tvs2 σto)+  | length tvs1 == length tvs2+  , all2 (⊑) (snd <$> tvs1) (snd <$> tvs2)+  = build μ σfrom σto++build μ (TyQu Exists tvs1 σfrom) (TyQu Exists tvs2 σto)+  | tvs1 == tvs2+  = build μ σfrom σto++build μ (TyApp tc1 [σf1, qf, σf2]) (TyApp tc2 [σt1, qt, σt2])+  | tc1 == tcFun, tc2 == tcFun+  = do+    dom ← build μ σt1 σf1+    cod ← build μ σf2 σt2+    let which = contractIdent $+          if qualifier qf ⊑ qualifier qt+            then "func"+            else "affunc"+    return [ex| $qvid:which $dom $cod |]++build _ σfrom σto+  = do+    σfrom <: σto+    return [ex| $qvid:anyId |]+    where anyId = contractIdent "any"++-- | Get the identifier for a known name from the contracts library.+contractIdent ∷ String → QVarId R+contractIdent = qident . ("INTERNALS.Contract." ++)++-- | Remember a coercion to use it recursively later.+remember ∷ (MonadConstraint tv r m, MonadState Integer m) ⇒+           RecMap tv r → Type tv → Type tv →+           (RecMap tv r → m (AST.Expr R)) →+           m (AST.Expr R)+remember μ σfrom σto k = do+  c      ← freshVarId+  rused  ← newRef False+  result ← k (M.insert (σfrom, σto) (c, rused) μ)+  used   ← readRef rused+  return $ if used+    then [ex| let rec $vid:c = $result in $vid:c |]+    else result++-- | Get a fresh variable name to build a recursive coercion.+freshVarId :: MonadState Integer m ⇒ m (VarId R)+freshVarId = do+  n ← get+  put (n + 1)+  return (ident ("c" ++ show n))+
+ src/Statics/Constraint.hs view
@@ -0,0 +1,1587 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module Statics.Constraint (+  -- * The constraint solver interface+  MonadConstraint(..), generalize, generalizeList, generalizeEx,++  -- * An implementation of the interface+  ConstraintT,+  runConstraintT, mapConstraintT,+  ConstraintState, constraintState0, pprConstraintState,+  runConstraintIO,+) where++import Util+import Util.Trace+import Util.MonadRef+import qualified Syntax.Ppr      as Ppr+import qualified Alt.Graph       as Gr+import qualified Data.UnionFind  as UF+import Type+import Statics.Error++import Prelude ()+import qualified Data.List  as List+import qualified Data.Set   as S+import qualified Data.Map   as M+import qualified Data.Boolean.SatSolver as SAT+import Data.IORef (IORef)++---+--- A CONSTRAINT-SOLVING MONAD+---++class MonadSubst tv r m ⇒ MonadConstraint tv r m | m → tv r where+  -- | Subtype and equality constraints+  (<:), (=:)    ∷ Type tv → Type tv → m ()+  -- | Subqualifier constraint+  (⊏:), (~:)    ∷ (Qualifier q1 tv, Qualifier q2 tv) ⇒ q1 → q2 → m ()+  -- | Constrain by the given variance+  relate        ∷ Variance → Type tv → Type tv → m ()+  --+  τ1 =: τ2   = τ1 <: τ2 >> τ2 <: τ1+  τ1 ~: τ2   = τ1 ⊏: τ2 >> τ2 ⊏: τ1+  relate variance τ1 τ2 = case variance of+    Covariant      → τ1 <: τ2+    Contravariant  → τ2 <: τ1+    Invariant      → τ1 =: τ2+    QCovariant     → τ1 ⊏: τ2+    QContravariant → τ2 ⊏: τ1+    QInvariant     → τ1 ~: τ2+    Omnivariant    → return ()+  --+  -- | Get the set of pinned type variables.+  getPinnedTVs    ∷ m (S.Set tv)+  -- | Run a computation in the context of some "pinned down" type+  --   variables, which means that they won't be considered for+  --   elimination or generalization.+  withPinnedTVs   ∷ Ftv a tv ⇒ a → m b → m b+  -- | Update the list of pinned type variables to reflect a substitution.+  --   PRECONDITION: τ is substituted.+  updatePinnedTVs ∷ tv → Type tv → m ()+  --+  -- | Figure out which variables to generalize in a piece of syntax.+  --   The 'Bool' indicates whether the syntax whose type is being+  --   generalized is a syntactic value.  Returns a list of+  --   generalizable variables and their qualifier bounds.+  generalize'     ∷ Bool → Rank → Type tv → m [(tv, QLit)]+  -- | Find 'QLit' bounds for a set of type variables.  This assumes+  --   that these variables may safely be removed from the constraint+  --   if bounded as specified.  In particular, all the variables must+  --   appear only on the left-hand side of the qualifier inequalities.+  getTVBounds     ∷ [tv] → m [QLit]+  -- | Ensure that the current constraint is satisfiable.  This is+  --   necessary after each REPL entry, because that's the commit point+  --   for the constraint, and the REPL becomes unusable if a particular+  --   type error hangs around in the constraint forever.+  ensureSatisfiability ∷ m ()++infix 5 <:, =:, ⊏:, ~:++--+-- Pass-through instances+--++instance (MonadConstraint tv s m, Monoid w) ⇒+         MonadConstraint tv s (WriterT w m) where+  (<:) = lift <$$> (<:)+  (=:) = lift <$$> (=:)+  (⊏:) = lift <$$> (⊏:)+  (~:) = lift <$$> (~:)+  getPinnedTVs   = lift getPinnedTVs+  withPinnedTVs  = mapWriterT <$> withPinnedTVs+  updatePinnedTVs= lift <$$> updatePinnedTVs+  generalize'    = lift <$$$> generalize'+  getTVBounds    = lift <$> getTVBounds+  ensureSatisfiability = lift ensureSatisfiability++instance MonadConstraint tv r m ⇒+         MonadConstraint tv r (StateT s m) where+  (<:) = lift <$$> (<:)+  (=:) = lift <$$> (=:)+  (⊏:) = lift <$$> (⊏:)+  (~:) = lift <$$> (~:)+  getPinnedTVs   = lift getPinnedTVs+  withPinnedTVs  = mapStateT <$> withPinnedTVs+  updatePinnedTVs= lift <$$> updatePinnedTVs+  generalize'    = lift <$$$> generalize'+  getTVBounds    = lift <$> getTVBounds+  ensureSatisfiability = lift ensureSatisfiability++instance MonadConstraint tv p m ⇒+         MonadConstraint tv p (ReaderT r m) where+  (<:) = lift <$$> (<:)+  (=:) = lift <$$> (=:)+  (⊏:) = lift <$$> (⊏:)+  (~:) = lift <$$> (~:)+  getPinnedTVs   = lift getPinnedTVs+  withPinnedTVs  = mapReaderT <$> withPinnedTVs+  updatePinnedTVs= lift <$$> updatePinnedTVs+  generalize'    = lift <$$$> generalize'+  getTVBounds    = lift <$> getTVBounds+  ensureSatisfiability = lift ensureSatisfiability++instance (MonadConstraint tv p m, Monoid w) ⇒+         MonadConstraint tv p (RWST r w s m) where+  (<:) = lift <$$> (<:)+  (=:) = lift <$$> (=:)+  (⊏:) = lift <$$> (⊏:)+  (~:) = lift <$$> (~:)+  getPinnedTVs   = lift getPinnedTVs+  withPinnedTVs  = mapRWST <$> withPinnedTVs+  updatePinnedTVs= lift <$$> updatePinnedTVs+  generalize'    = lift <$$$> generalize'+  getTVBounds    = lift <$> getTVBounds+  ensureSatisfiability = lift ensureSatisfiability++--+-- Some generic operations+--++-- | Generalize a type under a constraint and environment,+--   given whether the the value restriction is satisfied or not+generalize    ∷ MonadConstraint tv r m ⇒+                Bool → Rank → Type tv → m (Type tv)+generalize value γrank ρ = do+  αqs ← generalize' value γrank ρ+  standardizeMus <$> closeQuant Forall αqs <$> subst ρ++-- | Generalize a list of types together.+generalizeList ∷ MonadConstraint tv r m ⇒+                 Bool → Rank → [Type tv] → m [Type tv]+generalizeList value γrank ρs = do+  αqs ← generalize' value γrank (foldl tyTuple tyUnit ρs)+  mapM (standardizeMus <$> closeQuant Forall αqs <$$> subst) ρs++-- | Generalize the existential type variables in a type+generalizeEx   ∷ MonadConstraint tv r m ⇒+                 Rank → Type tv → m (Type tv)+generalizeEx γrank ρ0 = do+  ρ   ← subst ρ0+  αs  ← removeByRank γrank (filter (tvFlavorIs Existential) (ftvList ρ))+  αqs ← mapM addQual αs+  return (closeQuant Exists αqs ρ)+  where+    addQual α = case tvQual α of+      Just ql → return (α, ql)+      Nothing → typeBug "generalizeEx"+                        "existential type variable with no rank"++-- | Remove type variables from a list if their rank indicates that+--   they're in the environment or if they're pinned+removeByRank ∷ MonadConstraint tv r m ⇒ Rank → [tv] → m [tv]+removeByRank γrank αs = do+  pinned ← getPinnedTVs+  let keep α = do+        rank ← getTVRank α+        return (rank > γrank && α `S.notMember` pinned)+  filterM keep αs++---+--- SUBTYPING CONSTRAINT SOLVER+---++--+-- The internal state+--++-- | The state of the constraint solver.+data CTState tv r+  = CTState {+      -- | Graph for subtype constraints on type variables and atomic+      --   type constructors+      csGraph   ∷ !(Gr.Gr tv ()),+      -- | Reverse lookup for turning atoms into node numbers for the+      --   'csGraph' graph+      csNodeMap ∷ !(Gr.NodeMap tv),+      -- | Maps type variables to same-size equivalence classes+      csEquivs  ∷ !(ProxyMap tv r),+      -- | Types to relate by the subqualifier relation+      csQuals   ∷ ![(Type tv, Type tv)],+      -- | Stack of pinned type variables+      csPinned  ∷ ![S.Set tv]+    }++-- | Representation of type variable equivalence class+type TVProxy  tv r = UF.Proxy r (S.Set tv)+-- | The map from type variables to equivalence classes+type ProxyMap tv r = M.Map tv (TVProxy tv r)++-- | Updater for 'csQuals' field+csQualsUpdate ∷ ([(Type tv, Type tv)] → [(Type tv, Type tv)]) →+                CTState tv r → CTState tv r+csQualsUpdate f cs = cs { csQuals = f (csQuals cs) }++-- | Updater for 'csEquivs' field+csEquivsUpdate ∷ (ProxyMap tv r → ProxyMap tv r) →+                 CTState tv r → CTState tv r+csEquivsUpdate f cs = cs { csEquivs = f (csEquivs cs) }++-- | Updater for 'csPinned' field+csPinnedUpdate ∷ ([S.Set tv] → [S.Set tv]) →+                 CTState tv r → CTState tv r+csPinnedUpdate f cs = cs { csPinned = f (csPinned cs) }++instance Tv tv ⇒ Show (CTState tv r) where+  showsPrec _ cs+    | null (Gr.edges (csGraph cs)) +    , null (csQuals cs) +        = id+    | otherwise+        = showString "CTState { csGraph = "+        . shows (Gr.ShowGraph (csGraph cs))+        . showString ", csQuals = "+        . shows (csQuals cs)+        . showString " }"++instance Tv tv ⇒ Ppr.Ppr (CTState tv r) where+  ppr cs = Ppr.ppr . M.fromList $+    [ ("graph",    Ppr.fsep . Ppr.punctuate Ppr.comma $+                     [ Ppr.pprPrec 10 α1+                         Ppr.<> Ppr.text "<:"+                         Ppr.<> Ppr.pprPrec 10 α2+                     | (α1, α2) ← Gr.labNodeEdges (csGraph cs) ])+    , ("quals",    Ppr.fsep . Ppr.punctuate Ppr.comma $+                     [ Ppr.pprPrec 9 τ1+                         Ppr.<> Ppr.char '⊑'+                         Ppr.<> Ppr.pprPrec 9 τ2+                     | (τ1, τ2) ← csQuals cs+                     ])+    ]++--+-- The monad transformer+--++-- | Underlying 'ConstraintT' is a monad transformer that carries merely+--   the constraint-solving state.+newtype ConstraintT_ tv r m a+  = ConstraintT_ {+      unConstraintT_ ∷ StateT (CTState tv r) m a+    }+  deriving (Functor, Applicative, Monad, MonadAlmsError, MonadTrace)++-- | Map some higher-order operation through 'ConstraintT_'.+mapConstraintT_   ∷ (∀ s. m (a, s) → n (b, s)) →+                    ConstraintT_ tv r m a → ConstraintT_ tv r n b+mapConstraintT_ f = ConstraintT_ . mapStateT f .  unConstraintT_++-- | Constraint monad transformer carries constraint solver state.+--   'SubstT' substitution state.+type ConstraintT tv r m = ConstraintT_ tv r (SubstT r m)++-- | Map some higher-order operation through 'ConstraintT'.+mapConstraintT   ∷ (Functor m, Functor n) ⇒+                   (∀ s. m (a, s) → n (b, s)) →+                   ConstraintT tv r m a → ConstraintT tv r n b+mapConstraintT f = mapConstraintT_ (mapSubstT f')+  where+    f' action            = unshift <$> f (shift <$> action)+    shift ((a, s), s')   = (a, (s, s'))+    unshift (a, (s, s')) = ((a, s), s')++-- | Run the constraint solver.+runConstraintT ∷ (MonadAlmsError m, MonadRef r m) ⇒+                 ConstraintState (TV r) r →+                 ConstraintT (TV r) r m a →+                 m (a, ConstraintState (TV r) r)+runConstraintT ecs m = do+  ((result, cs), ss) ← runSubstT+                          (ecsSubst ecs)+                          (runStateT (unConstraintT_ (resetEquivTVs >> m))+                                     (ecsInternal ecs))+  return (result, ExternalConstraintState cs ss)++-- | Run a constraint computation in the IO Monad+runConstraintIO ∷ ConstraintState (TV IORef) IORef →+                  ConstraintT (TV IORef) IORef (AlmsErrorT IO) a →+                  IO (Either [AlmsError]+                             (a, ConstraintState (TV IORef) IORef))+runConstraintIO ecs m = runAlmsErrorT (runConstraintT ecs m)++-- | The external representation of the constraint solver's state+data ConstraintState tv r+  = ExternalConstraintState {+      ecsInternal       ∷ !(CTState tv r),+      ecsSubst          ∷ !SubstState+    }++-- | The initial constraint solver state+constraintState0 ∷ Tv tv ⇒ ConstraintState tv r+constraintState0+  = ExternalConstraintState {+      ecsInternal = CTState {+        csGraph   = Gr.empty,+        csNodeMap = Gr.new,+        csEquivs  = M.empty,+        csQuals   = [],+        csPinned  = []+      },+      ecsSubst = substState0+    }++instance Tv tv ⇒ Ppr.Ppr (ConstraintState tv r) where+  ppr = Ppr.ppr . ecsInternal++instance Tv tv ⇒ Show (ConstraintState tv r) where+  showsPrec = Ppr.showFromPpr++-- | Get a printable representations of the internal constraint-solving+--  state.+pprConstraintState ∷ Tv tv ⇒ ConstraintState tv r → Ppr.Doc+pprConstraintState = Ppr.ppr . ecsInternal++--+-- Instances+--++-- | Transformer instance+instance MonadTrans (ConstraintT_ tv r) where+  lift = ConstraintT_ . lift++-- | Pass through for reference operations+instance MonadSubst tv r m ⇒+         MonadRef r (ConstraintT_ tv r m) where+  newRef        = lift <$> newRef+  readRef       = lift <$> readRef+  writeRef      = lift <$$> writeRef++-- | Pass through for unification operations+instance MonadSubst tv r m ⇒+         MonadSubst tv r (ConstraintT_ tv r m) where+  newTV_ (Universal, kind, bound, descr) = do+    α ← lift (newTV' (kind, descr))+    fvTy α ⊏: bound+    return α+  newTV_ attrs  = lift (newTV' attrs)+  writeTV_      = lift <$$> writeTV_+  readTV_       = lift <$> readTV_+  getTVRank_    = lift <$> getTVRank_+  setTVRank_    = lift <$$> setTVRank_+  collectTVs    = mapConstraintT_ (mapListen2 collectTVs)+  reportTVs     = lift . reportTVs+  monitorChange = mapConstraintT_ (mapListen2 monitorChange)+  setChanged    = lift setChanged++-- | 'ConstraintT' implements 'Graph'/'NodeMap' transformer operations+--   for accessing its graph and node map.+instance (Ord tv, Monad m) ⇒+         Gr.MonadNM tv () Gr.Gr (ConstraintT_ tv r m) where+  getNMState = ConstraintT_ (gets (csNodeMap &&& csGraph))+  getNodeMap = ConstraintT_ (gets csNodeMap)+  getGraph   = ConstraintT_ (gets csGraph)+  putNMState (nm, g) = ConstraintT_ . modify $ \cs →+    cs { csNodeMap = nm, csGraph = g }+  putNodeMap nm = ConstraintT_ . modify $ \cs → cs { csNodeMap = nm }+  putGraph g    = ConstraintT_ . modify $ \cs → cs { csGraph = g }++-- | Constraint solver implementation.+instance MonadSubst tv r m ⇒+         MonadConstraint tv r (ConstraintT_ tv r m) where+  τ <: τ' = do+    traceN 3 ("<:", τ, τ')+    runSeenT (subtypeTypes False τ τ')+  τ =: τ' = do+    traceN 3 ("=:", τ, τ')+    runSeenT (subtypeTypes True τ τ')+  τ ⊏: τ' = do+    traceN 3 ("⊏:", qualToType τ, qualToType τ')+    addQualConstraint τ τ'+  --+  getPinnedTVs      = S.unions <$> ConstraintT_ (gets csPinned)+  --+  withPinnedTVs a m = do+    let αs = ftvSet a+    ConstraintT_ (modify (csPinnedUpdate (αs :)))+    result ← m+    ConstraintT_ (modify (csPinnedUpdate tail))+    return result+  --+  updatePinnedTVs α τ = do+    let βs      = ftvSet τ+        update  = snd . mapAccumR eachSet False+        eachSet False set+          | α `S.member` set = (True, βs `S.union` S.delete α set)+        eachSet done set       = (done, set)+    ConstraintT_ (modify (csPinnedUpdate update))+  --+  generalize'          = solveConstraint+  getTVBounds          = solveBounds+  ensureSatisfiability = checkQualifiers++{-# INLINE gtraceN #-}+gtraceN ∷ (TraceMessage a, Tv tv, MonadTrace m) ⇒+          Int → a → ConstraintT_ tv r m ()+gtraceN =+  if debug then \n info →+    if n <= debugLevel then do+      trace info+      cs ← ConstraintT_ get+      let doc = Ppr.ppr cs+      unless (Ppr.isEmpty doc) $+        trace (Ppr.nest 4 doc)+    else return ()+  else \_ _ → return ()++-- | Monad transformer for tracking which type comparisons we've seen,+--   in order to implement recursive subtyping.  A pair of types mapped+--   to @True@ means that they're known to be equal, whereas @False@+--   means that they're only known to be subtyped.+type SeenT tv r m = StateT (M.Map (Type tv, Type tv) Bool)+                           (ConstraintT_ tv r m)++-- | Run a recursive subtyping computation.+runSeenT ∷ (Tv tv, MonadTrace m) ⇒ SeenT tv r m a → ConstraintT_ tv r m a+runSeenT m = do+  gtraceN 4 "runSeenT {"+  result ← evalStateT m M.empty+  gtraceN 4 "} runSeenT"+  return result++-- | Relate two types at either subtyping or equality, depending on+--   the value of the first parameter (@True@ means equality).+--   This eagerly solves as much as possible, adding to the constraint+--   only as necessary.+subtypeTypes ∷ MonadSubst tv r m ⇒+               Bool → Type tv → Type tv → SeenT tv r m ()+subtypeTypes unify = check where+  check τ1 τ2 = do+    lift $ gtraceN 4 ("subtypeTypes", unify, τ1, τ2)+    τ1'  ← subst τ1+    τ2'  ← subst τ2+    seen ← get+    unless (M.lookup (τ1', τ2') seen >= Just unify) $ do+      put (M.insert (τ1', τ2') unify seen)+      decomp τ1' τ2'+  --+  decomp τ1 τ2 = case (τ1, τ2) of+    (TyVar v1, TyVar v2)+      | v1 == v2 → return ()+    (TyVar (Free r1), TyVar (Free r2))+      | tvFlavorIs Universal r1, tvFlavorIs Universal r2 →+      if unify+        then unifyVar r1 (fvTy r2)+        else do+          lift (makeEquivTVs r1 r2)+          addEdge r1 r2+    (TyVar (Free r1), _)+      | tvFlavorIs Universal r1 →+      occursCheck r1 τ2 decomp $ \τ2'' → do+      τ2' ← if unify then return τ2'' else copyType τ2''+      unifyVar r1 τ2'+      unless unify (check τ2' τ2)+    (_, TyVar (Free r2))+      | tvFlavorIs Universal r2 → do+      occursCheck r2 τ1 (flip decomp) $ \τ1'' → do+      τ1' ← if unify then return τ1'' else copyType τ1''+      unifyVar r2 τ1'+      unless unify (check τ1 τ1')+    (TyQu Forall αs1 τ1', TyQu Forall αs2 τ2')+      | if unify+          then αs1 == αs2+          else length αs1 == length αs2+            && and (zipWith ((⊒)`on`snd) αs1 αs2) →+      check τ1' τ2'+    (TyQu Exists αs1 τ1', TyQu Exists αs2 τ2')+      | αs1 == αs2 →+      check τ1' τ2'+    (TyApp tc1 τs1, TyApp tc2 τs2)+      | tc1 == tc2 && tc1 /= tcRowMap && length τs1 == length τs2 →+      sequence_+        [ if unify+            then if isQVariance var+              then τ1' ~: τ2'+              else check τ1' τ2'+            else relateTypes var τ1' τ2'+        | var ← tcArity tc1+        | τ1' ← τs1+        | τ2' ← τs2 ]+    (TyRow n1 τ11 τ12, TyRow n2 τ21 τ22)+      | n1 == n2 → do+        check τ11 τ21+        check τ12 τ22+      | otherwise   → do+        α ← newTVTy+        check (TyRow n1 τ11 α) τ22+        β ← newTVTy+        check τ12 (TyRow n2 τ21 β)+        check α β+    (TyMu _ τ1', _) →+      decomp (openTy 0 [τ1] τ1') τ2+    (_, TyMu _ τ2') →+      decomp τ1 (openTy 0 [τ2] τ2')+    _ | Just (τ1', τ2') ← matchReduce τ1 τ2 →+      check τ1' τ2'+    (TyApp tc1 [τ11, τ12], TyApp tc2 [τ21, τ22])+      | tc1 == tcRowMap && tc2 == tcRowMap → do+        check τ11 τ21+        check τ12 τ22+    _ | otherwise →+      tErrExp+        (if unify+           then [msg| Cannot unify: |]+           else [msg| Cannot subtype: |])+        (pprMsg τ1)+        (pprMsg τ2)+  --+  addEdge a1 a2 = do+    Gr.insNewMapNodeM a1+    Gr.insNewMapNodeM a2+    Gr.insMapEdgeM (a1, a2, ())+    lift (fvTy a1 ⊏: fvTy a2)++-- | Relate two types at the given variance.+relateTypes ∷ MonadSubst tv r m ⇒+              Variance → Type tv → Type tv → SeenT tv r m ()+relateTypes var = case var of+  Invariant     → subtypeTypes True+  Covariant     → subtypeTypes False+  Contravariant → flip (subtypeTypes False)+  QInvariant    → (~:)+  QCovariant    → (⊏:)+  QContravariant→ flip (⊏:)+  Omnivariant   → \_ _ → return ()++-- | Copy a type while replacing all the type variables with fresh ones+--   of the same kind.+copyType ∷ MonadSubst tv r m ⇒ Type tv → m (Type tv)+copyType =+   foldTypeM (mkQuF (return <$$$> TyQu))+             (mkBvF (return <$$$> bvTy))+             fvar+             fcon+             (return <$$$> TyRow)+             (mkMuF (return <$$> TyMu))+  where+    fvar α | tvFlavorIs Universal α = newTVTy' (tvKind α)+           | otherwise              = return (fvTy α)+    -- Nullary type constructors that are involved in the atomic subtype+    -- relation are converted to type variables:+    fcon tc τs+      = TyApp tc <$> sequence+          [ -- A Q-variant type constructor parameter becomes a single+            -- type variable:+            if isQVariance var+              then newTVTy' KdQual+              else return τ+          | τ   ← τs+          | var ← tcArity tc ]++-- | Unify a type variable with a type, where the type must be locally+--   closed.+--   ASSUMPTIONS: @α@ has not been substituted and the occurs check has+--   already passed.+unifyVar ∷ MonadSubst tv r m ⇒ tv → Type tv → SeenT tv r m ()+unifyVar α τ0 = do+  lift $ gtraceN 4 ("unifyVar", α, τ0)+  τ ← subst τ0+  tassert (lcTy 0 τ)+    [msg|+      Cannot unify because a $τ is insufficiently polymorphic+    |]+  writeTV α τ+  lift (updatePinnedTVs α τ)+  (n, _) ← Gr.mkNodeM α+  gr     ← Gr.getGraph+  case Gr.match n gr of+    (Nothing,                 _)   → return ()+    (Just (pres, _, _, sucs), gr') → do+      Gr.putGraph gr'+      sequence_ $+        [ case Gr.lab gr' n' of+            Nothing → return ()+            Just a  → subtypeTypes False (fvTy a) τ+        | (_, n') ← pres ]+        +++        [ case Gr.lab gr' n' of+            Nothing → return ()+            Just a  → subtypeTypes False τ (fvTy a)+        | (_, n') ← sucs ]++--- OCCURS CHECK++-- | Performs the occurs check and returns a type suitable for unifying+--   with the given type variable, if possible.  This does the subtyping+--   occurs check, which checks not in terms of type variables but in+--   terms of same-size equivalence classes of type variables.+--   Unification is possible if all occurrences of type variables+--   size-equivalent to @α@ appear guarded by a type constructor that+--   permits recursion, in which case we roll up @τ@ as a recursive type+--   and return that.+occursCheck ∷ MonadSubst tv r m ⇒+              tv → Type tv →+              (Type tv → Type tv → SeenT tv r m ()) →+              (Type tv → SeenT tv r m ()) →+              SeenT tv r m ()+occursCheck α τ0 kv kt = do+  lift (gtraceN 3 ("occursCheck", α, τ0))+  loop S.empty τ0+  where+  loop seen τ = do+    let (guarded, unguarded) = (M.keys***M.keys) . M.partition id $ ftvG τ+    apparentCycle ← lift $ anyA (checkEquivTVs α) unguarded+    if apparentCycle+      then case headReduceType τ of+        Next τ'@(TyVar (Free _)) → kv (fvTy α) τ'+        Next τ' | τ' ∉ seen      → loop (S.insert τ' seen) τ'+        _ →+          -- | This type error has to throw because continuing will+          --   likely cause the type checker to diverge.+          typeError' [msg|+            Occurs check failed.+            Cannot construct an infinite type when unifying:+            <dl>+              <dt>type variable <dd>$α+              <dt>type          <dd>$τ0+            </dl>+          |]+      else do+        recVars ← lift $ filterM (checkEquivTVs α) guarded+        unless (null recVars) $+          lift (gtraceN 3 ("occursCheck", "recvars", recVars))+        kt (foldr closeRec τ recVars)++-- | Records that two type variables have the same size.+makeEquivTVs  ∷ MonadSubst tv r m ⇒ tv → tv → ConstraintT_ tv r m ()+makeEquivTVs α β = do+  pα ← getTVProxy α+  pβ ← getTVProxy β+  UF.coalesce_ (return <$$> S.union) pα pβ++-- | Checks whether two type variables have the same size.+checkEquivTVs ∷ MonadSubst tv r m ⇒ tv → tv → ConstraintT_ tv r m Bool+checkEquivTVs α β = do+  pα ← getTVProxy α+  pβ ← getTVProxy β+  UF.sameRepr pα pβ++-- | Clears all size-equivalence classes and rebuilds them based on the+--   current atomic subtyping constraint graph.+resetEquivTVs ∷ MonadSubst tv r m ⇒ ConstraintT_ tv r m ()+resetEquivTVs = do+  ConstraintT_ (modify (csEquivsUpdate (const M.empty)))+  g     ← Gr.getGraph+  mapM_ (uncurry makeEquivTVs)+        [ (α, β) | (α, β) ← Gr.labNodeEdges g ]++-- | Helper to get the proxy the represents the size-equivalence class+--   of a type variable.+getTVProxy ∷ MonadSubst tv r m ⇒ tv → ConstraintT_ tv r m (TVProxy tv r)+getTVProxy α = do+  equivs ← ConstraintT_ (gets csEquivs)+  case M.lookup α equivs of+    Just pα → return pα+    Nothing → do+      pα ← UF.create (S.singleton α)+      ConstraintT_ (modify (csEquivsUpdate (M.insert α pα)))+      return pα++--- CONSTRAINT SOLVING++-- | Solve a constraint as much as possible, returning the type+--   variables to generalize and their qualifier bounds.+solveConstraint ∷ MonadSubst tv r m ⇒+                  Bool → Rank → Type tv → ConstraintT_ tv r m [(tv, QLit)]+solveConstraint value γrank τ0 = do+  τ ← subst τ0+  let τftv = ftvV τ+  gtraceN 2 (TraceIn ("gen", "begin", value, γrank, τftv, τ))+  τftv ← coalesceSCCs τftv+  gtraceN 3 ("gen", "scc", τftv, τ)+  Gr.modifyGraph Gr.trcnr+  gtraceN 4 ("gen", "trc", τftv, τ)+  eliminateExistentials True (γrank, τftv)+  gtraceN 3 ("gen", "existentials 1", τftv, τ)+  untransitive+  gtraceN 3 ("gen", "untrans", τftv, τ)+  eliminateExistentials False (γrank, τftv)+  gtraceN 3 ("gen", "existentials 2", τftv, τ)+  τftv ← polarizedReduce τftv+  gtraceN 3 ("gen", "polarized", τftv, τ)+  eliminateExistentials False (γrank, τftv)+  gtraceN 3 ("gen", "existentials 3", τftv, τ)+  -- Guessing starts here+  τftv ← coalesceComponents value (γrank, τftv)+  gtraceN 3 ("gen", "components", τftv, τ)+  -- Guessing ends here+  qc    ← ConstraintT_ $ gets csQuals >>= mapM subst+  cftv  ← S.fromList . map snd <$> Gr.getsGraph Gr.labNodes+  αs    ← S.fromDistinctAscList <$>+            filter (tvFlavorIs Universal) <$>+              (removeByRank γrank+                (S.toAscList $ (ftvSet qc `S.union` M.keysSet τftv) S.\\ cftv))+  (qc, αqs, τ) ← solveQualifiers value αs qc τ+  ConstraintT_ (modify (csQualsUpdate (const qc)))+  gtraceN 2 (TraceOut ("gen", "finished", αqs, τ))+  resetEquivTVs+  return αqs+  where+    --+    -- Eliminate existentially-quantified type variables from the+    -- constraint+    eliminateExistentials trans (γrank, τftv) = do+      extvs ← getExistentials (γrank, τftv)+      traceN 4 ("existentials:", extvs)+      mapM (eliminateNode trans) (S.toList extvs)+    -- Get the existential type variables+    getExistentials (γrank, τftv) = do+      lnodes ← Gr.getsGraph Gr.labNodes+      cftv   ← removeByRank γrank [ α | (_, α) ← lnodes ]+      return (S.fromList cftv S.\\ M.keysSet τftv)+    -- Remove a node unless it is necessary to associate some of its+    -- neighbors -- in particular, a node with multiple predecessors+    -- but no successor (or dually, multiple successors but no+    -- predecessor) should not be removed.+    eliminateNode trans α = do+      (nm, g) ← Gr.getNMState+      let node = Gr.nmLab nm α+      case (Gr.pre g node, Gr.suc g node) of+        (_:_:_, []) → return ()+        ([], _:_:_) → return ()+        (pre, suc)  → do+          β ← newTVTy' KdQual+          writeTV α β+          traceN 4 ("eliminateNode",+                    catMaybes (map (Gr.lab g) pre),+                    β,+                    catMaybes (map (Gr.lab g) suc))+          Gr.putGraph $+            let g' = Gr.delNode node g in+            if trans+              then g'+              else foldr ($) g'+                     [ Gr.insEdge (n1, n2, ())+                     | n1 ← pre+                     , n2 ← suc ]+    --+    -- Remove redundant edges:+    --  • Edges implied by transitivity+    untransitive = Gr.modifyGraph Gr.untransitive+    --+    -- Remove type variables based on polarity-related rules:+    --  • Coalesce positive type variables with a single predecessor+    --    and negative type variables with a single successor+    --  • Coalesce positive type variables that share all their+    --    predecessors and negative type variables that share all+    --    their successors.+    polarizedReduce = iterChanging $ \τftv → do+      nm ← Gr.getNodeMap+      foldM tryRemove τftv (findPolar nm τftv)+        where+        tryRemove τftv (n, α, var) = do+          let ln = (n, α)+          mτ ← readTV α+          g  ← Gr.getGraph+          case (mτ, Gr.gelem n g) of+            (Left _, True) →+              case (var, Gr.pre g n, Gr.suc g n) of+                -- Should we consider QCo(ntra)variance here too?+                (Covariant,     [pre], _)+                  → snd <$> coalesce ln (Gr.labelNode g pre) τftv+                (Contravariant, _,     [suc])+                  → snd <$> coalesce ln (Gr.labelNode g suc) τftv+                (Covariant,     pres,  _)+                  → siblings g τftv (ln,  1) pres (Gr.pre,Gr.suc)+                (Contravariant, _,     sucs)+                  → siblings g τftv (ln, -1) sucs (Gr.suc,Gr.pre)+                _ → return τftv+            _ → return τftv+        findPolar nm τftv = [ (Gr.nmLab nm α, α, var)+                            | (α, var) ← M.toList τftv+                            , var == 1 || var == -1 ]+        siblings g τftv (lnode@(n,_), var) pres (gpre, gsuc) = do+          lnodes ← liftM ordNub . runListT $ do+            pre ← ListT (return pres)+            sib ← ListT (return (gsuc g pre))+            guard $ sib /= n+            Just β ← return (Gr.lab g sib)+            guard $ M.lookup β τftv == Just var+            guard $ gpre g sib == pres+            return (sib, β)+          case lnodes of+            _:_ → do+                τftv' ← snd <$> coalesceList τftv (lnode:lnodes)+                return τftv'+            _   → return τftv+    --+    -- Coalesce the strongly-connected components to single atoms+    coalesceSCCs τftv = do+      foldM (liftM snd <$$> coalesceList) τftv =<< Gr.getsGraph Gr.labScc +    -- Given a list of atoms, coalesce them to one atom+    coalesceList τftv0 (ln:lns) =+      foldM (\(ln1, state) ln2 → coalesce ln1 ln2 state) (ln, τftv0) lns+    coalesceList _      [] = typeBug "coalesceList" "Got []"+    -- Assign n2 to n1, updating the graph, type variables, and ftvs,+    -- and return whichever node survives+    -- PRECONDITION: α1 /= α2+    coalesce (n1, α1) (n2, α2) τftv = do+      τftv' ← assignTV α1 α2 τftv+      assignNode n1 n2+      return ((n2, α2), τftv')+    -- Update the graph to remove node n1, assigning all of its+    -- neighbors to n2+    assignNode n1 n2 = Gr.modifyGraph $ \g →+      Gr.insEdges [ (n', n2, ())+                  | n' ← Gr.pre g n1, n' /= n1, n' /= n2 ] $+      Gr.insEdges [ (n2, n', ())+                  | n' ← Gr.suc g n1, n' /= n1, n' /= n2 ] $+      Gr.delNode n1 g+    -- Update the type variables to assign β to α, updating the+    -- ftvs appropriately+    assignTV α β τftv = do+      writeTV α (fvTy β)+      updatePinnedTVs α (fvTy β)+      assignFtvMap α β τftv+    -- Given two type variables, where α ← β, update a map of free+    -- type variables to variance lists accordingly+    assignFtvMap α β vmap =+      case M.lookup α vmap of+        Just vs → return $ M.insertWith (+) β vs vmap'+        Nothing → return vmap+      where vmap' = M.delete α vmap+    -- Coalesce and remove fully-generalizable components+    coalesceComponents value (γrank, τftv) = do+      extvs  ← getExistentials (γrank, τftv)+      τcands ← genCandidates value τftv γrank+      let candidates = extvs `S.union` τcands+          each τftv component@(_:_)+            | all (`S.member` candidates) (map snd component)+            = do+                ((node, _), τftv')+                  ← coalesceList τftv component+                Gr.getGraph >>= Gr.putGraph . Gr.delNode node+                return τftv'+          each τftv _+            = return τftv+      foldM each τftv =<< Gr.getsGraph Gr.labComponents+    -- Find the generalization candidates, which are free in τ but+    -- not in γ (restricted further if not a value)+    genCandidates value τftv γrank =+      S.fromDistinctAscList <$>+        removeByRank γrank (map fst (M.toAscList (restrict τftv)))+        where+        restrict = if value+                     then id+                     else M.filter (`elem` [1, -1, 2, -2])++---+--- QUALIFIER CONSTRAINT SOLVING+---++{-++Syntactic metavariables:++ γ:  any type variable+ α:  generalization candidates+ β:  type variables with Q-variance+ δ:  generalization candidates with Q-variance+ q:  qualifier literals+ _s: a collection of _++ qe  ::=  q  |  γs  |  q γs     (qualifier expressions)++First rewrite as follows:++(DECOMPOSE)+  γs₁ \ γs₂ = γ₁ ... γⱼ+  βs  = { γ ∈ γs₂ | γ is Q-variant }+  βsᵢ = if γᵢ is Q-variant then γs₂ else βs+  -----------------------------------------------------------------------+  q₁ γs₁ ⊑ q₂ γs₂  --->  q₁ \-\ q₂ ⊑ βs ⋀ γ₁ ⊑ q₁ βs₁ ⋀ ... ⋀ γⱼ ⊑ q₁ βsᵢ++(BOT-SAT)+  ---------------+  U ⊑ βs  --->  ⊤++(TOP-SAT)+  -----------------+  γ ⊑ A βs  --->  ⊤++(BOT-UNSAT)+  q ≠ U+  -----------------+  q ⊑ U  --->  fail++(COMBINE-QLIT)+  --------------------------------------------+  γ ⊑ q ⋀ γ ⊑ q' ⋀ C; τ  --->  γ ⊑ q⊓q' ⋀ C; τ++(COMBINE-LE)+  q ⊑ q'   βs ⊆ βs'+  ---------------------------------------------------+  γ ⊑ q βs ⋀ γ ⊑ q' βs' ⋀ C; τ  --->  γ ⊑ q βs ⋀ C; τ++Then we have a constraint where each inequality is in one of two forms:++  γ ⊑ q βs+  q ⊑ βs++Now we continue to rewrite and perform substitutions as well.  Continue+to apply the above rules when they apply.  These new rewrites apply to a+whole constraint and type together, not to single atomic constraints.++For a type variable γ and type τ, let V(γ,τ) be γ's variance in τ.  We+also refer to the free type variables in only the lower or upper bounds+of a constraint C as lftv(C) and uftv(C), respectively.++These are non-lossy rewrites. Repeat them as much as possible,+continuing to apply the rewrites above when applicable:++(FORCE-U)+  -------------------------------+  β ⊑ U ⋀ C; τ  --->  [U/β](C; τ)++(SUBST-NEG)+  δ ∉ lftv(C)   V(δ,τ) ⊑ Q-+  ---------------------------------+  δ ⊑ qe ⋀ C; τ  --->  [qe/δ](C; τ)++(SUBST-NEG-TOP)+  δ ∉ lftv(C)   V(δ,τ) ⊑ Q-+  -------------------------+  C; τ  --->  [A/δ](C; τ)++(SUBST-POS)+  δ ∉ uftv(C)   V(δ,τ) ⊑ Q++  -----------------------------------------------------------+  qe₁ ⊑ δ ⋀ ... ⋀ qeⱼ ⊑ δ ⋀ C; τ  --->  [qe₁⊔...⊔qeⱼ/δ](C; τ)++(SUBST-INV)+  δ ∉ uftv(C)   V(δ,τ) = Q=   δ' fresh+  --------------------------------------------------------------+  qe₀ ⊑ δ ⋀ ... ⋀ qeⱼ ⊑ δ ⋀ C; τ  --->  [δ'⊔qe₀⊔...⊔qeⱼ/δ](C; τ)++Substitute for contravariant qualifier variables by adding these lossy+rewrites:++(SUBST-NEG-LOSSY)+  δ ∉ lftv(C)   V(δ,τ) = Q-+  -----------------------------------------------+  δ ⊑ q₁ βs₁ ⋀ ... ⋀ δ ⊑ qⱼ βsⱼ ⋀ C; τ+    --->  [(q₁⊓...⊓qⱼ) (βs₁ ∩ ... ∩ βsⱼ)/δ](C; τ)++Run SAT as below for anything we missed.  Then, add bounds:++(BOUND)+  α ∉ lftv(C)   V(α,τ) ∈ { -, +, =, Q= }   q = q₁⊓...⊓qⱼ+  ------------------------------------------------------+  α ⊑ q₁ βs₁ ⋀ ... ⋀ α ⊑ qⱼ βsⱼ ⋀ C; τ+    ---> [U/α]C; ∀α:q. τ+++We convert it to SAT as follows:++  Define:++    πa(Q) = A ⊑ Q+    πa(β) = 2 * tvId β + 1+    πa(q1 ⊔ q2) = πa(q1) ⋁ πa(q2)+    πa(q1 ⊓ q2) = πa(q1) ⋀ πa(q2)++    Then given the constraint++      q1 ⊑ q1' ⋀ ... ⋀ qk ⊑ qk'++    generate the formula:++      (πa(q1) ⇒ πa(q1'))+        ⋀ ... ⋀+      (πa(qk) ⇒ πa(qk'))++-}++-- | Represents the meet of several qualifier expressions, which happens+--   when some variable has multiple upper bounds.  These are normalized+--   to implement COMBINE-QLIT and COMBINE-LE.+newtype QEMeet tv = QEMeet { unQEMeet ∷ [S.Set tv] }++instance Bounded (QEMeet tv) where+  minBound = QEMeet [S.empty]+  maxBound = QEMeet []++instance Tv tv ⇒ Ppr.Ppr (QEMeet tv) where+  ppr (QEMeet [])   = Ppr.char 'A'+  ppr (QEMeet [qe]) = Ppr.ppr (QeU qe)+  ppr (QEMeet qem)  =+    Ppr.prec Ppr.precCaret $+      Ppr.fsep (Ppr.punctuate (Ppr.text " ⋀")+                              (Ppr.ppr <$> QeU <$> qem))++instance Tv tv ⇒ Show (QEMeet tv) where showsPrec = Ppr.showFromPpr++instance Ord tv ⇒ Ftv (QEMeet tv) tv where+  ftvTree = FTBranch . map FTSingle . S.toList . ftvSet+  ftvSet  = S.unions . unQEMeet++instance Ord tv ⇒ Monoid (QEMeet tv) where+  mempty  = maxBound+  mappend = foldr (qemInsert . QeU) <$.> unQEMeet++qemSingleton ∷ QExp tv → QEMeet tv+qemSingleton QeA      = maxBound+qemSingleton (QeU αs) = QEMeet [αs]++qemInsert ∷ Ord tv ⇒ QExp tv → QEMeet tv → QEMeet tv+qemInsert qe (QEMeet qem) = QEMeet (loop qe qem) where+  loop QeA      qem = qem+  loop (QeU αs) qem = loopU αs qem+  loopU αs      []       = [αs]+  loopU αs      (βs:qem)+    | αs `S.isSubsetOf` βs = loopU αs qem+    | βs `S.isSubsetOf` αs = βs:qem+    | otherwise            = βs:loopU αs qem++-- | State of the qualifier constraint solver+data QCState tv+  = QCState {+      -- | Generalization candidates, which are type variables that+      --   appear in the qualifier constraint or type-to-be-generalized,+      --   but not in the shape constraint or environment+      sq_αs    ∷ !(S.Set tv),+      -- | The current type to be generalized+      sq_τ     ∷ !(Type tv),+      -- | Free type variables and variances in the type-to-be-generalized.+      sq_τftv  ∷ !(VarMap tv),+      -- | Part of the qualifier constraint: joins of type variables+      --   lower-bounded by qualifier literals.+      sq_βlst  ∷ ![(QLit, S.Set tv)],+      -- | Part of the qualifier constraint: type variables+      --   upper-bounded by (meets of) qualifier expressions.+      sq_vmap  ∷ !(M.Map tv (QEMeet tv))+    }+  deriving Show++-- | The empty qualifier constraint+qcState0 ∷ QCState tv+qcState0 = QCState S.empty tyUnit M.empty mempty M.empty++instance Tv tv ⇒ Ppr.Ppr (QCState tv) where+  ppr sq = p . M.fromList $+    [ ("αs",    p (sq_αs sq))+    , ("τ",     p (sq_τ sq))+    , ("τftv",  p (sq_τftv sq))+    , ("βlst",  Ppr.fsep . Ppr.punctuate (Ppr.text " ⋀") $+                  [ p ql Ppr.<> Ppr.char '⊑' Ppr.<>+                    Ppr.hcat (Ppr.punctuate (Ppr.char '⊔')+                                (p <$> S.toList tvs))+                  | (ql, tvs) ← sq_βlst sq ])+    , ("vmap",  Ppr.fsep . Ppr.punctuate (Ppr.text " ⋀") $+                  [ p α Ppr.<> Ppr.char '⊑' Ppr.<> p qe+                  | (α, qem) ← M.toList (sq_vmap sq)+                  , qe       ← unQEMeet qem ])+    ]+    where p x = Ppr.ppr x++---+--- MAIN QUALIFIER CONSTRAINT OPERATIONS+---++-- | Add a qualifier subtyping constraint+addQualConstraint ∷ (MonadSubst tv r m, Qualifier q1 tv, Qualifier q2 tv) ⇒+                    q1 → q2 → ConstraintT_ tv r m ()+addQualConstraint q1 q2 = do+  q1' ← simplifyQual q1+  q2' ← simplifyQual q2+  tassert (q1' /= qlitexp Qa || q2' /= qlitexp Qu)+    [msg| Qualifier inequality unsatisfiable:  Attempted to use an+          affine type where only an unlimited type is permitted. |]+  let qe1 = mapQExp (S.mapMonotonic Free) q1'+      qe2 = mapQExp (S.mapMonotonic Free) q2'+  unless (q1' ⊑ q2') $+    ConstraintT_ . modify . csQualsUpdate $+      ((qualToType qe1, qualToType qe2) :)++-- Find qualifier bounds for type variables that definitely have only+-- upper bounds.+solveBounds    ∷ MonadSubst tv r m ⇒+                 [tv] → ConstraintT_ tv r m [QLit]+solveBounds αs = do+  qc            ← ConstraintT_ (gets csQuals)+  state         ← decomposeQuals qc qcState0+  traceN 4 ("solveBounds", "decompose", state)+  let vmap      = sq_vmap state+  ConstraintT_ . modify . csQualsUpdate . const $+    recomposeQuals state { sq_vmap = foldl' (flip M.delete) vmap αs }+  return [ case M.lookup α vmap of+             Just (QEMeet (_:_)) → Qu+             _                   → Qa+         | α ← αs ]++-- Ensure that the qualifier constraint is satisfiable, but don't+-- make any approximating assumptions toward solving the constraint.+checkQualifiers ∷ MonadSubst tv r m ⇒ ConstraintT_ tv r m ()+checkQualifiers = do+  qc            ← ConstraintT_ (gets csQuals)+  state         ← decomposeQuals qc qcState0+  traceN 4 ("checkQualifiers", "decompose", state)+  runSat state False+  ConstraintT_ . modify . csQualsUpdate . const $ recomposeQuals state++-- | Solver for qualifier contraints.+--   Given a qualifier constraint, solve and produce type variable+--   bounds.  Also return any remaining inequalities (which must be+--   satisfiable, but we haven't guessed how to satisfy them yet).+solveQualifiers+  ∷ MonadConstraint tv r m ⇒+    -- | Are we generalizing the type of a non-expansive term?+    Bool →+    -- | Generalization candidates+    S.Set tv →+    -- | The constraint as pairs of types in the subqualifier relation+    [(Type tv, Type tv)] →+    -- | The type to be generalized+    Type tv →+    m ([(Type tv, Type tv)], [(tv, QLit)], Type tv)+solveQualifiers value αs qc τ = do+  traceN 3 (TraceIn ("solveQ", "init", αs, qc))+  -- Decompose implements DECOMPOSE, TOP-SAT, BOT-SAT, and BOT-UNSAT.+  τftv           ← ftvV <$> subst τ+  state          ← decomposeQuals qc qcState0 {+                     sq_αs   = αs,+                     sq_τftv = τftv,+                     sq_τ    = τ+                   }+  traceN 4 ("solveQ", "decompose", state)+  -- Rewrite until it stops changing+  state          ← iterChanging+                     (stdizeType        >=>+                      forceU            >=>+                      substNeg False    >=>!+                      substPosInv       >=>!+                      substNeg True)+                     state+  traceN 4 ("solveQ", "rewrites", state)+  -- Try the SAT solver, then recheck+  state          ← runSat state True+  traceN 4 ("solveQ", "sat", state)+  runSat state False+  -- Finish by reconstructing the constraint and returning the bounds+  -- for the variables to quantify.+  state          ← genVars state+  traceN 3 (TraceOut ("solveQ", "done", state))+  return (recomposeQuals state, getBounds state, τ)+  where+  --+  -- Standardize the qualifiers in the type+  stdizeType state = do+    τ    ← subst τ+    let meet (QEMeet [αs])+          | S.null αs      = Qu+        meet _             = Qa+        qm   = meet <$> sq_vmap state+        τ'   = standardizeQuals qm τ+        τftv = ftvV τ'+    traceN 5 ("stdizeType", τ, τ', qm)+    return state {+             sq_τ    = τ',+             sq_τftv = τftv+           }+  --+  -- Substitute U for qualifier variables upper bounded by U (FORCE-U).+  forceU state =+    qSubsts "forceU" state $+      minBound <$+        M.filterWithKey+          (\β qem → case qem of+            QEMeet [γs] → qUnifiable state β && S.null γs+            _           → False)+          (sq_vmap state)+  --+  -- Replace Q- and 0-variant variables by a single upper bound, if they+  -- have only one (SUBST-NEG), or by A if they have none (SUBST-NEG-TOP).+  -- If 'doLossy', then we include SUBST-NEG-LOSSY as well, which uses+  -- approximate lower bounds for combining multiple upper bounds.+  substNeg doLossy state =+    qSubsts who state $ M.fromDistinctAscList $ do+      δ ← S.toAscList (sq_αs state)+      guard (qUnifiable state δ+             && M.lookup δ (sq_τftv state) ⊑ Just QContravariant)+      case M.lookup δ (sq_vmap state) of+        Nothing            → return (δ, maxBound)+        Just (QEMeet [])   → return (δ, maxBound)+        Just (QEMeet [qe]) → return (δ, QeU qe)+        Just (QEMeet qes)+          | doLossy        → return (δ, bigMeet (QeU <$> qes))+          | otherwise      → mzero+    where who = if doLossy then "substNeg/lossy" else "substNeg"+  --+  -- Replace Q+ and Q= variables with tight lower bounds.+  substPosInv state = do+    let add qe (S.toList → [β])+          | β `S.member` sq_αs state+          = M.insertWith (liftA2 (⊔)) β (Just qe)+        add _  βs+          = M.union (setToMap Nothing βs)+        -- For each (γ ⊑ meet) in the state, make γ ⊑ each qe in the meet+        add_vmap = M.foldrWithKey each <-> (sq_vmap state) where+          each γ (QEMeet qem) = foldr (add (qvarexp γ)) <-> qem+        -- for each (q ⊑ βs) in the state, make q ⊑ βs+        add_βlst = foldr each <-> sq_βlst state where+          each (q, βs) = add (qlitexp q) βs+        -- The lower bounds+        lbs = M.mapMaybe id . add_βlst . add_vmap+            $ setToMap (Just minBound)+                       (S.filter (qUnifiable state) (sq_αs state))+                M.\\ sq_vmap state+        -- Positive variables with lower bounds+        pos  = lbs M.\\ M.filter (/= QCovariant) (sq_τftv state)+        -- Invariant variables with lower bounds+        inv  = lbs `M.intersection`+                 M.filter (== QInvariant) (sq_τftv state)+    (δ's, inv) ← first S.fromDistinctAscList . unzip <$> sequence+      [ do+          δ' ← newTV' KdQual+          return (δ', (δ, S.insert δ' `mapQExp` qe))+      | (δ, qe) ← M.toAscList inv+      , qe /= minBound ]+    qSubsts "substPosInv"+            state {+              sq_αs = sq_αs state `S.union` δ's+            }+            (pos `M.union` M.fromDistinctAscList inv)+  --+  -- Find the variables to generalize+  genVars state = return state { sq_αs = αs' } where+    αs'  = sq_αs state `S.intersection` kset+    kset = M.keysSet (keep (sq_τftv state))+    keep = if value then id else M.filter (`elem` [-2,-1,1,2])+  --+  -- Find the the bounds of variables to generalize+  getBounds state =+    map (id &&& getBound) (S.toList (sq_αs state)) where+      getBound α = maybe maxBound qeMeetQLit (M.lookup α (sq_vmap state))+  --+  -- The QLit lower bound of a QExp+  qeMeetQLit (QEMeet []) = maxBound+  qeMeetQLit _           = minBound++---+--- COMMON QUALIFIER CONSTRAINT HELPERS+---++-- Put a set of qualifier inequalities in decomposed form (given+-- possibly some in decomposed form already.+decomposeQuals ∷ MonadSubst tv r m ⇒+                 [(Type tv, Type tv)] →+                 QCState tv →+                 m (QCState tv)+decomposeQuals qc0 state0 = do+  qc             ← stdize qc0+  traceN 4 ("decomposeQuals", "stdize", qc)+  decompose state0 qc+  where+  --+  -- Given a list of qualifier inequalities on types, produce a list of+  -- inequalities on standard-form qualifiers, omitting trivial+  -- inequalities along the way.+  stdize qc = mapM each qc where+    each (τl, τh) = do+      qe1 ← simplifyQual τl+      qe2 ← simplifyQual τh+      return (qe1, qe2)+  --+  -- Given a list of inequalities on qualifiers, rewrite them into+  -- the two decomposed forms:+  --+  --  • γ ⊑ q βs+  --+  --  • q ⊑ βs+  --+  -- This implements DECOMPOSE, BOT-SAT, TOP-SAT, and BOT-UNSAT.+  decompose = foldM each where+    each state (_,       QeA)     = return state -- (TOP-SAT)+    each state (QeA,     QeU γs2) = each' state (Qa, S.empty) γs2+    each state (QeU γs1, QeU γs2) = each' state (Qu, γs1)     γs2+    each' state (q1, γs1) γs2 = do+      let γs'  = γs1 S.\\ γs2+          βs'  = S.filter flex γs2+          flex = (||) <$> qUnifiable state <*> (`S.notMember` sq_αs state)+      fβlst ← case q1 of+        -- (BOT-SAT)+        Qu → return id+        -- (BOT-UNSAT)+        _  | S.null βs' → do+               tErrExp_+                 [msg| Qualifier inequality unsatisfiable. |]+                 (pprMsg q1)+                 (pprMsg (QeU γs2))+               return id+           | otherwise →+               return ((q1, βs') :)+      let fvmap = M.unionWith mappend (setToMapWith bound γs')+          bound γ+            | M.lookup γ (sq_τftv state) == Just Covariant+            , γ `S.member` sq_αs state+                                 = qemSingleton maxBound+            | qUnifiable state γ = qemSingleton (QeU γs2)+            | otherwise          = qemSingleton (QeU βs')+      return state {+               sq_βlst = fβlst (sq_βlst state),+               sq_vmap = fvmap (sq_vmap state)+             }++-- | Turn the decomposed constraint back into a list of pairs of types.+recomposeQuals ∷ Ord tv ⇒ QCState tv → [(Type tv, Type tv)]+recomposeQuals state =+    [ (fvTy γ, clean βs)+    | (γ, QEMeet qem) ← M.toList (sq_vmap state)+    , γ `S.notMember` sq_αs state+    , βs ← qem ]+  +++    [ (qualToType ql, clean βs)+    | (ql, βs) ← sq_βlst state ]+  where+  clean βs = qualToType (βs S.\\ sq_αs state)++-- | Given a list of type variables and qualifiers, substitute for each,+--   updating the state as necessary.+qSubsts ∷ MonadConstraint tv r m ⇒+          String → QCState tv → M.Map tv (QExp tv) → m (QCState tv)+qSubsts who state γqes0+  | M.null γqes0 = return state+  | otherwise      = do+  traceN 4 (who, γqes0, state)+  let sanitize _    []  []+        = typeBug "subst" $+            "Attempted impossible substitution: " ++ show γqes0+      sanitize _    acc []+        = unsafeSubsts state (M.fromDistinctAscList (reverse acc))+      sanitize seen acc ((γ, qe):rest)+        | S.member γ (S.union seen (ftvSet qe))+        = sanitize seen acc rest+        | otherwise+        = sanitize (seen `S.union` ftvSet qe) ((γ, qe):acc) rest+  sanitize S.empty [] (M.toAscList γqes0)+  where+  --+  -- This does the main work of substitution, and it has a funny+  -- precondition (which is enforced by 'subst', above), namely:+  -- the type variables will be substituted in increasing order, so the+  -- image of later variables must not contain earlier variables.+  --+  -- This is okay:     { 1 ↦ 2 3, 2 ↦ 4 }+  -- This is not okay: { 1 ↦ 3 4, 2 ↦ 1 }+  unsafeSubsts state γqes = do+    sequence [ do+                 let τ = qualToType (liftVQExp qe)+                 writeTV γ τ+                 updatePinnedTVs γ τ+             | (γ, qe) ← M.toList γqes ]+    let γset          = M.keysSet γqes+        unchanged set = S.null (γset `S.intersection` set)+        (βlst, βlst') = List.partition (unchanged . snd) (sq_βlst state)+        (vmap, vmap') = M.partitionWithKey+                          (curry (unchanged . ftvSet))+                          (sq_vmap state)+    let ineqs =+          [ (qualToType ql, qualToType βs)+          | (ql, βs) ← βlst' ]+            +++          [ (fvTy γ, qualToType qe)+          | (γ, qem) ← M.toList vmap'+          , qe       ← unQEMeet qem ]+    state ← decomposeQuals ineqs+      state {+        sq_αs   = sq_αs state S.\\ γset,+        sq_τftv = M.foldrWithKey substQE (sq_τftv state) γqes,+        sq_βlst = βlst,+        sq_vmap = vmap+      }+    traceN 4 ("subst", γqes, state)+    return state++-- | Substitute and simplify a qualifier expression+simplifyQual ∷ (MonadSubst tv r m, Qualifier q tv) ⇒+               q → m (QExp tv)+simplifyQual q = do+  qe ← qualifier <$> subst (qualToType q)+  case qe of+    QeA    → return QeA+    QeU γs → do+      (γs', qls) ← partitionJust tvQual <$> mapM fromTyVar (S.toAscList γs)+      case bigJoin qls of+        Qa      → return QeA+        _       → return (QeU (S.fromDistinctAscList γs'))++---+--- SAT SOLVING FOR QUALIFIER CONSTRAINTS+---++--+-- As a last ditch effort, use a simple SAT solver to find a+-- decent literal-only substitution.+runSat ∷ MonadConstraint tv r m ⇒+         QCState tv → Bool → m (QCState tv)+runSat state doIt = do+  let sols    = SAT.solve =<< SAT.assertTrue formula SAT.newSatSolver+  traceN 4 ("runSat", formula, sols)+  case sols of+    []  → do+      typeError_ [msg| Qualifier constraints unsatisfiable |]+      return state+    sat:_ | doIt+        → qSubsts "sat" state =<<+            M.fromDistinctAscList <$> sequence+              [ return (δ, qlitexp ql)+                -- warn $ "\nSAT: substituting " ++ show (QE ql slack) +++                --        " for type variable " ++ show δ+              | δ ← S.toAscList (sq_αs state)+              , qUnifiable state δ+              , let (ql, var) = decodeSatVar δ (sq_τftv state) sat+              , ql == Qa || var /= QInvariant ]+    _   → return state+  where+  formula = foldr (SAT.:&&:) SAT.Yes $+      [ (πa τftv q ==> πa τftv βs)+      | (q, βs) ← sq_βlst state ]+    +++      [ (πa τftv (Free α) ==> πa τftv αs)+      | (α, QEMeet qes) ← M.toList (sq_vmap state)+      , qUnifiable state α+      , αs              ← qes ]+  p ==> q = SAT.Not p SAT.:||: q+  τftv    = sq_τftv state++-- | To encode some qualifier as a SAT formula+class SATable a v where+  πa ∷ VarMap v → a → SAT.Boolean++instance SATable QLit v where+  πa _ Qa = SAT.Yes+  πa _ _  = SAT.No++instance Tv v ⇒ SATable (TyVar v) v where+  πa vm (Free β) = encodeSatVar β vm+  πa _  _        = SAT.No++instance Tv v ⇒ SATable (S.Set v) v where+  πa vm vs = S.fold ((SAT.:||:) . πa vm . Free) SAT.No vs++-- | Given a type variable and a SAT solution, return a bound+--   for that type variable as implied by the solution.+decodeSatVar ∷ Tv tv ⇒ tv → VarMap tv → SAT.SatSolver → (QLit, Variance)+decodeSatVar β vm solver = (q, var) where+  (maximize, var) = maximizeVariance β vm+  q   = case (maximize, mba) of+    -- For minimizing variables, each component tells us whether that+    -- component may be omitted from the substitution, so we choose the+    -- smallest qualifier literal that includes the required components.+    (False, Just False) → Qa+    (False, _         ) → Qu+    -- For maximizing variables, each component tells us whether that+    -- component may be included in the substitution, so we choose the+    -- largest qualifier literal that omits the forbidden components.+    (True , Just False) → Qu+    (True , _         ) → Qa+  mba = SAT.lookupVar βa solver+  βa  = tvUniqueID β++-- | Encode the 'q' component of type variable 'β'.  We want to maximize+--   contravariant variables and minimize all the others.  Since the+--   solver tries true before false, we use a positive literal to stand+--   for the 'q' component of a maximized variable and a negative+--   literal for a minimized variable.+encodeSatVar ∷ Tv tv ⇒ tv → VarMap tv → SAT.Boolean+encodeSatVar β vm+  | fst (maximizeVariance β vm) = SAT.Var z+  | otherwise                   = SAT.Not (SAT.Var z)+  where z = tvUniqueID β++maximizeVariance ∷ Ord tv ⇒ tv → VarMap tv → (Bool, Variance)+maximizeVariance γ vm = case M.findWithDefault 0 γ vm of+  v@QCovariant  → (False, v)+  v@QInvariant  → (False, v)+  v             → (True,  v)++instance Ppr.Ppr SAT.Boolean where pprPrec = Ppr.pprFromShow+instance Ppr.Ppr SAT.SatSolver where pprPrec = Ppr.pprFromShow++---+--- General qualifier-solving utility functions+---++-- | Is the given type variable unifiable as a qualifier variable?+--   Right now, this just means its kind is 'KdQual'.+qUnifiable ∷ Tv tv ⇒ QCState tv → tv → Bool+qUnifiable _ α = tvKindIs KdQual α++-- | Project a free type variable from a 'TyVar', or error if the+-- 'TyVar' is bounds.+fromTyVar ∷ MonadAlmsError m ⇒ TyVar tv → m tv+fromTyVar (Free α) = return α+fromTyVar _        = typeBug "solveQualifiers" "Got bound type variable"++-- | Update a type variable variance map as a result of substituting a+--   qualifier expression for a type variable.+substQE ∷ Ord tv ⇒ tv → QExp tv → VarMap tv → VarMap tv+substQE β qe vmap = case takeMap β vmap of+  (Just v, vmap') → M.unionWith (⊔) vmap' (setToMap v (ftvSet qe))+  _               → vmap++-- | Lookup a key in a map and remove the key from the map.+takeMap ∷ Ord k ⇒ k → M.Map k v → (Maybe v, M.Map k v)+takeMap = M.updateLookupWithKey (\_ _ → Nothing)++-- | Lift a 'S.Set' to a 'M.Map' with constant value+setToMap   ∷ a → S.Set k → M.Map k a+setToMap   = setToMapWith . const++-- | Lift a 'S.Set' to a 'M.Map' with values computed from keys.+setToMapWith   ∷ (k → a) → S.Set k → M.Map k a+setToMapWith f = M.fromDistinctAscList . map (id &&& f) . S.toAscList++{-++OPTIMIZATIONS FROM SIMONET 2003++6.1 Collapsing Cycles++  This is the SCC phase++6.2 Polarities (implemented in buildGraph)++  Upper bounds on positive variables and lower bounds on negative+  variables are irrelevant, e.g.:++    f : ∀ α ≤ A. 1 → α × α+    f : ∀ α. 1 → α × α++  Or:++    let rec f = λx. f (f x) in f+    f : α → β [β ≤ α]+    f : ∀α. ∀β ≤ α. α → β+    f : ∀α. ∀β. α → β++6.3 Reducing Chains (implemented in polarizedReduce)++  A positive variable with a single predecessor can be fused with the+  predecessor; dually, a negative variable can be fused with a single+  successor.++    ∀ α ≤ A. α → 1+    A → 1++    ∀ α ≤ A. α × α → 1+    A × A → 1++  Currently this is implemented only for variables that occur only once.+  Why?++6.4 Polarized Garbage Collection++  ?++6.5 Minimization++  If two positive variables have all the same predecessors, the can be+  coalesced. Dually for negative variables with the same successors.++  ∀ α ≤ C. ∀ β ≤ C. α × β → 1+    A × B → 1++  ∀ α ≤ C. α × α → 1+    C × C → 1+    A × B → 1+-}+
+ src/Statics/Decl.hs view
@@ -0,0 +1,430 @@+-- | Type checking declarations+module Statics.Decl (+  tcProg, tcDecls, tcDecl, tcSigExp,+) where++import Util+import qualified AST+import qualified Data.Loc+import Meta.Quasi+import Type+import Statics.Constraint+import Statics.Env as Env+import Statics.Error+import Statics.Type+import Statics.Expr+import Statics.Sealing++import Prelude ()+import Data.IORef (IORef)+import qualified Data.List as L+import qualified Data.Map  as M+import qualified Data.Set  as S++-- | Type check a program+tcProg  ∷ MonadConstraint tv r m ⇒+          Γ tv → AST.Prog R → m (AST.Prog R, Maybe (Type tv))+tcProg γ prog0 = withLocation prog0 $ case prog0 of+  [prQ| $list:ds in $opt:me |]                  → do+    (ds', γ', _)        ← tcDecls [] γ ds+    meσ'                ← mapM (tcExpr γ') me+    let me' = fst <$> meσ'+    return ([prQ| $list:ds' in $opt:me' |], snd <$> meσ')++-- | Type check a declaration.+tcDecl  ∷ MonadConstraint tv r m ⇒+          [ModId] → Γ tv → AST.Decl R → m+          (AST.Decl R, Γ tv, Signature tv)+tcDecl μ γ d0 = withLocation d0 $ case d0 of+  [dc| let $π = $e |]                           → do+    (e', σs)    ← tcExprPatt γ e π+    γ'          ← γ !+! π -:*- σs+    return ([dc| let $π = $e' |], γ', zipWith SgVal (AST.dv π) σs)+  [dc| let rec $list:bns |]                     → do+    (bns', ns, σs) ← tcLetRecBindings γ bns+    γ'          ← γ !+! ns -:*- σs+    return ([dc| let rec $list:bns' |], γ', zipWith SgVal ns σs)+  [dc| type $tid:lhs = type $qtid:rhs |]        → do+    tc          ← γ !.! rhs+    let sig     = [SgTyp lhs tc { tcName = J (reverse μ) lhs }]+    return (d0, γ =+= sig, sig)+  [dc| abstype $list:at with $list:ds end |]    → do+    (sigC, sigA)        ← tcAbsTys μ γ at+    (ds', _, sig1)      ← tcDecls μ (γ =+= sigC) ds+    let sig             = sigA ++ replaceTyCons (getSigTyCons sigA) sig1+    γ'                  ← γ !+! sig+    return ([dc| abstype $list:at with $list:ds' end |], γ', sig)+  [dc| type $list:tds |]                        → do+    sig         ← tcTyDecs μ γ tds+    return (d0, γ =+= sig, sig)+  [dc| module type $sid:n = $sigexp |]          → do+    sig1        ← tcSigExp γ sigexp+    let sig     = [SgSig n sig1]+    return (d0, γ =+= sig, sig)+  [dc| module $mid:n = $modexp |]               → do+    (modexp', sig1)     ← tcModExp (n:μ) γ modexp+    let sig     = [SgMod n sig1]+    γ'          ← γ !+! sig+    return ([dc| module $mid:n = $modexp' |], γ', sig)+  [dc| open $modexp |]                          → do+    (modexp', sig) ← tcModExp μ γ modexp+    γ'          ← γ !+! sig+    return ([dc| open $modexp' |], γ', sig)+  [dc| local $list:ds0 with $list:ds1 end |]    → do+    (ds0', γ', _)    ← tcDecls (AST.ident "?LocalModule":μ) γ ds0+    (ds1', _,  sig1) ← tcDecls μ γ' ds1+    γ''              ← γ !+! sig1+    return ([dc| local $list:ds0' with $list:ds1' end |], γ'', sig1)+  [dc| exception $cid:c of $opt:mt |]           → do+    mσ ← toEmptyF <$$> mapM (tcType mempty γ) mt+    let sig     = [SgExn c mσ]+    return (d0, γ =+= sig, sig)+  [dc| $anti:a |]                               → $(AST.antifail)++-- | Type check a sequence of declarations+tcDecls ∷ MonadConstraint tv r m ⇒+          [ModId] → Γ tv → [AST.Decl R] →+          m ([AST.Decl R], Γ tv, Signature tv)+tcDecls _ γ []     = return ([], γ, [])+tcDecls μ γ (d:ds) = do+  (d', γ', sig0)   ← tcDecl μ γ d+  (ds', γ'', sig1) ← tcDecls μ γ' ds+  return (d':ds', γ'', sig0 ++ sig1)++-- | Type check a module expression+tcModExp ∷ MonadConstraint tv r m ⇒+           [ModId] → Γ tv → AST.ModExp R →+           m (AST.ModExp R, Signature tv)+tcModExp μ γ modexp0 = withLocation modexp0 $ case modexp0 of+  [meQ| struct $list:ds end |]                  → do+    (ds', _, sig)       ← tcDecls μ γ ds+    return ([meQ| struct $list:ds' end |], sig)+  [meQ| $qmid:n $list:_ |]                      → do+    (sig, _) ← γ !.! n+    return (modexp0, sig)+  [meQ| $modexp : $sigexp |]                    → do+    (modexp', sig0)     ← tcModExp μ γ modexp+    sig1                ← tcSigExp γ sigexp+    sig                 ← sealWith μ sig0 sig1+    return ([meQ| $modexp' : $sigexp |], sig)+  [meQ| $anti:a |]                              → $(AST.antifail)++-- | Type check a single signature item+tcSigItem ∷ MonadConstraint tv r m ⇒+            Γ tv → AST.SigItem R → m (Signature tv)+tcSigItem γ sigitem0 = withLocation sigitem0 $ case sigitem0 of+  [sgQ| val $vid:n : $t |]                      → do+    σ           ← tcType mempty γ t+    return [SgVal n σ]+  [sgQ| type $list:tds |]                       → tcTyDecs [] γ tds+  [sgQ| type $tid:lhs = type $qtid:rhs |]       → do+    tc          ← γ !.! rhs+    return [SgTyp lhs tc { tcName = J [] lhs }]+  [sgQ| module $mid:n : $sigexp |]              → do+    sig         ← tcSigExp γ sigexp+    return [SgMod n sig]+  [sgQ| module type $sid:n = $sigexp |]         → do+    sig         ← tcSigExp γ sigexp+    return [SgSig n sig]+  [sgQ| include $sigexp |]                      → tcSigExp γ sigexp+  [sgQ| exception $cid:c of $opt:mt |]          → do+    mσ ← toEmptyF <$$> mapM (tcType mempty γ) mt+    return [SgExn c mσ]+  [sgQ| $anti:a |]                              → $(AST.antifail)++-- | Type check a signature body+tcSigItems   ∷ MonadConstraint tv r m ⇒+               Γ tv → [AST.SigItem R] → m (Signature tv)+tcSigItems _ []       = return []+tcSigItems γ (sg:sgs) = do+  sig0  ← tcSigItem γ sg+  γ'    ← γ !+! sig0+  sig1  ← tcSigItems γ' sgs+  return (sig0 ++ sig1)++-- | Type check a signature expression+tcSigExp ∷ MonadConstraint tv r m ⇒+           Γ tv → AST.SigExp R → m (Signature tv)+tcSigExp γ sigexp0 = withLocation sigexp0 $ case sigexp0 of+  [seQ| sig $list:sgs end |]                    → tcSigItems γ sgs+  [seQ| $qsid:n $list:_ |]                      → fst <$> γ !.! n+  [seQ| $sigexp with type $list:αs $qtid:qc = $t |]+                                                → do+    sig         ← tcSigExp γ sigexp+    let td      = AST.tdSyn (jname qc) [(AST.tpVar <$> αs <*> pure 1, t)]+    [(_, tc)]   ← tcTyDecs' [] γ [td]+    return (fibrate qc tc sig)+  [seQ| $anti:a |]                              → $(AST.antifail)++-- | Type check the type declarations of an abstype block+tcAbsTys ∷ MonadConstraint tv r m ⇒+           [ModId] → Γ tv → [AST.AbsTy R] →+           m (Signature tv, Signature tv)+tcAbsTys μ γ ats = do+  (arities, quals, tydecs) ← unzip3 <$> mapM unAbsTy ats+  ntcs0                    ← tcTyDecs' μ γ tydecs+  ntcs1 ← sequence+    [ do+        qe ← indexQuals (AST.tdParams (view td)) qual+        let tc' = tc {+                    tcArity = arity,+                    tcQual  = qe,+                    tcCons  = mempty,+                    tcNext  = Nothing+                  }+        checkTyConMonotone (AST.tdParams (view td)) tc+        return (n, tc')+    | (n, tc) ← ntcs0+    | arity   ← arities+    | qual    ← quals+    | td      ← tydecs ]+  return (uncurry SgTyp <$> ntcs0, uncurry SgTyp <$> ntcs1)+  where+    unAbsTy (AST.N _ (AST.AbsTy arity qual td)) = return (arity, qual, td)+    unAbsTy (AST.N _ (AST.AbsTyAnti a))         = $(AST.antifail)++-- | Type check a type declaration group+tcTyDecs  ∷ MonadConstraint tv r m ⇒+            [ModId] → Γ tv → [AST.TyDec R] → m (Signature tv)+tcTyDecs  = uncurry SgTyp <$$$$$> tcTyDecs'++-- | Type check a type declaration group+tcTyDecs' ∷ MonadConstraint tv r m ⇒+            [ModId] → Γ tv → [AST.TyDec R] → m [(TypId, TyCon)]+tcTyDecs' μ γ tds = do+  stub_sig  ← forM tds $ \td → withLocation td $ case view td of+    AST.TdDat tid params _+      → allocStub tid (AST.tvqual <$> params)+    AST.TdSyn tid ((tps,_):_)+      → allocStub tid (Qa <$ tps)+    AST.TdAbs tid params variances guards qual+      → do+        qe ← indexQuals params qual+        ix ← tvUniqueID <$> newTV+        let tc = mkTC ix (J (reverse μ) tid)+                         qe+                         (zip3 variances+                               (AST.tvqual <$> params)+                               ((`elem` guards) <$> params))+        checkTyConMonotone params tc+        return (tid, tc)+    AST.TdSyn _ []+      → typeBug "tcTyDecs'" "Saw type synonym with 0 clauses."+    AST.TdAnti a+      → $(AST.antifail)+  real_sig ← iterChanging <-> stub_sig $ \sig →+    zipWithM (tcTyDec (γ =+= Env.fromList sig)) tds sig+  return (second (replaceTyCons (snd <$> real_sig)) <$> real_sig)+  where+    allocStub tid bounds = do+      ix ← tvUniqueID <$> newTV+      return (tid, mkTC ix (J (reverse μ) tid)+                           ((Omnivariant,,False) <$> bounds) ∷ TyCon)+    --++checkTyConMonotone ∷ MonadAlmsError m ⇒ [AST.TyVar R] → TyCon → m ()+checkTyConMonotone params tc = do+  let ftv_qe  = ftvSet (tcQual tc)+      bad_tvs = map ([msg| $2 (variance $1, at $3) |]+                       <$> sel2 <*> sel3 <*> AST.getLoc. sel3) .+                filter (\tup → S.member (sel1 tup) ftv_qe) .+                filter (\tup → sel2 tup ⊑ Contravariant) $+                zip3 [ 0 .. ] (tcArity tc) params+      name    = tcName tc+  unless (null bad_tvs) $+    typeError [msg| Type declaration for $q:name is inadmissable+      because it doesn’t satisfy the monotonicity condition for+      type constructors.+      All type variable parameters that appear in the qualifier of+      a type must be covariant or invariant, this is not satisfied+      by all parameters of $q:name:+      $ul:bad_tvs+    |]++tcTyDec ∷ MonadConstraint tv r m ⇒+          Γ tv → AST.TyDec R → (TypId, TyCon) → m (TypId, TyCon)+tcTyDec γ td (tid, tc) = withLocation td $ case view td of+  AST.TdDat _ params alts+    → do+      αs        ← mapM (curry newTV' Skolem) params+      let δ     = params -:*- αs+      mσs       ← mapM (mapM (tcType δ γ) . snd) alts+      let mσs'          = toEmptyF . closeTy 0 αs <$$> mσs+          arity         = M.findWithDefault 0 <-> ftvV mσs <$> αs+          bounds        = AST.tvqual <$> params+          guards        = M.findWithDefault True <-> ftvG mσs <$> αs+          qual          = case qualifierEnv [bounds] mσs' of+            QeA     → QeA+            QeU set → QeU (S.mapMonotonic each set)+              where each (Bound _ j _) = j+                    each (Free r)      = elimEmpty r+      when (arity  /= tcArity tc+         || bounds /= tcBounds tc+         || guards /= tcGuards tc+         || qual   /= tcQual tc)+        setChanged+      return (tid, tc {+                     tcArity  = arity,+                     tcBounds = bounds,+                     tcGuards = guards,+                     tcQual   = qual,+                     tcCons   = map fst alts -:*- mσs'+                   })+  AST.TdSyn _ cs@((tps0, _):_)+    → do+      let nparams = length tps0+      tassert (all ((== nparams) . length . fst) cs)+        [msg| In definition of type operator $q:tid, not all clauses+              have the same number of parameters. |]+      (cs', infos) ← unzip <$$> for cs $ \(tps, rhs) → do+        (tps', αss)     ← unzip <$> mapM (tcTyPat γ) tps+        αss'            ← mapM (mapM (const newTV . fst)) αss+        let (dot, nonDot)+                        = L.partition (snd . fst)+                            (zip (concat αss) (concat αss'))+            dot_αs      = first fst <$> dot+            αs          = fst . fst <$> nonDot+            αs'         = snd <$> nonDot+        σ               ← tcTypeRowDots (αs -:*- αs') dot_αs γ rhs+        qlss            ← mapM getTVBounds αss'+        let σ'          = toEmptyF (closeTy 0 (concat αss') σ)+            -- For each pattern, for each of its type variables,+            -- a triple of its variance, inclusion in the qualifer,+            -- and guardedness:+            kindses     = tyPatKinds <$> tps'+        -- Bounds are computed by checking which type variables need to+        -- be bounded for the right-hand side to be well-formed, then+        -- checking which are similarly bounded on the left.  For those+        -- that are not yet bounded on the left, if they are involved in+        -- the qualifier of the pattern then we can bound them by bounding+        -- the pattern, but otherwise it's an error.+        bounds  ← sequence+          [ bigMeet <$> sequence+            [ if qll ⊑ qlr then return Qa+              else if inQExp then return Qu+              else do+                typeError_ $ uncurry+                  [msg|+                    Ill-formed type $1 declaration.+                    <br>+                    Type variable $α must be bounded by U (unlimited)+                    for the type on the right-hand side of $2 to be+                    well-formed, but it is not bounded by its appearance+                    in the pattern, and because it does not contribute+                    to the qualifier of the pattern, bounded the pattern+                    cannot effectively bound $α.+                  |] $+                  if length cs == 1+                    then ("synonym", "the declaration")+                    else ("operator", "clause " ++ show i)+                return Qa+            | (_, inQExp, _, qll) ← kindsi+            | α   ← αsi+            | qlr ← qlsi ]+          | i      ← [1 ∷ Int .. ]+          | kindsi ← kindses+          | αsi    ← αss+          | qlsi   ← qlss ]+            -- The arity of each parameter is the join of the products+            -- of the arities of the type variables in the pattern and+            -- rhs type.+        let varmap      = ftvV σ+            arity       = [ bigJoin $+                              zipWith (*)+                                (sel1 <$> kindsi)+                                (M.findWithDefault 0 <-> varmap <$> αsi')+                          | kindsi ← kindses+                          | αsi'   ← αss' ]+            -- This is very permissive:+            guardmap    = ftvG σ+            guards      = [ all2 (||)+                              (M.findWithDefault True <-> guardmap <$> αsi')+                              (sel3 <$> kindsi)+                          | kindsi ← kindses+                          | αsi'   ← αss' ]+            -- For each parameter, a list of which of its type+            -- variables are significant to the qualifier+            qinvolveds = [ map snd . filter fst $+                              zip (sel2 <$> kindsi)+                                  αsi'+                          | kindsi ← kindses+                          | αsi'   ← αss' ]+            qual        = case qualifier σ of+              QeA       → QeA+              QeU βs    → bigJoin+               [ case L.findIndex (β `elem`) qinvolveds of+                   Nothing → QeA+                   Just ix+                     | Qu:_ ← drop ix bounds → qlitexp Qu+                     | otherwise             → qvarexp ix+               | Free β ← S.toList βs ]+        return ((tps', σ'), (arity, bounds, guards, qual))+      let (arities, boundses, guardses, quals) = unzip4 infos+          arity  = foldl1 (zipWith (⊔)) arities+          bounds = foldl1 (zipWith (⊓)) boundses+          guards = foldl1 (zipWith (&&)) guardses+          qual   = bigJoin quals+      when (arity  /= tcArity tc+         || bounds /= tcBounds tc+         || guards /= tcGuards tc+         || qual   /= tcQual tc)+        setChanged+      traceN 1 ("bounds", bounds)+      return (tid, tc {+                     tcArity  = arity,+                     tcBounds = bounds,+                     tcGuards = guards,+                     tcQual   = qual,+                     tcNext   = Just cs'+                   })+  AST.TdAbs _ _ _ _ _+    → return (tid, tc)+  AST.TdSyn _ []+    → typeBug "tcTyDec" "Saw type synonym with 0 clauses."+  AST.TdAnti a+    → $(AST.antifail)++-- | Convert a syntactic qualifier expression into an internal+--   qualifier expression over 'Int'.+indexQuals ∷ MonadAlmsError m ⇒+             [AST.TyVar R] → AST.QExp R → m (QExp Int)+indexQuals params = qInterpret resolver where+  resolver tv = case L.findIndex (== tv) params of+    Nothing → typeBug "indexQuals" "tv not found in type params"+    Just ix → return ix++-- | Given a functor, replace the contents with 'Empty', provided+--   there is no contents. If an 'Empty' value is actually required,+--   this is an error.+toEmptyF ∷ Functor f ⇒ f a → f Empty+toEmptyF = fmap toEmpty where+  toEmpty _ = throw (almsBug StaticsPhase "tcDecl" "saw free type variable")++---+--- MODULE SYSTEM+---++-- | Functional update on a signature+fibrate  ∷ QTypId → TyCon → Signature tv → Signature tv+fibrate (J [] tid) tc sig = map eachItem sig where+  eachItem (SgTyp tid' _)+    | tid == tid'       = SgTyp tid tc+  eachItem sigitem      = sigitem+fibrate (J (mid:rest) tid) tc sig = map eachItem sig where+  eachItem (SgMod mid' sig')+    | mid == mid'       = SgMod mid (fibrate (J rest tid) tc sig')+  eachItem sigitem      = sigitem++---+--- TESTING+---++test_tcProg ∷ AST.Prog R →+              IO (Either [AlmsError]+                         (Maybe (Type (TV IORef)),+                          ConstraintState (TV IORef) IORef))+test_tcProg p =+  runConstraintIO+    constraintState0+    (subst =<< snd <$> tcProg test_g0 p)+
+ src/Statics/Decl.hs-boot view
@@ -0,0 +1,12 @@+{-# LANGUAGE+      UnicodeSyntax+    #-}+module Statics.Decl where++import qualified AST+import Statics.Constraint+import Statics.Env++tcDecl  ∷ MonadConstraint tv r m ⇒+          [ModId] → Γ tv → AST.Decl R →+          m (AST.Decl R, Γ tv, Signature tv)
+ src/Statics/Env.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE TypeFamilies #-}+module Statics.Env (+  -- * Type variable environment+  Δ,+  -- * Main environment+  Γ(..), Γv, Γc, Γt, Γm, Γs, R,+  -- ** Operations+  bumpΓ, sigToEnv, sigItemToEnv, (!.!), (!..!), ExtendRank(..),+  -- * Testing+  test_g0,+  -- * Re-exports+  module Statics.Sig,+  module Env,+) where++import Util+import qualified AST+import Type+import Statics.Sig+import Statics.Error+import qualified Type.Rank as Rank+import qualified Syntax.Ppr as Ppr+import Env++import Prelude ()+import Data.Generics (Typeable, Data)+import qualified Data.Map as M++type R = AST.Renamed++-- | Mapping from type variable names to type variables+type Δ tv = Env (AST.TyVar R) tv++-- | Mapping variable names to type+type Γv tv      = Env VarId (Type tv)+-- | Mapping data constructor names to type constructors or exception+--   parameter types+type Γc tv      = Env ConId (Either TyCon (Maybe (Type Empty)))+-- | Mapping type names to type constructors+type Γt tv      = Env TypId TyCon+-- | Mapping module names to their signatures and reflection as an environment+type Γm tv      = Env ModId (Signature tv, Γ tv)+-- | Mapping signature names to signatures and reflection as an environment+type Γs tv      = Env SigId (Signature tv, Γ tv)++-- | An environment+data Γ tv+  = Γ {+      rankΓ     ∷ !Rank.Rank,+      varΓ      ∷ !(Γv tv),+      conΓ      ∷ !(Γc tv),+      typΓ      ∷ !(Γt tv),+      modΓ      ∷ !(Γm tv),+      sigΓ      ∷ !(Γs tv)+    }+  deriving (Functor, Show, Typeable, Data)++instance Monoid (Γ tv) where+  mempty = Γ Rank.zero empty empty empty empty empty+  Γ rank a b c d e `mappend` Γ rank' a' b' c' d' e'+    = Γ (rank `max` rank') (a=+=a') (b=+=b') (c=+=c') (d=+=d') (e=+=e')++-- | Increment the rank of the environment+bumpΓ ∷ Γ tv → Γ tv+bumpΓ γ = γ { rankΓ = Rank.inc (rankΓ γ) }++-- | Reflect a signature as an environment+sigToEnv ∷ Signature tv → Γ tv+sigToEnv = foldMap sigItemToEnv++-- | Reflect a signature item as an environment+sigItemToEnv ∷ SigItem tv → Γ tv+sigItemToEnv (SgVal n τ)   = mempty { varΓ = n =:= τ }+sigItemToEnv (SgTyp n tc)  =+  mempty {+    typΓ = n =:= tc,+    conΓ = Left tc <$ tcCons tc+  }+sigItemToEnv (SgExn n mτ)  = mempty { conΓ = n =:= Right mτ }+sigItemToEnv (SgMod n sig) = mempty { modΓ = n =:= (sig, sigToEnv sig) }+sigItemToEnv (SgSig n sig) = mempty { sigΓ = n =:= (sig, sigToEnv sig) }++---+--- INSTANCES+---++instance GenEmpty (Γ tv) where+  genEmpty = mempty++instance GenExtend (Γ tv) (Γ tv) where+  (=+=) = mappend+instance (v ~ VarId, tv ~ tv') ⇒+         GenExtend (Γ tv) (Env v (Type tv')) where       -- Γv+  e =+= ev' = e { varΓ = varΓ e =+= ev' }+instance (c ~ ConId, tc ~ TyCon, mt ~ Maybe (Type Empty)) ⇒+         GenExtend (Γ tv) (Env c (Either tc mt)) where  -- Γc+  e =+= ec' = e { conΓ = conΓ e =+= ec' }+instance t ~ TypId ⇒+         GenExtend (Γ tv) (Env t TyCon) where           -- Γt+  e =+= et' = e { typΓ = typΓ e =+= et' }+instance (s ~ Signature tv, g ~ Γ tv) ⇒+         GenExtend (Γ tv) (Env ModId (s, g)) where      -- Γm+  e =+= em' = e { modΓ = modΓ e =+= em' }+instance (s ~ Signature tv, g ~ Γ tv) ⇒+         GenExtend (Γ tv) (Env SigId (s, g)) where      -- Γs+  e =+= es' = e { sigΓ = sigΓ e =+= es' }+instance tv ~ tv' ⇒ GenExtend (Γ tv) (Signature tv') where+  e =+= sig = e =+= sigToEnv sig++instance GenLookup (Γ tv) VarId (Type tv) where+  (=..=) = (=..=) . varΓ+instance GenLookup (Γ tv) ConId (Either TyCon (Maybe (Type Empty))) where+  (=..=) = (=..=) . conΓ+instance GenLookup (Γ tv) TypId TyCon where+  (=..=) = (=..=) . typΓ+instance GenLookup (Γ tv) ModId (Signature tv, Γ tv) where+  (=..=) = (=..=) . modΓ+instance GenLookup (Γ tv) SigId (Signature tv, Γ tv) where+  (=..=) = (=..=) . sigΓ+instance GenLookup (Γ tv) k v =>+         GenLookup (Γ tv) (Path ModId k) v where+  e =..= J []     k = e =..= k+  e =..= J (p:ps) k = do+    (_, e') <- e =..= p+    e' =..= J ps k++(!.!) ∷ (GenLookup e k v, Show k, MonadAlmsError m) ⇒ e → k → m v+e !.! k = case e =..= k of+  Just v  → return v+  Nothing → typeBug "GenLookup" ("unbound identifier: " ++ show k)++(!..!) ∷ (GenLookup e k v, Show k) ⇒ e → k → v+e !..! k = case e =..= k of+  Just v  → v+  Nothing → typeBugError "GenLookup" ("unbound identifier: " ++ show k)++infixl 6 !.!, !..!++-- | Extend the environment and update the ranks of the free type+--   variables of the added types.+class ExtendRank a tv | a → tv where+  (!+!) ∷ MonadSubst tv r m ⇒ Γ tv → a → m (Γ tv)++infixl 2 !+!++instance ExtendRank (Γ tv) tv where+  γ !+! γ' = do+    lowerRank (Rank.inc (rankΓ γ)) =<< subst (range (varΓ γ'))+    return (bumpΓ γ =+= γ')++instance ExtendRank (Γv tv) tv where+  γ !+! γv = γ !+! mempty { varΓ = γv }++instance ExtendRank (Signature tv) tv where+  γ !+! sig = γ !+! sigToEnv sig++instance (Ppr.Ppr k, Ppr.Ppr v) ⇒ Ppr.Ppr (Env k v) where+  ppr env = Ppr.braces . Ppr.fsep . Ppr.punctuate Ppr.comma $+    [ Ppr.ppr0 k Ppr.<> Ppr.colon Ppr.<+> Ppr.ppr0 v+    | (k, v) <- Env.toList env ]++instance Tv tv ⇒ Ppr.Ppr (Γ tv) where+  ppr γ = Ppr.char 'Γ' Ppr.<> Ppr.ppr (M.fromList+    [ ("rank", Ppr.ppr0 $ rankΓ γ)+    , ("typ",  Ppr.ppr0 $ typΓ γ)+    , ("var",  Ppr.ppr0 $ varΓ γ)+    , ("con",  Ppr.ppr0 $ conΓ γ)+    , ("mod",  Ppr.ppr0 $ snd <$> modΓ γ)+    , ("sig",  Ppr.ppr0 $ snd <$> sigΓ γ)+    ])++test_g0 ∷ ∀ tv. Tv tv ⇒ Γ tv+test_g0 = mempty+  =+= AST.ident "->"            =:= tcFun+  =+= AST.ident "unit"          =:= tcUnit+    =+= AST.ident "()"            =:= Left tcUnit+  =+= AST.ident "int"           =:= tcInt+  =+= AST.ident "exn"           =:= tcExn+    =+= AST.ident "Failure"       =:= Right (Just tyString)+    =+= AST.ident "Match"         =:= Right Nothing+  =+= AST.ident "U"             =:= tcUn+  =+= AST.ident "A"             =:= tcAf+  =+= AST.ident "\\/"           =:= tcJoin+  =+= AST.ident "*"             =:= tcTuple+  =+= AST.ident "rowend"        =:= tcRowEnd+  =+= AST.ident "variant"       =:= tcVariant+  =+= AST.ident "record"        =:= tcRecord+    =+= AST.ident "nilRecord"     =:= TyApp tcRecord [tyUn, tyRowEnd]+  =+= AST.ident "rowmap"        =:= tcRowMap+  =+= AST.ident "rowhole"       =:= tcRowHole+  =+= AST.ident "option"        =:= tcOption+    =+= AST.ident "None"          =:= Left tcOption+    =+= AST.ident "Some"          =:= Left tcOption+  =+= AST.ident "idfun"         =:= tcIdfun+    =+= AST.ident "Mono"          =:= Left tcIdfun+    =+= AST.ident "Poly"          =:= Left tcIdfun+  =+= AST.ident "ident"         =:= tcIdent+  =+= AST.ident "const"         =:= tcConst+  =+= AST.ident "cons"          =:= tcConsTup+  =+= AST.ident "x"             =:= tyInt+  =+= AST.ident "bot"           =:= TyQu Forall [(Nope, Qa)] (bvTy 0 0 Nope)+  =+= AST.ident "botU"          =:= TyQu Forall [(Nope, Qu)] (bvTy 0 0 Nope)
+ src/Statics/Error.hs view
@@ -0,0 +1,107 @@+-- | Type errors+module Statics.Error (+  -- * Basic error functions+  typeBug, typeBugError, typeError, typeError_, typeError', tassert,++  -- * Messages+  gotMessage, expMessage,+  -- ** Specialized message functions+  tErrGot, tErrGot_, tErrGot', tAssGot,+  tErrExp, tErrExp_, tErrExp', tAssExp,++  -- * Re-exports+  module Error,+) where++import Util+import Error+import Type++import Prelude ()++-- | Indicate a bug in the type checker.+typeBug         ∷ MonadAlmsError m ⇒ String → String → m a+typeBug         = throwAlms <$$> almsBug StaticsPhase++-- | Indicate a bug in the type checker, with no Alms error monad.+typeBugError    ∷ String → String → a+typeBugError    = throw <$$> almsBug StaticsPhase++-- | Indicate a type error.+typeError       ∷ (MonadAlmsError m, Bogus a) ⇒ Message V → m a+typeError msg0  = do+  reportAlms (AlmsError StaticsPhase bogus msg0)+  return bogus++-- | Indicate a type error.+typeError_      ∷ MonadAlmsError m ⇒ Message V → m ()+typeError_      = typeError++-- | Indicate a type error from which we cannot recover.+typeError'      ∷ MonadAlmsError m ⇒ Message V → m a+typeError'      = throwAlms <$> AlmsError StaticsPhase bogus++-- | Assert some condition, indicating a type error if it doesn't hold.+tassert         ∷ MonadAlmsError m ⇒ Bool → Message V → m ()+tassert True _  = return ()+tassert False m = typeError m++-- | Common message pattern: A got B where C expected+gotMessage      ∷ Tv tv ⇒ String → Type tv → String → Message V+gotMessage who got expected =+  [msg| $words:who got $q:got where $words:expected expected. |]++-- | Error for 'gotMessage'+tErrGot         ∷ (MonadAlmsError m, Bogus a, Tv tv) =>+                  String -> Type tv -> String -> m a+tErrGot         = typeError <$$$> gotMessage++-- | Error for 'gotMessage'+tErrGot_        ∷ (MonadAlmsError m, Tv tv) =>+                  String -> Type tv -> String -> m ()+tErrGot_        = tErrGot++-- | Stopping error for 'gotMessage'+tErrGot'        ∷ (MonadAlmsError m, Tv tv) =>+                  String -> Type tv -> String -> m a+tErrGot'        = typeError' <$$$> gotMessage+++-- | Assertion for 'gotMessage'+tAssGot         ∷ (MonadAlmsError m, Tv tv) =>+                  Bool -> String -> Type tv -> String -> m ()+tAssGot True    = \_ _ _ → return ()+tAssGot False   = tErrGot++-- | Common message pattern, actual vs. expected+expMessage      ∷ Message V → Message V → Message V → Message V+expMessage      =+  [msg|+    $msg:1+    <dl>+      <dt>actual:   <dd>$msg:2+      <dt>expected: <dd>$msg:3+    </dl>+  |]++-- | Error for 'expMessage'+tErrExp         ∷ (MonadAlmsError m, Bogus a) ⇒+                  Message V → Message V → Message V → m a+tErrExp         = typeError <$$$> expMessage++-- | Error for 'expMessage'+tErrExp_        ∷ MonadAlmsError m ⇒+                  Message V → Message V → Message V → m ()+tErrExp_        = tErrExp++-- | Stopping error for 'expMessage'+tErrExp'        ∷ (MonadAlmsError m) ⇒+                  Message V → Message V → Message V → m a+tErrExp'        = typeError' <$$$> expMessage++-- | Assertion for 'expMessage'+tAssExp         ∷ MonadAlmsError m ⇒+                  Bool → Message V → Message V → Message V → m ()+tAssExp True    = \_ _ _ → return ()+tAssExp False   = tErrExp+
+ src/Statics/Expr.hs view
@@ -0,0 +1,425 @@+-- | Type inference for expressions+module Statics.Expr (+  tcExpr, tcExprPatt, tcLetRecBindings,+) where++import Util+import Util.MonadRef+import qualified AST+import qualified Data.Loc+import Meta.Quasi+import Type+import Statics.Env+import Statics.Error+import Statics.Constraint+import Statics.Coercion+import Statics.InstGen+import Statics.Subsume+import Statics.Type+import Statics.Patt+import {-# SOURCE #-} Statics.Decl++import Prelude ()+import qualified Data.Map as M+import Data.IORef (IORef)++tcExpr ∷ MonadConstraint tv r m ⇒+         Γ tv → AST.Expr R → m (AST.Expr R, Type tv)+tcExpr γ e = withTVsOf mempty γ e $ \δ →+  infer (request Forall Exists) δ γ e Nothing++tcExprPatt ∷ MonadConstraint tv r m ⇒+             Γ tv → AST.Expr R → AST.Patt R →+             m (AST.Expr R, [Type tv])+tcExprPatt γ e π = withTVsOf mempty γ (e, π) $ \δ → do+  mσ1               ← extractPattAnnot δ γ π+  (e', σ1)          ← infer (request Forall Exists) δ γ e mσ1+  (_, σs)           ← tcPatt δ γ π (Just σ1) [ex|+! () |]+  mapM (⊏: Qu) σs+  return (e', σs)++infer  ∷ MonadConstraint tv r m ⇒+         Request tv → Δ tv → Γ tv → AST.Expr R → Maybe (Type tv) →+         m (AST.Expr R, Type tv)+infer φ0 δ γ e0 mσ0 = do+  traceN 1 (TraceIn ("infer", φ0, e0, mσ0))+  mσ ← mapM subst mσ0+  let φ = maybe id prenexFlavors mσ φ0+  σ ← withLocation e0 $ case e0 of+    [ex| $qvid:n |]             → do+      σ' ← maybeInstGen e0 φ γ =<< γ !.! n+      return ([ex| $qvid:n |], σ')+    --+    [ex| $int:_ |]              → return (e0, tyInt)+    [ex| $char:_ |]             → return (e0, tyChar)+    [ex| $flo:_ |]              → return (e0, tyFloat)+    [ex| $str:_ |]              → return (e0, tyString)+    --+    [ex| $qcid:c $opt:me |]     → do+      -- Look up the type constructor and parameter type for the+      -- given data constructor+      tcexn ← γ !.! c+      (tc, mσ1) ← case tcexn of+        Left tc   → (tc,) <$> tcCons tc !.! jname c+        Right mσ1 → return (tcExn, mσ1)+      -- Propagation: If an annotation has been passed downward, split+      -- it into type parameters for the type constructor.  If splitting+      -- fails, then instantiate type variables with the right bounds+      -- and kinds.+      mσs ← splitCon mσ tc+      σs  ← sequence+              [ maybe (newTVTy' (qli, variancei)) return mσi+              | mσi       ← mσs+              | qli       ← tcBounds tc+              | variancei ← tcArity tc ]+      -- Check whether a parameter is expected. If it isn't, then assert+      -- that none was given.  If it is, then instantiate it using the+      -- propagated parameters, and propagate the instantated parameter+      -- type downward.  Force the result to subsume the expected type.+      case mσ1 of+        Nothing → do+          tassert (isNothing me)+            [msg| In expression, nullary data constructor $q:c is+                  applied to an argument. |]+          σ' ← maybeGen e0 φ γ (TyApp tc σs)+          return ([ex| $qcid:c |], σ')+        Just σ1E → do+          let σ1 = openTy 0 σs (elimEmptyF σ1E)+          case me of+            Just e  → do+              (e', σ1') ← infer request δ γ e (Just σ1)+              σ1' ≤ σ1+              σ' ← maybeGen e0 φ γ (TyApp tc σs)+              return ([ex| $qcid:c $e' |], σ')+            Nothing → do+              σ' ← maybeGen e0 φ γ (tyArr σ1 (TyApp tc σs))+              return ([ex|+ λ x → $qcid:c x |], σ')+    --+    [ex| let $π = $e1 in $e2 |] → do+      mσ1               ← extractPattAnnot δ γ π+      ((e1', σs), αs)   ← collectTVs $ do+        (e1', σ1)         ← infer (request Forall Exists) δ γ e1 mσ1+        (_, σs)           ← tcPatt δ γ π (Just σ1) e2+        return (e1', σs)+      γ'                ← γ !+! π -:*- σs+      (e2', σ')         ← infer (request φ γ αs) δ γ' e2 mσ+      return ([ex| let $π = $e1' in $e2' |], σ')+    [ex| match $e1 with $list:cas |] → do+      ((e1', σ1), αs)   ← collectTVs (infer request δ γ e1 Nothing)+      (cas', σ')        ← tcMatchCases (request φ γ αs) δ γ σ1 cas mσ+      return ([ex| match $e1' with $list:cas' |], σ')+    [ex| let rec $list:bs in $e2 |] → do+      (bs', ns, σs)     ← tcLetRecBindingsΔ δ γ bs+      γ'                ← γ !+! ns -:*- σs+      (e2', σ')         ← infer φ δ γ' e2 mσ+      return ([ex| let rec $list:bs' in $e2' |], σ')+    [ex| let $decl:d in $e1 |]      → do+      (d', γ', _)       ← tcDecl [AST.ident "?LetModule"] γ d+      (e1', σ1)         ← infer request δ γ' e1 mσ+      σ'                ← maybeInstGen e0 φ γ σ1+      return ([ex| let $decl:d' in $e1' |], σ')+    --+    [ex| ($e1, $e2) |]          → do+      [mσ1, mσ2]        ← splitCon mσ tcTuple+      (e1', σ1)         ← infer request δ γ e1 mσ1+      (e2', σ2)         ← infer request δ γ e2 mσ2+      σ'                ← maybeGen e0 φ γ (tyTuple σ1 σ2)+      return ([ex| ($e1', $e2') |], σ')+    --+    [ex| λ $π → $e |]           → do+      [mσ1, _, mσ2]     ← splitCon mσ tcFun+      ((σ1, σs), αs)    ← collectTVs (tcPatt δ γ π mσ1 e)+      αs'               ← filterM (isMonoType <$$> subst . fst)+                                  ((fvTy &&& tvDescr) <$> αs)+      γ'                ← γ !+! π -:*- σs+      (e', σ2)          ← infer (request Exists γ αs) δ γ' e mσ2+      for_ αs' $ \(α, descr) → do+        τ ← subst α+        tassert (isMonoType τ)+          [msg| Use $descr polymorphically |]+      let qe            = arrowQualifier γ e0+      σ'                ← maybeGen e0 φ γ (tyFun σ1 qe σ2)+      return ([ex| λ $π → $e' |], σ')+    --+    [ex| $_ $_ |]               → do+      let (es, e1)      = AST.unfoldExApp e0+      ((e0', σ), αs)    ← collectTVs $ do+        (e1', σ1)         ← infer request δ γ e1 Nothing+        (es', σ)          ← inferApp δ γ σ1 es+        return (foldl' AST.exApp e1' es', σ)+      σ'                ← maybeInstGen e0 (request φ γ αs) γ σ+      return (e0', σ')+    --+    [ex| `$uid:c $opt:me1 |]    → do+      [mσRow]           ← splitCon mσ tcVariant+      (mσ1, _)          ← splitRow mσRow c+      σ2                ← newTVTy+      (me1', σ1)        ← case me1 of+        Nothing → return (Nothing, tyUnit)+        Just e1 → first Just <$> infer request δ γ e1 mσ1+      σ'                ← maybeGen e0 φ γ (TyApp tcVariant [TyRow c σ1 σ2])+      return ([ex| `$uid:c $opt:me1' |], σ')+    [ex| #$uid:c $e1 |]         → do+      [mσRow]           ← splitCon mσ tcVariant+      (_, mσ2)          ← splitRow mσRow c+      (e1', σ2)         ← infer request δ γ e1 (tyUnOp tcVariant <$> mσ2)+      σ1                ← newTVTy+      σ2'               ← newTVTy+      tyUnOp tcVariant σ2' =: σ2+      σ'                ← maybeGen e0 φ γ (tyUnOp tcVariant (TyRow c σ1 σ2'))+      return ([ex| #$uid:c $e1' |], σ')+    --+    [ex| { $list:flds | $e2 } |] → do+      (flds', e2', σ') ← inferRecordExp False e0 φ δ γ flds e2 mσ+      return ([ex| { $list:flds' | $e2' } |], σ')+    [ex| {+ $list:flds | $e2 +} |] → do+      (flds', e2', σ') ← inferRecordExp True e0 φ δ γ flds e2 mσ+      return ([ex| {+ $list:flds' | $e2' +} |], σ')+    --+    [ex| $e1 . $uid:u |] → do+      (([e1'], σ), αs)  ← collectTVs $ do+        σField            ← newTVTy+        σRow              ← newTVTy+        let σSel = tyBinOp tcRecord tyAf (TyRow u σField σRow) `tyLol` σField+        inferApp δ γ σSel [e1]+      σ'                ← maybeInstGen e0 (request φ γ αs) γ σ+      return ([ex| $e1' . $uid:u |], σ')+    --+    [ex| $e : $annot |]         → do+      σ                 ← tcType δ γ annot+      (e', αs)          ← collectTVs . withPinnedTVs σ $ do+        (e', σ')          ← infer request δ γ e (Just σ)+        σ' ≤ σ+        return e'+      σ'                ← maybeGen e0 (request φ γ αs) γ σ+      return ([ex| $e' : $annot |], σ')+    [ex| $e1 :> $annot |]       → do+      σ                 ← tcType δ γ annot+      let φ'            = prenexFlavors σ request+      (e1', σ1)         ← infer (request φ') δ γ e1 Nothing+      (e', αs)          ← collectTVs (coerceExpression e1' σ1 σ)+      σ'                ← maybeGen e0 (request φ γ αs) γ σ+      return (e', σ')+    --+    [ex| $anti:a |]             → $(AST.antifail)+    [ex| $antiL:a |]            → $(AST.antifail)+    --+  traceN 1 (TraceOut ("infer", σ))+  return σ++-- | Infer the type of a record expression.+inferRecordExp ∷ MonadConstraint tv r m ⇒+                 Bool → AST.Expr R →+                 Request tv → Δ tv → Γ tv →+                 [AST.Field R] → AST.Expr R → Maybe (Type tv) →+                 m ([AST.Field R], AST.Expr R, Type tv)+inferRecordExp bqual e0 φ δ γ flds e2 mσ = do+  let qual = if bqual then tyAf else tyUn+  [_, mσRow]         ← splitCon mσ tcRecord+  let eachFld mσRow' [fdQ| $uid:ui = $ei |] = do+        when bqual . tassert (AST.syntacticValue ei) $+          [msg|+            In an additive-record expression, all fields must be syntactic+            values:+            <dl>+              <dt>field:      <dd>$1+              <dt>expression: <dd>$5:ei+            </dl>+          |] (AST.uidToLid ui)+        (mσi, mσRow'')  ← splitRow mσRow' ui+        (ei', σi)       ← infer request δ γ ei mσi+        tell ([[fdQ| $uid:ui = $ei' |]], Endo (TyRow ui σi))+        return mσRow''+      eachFld _      [fdQ| $antiF:a |] = $(AST.antifail)+  (mσ2, (flds', σs)) ← runWriterT (foldM eachFld mσRow flds)+  (e2', σ2)          ← infer request δ γ e2 (tyBinOp tcRecord qual <$> mσ2)+  σRow               ← newTVTy+  σ2 <: tyBinOp tcRecord qual σRow+  σ'                 ← maybeGen e0 φ γ+                         (tyBinOp tcRecord qual (appEndo σs σRow))+  return (flds', e2', σ')++-- | Infer the type of an n-ary application expression+inferApp ∷ MonadConstraint tv r m ⇒+           Δ tv → Γ tv → Type tv → [AST.Expr R] →+           m ([AST.Expr R], Type tv)+inferApp δ γ ρ e1n = do+  traceN 2 (TraceIn ("inferApp", ρ, e1n))+  (σ1m, σ)              ← funmatchN (length e1n) ρ+  refs                  ← replicateM (length σ1m) (newRef Nothing)+  withPinnedTVs ρ $+    subsumeN [ (σi, do+                      (ei', σi') ← infer (request Exists) δ γ ei (Just σi)+                      writeRef refi (Just ei')+                      traceN 2 ("subsumeI", i, ei, σi', σi)+                      if AST.isAnnotated ei+                        then σi' <: σi+                        else σi' ≤  σi)+             | i    ← [ 0 ∷ Int .. ]+             | refi ← refs+             | σi   ← σ1m+             | ei   ← e1n ]+  e1m'                  ← for refs $+    readRef >=> maybe (typeBug "inferApp" "ref contained Nothing") return+  if length σ1m < length e1n+    then do+      ρ' ← instantiate σ+      first (e1m' ++) <$> inferApp δ γ ρ' (drop (length σ1m) e1n)+    else do+      traceN 2 (TraceOut ("inferApp", σ))+      return (e1m', σ)++-- | Type check a list of pattern match alternatives+tcMatchCases ∷ MonadConstraint tv r m ⇒+               Request tv → Δ tv → Γ tv →+               Type tv → [AST.CaseAlt R] → Maybe (Type tv) →+               m ([AST.CaseAlt R], Type tv)+tcMatchCases _ _ _ _ [] _ = ([],) <$> newTVTy+tcMatchCases φ δ γ σ ([caQ| #$uid:n $opt:mπi → $ei |]:cas) mσ = do+  traceN 3 ("tcMatchCases", φ, σ, "variant", n, mπi, ei)+  β                     ← newTVTy+  σ1                    ← newTVTy+  σ2                    ← newTVTy+  σ ≤≥ TyApp tcVariant [TyRow n σ1 σ2]+  (γ', αs)              ← case mπi of+    Just πi → do+      ((_, σs), αs)         ← collectTVs (tcPatt δ γ πi (Just σ1) ei)+      γ'                    ← γ !+! πi -:*- σs+      return (γ', αs)+    Nothing → do+      σ1 =: tyUnit+      return (γ, [])+  (ei', σi)             ← infer (request φ γ αs) δ γ' ei mσ+  (cas', σk)            ← if null cas+    then do+      σ2 ≤≥ tyNulOp tcRowEnd+      return ([], β)+    else tcMatchCases φ δ γ (TyApp tcVariant [σ2]) cas mσ+  if AST.isAnnotated ei+    then σi <: β+    else σi ≤  β+  σk <: β+  return ([caQ|+ `$uid:n $opt:mπi → $ei' |]:cas', β)+-- Should we do this case automatically like this?:+{-+tcMatchCases φ δ γ σ ([caQ| `$uid:n $opt:mπi → $ei |]:cas) mσ+  | maybe True (isPattTotal γ) mπi = do+  tcMatchCases φ δ γ σ ([caQ| #$uid:n $opt:mπi → $ei |]:cas) mσ+  -}+tcMatchCases φ δ γ σ ([caQ| $πi → $ei |]:cas) mσ = do+  traceN 3 ("tcMatchCases", φ, σ, πi, ei)+  β                     ← newTVTy+  ((_, σs), αs)         ← collectTVs (tcPatt δ γ πi (Just σ) ei)+  γ'                    ← γ !+! πi -:*- σs+  (ei', σi)             ← infer (request φ γ αs) δ γ' ei mσ+  (cas', σk)            ← tcMatchCases φ δ γ σ cas mσ+  if AST.isAnnotated ei+    then σi <: β+    else σi ≤  β+  σk <: β+  return ([caQ|+ $πi → $ei' |]:cas', β)+tcMatchCases _ _ _ _ ([caQ| $antiC:a |]:_) _ = $(AST.antifail)++tcLetRecBindings ∷ MonadConstraint tv r m ⇒+                   Γ tv → [AST.Binding R] →+                   m ([AST.Binding R], [VarId], [Type tv])+tcLetRecBindings γ bs = withTVsOf mempty γ bs $ \δ → tcLetRecBindingsΔ δ γ bs++tcLetRecBindingsΔ ∷ MonadConstraint tv r m ⇒+                    Δ tv → Γ tv → [AST.Binding R] →+                    m ([AST.Binding R], [VarId], [Type tv])+tcLetRecBindingsΔ δ γ bs = do+  (ns, es)          ← unzip <$> mapM unBinding bs+  let mannots       = AST.getExprAnnot <$> es+  σs                ← mapM (maybe newTVTy (tcType δ γ)) mannots+  γ'                ← γ !+! ns -:*- σs+  (es', σs')        ← unzip <$> sequence+    [ do+        tassert (AST.syntacticValue ei)+          [msg|+            In let rec, binding for $q:ni is not a syntactic value.+          |]+        σi ⊏: Qu+        infer request δ γ' ei (σi <$ mannoti)+    | ni        ← ns+    | ei        ← es+    | mannoti   ← mannots+    | σi        ← σs ]+  zipWithM (<:) σs' σs+  σs''              ← generalizeList True (rankΓ γ) σs'+  return (zipWith AST.bnBind ns es', ns, σs'')+  where+    unBinding [bnQ| $vid:x = $e |] = return (x, e)+    unBinding [bnQ| $antiB:a |]    = $(AST.antifail)++---+--- MISCELLANEOUS HELPERS+---++-- | Determine which quantifiers may appear at the beginning of+--   a type scheme, given a list of quantifiers that may be presumed+--   to belong to an unsubstituted variable.+prenexFlavors ∷ Type tv → Request tv' → Request tv'+prenexFlavors σ φ =+  case σ of+    TyQu Exists _ (TyQu Forall _ _) → φ { rqEx = True, rqAll = True }+    TyQu Exists _ (TyVar _)         → φ { rqEx = True }+    TyQu Exists _ _                 → φ { rqEx = True, rqAll = False }+    TyQu Forall _ _                 → φ { rqEx = False, rqAll = True }+    TyVar _                         → φ+    _                               → φ { rqEx = False, rqAll = False }++-- | To compute the qualifier expression for a function type.+arrowQualifier ∷ Ord tv ⇒ Γ tv → AST.Expr R → QExpV tv+arrowQualifier γ e =+  bigJoin [ qualifier (γ =..= n)+          | n      ← M.keys (AST.fv e) ]++---+--- SUBSUMPTION OPERATIONS+---++-- | Given a function arity and a type, extracts a list of argument+--   types and a result type of at most the given arity.+funmatchN ∷ MonadConstraint tv r m ⇒+            Int → Type tv → m ([Type tv], Type tv)+funmatchN n0 σ0 = loop False n0 =<< subst σ0+  where+  loop _    0 σ = return ([], σ)+  loop okay n σ = case σ of+    TyApp tc [σ1, _, σ']        | tc == tcFun+      → first (σ1:) <$> loop True (n - 1) σ'+    TyApp _ _                   | Next σ' ← headReduceType σ+      → loop okay n σ'+    TyVar (Free α)              | tvFlavorIs Universal α+      → do+      β1 ← newTVTy+      qe ← qvarexp . Free <$> newTV' KdQual+      β2 ← newTVTy+      σ =: tyFun β1 qe β2+      return ([β1], β2)+    TyMu _ σ1+      → loop okay n (openTy 0 [σ] σ1)+    _ | okay+      → return ([], σ)+      | otherwise+      → do+      tErrExp_+        [msg| In application expression, operator is not a function: |]+        [msg| $σ |]+        [msg| a function type |]+      βs ← replicateM n newTVTy+      β2 ← newTVTy+      return (βs, β2)++---+--- Testing++test_tcExpr ∷ AST.Expr R →+              IO (Either [AlmsError]+                         (Type (TV IORef), ConstraintState (TV IORef) IORef))+test_tcExpr e =+  runConstraintIO+    constraintState0+    (subst =<< snd <$> tcExpr test_g0 e)+
+ src/Statics/InstGen.hs view
@@ -0,0 +1,277 @@+-- | Instantiation and generalization+module Statics.InstGen (+  -- * Instantiation operations+  instantiate, instantiateNeg, instAllEx, instAll, instEx,+  -- * Type-matching instantiation+  splitCon, splitRow,+  -- * Conditional generalization/instantiation+  Request(..), MkRequest(..),+  maybeGen, maybeInstGen, checkEscapingEx,+  -- * Instantiating type annotation variables+  withTVsOf,+) where++import Util+import qualified AST+import AST.TypeAnnotation+import qualified Syntax.Ppr as Ppr+import qualified Type.Rank as Rank+import Type+import Statics.Env+import Statics.Error+import Statics.Constraint++import Prelude ()+import qualified Data.Map as M++---+--- INSTANTIATION OPERATIONS+---++-- | To instantiate a prenex quantifier with fresh type variables.+instantiate ∷ MonadConstraint tv r m ⇒ Type tv → m (Type tv)+instantiate = instAllEx True True++-- | To instantiate a prenex quantifier with fresh type variables, in+--   a negative position+instantiateNeg ∷ MonadConstraint tv r m ⇒ Type tv → m (Type tv)+instantiateNeg = instAllEx False False++-- | Instantiate the outermost universal and existential quantifiers+--   at the given polarities.+instAllEx ∷ MonadConstraint tv r m ⇒ Bool → Bool → Type tv → m (Type tv)+instAllEx upos epos = subst >=> instEx epos >=> instAll upos++-- | Instantiate an outer universal quantifier.+--   PRECONDITION: σ is fully substituted.+instAll ∷ MonadConstraint tv r m ⇒ Bool → Type tv → m (Type tv)+instAll pos (TyQu Forall αqs σ) = do+  traceN 4 ("instAll/∀", pos, αqs, σ)+  instGeneric 0 (determineFlavor Forall pos) αqs σ+instAll pos (TyQu Exists αqs (TyQu Forall βqs σ)) = do+  traceN 4 ("instAll/∃∀", pos, αqs, βqs, σ)+  TyQu Exists αqs <$> instGeneric 1 (determineFlavor Forall pos) βqs σ+instAll _ σ = return σ++-- | Instantiate an outer existential quantifier.+--   PRECONDITION: σ is fully substituted.+instEx ∷ MonadConstraint tv r m ⇒ Bool → Type tv → m (Type tv)+instEx pos (TyQu Exists αqs σ) = do+  traceN 4 ("instEx", pos, αqs, σ)+  instGeneric 0 (determineFlavor Exists pos) αqs σ+instEx _ σ = return σ++-- | Instantiate type variables and use them to open a type, given+--   a flavor and list of qualifier literal bounds.  Along with the+--   instantiated type, returns any new type variables.+--   PRECONDITION: σ is fully substituted.+instGeneric ∷ MonadConstraint tv r m ⇒+              Int → Flavor → [(a, QLit)] → Type tv →+              m (Type tv)+instGeneric k flav αqs σ = do+  αs ← zipWithM (newTV' <$$> (,flav,) . snd) αqs (inferKinds σ)+  return (openTy k (fvTy <$> αs) σ)++-- | What kind of type variable to create when instantiating+--   a given quantifier in a given polarity:+determineFlavor ∷ Quant → Bool → Flavor+determineFlavor Forall True  = Universal+determineFlavor Forall False = Skolem+determineFlavor Exists True  = Existential+determineFlavor Exists False = Universal++---+--- TYPE-MATCHING INSTANTIATION+---++-- | Given (maybe) a type, and a type constructor,+--   return a list of (maybe) parameter types and returns+--   a list of any new type variables.  The output types are @Nothing@+--   iff the input type is @Nothign@.  If the input type is a type+--   variable, it gets unified with the requested shape over fresh type+--   variables using the given type relation.+--   PRECONDITION: σ is fully substituted.+{-+Instantiates both ∀ and ∃ to univars:+  (λx.x) : A → A          ⇒       (λ(x:A). (x:A)) : A → A+  (λx.x) : ∀α. α → α      ⇒       (λ(x:β). (x:β)) : ∀α. α → α+  (λx.x) : ∀α. C α → C α  ⇒       (λ(x:C β). (x:C β)) : ∀α. C α → C α+  (λx.x) : ∃α. α → α      ⇒       (λ(x:β). (x:β)) : ∃α. α → α+  (λx.x) : ∃α. C α → C α  ⇒       (λ(x:C β). (x:C β)) : ∃α. C α → C α+-}+splitCon ∷ MonadConstraint tv r m ⇒+           -- | Type to split+           Maybe (Type tv) →+           -- | Expected type+           TyCon →+           m ([Maybe (Type tv)])+splitCon Nothing  tc = return (Nothing <$ tcArity tc)+splitCon (Just σ) tc = do+  traceN 4 ("splitCon", σ, tc)+  ρ ← instAllEx True False σ+  loop ρ+  where+  loop ρ = case ρ of+    TyApp tc' σs     | tc == tc'+      → return (Just <$> σs)+                     | Next ρ' ← headReduceType ρ+      → loop ρ'+    _ → return (Nothing <$ tcArity tc)++-- | Like 'splitCon', but for rows.+--   PRECONDITION: σ is fully substituted.+splitRow ∷ MonadConstraint tv r m ⇒+           -- | The type to split+           Maybe (Type tv) →+           -- | The row label that we're expecting+           RowLabel →+           m (Maybe (Type tv), Maybe (Type tv))+splitRow Nothing  _   = return (Nothing, Nothing)+splitRow (Just σ) lab = do+  traceN 4 ("splitRow", σ, lab)+  ρ ← instAllEx True False σ+  loop ρ+  where+  loop ρ = case ρ of+    TyRow lab' τ1 τ2 | lab' == lab+      → return (Just τ1, Just τ2)+                     | otherwise+      → do+        (mτ1, mτ2) ← loop τ2+        return (mτ1, TyRow lab' τ1 <$> mτ2)+    _ → return (Nothing, Nothing)++---+--- CONDITIONAL GENERALIZATION/INSTANTIATION+---++-- A system for specifying requested generalization/instantiation++-- | Used by 'infer' and helpers to specify a requested+--   generalization/instantiation state.+data Request tv+  = Request {+      -- | Request the type to have ∀ quantifiers generalized+      rqAll  ∷ !Bool,+      -- | Request the type to have ∃ quantifiers generalized+      rqEx   ∷ !Bool,+      -- | Require that the existential type variables among these+      --   be generalizable at the given ranks+      rqTVs  ∷ [(tv, Rank.Rank)],+      -- | Rank to which to generalize+      rqRank ∷ !Rank.Rank+    }++instance Ppr.Ppr tv ⇒ Ppr.Ppr (Request tv) where+  ppr φ = (if rqAll φ then Ppr.char '∀' else mempty)+          Ppr.<>+          (if rqEx φ then Ppr.char '∃' else mempty)+          Ppr.<>+          (if null (rqTVs φ)+             then mempty+             else Ppr.ppr (rqTVs φ) Ppr.<>+                  Ppr.char '/' Ppr.<> Ppr.ppr (rqRank φ))++-- | Defines a variadic function for building 'Request' states.  Minimal+--   definition: 'addToRequest'+class MkRequest r tv | r → tv where+  -- | Variadic function that constructs a 'Request' state given some+  --   number of parameters to modify it, as shown by instances below.+  request      ∷ r+  request      = addToRequest Request {+    rqAll   = False,+    rqEx    = False,+    rqTVs   = [],+    rqRank  = Rank.infinity+  }+  addToRequest ∷ Request tv → r++instance MkRequest (Request tv) tv where+  addToRequest = id++instance MkRequest r tv ⇒ MkRequest (Request tv → r) tv where+  addToRequest _ r' = addToRequest r'++instance (Tv tv, MkRequest r tv) ⇒ MkRequest (Γ tv' → [tv] → r) tv where+  addToRequest r γ αs = addToRequest r {+    rqTVs  = [(α, rank) | α ← αs, tvFlavorIs Existential α] ++ rqTVs r,+    rqRank = rank `min` rqRank r+  }+    where rank = rankΓ γ++instance MkRequest r tv ⇒ MkRequest (Rank.Rank → r) tv where+  addToRequest r rank = addToRequest r {+    rqRank = rank `min` rqRank r+  }++instance MkRequest r tv ⇒ MkRequest (Quant → r) tv where+  addToRequest r Forall = addToRequest r { rqAll = True }+  addToRequest r Exists = addToRequest r { rqEx = True }++-- 'maybeGen', 'maybeInst', and 'maybeInstGen' are the external+-- interface to conditional generalization.++-- | Generalize the requested flavors,·+maybeGen ∷ MonadConstraint tv r m ⇒+           AST.Expr R → Request tv → Γ tv → Type tv → m (Type tv)+maybeGen e0 φ γ σ = do+  let value = AST.syntacticValue e0+  traceN 4 ("maybeGen", value, φ, σ)+  checkEscapingEx φ+  (if rqAll φ then generalize value (Rank.inc (rankΓ γ)) else return)+    >=>+    (if rqEx φ then generalizeEx (rankΓ γ `min` rqRank φ) else return)+    >=>+    (if rqAll φ then generalize value (rankΓ γ) else return)+    $ σ++maybeInstGen ∷ MonadConstraint tv r m ⇒+               AST.Expr R → Request tv → Γ tv → Type tv → m (Type tv)+maybeInstGen e φ γ σ = do+  σ' ← case () of+     _ | AST.isAnnotated e → return σ+       | rqAll φ           → return σ+       | rqEx φ            → instAll True =<< subst σ+       | otherwise         → instantiate σ+  maybeGen e φ γ σ'++-- | Check for escaping existential type variables+checkEscapingEx ∷ MonadConstraint tv r m ⇒ Request tv → m ()+checkEscapingEx φ = do+  αrs ← filterM escapes (rqTVs φ)+  tassert (null αrs) $+    case αrs of+      [(α,_)] → [msg| Existential type variable $α escapes its context. |]+      _       → [msg| Existential type variables escape their context: $ul:1 |]+                  [ pprMsg α | (α, _) ← αrs ]+  where+    escapes (α, rank) = (rank >=) <$> getTVRank α++---+--- INSTANTIATING ANNOTATION TYPE VARIABLES+---++-- | Given the environments, a piece of syntax, and a continuation,+--   call the continuation with the type variable environment extended+--   with fresh type variables for any annotation type variables in the+--   piece of syntax.+withTVsOf ∷ (MonadConstraint tv r m, HasAnnotations a R) ⇒+            Δ tv → Γ tv → a → (Δ tv → m b) → m b+withTVsOf δ γ stx kont = do+  let (αs, κs) = unzip (tvsWithKinds γ stx)+  αs' ← zipWithM (\α κ → newTV' (AST.tvqual α, κ)) αs κs+  kont (δ =+= αs =:*= αs')++-- | Given an expression, get its type variables with their kinds+tvsWithKinds ∷ HasAnnotations a R ⇒+               Γ tv → a → [(AST.TyVar R, Kind)]+tvsWithKinds γ = M.toList . annotFtvMap var con cmb where+  var _      = KdType+  con n ix = case γ =..= n of+    Just tc+      | variance:_ ← drop ix (tcArity tc)+      , isQVariance variance+      → \_ → KdQual+    _ → id+  cmb KdQual KdQual = KdQual+  cmb _      _      = KdType
+ src/Statics/Patt.hs view
@@ -0,0 +1,209 @@+-- | Type inference for patterns+module Statics.Patt (+  tcPatt, extractPattAnnot, isPattTotal,+) where++import Util+import qualified AST+import qualified Data.Loc+import qualified Syntax.PprClass as Ppr+import Meta.Quasi+import Message.Quasi+import Type+import Statics.Constraint+import Statics.Env+import Statics.Error+import Statics.InstGen+import Statics.Subsume+import Statics.Type++import Prelude ()+import qualified Data.Map as M++-- | Type check a pattern.+tcPatt ∷ (MonadConstraint tv r m, AST.Fv stx R) ⇒+         -- | type variable environment+         Δ tv →+         -- | environment+         Γ tv →+         -- | pattern to check+         AST.Patt R →+         -- | expected type to match+         Maybe (Type tv) →+         -- | expression in scope of pattern (used to check variable+         --   occurrences)+         stx →+         m (Type tv, [Type tv])+tcPatt δ γ π0 mσ0 e0 = do+  traceN 1 (TraceIn ("inferPatt", δ, π0, mσ0))+  (σ, σs) ← evalRWST (loop π0 mσ0) 0 ()+  traceN 1 (TraceOut ("inferPatt", σ, σs))+  return (σ, σs)+  where+  -- Loop writes the types of bound parameters and reads the number+  -- of occurrences of any surrounding "as" patterns. The latter is so+  -- that if we check a pattern like “π as x”, occurrences of x count+  -- as occurrences of all the variables in π.+  loop π mσ = withLocation π $ case π of+    [pa| _ |]                     → do+      σ ← maybeFresh mσ [msg| unannotated wildcard pattern |]+      return σ+    [pa| $vid:n |]                → do+      σ ← maybeFresh mσ [msg| unannotated parameter $q:n |]+      bind n σ+      return σ+    [pa| $qcid:c $opt:mπ |]         → do+      tcexn ← γ !.! c+      (tc, mσ1) ← case tcexn of+        Left tc   → (tc,) <$> tcCons tc !.! jname c+        Right mσ1 → return (tcExn, mσ1)+      mσs ← splitCon mσ tc+      σs  ← mapM (flip maybeFresh [msg| |]) mσs+      case (mπ, mσ1) of+        (Just π1, Just σ1) → void $ loop π1 (Just (openTy 0 σs (elimEmptyF σ1)))+        (Nothing, Nothing) → return ()+        (Nothing, Just _ ) →+          typeError_ [msg|+            In pattern, unary data constructor $q:c is+            used with no argument.+          |]+        (Just _,  Nothing) →+          typeError_ [msg|+            In pattern, nullary data constructor $q:c is+            applied to an argument.+          |]+      mσ ?≤ TyApp tc σs+    [pa| ($π1, $π2) |]            → do+      [mσ1, mσ2] ← splitCon mσ tcTuple+      σ1 ← loop π1 mσ1+      σ2 ← loop π2 mσ2+      mσ ?≤ tyTuple σ1 σ2+    [pa| $str:_ |]                → tcLitPatt tcString mσ+    [pa| $int:_ |]                → tcLitPatt tcInt mσ+    [pa| $flo:_ |]                → tcLitPatt tcFloat mσ+    [pa| $char:_ |]               → tcLitPatt tcChar mσ+    [pa| $antiL:a |]              → $(AST.antifail)+    [pa| $π1 as $vid:n |]          → do+      σ  ← local (+ occOf n) (loop π1 mσ)+      bind n σ+      return σ+    [pa| `$uid:lab $opt:mπ |]     → do+      [mσRow]    ← splitCon mσ tcVariant+      (mσ1, mσ2) ← splitRow mσRow lab+      let π1 = fromMaybe [pa|+ () |] mπ+      σ1 ← loop π1 mσ1+      σ2 ← maybeFresh mσ2 [msg| |]+      mσ ?≤ TyApp tcVariant [TyRow lab σ1 σ2]+    [pa| $π1 : $annot |]           → do+      σ' ← tcType δ γ annot+      σ  ← mσ ?≤ σ'+      loop π1 (Just σ')+      return σ+    [pa| { $uid:u = $π1 | $π2 } |] → do+      [_, mσRow]        ← splitCon mσ tcRecord+      (mσ1, mσ2)        ← splitRow mσRow u+      σ1                ← loop π1 mσ1+      σ2                ← loop π2 (tyRecord tyUn <$> mσ2)+      σ2'               ← newTVTy+      tyRecord tyUn σ2' =: σ2+      mσ ?≤ tyRecord tyUn (TyRow u σ1 σ2')+    [pa| ! $_ |]                  →+      typeBug "tcPatt" "Encountered bang (!) pattern"+    [pa| $anti:a |]               → $(AST.antifail)+  --+  occOf n  = fromMaybe 0 (M.lookup (J [] n) (AST.fv e0))+  bind n τ = do+    as_occs ← ask+    τ ⊏: occOf n + as_occs+    tell [τ]+  --+  maybeFresh mσ message = case mσ of+    Nothing → newTVTy' (Ppr.ppr message)+    Just σ  → do+      σ' ← subst σ+      case σ' of+        TyVar (Free α) → reportTVs [α]+        _ → return ()+      return σ'+  --+  Nothing ?≤ σ' = return σ'+  Just σ  ?≤ σ' = do σ ≤ σ'; return σ++tcLitPatt ∷ MonadConstraint tv r m ⇒+            TyCon → Maybe (Type tv) → m (Type tv)+tcLitPatt tc mσ = do+  let σ' = tyNulOp tc+  maybe (return ()) (=: σ') mσ+  return σ'++isPattTotal ∷ Γ tv → AST.Patt R → Bool+isPattTotal γ = loop where+  loop [pa| _ |]                = True+  loop [pa| $vid:_ |]           = True+  loop [pa| $qcid:n $opt:mπ |]  =+    maybe False oneCon (γ =..= n) && maybe True loop mπ+    where+      oneCon (Left tc) = numberOfKeys (tcCons tc) == 1+      oneCon (Right _) = False+  loop [pa| ($π1, $π2) |]       = loop π1 && loop π2+  loop [pa| $lit:_ |]           = False+  loop [pa| $π as $vid:_ |]     = loop π+  loop [pa| `$uid:_ $opt:_ |]   = False+  loop [pa| $π : $_ |]          = loop π+  loop [pa| { $uid:_ = $π1 | $π2 } |]+                                = loop π1 && loop π2+  loop [pa| ! $π |]             = loop π+  loop [pa| $anti:a |]          = $(AST.antierror)++-- | Extract and instantiate the annotations in a pattern as an annotation.+extractPattAnnot ∷ MonadConstraint tv r m ⇒+                   Δ tv → Γ tv → AST.Patt R → m (Maybe (Type tv))+extractPattAnnot δ γ = loop where+  loop [pa| _ |]                = return Nothing+  loop [pa| $vid:_ |]           = return Nothing+  loop [pa| $qcid:_ $opt:_ |]   = return Nothing+  loop [pa| ($π1, $π2) |]       = do+    mσ1 ← loop π1+    mσ2 ← loop π2+    case (mσ1, mσ2) of+      (Just σ1, Just σ2)   → return (Just (tyTuple σ1 σ2))+      (Nothing, Just σ2)   → Just . flip tyTuple σ2 <$> newTVTy+      (Just σ1, Nothing)   → Just . tyTuple σ1 <$> newTVTy+      (Nothing, Nothing)   → return Nothing+  loop [pa| $lit:_ |]           = return Nothing+  loop [pa| $π as $vid:_ |]     = loop π+  loop [pa| `$uid:_ |]          = return Nothing+  loop [pa| `$uid:uid $π |]     = do+    mσ ← loop π+    case mσ of+      Just σ  → Just . TyRow uid σ <$> newTVTy+      Nothing → return Nothing+  loop [pa| $_ : $annot |]      = Just <$> tcType δ γ annot+  loop [pa| { $uid:uid = $π1 | $π2 } |]+                                = do+    mσ1 ← loop π1+    mσ2 ← loop π2+    case (mσ1, mσ2) of+      (Just σ1, Just (TyApp _ [qual, σ2])) →+        return (Just (tyRecord qual (TyRow uid σ1 σ2)))+      (Nothing, Just (TyApp _ [qual, σ2])) → do+        σ1 ← newTVTy+        return (Just (tyRecord qual (TyRow uid σ1 σ2)))+      (Just σ1, _) → do+        qual ← newTVTy' KdQual+        σ2   ← newTVTy+        return (Just (tyRecord qual (TyRow uid σ1 σ2)))+      (Nothing, _) → return Nothing+  loop [pa| ! $π |]             = loop π+  loop [pa| $anti:a |]          = $(AST.antierror)++-- | Bind a pattern to a list of types.+instance GenNewEnv (AST.Patt R) [Type tv] VarId (Type tv) where+  π -:*- σs = AST.dv π -:*- σs++{-+test_tcPatt π e =+  runConstraintIO+    constraintState0+    (subst =<< tcPatt mempty test_g0 π Nothing e)+-}
+ src/Statics/Rename.hs view
@@ -0,0 +1,1072 @@+module Statics.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, renameSigItem,+  -- * REPL query+  getRenamingInfo, RenamingInfo(..),+  renamingEnterScope,+) where++import Error++import Meta.Quasi+import AST hiding ((&))+import Data.Loc+import AST.TypeAnnotation+import qualified AST.Notable+import Util+import Syntax.Ppr (Ppr(..))++import Prelude ()+import qualified Data.Map as M+import qualified Data.Set as S++-- | 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 (ident "()") (ident "()", mkBogus "built-in", ())+  },+  savedCounter  = renamed0+}++-- | Generate a renamer error.+renameErrorStop :: Message V -> R a+renameErrorStop msg0 = do+  throwAlms (AlmsError RenamerPhase bogus msg0)++-- | Generate a renamer error, but keep going.+renameError :: Bogus a => Message V -> R a+renameError msg0 = do+  reportAlms (AlmsError RenamerPhase bogus msg0)+  return bogus++renameBug :: String -> String -> R a+renameBug culprit msg0 = do+  throwAlms (almsBug RenamerPhase culprit msg0)++-- | 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 RState (AlmsErrorT Identity) a+} deriving (Functor, MonadAlmsError)++-- | The threaded state of the renamer.+newtype RState = RState {+  -- | The gensym counter:+  rsCounter :: Renamed+}++instance Monad Renaming where+  return  = R . return+  m >>= k = R (unR m >>= unR . k)+  fail    = renameErrorStop . [msg| $words:1 |]++instance Applicative Renaming where+  pure  = return+  (<*>) = ap++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 [AlmsError] Renaming where+  throwError = throwAlmsList+  catchError = catchAlms++-- | The renaming environment+data Env = Env {+  tycons          :: !(EnvMap TypId  [ConId Raw]),+  vars            :: !(EnvMap VarId  ()),+  datacons        :: !(EnvMap ConId  ()),+  modules         :: !(EnvMap ModId  (Module, Env)),+  sigs            :: !(EnvMap SigId  (Module, Env)),+  tyvars          :: !(EnvMap Lid    (QLit, 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.+type Module = [ModItem]++data ModItem+  = MdTycon   !Loc !(TypId Raw) !(TypId Renamed) ![ConId Raw]+  | MdVar     !Loc !(VarId Raw) !(VarId Renamed)+  | MdDatacon !Loc !(ConId Raw) !(ConId Renamed)+  | MdModule  !Loc !(ModId Raw) !(ModId Renamed) !Module+  | MdSig     !Loc !(SigId Raw) !(SigId 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,+  inExpr   :: !Bool+}++-- | Run a renaming computation+runRenaming :: Bool -> Loc -> RenameState -> Renaming a ->+               Either [AlmsError] (a, RenameState)+runRenaming nonTrivial loc saved action = do+  runIdentity $+    runAlmsErrorT $ withLocation loc $ do+      (result, rstate, md) <-+        runRWST (unR action)+          Context {+            env      = savedEnv saved,+            allocate = nonTrivial,+            inExpr   = False+          }+          RState {+            rsCounter = savedCounter saved+          }+      let env' = savedEnv saved `mappend` envify md+      return (result, RenameState env' (rsCounter rstate))++-- | Run a renaming computation+runRenamingM :: MonadAlmsError m =>+                Bool -> Loc -> RenameState -> Renaming a ->+                m (a, RenameState)+runRenamingM = either throwAlmsList 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 Bogus Env where bogus = mempty++-- | Open a module into an environment+envify :: Module -> Env+envify  = foldMap envifyItem++envifyItem :: ModItem -> Env+envifyItem (MdTycon loc l l' dcs)+  = mempty { tycons   = M.singleton l (l', loc, dcs) }+envifyItem (MdVar loc l l')+  = mempty { vars = M.singleton l (l', loc, ()) }+envifyItem (MdDatacon loc u u')+  = mempty { datacons = M.singleton u (u', loc, ()) }+envifyItem (MdModule loc u u' md)+  = mempty { modules = M.singleton u (u',loc,(md,envify md)) }+envifyItem (MdSig loc u u' md)+  = mempty { sigs = M.singleton u (u',loc,(md,envify md)) }+envifyItem (MdTyvar loc tv tv')+  = mempty { tyvars = M.singleton (tvname tv)+                                  (tvname tv',loc,(tvqual tv', True)) }++-- | Like 'asks', but in the 'R' monad+withContext :: (Context -> R a) -> R a+withContext  = R . (ask >>=) . fmap 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++-- | Add the free annotation type variables in the given syntax+--   for the context of the action.+withAnnotationTVs :: HasAnnotations s Raw => s -> R a -> R a+withAnnotationTVs stx action = do+  skip <- R (asks inExpr)+  ((), md) <- steal $+    if skip+      then return ()+      else traverse_ bindTyvar (annotFtvSet stx)+  inModule md (R (local (\e -> e { inExpr = True }) (unR action)))++-- | Hide any annotation type variables that were in scope.+hideAnnotationTVs :: R a -> R a+hideAnnotationTVs = +  R . local (\e -> e { inExpr = False }) . unR .+    local (\e -> e { tyvars = each <$> tyvars e })+  where each (a, b, (c, _)) = (a, b, (c, False))++-- | 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 :: (Ppr a, Bogus b) => String -> a -> R b+unbound ns a =+  renameError [msg| $words:ns not in scope: $q:a |]++-- | Generate an error about a name declared twice+repeatedMsg :: Ppr a => String -> a -> String -> [Loc] -> Message V+repeatedMsg what a inwhat locs =+  [msg|+    $words:what $a+    repeated $words:times in $words:inwhat $words:at+    $ul:slocs+  |]+  where+    times = case length locs of+      0 -> ""+      1 -> ""+      2 -> "twice"+      3 -> "thrice"+      _ -> show (length locs) ++ " times"+    at    = if length locs > 1 then "at:" else ""+    slocs = map [msg| $show:1 |] locs++-- | Generate an error about a name declared twice+repeated :: (Ppr a, Bogus b) => String -> a -> String -> [Loc] -> R b+repeated what a inwhat locs =+  renameError $ repeatedMsg what [msg| $q:a |] inwhat locs++-- | Generate an error about a name declared twice+repeatedTVs :: Bogus b => [TyVar i] -> String -> R b+repeatedTVs []  _             = renameBug "repatedTVs" "got empty list"+repeatedTVs tvs@(tv:_) inwhat =+  let quals  = ordNub (tvqual <$> tvs)+      name   = tvname tv+      bothQs = length quals > 1+      callIt = if bothQs then [msg| `$name / '$name |] else [msg| $tv |]+      msg0   = repeatedMsg "Type variable" callIt inwhat (getLoc <$> tvs)+   in renameError $+        if bothQs+          then [msg|+                  $msg0+                  <indent>+                    (Type variables with the same name but different+                    qualifiers may not appear in the same scope.)+                  </indent>+                |]+          else msg0++-- | Are all keys of the list unique?  If not, return the key and+--   list of two or more values with the same keys+unique       :: Ord a => (b -> a) -> [b] -> Maybe (a, [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 (k, x' : x : filter ((== k) . getKey) xs)++-- | 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 -> [QVarId Renamed]+getAllVariables = S.toList . foldMap loop where+  loop (MdVar _ _ l')       = S.singleton (J [] l')+  loop (MdModule _ _ u' md) = S.mapMonotonic (\(J us l) -> J (u':us) l)+                                             (foldMap loop md)+  loop _                    = S.empty++-- | Look up something in an environment+envLookup :: (Ord k, Show k) =>+             (Env -> M.Map k k') ->+             Path (ModId Raw) k ->+             Env ->+             Either (Maybe (Path (ModId Renamed) (ModId Raw)))+                    (Path (ModId 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, Bogus k') =>+              String -> (Env -> M.Map k k') ->+              Path (ModId Raw) k -> R (Path (ModId 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), Bogus i, Bogus (f Renamed)) =>+              String -> (Env -> EnvMap f i) ->+              Path (ModId Raw) (f Raw) -> R (Path (ModId Renamed) (f Renamed))+getGeneric = liftM (fmap (\(qx', _, _) -> qx')) <$$$> getGenericFull++-- | Look up a variable in the environment+getVar :: QVarId Raw -> R (QVarId Renamed)+getVar  = getGeneric "Variable" vars++-- | Look up a data constructor in the environment+getDatacon :: QConId Raw -> R (QConId Renamed)+getDatacon  = getGeneric "Data constructor" datacons++-- | Look up a type in the environment+getTycon :: QTypId Raw -> R (QTypId Renamed)+getTycon  = getGeneric "Type constructor" tycons++-- | Look up a type with constructors in the environment+getTyconFull :: QTypId Raw -> R (QTypId Renamed, [ConId Raw])+getTyconFull qtid = do+  J ps (tid, _, cids) <- getGenericFull "Type name" tycons qtid+  return (J ps tid, cids)++-- | Look up a module in the environment+getModule :: QModId Raw -> R (QModId 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 :: QSigId Raw -> R (QSigId Renamed, Module, Env)+getSig  = liftM pull . getGenericFull "Signature" sigs+  where+    pull (J ps (qu, _, (m, e))) = (J ps qu, m, e)++-- | Look up a type variable in the environment. This is complicated,+--   because there are several possibilities.+getTyvar :: TyVar Raw -> R (TyVar Renamed)+getTyvar tv@(TV name ql _) = do+  e <- asks tyvars+  case M.lookup name e of+    -- If the type variable isn't found in the block-structured type+    -- variable environment, that is an error.+    Nothing                          -> do+      renameError [msg| Type variable $tv is not in scope. |]+    --+    -- If the type variable *is* found in the bound type variable+    -- environment, we need to check if it's in the current scope or+    -- hidden, and if it's in the current scope, whether the qualifier+    -- matches.  If the qualifier doesn't match or if it's hidden, that+    -- is an error.+    Just (name', loc', (ql', True))+      | ql == ql'                    -> return (TV name' ql' loc')+      | otherwise                    ->+      renameError $+        [msg|+          Type variable $tv is not in scope.+          <indent>+             (Type variable $1 was bound at $loc', but the same+             type variable name may not occur with different qualifiers+             in the same scope.)+          </indent>+        |] (TV name' ql' loc')+    --+    Just (_,     loc', (_,   False)) -> do+      renameError+        [msg|+          Type variable $tv is not in scope.+          <indent>+             (It was bound at $loc', but a nested declaration+              can neither see nor shadow type variables from its+              parent expression.)+          </indent>+        |]+getTyvar (TVAnti a) = $antifail++-- | Get a new name for a variable binding+bindGeneric :: (Ord ident, Show ident, Antible ident) =>+               (Renamed -> ident -> ident') ->+               (Loc -> ident -> ident' -> ModItem) ->+               ident -> R ident'+bindGeneric ren build x = do+  case prjAnti x of+    Just a  -> $antifail+    Nothing -> return ()+  new <- newRenamed+  loc <- getLocation+  let x' = ren new x+  tell [build loc x x']+  return x'++-- | Allocate a new 'Renamed' token if we're in the right mode.+newRenamed :: R Renamed+newRenamed = R $ do+  doAlloc <- asks allocate+  if doAlloc+    then do+      rstate  <- get+      put rstate { rsCounter = succ (rsCounter rstate) }+      return (rsCounter rstate)+    else do+      return trivialId++-- | Get a new name for a variable binding+bindVar :: VarId Raw -> R (VarId Renamed)+bindVar  = bindGeneric renId MdVar++-- | Get a new name for a variable binding+bindTycon :: TypId Raw -> [ConId Raw] -> R (TypId Renamed)+bindTycon l0 dcs = bindGeneric renId build l0+  where build loc old new = MdTycon loc old new dcs++-- | Get a new name for a data constructor binding+bindDatacon :: ConId Raw -> R (ConId Renamed)+bindDatacon = bindGeneric renId MdDatacon++-- | Get a new name for a module, and bind it in the environment+bindModule :: ModId Raw -> Module -> R (ModId Renamed)+bindModule u0 md = bindGeneric renId 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 :: SigId Raw -> Module -> R (SigId Renamed)+bindSig u0 md = bindGeneric renId 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 tv = do+  e <- asks tyvars+  case M.lookup (tvname tv) e of+    Nothing                      -> bindGeneric renId MdTyvar tv+    Just (name', loc', (ql', _)) ->+      if tvqual tv == ql'+        then+          renameError $+            [msg|+              Cannot shadow type variable $tv; it is already+              bound at $loc'.+            |]+        else+          renameError $+            [msg|+              Cannot introduce type variable $tv, because $1 is+              already bound at $loc'.  The same type variable name cannot+              appear in the same scope with different qualifiers.+            |] (TV name' ql' loc')++-- | 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 $ traverse 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 = withLocation d0 $ case d0 of+  [dc| let $x = $e |] -> do+    x'  <- renamePatt x+    e'  <- renameExpr e+    return [dc|+ let $x' = $e' |]+  [dc| let rec $list:bns |] -> do+    (bns', md) <- renameBindings bns+    tell md+    return [dc|+ let rec $list:bns' |]+  [dc| type $tid:lhs = type $qtid:rhs |] -> do+    (rhs', dcs) <- getTyconFull rhs+    lhs'        <- bindTycon lhs dcs+    mapM_ bindDatacon dcs+    return [dc|+ type $tid:lhs' = type $qtid:rhs' |]+  [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) = withLocation 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, locs) ->+        repeated "Type declaration for" l "abstype group" (snd <$> locs)+    (ats', mdD) <-+      steal $+        inModule mdT $+          forM ats $ \at -> withLocation 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 = ident "INTERNALS"+      (me1', md) <- steal $ renameModExp me1+      u' <- bindModule u md+      return [dc|+ module $mid:u' = $me1' |]+  [dc| module $mid:u = $me1 |] -> do+    (me1', md) <- steal $ renameModExp me1+    u' <- bindModule u md+    return [dc|+ module $mid:u' = $me1' |]+  [dc| module type $sid:u = $se1 |] -> do+    (se1', md) <- steal $ renameSigExp se1+    u' <- bindSig u md+    return [dc|+ module type $sid: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 $cid:u of $opt:mt |] -> do+    u'  <- bindDatacon u+    mt' <- traverse renameType mt+    return [dc|+ exception $cid:u' of $opt:mt' |]+  [dc| $anti:a |] -> $antifail++renameTyDecs :: [TyDec Raw] -> R [TyDec Renamed]+renameTyDecs tds = withLocation tds $ do+  let bindEach [tdQ| $anti:a |] = $antifail+      bindEach (N note td)       = withLocation note $ do+        bindTycon (tdName td) (tdMaybeCons td)+        return (tdName td, getLoc note)+  (llocs, md) <- listen $ mapM bindEach tds+  case unique fst llocs of+    Nothing -> return ()+    Just (l, locs) ->+      repeated "Type declaration for" l "type group" (snd <$> locs)+  inModule md $ mapM (liftM snd . renameTyDec Nothing) tds++tdMaybeCons :: TyDec' Raw -> [ConId Raw]+tdMaybeCons TdDat { tdAlts = alts } = fst <$> alts+tdMaybeCons _                       = []++renameTyDec :: Maybe (QExp Raw) -> TyDec Raw ->+               R (Maybe (QExp Renamed), TyDec Renamed)+renameTyDec _   (N _ (TdAnti a)) = $antierror+renameTyDec mqe (N note (TdSyn l clauses)) = withLocation note $ do+  case mqe of+    Nothing -> return ()+    Just _  ->+      renameBug "renameTyDec" "can’t rename QExp in context of type synonym"+  J [] l' <- getTycon (J [] l)+  clauses' <- forM clauses $ \(ps, rhs) -> withLocation 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)      = withLocation note $ do+  J [] l' <- getTycon (J [] (tdName td))+  let tvs = tdParams td+  case unique tvname tvs of+    Nothing        -> return ()+    Just (_, tvs') -> repeatedTVs tvs' "type parameters"+  (tvs', mdTvs) <- steal $ mapM bindTyvar tvs+  inModule mdTvs $ do+    mqe' <- traverse renameQExp mqe+    td'  <- case td of+      TdAbs _ _ variances gs qe -> do+        qe' <- renameQExp qe+        gs' <- ordNub <$> mapM getTyvar gs+        return (tdAbs l' tvs' variances gs' qe')+      TdSyn _ _ -> renameBug "renameTyDec" "unexpected TdSyn"+      TdDat _ _ cons -> do+        case unique fst cons of+          Nothing -> return ()+          Just (u, _) ->+            repeated "Data constructor" u "type declaration" []+        cons' <- forM cons $ \(u, mt) -> withLocation mt $ do+          -- XXX Why trivial?+          let u' = renTrivial u+          tell [MdDatacon (getLoc mt) u u']+          mt'   <- traverse 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 = withLocation me0 $ case me0 of+  [meQ| struct $list:ds end |] -> do+    ds' <- renameDecls ds+    return [meQ|+ struct $list:ds' end |]+  [meQ| $qmid:qu $list:_ |] -> do+    (qu', md, _) <- getModule qu+    let qls = getAllVariables md+    tell md+    return [meQ|+ $qmid:qu' $list:qls |]+  [meQ| $me1 : $se2 |] -> do+    (me1', md1) <- steal $ renameModExp me1+    (se2', md2) <- steal $ renameSigExp se2+    onlyInModule md1 $ sealWith md2+    return [meQ| $me1' : $se2' |]+  [meQ| $anti:a |] -> $antifail++renameSigExp :: SigExp Raw -> R (SigExp Renamed)+renameSigExp se0 = withLocation 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| $qsid:qu $list:_ |] -> do+    (qu', md, _) <- getSig qu+    let qls = getAllVariables md+    tell md+    return [seQ|+ $qsid:qu' $list:qls |]+  [seQ| $se1 with type $list:tvs $qtid:ql = $t |] -> do+    (se1', md) <- listen $ renameSigExp se1+    ql' <- onlyInModule md $ getTycon ql+    case unique id tvs of+      Nothing      -> return ()+      Just (_, tvs') -> repeatedTVs tvs' "with-type"+    (tvs', mdtvs) <- steal $ mapM bindTyvar tvs+    t' <- inModule mdtvs $ renameType t+    return [seQ|+ $se1' with type $list:tvs' $qtid:ql' = $t' |]+  [seQ| $anti:a |] -> $antifail++checkSigDuplicates :: Module -> R ()+checkSigDuplicates md = case md of+    []                   -> return ()+    md1:md2              -> do+      checkItem md1+      inModule [md1] $ checkSigDuplicates md2++  where+    checkItem item = case item of+      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+    mustFail loc kind which check = do+      failed <- (False <$ check) `catchError` \_ -> return True+      unless failed $ do+        withLocation loc $+          repeated kind which "signature" []++sealWith :: Module -> R ()+sealWith = mapM_ (each Nothing) where+  each b moditem = case moditem of+    MdTycon   _ l _ _  -> do+      (l', loc, cs') <- locate b "type constructor" tycons l+      tell [MdTycon loc l l' cs']+    MdVar     _ l _   -> do+      (l', loc, _) <- locate b "variable" vars l+      tell [MdVar loc l l']+    MdDatacon _ u _   -> do+      (u', loc, _) <- locate b "data constructor" datacons u+      tell [MdDatacon loc u u']+    MdModule  _ u _ md2 -> do+      (u', loc, (md1, _)) <- locate b "module" modules u+      ((), md1') <- steal $ onlyInModule md1 $ mapM_ (each b) md2+      tell [MdModule loc u u' md1']+    MdSig     _ u _ md2 -> do+      (u', loc, (md1, _)) <- locate b "module type" sigs u+      ((), _   ) <- steal $ onlyInModule md2 $ mapM_ (each (Just (Left u))) md1+      ((), md1') <- steal $ onlyInModule md1 $ mapM_ (each (Just (Right u))) md2+      tell [MdSig loc u u' md1']+    MdTyvar   _ _ _   ->+      renameBug "sealWith" "signature can’t declare type variable"+  locate b what prj name = do+    m <- asks prj+    case M.lookup name m of+      Just name' -> return name'+      Nothing    -> renameError $+        case b of+          Nothing -> [msg|+            In signature matching, structure is missing+            $words:what $q:name,+            which is present in ascribed signature.+          |]+          Just (Left u) -> [msg|+            In exact signature matching (for nested signature $u)+            found unexpected $words:what $q:name.+          |]+          Just (Right u) -> [msg|+            In exact signature matching (for nested signature $u)+            missing expected $words:what $q:name.+          |]++-- | Rename a signature item and return the environment+--   that they bind+renameSigItem :: SigItem Raw -> R (SigItem Renamed)+renameSigItem sg0 = withLocation sg0 $ case sg0 of+  [sgQ| val $vid:l : $t |] -> do+    l' <- bindVar l+    t' <- renameType (closeType t)+    return [sgQ|+ val $vid:l' : $t' |]+  [sgQ| type $list:tds |] -> do+    tds' <- renameTyDecs tds+    return [sgQ|+ type $list:tds' |]+  [sgQ| type $tid:lhs = type $qtid:rhs |] -> do+    (rhs', dcs) <- getTyconFull rhs+    lhs'        <- bindTycon lhs dcs+    mapM_ bindDatacon dcs+    return [sgQ|+ type $tid:lhs' = type $qtid:rhs' |]+  [sgQ| module $mid:u : $se1 |] -> do+    (se1', md) <- steal $ renameSigExp se1+    u' <- bindModule u md+    return [sgQ|+ module $mid:u' : $se1' |]+  [sgQ| module type $sid:u = $se1 |] -> do+    (se1', md) <- steal $ renameSigExp se1+    u' <- bindSig u md+    return [sgQ|+ module type $sid:u' = $se1' |]+  [sgQ| include $se1 |] -> do+    se1' <- renameSigExp se1+    return [sgQ|+ include $se1' |]+  [sgQ| exception $cid:u of $opt:mt |] -> do+    u'  <- bindDatacon u+    mt' <- traverse renameType mt+    return [sgQ|+ exception $cid:u' of $opt:mt' |]+  [sgQ| $anti:a |] -> $antifail++-- | Rename an expression+renameExpr :: Expr Raw -> R (Expr Renamed)+renameExpr e00 = withAnnotationTVs e00 $ loop e00 where+  loop e0 = withLocation e0 $ case e0 of+    [ex| $qvid:ql |] -> do+      ql' <- getVar ql+      return [ex|+ $qvid:ql' |]+    [ex| $lit:lit |] -> do+      lit' <- renameLit lit+      return [ex|+ $lit:lit' |]+    [ex| $qcid:qu $opt:me |] -> do+      qu' <- getDatacon qu+      me' <- traverse loop me+      return [ex|+ $qcid:qu' $opt:me' |]+    [ex| `$uid:u $opt:me |] -> do+      let u' = renTrivial u+      me' <- traverse loop me+      return [ex|+ `$uid:u' $opt:me' |]+    [ex| #$uid:u $e |] -> do+      let u' = renTrivial u+      e' <- loop e+      return [ex|+ #$uid:u' $e' |]+    [ex| let $x = $e1 in $e2 |] -> do+      (x', md) <- steal $ renamePatt x+      e1' <- loop e1+      e2' <- inModule md $ loop e2+      return [ex| let $x' = $e1' in $e2' |]+    [ex| match $e1 with $list:cas |] -> do+      e1'  <- loop 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 $ loop e+      return [ex|+ let rec $list:bns' in $e' |]+    [ex| let $decl:d in $e |] -> do+      (d', md) <- steal . hideAnnotationTVs $ renameDecl d+      e' <- inModule md (loop e)+      return [ex|+ let $decl:d' in $e' |]+    [ex| ($e1, $e2) |] -> do+      e1' <- loop e1+      e2' <- loop e2+      return [ex|+ ($e1', $e2') |]+    [ex| fun $x -> $e |] -> do+      (x', md) <- steal $ renamePatt x+      e' <- inModule md $ loop e+      return [ex|+ fun $x' -> $e' |]+    [ex| $e1 $e2 |] -> do+      e1' <- loop e1+      e2' <- loop e2+      return [ex|+ $e1' $e2' |]+    [ex| { $list:flds | $e2 } |] -> do+      flds' <- mapM renameField flds+      e2'   <- loop e2+      return [ex|+ { $list:flds' | $e2' } |]+    [ex| {+ $list:flds | $e2 +} |] -> do+      flds' <- mapM renameField flds+      e2'   <- loop e2+      return [ex|+ {+ $list:flds' | $e2' +} |]+    [ex| $e1.$uid:u |] -> do+      let u' = renTrivial u+      e1' <- loop e1+      return [ex|+ $e1'.$uid:u' |]+    [ex| ( $e : $t) |] -> do+      e'  <- loop e+      t'  <- renameType t+      return [ex| ( $e' : $t' ) |]+    [ex| ( $e :> $t) |] -> do+      e'  <- loop 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 = withLocation ca0 $ case ca0 of+  [caQ| $x -> $e |] -> do+    (x', md) <- steal $ renamePatt x+    e' <- inModule md $ renameExpr e+    return [caQ|+ $x' -> $e' |]+  [caQ| #$uid:lab -> $e |] -> do+    let lab' = renTrivial lab+    e' <- renameExpr e+    return [caQ|+ #$uid:lab' -> $e' |]+  [caQ| #$uid:lab $x -> $e |] -> do+    let lab' = renTrivial lab+    (x', md) <- steal $ renamePatt x+    e' <- inModule md $ renameExpr e+    return [caQ|+ #$uid:lab' $x' -> $e' |]+  [caQ| $antiC:a |] -> $antifail++-- | Rename a set of let rec bindings+renameBindings :: [Binding Raw] -> R ([Binding Renamed], Module)+renameBindings bns = withAnnotationTVs bns $ withLocation bns $ do+  lxes <- forM bns $ \bn ->+    case bn of+      [bnQ| $vid:x = $e |] -> return (_loc, x, e)+      [bnQ| $antiB:a |]    -> $antifail+  case unique (\(_,x,_) -> x) lxes of+    Nothing          -> return ()+    Just (x, locs) ->+      repeated "Variable binding for" x "let-rec" (sel1 <$> locs)+  let bindEach rest (l,x,e) = withLocation l $ do+        x' <- bindVar x+        return ((l,x',e):rest)+  (lxes', md) <- steal $ foldM bindEach [] lxes+  bns' <- inModule md $+            forM (reverse lxes') $ \(l,x',e) -> withLocation l $ do+              let _loc = l+              e'  <- renameExpr e+              return [bnQ|+ $vid:x' = $e' |]+  return (bns', md)++-- | Rename a record field+renameField :: Field Raw → R (Field Renamed)+renameField [fdQ| $uid:u = $e |] = do+  let u' = renTrivial u+  e' ← renameExpr e+  return [fdQ|+ $uid:u' = $e' |]+renameField [fdQ| $antiF:a |] = $antifail++-- | Rename a type+renameType :: Type Raw -> R (Type Renamed)+renameType t0 = withLocation t0 $ case t0 of+  [ty| ($list:ts) $qtid:ql |] -> do+    ql' <- getTycon ql+    ts' <- mapM renameType ts+    return [ty|+ ($list:ts') $qtid:ql' |]+  [ty| '$tv |] -> do+    tv' <- getTyvar tv+    return [ty|+ '$tv' |]+  [ty| $t1 -[$opt:mqe]> $t2 |] -> do+    t1'  <- renameType t1+    mqe' <- traverse renameQExp mqe+    t2'  <- renameType t2+    return [ty|+ $t1' -[$opt:mqe']> $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| `$uid:u of $t1 | $t2 |] -> do+    let u' = renTrivial u+    t1' <- renameType t1+    t2' <- renameType t2+    return [ty| `$uid:u' of $t1' | $t2' |]+  [ty| $anti:a |] -> $antifail++-- | Rename a type pattern+renameTyPats :: [TyPat Raw] -> R [TyPat Renamed]+renameTyPats x00 = evalStateT (mapM loop x00) M.empty where+  loop :: TyPat Raw ->+          StateT (M.Map (Lid Raw) (TyVar Raw, Loc)) Renaming (TyPat Renamed)+  loop x0 = withLocation x0 $ case x0 of+    [tpQ| $antiP:a |] -> $antifail+    N note (TpVar tv var) -> do+      tv' <- tyvar (getLoc note) tv+      return (tpVar tv' var <<@ note)+    N note (TpRow tv var) -> do+      tv' <- tyvar (getLoc note) tv+      return (tpRow tv' var <<@ note)+    [tpQ| ($list:tps) $qtid:ql |] -> do+      ql'  <- lift (withLocation _loc (getTycon ql))+      tps' <- mapM loop tps+      return [tpQ|+ ($list:tps') $qtid:ql' |]+  --+  tyvar :: Loc -> TyVar Raw ->+           StateT (M.Map (Lid Raw) (TyVar Raw, Loc)) Renaming (TyVar Renamed)+  tyvar loc1 tv = do+    seen <- get+    case M.lookup (tvname tv) seen of+      Just (tv', _) ->+        lift (repeatedTVs [tv,tv'] "type parameters")+      Nothing   -> do+        put (M.insert (tvname tv) (tv, loc1) seen)+        lift (bindTyvar tv)++-- | Rename a qualifier expression+renameQExp :: QExp Raw -> R (QExp Renamed)+renameQExp qe0 = withLocation qe0 $ case qe0 of+  [qeQ| $qlit:qlit |] -> do+    return [qeQ|+ $qlit:qlit |]+  [qeQ| $qvar:tv |] -> do+    tv' <- getTyvar tv+    return [qeQ| $qvar:tv' |]+  [qeQ| $qe1 \/ $qe2 |] -> do+    qe1' <- renameQExp qe1+    qe2' <- renameQExp qe2+    return [qeQ| $qe1' \/ $qe2' |]+  [qeQ| $anti:a |] -> do+    $antifail++-- | Rename a pattern+renamePatt :: Patt Raw -> R (Patt Renamed)+renamePatt x00 = evalStateT (loop x00) M.empty where+  loop :: Patt Raw ->+          StateT (M.Map (VarId Raw) Loc)+            Renaming (Patt Renamed)+  loop x0 = withLocation x0 $ case x0 of+    [pa| _ |] ->+      return [pa|+ _ |]+    [pa| $vid:l |] -> do+      l' <- var _loc l+      return [pa|+ $vid:l' |]+    [pa| $qcid:qu $opt:mx |] -> do+      qu' <- lift $ getDatacon qu+      mx' <- traverse loop mx+      return [pa|+ $qcid:qu' $opt:mx' |]+    [pa| `$uid:qu $opt:mx |] -> do+      let qu' = renTrivial qu+      mx' <- traverse loop mx+      return [pa|+ `$uid:qu' $opt:mx' |]+    [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 $vid:l |] -> do+      x' <- loop x+      l' <- var _loc l+      return [pa|+ $x' as $vid:l' |]+    [pa| { $uid:u = $x | $y } |] -> do+      let u' = renTrivial u+      x' <- loop x+      y' <- loop y+      return [pa|! { $uid:u' = $x' | $y' } |]+    [pa| ! $x |] -> do+      x' <- loop x+      return [pa| ! $x' |]+    [pa| $x : $t |] -> do+      x' <- loop x+      t' <- lift $ renameType t+      return [pa| $x' : $t' |]+    [pa| $anti:a |] -> do+      $antifail+  --+  var loc1 vid = do+    seen <- get+    case M.lookup vid seen of+      Just loc2 -> lift (repeated "Variable" vid "pattern" [loc1, loc2])+      Nothing   -> do+        put (M.insert vid loc1 seen)+        lift (withLocation loc1 (bindVar vid))++-- | Univerally-quantify all free type variables+closeType :: Type Raw -> Type Raw+closeType t = foldr tyAll t (annotFtvSet t)++addVal     :: VarId Raw -> R (VarId Renamed)+addType    :: TypId Raw -> Renamed -> [ConId Raw] -> R (TypId Renamed)+addMod     :: ModId Raw -> R a -> R (ModId Renamed, a)++addVal = bindVar++addType l i dcs = do+  let l' = renId i l+  loc <- getLocation+  tell [MdTycon loc l l' dcs]+  return l'++addMod u body = do+  let u' = renTrivial u+  (a, md) <- steal body+  loc <- getLocation+  tell [MdModule loc u u' md]+  return (u', a)++-- | Result for 'getRenamingInfo'+data RenamingInfo+  = ModuleAt   { renInfoLoc :: Loc, renInfoQModId :: QModId Renamed }+  | SigAt      { renInfoLoc :: Loc, renInfoQSigId :: QSigId Renamed }+  | VariableAt { renInfoLoc :: Loc, renInfoQVarId :: QVarId Renamed }+  | TyconAt    { renInfoLoc :: Loc, renInfoQTypId :: QTypId Renamed }+  | DataconAt  { renInfoLoc :: Loc, renInfoQConId :: QConId 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 name RenameState { savedEnv = e } =+  catMaybes $ case view name of+    Left ql  -> [ look tycons   (TypId <$> ql) TyconAt,+                  look vars     (VarId <$> ql) VariableAt ]+    Right qu -> [ look sigs     (SigId <$> qu) SigAt,+                  look modules  (ModId <$> qu) ModuleAt,+                  look datacons (ConId <$> 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'))++-- Open the given module, if it exists.+renamingEnterScope    :: ModId i -> RenameState -> RenameState+renamingEnterScope u r =+  let e  = savedEnv r in+  case M.lookup (renTrivial u) (modules e) of+    Nothing -> r+    Just (_, _, (_, e'))+            -> r { savedEnv = e `mappend` e' }++-- | Test runner for renaming an expression+re :: Expr Raw -> Either [AlmsError] (Expr Renamed)+re e = fst <$> runRenaming True bogus renameState0 (renameExpr e)++-- | Test runner for renaming an declaration+rd :: Decl Raw -> Either [AlmsError] (Decl Renamed)+rd d = fst <$> runRenaming True bogus renameState0 (renameDecl d)++_loc :: Loc+_loc = initial "<interactive>"
+ src/Statics/Sealing.hs view
@@ -0,0 +1,418 @@+module Statics.Sealing (+  sealWith,+  replaceTyCons, getSigTyCons, getSigItemTyCons,+) where++import Util+import qualified AST+import Type+import Statics.Constraint+import Statics.Env as Env+import Statics.Error+import Statics.Subsume++import Prelude ()+import qualified Data.Map as M++-- | Perform generative signature matching+sealWith ∷ MonadConstraint tv r m ⇒+           [ModId] → Signature tv → Signature tv → m (Signature tv)+sealWith μ sig0 sig1 = do+  let sig1'     = renameSig (makeNameMap sig0) μ sig1+      γ0        = sigToEnv sig0+  tcsubst       ← matchSigTycons γ0 sig1'+  subsumeSig γ0 (applyTCSInTyCon tcsubst sig1')+  let tcs       = getGenTycons sig1'+  tcs'          ← for tcs $ \tc → do+    ix ← tvUniqueID <$> newTV+    return tc { tcId = ix }+  return (substTyCons tcs tcs' sig1')++-- | For mapping renamed names (from structures) into unrenamed names+--   (in signatures)+data NameMap+  = NameMap {+      nmVar     ∷ Env VarId      VarId,+      nmCon     ∷ Env ConId      ConId,+      nmTyp     ∷ Env TypId      TypId,+      nmMod     ∷ Env ModId      (ModId, NameMap),+      nmSig     ∷ Env SigId      SigId+  }++instance Monoid NameMap where+  mempty = NameMap empty empty empty empty empty+  mappend (NameMap a1 a2 a3 a4 a5) (NameMap b1 b2 b3 b4 b5) =+    NameMap (a1 =+= b1) (a2 =+= b2) (a3 =+= b3) (a4 =+= b4) (a5 =+= b5)++instance GenEmpty NameMap where+  genEmpty = mempty+instance GenExtend NameMap NameMap where+  (=+=) = mappend+instance GenLookup NameMap VarId VarId where+  e =..= k = nmVar e =..= k+instance GenLookup NameMap ConId ConId where+  e =..= k = nmCon e =..= k+instance GenLookup NameMap TypId TypId where+  e =..= k = nmTyp e =..= k+instance GenLookup NameMap ModId (ModId, NameMap) where+  e =..= k = nmMod e =..= k+instance GenLookup NameMap SigId SigId where+  e =..= k = nmSig e =..= k++-- | Given a signature, construct a 'NameMap' mapping trivially-renamed+--   versions of its names to the actual renamed version.+makeNameMap ∷ Signature tv → NameMap+makeNameMap = foldMap eachItem where+  eachItem (SgVal n _)   = mempty { nmVar = unTag n =:= n }+  eachItem (SgTyp n tc)  =+    mempty {+      nmTyp = unTag n =:= n,+      nmCon = Env.fromList ((unTag &&& id) <$> Env.domain (tcCons tc))+    }+  eachItem (SgExn n _)   = mempty { nmCon = unTag n =:= n }+  eachItem (SgSig n _)   = mempty { nmSig = unTag n =:= n }+  eachItem (SgMod n sig) = mempty { nmMod = unTag n =:= (n, makeNameMap sig) }+  --+  unTag ∷ AST.Id a ⇒ a R → a R+  unTag = AST.renId bogus++-- | Make the names in a signature match the names from the module it's+--   being applied to.+renameSig ∷ NameMap → [ModId] → Signature tv → Signature tv+renameSig nm μ = map eachItem where+  eachItem (SgVal n σ)   = SgVal (nm !..! n) σ+  eachItem (SgTyp n tc)  = SgTyp (nm !..! n) tc'+    where+    tc' = tc {+      tcName = J (reverse μ) (jname (tcName tc)),+      tcCons = Env.fromList (first (nm !..!) <$> Env.toList (tcCons tc))+    }+  eachItem (SgExn n mσ)  = SgExn (nm !..! n) mσ+  eachItem (SgMod n sig) = SgMod n' sig'+    where+      (n', nm') = nm !..! n+      sig'      = renameSig nm' (n':μ) sig+  eachItem (SgSig n sig) = SgSig (nm !..! n) sig++-- | Given a signature, find the tycon substitutions necessary to+--   unify it with the module in the environment.+matchSigTycons ∷ MonadConstraint tv r m ⇒+                 Γ tv → Signature tv → m TyConSubst+matchSigTycons γ = execWriterT . eachSig [] where+  eachSig μ = mapM_ (eachItem μ)+  eachItem μ sigitem = case sigitem of+    SgVal _ _   → return ()+    SgTyp n tc  → do+      tc' ← γ !.! J (reverse μ) n+      tell (makeTyConSubst [tc] [tc'])+    SgExn _ _   → return ()+    SgMod n sig → eachSig (n:μ) sig+    SgSig _ _   → return ()++-- | Check whether the given signature subsumes the signature+--   implicit in the environment.+subsumeSig ∷ MonadConstraint tv r m ⇒+             Γ tv → Signature tv → m ()+subsumeSig γ = eachSig where+  eachSig      = mapM_ eachItem+  eachItem sg0 = case sg0 of+    SgVal n σ   → do+      σ'        ← γ !.! n+      σ' ≤ σ+        `addErrorContext`+          [msg| In signature matching, type mismatch for value binding $q:n. |]+    SgTyp n tc  → do+      tc'       ← γ !.! n+      case varietyOf tc of+        OperatorType → matchTyCons tc' tc+        DataType     → matchTyCons tc' tc+        AbstractType → do+          let sigAss assertion thing getter =+                tAssExp assertion+                  ([msg| In signature matching, cannot match the+                         definition for type $q:1 because the+                         $words:thing does not match: |] (tcName tc))+                  (showMsg (getter tc'))+                  (showMsg (getter tc))+          sigAss (length (tcArity tc') == length (tcArity tc))+            "number of type parameters" (length . tcArity)+          sigAss (all2 (⊑) (tcArity tc') (tcArity tc))+            "variance" tcArity+          sigAss (all2 (⊒) (tcBounds tc') (tcBounds tc))+            "parameter bounds" tcBounds+          sigAss (tcQual tc' ⊑ tcQual tc)+            "qualifier" tcQual+    SgExn n mσ  → do+      emσ'      ← γ !.! n+      case emσ' of+        Left _    → typeBug "subsumeSig" "Datacon where exn expected"+        Right mσ' → matchParamType mσ' mσ [msg| exception $q:n |]+    SgMod n sig → do+      (_, γ')   ← γ !.! n+      subsumeSig γ' sig+    SgSig n sig → do+      (sig', _) ← γ !.! n+      matchSigs sig' sig++-- | Check that exception parameter types match, given the constructor+--   name, the actual type, and the expected type.+matchParamType ∷ MonadConstraint tv r m ⇒+                 Maybe (Type Empty) → Maybe (Type Empty) →+                 Message H →+                 m ()+matchParamType mσ mσ' what = case (mσ, mσ') of+  (Nothing, Nothing)+    → return ()+  (Just σ,  Just σ')+    → elimEmptyF σ =: elimEmptyF σ' `addErrorContext`+        [msg| In signature matching, type mismatch in parameter of $msg:what |]+  _ → tErrExp+    [msg| In signature matching, parameter of $msg:what does not match |]+    (maybe [msg| no parameter |] pprMsg mσ)+    (maybe [msg| no parameter |] pprMsg mσ')++-- | Check that two signatures match EXACTLY.+--   First signature is what we have, and second is what we want.+matchSigs ∷ MonadConstraint tv r m ⇒+            Signature tv → Signature tv → m ()+matchSigs = loop where+  loop [] []                = return ()+  loop (SgVal n1 σ1 : sgs1)     (SgVal n2 σ2 : sgs2)+    | n1 == n2              = do+      σ1 =: σ2 `addErrorContext`+        [msg| In matching signatures, types do not match for+              value binding $q:n1. |]+      loop sgs1 sgs2+  loop (SgTyp n1 tc1 : sgs1)    (SgTyp n2 tc2 : sgs2)+    | n1 == n2              = do+      matchTyCons tc2 tc1+      loop (substTyCon tc1 tc2 sgs1) sgs2+  loop (SgExn n1 mσ1 : sgs1)    (SgExn n2 mσ2 : sgs2)+    | n1 == n2              = do+      matchParamType mσ2 mσ1 [msg| exception $q:n1 |]+      loop sgs1 sgs2+  loop (SgMod n1 sig1 : sgs1)   (SgMod n2 sig2 : sgs2)+    | n1 == n2              = do+      matchSigs sig1 sig2+      loop sgs1 sgs2+  loop (SgSig n1 sig1 : sgs1)   (SgSig n2 sig2 : sgs2)+    | n1 == n2              = do+      matchSigs sig1 sig2+      loop sgs1 sgs2+  loop [] (sg : _)          = do+    (n, what) ← whatIs sg+    typeError [msg|+      In exact signature matching, missing expected $what $qmsg:n.+    |]+  loop (sg : _) []          = do+    (n, what) ← whatIs sg+    typeError [msg|+      In exact signature matching, found unexpected $what $qmsg:n.+    |]+  loop (sg1 : _) (sg2 : _)  = do+    (n1, what1) ← whatIs sg1+    (n2, what2) ← whatIs sg2+    typeError [msg|+      In exact signature matching (for signatures as entries in+      signatures being matched), got signature items didn’t match:+      <dl>+        <dt>actual:   <dd>$what1 $qmsg:n1+        <dt>expected: <dd>$what2 $qmsg:n2+      </dl>+    |]+  --+  whatIs (SgVal n _) = return (pprMsg n, "value")+  whatIs (SgTyp n _) = return (pprMsg n, "type")+  whatIs (SgExn n _) = return (pprMsg n, "exception")+  whatIs (SgMod n _) = return (pprMsg n, "module")+  whatIs (SgSig n _) = return (pprMsg n, "module type")++-- | Get a list of all the tycons that need a new index allocated+--   because they're generative.+getGenTycons ∷ Signature tv → [TyCon]+getGenTycons = execWriter . eachSig where+  eachSig       = mapM_ eachItem+  eachItem sg0  = case sg0 of+    SgVal _ _   → return ()+    SgTyp _ tc  → unless (varietyOf tc == OperatorType) (tell [tc])+    SgExn _ _   → return ()+    SgMod _ sig → eachSig sig+    SgSig _ _   → return ()++-- | Check that two type constructors match exactly.+matchTyCons ∷ MonadConstraint tv r m ⇒ TyCon → TyCon → m ()+matchTyCons tc1 tc2 = case (varietyOf tc1, varietyOf tc2) of+  (AbstractType, AbstractType) → do+    tcArity tc1  ==! tcArity tc2        $ "arity or variance"+    tcBounds tc1 ==! tcBounds tc2       $ "parameter bound"+    tcGuards tc1 ==! tcGuards tc2       $ "guarded parameters"+    tcQual tc1   ==! tcQual tc2         $ "qualifier"+  (DataType, DataType) → do+    tcArity tc1  ==! tcArity tc2        $ "number of parameters"+    let rhs1 = tcCons tc1+        rhs2 = tcCons tc2+    forM_ (Env.toList rhs1) $ \(k, mσ1) → do+      mσ2 ← rhs2 !.! k+      matchParamType mσ2 mσ1 [msg| constructor $q:k |]+  (OperatorType, _)            | tyconExtEq tc1 tc2 → return ()+  (_,            OperatorType) | tyconExtEq tc1 tc2 → return ()+  (OperatorType, OperatorType) → do+    let next1 = fromMaybe [] (tcNext tc1)+        next2 = fromMaybe [] (tcNext tc2)+        ncs1  = length next1+        ncs2  = length next1+    ncs1         ==! ncs2               $ "number of clauses"+    forM_ (zip3 next1 next2 [1 ∷ Int .. ]) $+      \((tp1, σ1), (tp2, σ2), ix) → do+        length tp1 ==! length tp2 $+          if ncs1 == 1+            then "number of type parameters"+            else "number of parameters else in clause " ++ show ix+        zipWithM_ matchTyPats tp1 tp2+        σ1         ==! σ2               $+          if ncs1 == 1+            then "type synonym right-hand sides"+            else "type operator right-hand sides in clause " ++ show ix+  (v1, v2) → v1 ==! v2 $ "kind of definition"+  where+    (a1 ==! a2) what =+      tAssExp (a1 == a2)+        [msg| In signature matching, cannot match definition for type+              $q:tc1 because the $words:what does not match: |]+        (pprMsg a1)+        (pprMsg a2)++-- | Extensional equality for type constructors.+--   This is probably too weak.+tyconExtEq ∷ TyCon → TyCon → Bool+tyconExtEq tc1 tc2 | tcBounds tc1 == tcBounds tc2 =+  let tvs = fvTy <$> [ 1 .. length (tcArity tc1) ]+   in TyApp tc1 tvs == TyApp tc2 tvs+tyconExtEq _   _   = False++-- | To check that two type patterns match, and return the pairs of+--   type variables that line up and thus need renaming.+matchTyPats ∷ MonadAlmsError m ⇒ TyPat → TyPat → m ()+matchTyPats (TpVar _) (TpVar _)+  = return ()+matchTyPats (TpRow _) (TpRow _)+  = return ()+matchTyPats (TpApp tc1 tvs1) (TpApp tc2 tvs2)+  | tc1 == tc2+  = zipWithM_ matchTyPats tvs1 tvs2+matchTyPats tp1 tp2+  = tErrExp+      [msg| In signature matching, cannot match type patterns: |]+      (pprMsg tp1)+      (pprMsg tp2)++---+--- TYPE CONSTRUCTOR SUBSTITUTION+---++-- | A substitution mapping type constructors to other type+--   constructors+type TyConSubst = M.Map Int TyCon++-- | Construct a tycon substitution from a list of tycons and a list+--   to map them to.+makeTyConSubst ∷ [TyCon] → [TyCon] → TyConSubst+makeTyConSubst tcs tcs' = M.fromList (zip (tcId <$> tcs) tcs')++class SubstTyCon a where+  applyTCS, applyTCSInTyCon ∷ TyConSubst → a → a+  applyTCSInTyCon    = applyTCS++instance SubstTyCon a ⇒ SubstTyCon (Maybe a) where+  applyTCS        = fmap . applyTCS+  applyTCSInTyCon = fmap . applyTCSInTyCon++instance SubstTyCon a ⇒ SubstTyCon [a] where+  applyTCS        = fmap . applyTCS+  applyTCSInTyCon = fmap . applyTCSInTyCon++instance SubstTyCon v ⇒ SubstTyCon (Env k v) where+  applyTCS        = fmap . applyTCS+  applyTCSInTyCon = fmap . applyTCSInTyCon++instance (SubstTyCon a, SubstTyCon b) ⇒ SubstTyCon (a, b) where+  applyTCS s        = applyTCS s *** applyTCS s+  applyTCSInTyCon s = applyTCSInTyCon s *** applyTCSInTyCon s++instance (SubstTyCon a, SubstTyCon b, SubstTyCon c) ⇒+         SubstTyCon (a, b, c) where+  applyTCS s (a, b, c) = (applyTCS s a, applyTCS s b, applyTCS s c)+  applyTCSInTyCon s (a, b, c) =+    (applyTCSInTyCon s a, applyTCSInTyCon s b, applyTCSInTyCon s c)++instance (SubstTyCon a, SubstTyCon b) ⇒ SubstTyCon (Either a b) where+  applyTCS s        = applyTCS s +++ applyTCS s+  applyTCSInTyCon s = applyTCSInTyCon s +++ applyTCSInTyCon s++instance SubstTyCon TyCon where+  applyTCS s tc+    | Just tc' ← M.lookup (tcId tc) s+      = applyTCSInTyCon s tc'+    | otherwise+      = applyTCSInTyCon s tc+  applyTCSInTyCon s tc+    = tc {+          tcNext = applyTCS s (tcNext tc),+          tcCons = applyTCS s (tcCons tc)+        }++instance SubstTyCon TyPat where+  applyTCS s tp0 = case tp0 of+    TpVar _     → tp0+    TpRow _     → tp0+    TpApp tc σs → TpApp (applyTCS s tc) (applyTCS s σs)++instance SubstTyCon (Type tv) where+  applyTCS s σ0 = case σ0 of+    TyVar _         → σ0+    TyQu qu αs σ    → TyQu qu αs (applyTCS s σ)+    TyMu α σ        → TyMu α (applyTCS s σ)+    TyRow lab σ1 σ2 → TyRow lab (applyTCS s σ1)+                                (applyTCS s σ2)+    TyApp tc σs     → TyApp (applyTCS s tc)+                            (applyTCS s σs)++instance SubstTyCon (SigItem tv) where+  applyTCS s sg0 = case sg0 of+    SgVal n σ   → SgVal n (applyTCS s σ)+    SgTyp n tc  → SgTyp n (applyTCS s tc)+    SgExn n mσ  → SgExn n (applyTCS s mσ)+    SgMod n sig → SgMod n (applyTCS s sig)+    SgSig n sig → SgSig n (applyTCS s sig)+  applyTCSInTyCon s sg0 = case sg0 of+    SgVal n σ   → SgVal n (applyTCS s σ)+    SgTyp n tc  → SgTyp n (applyTCSInTyCon s tc)+    SgExn n mσ  → SgExn n (applyTCS s mσ)+    SgMod n sig → SgMod n (applyTCSInTyCon s sig)+    SgSig n sig → SgSig n (applyTCS s sig)++-- | Replace all the type constructors whose indices match the ones in the+--   list with the ones in the list.+replaceTyCons ∷ SubstTyCon a ⇒ [TyCon] → a → a+replaceTyCons tcs = substTyCons tcs tcs++-- Give a list of tycons to replace and a list of tycons to replace them+-- with, replaces them all recursively, including knot-tying+substTyCons ∷ SubstTyCon a ⇒ [TyCon] → [TyCon] → a → a+substTyCons tcs tcs' = applyTCS (makeTyConSubst tcs tcs')++-- | Replace all occurrences of the first tycon with the second+substTyCon ∷ SubstTyCon a ⇒ TyCon → TyCon → a → a+substTyCon tc tc' = substTyCons [tc] [tc']++-- | Get all the tycons that are bound in a signature+getSigTyCons ∷ Signature tv → [TyCon]+getSigTyCons = concatMap getSigItemTyCons++-- | Get all the tycons that are bound in a signature item+getSigItemTyCons ∷ SigItem tv → [TyCon]+getSigItemTyCons (SgVal _ _)   =  []+getSigItemTyCons (SgTyp _ tc)  = [tc]+getSigItemTyCons (SgExn _ _)   =  []+getSigItemTyCons (SgMod _ sig) = getSigTyCons sig+getSigItemTyCons (SgSig _ sig) = getSigTyCons sig
+ src/Statics/Sig.hs view
@@ -0,0 +1,80 @@+module Statics.Sig (+  Signature, SigItem (..),+  sigToStx, sigToStx', sigItemToStx, sigItemToStx',+  abstractSig, abstractSigItem,+  VarId, ModId, SigId, QVarId, QModId, QSigId,+) where++import Util+import qualified AST+import Type+import qualified Syntax.Ppr as Ppr++import Prelude ()+import Data.Generics (Typeable, Data)++type R = AST.Renamed+type VarId  = AST.VarId R+type ModId  = AST.ModId R+type SigId  = AST.SigId R+type QVarId = AST.QVarId R+type QModId = AST.QModId R+type QSigId = AST.QSigId R++data SigItem tv+  = SgVal !VarId !(Type tv)+  | SgTyp !TypId !TyCon+  | SgExn !ConId !(Maybe (Type Empty))+  | SgMod !ModId !(Signature tv)+  | SgSig !SigId !(Signature tv)+  deriving (Functor, Typeable, Data)++type Signature tv = [SigItem tv]++-- | Convert an internal signature to AST, with no type context+sigToStx' ∷ Tv tv ⇒ Signature tv → AST.SigExp R+sigToStx' = sigToStx tyNames0++-- | Convert an internal signature to AST+sigToStx ∷ Tv tv ⇒ TyNames → Signature tv → AST.SigExp R+sigToStx tn items = AST.seSig (sigItemToStx tn <$> items)++-- | Convert an internal signature item to an AST signature item,+--   with no type context.+sigItemToStx' ∷ Tv tv ⇒ SigItem tv → AST.SigItem R+sigItemToStx' = sigItemToStx tyNames0++-- | Convert an internal signature item to an AST signature item+--   TODO: Group mutually recursive types.+sigItemToStx ∷ Tv tv ⇒ TyNames → SigItem tv → AST.SigItem R+sigItemToStx tn si0 = case si0 of+  SgVal n τ   → AST.sgVal n (typeToStx t2sc τ)+  SgTyp _ tc  → AST.sgTyp [tyConToStx tn tc]+  SgExn n mτ  → AST.sgExn n (typeToStx t2sc <$> mτ)+  SgMod n sig → AST.sgMod n (sigToStx (tnEnter tn n) sig)+  SgSig n sig → AST.sgSig n (sigToStx tn sig)+  where+  t2sc = t2sContext0 { t2sTyNames = tn }++-- | Abstract a signature by removing the representation information+--   of all type constructors+abstractSig ∷ Signature tv → Signature tv+abstractSig = map abstractSigItem++-- | Abstract a signature item by removing the representation information+--   of all type constructors+abstractSigItem ∷ SigItem tv → SigItem tv+abstractSigItem sg = case sg of+  SgVal n σ     → SgVal n σ+  SgTyp n tc    → SgTyp n (abstractTyCon tc)+  SgExn n mσ    → SgExn n mσ+  SgMod n sig   → SgMod n (abstractSig sig)+  SgSig n sig   → SgSig n (abstractSig sig)++instance Tv tv ⇒ Ppr.Ppr (SigItem tv) where+  ppr item = Ppr.askTyNames $ \tn → Ppr.ppr (sigItemToStx tn item)+  pprList sig = Ppr.askTyNames $ \tn → Ppr.ppr (sigToStx tn sig)++instance Tv tv ⇒ Show (SigItem tv) where+  showsPrec = Ppr.showFromPpr+  showList  = Ppr.showFromPpr 0
+ src/Statics/Subsume.hs view
@@ -0,0 +1,98 @@+-- | Subsumption+module Statics.Subsume (+  subsumeN, (≤), (≤≥), subsumeBy,+) where++import Util+import Statics.Constraint+import Statics.Error+import Statics.InstGen+import Type++import Prelude ()+import qualified Data.Set as S++-- | Given a list of type/U-action pairs, run all the U actions, but+--   in an order that does all U-actions not assocated with tyvars+--   before those associated with tyvars. Checks dynamically after each+--   action, since an action can turn a tyvar into a non-tyvar.+subsumeN ∷ MonadConstraint tv r m ⇒+           [(Type tv, m ())] → m ()+subsumeN []  = return ()+subsumeN σs0 = subsumeOneOf σs0 >>= subsumeN+  where+    subsumeOneOf []             = return []+    subsumeOneOf [(_, u1)]      = [] <$ u1+    subsumeOneOf ((σ1, u1):σs)  = do+      σ ← substHead σ1+      case σ of+        TyVar (Free α) | tvFlavorIs Universal α+          → ((σ, u1):) <$> subsumeOneOf σs+        _ → σs <$ u1++-- | Subsumption+(≤)   ∷ MonadConstraint tv r m ⇒ Type tv → Type tv → m ()+σ1 ≤ σ2 = do+  traceN 2 ("≤", σ1, σ2)+  subsumeBy (<:) σ1 σ2+    `addErrorContext`+      [msg| When subsuming types (using instantiation and subtyping):+              <dl>+                <dt>actual:   <dd>$5:σ1+                <dt>expected: <dd>$5:σ2+              </dl> |]++-- | Subsumption+(≤≥)  ∷ MonadConstraint tv r m ⇒ Type tv → Type tv → m ()+σ1 ≤≥ σ2 = do+  traceN 2 ("≤≥", σ1, σ2)+  subsumeBy (=:) σ1 σ2+    `addErrorContext`+      [msg| When subsuming types (using instantiation and unification):+              <dl>+                <dt>actual:   <dd>$5:σ1+                <dt>expected: <dd>$5:σ2+              </dl> |]++subsumeBy ∷ MonadConstraint tv r m ⇒+            (Type tv → Type tv → m ()) → Type tv → Type tv → m ()+subsumeBy (≤*) σ10 σ20 = do+  σ1 ← subst σ10+  σ2 ← subst σ20+  case (σ1, σ2) of+    (TyVar (Free α), _) | tvFlavorIs Universal α → do+      σ1 ≤* σ2+    (_, TyVar (Free α)) | tvFlavorIs Universal α → do+      σ1' ← instAll True σ1+      σ1' ≤* σ2+    _ → do+      ρ1        ← instantiate σ1+      (ρ2, αs2) ← collectTVs (instantiateNeg σ2)+      ρ1 ≤* ρ2+      -- Check for escaping skolems+      let (us1, _, ss1) = partitionFlavors αs2+      σ1'  ← subst σ1+      σ2'  ← subst σ2+      us1' ← mapM subst (fvTy <$> us1)+      let freeSkolems = S.filter (tvFlavorIs Skolem) (ftvSet (σ1', σ2', us1'))+      when (any (`S.member` freeSkolems) ss1) $ do+        traceN 3 (αs2, freeSkolems)+        tErrExp+          [msg|+            Cannot subsume types because a type is less+            polymorphic than expected:+          |]+          (pprMsg σ1')+          (pprMsg σ2')++-- | Given a list of type variables, partition it into a triple of lists+--   of 'Universal', 'Existential', and 'Skolem' flavored type variables.+partitionFlavors ∷ Tv tv ⇒+                   [tv] → ([tv], [tv], [tv])+partitionFlavors = loop [] [] [] where+  loop us es ss []     = (us, es, ss)+  loop us es ss (α:αs) = case tvFlavor α of+    Universal   → loop (α:us) es     ss     αs+    Existential → loop us     (α:es) ss     αs+    Skolem      → loop us     es     (α:ss) αs+
+ src/Statics/Type.hs view
@@ -0,0 +1,203 @@+module Statics.Type (+  tcType, tcTypeRowDots, tcTyPat,+) where++import Util+import qualified AST+import Meta.Quasi+import Type+import Statics.Env+import Statics.Error+import Statics.Constraint++import Prelude ()+import qualified Data.Map as M++-- | Type check a type.+tcType ∷ MonadConstraint tv r m ⇒+         Δ tv → Γ tv → AST.Type R → m (Type tv)+tcType = tcTypeRowDots <-> []++-- | When checking row dots, there are three possible states we could be+--   in:+data DotState tv+  -- | We are not currently under an ellipsis, and the given type+  --   variables are available type variables bound under an ellipsis.+  = Available [tv]+  -- | We are under an ellipsis, but have not found out yet which+  --   variable it protects.+  | Unchosen [tv]+  -- | We are under an ellipsis that controls the given variable,+  --   with the remaining variables available for remaining ellipses.+  | Chosen tv [tv]++-- | Type check a type, resolving dots (maps over rows).  Type variables+--   in the list of dots variables *must not* be bound in the type+--   variable environment.+tcTypeRowDots ∷ MonadConstraint tv r m ⇒+                Δ tv → [(AST.TyVar R, tv)] → Γ tv →+                AST.Type R → m (Type tv)+tcTypeRowDots δ0 dotTVs γ t00 =+  evalStateT (loop δ0 (iaeInit :: CurrentImpArrRule tv) t00)+             (Available dotTVs)+  where+    loop δ iae t0 = withLocation t0 $ case t0 of+      [ty| `$α |] → do+        fvTy <$> δ !.! α `catchAlms` handleDotTV α+      --+      [ty| $t1 -[$opt:mqe]> $t2 |] → do+        qe  ← iaeInterpret (Free <$$> (δ !.!)) iae mqe+        τ1  ← loop δ (iaeLeft iae) t1+        τ2  ← loop δ (iaeRight iae qe τ1) t2+        return (tyFun τ1 qe τ2)+      --+      [ty| $t ... |] → do+        withDots $ loop δ iae t+      --+      [ty| ($list:ts) $qtid:n |] → do+        tc  ← γ !.! n+        τs  ← zipWithM (loop δ . iaeUnder iae) (tcArity tc) ts+        zipWithM_ (⊏:) τs (tcBounds tc)+        checkLength (length ts) (length (tcArity tc))+        return (TyApp tc τs)+        where+        checkLength actual expected =+          tAssExp (actual == expected)+            [msg| Type constructor $q:n got the wrong number of parameters: |]+            [msg| $actual |]+            [msg| $expected |]+      --+      [ty| $quant:qu `$_. $_ |] → do+        let (αs, t) = AST.unfoldTyQu qu t0+            qls     = AST.tvqual <$> αs+        qu' ← tcQuant qu+        αs' ← mapM (curry newTV' Skolem) qls+        τ'  ← loop (δ =+= αs =:*= αs') iae t+        return (closeQuant qu' (zip αs' qls) τ')+      --+      [ty| μ `$α. $t |] → do+        α' ← newTV+        τ' ← loop (δ =+= α =:= α') iae t+        checkGuarded α' τ'+        τ' ⊏: fvTy α'+        return (closeRec α' τ')+        where+        checkGuarded α' τ' = case M.lookup α' (ftvG τ') of+          Just False+            → typeError [msg|+                Recursive type is ill formed because the bound variable+                is unguarded:+                <dl>+                  <dt>type:     <dd>$t0+                  <dt>variable: <dd>$α+                </dl>+                The type variable bound by μ must appear only under type+                constructors that are allowed to <q>guard</q> recursion,+                such as under an open variant.+              |]+          _ → return ()+      --+      [ty| `$uid:uid of $t1 | $t2 |] → do+        τ1 ← loop δ iae t1+        τ2 ← loop δ iae t2+        return (TyRow uid τ1 τ2)+      --+      [ty| $anti:a |] → $(AST.antifail)++withDots ∷ (MonadSubst tv r m,+            MonadState (DotState (AST.TyVar R, tv)) m) ⇒+           m (Type tv) → m (Type tv)+withDots checkT = do+  dotState ← get+  put . Unchosen =<< case dotState of+    Available [] → do+      typeError' [msg|+        Row dots (<q>...</q>) may only appear on the right-hand side+        of a type operator declaration that also has row dots on the+        left-hand side.+      |]+    Available βs → return βs+    Unchosen βs  → return βs+    Chosen _ βs  → return βs+  σ ← checkT+  dotState' ← get+  case dotState' of+    Available _      → availableBug+    Unchosen _       → unchosenError+    Chosen (_, β') _ → do+      put dotState+      return (TyApp tcRowMap [σ, fvTy β'])+  where+    availableBug  = typeBug "withDots" "Saw Available inside dots"+    unchosenError = do+      typeError' [msg|+        Row dots (<q>...</q>) may only appear on the right-hand side+        of a type operator declaration, and must include in their+        parameter a type variable that appeared under row dots on the+        left-hand side.+      |]++-- | Given a type variable that was not bound in the type variable+--   environment (and the exceptions thrown to reflect that), check+--   if it's involved in row mapping (dots syntax) and if so, translate+--   it thusly.+handleDotTV ∷ (MonadSubst tv r m,+               MonadState (DotState (AST.TyVar R, tv)) m) ⇒+              AST.TyVar R → [AlmsError] → m (Type tv)+handleDotTV α es = do+  dotState ← get+  case dotState of+    Available βs+      | Just _ ← lookup α βs → do+      typeError' [msg|+        Type variable $α matches a row using dot notation (<q>...</q>)+        in the pattern of a type operator, but appears unprotected by+        dots on the right-hand side.+      |]+    Unchosen βs+      | Just α' ← lookup α βs → do+        put (Chosen (α, α') βs)+        return (TyApp tcRowHole [])+    Chosen (β, _) βs+      | α == β               → return (TyApp tcRowHole [])+      | Just _ ← lookup α βs → do+      typeError' [msg|+        Type variable $α, which stands for a row,+        appears under row dots (<q>...</q>) that iterate+        a different row variable, $β.+      |]+    _            → throwAlmsList es++-- | Convert an AST quantifer to an internal quantifier+tcQuant ∷ MonadAlmsError m ⇒ AST.Quant → m Quant+tcQuant AST.Forall        = return Forall+tcQuant AST.Exists        = return Exists+tcQuant (AST.QuantAnti a) = $(AST.antifail)++-- | Type check a type pattern.  Returns the internal pattern and a list+--   of type variables, each specifying whether it is a row variable.+tcTyPat ∷ MonadConstraint tv r m ⇒+          Γ tv → AST.TyPat R → m (TyPat, [(AST.TyVar R, Bool)])+tcTyPat γ = runWriterT . loop where+  loop tp0 = withLocation tp0 $ case tp0 of+    AST.N _ (AST.TpVar tv _)                  → do+      tell [(tv, False)]+      return (TpVar (Here (AST.idName tv)))+    AST.N _ (AST.TpRow tv _)                  → do+      tell [(tv, True)]+      return (TpRow (Here (AST.idName tv)))+    [tpQ| ($list:tps) $qtid:n |]              → do+      tc ← γ !.! n+      tassert (isNothing (tcNext tc)) $+        [msg| In type operator pattern, the type constructor to+              be matched is also a type operator:+              <dl>+                <dt>In pattern:       <dd> $tp0+                <dt>Type constructor: <dd> $1+              </dl>+              Type constructors in type patterns must be abstract types+              or concrete data types, not type synonyms or operators.+        |] (tcName tc)+      TpApp tc <$> mapM loop tps+    [tpQ| $antiP:a |]                     → $(AST.antifail)+
− src/Syntax.hs 
@@ -1,140 +0,0 @@-{-# 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 
@@ -1,378 +0,0 @@-{-# 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/Construction.hs view
@@ -0,0 +1,267 @@+-- | Utilities for constructing syntax+module Syntax.Construction (+  -- * Generic tuple building+  ToTuple(..),+  -- * Optimizing expression constructors+  exLet', exLetVar', exAbs', exAbsVar',+  -- * Substitution+  substExpr,+) where++import Util+import AST+import Data.Loc+import Meta.Quasi++import Prelude ()+import Data.Map as M+import Data.Generics (Data, everywhere, mkT)++-- | Constructs a let expression, but with a special case:+--+--   @let x      = e in x        ==   e@+--   @let (x, y) = e in (x, y)   ==   e@+--   @let x      = v in e        ==   [v/x]e@+--+-- This is always safe to do.+exLet' :: Tag i => Patt i -> Expr i -> Expr i -> Expr i+exLet' π e1 e2+  | π -==+ e2           = e1+  -- This case can cause code bloat:+  | [pa| $vid:x |] ← π+  , syntacticValue e1   = substExpr e1 (J [] x) e2+  | [pa| $vid:x |] ← π+  , qx ← J [] x+  , nextRedex qx e2+  , M.lookup qx (fv e2) == Just 1+                        = substExpr e1 (J [] x) e2+  | otherwise           = exLet π e1 e2++-- | Constructs a let expression whose pattern is a variable.+exLetVar' :: Tag i => VarId i -> Expr i -> Expr i -> Expr i+exLetVar'  = exLet' . paVar++-- | Constructs a lambda expression, but with a special case:+--+--    @exAbs' x     (exApp (exVar f) x)      ==  exVar f@+--    @exAbs' (x,y) (exApp (exVar f) (x,y))  ==  exVar f@+--+-- This eta-contraction is always safe, because f has no effect+exAbs' :: Tag i => Patt i -> Expr i -> Expr i+exAbs' x e = case view e of+  ExApp e1 e2 -> case view e1 of+    ExVar (J p f) | x -==+ e2+              -> exVar (J p f)+    _         -> exAbs x e+  _           -> exAbs x e++-- | Construct an abstraction whose pattern is just a variable.+exAbsVar' :: Tag i => VarId i -> Expr i -> Expr i+exAbsVar'  = exAbs' . paVar++-- | 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.+(-==+) :: Tag i => Patt i -> Expr i -> Bool+p -==+ e = case (dataOf p, dataOf e) of+  (PaVar l,      ExVar (J [] l'))+    -> l == l'+  (PaCon (J [] (ConId (Uid _ "()"))) Nothing,+   ExCon (J [] (ConId (Uid _ "()"))) Nothing)+    -> True+  (PaPair p1 p2, ExPair e1 e2)+    -> p1 -==+ e1 && p2 -==+ e2+  _ -> False+infix 4 -==+++-- Does the given variable appear where the next redex would be+-- for the expression, if a substitution were made? This, along with+-- linearity (a separate check) makes it safe to substitute any expression+-- for it.+nextRedex ∷ Tag i ⇒ QVarId i → Expr i → Bool+nextRedex x = loop where+  e1 >*> b2 = loop e1+           || syntacticValue e1+              && x `M.notMember` fv e1+              && b2+  loop e = case e of+    [ex| $qvid:x' |]            → x == x'+    [ex| $lit:_ |]              → False+    [ex| $qcid:_ $opt:me |]     → maybe False loop me+    [ex| let $vid:x' = $e1 in $e2 |]+      | J [] x' == x            → loop e1+      | otherwise               → e1 >*> loop e2+    [ex| let $_ = $e1 in $_ |]  → loop e1+    [ex| match $e0 with $list:_ |]+                                → loop e0+    [ex| let rec $list:bns in $e2 |]+                                → x `M.notMember` fv bns+                               && x ∉ qdv bns+                               && loop e2+    [ex| let $decl:_ in $_ |]   → False+    [ex| ($e1, $e2) |]          → e1 >*> loop e2+    [ex| λ $_ → $_ |]           → False+    [ex| $e1 $e2 |]             → e1 >*> loop e2+    [ex| `$uid:_ $opt:me2 |]    → maybe False loop me2+    [ex| #$uid:_ $e2 |]         → loop e2+    [ex| { $list:flds | $e2 } |]+                                → foldr (>*>) (loop e2)+                                        (fdexpr . view <$> flds)+    [ex| {+ $list:_ | $e2 +} |] → loop e2+    [ex| $e1.$uid:_ |]          → loop e1+    [ex| $e1 : $_ |]            → loop e1+    [ex| $e1 :> $_ |]           → loop e1+    [ex| $anti:a |]             → $antierror++-- Substitute an expression for a variable+substExpr ∷ Tag i ⇒ Expr i → QVarId i → Expr i → Expr i+substExpr e' x' = loop where+  fv_e'  = [ x | J [] x ← M.keys (fv e') ]+  loop e = case e of+    [ex| $qvid:x |]+      | x == x'                 → e'+      | otherwise               → e+    [ex| $lit:_ |]              → e+    [ex| $qcid:c $opt:me |]     → [ex| $qcid:c $opt:me' |]+      where me' = loop <$> me+    [ex| let $π = $e1 in $e2 |]+      | x' ∈ qdv π              → [ex| let $π = $e1' in $e2 |]+      | otherwise               → [ex| let $π' = $e1' in $e2' |]+      where e1'        = loop e1+            (π', e2'0) = avoidCapture fv_e' x' π e2+            e2'        = loop e2'0+    [ex| match $e0 with $list:cas |]+                                → [ex| match $e0' with $list:cas' |]+      where e0'  = loop e0+            cas' = substCaseAlt e' x' <$> cas+    [ex| let rec $list:bns in $e2 |]+      | x' ∈ (J [] <$> fs)      → [ex| let rec $list:bns' in $e2 |]+      where fs   = [ fi | [bnQ|! $vid:fi = $_ |] ← bns ]+            bns' = substBinding e' x' <$> bns+    [ex| let rec $list:bns in $e2 |]+      | otherwise               → [ex| let rec $list:bns' in $e2' |]+      where+      (fs, es)       = unzip [ (fi, ei) | [bnQ|! $vid:fi = $ei |] ← bns ]+      (fs', renamer) = avoidCapture' fv_e' x' fs (e2:es)+      bns'           = reverse (fst (foldl' eachBn ([], fs') bns))+      e2'            = loop (renamer e2)+      eachBn (acc, fi':rest) [bnQ| $vid:_ = $ei |]+                     = ([bnQ| $vid:fi' = $ei' |]:acc, rest)+                       where ei' = loop (renamer ei)+      eachBn (acc, rest)     bn@[bnQ| $antiB:_ |]+                     = (bn:acc, rest)+      eachBn _ _     =+        error "BUG in substExpr: Inconsistency in number of let rec bindings"+    [ex| let $decl:d in $e2 |]  → [ex| let $decl:d in $e2' |]+      where e2' = loop e2        -- Doesn't handle d+    [ex| ($e1, $e2) |]          → [ex| ($e1', $e2') |]+      where e1' = loop e1+            e2' = loop e2+    [ex| λ $π1 → $e2 |]+      | x' ∈ qdv π1             → e+      | otherwise               → [ex| λ $π1' → $e2' |]+      where (π1', e2')  = second loop+                        $ avoidCapture fv_e' x' π1 e2+    [ex| $e1 $e2 |]             → [ex| $e1' $e2' |]+      where e1' = loop e1+            e2' = loop e2+    [ex| `$uid:c $opt:me2 |]    → [ex| `$uid:c $opt:me2' |]+      where me2' = loop <$> me2+    [ex| #$uid:c $e2 |]         → [ex| #$uid:c $e2' |]+      where e2' = loop e2+    [ex| { $list:flds | $e2 } |]+                                → [ex| { $list:flds' | $e2' } |]+      where flds' = substField e' x' <$> flds+            e2'   = loop e2+    [ex| {+ $list:flds | $e2 +} |]+                                → [ex| {+ $list:flds' | $e2' +} |]+      where flds' = substField e' x' <$> flds+            e2'   = loop e2+    [ex| $e1.$uid:u |]          → [ex| $e1'.$uid:u |]+      where e1' = loop e1+    [ex| $e1 : $annot |]        → [ex| $e1' : $annot |]+      where e1' = loop e1+    [ex| $e1 :> $annot |]       → [ex| $e1' : $annot |]+      where e1' = loop e1+    [ex| $anti:_ |]             → e++substCaseAlt ∷ Tag i ⇒ Expr i → QVarId i → CaseAlt i → CaseAlt i+substCaseAlt e' x' ca = case ca of+  [caQ| $π1 → $e2 |]+    | x' ∈ qdv π1               → ca+    | otherwise                 → [caQ| $π1' → $e2' |]+      where (π1', e2') = second (substExpr e' x')+                       $ avoidCapture [ x | J [] x ← M.keys (fv e') ]+                                      x' π1 e2+  [caQ| #$uid:c → $e2 |]        → [caQ| #$uid:c → $e2' |]+      where e2'         = substExpr e' x' e2+  [caQ| #$uid:c $π1 → $e2 |]+    | x' ∈ qdv π1               → ca+    | otherwise                 → [caQ| #$uid:c $π1' → $e2' |]+      where (π1', e2') = second (substExpr e' x')+                       $ avoidCapture [ x | J [] x ← M.keys (fv e') ]+                                      x' π1 e2+  [caQ| $antiC:_ |]             → ca++substBinding ∷ Tag i ⇒ Expr i → QVarId i → Binding i → Binding i+substBinding e' x' bn = case bn of+  [bnQ| $vid:f = $e2 |]+    | x' == J [] f              → bn+    | otherwise                 → [bnQ| $vid:f' = $e2' |]+      where+      (f', e2') = second (substExpr e' x')+                $ avoidCapture [ x | J [] x ← M.keys (fv e') ]+                               x' f e2+  [bnQ| $antiB:_ |]             → bn++substField ∷ Tag i ⇒ Expr i → QVarId i → Field i → Field i+substField e' x' fld = case fld of+  [fdQ| $uid:u = $e2 |] → [fdQ| $uid:u = $e2' |]+    where e2' = substExpr e' x' e2+  [fdQ| $antiF:_ |]     → fld++-- | Given a list of names not to capture, the variable being+--  substituted, a pattern, and an expression+-- in the scope of the pattern, rename the pattern and expression+-- together so that it's safe to substitute the names under the pattern.+avoidCapture ∷ (Data a, Dv a i, Tag i) ⇒+               [VarId i] → QVarId i → a → Expr i → (a, Expr i)+avoidCapture fv_e' x' π e = second ($ e) (avoidCapture' fv_e' x' π e)++-- | Given a list of names not to capture, the variable being+-- substituted, a pattern, and an expression+-- in the scope of the pattern, rename the pattern and expression+-- together so that it's safe to substitute the names under the pattern.+avoidCapture' ∷ (Data a, Dv a i, Fv b i, Tag i) ⇒+                [VarId i] → QVarId i → a → b → (a, Expr i → Expr i)+avoidCapture' fv_e' x' π e+  | x' ∈ qdv π || x' `M.notMember` fv e = (π, id)+  | otherwise                           = (π', r)+  where+    fv_e  = [ idName x | J [] x ← M.keys (fv e) ]+    vs    = dv π ∩ fv_e'+    vs'   = ident <$> freshNames (Just . idName <$> vs)+                                 (fv_e ++ (idName <$> fv_e')) []+    π'    = foldr2 (\v v' → renameGeneric v' v) π vs vs'+    r e'  = foldr2 (\v v' → substExpr (exBVar v') (J [] v)) e' vs vs'++-- | Rename a variable+renameGeneric ∷ (Tag i, Data a) ⇒ VarId i → VarId i → a → a+renameGeneric x' x = everywhere (mkT each) where+  each y | x == y = x'+  each a          = a++---+--- GENERIC TUPLING+---++class ToTuple a b c where+  (-*-) ∷ a → [b] → c++infixl 3 -*-++instance (Tag i, ToPatt a i, ToPatt b i) ⇒ ToTuple a b (Patt i) where+  π -*- πs = foldl' paPair (toPatt π) (toPatt <$> πs)++instance (Tag i, ToExpr a i, ToExpr b i) ⇒ ToTuple a b (Expr i) where+  π -*- πs = foldl' exPair (toExpr π) (toExpr <$> πs)
− src/Syntax/Decl.hs 
@@ -1,331 +0,0 @@-{-# 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 
@@ -1,26 +0,0 @@--- 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, Typeable1)--data DeclNote i-data Decl' i-type Decl i = N (DeclNote i) (Decl' i)--instance Typeable1 DeclNote-instance Typeable1 Decl'-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 
@@ -1,325 +0,0 @@-{-# 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 
@@ -1,265 +0,0 @@-{-# 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 
@@ -1,12 +0,0 @@-module Syntax.Ident where--import Data.Data (Data, Typeable1)--class Id i--data TyVar i--instance Typeable1 TyVar-instance Data i => Data (TyVar i)-instance Id i   => Ord (TyVar i)-instance Id i   => Eq (TyVar i)
+ src/Syntax/ImplicitThreading.hs view
@@ -0,0 +1,1141 @@+-- | Translation of bang patterns, which introduce implicit threading.+module Syntax.ImplicitThreading (+  threadDecls, threadDecl, threadProg,+) where++import Util+import AST+import Data.Loc+import Error+import Meta.Quasi+import Syntax.Construction+import qualified Syntax.Ppr as Ppr++import Prelude ()+import Data.Generics (Data, everywhere, mkT, extT)+import qualified Data.Map as M+import qualified Data.Set as S++type R = Raw+type ThreadTrans a = MonadAlmsError m ⇒ a → m a++threadProg  ∷ ThreadTrans (Prog R)+threadDecls ∷ ThreadTrans [Decl R]+threadDecl  ∷ ThreadTrans (Decl R)++threadProg [prQ| $list:ds in $opt:me |] = do+  ds' ← mapM threadDecl ds+  me' ← mapM threadExpr me+  return [prQ| $list:ds' in $opt:me' |]++threadDecls = mapM threadDecl++threadDecl d0 = withLocation d0 $ case d0 of+  [dc| let $π = $e |]+    → do+    withLocation π $+      bassert (not (patternHasBang π)) [msg|+        Implicit threading translation does not allow ! patterns to appear+        declaration let bindings.+      |]+    e' ← threadExpr e+    return [dc| let $π = $e' |]+  [dc| let rec $list:bns |]+    → do+    bns' ← mapM threadBinding bns+    return [dc| let rec $list:bns' |]+  [dc| type $list:_ |] → return d0+  [dc| type $tid:_ = type $qtid:_ |] → return d0+  [dc| abstype $list:abstys with $list:ds end |]+    → do+      ds' ← mapM threadDecl ds+      return [dc| abstype $list:abstys with $list:ds' end |]+  [dc| module $mid:mid = $modexp |]+    → do+      modexp' ← threadModExp modexp+      return [dc| module $mid:mid = $modexp' |]+  [dc| module type $sid:_ = $_ |] → return d0+  [dc| open $modexp |]+    → do+      modexp' ← threadModExp modexp+      return [dc| open $modexp' |]+  [dc| local $list:ds1 with $list:ds2 end |]+    → do+      ds1' ← mapM threadDecl ds1+      ds2' ← mapM threadDecl ds2+      return [dc| local $list:ds1' with $list:ds2' end |]+  [dc| exception $uid:_ of $opt:_ |] → return d0+  [dc| $anti:a |] → $antifail++threadModExp ∷ ThreadTrans (ModExp R)+threadModExp modexp0 = withLocation modexp0 $ case modexp0 of+  [meQ| struct $list:ds end |]+    → do+      ds' ← mapM threadDecl ds+      return [meQ| struct $list:ds' end |]+  [meQ| $qmid:_ $list:_ |] → return modexp0+  [meQ| $modexp : $sigexp |]+    → do+      modexp' ← threadModExp modexp+      return [meQ| $modexp' : $sigexp |]+  [meQ| $anti:a |] → $antifail++threadBinding ∷ ThreadTrans (Binding R)+threadBinding bn0 = withLocation bn0 $ case bn0 of+  [bnQ| $vid:x = $e |]+    → do+    e' ← threadExpr e+    return [bnQ| $vid:x = $e' |]+  [bnQ| $antiB:a |] → $antifail++threadCaseAlt ∷ ThreadTrans (CaseAlt R)+threadCaseAlt ca0 = case ca0 of+  [caQ| $π → $e |]+    | (π', xs@(_:_)) ← patternBangRename π+    → do+    e'          ← beginTranslate xs e+    return [caQ| $π' → $e' |]+    | otherwise+    → do+    e'          ← threadExpr e+    return [caQ| $π → $e' |]+  [caQ| #$uid:c $opt:mπ → $e |]+    | Just (π', xs@(_:_)) ← patternBangRename <$> mπ+    → do+    e'          ← beginTranslate xs e+    return [caQ| #$uid:c $π' → $e' |]+    | otherwise+    → do+    e'          ← threadExpr e+    return [caQ| #$uid:c $opt:mπ → $e' |]+  [caQ| $antiC:a |] → $antifail++threadField ∷ ThreadTrans (Field R)+threadField fd0 = case fd0 of+  [fdQ| $uid:u = $e |]+    → do+    e' ← threadExpr e+    return [fdQ| $uid:u = $e' |]+  [fdQ| $antiF:a |] → $antifail++threadExpr ∷ ThreadTrans (Expr R)+threadExpr e = case e of+  [ex| $qvid:_ |]               → return e+  [ex| $lit:_   |]              → return e+  [ex| $qcid:c $opt:me |]+    → do+    me'         ← mapM threadExpr me+    return [ex| $qcid:c $opt:me' |]+  [ex| let $π = $e1 in $e2 |]+    | (π', xs@(_:_)) ← patternBangRename π+    → do+    e1'         ← threadExpr e1+    e2'         ← beginTranslate xs e2+    return [ex| let $π' = $e1' in $e2' |]+    | otherwise+    → do+    e1'         ← threadExpr e1+    e2'         ← threadExpr e2+    return [ex| let $π = $e1' in $e2' |]+  [ex| match $e0 with $list:cas |]+    → do+    e0'         ← threadExpr e0+    cas'        ← mapM threadCaseAlt cas+    return [ex| match $e0' with $list:cas' |]+  [ex| let rec $list:bns in $e1 |]+    → do+    bns'        ← mapM threadBinding bns+    e1'         ← threadExpr e1+    return [ex| let rec $list:bns' in $e1' |]+  [ex| let $decl:d in $e1 |]+    → do+    d'          ← threadDecl d+    e1'         ← threadExpr e1+    return [ex| let $decl:d' in $e1' |]+  [ex| ($e1, $e2) |]+    → do+    e1'         ← threadExpr e1+    e2'         ← threadExpr e2+    return [ex| ($e1', $e2') |]+  [ex| λ $π → $e2 |]+    | (π', xs@(_:_)) ← patternBangRename π+    → do+    e2'         ← beginTranslate xs e2+    return [ex| λ $π' → $e2' |]+    | otherwise+    → do+    e2'         ← threadExpr e2+    return [ex| λ $π → $e2' |]+  [ex| $e1 $e2 |]+    → do+    e1'         ← threadExpr e1+    e2'         ← threadExpr e2+    return [ex| $e1' $e2' |]+  [ex| `$uid:c $opt:me |]+    → do+    me'         ← mapM threadExpr me+    return [ex| `$uid:c $opt:me' |]+  [ex| #$uid:c $e2 |]+    → do+    e2'         ← threadExpr e2+    return [ex| #$uid:c $e2' |]+  [ex| { $list:flds | $e2 } |]+    → do+    flds'       ← mapM threadField flds+    e2'         ← threadExpr e2+    return [ex| { $list:flds' | $e2' } |]+  [ex| {+ $list:flds | $e2 +} |]+    → do+    flds'       ← mapM threadField flds+    e2'         ← threadExpr e2+    return [ex| {+ $list:flds' | $e2' +} |]+  [ex| $e1.$uid:u |]+    → do+    e1'         ← threadExpr e1+    return [ex| $e1'.$uid:u |]+  [ex| $e1 : $annot |]+    → do+    e1'         ← threadExpr e1+    return [ex| $e1' : $annot |]+  [ex| $e1 :> $annot |]+    → do+    e1'         ← threadExpr e1+    return [ex| $e1' :> $annot |]+  [ex| $anti:_ |] → return e++-- Synthesized attributes+data Synth+  = S {+      code      ∷ !(Expr R),+      typ       ∷ ![[VarId R]],+      vars      ∷ ![VarId R]+    }+  deriving Show++beginTranslate ∷ MonadAlmsError m ⇒ [VarId R] → Expr R → m (Expr R)+beginTranslate env0 e00 = do+  let e00_env = S.fromList env0+  e00' ← loop e00_env M.empty e00+  return $+    exLet' (r1 -*- vars e00') (code e00') $+      r1 -*- ren env0+  where+  loop env funs e = withLocation e $ case e of+    [ex| λ $π → $e1 |]+      → do+      let (π', new) = patternBangRename π+          e1_env    = (env ∖ dv π) ∪ new+      e1' ← loop e1_env funs e1+      let latent    = vars e1' ∖ ren new+          body      = optExAbs latent                           $+                        exLet' (r1 -*- vars e1') (code e1')     $+                          r1 -*- ren new ++ latent+      return S {+        vars = emptySet,+        typ  = latent : typ e1',+        code = [ex| λ $π' → $body |]+      }+    --+    [ex| $e1 $e2 |]+      | Just dv_π2@(_:_) ← expr2pattVars env e2+      → do+        e1'     ← loop env funs e1+        let (latent, cod_e1_typ) = splitType (typ e1')+            e_vars       = toList (vars e1' ∪ ren dv_π2 ∪ latent)+            interference = ren dv_π2 ∩ latent+            e2'          = ren e2+        bassert (null interference) $+          [msg|+            In implicit threading syntax expansion, the+            the operand of an application expression uses the+            some imperative variables that were also captured+            by the definition of the operator:+            <dl>+              <dt>operator:  <dd>$5:e1+              <dt>operand:   <dd>$5:e2+              <dt>variables: <dd>$interference+            </dl>+          |]+        return S {+          vars  = e_vars,+          typ   = cod_e1_typ,+          code  = exLet' (r1 -*- vars e1') (code e1')           $+                  exLet' (r2 -*- ren dv_π2 ++ latent)+                         (optExApp [ex| $vid:r1 $e2' |] latent) $+                    r2 -*- e_vars+        }+      | otherwise+      → do+        e1'     ← loop env funs e1+        e2'     ← loop env funs e2+        assertNotFun e2' "operand of an application expression" e2+        let (latent, cod_e1_typ) = splitType (typ e1')+            e_vars = toList (vars e1' ∪ vars e2' ∪ latent)+        return S {+          vars  = e_vars,+          typ   = cod_e1_typ,+          code  = exLet' (r1 -*- vars e1') (code e1')   $+                  exLet' (r2 -*- vars e2') (code e2')   $+                  exLet' (r -*- latent)+                         (optExApp [ex| $vid:r1 $vid:r2 |] latent) $+                    r -*- e_vars+        }+    --+    [ex| $vid:x |]+      | x ∈ env+      → return S {+          vars = [ren x],+          typ  = [],+          code = exPair (ren e) exUnit+        }+      | otherwise+      → return S {+          vars = [],+          typ  = M.findWithDefault [] x funs,+          code = e+        }+    [ex| $qvid:_ |]+      → return S {+          vars = [],+          typ  = [],+          code = e+        }+    [ex| $qcid:_ |]+      → return S {+          vars = [],+          typ  = [],+          code = e+        }+    [ex| $qcid:c1 $e2 |]+      → do+        e2' ← loop env funs e2+        assertNotFun e2' "argument of a data constructor" e2+        return S {+          vars = vars e2',+          typ  = [],+          code = exLet' (r -*- vars e2') (code e2') $+                   [ex| $qcid:c1 $vid:r |] -*- vars e2'+        }+    [ex| let $π = $e1 in $e2 |]+      | Just dv_π1@(_:_) ← expr2pattVars env e1+      → do+        let (π', new) = patternBangRename π+            hidden    = dv_π1 ∖ (dv π ∖ new)+            e2_env    = (env ∖ hidden ∖ dv π) ∪ new+            e1'       = ren e1+        e2'     ← loop e2_env funs e2+        let e_vars    = ren dv_π1 ∪ (vars e2' ∖ ren new)+            e_vars'   = [ if v ∈ ren new then exUnit else toExpr v+                        | v ← e_vars ]+            body      =+              censorVars (ren (dv_π1 ∖ dv π))    $+              exLet (r2 -*- vars e2') (code e2') $+                r2 -*- (toExpr <$> ren new) ++ e_vars'+            π''       = renOnly (env ∖ new) π'+        return S {+          vars  = e_vars,+          typ   = typ e2',+          code  = [ex| let $π'' = $e1' in $body |]+        }+      | otherwise+      → do+        e1'     ← loop env funs e1+        case typ e1' of+          _:_+            | [pa| $vid:x |] ← π+            → do+              let e2_env  = env ∖ [x]+                  e2_funs = M.insert x (typ e1') funs+              e2'         ← loop e2_env e2_funs e2+              let e_vars  = vars e1' ∪ vars e2'+              return S {+                vars = e_vars,+                typ  = typ e2',+                code = (exLet (x -*- vars e1') (code e1') $+                        exLet' (r2 -*- vars e2') (code e2') $+                          r2 -*- e_vars)+                       <<@ _loc+              }+          _ → do+              assertNotFun e1' "right-hand side of a let expression" e1+              let (π', new)     = patternBangRename π+                  e2_env        = env ∪ new+              e2'               ← loop e2_env funs e2+              let e_vars        = vars e1' ∪ (vars e2' ∖ ren new)+              return S {+                vars = e_vars,+                typ  = typ e2',+                code = (exLet' (r1 -*- vars e1') (code e1')      $+                        exLet' (r -*- (vars e2' ∖ ren new))+                               (exLet π' (toExpr r1)    $+                                exLet' (r2 -*- vars e2') (code e2') $+                                  ((r2 -*- ren new ∷ Expr Raw)+                                     -*- (vars e2' ∖ ren new)))  $+                          (r -*- e_vars))+                      <<@ _loc+              }+    [ex| $lit:_ |]+      → return S {+          vars = [],+          typ  = [],+          code = e+        }+    --+    [ex| match $e0 with $list:cas |]+      → do+        (used, changed, rhs) ←+          case expr2pattVars env e0 of+            Just dv_π0@(_:_) →+              return (S.fromList dv_π0, [], ren e0)+            _                     → do+              e0' ← loop env funs e0+              assertNotFun e0' "expression in match" e0+              return (emptySet, vars e0', code e0')+        let decompose [caQ|@=loc $πi → $ei |]+                    = let (πi', newi) = patternBangRename πi+                       in (dv πi, newi ∖ used, Left πi', ei, loc)+            decompose [caQ|@=loc #$uid:c → $ei |]+                    = ([], [], Right (c, Nothing), ei, loc)+            decompose [caQ|@=loc #$uid:c $πi → $ei |]+                    = let (πi', newi) = patternBangRename πi+                       in (dv πi, newi ∖ used, Right (c, Just πi'), ei, loc)+            decompose [caQ|@=loc $antiC:a |] = $antierror+        let (dv_πs, news, eπs', es, locs)+                    = unzip5 (decompose <$> cas)+            hides   = ren ((used ∖) <$> dv_πs)+            ei_envs = zipWith (\dv_πi newi → (env ∖ dv_πi) ∪ used ∪ newi)+                              dv_πs news+        synths  ← zipWithM (loop <-> funs) ei_envs es+        let e_vars  = foldl' (∪) (changed ∪ ren used)+                                 (zipWith (∖) (vars <$> synths) (ren news))+            e_typ   = foldl' joinType [] (typ <$> synths)+            coerces = (`coerceType` e_typ) <$> typ <$> synths+            cas'    = [ let body = censorVars (toList hidei)          $+                                   exLet' (r -*- vars ei') (code ei') $+                                     coercei -*- e_vars+                         in case renOnly used eπi' of+                              Left πi'+                                → [caQ|@=loc $πi' → $body |]+                              Right (c, mπi')+                                → [caQ|@=loc #$uid:c $opt:mπi' → $body |]+                      | eπi'    ← eπs'+                      | hidei   ← hides+                      | ei'     ← synths+                      | coercei ← coerces+                      | loc     ← locs]+        return S {+          vars = e_vars,+          typ  = e_typ,+          code = exLet' (r -*- changed) rhs $+                 [ex| match $vid:r with $list:cas' |]+        }+    --+    [ex| let rec $list:bns in $e2 |]+      → do+        -- We infer the types of recursive functions by iterating to+        -- a fixpoint.  Does this terminate?  I believe it's monotone+        -- and in a finite domain, so it should.+        let bloop previous = do+              let env'  = env ∖ (fst <$> previous)+                  funs' = foldr (uncurry M.insert) funs previous+              (fτs, bns') ← unzip `liftM` mapM (binding env' funs') bns+              if (previous == fτs)+                then return (env', funs', bns')+                else bloop fτs+        (e2_env, e2_funs, bns') ← bloop []+        e2'                     ← loop e2_env e2_funs e2+        let e2_code             = code e2'+        return S {+          vars = vars e2',+          typ  = typ e2',+          code = [ex| let rec $list:bns' in $e2_code |]+        }+    [ex| let $decl:d in $e2 |]+      → do+        d'              ← threadDecl d+        -- Note: decl bindings do not shadow bang variables+        e2'             ← loop env funs e2+        let e2_code     = code e2'+        return S {+          vars = vars e2',+          typ  = typ e2',+          code = [ex| let $decl:d' in $e2_code |]+        }+    [ex| ($e1, $e2) |]+      → do+        e1' ← loop env funs e1+        e2' ← loop env funs e2+        assertNotFun e1' "tuple component" e1+        assertNotFun e2' "tuple component" e2+        let e_vars = vars e1' ∪ vars e2'+        return S {+          vars  = e_vars,+          typ   = [],+          code  = exLet' (r1 -*- vars e1') (code e1') $+                  exLet' (r2 -*- vars e2') (code e2') $+                    [ex| ($vid:r1, $vid:r2) |] -*- e_vars+        }+    [ex| `$uid:_ |]+      → return S {+          vars = [],+          typ  = [],+          code = e+        }+    [ex| `$uid:c1 $e2 |]+      → do+        e2' ← loop env funs e2+        assertNotFun e2' "argument of a variant constructor" e2+        return S {+          vars = vars e2',+          typ  = [],+          code = exLet' (r -*- vars e2') (code e2') $+                   [ex| `$uid:c1 $vid:r |] -*- vars e2'+        }+    [ex| #$uid:c1 $e2 |]+      → do+        e2' ← loop env funs e2+        assertNotFun e2' "argument of a variant embedding" e2+        return S {+          vars = vars e2',+          typ  = [],+          code = exLet' (r -*- vars e2') (code e2') $+                   [ex| #$uid:c1 $vid:r |] -*- vars e2'+        }+    [ex| { $list:flds1 | $e2 } |]+      → let eachField [] =+              withLocation e2 $ do+                e2' ← loop env funs e2+                assertNotFun e2' "record in extension expression" e2+                return e2'+            eachField ([fdQ|@=loci $uid:ui = $ei |]:flds) =+              withLocation loci $ do+                ei'       ← loop env funs ei+                flds'     ← eachField flds+                assertNotFun ei' "field of record" ei+                let each_vars = vars ei' ∪ vars flds'+                return S {+                  vars = each_vars,+                  typ  = [],+                  code = exLet' (r1 -*- vars ei') (code ei') $+                         exLet' (r2 -*- vars flds') (code flds') $+                           [ex| { $uid:ui = $vid:r1 | $vid:r2 } |]+                             -*- each_vars+                }+            eachField ([fdQ|! $antiF:a |]:_) = $antifail+         in eachField flds1+    [ex| {+ $list:flds1 | $e2 +} |]+      → do+        sequence_+          [ withLocation loci $ do+              ei' ← loop env funs ei+              assertNotFun ei' "field of record" ei+              assertNoCapture ei' "Additive-record field"+          | [fdQ|@=loci $uid:_ = $ei |] ← flds1 ]+        e2' ← loop env funs e2+        assertNotFun e2' "record in extension expression" e2+        assertNoCapture e2' "Additive-record in extension expression"+        return S {+          vars = [],+          typ  = [],+          code = e+        }+    [ex| $e1.$uid:u |]+      → do+        e1' ← loop env funs e1+        assertNotFun e1' "record in selector expression" e1+        return S {+          vars = vars e1',+          typ  = [],+          code = exLet' (r1 -*- vars e1') (code e1') $+                   [ex| $vid:r1.$uid:u |] -*- vars e1'+        }+    [ex| $e1 : $annot |]+      → do+        e1' ← loop env funs e1+        return S {+          vars = vars e1',+          typ  = typ e1',+          code = exLet' (r -*- vars e1') (code e1') $+                   [ex| $vid:r : $annot |] -*- vars e1'+        }+    [ex| $e1 :> $annot |]+      → do+        e1' ← loop env funs e1+        return S {+          vars = vars e1',+          typ  = typ e1',+          code = exLet' (r -*- vars e1') (code e1') $+                   [ex| $vid:r :> $annot |] -*- vars e1'+        }+    [ex| $anti:a |]+      → $antifail+  --+  binding env funs bn = withLocation bn $ case bn of+    [bnQ| $vid:f = $e |] → do+      let env_e = env ∖ [f]+      e'        ← loop env_e funs e+      bassert (null (vars e')) $+        [msg|+          In implicit threading syntax expansion, imperative variables+          may not be used on the right-hand side of a let rec binding+          unless they occur in the body of a function.+          <dl>+            <dt>In binding:      <dd> $f+            <dt>Used variables:  <dd> $1+          </dl>+        |]+        (vars e')+      let e_code        = code e'+      return ((f, typ e'), [bnQ| $vid:f = $e_code |])+    [bnQ| $antiB:a |]    → $antifail+++-- Find the least-upper bound of two variable/effect types.+joinType ∷ [[VarId R]] → [[VarId R]] → [[VarId R]]+joinType (vs1:rest1) (vs2:rest2) = (vs1 ∪ vs2) : joinType rest1 rest2+joinType []          τ2          = τ2+joinType τ1          []          = τ1++-- | Coerce a value whose variable/effect type is the first argument+--   to have the effect of the second. Assumes that the second subsumes+--   the first.  Assumes that the value is named @r@.+coerceType ∷ [[VarId R]] → [[VarId R]] → Expr R+coerceType _            []           = toExpr r+coerceType reste        restg+  | reste == restg                   = toExpr r+coerceType []           (gots:restg) =+  exAbsVar' r1 $+    optExAbs gots $+      exLetVar' r (exApp (toExpr r) (toExpr r1)) $+        coerceType [] restg -*- gots+coerceType (exps:reste) (gots:restg) =+  exAbsVar' r1 $+    optExAbs gots $+      exLet' (r -*- exps)+             (optExApp (exApp (toExpr r) (toExpr r1)) exps) $+        coerceType reste restg -*- gots++-- | Shadow some variables with @()@.+censorVars        ∷ [VarId R] → Expr R → Expr R+censorVars []     = id+censorVars (v:vs) = exLet' (v -*- vs) (exUnit -*- exUnit <$ vs)++-- Given an expression and a list, apply the expression to the+-- tuple of the list only if the list is non-empty.+optExApp  ∷ (Tag i, ToExpr a i) ⇒ Expr i → [a] → Expr i+optExApp e0 []          = e0+optExApp e0 (e1:es)     = exApp e0 (e1 -*- es)++-- Given an expression and a list, abstract to a tuple pattern+-- of the list only if the list is non-empty.+optExAbs  ∷ (Tag i, ToPatt a i) ⇒ [a] → Expr i → Expr i+optExAbs []      e0    = e0+optExAbs (π1:πs) e0    = exAbs' (π1 -*- πs) e0++-- Split a type into the latent effect and the codomain+splitType ∷ [[a]] → ([a], [[a]])+splitType []     = ([], [])+splitType (v:vs) = (v, vs)++-- | Given a pattern, rename any !-ed variables, remove the ! itself,+--   and return the list of renamed variables.+patternBangRename ∷ Patt R → (Patt R, [VarId R])+patternBangRename = runWriter . loop False+  where+  loop doIt π0 = case π0 of+    [pa| $vid:x  |]+      | doIt                       → do+        tell [x]+        let x' = ren x+        return [pa| $vid:x' |]+      | otherwise                 → return π0+    [pa| _ |]                     → return π0+    [pa| $qcid:c $opt:mπ |]       → do+      mπ' ← mapM (loop doIt) mπ+      return [pa| $qcid:c $opt:mπ' |]+    [pa| ($π1, $π2) |]            → do+      π1' ← loop doIt π1+      π2' ← loop doIt π2+      return [pa| ($π1', $π2') |]+    [pa| $lit:_ |]                → return π0+    [pa| $π as $vid:x |]          → do+      π' ← loop doIt π+      return [pa| $π' as $vid:x |]+    [pa| `$uid:c $opt:mπ |]       → do+      mπ' ← mapM (loop doIt) mπ+      return [pa| `$uid:c $opt:mπ' |]+    [pa| $π : $annot |]           → do+      π' ← loop doIt π+      return [pa| $π' : $annot |]+    [pa| {$uid:u = $π1 | $π2} |]  → do+      π1' ← loop doIt π1+      π2' ← loop doIt π2+      return [pa| { $uid:u = $π1' | $π2' } |]+    [pa| ! $π |]                  → loop True π+    [pa| $anti:a |]               → $antifail++patternHasBang ∷ Patt i → Bool+patternHasBang π0 = case π0 of+  [pa| $vid:_  |]               → False+  [pa| _ |]                     → False+  [pa| $qcid:_ $opt:mπ |]       → maybe False patternHasBang mπ+  [pa| ($π1, $π2) |]            → patternHasBang π1 || patternHasBang π2+  [pa| $lit:_ |]                → False+  [pa| $π as $vid:_ |]          → patternHasBang π+  [pa| `$uid:_ $opt:mπ |]       → maybe False patternHasBang mπ+  [pa| $π : $_ |]               → patternHasBang π+  [pa| {$uid:_ = $π1 | $π2} |]  → patternHasBang π1 || patternHasBang π2+  [pa| ! $_ |]                  → True+  [pa| $anti:a |]               → $antierror++ren :: Data a => a → a+ren = everywhere (mkT eachRaw `extT` eachRen) where+  eachRaw ∷ VarId Raw     → VarId Raw+  eachRen ∷ VarId Renamed → VarId Renamed+  eachRaw = each; eachRen = each+  each    ∷ Tag i ⇒ VarId i → VarId i+  each (VarId (LidAnti a)) = VarId (LidAnti a)+  each (VarId (Lid i s))   = VarId (Lid i (s ++ "!"))++renOnly :: ∀ a i. (Data a, Tag i) ⇒ S.Set (VarId i) → a → a+renOnly set = everywhere (mkT each) where+  each    ∷ VarId i → VarId i+  each vid | vid `S.member` set = ren vid+           | otherwise          = vid++{-+---- The first order, 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 ]]+  [[ c e ]]   = let (r, y) = [[ e ]] in+                  (c r, y)++-- The first order 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 ::= 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]++-- The pattern and function case (3):++  Types:+    τ ∷= 1 → τ / [VarId]+       | 1++  Inherited attributes:+    - env  ∷ S.Set VarId+    - funs ∷ S.Map VarId τ      -- τ is renamed++  Synthesized attributes:+    - vars  ∷ [VarId]           -- renamed+    - type  ∷ τ                 -- renamed+    - code  ∷ Expr++  Notation+    • e! is e renamed+    • [xs/ys]e is the substitution of xs for ys in e+    • [!xs]e = [!xs/xs]e+    • {vs} means include this only if vs is non-empty++  π → e1             ==>   [!e1.env]π →+                             let (r1, e1.vars) = e1.code+                              in (r1, !e1.env)+                           where e1.env  = bangvars(π)+                                 e1.funs = ∅++  let π = e1 in e2   ==>   let [!e.env]π = e1 in+                            let (r1, e2.vars) = e2.code+                             in (r1, !e2.env)+                            where e2.env  = bangvars π+                                  e2.funs = ∅++  e ::= λ π → e1++    new    = bangvars(π)+    latent = e1.vars \ !new++    e1.env = (e.env \ dv π) ∪ new+    e.vars = ∅+    e.type = 1 → e1.type / latent++    e.code = λ [!new]π {latent} →+               let (r, e1.vars) = e1.code in+                 (r, {!new}, {latent})++  e ::= e1 π2++    [ dv π2 nonempty ⊆ e.env ]++    latent = latent(e1.type)++      [ !(dv π2) ∩ latent ≠ ∅ ] ERROR!++    e.vars = e1.vars ∪ !(dv π2) ∪ latent+    e.type = cod(e1.type)+    e.code = let (r1, e1.vars)           = e1.code in+             let (r, !(dv π2), {latent}) = r1 !π2 {latent} in+              (r, e.vars)++  e ::= e1 e2++    [ e2.type ≠ 1 ]++    ERROR!++    latent = latent(e1.type)++    e.vars = e1.vars ∪ e2.vars ∪ latent+    e.type = cod(e1.type)+    e.code = let (r1, e1.vars)  = e1.code in+             let (r2, e2.vars)  = e2.code in+             let (r,  {latent}) = r1 r2 {latent} in+               (r, e.vars)++  e ::= x++    [ x ∈ e.env ]++    e.vars = !x+    e.type = 1+    e.code = (!x, ())++    [ otherwise ]++    e.vars = ∅+    e.type = e.funs(x) || 1+    e.code = x++  e ::= c1 e2++    [ e2.type ≠ 1 ]++    ERROR!++    [ otherwise ]++    e.vars  = e2.vars+    e.type  = 1+    e.code  = let (r, e2.vars) = e2 in+                (c1 r, e.vars)++  e ::= let π = π1 in e2++    [ dv π1 nonempty ⊆ e.env ]++    new    = bangvars(π)+    hidden = dv π1 \ (dv π \ new)++    e2.env = (e.env \ hidden \ dv π) ∪ new+    e.vars = !(dv π1) ∪ (e2.vars \ !new)+    e.type = e2.type+    e.code = let [!new][!π1]π    = !π1 in+             let !(dv π1 \ dv π) = () ... () in+             let (r2, e2.vars)   = e2.code in+               ((r2, !new), [()/!new]e.vars)++  e ::= let x = e1 in e2++    [ e1.type ≠ 1 ]++    e2.env  = e.env \ x+    e2.funs = e.funs[x ↦ e1.type]+    e.vars  = e1.vars ∪ e2.vars+    e.type  = e2.type+    e.code  = let (x, e1.vars)  = e1 in+              let (r2, e2.vars) = e2 in+                (r2, e.vars)++  e ::= let π = e1 in e2++    [ e1.type ≠ 1 ]++    ERROR!++    [ otherwise ]++    new    = bangvars(π)++    e2.env = e.env ∪ new+    e.vars = e1.vars ∪ (e2.vars \ !new)+    e.type = e2.type++    e.code = let (r1, e1.vars) = e1.code in+             let (r, e2.vars \ !new) =+                 let [!new]π       = r1 in+                 let (r2, e2.vars) = e2.code in+                   ((r2, !new), e2.vars \ !new) in+               (r, e.vars)++  e ::= match e0 with+        | π1 → e1+        ⋮+        | πk → ek++  {+    [ e0 = π0 ⋀ dv π0 nonempty ⊆ e.env ]++      used    = dv π0+      changed = ∅+      rhs     = !π0++    [ e0.type ≠ 1 ]++      ERROR++    [ otherwise ]++      used    = ∅+      changed = e0.vars+      rhs     = e0.code+  }++    newᵢ   = bangvars(πᵢ) \ used+    hideᵢ  = !(used \ dv πᵢ)+    eᵢ.env = (e.env \ dv πᵢ) ∪ used ∪ newᵢ++    e.vars = !used ∪ changed ∪ (e1.vars \ !new1) ∪ ... ∪ (ek.vars \ !newk)+    e.type = e1.type ⊔ ... ⊔ ek.type+    coerceᵢ= eᵢ.type ⇝ e.type++    e.code = let (r, changed) = rhs in+               match r with+               | [!used][!new]π1 →+                   let hide1        = () ... () in+                   let (r, e1.vars) = e1.code in+                     (coerce1 r, e.vars)+               ⋮+               | [!used][!new]πk →+                   let hidek        = () ... () in+                   let (r, ek.vars) = ek.code in+                     (coercek r, e.vars)++-}++r, r1, r2 :: VarId R+r       = ident "r.!"+r1      = ident "r1.!"+r2      = ident "r2.!"++-- | Transform an expression into a pattern, if possible, using only+--   the specified variables, and return the set of variables used.+expr2pattVars ∷ S.Set (VarId R) → Expr R → Maybe [VarId R]+expr2pattVars vs0 e0 = evalStateT (loop e0) vs0+  where+  loop e = case e of+    [ex| $vid:x |]                      → do+      possible ← get+      if x `S.member` possible+        then do+          put (S.delete x possible)+          return [x]+        else mzero+    [ex| $lit:_ |]                      → return []+    [ex| $qcid:_ $opt:me |]             → concatMapM loop me+    [ex| ($e1, $e2) |]                  → mappend <$> loop e1 <*> loop e2+    [ex| `$uid:_ $opt:me |]             → concatMapM loop me+    [ex| $e1 : $_ |]                    → loop e1+    [ex| $qvid:_ |]                     → mzero+    [ex| let $_ = $_ in $_ |]           → mzero+    [ex| match $_ with $list:_ |]       → mzero+    [ex| let rec $list:_ in $_ |]       → mzero+    [ex| let $decl:_ in $_ |]           → mzero+    [ex| λ $_ → $_ |]                   → mzero+    [ex| $_ $_ |]                       → mzero+    [ex| #$uid:_ $_ |]                  → mzero+    [ex| { $list:flds | $e2 } |]        → mappend <$> concatMapM loopField flds+                                                  <*> loop e2+    [ex| {+ $list:_ | $_ +} |]          → mzero+    [ex| $_.$uid:_ |]                   → mzero+    [ex| $anti:_ |]                     → mzero+    [ex| $_ :> $_ |]                    → mzero+  --+  loopField [fdQ| $uid:_ = $ei |]       = loop ei+  loopField [fdQ| $antiF:_ |]           = mzero++---+--- Producing errors+---++-- | Indicate a bug in the bang translator.+bangBug         ∷ MonadAlmsError m ⇒ String → String → m a+bangBug         = throwAlms <$$> almsBug ParserPhase++-- | Indicate a bug in the bang translator, with no Alms error monad.+bangBugError    ∷ String → String → a+bangBugError    = throw <$$> almsBug ParserPhase++-- | Indicate a bang translation error.+bangError       ∷ (MonadAlmsError m, Bogus a) ⇒ Message V → m a+bangError msg0  = do+  reportAlms (AlmsError ParserPhase bogus msg0)+  return bogus++-- | Indicate a bang error.+bangError_      ∷ MonadAlmsError m ⇒ Message V → m ()+bangError_      = bangError++-- | Indicate a bang error from which we cannot recover.+bangError'      ∷ MonadAlmsError m ⇒ Message V → m a+bangError'      = throwAlms <$> AlmsError ParserPhase bogus++-- | Assert some condition, indicating a bang translation error if+--   it doesn't hold.+bassert         ∷ MonadAlmsError m ⇒ Bool → Message V → m ()+bassert True _  = return ()+bassert False m = bangError m++-- | Assert that the type of the given synthesized attribute is trivial,+--   indicating that the term it belongs to hasn't captured any bang+--   vars.  Also takes a description of the role of the term and the+--   term itself.+assertNotFun   ∷ (MonadAlmsError m, Ppr.Ppr a, Ppr.Ppr b) ⇒ +                  Synth → a → b → m ()+assertNotFun e' =+  bassert (all null (typ e')) <$$>+    [msg|+      In implicit threading syntax expansion, the $2 cannot be a+      function that captures some imperative variables.+      <dl>+        <dt>culprit:    <dd>$5:3+        <dt>captured:   <dd>$1+      </dl>+    |]+    (fromOpt [] (typ e'))++assertNoCapture ∷ (MonadAlmsError m, Ppr.Ppr a) ⇒+                  Synth → a → m ()+assertNoCapture e' =+  bassert (null (vars e')) <$>+    [msg|+      $2 may not capture implicitly threaded variables:+      <dl>+        <dt>captures: <dd>$1+      </dl>+    |]+    (vars e')
− src/Syntax/Kind.hs 
@@ -1,263 +0,0 @@-{-# 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/Lexer.hs view
@@ -0,0 +1,351 @@+-- | Lexer setup for parsec+module Syntax.Lexer (+  -- * Class for saving pre-whitespace position+  T.TokenEnd(..),+  -- * Identifier tokens+  isUpperIdentifier, lid, uid,+  llabel, ulabel,++  -- * Operators+  opP,+  cons, semis, bang, star,+  pragma,+  lolli, arrow, funbraces, plusbraces,+  lambda, forall, exists, mu,+  qualbox,+  qualU, qualA, qjoin, qjoinArr, ellipsis,+  variantInj, variantEmb,+  sigilU, sigilA,+  markCovariant, markContravariant, markInvariant, markOmnivariant,+  markQVariant,++  -- * 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 Syntax.Prec+import Util+import Alt.Parsec+import qualified Alt.Token as T++import Prelude ()+import Data.Char+import qualified Data.List as List++tok :: T.TokenEnd st => T.TokenParser st+tok = T.makeTokenParser T.LanguageDef {+    T.commentStart   = "(*",+    T.commentEnd     = "*)",+    T.commentLine    = "--",+    T.nestedComments = True,+    T.identStart     = noλμ $ upper <|> lower <|> oneOf "_",+    T.identLetter    = alphaNum <|> oneOf "_'′₀₁₂₃₄₅₆₇₈₉⁰¹²³⁴⁵⁶⁷⁸⁹ᵢⱼₐₑₒₓⁱⁿ",+    T.opStart        = satisfy isOpStart <|> plusNoBrace,+    T.opLetter       = satisfy isOpLetter <|> plusNoBrace,+    T.reservedNames  = ["fun", "λ",+                        "if", "then", "else",+                        "match", "with", "as", "_",+                        "try",+                        "local", "open", "exception",+                        "let", "rec", "and", "in",+                        "interface", "abstype", "end",+                        "module", "struct",+                        "sig", "val", "include",+                        "all", "ex", "mu", "μ", "of",+                        "type", "qualifier" ],+    T.reservedOpNames = ["|", "=", ":", ":>", "->", "→", "⊸",+                         "∀", "∃", "⋁", "\\/", "...", "…", "::", "∷" ],+    T.caseSensitive = True+  }+  -- 'λ' is not an identifier character, so that we can use it as+  -- a reserved operator. Otherwise, we'd need a space after it.+  where noλμ p      = notFollowedBy (char 'λ' <|> char 'μ') *> p+        plusNoBrace = char '+' <* notFollowedBy (char '}')++isOpStart, isOpLetter :: Char -> Bool+isOpStart c+  | isAscii c = c `elem` "!$%&*-/<=>?@^|~"+  | otherwise = case generalCategory c of+      ConnectorPunctuation  -> True+      DashPunctuation       -> True+      OtherPunctuation      -> True+      MathSymbol            -> True+      CurrencySymbol        -> True+      OtherSymbol           -> True+      ModifierSymbol        -> True+      OpenPunctuation       -> True+      ClosePunctuation      -> True+      _                     -> False+isOpLetter c+  | isAscii c = c `elem` "!$%&*-/<=>?@^|~.:"+  | otherwise = case generalCategory c of+      ConnectorPunctuation  -> True+      DashPunctuation       -> True+      OtherPunctuation      -> True+      MathSymbol            -> True+      CurrencySymbol        -> True+      OtherSymbol           -> True+      ModifierSymbol        -> True+      OpenPunctuation       -> True+      ClosePunctuation      -> True+   -- InitialQuote+   -- FinalQuote+      _                     -> False++identifier      :: T.TokenEnd st => CharParser st String+identifier       = T.identifier tok+reserved        :: T.TokenEnd st => String -> CharParser st ()+reserved         = T.reserved tok+operator        :: T.TokenEnd st => CharParser st String+operator         = T.operator tok+reservedOp      :: T.TokenEnd st => String -> CharParser st ()+reservedOp       = T.reservedOp tok+charLiteral     :: T.TokenEnd st => CharParser st Char+charLiteral      = T.charLiteral tok+stringLiteral   :: T.TokenEnd st => CharParser st String+stringLiteral    = T.stringLiteral tok+natural         :: T.TokenEnd st => CharParser st Integer+natural          = T.natural tok+integer         :: T.TokenEnd st => CharParser st Integer+integer          = lexeme $ try $ do+  sign <- choice [+            char '+' >> return id,+            char '-' >> return negate,+            return id+          ]+  nat  <- natural+  return (sign nat)+integerOrFloat  :: T.TokenEnd st => 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           :: T.TokenEnd st => CharParser st Double+float            = T.float tok+naturalOrFloat  :: T.TokenEnd st => CharParser st (Either Integer Double)+naturalOrFloat   = T.naturalOrFloat tok+decimal         :: T.TokenEnd st => CharParser st Integer+decimal          = T.decimal tok+hexadecimal     :: T.TokenEnd st => CharParser st Integer+hexadecimal      = T.hexadecimal tok+octal           :: T.TokenEnd st => CharParser st Integer+octal            = T.octal tok+symbol          :: T.TokenEnd st => String -> CharParser st String+symbol           = T.symbol tok+lexeme          :: T.TokenEnd st => CharParser st a -> CharParser st a+lexeme           = T.lexeme tok+whiteSpace      :: T.TokenEnd st => CharParser st ()+whiteSpace       = T.whiteSpace tok+parens          :: T.TokenEnd st => CharParser st a -> CharParser st a+parens           = T.parens tok+braces          :: T.TokenEnd st => CharParser st a -> CharParser st a+braces           = T.braces tok+angles          :: T.TokenEnd st => CharParser st a -> CharParser st a+angles           = T.angles tok+brackets        :: T.TokenEnd st => CharParser st a -> CharParser st a+brackets         = T.brackets tok+squares         :: T.TokenEnd st => CharParser st a -> CharParser st a+squares          = T.squares tok+semi            :: T.TokenEnd st => CharParser st String+semi             = T.semi tok+comma           :: T.TokenEnd st => CharParser st String+comma            = T.comma tok+colon           :: T.TokenEnd st => CharParser st String+colon            = T.reservedOp tok ":" >> return ":"+dot             :: T.TokenEnd st => CharParser st String+dot              = T.dot tok+semiSep         :: T.TokenEnd st => CharParser st a -> CharParser st [a]+semiSep          = T.semiSep tok+semiSep1        :: T.TokenEnd st => CharParser st a -> CharParser st [a]+semiSep1         = T.semiSep1 tok+commaSep        :: T.TokenEnd st => CharParser st a -> CharParser st [a]+commaSep         = T.commaSep tok+commaSep1       :: T.TokenEnd st => CharParser st a -> CharParser st [a]+commaSep1        = T.commaSep1 tok++-- | Parse a pragma or a prefix thereof+pragma          :: T.TokenEnd st ⇒ String → CharParser st ()+pragma name      = try $ do+  char '#'+  s ← lid+  guard (s `List.isPrefixOf` name)++-- | @!@, which has special meaning in let patterns+bang            :: T.TokenEnd st => CharParser st String+bang             = symbol "!"++-- | The @-o@ type operator, which violates our other lexer rules+lolli           :: T.TokenEnd st => CharParser st ()+lolli            = reserved "-o" <|> reservedOp "⊸"++-- | The @->@ type operator+arrow           :: T.TokenEnd st => CharParser st ()+arrow            = reservedOp "->" <|> reservedOp "→"++-- | The left part of the $-_>$ operator+funbraceLeft    :: T.TokenEnd st => CharParser st ()+funbraceLeft     = () <$ symbol "-"++-- | The right part of the $-_>$ operator+funbraceRight   :: T.TokenEnd st => CharParser st ()+funbraceRight    = () <$ symbol ">"++-- | The left part of the $-[_]>$ operator+oldFunbraceLeft    :: T.TokenEnd st => CharParser st ()+oldFunbraceLeft     = () <$ try (symbol "-[")++-- | The right part of the $-[_]>$ operator+oldFunbraceRight   :: T.TokenEnd st => CharParser st ()+oldFunbraceRight    = () <$ try (symbol "]>")++funbraces       :: T.TokenEnd st => CharParser st a -> CharParser st a+funbraces        = liftM2 (<|>) (between oldFunbraceLeft oldFunbraceRight)+                                (between funbraceLeft funbraceRight)++-- | Curly braces with + symbols+plusbraces      :: T.TokenEnd st => CharParser st a -> CharParser st a+plusbraces       = between (try (symbol "{+")) (try (symbol "+}"))++-- | The left part of the $|[_]$ annotation+qualboxLeft     :: T.TokenEnd st => CharParser st ()+qualboxLeft      = () <$ try (symbol "|[")++-- | The right part of the $|[_]$ annotation+qualboxRight    :: T.TokenEnd st => CharParser st ()+qualboxRight     = () <$ symbol "]"++qualbox         :: T.TokenEnd st => CharParser st a -> CharParser st a+qualbox          = between qualboxLeft qualboxRight++-- | The function keyword+lambda          :: T.TokenEnd st => CharParser st ()+lambda           = reserved "fun" <|> reservedOp "λ"++-- | The universal quantifier keyword+forall          :: T.TokenEnd st => CharParser st ()+forall           = reserved "all" <|> reservedOp "∀"++-- | The existential quantifier keyword+exists          :: T.TokenEnd st => CharParser st ()+exists           = reserved "ex" <|> reservedOp "∃"++-- | The recursive type binder+mu              :: T.TokenEnd st => CharParser st ()+mu               = reserved "mu" <|> reservedOp "μ"++-- | The list constructor+cons            :: T.TokenEnd st => CharParser st ()+cons             = reservedOp "::" <|> reservedOp "∷"++-- | @;@, @;;@, ...+semis           :: T.TokenEnd st => CharParser st String+semis            = lexeme (many1 (char ';'))++-- | @*@, which gets special treatment for unicode+star            :: T.TokenEnd st => CharParser st String+star             = symbol "*" <|> symbol "×"++-- | Qualifier @U@ (not reserved)+qualU    :: T.TokenEnd st => CharParser st ()+qualU     = reserved "U"+-- | Qualifier @A@ (not reserved)+qualA    :: T.TokenEnd st => CharParser st ()+qualA     = reserved "A"++-- | Infix operator for qualifier disjunction+qjoin           :: T.TokenEnd st => CharParser st String+qjoin            = "\\/" <$ (reservedOp "\\/" <|> reservedOp "⋁")++-- | Infix operator for qualifier disjunction in type arrows+qjoinArr        :: T.TokenEnd st => CharParser st ()+qjoinArr         = reservedOp "," <|> reservedOp "\\/" <|> reservedOp "⋁"++-- | Postfix ellipsis type operator+ellipsis        :: T.TokenEnd st => CharParser st ()+ellipsis         = () <$ (reservedOp "..." <|> reservedOp "…")++-- | Marker for open variant injection+variantInj      :: T.TokenEnd st => CharParser st ()+variantInj       = () <$ symbol "`"++-- | Marker for open variant embedding+variantEmb      :: T.TokenEnd st => CharParser st ()+variantEmb       = () <$ symbol "#"++-- | Marker for unlimited type variables+sigilU   :: T.TokenEnd st => CharParser st ()+sigilU    = () <$ symbol "'"++-- | Marker for affine type variables+sigilA   :: T.TokenEnd st => CharParser st ()+sigilA    = () <$ symbol "`"++markCovariant, markContravariant, markInvariant, markOmnivariant,+  markQVariant :: T.TokenEnd st => CharParser st ()++markCovariant        = () <$ symbol "+"+markContravariant    = () <$ symbol "-"+markInvariant        = () <$ symbol "="+markOmnivariant      = () <$ symbol "0"+markQVariant         = () <$ symbol "Q"++-- | 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 "[]"    = True+isUpperIdentifier "::"    = True+isUpperIdentifier (c:_)   = isUpper c+isUpperIdentifier _       = False++-- | Lex a lowercase identifer+lid        :: T.TokenEnd st => CharParser st String+lid              = try $ do+  s <- identifier+  if isUpperIdentifier s+    then pzero <?> "lowercase identifier"+    else return s++-- | Lex an uppercase identifer+uid        :: T.TokenEnd st => CharParser st String+uid              = try $ do+  s <- identifier <|> symbol "()" <|> symbol "[]"+  if isUpperIdentifier s+    then return s+    else pzero <?> "uppercase identifier"++-- | Lex a record label+llabel     :: T.TokenEnd st => CharParser st String+llabel           = try $ do+  c:s <- identifier+  if isLower c+    then return (toUpper c : s)+    else pzero <?> "record field label"++-- | Lex a variant label+ulabel     :: T.TokenEnd st => CharParser st String+ulabel           = try $ do+  s@(c:_) <- identifier+  if isUpper c+    then return s+    else pzero <?> "variant constructor label"++-- | Accept an operator having the specified precedence+opP :: T.TokenEnd st => Prec -> CharParser st String+opP p = try $ do+  op <- operator+  if precOp op == p+    then return op+    else pzero+
− src/Syntax/Lit.hs 
@@ -1,18 +0,0 @@-{-# 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 
@@ -1,60 +0,0 @@-{-# 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 
@@ -1,87 +0,0 @@-module Syntax.POClass (-  -- * Partial orders-  PO(..), bigVee, bigVeeM, bigWedge, bigWedgeM,-) where--import Util--import Control.Monad.Error-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 :: (Error e, MonadError e 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-  (\/?) :: (Error e, MonadError e m) => a -> a -> m a-  (\/?)  = ifMJ True--  -- | Partial meet returns in a monad, in case meet DNE-  (/\?) :: (Error e, MonadError e m) => a -> a -> m a-  (/\?)  = ifMJ False--  -- | Total join-  (\/)  :: a -> a -> a-  -- | Total meet-  (/\)  :: a -> a -> a-  x \/ y = either error id (x \/? y)-  x /\ y = either error id (x /\? y)--  -- | The order relation (derived)-  (<:)  :: a -> a -> Bool-  x <: y = either (const False :: String -> Bool) ((==) x) (x /\? y)-        || either (const False :: String -> Bool) ((==) 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 :: (Error e, MonadError e m, Bounded a, PO a) => [a] -> m a-bigVeeM  = foldrM (\/?) minBound--bigWedge :: (Bounded a, PO a) => [a] -> a-bigWedge  = foldr (/\) maxBound--bigWedgeM :: (Error e, MonadError e 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  = liftM Just (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/Parser.hs view
@@ -0,0 +1,1376 @@+-- | Parser+module Syntax.Parser (+  -- * The parsing monad+  P, parse,+  -- ** Errors+  ParseError,+  -- ** Quasiquote parsing+  parseQuasi,+  -- ** File and REPL command parsing+  parseFile,+  REPLCommand(..), parseCommand,+  -- ** Parsers+  parseProg, parseRepl, parseDecls, parseDecl, parseModExp,+    parseTyDec, parseAbsTy, parseType, parseTyPat,+    parseQExp, parseExpr, parsePatt,+    parseCaseAlt, parseBinding, parseField,+    parseSigExp, parseSigItem,+  -- ** For parsing with row dots+  withDots,+  -- * Convenience parsers (quick and dirty)+  pp, pds, pd, pme, ptd, pt, ptp, pqe, pe, px+) where++import Util hiding (before, lift)+import Paths+import AST+import Syntax.Prec+import Syntax.Lexer as Lexer+import Error (AlmsError(..), Phase(ParserPhase))+import qualified Message.AST as Msg+import Alt.Parsec hiding (parse)++import Prelude ()+import qualified Data.Map as M+import qualified Data.List as L+import qualified Language.Haskell.TH as TH+import qualified Text.ParserCombinators.Parsec.Error as PE+import System.IO.Unsafe (unsafePerformIO)++data St   = St {+              stAnti  :: !Bool,+              stPos   :: !SourcePos,+              stDots  :: !Bool+            }++instance TokenEnd St where+  saveTokenEnd = do+    pos <- getPosition+    updateState $ \st -> st { stPos = pos }++-- | A 'Parsec' character parser, with abstract state+type P a  = CharParser St a++state0 :: St+state0 = St {+           stAnti  = False,+           stPos   = toSourcePos bogus,+           stDots  = 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 ->+              (String -> String -> Maybe TH.Name -> P a) ->+              TH.Q a+parseQuasi str p = do+  loc <- fromTHLoc <$> TH.location+  let parser = do+        setPosition (toSourcePos loc)+        iflag <- (++) <$> option "" (string "+")+                      <*> option "" (string "'")+        lflag <- choice [+                   do char '@'+                      choice [ char '=' >> identp_no_ws >>! Just,+                               char '!' >> return Nothing ],+                   char '!' >> return Nothing,+                   return (Just "_loc")+                 ]+        p (file loc) iflag (fmap TH.mkName lflag)+  either (fail . show) return $+    runParser parser state0 { stAnti = True } "<quasi>" str++-- | Given a file name and source, parse it+parseFile :: Tag i => String -> String -> Either AlmsError (Prog i)+parseFile  = (almsParseError +++ id) <$$> parse parseProg++almsParseError :: ParseError -> AlmsError+almsParseError e =+  AlmsError ParserPhase (fromSourcePos (errorPos e)) message+  where+    message =+      Msg.Stack Msg.Broken [+        flow ";" messages,+        (if null messages then id else Msg.Indent)+           (Msg.Table (unlist ++ explist))+      ]+    unlist  = case unexpects of+      []  -> []+      s:_ -> [("unexpected:", Msg.Words s)]+    explist = case expects of+      []  -> []+      _   -> [("expected:", flow "," expects)]+    messages  = [ s | PE.Message s     <- PE.errorMessages e, not $ null s ]+    unexpects = [ s | PE.UnExpect s    <- PE.errorMessages e, not $ null s ]+             ++ [ s | PE.SysUnExpect s <- PE.errorMessages e, not $ null s ]+    expects   = [ s | PE.Expect s      <- PE.errorMessages e, not $ null s ]+    flow c         = Msg.Flow . map Msg.Words . punct c . L.nub+    punct _ []     = []+    punct _ [s]    = [s]+    punct c (s:ss) = (s++c) : punct c ss++-- | REPL-level commands+data REPLCommand+  = GetInfoCmd [Ident Raw]+  | GetPrecCmd [String]+  | GetConstraintCmd+  | QuitCmd+  | DeclsCmd [Decl Raw]+  | ParseError AlmsError++-- | Parse a line typed into the REPL+parseCommand :: Int -> String -> String -> REPLCommand+parseCommand row line syntax =+  case parsePragma line of+    Just cmd -> cmd+    _        -> case parseInteractive row syntax of+      Right ast -> DeclsCmd ast+      Left err  -> ParseError (almsParseError err)++-- | Parse a #-style REPL command+parsePragma :: String -> Maybe REPLCommand+parsePragma  = (const Nothing ||| Just) . runParser parser state0 "-"+  where+    parser = finish $+          GetInfoCmd <$+            pragma "info" <*>+            many1 (identp+                   <|> J [] . Var . ident <$> (operator <|> qjoin))+      <|> GetPrecCmd <$+            pragma "precedence" <*>+            many1 (operator <|> qjoin)+      <|> GetConstraintCmd <$+            pragma "constraints"+      <|> QuitCmd <$+            pragma "quit"++-- | Parse a declaration or expression in the REPL+parseInteractive :: Tag 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++-- | Get the ending position of the last token, before trailing whitespace+getEndPosition :: P SourcePos+getEndPosition  = stPos <$> getState++-- | Parse something and return the span of its location+withLoc :: P a -> P (a, Loc)+withLoc p = do+  before <- getPosition+  a      <- p+  after  <- getEndPosition+  return (a, fromSourcePosSpan before after)++addLoc :: Relocatable a => P a -> P a+addLoc  = uncurry (<<@) <$$> withLoc++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++antilistp :: Antible a => P b -> P a -> P [a]+antilistp  = option [] <$$> antilist1p++-- | Accept or don't accept row type dots.+withDots     :: Bool -> P a -> P a+withDots b p  = do+  saved  <- getState+  setState saved { stDots = b }+  result <- p+  state  <- getState+  setState state { stDots = stDots saved }+  return result++-- | Assert that we are accepting dots.+assertDots   :: P ()+assertDots    = do+  state  <- getState+  if stDots state+    then return ()+    else pzero++-- Just uppercase identifiers+uidp :: Tag i => P (Uid i)+uidp  = ident <$> Lexer.uid+    <|> antiblep+  <?> "uppercase identifier"++-- Just lowercase identifiers+lidp :: Tag i => P (Lid i)+lidp  = ident <$> Lexer.lid+    <|> antiblep+  <?> "lowercase identifier"++-- Just uppercase row labels+ulabelp :: Tag i => P (Uid i)+ulabelp  = ident <$> Lexer.ulabel+    <|> antiblep+  <?> "variant constructor label"++-- Just lowercase row labels+llabelp :: Tag i => P (Uid i)+llabelp  = ident <$> Lexer.llabel+    <|> antiblep+  <?> "record field label"++-- Infix operator at the given precdence+oplevelp :: Tag i => Prec -> P (Lid i)+oplevelp p = ident <$> opP p+  <?> "infix operator"++-- Just parenthesized operators+operatorp :: Tag i => P (Lid i)+operatorp  = ident <$> try (parens (operator <|> semis))+  <?> "operator name"++-- Lowercase identifiers or naturals+--  - tycon declarations+lidnatp :: Tag i => P (Lid i)+lidnatp = ident <$> (Lexer.lid <|> show <$> natural)+      <|> operatorp+      <|> antiblep+  <?> "type name"++-- Type identifiers (unqualified)+typidp :: Tag i => P (TypId i)+typidp  = antiblep+      <|> TypId <$> (lidnatp <|> operatorp)+  <?> "type constructor"++-- Infix type identifiers+typopp  :: Tag i => Prec → P (TypId i)+typopp p = TypId <$> oplevelp p+  <?> "infix type operator"++-- Variable bindings+varidp :: Tag i => P (VarId i)+varidp  = antiblep+      <|> VarId <$> (lidp <|> operatorp)+  <?> "variable name"++-- Infix variable occurrences+varopp  :: Tag i => Prec → P (VarId i)+varopp p = VarId <$> oplevelp p+  <?> "infix operator"++-- Data constructor names+conidp :: Tag i => P (ConId i)+conidp  = antiblep+      <|> ConId <$> uidp+      <|> ConId (ident "::") <$ parens cons+  <?> "data constructor"++-- Module names+modidp :: Tag i => P (ModId i)+modidp  = antiblep+      <|> ModId <$> uidp+  <?> "module name"++-- Module type names+sigidp :: Tag i => P (SigId i)+sigidp  = antiblep+      <|> SigId <$> uidp+  <?> "module type (signature) name"++-- Add a path before something+pathp :: (Tag i, Antible b) => P ([ModId i] -> b) -> P b+pathp p = (antiblep <|>) . try $ do+  path <- many $ try $ modidp <* dot+  make <- p+  return (make path)++-- Qualified type identifiers+qtypidp :: Tag i => P (QTypId i)+qtypidp  = pathp (flip J <$> typidp)+       <|> qident tnAf <$ qualA+       <|> qident tnUn <$ qualU+  <?> "(qualified) type constructor"++-- Qualified variable occurrences+qvaridp :: Tag i => P (QVarId i)+qvaridp  = pathp (flip J <$> varidp)+  <?> "(qualified) variable name"++-- Qualified data constructor names+qconidp :: Tag i => P (QConId i)+qconidp  = pathp (flip J <$> conidp)+  <?> "(qualified) data constructor"++-- Qualified module names+qmodidp :: Tag i => P (QModId i)+qmodidp  = pathp (flip J <$> modidp)+  <?> "(qualified) module name"++-- Qualified module type names+qsigidp :: Tag i => P (QSigId i)+qsigidp  = pathp (flip J <$> sigidp)+  <?> "(qualified) module type name"++-- Identifiers+identp :: Tag i => P (Ident i)+identp = pathp (flip J <$> (Var . unTypId <$> typidp <|> Con <$> uidp))+  <?> "identifier"++-- Type variables+tyvarp :: Tag i => P (TyVar i)+tyvarp  = try $ "type variable" @@+            sigilU *> tv Qu+        <|> sigilA *> tv Qa+  where tv q = antiblep <|> TV <$> lidp <*> pure q <*> pure bogus++-- open variant injection constructor+varinjp ∷ Tag i ⇒ P (Uid i)+varinjp = try (variantInj *> ulabelp)+  <?> "open variant constructor"++-- open variant embedding constructor+varembp ∷ Tag i ⇒ P (Uid i)+varembp = try (variantEmb *> ulabelp)+  <?> "open variant constructor"++quantp :: P Quant+quantp  = Forall <$ forall+      <|> Exists <$ exists+      <|> antiblep+  <?> "quantifier"++typep  :: Tag i => P (Type i)+typep   = typepP precStart++typepP :: Tag i => Int -> P (Type i)+typepP p = "type" @@ case () of+  _ | p == precStart+          -> tyrowp1 <|> next+    | p == precDot+          -> do+               tc <- tyQu <$> quantp+                 <|> tyMu <$  mu+               tvs <- many tyvarp+               dot+               t   <- typepP p+               return (foldr tc t tvs)+             <|> next+    | p == precArr+          -> chainr1last+               next+               (choice+                [ tyArr <$ arrow,+                  tyLol <$ lolli,+                  funbraces (flip tyFun <$> (antiblep <|> Just <$> qExpp)),+                  tybinopp (Right precArr) ])+               (typepP precStart)+    | p == precTySemi+          -> chainr1last next+                         (tyAppN <$> (semis <|> qjoin))+                         (typepP precStart)+    | Just (Left _) <- fixities p+          -> chainl1last next+                         (tybinopp (Left p))+                         (typepP precStart)+    | Just (Right _) <- fixities p+          -> chainr1last next+                         (tybinopp (Right p))+                         (typepP precStart)+    | p == precApp -- this case ensures termination+          -> tyarg >>= tyapp'+    | p <  precApp+          -> next+    | otherwise+          -> typepP precStart+  where+  tyarg :: Tag i => P [Type i]+  tyarg  = parens (antiblep <|> commaSep1 (typepP precMin))+       <|> (:[]) <$> tyatom+  --+  tyatom :: Tag i => P (Type i)+  tyatom  = tyVar <$> tyvarp+        <|> tyApp <$> qtypidp <*> pure []+        <|> antiblep+        <|> varianttyp+        <|> recordtyp+        <|> parens (typepP precMin)+        <|> do+              ops <- many1 $ addLoc $+                typopp (Right precBang) >>! tyApp . J []+              arg <- tyatom+              return (foldr (\op t -> op [t]) arg ops)+  --+  tyapp' :: Tag i => [Type i] -> P (Type i)+  tyapp' [t] = option t $+    do+      tc <- qtypidp+      tyapp' [tyApp tc [t]]+    <|>+    do+      assertDots+      ellipsis+      tyapp' [tyRowDots t]+  tyapp' ts  = do+    tc <- qtypidp+    tyapp' [tyApp tc ts]+  --+  next = typepP (p + 1)++-- A variant type+varianttyp ∷ Tag i ⇒ P (Type i)+varianttyp = AST.tyVariant <$> brackets tyrowp++-- A non-empty type row, in variant style+tyrowp1 ∷ Tag i ⇒ P (Type i)+tyrowp1 = AST.tyRow <$> varinjp+                       <*> option AST.tyUnit+                             (reserved "of" *> typepP precStart)+                       <*> option AST.tyRowEnd+                             (reservedOp "|" *> tyrowp)++-- A possibly empty type row, in variant style+tyrowp ∷ Tag i ⇒ P (Type i)+tyrowp = "row type" @@+         antiblep+     <|> tyrowp1+     <|> extensionp+     <|> AST.tyRowEnd <$  whiteSpace++-- A record type+recordtyp ∷ Tag i ⇒ P (Type i)+recordtyp = AST.tyRecordAdditive <$>+              plusbraces (recrowp <|> pure AST.tyRowEnd)+        <|> AST.tyRecordMultiplicative <$>+              braces (recrowp <|> pure AST.tyRowEnd)++-- A type row in record style+recrowp ∷ Tag i ⇒ P (Type i)+recrowp = antiblep+      <|> do+            labs ← commaSep1 llabelp+            colon+            t    ← typepP precStart+            rest ← option AST.tyRowEnd $+                         comma *> recrowp+                     <|> reservedOp "|" *> extensionp+            return (foldr (AST.tyRow <-> t) rest labs)+      <|> extensionp++-- A row extension variable or dot form+extensionp ∷ Tag i ⇒ P (Type i)+extensionp = try (tyRowDots <$> withDots False (typepP precApp) <* ellipsis)+         <|> AST.tyVar <$> tyvarp ++tybinopp :: Tag i => Prec -> P (Type i -> Type i -> Type i)+tybinopp p = try $ do+  op <- typopp p+  when (idName op == "-") pzero+  return (\t1 t2 -> tyApp (J [] op) [t1, t2])++progp :: Tag 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 :: Tag i => P [Decl i]+replp  = choice [+           try $ do+             ds <- declsp+             when (null ds) pzero+             eof+             return ds,+           exprp >>! (prog2decls . prog [] . Just)+         ]++declsp :: Tag i => P [Decl i]+declsp  = antiblep <|> loop+  where loop =+          choice [+            do+              d  <- declp+              ds <- loop+              return (d : ds),+            (<?> "#load") $ do+              pragma "load"+              name <- stringLiteral+              rel  <- sourceName `liftM` getPosition+              let mcontents = unsafePerformIO $ do+                    mfile <- findAlmsLibRel name rel+                    traverse 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 :: Tag i => P (Decl i)+declp  = "declaration" @@ choice [+           do+             tid ← try $+               reserved "type" *> typidp <* reservedOp "=" <* reserved "type"+             rhs ← qtypidp+             return (dcAli tid rhs),+           do+             reserved "type"+             tyDecsp >>! dcTyp,+           letp,+           do+             reserved "open"+             modexpp >>! dcOpn,+           do+             reserved "module"+             choice [+                 do+                   reserved "type"+                   n <- sigidp+                   reservedOp "="+                   s <- sigexpp+                   return (dcSig n s),+                 do+                   n   <- modidp+                   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  <- conidp+             t  <- antioptaroundp (reserved "of" `between` punit) typep+             return (dcExn n t),+           antiblep+         ]++modexpp :: Tag i => P (ModExp i)+modexpp  = "structure" @@ foldlp meAsc body ascription where+  body = choice [+           meStr  <$> between (reserved "struct") (reserved "end") declsp,+           meName <$> qmodidp+                  <*> antilistp comma qvaridp,+           antiblep+         ]+  ascription = colon *> sigexpp++sigexpp :: Tag i => P (SigExp i)+sigexpp  = "signature" @@ do+  se <- choice [+          seSig  <$> between (reserved "sig") (reserved "end")+                             (antiblep <|> many sigitemp),+          seName <$> qsigidp+                 <*> antilistp comma qvaridp,+          antiblep+        ]+  specs <- many $ do+    reserved "with"+    reserved "type"+    flip sepBy1 (reserved "and") $ "signature specialization" @@ do+      (tvs, tc) <- tyAppp (antiblep <|>) tyvarp (J []) qtypidp+      reservedOp "="+      t         <- typep+      return (\sig -> seWith sig tc tvs t)+  return (foldl (flip ($)) se (concat specs))++sigitemp :: Tag i => P (SigItem i)+sigitemp = "signature item" @@ choice [+    do+      reserved "val"+      n <- varidp+      colon+      t <- typep+      return (sgVal n t),+   do+     tid ← try $+       reserved "type" *> typidp <* reservedOp "=" <* reserved "type"+     rhs ← qtypidp+     return (sgAli tid rhs),+    do+      reserved "type"+      sgTyp <$> tyDecsp,+    do+      reserved "module"+      choice [+          do+            reserved "type"+            n <- sigidp+            reservedOp "="+            s <- sigexpp+            return (sgSig n s),+          do+            n <- modidp+            colon+            s <- sigexpp+            return (sgMod n s)+        ],+    do+      reserved "include"+      sgInc <$> sigexpp,+    do+      reserved "exception"+      n  <- conidp+      t  <- antioptaroundp (reserved "of" `between` punit) typep+      return (sgExn n t),+    antiblep+  ]++tyDecsp :: Tag i => P [TyDec i]+tyDecsp  = antilist1p (reserved "and") tyDecp++tyDecp :: Tag i => P (TyDec i)+tyDecp = "type declaration" @@ addLoc $ choice+  [ antiblep+  , do+      optional (reservedOp "|")+      tp    <- typatp+      (name, ps) <- checkHead tp+      case checkTVs ps of+        -- Could be a data type, a synonym, or an abstract type+        Just (True, tvs, arity) ->+          reservedOp "=" *>+             (tdDat name tvs <$> altsp+              <|> tryTySyn name ps)+          <|> finishTyAbs name tvs arity+        -- Must be a synonym or an abstract type+        Just (_, tvs, arity) ->+          reservedOp "=" *> tryTySyn name ps+          <|> finishTyAbs name tvs arity+        -- Must be a type function+        Nothing ->+          reservedOp "=" *> tryTySyn name ps+        ]+  where+  -- Try to parse the right-hand side of a type synonym+  tryTySyn name ps = do+    t    <- withDots True 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 <- withDots True typep+      return (ps', ti)+    return (tdSyn name ((ps,t):alts))+  --+  finishTyAbs name tvs arity = do+    let guardsp = option [] $ reserved "rec" *> commaSep1 tyvarp+    guards1 ← guardsp+    qual    ← qualsp+    guards2 ← guardsp+    return (tdAbs name tvs arity (guards1 ++ guards2) qual)+  --+  -- A type declaration needs to give an unqualified name for the type+  -- being defined.  This checks that and splits into the name and the+  -- parameter patterns.+  checkHead tp = case dataOf tp of+    TpApp (J [] name) ps -> return (name, ps)+    TpApp _ _            -> unexpected "qualified identifier"+    TpVar _ _            -> unexpected "type variable"+    TpRow _ _            -> unexpected "row type"+    TpAnti _             -> unexpected "antiquote"+  --+  -- Look at the parameters and determine what kind of type declaration+  -- this might be. Returns @Just (allInv, tvs, vars)@ if all the+  -- parameters are type variables, where @allInv@ tells whether all the+  -- variances are 'Invariant', and @tvs@ and @vars@ are the lists of+  -- type variables and variances. Otherwise, we're defining a type+  -- function and it returns @Nothing@.+  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++-- | Generic parser for things in the shape of type constructor+--   applications.+tyAppp :: Tag i =>+          -- | Wrapper for parsing the parameter(s) of a normal suffix+          --   type application+          (P [a] -> P [a]) ->+          -- | Parser for a type parameter+          P a ->+          -- | Injection to lift a type operator+          (TypId i -> b) ->+          -- | Parser for postfix constructor+          P b ->+          P ([a], b)+tyAppp wrap param oper suffix = choice [+  -- prefix operator+  do+    l  <- typopp (Right precBang)+    p1 <- param+    return ([p1], oper l),+  -- infix operator+  try $ do+    p1 <- param+    n <- choice [ semis, operator ]+    when (n == "-" || precOp n == Right precBang) pzero+    p2 <- param+    return ([p1, p2], oper (ident n)),+  -- normal postfix application+  do+    ps   <- wrap (delimList punit parens comma param)+    name <- suffix+    return (ps, name)+  ]++-- | Left-hand side of a type declaration, which looks like a+--   type constructor applied to parameters+tyProtp :: Tag i => P ([(Variance, TyVar i)], TypId i)+tyProtp  = tyAppp id paramVp id typidp++-- | A type pattern+typatp  :: Tag i => P (TyPat i)+typatp   = typatpP precStart++typatpP :: Tag i => Int -> P (TyPat i)+typatpP p = "type pattern" @@ case () of+  _ | p == precTySemi+          -> chainr1last (typatpP (p + 1))+                         (tpBinOp . J [] . ident <$> semis)+                         (typatpP precStart)+    | Just e <- fixities p -> case e of+        Left _ ->+          chainl1last (typatpP (p + 1))+                      (tpBinOp . J [] <$> typopp (Left p))+                      (typatpP precStart)+        Right _ ->+          chainr1last (typatpP (p + 1))+                      (tpBinOp . J [] <$> typopp (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  = parens (antiblep <|> commaSep1 (typatpP precMin))+       <|> (:[]) <$> tpatom+  --+  tpatom  = tpvar+        <|> tpApp <$> qtypidp <*> pure []+        <|> antiblep+        <|> tpApp (qident tnUn) [] <$ qualU+        <|> tpApp (qident tnAf) [] <$ qualA+        <|> tpvariant+        <|> tprecord+        <|> parens (typatpP precMin)+        <|> do+              ops <- many1 $ addLoc $+                typopp (Right precBang) >>! tpApp . J []+              arg <- tpatom+              return (foldr (\op t -> op [t]) arg ops)+  tpapp' [t] = option t $ do+    tc <- qtypidp+    tpapp' [tpApp tc [t]]+  tpapp' ts  = do+    tc <- qtypidp+    tpapp' [tpApp tc ts]+  --+  tpvar = do+    (v,tv) <- paramVp+    con    <- option tpVar (tpRow <$ ellipsis)+    return (con tv v)+  --+  tpvariant = brackets $+    tpApp (qident tnVariant) . (:[]) <$> (antiblep <|> tpvar)+  tprecord  = braces $+    tpApp (qident tnRecord) . (:[]) <$> (antiblep <|> tpvar)++-- | A let or let rec declaration+letp :: Tag i => P (Decl i)+letp  = do+  reserved "let"+  choice [+    do+      reserved "rec"+      dcLetRec <$> antilist1p (reserved "and") bindingp,+    do+      f     <- varidp+      args  <- buildargsp+      annot <- buildannotp+      reservedOp "="+      e     <- args . annot <$> exprp+      return (dcLet (paVar f) e),+    dcLet <$> pattp+          <*  reservedOp "="+          <*> exprp+    ]++-- An abstype group+absTysp :: Tag i => P [AbsTy i]+absTysp = antilist1p (reserved "and") $ absTyp++-- A single abstype+absTyp :: Tag 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))++-- A type declaration parameter, consisting of a variance and a tyvar+paramVp :: Tag i => P (Variance, TyVar i)+paramVp = try $ (,) <$> variancep <*> tyvarp++-- A variance mark+variancep :: P Variance+variancep = do+    qvariance ← option Invariant (QInvariant <$ markQVariant)+    sign      ← option Invariant $ choice+      [ Covariant     <$ markCovariant+      , Contravariant <$ markContravariant+      , Omnivariant   <$ markOmnivariant+      , Invariant     <$ markInvariant ]+    return (qvariance ⊓ sign)+  <?> "variance marker"++-- A qualifier annotation for a type declaration+qualsp   :: Tag i => P (QExp i)+qualsp    = option minBound $+  (reserved "qualifier" <|> reservedOp ":") *> qExpp++-- A qualifier expression+qExpp :: Tag i => P (QExp i)+qExpp  = "qualifier expression" @@ qexp where+  qexp  = addLoc $+            chainl1 qatom (addLoc $ qeJoin <$ (void comma <|> qjoinArr))+  qatom = addLoc $+          qeLit Qu <$  qualU+      <|> qeLit Qa <$  qualA+      <|> clean    <$> tyvarp+      <|> qeLid    <$> lidp+      <|> antiblep+      <|> parens qexp+  qeLid = qeVar . (TV <-> Qa <-> bogus)+  clean (TV _ Qu _) = minBound+  clean tv          = qeVar tv++altsp :: Tag i => P [(ConId i, Maybe (Type i))]+altsp  = sepBy1 altp (reservedOp "|")++altp  :: Tag i => P (ConId i, Maybe (Type i))+altp   = do+  k <- try $ conidp <* try (dot *> pzero <|> punit)+  t <- optionMaybe $ do+    reserved "of"+    typep+  return (k, t)++exprp :: Tag i => P (Expr i)+exprp  = exprpP precStart++exprpP :: Tag i => Int -> P (Expr i)+exprpP p = mark $ case () of+  _ | p == precStart → choice+    [ do reserved "let"+         choice+           [ exLetRec <$  reserved "rec"+                      <*> antilist1p (reserved "and") bindingp+                      <*  reserved "in"+                      <*> exprp+           , exLet <$> (paVar <$> varidp)+                   <*> (buildargsp <*>+                         (buildannotp <* reservedOp "=" <*> exprp))+                   <*  reserved "in"+                   <*> exprp+           , exLet <$> pattp+                   <*  reservedOp "="+                   <*> exprp+                   <*  reserved "in"+                   <*> exprp+           , reserved "let" *> unexpected "let"+           , exLetDecl <$> declp+                       <*  reserved "in"+                       <*> exprp ],+      do reserved "if"+         ec  <- exprp+         clt <- addLoc $ do+           reserved "then"+           caClause (paCon idTrueValue Nothing)+                <$> exprp+         clf <- addLoc $ do+           reserved "else"+           caClause (paCon idFalseValue Nothing)+                <$> exprp+         return (exCase ec [clt, clf]),+      do reserved "match"+         e1 <- exprp+         reserved "with"+         choice [+           exCase e1 <$> antiblep,+           do+             optional (reservedOp "|")+             clauses <- flip sepBy1 (reservedOp "|") casealtp+             return (exCase e1 clauses) ],+      do reserved "try"+         e1 <- exprp+         reserved "with"+         optional (reservedOp "|")+         clauses <- sepBy1 <-> reservedOp "|" $ addLoc $ do+           caClause . paCon (qident "Left") . Just+             <$> pattp+             <*  arrow+             <*> exprp+         let tryQ = qident $+                      "INTERNALS.Exn.tryfun"+         return $+           exCase (exApp (exVar tryQ)+                         (exAbs paWild e1)) $+             caClause (paCon (qident "Right")+                             (Just (paVar (ident "x"))))+                      (exVar (qident "x"))+             :+             clauses +++             [caClause+                (paCon (qident "Left")+                       (Just (paVar (ident "e"))))+                (exApp (exVar (qident "INTERNALS.Exn.raise"))+                       (exVar (qident "e")))+              ],+      lambda *> buildargsp <* arrow <*> exprp,+      next ]+    | p == precExSemi → do+        e1 <- next+        choice+          [ do semi+               e2 <- exprp+               return (exSeq e1 e2),+            return e1 ]+    | p == precCast → do+        e1 <- next+        anns <- many $ do+          b  <- False <$ colon+            <|> True <$ reservedOp ":>"+          t2 <- typep+          return (t2, b)+        return (foldl (uncurry . exCast) e1 anns)+    | p == precTySemi →+        next+    | p == precApp    →+        choice [+          exCon <$> qconidp <*> antioptp next,+          exInj <$> varinjp <*> antioptp next,+          exEmb <$> varembp <*> next,+          chainl1 next (addLoc (return exApp))+        ]+    | p == precSel    → do+        foldl' exSel <$> next <*> many (dot *> llabelp)+    | p == precBang   → do+        ops <- many $ addLoc $ exBVar <$> varopp (Right precBang)+        arg <- next+        return (foldr exApp arg ops)+    | p == precCom    →+        foldl1 exPair <$> commaSep1 next+    | p > precMax     → choice+        [+          exVar <$> qvaridp,+          exCon <$> qconidp <*> pure Nothing,+          exLit <$> litp,+          antiblep,+          brackets (listexp <|> pure exNil),+          parens (exprpP precMin <|> pure exUnit),+          recordp+        ]+    | p == precCaret+          -> chainr1last next+                         (opappp (Right p) <|> opconsp exCon exPair)+                         exprp+    | Just (Left _) <- fixities p ->+        chainl1last next (opappp (Left p)) exprp+    | Just (Right _) <- fixities p ->+        chainr1last next (opappp (Right p)) exprp+    | otherwise       → next+  where+  next = exprpP (p + 1)+  mark = ("expression" @@)++-- | The body of a list.+listexp ∷ Tag i ⇒ P (Expr i)+listexp = foldr exCons exNil <$> commaSep1 exprp++-- | Parse a record expression+recordp :: Tag i ⇒ P (Expr i)+recordp  = plusbraces (recordbodyp True <|> pure exNilRecord)+       <|> braces (recordbodyp False <|> pure exNilRecord)++-- | Parse a record expression body+recordbodyp :: Tag i => Bool → P (Expr i)+recordbodyp additive = "record field" @@ do+   fields ← antilist1p comma fieldp+   end    ← reservedOp "|" *> exprp+        <|> pure exNilRecord+   return (exRec additive fields end)++-- | Parse a record field+fieldp :: Tag i ⇒ P (Field i)+fieldp  = "record field" @@ antiblep <|> do+  lab ← llabelp+  e   ← option (exBVar (VarId (uidToLid lab))) $+    buildargsp <*> (buildannotp <* reservedOp "=" <*> exprp)+  return (fdField lab e)++-- Parse a match clause+casealtp :: Tag i => P (CaseAlt i)+casealtp  = "match clause" @@ antiblep <|>+     caClause <$> pattp <* arrow <*> exprp+ <|> caPrj <$> varembp <*> antioptp pattp <* arrow <*> exprp++-- Parse a single let rec binding+bindingp :: Tag i => P (Binding i)+bindingp = "let rec binding" @@ antiblep <|>+  bnBind <$> varidp+         <*> (buildargsp+               <*> (buildannotp+                     <* reservedOp "="+                     <*> exprp))++-- Parse an infix operator at given precedence+opappp :: Tag i => Prec -> P (Expr i -> Expr i -> Expr i)+opappp p = do+  op  <- addLoc (exBVar <$> varopp p)+  return (\e1 e2 -> op `exApp` e1 `exApp` e2)++-- Parse list cons+opconsp  :: Tag i => (QConId i -> Maybe a -> a) → (a -> a -> a) →+                   P (a -> a -> a)+opconsp con pair = cons *> return (con idConsList . Just <$$> pair)++-- Parse some number of argument patterns and return the function+-- that adds them to a body expression to build a lambda.+buildargsp :: Tag i => P (Expr i -> Expr i)+buildargsp = (foldr exAbs <->) <$> many (pattpP (precApp + 1))++-- Parse an optional type annotation and return the function that+-- adds it as an ascription on an expression.+buildannotp :: Tag i => P (Expr i -> Expr i)+buildannotp = do+  mt <- antioptaroundp (colon *>) typep+  return $ case mt of+    Nothing → id+    Just t  → \e → exCast e t False++-- A pattern+pattp :: Tag i => P (Patt i)+pattp  = pattpP precStart++pattpP ∷ Tag i ⇒ Int → P (Patt i)+pattpP p = mark $ case () of+  _ | p == precCast →+        foldl paAnn <$> next <*> many (colon *> typep)+    | p == precEq   → do+        x <- next+        choice+          [ do+              reserved "as"+              y <- varidp+              return (paAs x y),+            return x+          ]+    | p == precApp    →+        choice [+          paCon <$> qconidp <*> antioptp next,+          paInj <$> varinjp <*> antioptp next,+          next+        ]+    | p == precBang   →+        option id (paBang <$ bang) <*> next+    | p == precCom    →+        foldl1 paPair <$> commaSep1 next+    | p == precCaret  →+        chainr1last next (opconsp paCon paPair) pattp+    | p > precMax     → choice+        [+          paWild <$  reserved "_",+          paVar  <$> varidp,+          paCon  <$> qconidp <*> pure Nothing,+          paInj  <$> varinjp <*> pure Nothing,+          paLit  <$> litp,+          antiblep,+          brackets (listpap <|> pure paNil),+          braces recordpap,+          parens (pattpP precMin <|> pure paUnit)+        ]+    | otherwise     → next+  where+  next = pattpP (p + 1)+  mark  = ("pattern" @@)++-- | The body of a list.+listpap ∷ Tag i ⇒ P (Patt i)+listpap = foldr paCons paNil <$> commaSep1 pattp++recordpap ∷ Tag i ⇒ P (Patt i)+recordpap = do+  flds ← commaSep1 $ do+    lab ← llabelp+    π   ← option (paVar (VarId (uidToLid lab))) (reservedOp "=" *> pattp)+    return (lab, π)+  ext  ← option paWild (reservedOp "|" *> pattp)+  return (foldr (uncurry paRec) ext flds)++litp :: P Lit+litp = (<?> "literal") $ choice [+         integerOrFloat >>! either LtInt LtFloat,+         charLiteral    >>! LtChar,+         stringLiteral  >>! LtStr,+         antiblep+       ]++finish :: P a -> P a+finish p = do+  optional whiteSpace+  r <- p+  eof+  return r++-- | Parse a program+parseProg     :: Tag i => P (Prog i)+-- | Parse a REPL line+parseRepl     :: Tag i => P [Decl i]+-- | Parse a sequence of declarations+parseDecls    :: Tag i => P [Decl i]+-- | Parse a declaration+parseDecl     :: Tag i => P (Decl i)+-- | Parse a module expression+parseModExp   :: Tag i => P (ModExp i)+-- | Parse a type declaration+parseTyDec    :: Tag i => P (TyDec i)+-- | Parse a abstype declaration+parseAbsTy    :: Tag i => P (AbsTy i)+-- | Parse a type+parseType     :: Tag i => P (Type i)+-- | Parse a type pattern+parseTyPat    :: Tag i => P (TyPat i)+-- | Parse a qualifier expression+parseQExp     :: Tag i => P (QExp i)+-- | Parse an expression+parseExpr     :: Tag i => P (Expr i)+-- | Parse a pattern+parsePatt     :: Tag i => P (Patt i)+-- | Parse a case alternative+parseCaseAlt  :: Tag i => P (CaseAlt i)+-- | Parse a let rec binding+parseBinding  :: Tag i => P (Binding i)+-- | Parse a record field+parseField    :: Tag i => P (Field i)+-- | Parse a signature+parseSigExp   :: Tag i => P (SigExp i)+-- | Parse a signature item+parseSigItem  :: Tag 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+parseField     = finish fieldp+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 :: Tag i => String -> TyDec i+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++{-+deriving instance Show (Expr' i)+deriving instance Show (CaseAlt' i)+deriving instance Show (Decl' i)+deriving instance Show (Binding' i)+deriving instance Show (AbsTy' i)+deriving instance Show (ModExp' i)+deriving instance Show (SigExp' i)+deriving instance Show (TyDec' i)+deriving instance Show (TyPat' i)+deriving instance Show (SigItem' i)+deriving instance Show (Patt' i)+deriving instance Show (Type' i)+deriving instance Show (QExp' i)+deriving instance Show (Prog' i)+deriving instance Show Lit+instance Show a ⇒ Show (N i a) where showsPrec = showsPrec <$.> view+-}++makeQaD :: P a -> String -> a+makeQaD parser =+  either (error . show) id . runParser parser state0 "<string>"+
− src/Syntax/Patt.hs 
@@ -1,121 +0,0 @@-{-# 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/Ppr.hs view
@@ -0,0 +1,638 @@+-- | Pretty-printing+module Syntax.Ppr (+  pprTyApp,+  -- * Re-exports+  module Syntax.PprClass,+  module Syntax.Prec+) where++import Meta.Quasi+import Syntax.PprClass+import Syntax.Prec+import AST+import Util++import qualified Syntax.Strings as Strings+import Data.Loc++import Prelude ()+import Data.List (sortBy)++instance IsInfix (Type i) where+  isInfix [ty| ($_, $_) $lid:n |] = isOperator n+  isInfix [ty| $_ -[$_]> $_ |]    = True+  isInfix _                        = False++-- | For printing infix expressions.  Given a splitter function that+--   splits expressions into a left operand, operator name, and right+--   operand (if possible), and an expression to print, pretty-prints+--   the expression, but only if there is one level of infix to be+--   done.+pprInfix :: Ppr a =>+            (a -> Maybe (a, String, Maybe a)) ->+            a -> Maybe Doc+pprInfix inspect x0+  | Just (x1, op, Nothing) <- inspect x0+  , precOp op == Right precBang+    = let rloop x'+            | Just (x1', op', Nothing) <- inspect x'+            , precOp op == Right precBang+            = first (op':) (rloop x1')+            | otherwise+            = ([], x')+          (ops, x) = first (op:) (rloop x1)+       in Just $+            fsep (mapTail (nest 2) $ map text ops)+            <> pprPrec precBang x+  | Just (_, op, Just _) <- inspect x0+  , isOperator (ident op :: Lid Raw)+  , p <- precOp op+  , p /= Right precBang+    = Just $+        prec (id|||id $ p) $+          fcat $ mapTail (nest 2) $ loop p mempty x0+  | otherwise+    = Nothing+  where+  loop p suf x+    | Just (x1, op, Just x2) <- inspect x+    , precOp op == p+    = case precOp op of+        Left _  -> loop p (oper op) x1 ++ [ppr1 x2 <> suf]+        Right _ -> ppr1 x1 <> oper op : loop p suf x2+  loop _ suf x = [ ppr x <> suf ]+  oper s = case s of+    '@':_ -> text s+    "\\/" -> text Strings.join+    ';':_ -> text s <> space+    _     -> space <> text s <> space++instance Ppr (Type i) where+  ppr [ty| $t1 -> $t2 |]+            = prec precArr $+              sep [ ppr1 t1, text Strings.uArrow <+> pprRight t2 ]+  ppr [ty| $t1 -[$q]> $t2 |]+            = prec precArr $+              sep [ ppr1 t1,+                    text Strings.arrowPre <> ppr0 q <>+                    text Strings.arrowPost <+> pprRight t2 ]+  ppr [ty| U |]     = char 'U'+  ppr [ty| A |]     = char 'A'+  ppr [ty| [ $t ] |]+                    = atPrec precStart $+                        pprVariantRow (lbrack <+>) t (<+> rbrack)+  ppr [ty| {+ $t +} |] = pprRecordType "{+" t "+}"+  ppr [ty| { $t } |]   = pprRecordType "{" t "}"+  ppr [ty| $t ... |] = prec precApp $ sep [ ppr t, text Strings.ellipsis ]+  ppr [ty| $t $qtid:n |]+    | show n == tnRowHole+                    = brackets $ ppr0 t+  ppr t@[ty| ($list:ts) $qtid:n |]+    | Just doc <- pprInfix unfoldType t+                    = doc+    | null ts       = ppr n+    | otherwise     = prec precApp $ sep [ ppr ts, ppr n ]+  ppr [ty| '$x |]  = ppr x+  ppr [ty| $quant:qu '$x. $t |]+                    = prec precDot $+                        ppr qu <+>+                        fsep (map ppr1 tvs) <>+                        char '.'+                          >+> ppr body+      where (tvs, body) = unfoldTyQu qu [ty| $quant:qu '$x. $t |]+  ppr [ty| mu '$x. $t |]+                    = prec precDot $+                        text Strings.mu <+>+                        ppr1 x <>+                        char '.'+                          >+> ppr t+  ppr t@[ty| `$uid:_ of $_ | $_ |]+                       = pprVariantRow id t id+  ppr [ty| $anti:a |] = ppr a++unfoldType :: Type i -> Maybe (Type i, String, Maybe (Type i))+unfoldType [ty| ($t1, $t2) $name:n |] = Just (t1, n, Just t2)+unfoldType [ty| $t1 $name:n |]        = Just (t1, n, Nothing)+unfoldType _                           = Nothing++pprVariantRow ∷ (Doc → Doc) → Type i → (Doc → Doc) → Doc+pprVariantRow pre t post =+  case items' ++ end' of+    []   → pre (post mempty)+    docs → prec precStart .+           sep .+           mapHead pre .+           mapLast post .+           mapTail (char '|' <+>) $+             docs+  where+    (items, end) = unfoldTyRow t+    items' = [ char '`' <> ppr ni <+>+                 case ti of+                   [ty| unit                     |] → mempty+                   [ty| INTERNALS.PrimTypes.unit |] → mempty+                   _ → text "of" <+> ppr1 ti+             | (ni, ti) ← sortBy (compare`on`show.fst) items ]+    end'   = case end of+      [ty| $qtid:n |] | show n == tnRowEnd+                      → []+      _               → [ppr1 end]++pprRecordType ∷ String → Type i → String → Doc+pprRecordType lb t rb = case items' ++ end' of+  []   → text lb <> text rb+  docs → atPrec precStart .+         fsep .+         mapHead (text lb <+>) .+         mapTail (nest 2) .+         mapLast (<+> text rb) $+           docs+  where+    (uitems, end) = unfoldTyRow t+    items         = first uidToLid <$> uitems+    items' = punctuate comma+               [ ppr ni <> colon <+> ppr1 ti+               | (ni, ti) ← sortBy (compare`on`show.fst) items ]+    end'   = case end of+      [ty| $qtid:n |] | show n == tnRowEnd+                      → []+      _               → [(if null items' then mempty else char '|')+                         <+> ppr1 end]++instance Ppr (TyPat i) where+  ppr tp0 = case tp0 of+    _ | Just doc <- pprInfix unfoldTyPat tp0+                       -> doc+    N _ (TpVar tv var) -> pprParamV var tv+    N _ (TpRow tv var) -> pprParamV var tv <+> text Strings.ellipsis+    [tpQ| [ $tp ] |]   -> lbrack <+> ppr0 tp <+> rbrack+    [tpQ| { $tp } |]   -> lbrace <+> ppr0 tp <+> rbrace+    [tpQ| $qtid:ql |]  -> ppr ql+    [tpQ| ($list:tps) $qtid:ql |]+                       -> prec precApp $ sep [ppr tps, ppr ql]+    [tpQ| $antiP:a |]  -> ppr a++unfoldTyPat :: TyPat i -> Maybe (TyPat i, String, Maybe (TyPat i))+unfoldTyPat [tpQ| ($t1, $t2) $name:n |] = Just (t1, n, Just t2)+unfoldTyPat [tpQ| $t1 $name:n |]        = Just (t1, n, Nothing)+unfoldTyPat _                           = Nothing++instance Ppr (QExp i) where+  ppr [qeQ| $qlit:qu |]   = ppr qu+  ppr [qeQ| $qvar:v |]    = ifPrec (> 0)+                              (ppr v)+                              (ppr (tvname v))+  ppr [qeQ| $qe1, $qe2 |] = ifPrec (> 0)+    (ppr qe1 <+> text Strings.join <+> ppr qe2)+    (ppr qe1 <> comma <> ppr qe2)+  ppr [qeQ| $anti:a |]    = ppr a++instance Ppr (Prog i) where+  ppr [prQ| $list:ms |]       = vcat (map ppr0 ms)+  ppr [prQ| $expr:e |]        = ppr e+  ppr [prQ| $list:ms in $e |] = vcat (map ppr0 ms) $+$+                                 (text "in" >+> ppr e)++instance Ppr (Decl i) where+  ppr [dc| let $lid:x = $e |] =+    prec precDot $+      pprLet (text "let" <+> ppr x) e False+  ppr [dc| let $x = $e |] =+    prec precDot $+      text "let" <+> ppr x <+> equals+        >+> ppr e+  ppr [dc| let rec $list:bs |] =+    prec precDot $+      text "let" <+>+      vcat (zipWith pprBinding ("rec" : repeat "and") bs)+  ppr [dc| type $tid:lhs = type $qtid:rhs |] =+    text "type" <+> ppr lhs <+> equals <+> text "type" <+> ppr rhs+  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 gs qs -> pprProtoV n vs ps+                             >?> pprQuals qs+                             >?> pprGuards gs+    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+                           >+> equals <+> 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  :: TypId i -> [TyPat i] -> Doc+pprProto n ps = ppr (tpApp (J [] n) ps)++pprProtoV :: TypId 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++pprGuards :: [TyVar i] -> Doc+pprGuards []  = mempty+pprGuards tvs = text "rec" <+> fsep (punctuate comma (ppr <$> tvs))++pprQuals :: QExp i -> Doc+pprQuals [qeQ| U |] = mempty+pprQuals qs         = text ":" <+> pprPrec precApp qs++pprAlternatives :: [(ConId 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+  [meQ| $qmid:n |] -> add (ppr n)+  [meQ| $qmid:n $list:qls |] ->+    add (ppr n) <+>+    pprStyleList listStyleBrack qls+  [meQ| struct $list:ds end |] ->+    add (text "struct")+    $$ nest 2 (vcat (map ppr0 ds))+    $$ text "end"+  [meQ| $me1 : $se2 |] ->+    pprSigExp (pprModExp add me1 <+> colon <+>) se2+  [meQ| $anti:a |] -> add (ppr a)++instance Ppr (SigExp i) where+  ppr = pprSigExp id++pprSigExp :: (Doc -> Doc) -> SigExp i -> Doc+pprSigExp add se0 = body >+> withs where+  (wts, se1) = unfoldSeWith se0+  body       = case se1 of+    [seQ| $qsid:n |] -> add (ppr n)+    [seQ| $qsid:n $list:qls |] ->+      add (ppr n) <+>+      pprStyleList listStyleBrack qls+    [seQ| sig $list:sgs end |] ->+      add (text "sig")+      $$ nest 2 (vcat (map ppr0 sgs))+      $$ text "end"+    [seQ| $_ with type $list:_ $qtid:_ = $_ |] ->+      error "BUG! can't happen in pprSigExp"+    [seQ| $anti:a |] -> add (ppr a)+  withs      =+    atPrec 0 $ sep $+      mapHead (text "with type" <+>) $+        mapTail ((nest 6) . (text "and" <+>)) $+          [ pprTyApp 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| type $tid:lhs = type $qtid:rhs |] ->+      text "type" <+> ppr lhs <+> equals <+> text "type" <+> ppr rhs+    [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+  ppr e0 = case e0 of+    _ | Just doc <- pprInfix unfoldExpr e0+                       -> doc+      | Just es <- unfoldExList e0+                       -> pprStyleList listStyleBrack es+    [ex| { } |]        -> braces mempty -- Must come before ExVar case+    [ex| $e1 :: $e2 |] -> prec precCaret $+                            ppr1 e1 <+> text Strings.cons <+> ppr e2+    [ex| $qvid:x |]    -> ppr x+    [ex| $lit:lt |]    -> ppr lt+    [ex| $qcid:x |]    -> ppr x+    [ex| $qcid:x $e |] -> prec precApp (sep [ ppr x, ppr1 e ])+    [ex| `$uid:x |]    -> char '`' <> ppr x+    [ex| `$uid:x $e |] -> prec precApp (sep [ char '`' <> ppr x, ppr1 e ])+    [ex| #$uid:x $e |] -> prec precApp (sep [ char '#' <> ppr x, ppr1 e ])+    [ex| if $ec then $et else $ef |] ->+      prec precDot $+        sep [ text "if" <+> ppr ec,+              nest 2 $ text "then" <+> ppr0 et,+              nest 2 $ text "else" <+> ppr ef ]+    [ex| $_; $_ |] ->+      prec precExSemi $+        sep (unfold e0)+      where unfold [ex| $e1; $e2 |] = ppr1 e1 <> semi : unfold e2+            unfold e                 = [ ppr0 e ]+    [ex| let $lid:x = $e1 in $e2 |] ->+      prec precDot $+        hangLet (pprLet (text "let" <+> ppr x) e1 True) e2+    [ex| let $x = $e1 in $e2 |] ->+      prec precDot $+        hangLet (text "let" <+> ppr x <+> equals+                  >+> ppr e1 <+> text "in")+                e2+    [ex| match $e1 with $list:clauses |] ->+      prec precDot $+        vcat (sep [ text "match",+                    nest 2 $ ppr0 e1,+                    text "with" ] : map ppr clauses)+    [ex| let rec $list:bs in $e2 |] ->+      prec precDot $+        text "let" <+>+        vcat (zipWith pprBinding ("rec" : repeat "and") bs) $$+        nest 1 (text "in" <+> ppr e2)+    [ex| let $decl:d in $e2 |] ->+      prec precDot $+        hangLet+          (text "let" <+> ppr0 d <+> text "in")+          e2+    [ex| ($e1, $e2) |] ->+      prec precCom $+        sep [ ppr e1 <> comma, ppr1 e2 ]+    [ex| λ $_ → $_ |]  ->+      prec precDot $+        hang+          (text Strings.fun <+>+           fsep (pprPrec1 precApp <$> args) <+>+           text Strings.arrow)+          2+          (ppr body)+        where (args, body) = unfoldExAbs e0+    [ex| $e1 $e2 |]+          -> prec precApp $+               sep [ ppr e1, ppr1 e2 ]+    [ex| ( $e : $t1 :> $t2 ) |] ->+      prec precCast $+        atPrec (precCast + 2) $+          sep [ ppr e,+                colon     <+> ppr t1,+                text ":>" <+> ppr t2 ]+    [ex| { $list:flds | $e2 } |] ->+      pprRecord "{" flds e2 "}"+    [ex| {+ $list:flds | $e2 +} |] ->+      pprRecord "{+" flds e2 "+}"+    [ex| $e . $uid:sel |] ->+      prec precSel $+        pprPrec precSel e <> char '.' <> ppr (uidToLid sel)+    [ex| ( $e : $t1 ) |] ->+      prec precCast $+        atPrec (precCast + 2) $+          sep [ ppr e,+                colon <+> ppr t1 ]+    [ex| ( $e :> $t1 ) |] ->+      prec precCast $+        atPrec (precCast + 2) $+          sep [ ppr e,+                text ":>" <+> ppr t1 ]+    [ex| $anti:a |] -> ppr a+    where+    unfoldExpr [ex| ($name:x $e1) $e2 |] = Just (e1, x, Just e2)+    unfoldExpr [ex| $name:x $e1 |]       = Just (e1, x, Nothing)+    unfoldExpr _                          = Nothing++unfoldExList ∷ Expr i → Maybe [Expr i]+unfoldExList [ex| [] |]        = Just []+unfoldExList [ex| [ ] |]       = Just []+unfoldExList [ex| $e1 ∷ $e2 |] = (e1 :) <$> unfoldExList e2+unfoldExList _                 = Nothing++pprRecord    ∷ String → [Field i] → Expr i → String → Doc+pprRecord bl flds e2 br =+  atPrec precStart $+    text bl <+>+    fsep (punctuate comma (ppr <$> flds)+          ++ case e2 of+               [ex|! { } |] → []+               _            → [char '|' <+> ppr e2])+    <+> text br++instance Ppr (Field i) where+  ppr [fdQ| $uid:u = $e |] = pprLet (ppr (uidToLid u)) e False+  ppr [fdQ| $antiF:a |]    = ppr a++pprBinding :: String -> Binding i -> Doc+pprBinding kw [bnQ| $lid:x = $e |] = pprLet (text kw <+> ppr x) e True+pprBinding kw [bnQ| $antiB:a |]    = text kw <+> ppr a++instance Ppr (CaseAlt i) where+  ppr [caQ| $xi -> $ei |] =+    hang (char '|' <+> ppr xi <+> text Strings.arrow)+         4+         (ppr ei)+  ppr [caQ| #$uid:lab $opt:mxi -> $ei |] =+    hang (text "| #" <> ppr lab+          <+> maybe mempty (pprPrec (precApp + 1)) mxi+          <+> text Strings.arrow)+         4+         (ppr ei)+  ppr [caQ| $antiC:a |]   = char '|' <+> ppr a++-- | Print a let expression, indenting the body only if the body is+--   not another let expression.+hangLet ∷ Doc → Expr i → Doc+hangLet doc e2 = hang doc (if (isLet e2) then 0 else 2) (ppr e2)+  where+  isLet [ex| $_; $_ |]                = False+  isLet [ex| let $_ = $_ in $_ |]     = True+  isLet [ex| let rec $list:_ in $_ |] = True+  isLet _                             = False++-- | Print the binding and rhs of a let+pprLet :: Doc -> Expr i -> Bool -> Doc+pprLet doc e1 withIn =+  doc <+>+  nest 2 (fsep (pprPrec1 precApp <$> args)) <+>+  maybe mempty (nest 2 . (colon <+>) . ppr0) mannot <+> equals+    >+> ppr rhs <+> if withIn then text "in" else mempty+  where+    (args, rhs, mannot) = resugarLet e1++-- | Given the rhs of a let expression, pull out the arguments and+--   any result-type annotation.+resugarLet ∷ Expr i → ([Patt i], Expr i, Maybe (Type i))+resugarLet e =+  let (args, rhs0)  = unfoldExAbs e+   in case rhs0 of+        [ex| $e' : $t |] → (args, e', Just t)+        _                → (args, rhs0, Nothing)++instance Ppr (Patt i) where+  ppr π0 | Just πs ← unfoldPaList π0+                            = pprStyleList listStyleBrack πs+  ppr [pa| _ |]             = text "_"+  ppr [pa| $lid:l |]        = ppr l+  ppr [pa| $x :: $y |]      = prec precCaret $+                                 ppr1 x <+> text Strings.cons <+> ppr y+  ppr [pa| $qcid:qu |]      = ppr qu+  ppr [pa| $qcid:qu $x |]   = prec precApp $+                                 ppr qu <+> ppr1 x+  ppr [pa| ($x, $y) |]      = prec precCom $+                                 ppr x <> comma <+> ppr1 y+  ppr [pa| $lit:lt |]       = ppr lt+  ppr [pa| $x as $lid:l |]  = prec precDot $+                                 ppr1 x <+> text "as" <+> ppr l+  ppr [pa| `$uid:u |]       = char '`' <> ppr u+  ppr [pa| `$uid:u $x |]    = prec precApp $+                                char '`' <> ppr u <+> ppr1 x+  ppr π0@[pa| { $uid:_ = $_ | $_ } |]+                            =+    atPrec precStart $+      char '{' <+>+      fsep (punctuate comma+             [ ppr (uidToLid ui) <+> equals <+> ppr πi+             | (ui, πi) ← flds ]+            ++ case π2 of+                 [pa|! _ |] → []+                 _          → [char '|' <+> ppr π2])+      <+> char '}'+    where (flds, π2) = unfoldPaRec π0+  ppr [pa| ! $x |]          = prec precBang $+                                char '!' <> ppr1 x+  ppr [pa| $x : $t |]       = prec precCast $+                                hang (ppr x)+                                     2+                                     (colon <+> ppr0 t)+  ppr [pa| $anti:a |]       = ppr a++unfoldPaList ∷ Patt i → Maybe [Patt i]+unfoldPaList [pa| [] |]        = Just []+unfoldPaList [pa| [ ] |]       = Just []+unfoldPaList [pa| $π1 ∷ $π2 |] = (π1 :) <$> unfoldPaList π2+unfoldPaList _                 = Nothing++instance Ppr Lit where+  ppr (LtInt i)   = integer i+  ppr (LtChar c)  = text (show c)+  ppr (LtFloat f) = double f+  ppr (LtStr s)   = text (show s)+  ppr (LtAnti a)  = ppr a++--+-- Helper for pretty-printing type-like things -- doesn't require+-- underlying types, but does need to see the operator name.+--++data PprTyAppHelper i a+  = PTAHBranch (QTypId i) [a]+  | PTAHLeaf   a++instance Ppr a => Ppr (PprTyAppHelper i a) where+  ppr (PTAHLeaf a) = ppr a+  ppr _            = error "BUG! in PprTyAppHelper.ppr"++unfoldPTAH :: PprTyAppHelper i a ->+              Maybe (PprTyAppHelper i a, String, Maybe (PprTyAppHelper i a))+unfoldPTAH (PTAHBranch (J [] l) [a, b])+  = Just (PTAHLeaf a, unLid (unTypId l), Just (PTAHLeaf b))+unfoldPTAH (PTAHBranch (J [] l) [a])+  = Just (PTAHLeaf a, unLid (unTypId l), Nothing)+unfoldPTAH _+  = Nothing++pprTyApp :: Ppr a => QTypId i -> [a] -> Doc+pprTyApp ql ts+  | Just doc <- pprInfix unfoldPTAH (PTAHBranch ql ts)+               = doc+pprTyApp ql [] = ppr ql+pprTyApp ql ts = prec precApp $ sep [ ppr ts, ppr ql ]++--+-- Instances+--++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 Loc       where pprPrec = pprFromShow+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 (TypId i) where pprPrec = pprFromShow+instance Ppr (VarId i) where pprPrec = pprFromShow+instance Ppr (ConId i) where pprPrec = pprFromShow+instance Ppr (ModId i) where pprPrec = pprFromShow+instance Ppr (SigId 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+
+ src/Syntax/PprClass.hs view
@@ -0,0 +1,394 @@+module Syntax.PprClass (+  -- * Documents+  Doc,+  -- * Pretty-printing class+  Ppr(..), IsInfix(..), ListStyle(..), listStyleBrack,+  -- ** Helpers+  ppr0, ppr1, pprPrec1, pprDepth,+  -- ** Context operations+  prec, prec0, mapPrec, prec1, descend, atPrec, atDepth,+  askPrec, ifPrec, askDepth, ifDepth,+  trimList, trimCat,+  -- *** For type name shortening+  TyNames(..), tyNames0,+  setTyNames, askTyNames, enterTyNames, lookupTyNames,+  -- * Pretty-printing combinators+  (>+>), (>?>), ifEmpty,+  vcat, sep, cat, fsep, fcat,+  -- * Renderers+  render, renderS, printDoc, printPpr, hPrintDoc, hPrintPpr,+  -- ** Instantiations of several context-sensitive functions+  --    with the zero context+  isEmpty, renderStyle, fullRender,+  -- ** Instance helpers+  showFromPpr, pprFromShow,+  -- * Alternate printing of 'Maybe'+  MAYBE(..),+  -- * Re-exports+  module Alt.PrettyPrint+) where++import Alt.PrettyPrint hiding ( Doc(..),+                                render, isEmpty, renderStyle, fullRender,+                                vcat, sep, cat, fsep, fcat )+import qualified Alt.PrettyPrint as P++import Data.Perhaps+import Syntax.Prec+import qualified Syntax.Strings as Strings+import AST.Ident (QTypId, ModId, Renamed)++import System.IO (Handle, stdout, hPutChar, hPutStr)+import qualified Data.Map as M+import qualified Data.Set as S++-- | Context for pretty-printing.+data PprContext+  = PprContext {+      pcPrec   :: !Int,+      pcDepth  :: !Int,+      pcTyName :: !TyNames+  }++data TyNames =+  TyNames {+    tnLookup   :: Int -> QTypId Renamed -> QTypId Renamed,+    tnEnter    :: ModId Renamed -> TyNames+  }++-- | Default context+pprContext0 :: PprContext+pprContext0  = PprContext {+  pcPrec   = 0,+  pcDepth  = -1,+  pcTyName = tyNames0+}++tyNames0 :: TyNames+tyNames0  = TyNames {+  tnLookup = const id,+  tnEnter  = const tyNames0+}++type Doc = P.Doc PprContext++data ListStyle +  = ListStyle {+    listStyleBegin, listStyleEnd, listStylePunct :: Doc,+    listStyleDelimitEmpty, listStyleDelimitSingleton :: Bool,+    listStyleJoiner :: [Doc] -> Doc+  }++-- | Class for pretty-printing at different types+--+-- Minimal complete definition is one of:+--+-- * 'pprPrec'+--+-- * 'ppr'+class Ppr p where+  -- | Print current precedence+  ppr     :: p -> Doc+  -- | Print at the specified enclosing precedence+  pprPrec :: Int -> p -> Doc+  -- | Print a list in the default style+  pprList :: [p] -> Doc+  -- | Print a list in the specified style+  pprStyleList :: ListStyle -> [p] -> Doc+  -- | Style for printing lists+  listStyle   :: [p] -> ListStyle+  --+  --+  ppr         = asksD pcPrec . flip pprPrec+  pprPrec p   = prec p . ppr+  pprList xs  = pprStyleList (listStyle xs) xs+  --+  pprStyleList st [] =+    if listStyleDelimitEmpty st+      then listStyleBegin st <> listStyleEnd st+      else mempty+  pprStyleList st [x] =+    if listStyleDelimitSingleton st+      then listStyleBegin st <> ppr0 x <> listStyleEnd st+      else ppr x+  pprStyleList st xs  =+    listStyleBegin st <>+      listStyleJoiner st (punctuate (listStylePunct st) (map ppr0 xs))+    <> listStyleEnd st+  --+  listStyle _ = ListStyle {+    listStyleBegin            = lparen,+    listStyleEnd              = rparen,+    listStylePunct            = comma,+    listStyleDelimitEmpty     = False,+    listStyleDelimitSingleton = False,+    listStyleJoiner           = fsep+  }++-- | Style for printing square-bracketed lists.+listStyleBrack ∷ ListStyle+listStyleBrack = ListStyle {+  listStyleBegin            = lbrack,+  listStyleEnd              = rbrack,+  listStylePunct            = comma,+  listStyleDelimitEmpty     = True,+  listStyleDelimitSingleton = True,+  listStyleJoiner           = fsep+}++-- | Print at top level.+ppr0      :: Ppr p => p -> Doc+ppr0       = atPrec 0 . ppr++-- | Print at next level.+ppr1      :: Ppr p => p -> Doc+ppr1       = prec1 . ppr++-- | Print at one more than the given level.+pprPrec1  :: Ppr p => Int -> p -> Doc+pprPrec1   = pprPrec . succ++-- | Print to the given depth.+pprDepth  :: Ppr p => Int -> p -> Doc+pprDepth d = atDepth d . ppr++-- | Enter the given precedence level, drawing parentheses if necessary,+--   and count it as a descent in depth as well.+prec :: Int -> Doc -> Doc+prec p doc = asksD pcPrec $ \p' ->+  if p' > p+    then descend $ parens (atPrec p doc)+    else atPrec p doc++-- | Enter the given precedence level, drawing parentheses if necessary,+--   and count it as a descent in depth as well. If we enter+--   parentheses, reset the precedence to 0 at most.+prec0 :: Int -> Doc -> Doc+prec0 p doc = asksD pcPrec $ \p' ->+  if p' > p+    then descend $ parens (atPrec (p `min` 0) doc)+    else atPrec p doc++-- | Adjust the precedence with the given function.+mapPrec :: (Int -> Int) -> Doc -> Doc+mapPrec f doc = askPrec (\p -> prec (f p) doc)++-- | Go to the next (tigher) precedence level.+prec1 :: Doc -> Doc+prec1  = mapD (\e -> e { pcPrec = pcPrec e + 1 })++-- | Descend a level, elliding if the level counter runs out+descend :: Doc -> Doc+descend doc = askD $ \e ->+  case pcDepth e of+    -1 -> doc+    0  -> text Strings.ellipsis+    k  -> localD e { pcDepth = k - 1 } doc++-- | Set the precedence, but check or draw parentheses+atPrec   :: Int -> Doc -> Doc+atPrec p  = mapD (\e -> e { pcPrec = p })++-- | Set the precedence, but check or draw parentheses+atDepth  :: Int -> Doc -> Doc+atDepth k = mapD (\e -> e { pcDepth = k })++-- | Find out the precedence+askPrec :: (Int -> Doc) -> Doc+askPrec  = asksD pcPrec++-- | A conditional: uses the second argument if the current precedence+--   satisfies the predicate, otherwise the second+ifPrec  :: (Int -> Bool) -> Doc -> Doc -> Doc+ifPrec predicate true false =+  askPrec $ \p → if predicate p then true else false++-- | Find out the depth+askDepth :: (Int -> Doc) -> Doc+askDepth  = asksD pcDepth++-- | A conditional: uses the second argument if the current depth+--   satisfies the predicate, otherwise the second+ifDepth  :: (Int -> Bool) -> Doc -> Doc -> Doc+ifDepth predicate true false =+  askDepth $ \p → if predicate p then true else false++-- | Change the type name lookup function+setTyNames   :: TyNames -> Doc -> Doc+setTyNames f  = mapD (\e -> e { pcTyName = f })++-- | Retrieve the type name lookup function+askTyNames   :: (TyNames -> Doc) -> Doc+askTyNames    = asksD pcTyName++-- | Render a document with a module opened+enterTyNames :: ModId Renamed -> Doc -> Doc+enterTyNames u doc = askTyNames $ \tn ->+  setTyNames (tnEnter tn u) doc++-- | Look up a type name in the rendering context+lookupTyNames :: Int -> QTypId Renamed -> (QTypId Renamed -> Doc) -> Doc+lookupTyNames tag ql kont = askTyNames $ \tn ->+  kont (tnLookup tn tag ql)++-- | Trim a list to (about) the given number of elements, with+--   "..." in the middle.+trimList :: Int -> [Doc] -> [Doc]+trimList (-1) ds = ds+trimList n2   ds = if k <= 2 * n+                     then ds+                     else take n ds ++ text "... " : drop (k - n) ds+  where+    n = (n2 + 1) `div` 2+    k = length ds++-- | Lift a concatenation function to respect depth.+trimCat :: ([Doc] -> Doc) -> [Doc] -> Doc+trimCat xcat docs = asksD pcDepth $ \d -> case d of+  -1 -> xcat docs+  _  -> atDepth ((d + 1) `div` 2) (xcat (trimList d docs))++vcat, sep, cat, fsep, fcat :: [Doc] -> Doc+vcat = trimCat P.vcat+sep  = trimCat P.sep+cat  = trimCat P.cat+fsep = trimCat P.fsep+fcat = trimCat P.fcat++newtype MAYBE a = MAYBE (Maybe a) deriving (Eq, Ord)++instance Ppr a => Ppr (MAYBE a) where+  ppr (MAYBE Nothing)  = text "nothing"+  ppr (MAYBE (Just a)) = ppr a++instance Ppr a => Ppr (Maybe a) where+  ppr Nothing  = mempty+  ppr (Just a) = ppr a++instance Ppr a => Ppr (Perhaps a) where+  ppr Nope     = mempty+  ppr (Here a) = ppr a++instance (Ppr a, Ppr b) => Ppr (Either a b) where+  ppr (Left a)  = prec precApp (text "Left" <+> ppr a)+  ppr (Right a) = prec precApp (text "Right" <+> ppr a)++instance Ppr a => Ppr [a] where+  ppr = pprList++instance (Ppr a, Ppr b) => Ppr (a, b) where+  ppr (a, b) = parens (sep (punctuate comma [ppr0 a, ppr0 b]))++instance (Ppr a, Ppr b, Ppr c) => Ppr (a, b, c) where+  ppr (a,b,c) =+    parens (sep (punctuate comma [ppr0 a, ppr0 b, ppr0 c]))++instance (Ppr a, Ppr b, Ppr c, Ppr d) => Ppr (a, b, c, d) where+  ppr (a,b,c,d) =+    parens (sep (punctuate comma [ppr0 a, ppr0 b, ppr0 c, ppr0 d]))++instance (Ppr k, Ppr v) => Ppr (M.Map k v) where+  ppr m = braces . fsep . punctuate comma $+    [ ppr0 k <> colon <+> ppr0 v+    | (k, v) <- M.toList m ]++instance Ppr a => Ppr (S.Set a) where+  ppr = braces . fsep . punctuate comma . map ppr0 . S.toList++-- | Class to check if a particular thing will print infix.  Adds+--   an operation to print at the given precedence only if the given+--   thing is infix.  (We use this for printing arrows without too+--   many parens.)+class Ppr a => IsInfix a where+  isInfix  :: a -> Bool+  pprRight :: a -> Doc+  pprRight a =+    if isInfix a+      then ppr a+      else ppr0 a++instance Ppr Bool      where pprPrec = pprFromShow+instance Ppr Int       where ppr = int+instance Ppr Integer   where ppr = integer+instance Ppr Double    where ppr = double++instance Ppr Char where+  pprPrec        = pprFromShow+  pprStyleList _ = text++instance Ppr (P.Doc PprContext)  where ppr = id+instance Show (P.Doc PprContext) where showsPrec = showFromPpr++-- Render a document in the preferred style, given a string continuation+renderS :: Doc -> ShowS+renderS doc rest = fullRenderIn pprContext0 PageMode 80 1.1 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 ""++-- Is the document empty (in 'pprContext0')?+isEmpty :: Doc -> Bool+isEmpty  = isEmptyIn pprContext0++-- Render in the given style (in 'pprContext0')+renderStyle :: Style -> Doc -> String+renderStyle = renderStyleIn pprContext0++-- Render with the given parameters (in 'pprContext0')+fullRender :: Mode -> Int -> Float ->+              (TextDetails -> a -> a) -> a ->+              Doc -> a+fullRender = fullRenderIn pprContext0++-- Render and display a document in the preferred style+printDoc :: Doc -> IO ()+printDoc  = hPrintDoc stdout++-- Pretty-print, render and display in the preferred style+printPpr :: Ppr a => a -> IO ()+printPpr  = hPrintPpr stdout++-- Render and display a document in the preferred style+hPrintDoc :: Handle -> Doc -> IO ()+hPrintDoc h = fullRenderIn pprContext0 PageMode 80 1.1 each (putChar '\n')+  where each (Chr c) io  = hPutChar h c >> io+        each (Str s) io  = hPutStr h s >> io+        each (PStr s) io = hPutStr h s >> io++hPrintPpr :: Ppr a => Handle -> a -> IO ()+hPrintPpr h = hPrintDoc h . 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 "")++--+-- Some indentation operations+--++liftEmpty :: (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc+liftEmpty joiner d1 d2 = askD f where+  f e | isEmptyIn e d1 = d2+      | isEmptyIn e d2 = d1+      | otherwise      = joiner d1 d2++ifEmpty :: Doc -> Doc -> Doc -> Doc+ifEmpty dc dt df = askD $ \e ->+  if isEmptyIn e dc+    then dt+    else df++(>+>) :: Doc -> Doc -> Doc+(>+>) = flip hang 2++(>?>) :: Doc -> Doc -> Doc+(>?>)  = liftEmpty (>+>)++infixr 5 >+>, >?>+
+ src/Syntax/Prec.hs view
@@ -0,0 +1,80 @@+-- | Operator precdences+--+-- We use operator precedences from Ocaml.  The precence and+-- associativity of an operator is determined by its first character.+module Syntax.Prec (+  Prec, precOp, fixities,+  -- * Precedences for reserved operators needed by the parser+  precMin, precStart, precMax, precCast,+  precCom, precDot, precExSemi, precTySemi, precEq, precCaret, precArr,+  precPlus, precStar, precAt, precApp, precBang, precSel,+) where++import Data.Char++-- | 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 ('-':'>':_)    = Right precArr+precOp ('-':'o':_)    = Right precArr+precOp "-[]>"         = Right precArr+precOp (';':_)        = Right precTySemi+precOp "⋁"            = Right precTySemi+precOp "\\/"          = Right precTySemi+precOp "!="           = Left precEq+precOp (c:cs)+  | c `elem` "=<>|&$" = Left precEq+  | c `elem` "*×/%"   = Left precStar+  | c `elem` "+-"     = Left precPlus+  | c `elem` "^:∷"    = Right precCaret+  | c `elem` "@"      = Right precAt+  | c `elem` "!~?"    = Right precBang+  | otherwise = case generalCategory c of+      CurrencySymbol        -> Left precEq+      MathSymbol            -> Left precStar+      DashPunctuation       -> Left precPlus+      OtherSymbol           -> Left precPlus+      ConnectorPunctuation  -> Right precCaret+      OtherPunctuation      -> Right precAt+      _                     -> precOp cs+precOp ""             = Left precApp++precMin, precStart, precMax, precCast,+  precCom, precDot, precExSemi, precTySemi, precEq, precCaret, precArr,+  precPlus, precStar, precAt, precApp, precSel, precBang :: Int+precMin   = -1+precCom   = -1 -- ,+precStart =  0 -- includes "|" for row types+precDot   =  1 -- in, else, of, .+precExSemi=  1 -- ;  (expressions only)+precCast  =  2 -- :>+precArr   =  3 -- ->+precEq    =  4 -- != = < > | & $ as+precCaret =  5 -- ^ : (infixr)+precPlus  =  6 -- - ++precStar  =  7 -- % / *+precTySemi=  8 -- ; "\\/" "⋁" (types only)+precAt    =  9 -- @ ** (infixr)+precApp   = 10 -- f x+precSel   = 11 -- record selection+precBang  = 12 -- ! ~ ? (prefix)+precMax   = 12++{-# INLINE fixities #-}+-- 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 == precTySemi = Just $ Right precTySemi+  | n == precAt     = Just $ Right precAt+  | n == precBang   = Just $ Right precBang+  | otherwise       = Nothing
+ src/Syntax/Strings.hs view
@@ -0,0 +1,146 @@+-- | Hard-coded strings that depend on whether we're doing unicode.+module Syntax.Strings where++{-# INLINE digits #-}+-- | Subscript numerals for type variables+digits ∷ [Char]++{-# INLINE tvNames #-}+-- | Names to give to type variables+tvNames ∷ [Char]++{-# INLINE fun #-}+{-# INLINE arrow #-}+-- | Term keywords+fun, arrow ∷ String++{-# INLINE all #-}+{-# INLINE ex #-}+{-# INLINE mu #-}+-- | Quantifiers+all, ex, mu ∷ String++{-# INLINE cons #-}+{-# INLINE product #-}+{-# INLINE uArrow #-}+{-# INLINE aArrow #-}+{-# INLINE arrowPre #-}+{-# INLINE arrowPost #-}+{-# INLINE join #-}+-- | Infix type constructors+cons, product, uArrow, aArrow, arrowPre, arrowPost, join ∷ String++{-# INLINE affine #-}+{-# INLINE unlimited #-}+{-# INLINE covariant #-}+{-# INLINE contravariant #-}+{-# INLINE invariant #-}+{-# INLINE omnivariant #-}+{-# INLINE qcovariant #-}+{-# INLINE qcontravariant #-}+{-# INLINE qinvariant #-}+-- | Sigils+affine, unlimited,+  covariant, contravariant, invariant, omnivariant,+  qcovariant, qcontravariant, qinvariant ∷ String++{-# INLINE ellipsis #-}+ellipsis ∷ String++#ifdef UNICODE+digits = unicodeDigits+tvNames         = [ 'a' .. 'z' ]+all             = "∀"+ex              = "∃"+mu              = "μ"+cons            = "∷"+product         = "×"+uArrow          = "→"+aArrow          = "-A>"+arrowPre        = "-"+arrowPost       = ">"+join            = "⋁"+affine          = "`"+unlimited       = "\'"+covariant       = "+"+contravariant   = "-"+invariant       = ""+omnivariant     = "0"+qcovariant      = "Q+"+qcontravariant  = "Q-"+qinvariant      = "Q"+ellipsis        = "..."+fun             = "λ"+arrow           = "→"+#else+digits = asciiDigits+tvNames         = [ 'a' .. 'z' ]+all             = "all"+ex              = "ex"+mu              = "mu"+cons            = "::"+product         = "*"+uArrow          = "->"+aArrow          = "-A>"+arrowPre        = "-"+arrowPost       = ">"+join            = "\\/"+affine          = "`"+unlimited       = "\'"+covariant       = "+"+contravariant   = "-"+invariant       = ""+omnivariant     = "0"+qcovariant      = "Q+"+qcontravariant  = "Q-"+qinvariant      = "Q"+ellipsis        = "..."+fun             = "fun"+arrow           = "->"+#endif++{-# INLINE unicodeDigits #-}+{-# INLINE asciiDigits #-}+unicodeDigits, asciiDigits ∷ [Char]+unicodeDigits = "₀₁₂₃₄₅₆₇₈₉"+asciiDigits   = "0123456789"++normalizeChar ∷ Char → Char+normalizeChar '₀' = '0'+normalizeChar '₁' = '1'+normalizeChar '₂' = '2'+normalizeChar '₃' = '3'+normalizeChar '₄' = '4'+normalizeChar '₅' = '5'+normalizeChar '₆' = '6'+normalizeChar '₇' = '7'+normalizeChar '₈' = '8'+normalizeChar '₉' = '9'+normalizeChar '′' = '\''+normalizeChar 'α' = 'a'+normalizeChar 'β' = 'b'+normalizeChar 'ψ' = 'c'+normalizeChar 'δ' = 'd'+normalizeChar 'ε' = 'e'+normalizeChar 'φ' = 'f'+normalizeChar 'γ' = 'g'+normalizeChar 'η' = 'h'+normalizeChar 'ι' = 'i'+normalizeChar 'ξ' = 'j'+normalizeChar 'κ' = 'k'+normalizeChar 'λ' = 'l'+normalizeChar 'μ' = 'm'+normalizeChar 'ν' = 'n'+normalizeChar 'ο' = 'o'+normalizeChar 'π' = 'p'+normalizeChar 'ρ' = 'r'+normalizeChar 'σ' = 's'+normalizeChar 'τ' = 't'+normalizeChar 'θ' = 'u'+normalizeChar 'ω' = 'v'+normalizeChar 'ς' = 'w'+normalizeChar 'χ' = 'x'+normalizeChar 'υ' = 'y'+normalizeChar 'ζ' = 'z'+normalizeChar c   = c+
− src/Syntax/SyntaxTable.hs 
@@ -1,133 +0,0 @@-{-# 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-  & "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 
@@ -1,136 +0,0 @@-{-# 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  (Maybe (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 Nothing--tyLol         :: Type i -> Type i -> Type i-tyLol          = tyFun (Just 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 mq dom cod -> do-      putStrLn $ case mq of-        Just q  -> "-[" ++ maybe "ANTI" show (qInterpretM q) ++ "]> {"-        Nothing -> "-> {"-      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/Token.hs 
@@ -1,494 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{--  This is a modified version of the Parsec module whose copyright is-  below, which supports figuring out where a token has ended *before*-  ensuing whitespace.--  In particular, it defines a type class for functionally updating the-  state with a SourcePos, and then lexeme always stashes the position-  there before discarding whitespace.--}--------------------------------------------------------------------------------- |--- Module      :  Text.ParserCombinators.Parsec.Token--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)------ Maintainer  :  daan@cs.uu.nl--- Stability   :  provisional--- Portability :  non-portable (uses existentially quantified data constructors)------ A helper module to parse lexical elements (tokens).-----------------------------------------------------------------------------------module Token-                  ( TokenEnd (..)-                  , LanguageDef (..)-                  , TokenParser (..)-                  , makeTokenParser-                  ) where--import Data.Char (isAlpha,toLower,toUpper,isSpace,digitToInt)-import Data.List (nub,sort)-import Text.ParserCombinators.Parsec--class TokenEnd st where-  saveTokenEnd :: CharParser st ()--instance TokenEnd () where-  saveTokenEnd  = return ()---------------------------------------------------------------- Language Definition-------------------------------------------------------------data LanguageDef st-    = LanguageDef-    { commentStart   :: String-    , commentEnd     :: String-    , commentLine    :: String-    , nestedComments :: Bool-    , identStart     :: CharParser st Char-    , identLetter    :: CharParser st Char-    , opStart        :: CharParser st Char-    , opLetter       :: CharParser st Char-    , reservedNames  :: [String]-    , reservedOpNames:: [String]-    , caseSensitive  :: Bool-    }---------------------------------------------------------------- A first class module: TokenParser-------------------------------------------------------------data TokenParser st-    = TokenParser{ identifier       :: CharParser st String-                 , reserved         :: String -> CharParser st ()-                 , operator         :: CharParser st String-                 , reservedOp       :: String -> CharParser st ()--                 , charLiteral      :: CharParser st Char-                 , stringLiteral    :: CharParser st String-                 , natural          :: CharParser st Integer-                 , integer          :: CharParser st Integer-                 , float            :: CharParser st Double-                 , naturalOrFloat   :: CharParser st (Either Integer Double)-                 , decimal          :: CharParser st Integer-                 , hexadecimal      :: CharParser st Integer-                 , octal            :: CharParser st Integer--                 , symbol           :: String -> CharParser st String-                 , lexeme           :: forall a. CharParser st a -> CharParser st a-                 , whiteSpace       :: CharParser st ()--                 , parens           :: forall a. CharParser st a -> CharParser st a-                 , braces           :: forall a. CharParser st a -> CharParser st a-                 , angles           :: forall a. CharParser st a -> CharParser st a-                 , brackets         :: forall a. CharParser st a -> CharParser st a-                 -- "squares" is deprecated-                 , squares          :: forall a. CharParser st a -> CharParser st a--                 , semi             :: CharParser st String-                 , comma            :: CharParser st String-                 , colon            :: CharParser st String-                 , dot              :: CharParser st String-                 , semiSep          :: forall a . CharParser st a -> CharParser st [a]-                 , semiSep1         :: forall a . CharParser st a -> CharParser st [a]-                 , commaSep         :: forall a . CharParser st a -> CharParser st [a]-                 , commaSep1        :: forall a . CharParser st a -> CharParser st [a]-                 }---------------------------------------------------------------- Given a LanguageDef, create a token parser.-------------------------------------------------------------makeTokenParser :: TokenEnd st => LanguageDef st -> TokenParser st-makeTokenParser languageDef-    = TokenParser{ identifier = identifier-                 , reserved = reserved-                 , operator = operator-                 , reservedOp = reservedOp--                 , charLiteral = charLiteral-                 , stringLiteral = stringLiteral-                 , natural = natural-                 , integer = integer-                 , float = float-                 , naturalOrFloat = naturalOrFloat-                 , decimal = decimal-                 , hexadecimal = hexadecimal-                 , octal = octal--                 , symbol = symbol-                 , lexeme = lexeme-                 , whiteSpace = whiteSpace--                 , parens = parens-                 , braces = braces-                 , angles = angles-                 , brackets = brackets-                 , squares = brackets-                 , semi = semi-                 , comma = comma-                 , colon = colon-                 , dot = dot-                 , semiSep = semiSep-                 , semiSep1 = semiSep1-                 , commaSep = commaSep-                 , commaSep1 = commaSep1-                 }-    where--    ------------------------------------------------------------    -- Bracketing-    ------------------------------------------------------------    parens p        = between (symbol "(") (symbol ")") p-    braces p        = between (symbol "{") (symbol "}") p-    angles p        = between (symbol "<") (symbol ">") p-    brackets p      = between (symbol "[") (symbol "]") p--    semi            = symbol ";"-    comma           = symbol ","-    dot             = symbol "."-    colon           = symbol ":"--    commaSep p      = sepBy p comma-    semiSep p       = sepBy p semi--    commaSep1 p     = sepBy1 p comma-    semiSep1 p      = sepBy1 p semi---    ------------------------------------------------------------    -- Chars & Strings-    ------------------------------------------------------------    -- charLiteral :: CharParser st Char-    charLiteral     = lexeme (between (char '\'')-                                      (char '\'' <?> "end of character")-                                      characterChar )-                    <?> "character"--    characterChar   = charLetter <|> charEscape-                    <?> "literal character"--    charEscape      = do{ char '\\'; escapeCode }-    charLetter      = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))----    -- stringLiteral :: CharParser st String-    stringLiteral   = lexeme (-                      do{ str <- between (char '"')-                                         (char '"' <?> "end of string")-                                         (many stringChar)-                        ; return (foldr (maybe id (:)) "" str)-                        }-                      <?> "literal string")--    -- stringChar :: CharParser st (Maybe Char)-    stringChar      =   do{ c <- stringLetter; return (Just c) }-                    <|> stringEscape-                    <?> "string character"--    stringLetter    = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))--    stringEscape    = do{ char '\\'-                        ;     do{ escapeGap  ; return Nothing }-                          <|> do{ escapeEmpty; return Nothing }-                          <|> do{ esc <- escapeCode; return (Just esc) }-                        }--    escapeEmpty     = char '&'-    escapeGap       = do{ many1 space-                        ; char '\\' <?> "end of string gap"-                        }----    -- escape codes-    escapeCode      = charEsc <|> charNum <|> charAscii <|> charControl-                    <?> "escape code"--    -- charControl :: CharParser st Char-    charControl     = do{ char '^'-                        ; code <- upper-                        ; return (toEnum (fromEnum code - fromEnum 'A'))-                        }--    -- charNum :: CharParser st Char-    charNum         = do{ code <- decimal-                                  <|> do{ char 'o'; number 8 octDigit }-                                  <|> do{ char 'x'; number 16 hexDigit }-                        ; return (toEnum (fromInteger code))-                        }--    charEsc         = choice (map parseEsc escMap)-                    where-                      parseEsc (c,code)     = do{ char c; return code }--    charAscii       = choice (map parseAscii asciiMap)-                    where-                      parseAscii (asc,code) = try (do{ string asc; return code })---    -- escape code tables-    escMap          = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")-    asciiMap        = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)--    ascii2codes     = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",-                       "FS","GS","RS","US","SP"]-    ascii3codes     = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",-                       "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",-                       "CAN","SUB","ESC","DEL"]--    ascii2          = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',-                       '\EM','\FS','\GS','\RS','\US','\SP']-    ascii3          = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',-                       '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',-                       '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']---    ------------------------------------------------------------    -- Numbers-    ------------------------------------------------------------    -- naturalOrFloat :: CharParser st (Either Integer Double)-    naturalOrFloat  = lexeme (natFloat) <?> "number"--    float           = lexeme floating   <?> "float"-    integer         = lexeme int        <?> "integer"-    natural         = lexeme nat        <?> "natural"---    -- floats-    floating        = do{ n <- decimal-                        ; fractExponent n-                        }---    natFloat        = do{ char '0'-                        ; zeroNumFloat-                        }-                      <|> decimalFloat--    zeroNumFloat    =  do{ n <- hexadecimal <|> octal-                         ; return (Left n)-                         }-                    <|> decimalFloat-                    <|> fractFloat 0-                    <|> return (Left 0)--    decimalFloat    = do{ n <- decimal-                        ; option (Left n)-                                 (fractFloat n)-                        }--    fractFloat n    = do{ f <- fractExponent n-                        ; return (Right f)-                        }--    fractExponent n = do{ fract <- fraction-                        ; expo  <- option 1.0 exponent'-                        ; return ((fromInteger n + fract)*expo)-                        }-                    <|>-                      do{ expo <- exponent'-                        ; return ((fromInteger n)*expo)-                        }--    fraction        = do{ char '.'-                        ; digits <- many1 digit <?> "fraction"-                        ; return (foldr op 0.0 digits)-                        }-                      <?> "fraction"-                    where-                      op d f    = (f + fromIntegral (digitToInt d))/10.0--    exponent'       = do{ oneOf "eE"-                        ; f <- sign-                        ; e <- decimal <?> "exponent"-                        ; return (power (f e))-                        }-                      <?> "exponent"-                    where-                       power e  | e < 0      = 1.0/power(-e)-                                | otherwise  = fromInteger (10^e)---    -- integers and naturals-    int             = do{ f <- lexeme sign-                        ; n <- nat-                        ; return (f n)-                        }--    -- sign            :: CharParser st (Integer -> Integer)-    sign            =   (char '-' >> return negate)-                    <|> (char '+' >> return id)-                    <|> return id--    nat             = zeroNumber <|> decimal--    zeroNumber      = do{ char '0'-                        ; hexadecimal <|> octal <|> decimal <|> return 0-                        }-                      <?> ""--    decimal         = number 10 digit-    hexadecimal     = do{ oneOf "xX"; number 16 hexDigit }-    octal           = do{ oneOf "oO"; number 8 octDigit  }--    -- number :: Integer -> CharParser st Char -> CharParser st Integer-    number base baseDigit-        = do{ digits <- many1 baseDigit-            ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits-            ; seq n (return n)-            }--    ------------------------------------------------------------    -- Operators & reserved ops-    ------------------------------------------------------------    reservedOp name =-        lexeme $ try $-        do{ string name-          ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)-          }--    operator =-        lexeme $ try $-        do{ name <- oper-          ; if (isReservedOp name)-             then unexpected ("reserved operator " ++ show name)-             else return name-          }--    oper =-        do{ c <- (opStart languageDef)-          ; cs <- many (opLetter languageDef)-          ; return (c:cs)-          }-        <?> "operator"--    isReservedOp name =-        isReserved (sort (reservedOpNames languageDef)) name---    ------------------------------------------------------------    -- Identifiers & Reserved words-    ------------------------------------------------------------    reserved name =-        lexeme $ try $-        do{ caseString name-          ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)-          }--    caseString name-        | caseSensitive languageDef  = string name-        | otherwise               = do{ walk name; return name }-        where-          walk []     = return ()-          walk (c:cs) = do{ caseChar c <?> msg; walk cs }--          caseChar c  | isAlpha c  = char (toLower c) <|> char (toUpper c)-                      | otherwise  = char c--          msg         = show name---    identifier =-        lexeme $ try $-        do{ name <- ident-          ; if (isReservedName name)-             then unexpected ("reserved word " ++ show name)-             else return name-          }---    ident-        = do{ c <- identStart languageDef-            ; cs <- many (identLetter languageDef)-            ; return (c:cs)-            }-        <?> "identifier"--    isReservedName name-        = isReserved theReservedNames caseName-        where-          caseName      | caseSensitive languageDef  = name-                        | otherwise               = map toLower name---    isReserved names name-        = scan names-        where-          scan []       = False-          scan (r:rs)   = case (compare r name) of-                            LT  -> scan rs-                            EQ  -> True-                            GT  -> False--    theReservedNames-        | caseSensitive languageDef  = sortedNames-        | otherwise               = map (map toLower) sortedNames-        where-          sortedNames   = sort (reservedNames languageDef)----    ------------------------------------------------------------    -- White space & symbols-    ------------------------------------------------------------    symbol name-        = lexeme (string name)--    lexeme p-        = do-            x <- p-            saveTokenEnd-            whiteSpace-            return x---    --whiteSpace-    whiteSpace-        | noLine && noMulti  = skipMany (simpleSpace <?> "")-        | noLine             = skipMany (simpleSpace <|> multiLineComment <?> "")-        | noMulti            = skipMany (simpleSpace <|> oneLineComment <?> "")-        | otherwise          = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")-        where-          noLine  = null (commentLine languageDef)-          noMulti = null (commentStart languageDef)---    simpleSpace =-        skipMany1 (satisfy isSpace)--    oneLineComment =-        do{ try (string (commentLine languageDef))-          ; skipMany (satisfy (/= '\n'))-          ; return ()-          }--    multiLineComment =-        do { try (string (commentStart languageDef))-           ; inComment-           }--    inComment-        | nestedComments languageDef  = inCommentMulti-        | otherwise                = inCommentSingle--    inCommentMulti-        =   do{ try (string (commentEnd languageDef)) ; return () }-        <|> do{ multiLineComment                     ; inCommentMulti }-        <|> do{ skipMany1 (noneOf startEnd)          ; inCommentMulti }-        <|> do{ oneOf startEnd                       ; inCommentMulti }-        <?> "end of comment"-        where-          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)--    inCommentSingle-        =   do{ try (string (commentEnd languageDef)); return () }-        <|> do{ skipMany1 (noneOf startEnd)         ; inCommentSingle }-        <|> do{ oneOf startEnd                      ; inCommentSingle }-        <?> "end of comment"-        where-          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)-
src/Type.hs view
@@ -1,1068 +1,23 @@ -- | The internal representation of types, created by the type checker---   from the syntactic types in 'Syntax.Type'.-{-# LANGUAGE-      CPP,-      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,-  -- * Implicit arrow annotations-  CurrentImpArrRule, ImpArrRule(..),-  -- * 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-  ppr t = askTyNames (\tn -> ppr (typeToStx tn t))-instance Ppr TyPat where-  ppr t = askTyNames (\tn -> ppr (tyPatToStx tn t))--instance Show Type  where showsPrec = showFromPpr-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'  = typeToStx tyNames0---- | Represent a type value as a syntactic type, for printing; renames---   so that scope is apparent, since internal renaming may result in---   different identifiers that print the same-typeToStx :: TyNames -> Type -> Stx.Type Renamed-typeToStx tns = typeToStxRule tns (iaeInit :: CurrentImpArrPrintingRule)--#ifdef ANNOTATION_RULE-type CurrentImpArrRule = ANNOTATION_RULE-#else-type CurrentImpArrRule = Rule4-#endif--#ifdef ANNOTATION_PRINTING_RULE-type CurrentImpArrPrintingRule = ANNOTATION_PRINTING_RULE-#else-type CurrentImpArrPrintingRule = CurrentImpArrRule-#endif--class ImpArrRule a where-  iaeInit      :: a-  iaeLeft      :: a -> a-  iaeRight     :: a -> QDen (TyVar Renamed) -> Type -> a-  iaeImplied   :: a -> QDen (TyVar Renamed)-  iaeInterpret :: Monad m =>-                  a -> Maybe (QExp Renamed) -> m (QDen (TyVar Renamed))-  iaeRepresent :: a -> QDen (TyVar Renamed) -> Maybe (QExp Renamed)-  iaeUnder     :: a -> Variance -> a-  ---  iaeLeft _           = iaeInit-  iaeRight iae _ _    = iae-  iaeImplied _        = minBound-  iaeInterpret iae    = maybe (return (iaeImplied iae)) qInterpretM-  iaeRepresent iae actual-    | actual == iaeImplied iae = Nothing-    | otherwise                = Just (qRepresent actual)-  iaeUnder _ _        = iaeInit---- | Turns annotated arrows into implicit arrows where possible-typeToStxRule :: ImpArrRule iae => TyNames -> iae -> Type -> Stx.Type Renamed-typeToStxRule f iae0 = loop (S.empty, M.empty) iae0 where-  loop ren iae t0 = case t0 of-    TyVar tv      -> Stx.tyVar (maybe tv id (M.lookup tv (snd ren)))-    TyFun q t1 t2 -> Stx.tyFun (iaeRepresent iae q)-                               (loop ren (iaeLeft iae) t1)-                               (loop ren (iaeRight iae q t1) t2)-    TyApp tc ts _ -> Stx.tyApp-                       (bestName f tc)-                       (zipWith (loop ren . iaeUnder iae) (tcArity tc) ts)-    TyQu qu tv t1 -> Stx.tyQu qu tv' (loop ren' iae t1)-      where (tv', ren') = fresh tv ren-    TyMu tv t1    -> Stx.tyMu tv' (loop ren' iae 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))---- | Print all arrow annotations explicitly-data Rule0 = Rule0--instance ImpArrRule Rule0 where-  iaeInit                = Rule0-  iaeRepresent _ actual  = Just (qRepresent actual)---- | Annotation ‘U’ is implicit for unlabeled arrows.-data Rule1 = Rule1--instance ImpArrRule Rule1 where-  iaeInit        = Rule1--newtype Rule2 = Rule2 { unRule2 :: QDen (TyVar Renamed) }---- | Implicit annotation is lub of qualifiers of prior curried---   arguments.  Explicit annotations have no effect on subsequent---   arrows.-instance ImpArrRule Rule2 where-  iaeInit      = Rule2 minBound-  iaeRight iae _ t = Rule2 (unRule2 iae \/ qualifier t)-  iaeImplied   = unRule2---- | Like 'Rule2', but explicit annotations reset the qualifier to---   themselves for subsequent arrows.-newtype Rule3 = Rule3 { unRule3 :: QDen (TyVar Renamed) }--instance ImpArrRule Rule3 where-  iaeInit      = Rule3 minBound-  iaeRight iae actual t-    | unRule3 iae == actual = Rule3 (unRule3 iae \/ qualifier t)-    | otherwise             = Rule3 (actual \/ qualifier t)-  iaeImplied   = unRule3---- | Like 'Rule3', but we arrow the implicit qualifer into covariant---   type constructors.-newtype Rule4 = Rule4 { unRule4 :: QDen (TyVar Renamed) }--instance ImpArrRule Rule4 where-  iaeInit      = Rule4 minBound-  iaeRight iae actual t-    | unRule4 iae == actual = Rule4 (unRule4 iae \/ qualifier t)-    | otherwise             = Rule4 (actual \/ qualifier t)-  iaeImplied   = unRule4-  iaeUnder iae Covariant    = iae-  iaeUnder _   _            = iaeInit---- | Like 'Rule4', but we carry the implicit quantifier into ALL type---   constructors and only use it when we arrive at an arrow in a---   positive position wrt the surrounding arrow.-data Rule5-  = Rule5 {-      unRule5 :: !(QDen (TyVar Renamed)),-      r4Var   :: !Variance-    }--instance ImpArrRule Rule5 where-  iaeInit      = Rule5 minBound 1-  iaeRight iae actual t-    | unRule5 iae == actual = Rule5 (unRule5 iae \/ qualifier t) 1-    | otherwise             = Rule5 (actual \/ qualifier t) 1-  iaeImplied iae-    | r4Var iae == 1 = unRule5 iae-    | otherwise      = minBound-  iaeUnder iae var          = Rule5 (unRule5 iae) (var * r4Var iae)--tyPatToStx' :: TyPat -> Stx.TyPat Renamed-tyPatToStx'  = tyPatToStx tyNames0---- | Represent a type pattern as a syntactic type pattern, for printing-tyPatToStx :: TyNames -> TyPat -> Stx.TyPat Renamed-tyPatToStx f tp0 = case tp0 of-  TpVar tv      -> Stx.tpVar tv Invariant-  TpApp tc tps  -> Stx.tpApp (bestName f tc) (map (tyPatToStx f) tps)-  where---- | Look up the best printing name for a type.-bestName :: TyNames -> TyCon -> QLid Renamed-bestName tn = tnLookup tn <$> tcId <*> tcName---- | 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 = atPrec 0 $-    case tcNext tc of-      Just [(tps,t)] -> pprTyApp (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 '=' <>-                                             mapPrec (max precEq) (ppr tp)-                                       Qu -> ppr tp-                                  in (tv, tv')-                 | tp   <- tps-                 | qlit <- tcBounds tc-                 | i <- [ 1 :: Integer .. ] ]-      ---      Just next -> pprTyApp (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 (jname (tcName tc))-                          >?> char '=' <+> ppr t-      ---      Nothing -> pprTyApp (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 :: Ppr a => [a] -> [Doc]-      ps tvs = [ ppr var <> pprPrec (precApp + 1) tv-               | tv <- tvs-               | var <- tcArity tc ]--instance Show TyCon where showsPrec = showFromPpr+--   from the syntactic types in 'AST.Type'.+module Type (+  module Type.Analyses,+  module Type.ArrowAnnotations,+  module Type.Internal,+  module Type.Ppr,+  module Type.Recursive,+  module Type.Reduce,+  module Type.Subst,+  module Type.Syntax,+  module Type.TyVar,+) where++import Type.Analyses+import Type.ArrowAnnotations+import Type.Internal+import Type.Ppr+import Type.Recursive (standardizeMus)+import Type.Reduce+import Type.Subst+import Type.Syntax+import Type.TyVar
+ src/Type/Analyses.hs view
@@ -0,0 +1,78 @@+module Type.Analyses (+  inferKinds,+  isMonoType,+  tyPatToType,+  tyPatKinds,+) where++import Util+import Type.Internal+import Type.TyVar++import Prelude ()+import qualified Data.Set as S++-- | Find the kinds of the rib 0 type variables in an opened type, where+--   the given 'Int' is the width of the rib.+inferKinds ∷ Ord tv ⇒ Type tv → [Kind]+inferKinds = varianceToKind <$$> loop 0 where+  loop k (TyQu _ _ σ)             = loop (k + 1) σ+  loop k (TyVar (Bound i j _))+    | i == k                      = replicate j 0 ++ 1 : repeat 0+    | otherwise                   = repeat 0+  loop _ (TyVar (Free _))         = repeat 0+  loop k (TyApp tc σs)            =+    foldr (zipWith (+)) (repeat 0)+      [ let σ' = if isQVariance var+                   then qualToType σ+                   else σ+         in (* var) <$> loop k σ'+      | var ← tcArity tc+      | σ   ← σs ]+  loop k (TyRow _ σ1 σ2)          = zipWith (+) (loop k σ1) (loop k σ2)+  loop k (TyMu _ σ)               = loop (k + 1) σ++-- | Is the given type monomorphic (quantifer free)?+isMonoType ∷ Ord tv ⇒ Type tv → Bool+isMonoType = foldType (\_ ns k → k (() <$ ns) (\_ → False))+                      (\_ _ _ → False)+                      (\_ → True)+                      (\_ → and)+                      (\_ → (&&))+                      (\_ k → k () id)++-- | Convert a type pattern to a type.+tyPatToType ∷ TyPat → Type Int+tyPatToType tp0 = evalState (loop tp0) [0..]+  where+  loop (TpVar _)      = fvTy <$> next+  loop (TpRow _)      = tyBinOp tcRowMap (tyNulOp tcRowHole) . fvTy <$> next+  loop (TpApp tc tps) = TyApp tc <$> mapM loop tps+  next = do+    i:rest ← get+    put rest+    return i++-- | Find out the variances, qualifier-involvement, guardedness and+--   'QLit' bounds of the type variables in a type pattern.+tyPatKinds ∷ TyPat → [(Variance, Bool, Bool, QLit)]+tyPatKinds = loop 1 True False Qa where+  loop !variance !involved !guarded !bound tp0 = case tp0 of+    TpVar _      → [(variance, involved, guarded, bound)]+    TpRow _      → [(variance, involved, guarded, bound)]+    TpApp tc tps →+      concat+        [ loop (vi * variance)+               (involved && S.member i ftv_qe)+               (guarded || gi)+               (if bound == Qu && involved+                  then Qu+                  else bi)+               tpi+        | i        ← [ 0 .. ]+        | vi       ← tcArity tc+        | gi       ← tcGuards tc+        | bi       ← tcBounds tc+        | tpi      ← tps ]+      where ftv_qe = ftvSet (tcQual tc)+
+ src/Type/ArrowAnnotations.hs view
@@ -0,0 +1,143 @@+-- | Rules for interpreting arrow qualifier annotations.+module Type.ArrowAnnotations (+  -- * Between internal and external qualifier expressions+  qInterpret, qRepresent,+  -- * Arrow annotation rules+  ImpArrRule(..), CurrentImpArrRule, CurrentImpArrPrintingRule,+) where++import Util+import Meta.Quasi+import qualified AST+import Type.Internal++import Prelude ()+import qualified Data.Set as S++type R = AST.Renamed++-- | The rule for parsing arrows+#ifdef ANNOTATION_RULE+type CurrentImpArrRule = ANNOTATION_RULE+#else+type CurrentImpArrRule = Rule3+#endif++-- | The rule for printing arrows+#ifdef ANNOTATION_PRINTING_RULE+type CurrentImpArrPrintingRule = ANNOTATION_PRINTING_RULE+#else+type CurrentImpArrPrintingRule = CurrentImpArrRule+#endif++-- | Interpret an explicit external qualifier as an internal one+qInterpret ∷ (Ord tv, Monad m) ⇒+             (AST.TyVar R → m tv) →+             AST.QExp R → m (QExp tv)+qInterpret resolve = loop where+  loop [qeQ| $qlit:ql |]    = return (qlitexp ql)+  loop [qeQ| `$tv |]        = qvarexp `liftM` resolve tv+  loop [qeQ| $qe1 ⋁ $qe2 |] = (⊔) `liftM` loop qe1 `ap` loop qe2+  loop [qeQ| $anti:a |]     = $(AST.antifail)++-- | Represent an internal qualifier as an explicit external one+qRepresent ∷ (tv → AST.TyVar R) →+             QExp tv → AST.QExp R+qRepresent _      QeA       = [qeQ|+! A |]+qRepresent rename (QeU tvs)+  | S.null tvs              = [qeQ|+! U |]+  | otherwise               =+      foldr1 AST.qeJoin (AST.qeVar . rename <$> S.toList tvs)++-- | Interface to rules for implicit annotation of arrows+class ImpArrRule rule where+  -- | The initial labeling state+  iaeInit      ∷ rule tv+  -- | Update the state to the left of an arrow+  iaeLeft      ∷ rule tv → rule tv+  -- | Update the state to the right of an arrow with the given+  --   qualifier+  iaeRight     ∷ Ord tv ⇒ rule tv → QExpV tv → Type tv → rule tv+  -- | The implied qualifier at a particular point+  iaeImplied   ∷ rule tv → QExpV tv+  -- | Interpret the given implicit qualifier into an explicit qualifier+  --   at the given point+  iaeInterpret ∷ (Ord tv, Monad m) ⇒+                 (AST.TyVar R → m (TyVar tv)) →+                 rule tv → Maybe (AST.QExp R) → m (QExpV tv)+  -- | Represent the given explicit qualifier as an implicit one+  iaeRepresent ∷ Eq tv ⇒+                 (TyVar tv → AST.TyVar R) →+                 rule tv → QExpV tv → Maybe (AST.QExp R)+  -- | Update the state under the given variance+  iaeUnder     ∷ rule tv → Variance → rule tv+  --+  iaeLeft _           = iaeInit+  iaeRight iae _ _    = iae+  iaeImplied _        = minBound+  iaeInterpret resolve iae+                      = maybe (return (iaeImplied iae)) (qInterpret resolve)+  iaeRepresent rename iae actual+    | actual == iaeImplied iae = Nothing+    | otherwise                = Just (qRepresent rename actual)+  iaeUnder _ _        = iaeInit++-- | Print all arrow annotations explicitly+data Rule0 tv = Rule0++instance ImpArrRule Rule0 where+  iaeInit                       = Rule0+  iaeRepresent rename _ actual  = Just (qRepresent rename actual)++-- | Annotation ‘U’ is implicit for unlabeled arrows.+data Rule1 tv = Rule1++instance ImpArrRule Rule1 where+  iaeInit        = Rule1++newtype Rule2 tv = Rule2 { unRule2 ∷ QExpV tv }++-- | Implicit annotation is lub of qualifiers of prior curried+--   arguments.  Explicit annotations have no effect on subsequent+--   arrows.+instance ImpArrRule Rule2 where+  iaeInit          = Rule2 minBound+  iaeRight iae _ t = Rule2 (unRule2 iae ⊔ qualifier t)+  iaeImplied       = unRule2++-- | Like 'Rule2', but explicit annotations reset the qualifier to+--   themselves for subsequent arrows.+newtype Rule3 tv = Rule3 { unRule3 ∷ QExpV tv }++instance ImpArrRule Rule3 where+  iaeInit             = Rule3 minBound+  iaeRight _ actual t = Rule3 (actual ⊔ qualifier t)+  iaeImplied          = unRule3++-- | Like 'Rule3', but we arrow the implicit qualifer into covariant+--   type constructors.+newtype Rule4 tv = Rule4 { unRule4 ∷ QExpV tv }++instance ImpArrRule Rule4 where+  iaeInit                = Rule4 minBound+  iaeRight _ actual t    = Rule4 (actual ⊔ qualifier t)+  iaeImplied             = unRule4+  iaeUnder iae Covariant = iae+  iaeUnder _   _         = iaeInit++-- | Like 'Rule4', but we carry the implicit quantifier into ALL type+--   constructors and only use it when we arrive at an arrow in a+--   positive position wrt the surrounding arrow.+data Rule5 tv+  = Rule5 {+      unRule5 ∷ !(QExpV tv),+      r4Var   ∷ !Variance+    }++instance ImpArrRule Rule5 where+  iaeInit      = Rule5 minBound 1+  iaeRight _ actual t = Rule5 (actual ⊔ qualifier t) 1+  iaeImplied iae+    | r4Var iae == 1 = unRule5 iae+    | otherwise      = minBound+  iaeUnder iae var          = Rule5 (unRule5 iae) (var * r4Var iae)
+ src/Type/Internal.hs view
@@ -0,0 +1,847 @@+{-# LANGUAGE TypeFamilies #-}+-- | The internal representation of types, created by the type checker+--   from the syntactic types in 'AST.Type'.+module Type.Internal (+  -- * Data definitions+  -- ** Types+  Quant(..), TyVar(..), Type(..), TyCon(..),+  -- ** Qualifiers+  QLit(..), QExp(..), QExpV,+  -- ** Type patterns+  TyPat(..),+  -- ** Kind re-exports+  Variance(..), Lattice(..), BoundedLattice(..), isQVariance,+  -- ** Names+  Name, TypId, QTypId, ConId, QConId, RowLabel, RecLabel,++  -- * Qualifiers+  Qualifier(..), qlitexp, qvarexp, extractQual, liftVQExp, mapQExp,++  -- * Type constructors+  abstractTyCon, mkTC,+  -- ** Built-in+  tcUnit, tcInt, tcChar, tcFloat, tcString, tcExn, tcTuple, tcFun,+  tcUn, tcAf, tcJoin, tcRowEnd, tcRecord, tcVariant, tcRowMap,+  tcRowDots, tcRowHole,+  -- ** Convenient constructors and projections+  fvTy, bvTy, fromFreeTV,+  -- ** Pre-constructed types+  tyNulOp, tyUnOp, tyBinOp,+  tyFun, tyArr, tyLol, tyTuple, tyQLit,+  tyAf, tyUn, tyUnit, tyInt, tyChar, tyFloat, tyString, tyExn,+  tyRecord, tyRowEnd, tyRowMap, tyRowHole,+  (.->.), (.-*.), (.*.),+  -- *** For testing+  tcCycle, tcConst, tcIdent, tcConsTup, tcOption, tcIdfun,+  tcSessOne, tcSessSend, tcSessRecv, tcSessSemi, tcSessDual,++  -- * Standard forms+  standardizeType, standardizeQuals,++  -- * Unfolds and folds+  -- ** Type folding+  foldType, foldTypeM, foldTypeEnv, mkBvF, mkQuF, mkMuF,+  -- ** Unfolds+  unfoldQu, unfoldRow, unfoldMu,+  -- ** Row operations+  foldRow, sortRow,++  -- * Locally nameless+  openTy, openTyN, closeTy, lcTy, lcTyK,+  closeRec, closeQuant,++  -- * Varieties+  TyConVariety(..), varietyOf,++  module Data.Empty,+) where++import Util+import Util.MonadRef+import Data.Empty+import Data.Lattice+import Error+import qualified Env+import qualified AST+import AST ( QLit(..), Variance(..), isQVariance )++import Prelude ()+import Control.Monad.ST+import Data.Generics (Typeable, Data)+import Data.STRef (STRef)+import qualified Data.List as List+import qualified Data.Map  as M+import qualified Data.Set  as S++---+--- DATA TYPES+---++-- | Everything should be renamed by now+type R        = AST.Renamed+type TypId    = AST.TypId R+type QTypId   = AST.QTypId R+type ConId    = AST.ConId R+type QConId   = AST.QConId R+type RowLabel = AST.Uid R+type RecLabel = AST.Lid R++-- | Optional names that don't affect α equivalence+type Name = Perhaps String++-- | Locally-nameless–style type variable occurrences in internal types+data TyVar tv+  -- | A free type variable+  = Free !tv+  -- | A bound type variable+  | Bound !Int !Int !Name+  deriving (Eq, Ord, Functor, Typeable, Data)++-- | Quantifiers+data Quant+  -- | Universal quantifier+  = Forall+  -- | Existential quantifier+  | Exists+  deriving (Eq, Ord, Typeable, Data)++-- | The internal representation of a type+data Type tv+  -- | A free type variable+  = TyVar !(TyVar tv)+  -- | A quantified (all or ex) type+  | TyQu  !Quant ![(Name, QLit)] !(Type tv)+  -- | A recursive (mu) type+  | TyMu  !Name !(Type tv)+  -- | A row type+  | TyRow !RowLabel !(Type tv) !(Type tv)+  -- | The application of a type constructor (possibly nullary).+  | TyApp !TyCon ![Type tv]+  deriving (Functor, Typeable, Data)++-- | Internal qualifier expressions+data QExp tv+  -- | The type qualifier expression+  = QeA+  -- | The join of a set of type variables+  | QeU !(S.Set tv)+  deriving (Eq, Typeable, Data)++-- | Qualifier expressions containing bound variables+type QExpV tv = QExp (TyVar tv)++-- | Information about a type constructor+data TyCon+  = TyCon {+      -- | Unique ID+      tcId        ∷ !Int,+      -- | Printable name+      tcName      ∷ !QTypId,+      -- | Variances for parameters, and correct length+      tcArity     ∷ ![Variance],+      -- | Bounds for parameters+      tcBounds    ∷ ![QLit],+      -- | Guards recursive types+      tcGuards    ∷ ![Bool],+      -- | Qualifier as a function of parameters+      tcQual      ∷ !(QExp Int),+      -- | For pattern-matchable types, the data constructors,+      -- where type parameters are bound at level 0+      tcCons      ∷ !(Env.Env ConId (Maybe (Type Empty))),+      -- | For type operators, the next head reduction+      tcNext      ∷ !(Maybe [([TyPat], Type Empty)])+    }+  deriving (Typeable, Data)++-- | A type pattern, for defining type operators+data TyPat+  -- | A type variable, matching any type and binding+  = TpVar !Name+  -- | A type application node, matching the given constructor+  --   and its parameters+  | TpApp !TyCon ![TyPat]+  -- | A row type pattern+  | TpRow !Name+  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')++---+--- Abstracting type constructors+---++-- | Remove the representation from a type constructor+abstractTyCon ∷ TyCon → TyCon+abstractTyCon tc = tc { tcCons = mempty, tcNext = Nothing }++---+--- Built-in types+---++class ExtTC r where+  extTC ∷ TyCon → r++instance ExtTC TyCon where+  extTC = id++instance ExtTC r ⇒ ExtTC (QTypId → r) where+  extTC tc x = extTC (tc { tcName = x })++instance (v ~ Variance, ql ~ QLit, ExtTC r) ⇒+         ExtTC ([(v, ql, Bool)] → r) where+  extTC tc x = extTC tc {+                 tcArity  = sel1 <$> x,+                 tcBounds = sel2 <$> x,+                 tcGuards = sel3 <$> x+               }++instance (tv ~ Int, ExtTC r) ⇒ ExtTC (QExp tv → r) where+  extTC tc x = extTC (tc { tcQual = x })++instance (a ~ Type Empty, ExtTC r) ⇒+         ExtTC (Env.Env ConId (Maybe a) → r) where+  extTC tc x = extTC (tc { tcCons = x })++instance (t ~ Type Empty, ExtTC r) ⇒+         ExtTC ([([TyPat], t)] → r) where+  extTC tc x = extTC (tc { tcNext = Just x })++mkTC ∷ ExtTC r ⇒ Int → AST.QTypId R → r+mkTC i ql+  = extTC TyCon {+    tcId        = i,+    tcName      = ql,+    tcArity     = [],+    tcBounds    = [],+    tcGuards    = [],+    tcQual      = minBound,+    tcCons      = Env.empty,+    tcNext      = Nothing+  }++internalTC ∷ ExtTC r ⇒ Int → String → r+internalTC i s = mkTC i (AST.J [] (AST.identT (AST.Ren_ i) s))++tcUnit, tcInt, tcChar, tcFloat, tcString,+  tcExn, tcUn, tcAf, tcJoin, tcTuple, tcFun,+  tcRowEnd, tcRecord, tcVariant, tcRowMap, tcRowDots, tcRowHole ∷ TyCon++tcFun        = internalTC (-1) "->"     (qvarexp 1)+                                        [(Contravariant, Qa, False),+                                         (QCovariant,    Qa, False),+                                         (Covariant,     Qa, False)]+tcUnit       = internalTC (-2) "unit"+                 (Env.fromList [(AST.ident "()" ∷ ConId, Nothing)])+tcInt        = internalTC (-3) "int"+tcChar       = internalTC (-4) "char"+tcFloat      = internalTC (-5) "float"+tcString     = internalTC (-6) "string"+tcExn        = internalTC (-7) "exn"    QeA+tcUn         = internalTC (-8) "U"+tcAf         = internalTC (-9) "A"      QeA+tcJoin       = internalTC (-10) "\\/"   (qvarexp 0 ⊔ qvarexp 1)+                                        [(Covariant,     Qa, False),+                                         (Covariant,     Qa, False)]+tcTuple      = internalTC (-11) "*"     (qvarexp 0 ⊔ qvarexp 1)+                                        [(Covariant,     Qa, False),+                                         (Covariant,     Qa, False)]+tcRowEnd     = internalTC (-12) "rowend"+tcVariant    = internalTC (-13) "variant" (qvarexp 0)+                                          [(Covariant, Qa, False)]+tcRecord     = internalTC (-14) "record"  (qvarexp 1)+                                          [(QCovariant, Qa, False),+                                           (Covariant, Qa, False)]+tcRowMap     = internalTC (-15) "rowmap#"  (qvarexp 0 ⊔ qvarexp 1)+                                           [(Covariant, Qa, False),+                                           (Invariant, Qa, False)]+tcRowDots    = internalTC (-16) "rowdots#" (qvarexp 0)+                                           [(Covariant, Qa, True)]+tcRowHole    = internalTC (-17) "rowhole#" (qvarexp 0)+                                           [(Covariant, Qa, True)]++-- Types for testing++tcCycle, tcConst, tcIdent, tcConsTup, tcOption, tcIdfun ∷ TyCon+tcCycle      = internalTC (-51) "cycle" [(Invariant,     Qa, True)]+tcConst      = internalTC (-52) "const" [(Omnivariant, Qa, False)]+                 [([TpVar Nope], tyUnit)]+tcIdent      = internalTC (-53) "ident" (qvarexp 0)+                                        [(Covariant, Qa, False)]+                 [([TpVar Nope], TyVar (Bound 0 0 Nope))]+tcConsTup    = internalTC (-54) "cons"  (qvarexp 0 ⊔ qvarexp 1)+                                        [(Covariant, Qa, False),+                                         (Covariant, Qa, False)]+                 [([TpVar Nope, TpApp tcTuple [TpVar Nope, TpVar Nope]],+                   TyApp tcTuple [TyApp tcConsTup [TyVar (Bound 0 0 Nope),+                                                   TyVar (Bound 0 1 Nope)],+                                  TyVar (Bound 0 2 Nope)]),+                  ([TpVar Nope, TpVar Nope],+                   TyApp tcTuple [TyVar (Bound 0 0 Nope),+                                  TyVar (Bound 0 1 Nope)])]+tcOption     = internalTC (-55) "option" (qvarexp 0)+                                         [(Covariant, Qa, False)]+                 (Env.fromList [(AST.ident "None" ∷ ConId, Nothing),+                                (AST.ident "Some", Just (bvTy 0 0 Nope))])+tcIdfun      = internalTC (-55) "idfun" [(Invariant, Qa, False)]+                 (Env.fromList [(AST.ident "Mono" ∷ ConId,+                                 Just (bvTy 0 0 Nope .->. bvTy 0 0 Nope)),+                                (AST.ident "Poly",+                                 Just (TyQu Forall [(Nope, Qa)]+                                        (bvTy 0 0 Nope .->. bvTy 0 0 Nope)))])++tcSessOne, tcSessSend, tcSessRecv, tcSessSemi, tcSessDual ∷ TyCon+tcSessOne        = internalTC (-56) "1"+tcSessSend       = internalTC (-57) "!" [(-1, Qa, False)]+tcSessRecv       = internalTC (-58) "?" [(1, Qa, False)]+tcSessSemi       = internalTC (-59) ";" [(1, Qu, False), (1, Qu, True)]+tcSessDual       = internalTC (-60) "dual" [(-1, Qu, False)]+     [([TpApp tcSessOne []],+       TyApp tcSessOne []),+      ([TpApp tcSessSemi [TpApp tcSessSend [TpVar Nope], TpVar Nope]],+       TyApp tcSessSemi [TyApp tcSessRecv [TyVar (Bound 0 0 Nope)],+                         TyApp tcSessDual [TyVar (Bound 0 1 Nope)]]),+      ([TpApp tcSessSemi [TpApp tcSessRecv [TpVar Nope], TpVar Nope]],+       TyApp tcSessSemi [TyApp tcSessSend [TyVar (Bound 0 0 Nope)],+                         TyApp tcSessDual [TyVar (Bound 0 1 Nope)]])]++---+--- Convenience constructors+---++-- | Make a free type variable into a type+fvTy ∷ tv → Type tv+fvTy = TyVar . Free++-- | Make a bound type variable type+bvTy ∷ Optional f ⇒ Int → Int → f String → Type tv+bvTy i j n = TyVar (Bound i j (foldOpt Nope Here n))++-- | Project a free type variable from a 'TyVar'+fromFreeTV ∷ TyVar tv → tv+fromFreeTV (Free r)     = r+fromFreeTV _            = throw $+  almsBug StaticsPhase "fromFreeTV" "Got bound type variable"++-- | Make a type from a nullary type constructor+tyNulOp ∷ TyCon → Type tv+tyNulOp tc = TyApp tc []++-- | Make a type from a unary type constructor+tyUnOp ∷ TyCon → Type tv → Type tv+tyUnOp tc t1 = TyApp tc [t1]++-- | Make a type from a binary type constructor+tyBinOp ∷ TyCon → Type tv → Type tv → Type tv+tyBinOp tc t1 t2 = TyApp tc [t1, t2]++-- | A function type+tyFun ∷ Qualifier qe tv ⇒ Type tv → qe → Type tv → Type tv+tyFun t1 qe t2 = TyApp tcFun [t1, qualToType qe, t2]++-- | Constructor for unlimited arrow types+tyArr ∷ Type tv → Type tv → Type tv+tyArr = tyFun <-> Qu++-- | Constructor for affine arrow types+tyLol ∷ Type tv → Type tv → Type tv+tyLol = tyFun <-> Qa++-- | Type from a 'QLit'+tyQLit ∷ QLit → Type tv+tyQLit Qa = tyAf+tyQLit Qu = tyUn++-- | Binary types+tyTuple, tyRowMap, tyRecord ∷ Type tv → Type tv → Type tv++tyTuple  = tyBinOp tcTuple+tyRowMap = tyBinOp tcRowMap+tyRecord = tyBinOp tcRecord++-- | Nullary types+tyAf, tyUn, tyUnit, tyInt, tyChar, tyFloat, tyString, tyExn,+  tyRowEnd, tyRowHole ∷ Type tv++tyAf     = tyNulOp tcAf+tyUn     = tyNulOp tcUn+tyUnit   = tyNulOp tcUnit+tyInt    = tyNulOp tcInt+tyChar   = tyNulOp tcChar+tyFloat  = tyNulOp tcFloat+tyString = tyNulOp tcString+tyExn    = tyNulOp tcExn+tyRowEnd = tyNulOp tcRowEnd+tyRowHole= tyNulOp tcRowHole++(.*.), (.->.), (.-*.) ∷ Type tv → Type tv → Type tv+(.*.)    = tyTuple+(.->.)   = tyArr+(.-*.)   = tyLol++infixr 6 .->., .-*., `tyArr`, `tyLol`+infixl 7 .*., `tyTuple`++---+--- Qualifiers+---++instance Ord tv ⇒ Lattice (QExp tv) where+  QeA     ⊔ _        = QeA+  _       ⊔ QeA      = QeA+  QeU tvs ⊔ QeU tvs' = QeU (tvs `S.union` tvs')+  --+  QeA     ⊓ qe'      = qe'+  qe      ⊓ QeA      = qe+  QeU tvs ⊓ QeU tvs' = QeU (tvs `S.intersection` tvs')+  --+  _       ⊑ QeA      = True+  QeA     ⊑ _        = False+  QeU tvs ⊑ QeU tvs' = tvs `S.isSubsetOf` tvs'++instance Bounded (QExp tv) where+  minBound = QeU S.empty+  maxBound = QeA++class Qualifier q tv | q → tv where+  qualToType     ∷ q → Type tv+  qualifierEnv   ∷ Ord tv ⇒ [[QLit]] → q → QExpV tv+  qualifier      ∷ Ord tv ⇒ q → QExpV tv+  qualifierEnv   = const qualifier+  qualifier      = qualifierEnv []++instance Qualifier q tv ⇒ Qualifier (Maybe q) tv where+  qualToType   = maybe tyUn qualToType+  qualifierEnv = maybe minBound . qualifierEnv++instance (Ord tv, Qualifier q tv) ⇒ Qualifier [q] tv where+  qualToType   = qualToType . qualifier+  qualifierEnv = bigJoin <$$> map . qualifierEnv++instance Qualifier QLit tv where+  qualToType Qa     = tyAf+  qualToType Qu     = tyUn+  qualifier Qa      = QeA+  qualifier Qu      = QeU S.empty++instance Qualifier AST.Occurrence tv where+  qualToType = qualToType . AST.occToQLit+  qualifier  = qualifier . AST.occToQLit++instance Ord tv ⇒ Qualifier (Type tv) tv where+  qualToType        = qualToType . qualifier+  qualifierEnv env0 = foldTypeEnv (Left <$$> env0)+                                  fquant fbvar ffvar fcon frow frec+    where+    fquant ∷ Quant → [(Name, QLit)] →+             ([Either QLit QLit] → (QExpV tv → QExpV tv) → a) → a+    frec   ∷ Name → (Either QLit QLit → (QExpV tv → QExpV tv) → a) → a+    fquant Forall αs k     = k (Right Qu <$ αs) bumpQExp+    fquant Exists αs k     = k (Right . snd <$> αs) bumpQExp+    fbvar _ _    (Just (Right ql)) = qlitexp ql+    fbvar _ _    (Just (Left Qu))  = qlitexp Qu+    fbvar (i,j) n _                = qvarexp (Bound i j n)+    ffvar                  = qvarexp . Free+    fcon tc qes            = extractQual (tcQual tc) qes+    frow _ qe1 qe2         = qe1 ⊔ qe2+    frec _ k               = k (Right Qu) bumpQExp+    --+    bumpQExp QeA           = QeA+    bumpQExp (QeU tvs)     = QeU (S.map (bumpVar (-1)) tvs)+    bumpVar _ (Free r)     = Free r+    bumpVar k (Bound i j n)= Bound (i + k) j n++instance Qualifier (QExpV tv) tv where+  qualToType QeA       = TyApp tcAf []+  qualToType (QeU tvs)+    | S.null tvs       = TyApp tcUn []+    | otherwise        = foldr1 (\t1 t2 → TyApp tcJoin [t1, t2])+                                (TyVar <$> S.toList tvs)+  qualifier = id++instance Qualifier (S.Set tv) tv where+  qualifier αs   = QeU (S.mapMonotonic Free αs)+  qualToType αs  = qualToType (QeU (S.mapMonotonic Free αs))++-- | Make a qualifier expression from a single literal+qlitexp ∷ QLit → QExp tv+qlitexp Qa = QeA+qlitexp Qu = QeU S.empty++-- | Make a qualifier expression from a single type variable+qvarexp ∷ tv → QExp tv+qvarexp = QeU . S.singleton++-- | Build a qualifier from a list of qualifiers using an+--   integer-numbered qualifier.+extractQual ∷ Ord tv ⇒ QExp Int → [QExp tv] → QExp tv+extractQual QeA      _   = QeA+extractQual (QeU zs) qes = bigJoin (fst <$> filter ((`elem` zs) . snd)+                                                   (zip qes [0 ..]))++-- | Lift a free-variable q-expression to a 'QExpV'+liftVQExp ∷ QExp tv → QExpV tv+liftVQExp QeA           = QeA+liftVQExp (QeU αs)      = QeU (S.mapMonotonic Free αs)++-- | Modify the set of a 'QeU' 'QExp"+mapQExp ∷ (S.Set tv → S.Set tv') → QExp tv → QExp tv'+mapQExp _ QeA      = QeA+mapQExp f (QeU αs) = QeU (f αs)++---+--- Folds and unfolds+---++foldTypeEnv+         ∷ Ord tv ⇒+           -- | Initial environment+           [[s]] →+           -- | For quantifiers+           (∀a. Quant → [(Name, QLit)] → ([s] → (r → r) → a) → a) →+           -- | For bound variables+           ((Int, Int) → Name → Maybe s → r) →+           -- | For free variables+           (tv → r) →+           -- | For constructor applications+           (TyCon → [r] → r) →+           -- | For row type labels+           (RowLabel → r → r → r) →+           -- | For recursive types+           (∀a. Name → (s → (r → r) → a) → a) →+           -- | Type to fold+           Type tv →+           r+foldTypeEnv env0 fquant fbvar ffvar fcon frow frec σ0 =+  runReader (loop σ0) env0+  where+  loop (TyQu q αs σ)            =+    fquant q αs $ \ss f → f `liftM` local (ss:) (loop σ)+  loop (TyVar (Bound i j n))    = do+    env ← ask+    return (fbvar (i, j) n (look i j env))+  loop (TyVar (Free v))         = return (ffvar v)+  loop (TyApp tc ts)            =+    fcon tc <$> sequence+      [ if isQVariance v+          then loop (qualToType t)+          else loop t+      | t ← ts+      | v ← tcArity tc ]+  loop (TyRow n t1 t2)          =+    frow n `liftM` loop t1 `ap` loop t2+  loop (TyMu n t)               =+    frec n (\s f → f `liftM` local ([s]:) (loop t))+  --+  look i j env+    | rib:_ ← drop i env+    , elt:_ ← drop j rib = Just elt+  look _ _ _             = Nothing++foldType ∷ Ord tv ⇒+           -- | For quantifiers+           (∀a. Quant → [(Name, QLit)] → ([s] → (r → r) → a) → a) →+           -- | For bound variables+           ((Int, Int) → Name → Maybe s → r) →+           -- | For free variables+           (tv → r) →+           -- | For constructor applications+           (TyCon → [r] → r) →+           -- | For row type labels+           (RowLabel → r → r → r) →+           -- | For recursive types+           (∀a. Name → (s → (r → r) → a) → a) →+           -- | Type to fold+           Type tv →+           r+foldType = foldTypeEnv []++-- | Helper for constructing bound variable case for 'foldType'+mkBvF   ∷ (Int → Int → Name → r) →+          (Int, Int) → Name → a → r+mkBvF f (i, j) pn _ = f i j pn++-- | Helper for constructing quantifier case for 'foldType'+mkQuF+  ∷ (Quant → [(Name, QLit)] → r → s) →+    (∀a. Quant → [(Name, QLit)] → ([(Int, Int)] → (r → s) → a) → a)+mkQuF f q αs k = k [ (0, j) | j ← [0 .. length αs - 1] ] (f q αs)++-- | Helper for constructing recursive case for 'foldType'+mkMuF ∷ (Name → r → s) →+        (∀a. Name → ((Int, Int) → (r → s) → a) → a)+mkMuF f pn k = k (0, 0) (f pn)++foldTypeM ∷ (Monad m, Ord tv) ⇒+            -- | For quantifiers+            (∀a. Quant → [(Name, QLit)] → ([s] → (r → m r) → a) → a) →+            -- | For bound variables+            ((Int, Int) → Name → Maybe s → m r) →+            -- | For free variables+            (tv → m r) →+            -- | For constructor applications+            (TyCon → [r] → m r) →+            -- | For row type labels+            (RowLabel → r → r → m r) →+            -- | For recursive types+            (∀a. Name → (s → (r → m r) → a) → a) →+            -- | Type to fold+            Type tv →+            m r+foldTypeM fquant fbvar ffvar fapp frow frec =+  foldType (\qu ns k → fquant qu ns (\s k' → k s (>>= k')))+           fbvar+           ffvar+           (\tc mrs → sequence mrs >>= fapp tc)+           (\lab mr1 mr2 → mr1 >>= \r1 → mr2 >>= frow lab r1)+           (\n k → frec n (\s k' → k s (>>= k')))++--+-- Other unfolds+--++-- To strip off as many of the specified quantifier as possible,+-- building a qualifier bound environment for the layers.+unfoldQu ∷ Quant → Type tv → ([[QLit]], Type tv)+unfoldQu u0 = first reverse . loop where+  loop (TyQu u tvs t)+    | u0 == u || lcTyK 0 t = first (map snd tvs:) (loop t)+  loop t                   = ([], t)++-- To find the labels and fields of a row type, and the extension,+-- in standard order+unfoldRow ∷ Type tv → ([(RowLabel, Type tv)], Type tv)+unfoldRow = first (List.sortBy (compare <$> fst <$.> fst)) . loop where+  loop (TyRow n t1 t2) = first ((n, t1):) (loop t2)+  loop t               = ([], t)++-- Unfold leading μ (recursive type) binders.+unfoldMu ∷ Type tv → ([Name], Type tv)+unfoldMu (TyMu pn t) = first (pn:) (unfoldMu t)+unfoldMu t           = ([], t)++---+--- Row operations+---++-- Construct a row from a list of label/type pairs and a tail type.+foldRow ∷ [(RowLabel, Type a)] → Type a → Type a+foldRow = flip (foldr (uncurry TyRow))++-- Sort a row by its labels+sortRow ∷ Type a → Type a+sortRow = uncurry foldRow . unfoldRow++---+--- Type standardization+---++-- | @standardize@ puts a type in standard form.+--   A type is in standard form if three conditions are met:+--    +--   * All bound type variables actually appear in their scope.  That+--     is, ‘∀ α β γ. α → γ’ is not standard, but ‘∀ α γ. α → γ’ is.+--+--   * The same quantifier never nests directly inside itself.  That is,+--     ‘∀ α β. ∀ γ. C α β γ’ is not standard, but ‘∀ α β γ. C α β γ’ is.+--+--   * The bound type variables of each quantifier are listed in the+--     order that they appear in its scope.  That is,+--     ‘∀ α β γ. C α γ β’ is not standard, but ‘∀ α β γ. C α β γ’ is.+--+--   * Type variables bound by μ appear in their scope, and there are+--     never multiple, immediately nested μs.+--+--  Type standardization is necessary as a post-pass after parsing,+--  because it's difficult to parse into standard form directly.+standardizeType  ∷ Ord tv ⇒ Type tv → Type tv+standardizeType  = standardizeQuals M.empty++-- | Used in the definition of 'standardizeQuals' below.+type StdizeEnv s = [[(Int, STRef s [((Int, Int), (Name, QLit))], Bool, QLit)]]++-- | Standardize a type while cleaning up qualifiers.+standardizeQuals ∷ ∀tv. Ord tv ⇒ M.Map tv QLit → Type tv → Type tv+standardizeQuals qm t00 = runST (loop 0 [] t00) where+  loop ∷ ∀s. Int → StdizeEnv s → Type tv → ST s (Type tv)+  loop depth g t0 = case t0 of+    TyQu u _ _ → do+      rn ← newRef []+      let (qls, t) = unfoldQu u t0+          i        = length qls+          g'       = (depth + i, rn, False,) <$$> qls+      t' ← loop (depth + i) (g' ++ g) t+      nl ← readRef rn+      return $ case nl of+        [] → openTyN i (-1) [] t'+        _  → TyQu u [ n | (_,n) ← nl ] (openTyN (i - 1) (i - 1) [] t')+    TyApp tc ts          → TyApp tc <$> sequence+      [ if isQVariance v+          then doQual depth g t+          else loop depth g t+      | t ← ts+      | v ← tcArity tc ]+    TyVar v               → TyVar . fst <$> doVar depth g (const True) v+    TyRow _ _ _           → do+      let (row, ext) = unfoldRow t0+      row' ← sequence+        [ (ni,) <$> loop depth g ti+        | (ni, ti) ← row ]+      ext' ← loop depth g ext+      return (foldRow row' ext')+    TyMu pn _            → do+      rn ← newRef []+      let (pns, t) = unfoldMu t0+          i        = length pns+          g'       = (depth + i, rn, True,) <$$> replicate i [Qa]+      t' ← loop (depth + i) (g' ++ g) t+      nl ← readRef rn+      return $+        if null nl+          then openTyN i (-1) [] t'+          else TyMu pn (openTyN (i - 1) (i - 1) [] t')+  --+  doVar ∷ ∀s. Int → StdizeEnv s →+              (QLit → Bool) → TyVar tv → ST s (TyVar tv, Bool)+  doVar depth g keep v0 = case v0 of+    Bound i j n+      | rib:_                    ← drop i g+      , (olddepth, r, rec, ql):_ ← drop j rib+                          → do+        s  ← readRef r+        if rec+          then do+            case List.findIndex ((== (depth - i)) . fst . fst) s of+              Just _  → return ()+              Nothing → writeRef r (s ++ [((depth - i, 0), (n, ql))])+            return (Bound (depth - olddepth) 0 n, True)+          else do+            j' ← case List.findIndex ((== (depth - i, j)) . fst) s of+              Just j' → return j'+              Nothing → do+                when (keep ql) $+                  writeRef r (s ++ [((depth - i, j), (n, ql))])+                return (length s)+            return (Bound (depth - olddepth) j' n, keep ql)+      | otherwise   → return (v0, True)+    Free r       → return (Free r,+                              keep (M.findWithDefault maxBound r qm))+  --+  doQual ∷ ∀s. Ord tv ⇒ Int → StdizeEnv s → Type tv → ST s (Type tv)+  doQual depth g t =+    qualToType <$> case qualifier t of+      QeA     → return QeA+      QeU tvs → do+        tvbs' ← mapM (doVar depth g (== Qa)) (S.toList tvs)+        return (QeU (S.fromList (fst <$> filter snd tvbs')))++---+--- Locally-nameless operations+---++-- | @openTy k τs τ@ substitutes @τs@ for the bound type variables at+--   rib level @k@.  DeBruijn indices higher than @k@ are adjusted downward,+--   since opening a type peels off a quantifier.+openTy ∷ Int → [Type a] → Type a → Type a+openTy  = openTyN 1++-- | Generalization of 'openTy': the first argument specifies how much+--   to adjust indices that exceed @k@.+openTyN ∷ Int → Int → [Type a] → Type a → Type a+openTyN n k vs σ0 = case σ0 of+  TyQu u e σ       → TyQu u e (next σ)+  TyVar v          → openTV_N n k vs v+  TyApp name σs    → TyApp name (map this σs)+  TyRow name σ1 σ2 → TyRow name (this σ1) (this σ2)+  TyMu name σ      → TyMu name (next σ)+  where+    this = openTyN n k vs+    next = openTyN n (k + 1) vs++openTV_N ∷ Int → Int → [Type a] → TyVar a → Type a+openTV_N n k vs (Bound i j name)+  | i > k      = TyVar (Bound (i - n) j name)+  | i == k, Just σ ← listNth j vs+              = σ+  | otherwise = TyVar (Bound i j name)+openTV_N _ _ _  (Free v) = TyVar (Free v)++-- | @closeTy k αs τ@ finds the free variables @αs@ and replaces them+--   with bound variables at rib level @k@.  The position of each type+--   variable in @αs@ gives the index of each bound variable into the+--   new rib.+closeTy ∷ Eq a ⇒ Int → [a] → Type a → Type a+closeTy k vs σ0 = case σ0 of+  TyQu u e σ   → TyQu u e (next σ)+  TyVar (Bound i j n)+    | i >= k    → TyVar (Bound (i + 1) j n)+    | otherwise → TyVar (Bound i j n)+  TyVar (Free v)+    | Just j ← List.findIndex (== v) vs+                → TyVar (Bound k j Nope)+    | otherwise → TyVar (Free v)+  TyApp n σs    → TyApp n (map this σs)+  TyRow n σ1 σ2 → TyRow n (this σ1) (this σ2)+  TyMu n σ     → TyMu n (next σ)+  where+    this = closeTy k vs+    next = closeTy (k + 1) vs++-- | Build a recursive type by closing and binding the given variable+closeRec ∷ Ord tv ⇒ tv → Type tv → Type tv+closeRec α σ = standardizeType (TyMu Nope (closeTy 0 [α] σ))++-- | Add the given quantifier while binding the given list of variables+closeQuant ∷ Ord tv ⇒ Quant → [(tv, QLit)] → Type tv → Type tv+closeQuant qu αqs ρ = standardizeType (TyQu qu nqs (closeTy 0 αs ρ))+  where+    αs  = fst <$> αqs+    nqs = zip (repeat Nope) (snd <$> αqs)++-- | Is the given type locally closed to level k?  A type is locally closed+--   if none of its bound variables point to quantifiers "outside" the+--   type.+--+--   ASSUMPTION: No bound variables are lurking behind an apparent free+--   variable, because @lcTy@ doesn't attempt to dereference free+--   variables.  This should be an invariant, because it would come+--   about only as a result of a capturing substitution.+lcTy ∷ Int → Type a → Bool+lcTy  = loop where+  loop k (TyQu _ _ t)          = loop (k + 1) t+  loop k (TyVar (Bound i _ _)) = k > i+  loop _ (TyVar (Free _))      = True+  loop k (TyApp _ ts)          = all (loop k) ts+  loop k (TyRow _ t1 t2)       = loop k t1 && loop k t2+  loop k (TyMu _ t)            = loop (k + 1) t++-- | Are there no bound vars of level k?+lcTyK ∷ Int → Type tv → Bool+lcTyK  = loop where+  loop k (TyQu _ _ t)            = loop (k + 1) t+  loop k (TyVar (Bound i _ _)) = k /= i+  loop _ (TyVar (Free _))      = True+  loop k (TyApp _ ts)             = all (loop k) ts+  loop k (TyRow _ t1 t2)          = loop k t1 && loop k t2+  loop k (TyMu _ t)              = loop (k + 1) t++---+--- TyCon Varieties+---++data TyConVariety+  = AbstractType+  | DataType+  | OperatorType+  deriving (Eq, Ord)++-- | Find out the variety of a type constructor+varietyOf ∷ TyCon → TyConVariety+varietyOf tc+  | isJust (tcNext tc)          = OperatorType+  | Env.isEmpty (tcCons tc)     = AbstractType+  | otherwise                   = DataType+
+ src/Type/Ppr.hs view
@@ -0,0 +1,108 @@+-- | Pretty printing of internal types+module Type.Ppr ( TyConInfo(..) ) where++import Util+import qualified AST+import Type.Internal+import Type.Syntax+import Type.TyVar+import Type.ArrowAnnotations+import Syntax.Ppr++import Prelude ()+import qualified Data.Set as S++instance Tv tv ⇒ Ppr (Type tv) where+  ppr τ = askTyNames $ \tn → ppr (typeToStx t2sContext0 { t2sTyNames = tn } τ)++instance Ppr TyPat where+  ppr tp = askTyNames $ \tn → ppr (fst (tyPatToStx tn [] Qa tp))++instance Ppr TyCon where+  ppr tc = askTyNames $ \tn → ppr (tyConToStx tn tc)++instance Tv tv ⇒ Ppr (QExp tv) where+  ppr QeA        = char 'A'+  ppr (QeU αset) = case S.toList αset of+    []  → char 'U'+    [α] → ppr α+    αs  → prec precTySemi $+            fcat (punctuate (char '⋁') (ppr0 <$> αs))++instance Ppr TyConVariety where+  ppr AbstractType = text "abstract type"+  ppr DataType     = text "data type"+  ppr OperatorType = text "type synonym or operator"++instance Tv tv ⇒ Show (Type tv) where showsPrec = showFromPpr+instance Show TyPat where showsPrec = showFromPpr+instance Show TyCon where showsPrec = showFromPpr+instance Tv tv ⇒ Show (QExp tv) where showsPrec = showFromPpr+instance Show TyConVariety where showsPrec = showFromPpr++-- | For verbose printing of 'TyCon's+newtype TyConInfo = TyConInfo TyCon++instance Ppr TyConInfo where+  ppr (TyConInfo tc) | tc == tcExn = text "exn"+  ppr (TyConInfo tc) = askTyNames $ \tn → atPrec 0 $+    case view (tyConToStx tn tc) of+      AST.TdSyn { AST.tdClauses = [(tps, t)] } →+        pprTyApp (tcName tc) (ps (snd <$> tvs))+          >?> ge (fst <$> tvs)+            >?> qe (fst <$> tvs)+              >?> char '=' <+> ppr t+          where+            tvs = [ case view tp of+                      AST.TpVar tv _ → (tv, ppr tv)+                      _              →+                        let tv  = AST.TV (AST.ident (show i)) qlit bogus+                            tv' = case qlit of+                                    Qa → ppr tv <> char '=' <>+                                          mapPrec (max precEq) (ppr tp)+                                    Qu → ppr tp+                         in (tv, tv')+                  | tp   ← tps+                  | qlit ← tcBounds tc+                  | i    ← [ 1 ∷ Int .. ] ]+      AST.TdSyn { AST.tdClauses = next } →+        pprTyApp (tcName tc) (ps tvs)+          >?> ge tvs+            >?> (qe tvs <+> text "with"+                 $$ vcat (map alt next))+              where+                tvs  = [ AST.TV (AST.ident (show i)) qlit bogus+                       | qlit ← tcBounds tc+                       | i ← [ 1 .. ] ∷ [Int] ]+                alt (tps,t) = char '|' <+> pprPrec precApp tps+                                <+> ppr (AST.jname (tcName tc))+                                >?> char '=' <+> ppr t+      AST.TdAbs { AST.tdParams = tvs } →+        pprTyApp (tcName tc) (ps tvs)+          >?> ge tvs+            >?> qe tvs+      AST.TdDat { AST.tdParams = tvs, AST.tdAlts = altsList } →+        pprTyApp (tcName tc) (ps tvs)+          >?> ge tvs+            >?> qe tvs+              >?> alts+        where+          alts = sep $+                 mapHead (text "=" <+>) $+                 mapTail (text "|" <+>) $+                 map alt altsList+          alt (u, Nothing) = ppr u+          alt (u, Just t)  = ppr u <+> text "of" <+> ppr t+      AST.TdAnti a → AST.antierror "ppr (TyConInfo)" a+    where+      qe tvs = case tcQual tc of+                 QeU αs | S.null αs+                     → mempty+                 qe' → colon <+> pprPrec precApp (qRepresent (tvs !!) qe')+      ps tvs = [ ppr var <> pprPrec (precApp + 1) tv+               | tv  ← tvs+               | var ← tcArity tc ]+      ge tvs = case map snd . filter fst $ zip (tcGuards tc) tvs of+                 []   → mempty+                 tvs' → text "rec" <+> fsep (punctuate comma (ppr <$> tvs'))+
+ src/Type/Rank.hs view
@@ -0,0 +1,30 @@+module Type.Rank (+  Rank, zero, infinity, inc+) where++import Syntax.PprClass as Ppr++import Data.Generics (Typeable, Data)++data Rank+  = Finite !Int+  | Infinity+  deriving (Eq, Ord, Typeable, Data)++instance Show Rank where+  show (Finite n) = show n+  show Infinity   = "∞"++instance Ppr Rank where ppr = Ppr.text . show++instance Bounded Rank where+  minBound = Finite 0+  maxBound = Infinity++zero, infinity ∷ Rank+zero     = minBound+infinity = maxBound++inc ∷ Rank → Rank+inc (Finite n) = Finite (n + 1)+inc Infinity   = Infinity
+ src/Type/Recursive.hs view
@@ -0,0 +1,136 @@+-- | Facilities for proper handling of equirecursive types+module Type.Recursive (+  -- * Equirecursive type standardization+  standardizeMus,++  -- * Non-equirecursive comparison+  NoRec(..),+) where++import Util+import Util.MonadRef+import Type.Internal++import Prelude ()+import qualified Data.Map as M+import qualified Data.Set as S+import Control.Monad.ST (runST)++-- | Put all recursion in standard form.+--   PRECONDITION: The type is in 'standardize' standard form and all+--   type variables are substituted+standardizeMus ∷ Ord tv ⇒ Type tv → Type tv+standardizeMus σ00 = runST $ do+  counter ← newRef (0 ∷ Int)+  let loop g0 σ0 = do+        case M.lookup σ0 g0 of+          Just (i, used') → do+            writeRef used' True+            return (fvTy i)+          Nothing → do+            i    ← gensym+            used ← newRef False+            let g = M.insert σ0 (i, used) g0+            σ0'  ← case σ0 of+              TyQu qu qls σ → do+                is ← mapM (const gensym) qls+                σ' ← loop g (openTy 0 (map fvTy is) σ)+                return (TyQu qu qls (closeTy 0 is σ'))+              TyApp tc σs   → TyApp tc `liftM` mapM (loop g) σs+              TyVar _       → return σ0+              TyRow n σ1 σ2 → TyRow n `liftM` loop g σ1 `ap` loop g σ2+              TyMu _ σ1     → loop g0 (openTy 0 [σ0] σ1)+            wasUsed ← readRef used+            return $ if wasUsed+              then TyMu Nope (closeTy 0 [i] σ0')+              else σ0'+      gensym  = do+        i ← readRef counter+        writeRef counter (i + 1)+        return (Right i)+      clean = either id (error "BUG! (standardizeMus)")+  σ00' ← loop M.empty (Left <$> σ00)+  return (clean <$> σ00')+++-- | Newtype for defining 'Eq' and 'Ord' on types treating 'TyMu' as a+-- normal type constructor without unfolding.  We build the correct+-- equirecursive operations on top of this.+newtype NoRec tv = NoRec (Type tv)++instance Ord tv ⇒ Eq (Type tv) where+  σ1 == σ2 = compare σ1 σ2 == EQ++instance Ord tv ⇒ Ord (Type tv) where+  compare σ10 σ20 = evalState (loop σ10 σ20) S.empty where+    compareM a b = return (compare a b)+    loop σ1 σ2 = do+      seen ← get+      if (S.member (NoRec σ1, NoRec σ2) seen ||+          S.member (NoRec σ2, NoRec σ1) seen)+        then return EQ+        else do+          put (S.insert (NoRec σ1, NoRec σ2) seen)+          case (σ1, σ2) of+            (TyMu _ σ1', _)+              → loop (openTy 0 [σ1] σ1') σ2+            (_, TyMu _ σ2')+              → loop σ1 (openTy 0 [σ2] σ2')+            (TyVar v1, TyVar v2)+              → compareM v1 v2+            (TyQu qu1 qls1 σ1', TyQu qu2 qls2 σ2')+              → compareM qu1 qu2        `thenCmpM`+                compareM qls1 qls2      `thenCmpM`+                loop σ1' σ2'+            (TyRow n1 σ1f σ1r, TyRow n2 σ2f σ2r)+              → compareM n1 n2          `thenCmpM`+                loop σ1f σ2f            `thenCmpM`+                loop σ1r σ2r+            (TyApp n1 σs1, TyApp n2 σs2)+              → compareM n1 n2          `thenCmpM`+                compareM (length σs1) (length σs2)+                                        `thenCmpM`+                foldl' thenCmpM (return EQ) (zipWith loop σs1 σs2)+            (TyVar _, _)+              → return LT+            (_, TyVar _)+              → return GT+            (TyQu _ _ _, _)+              → return LT+            (_, TyQu _ _ _)+              → return GT+            (TyApp _ _, _)+              → return LT+            (_, TyApp _ _)+              → return GT++instance Ord tv ⇒ Eq (NoRec tv) where+  σ1 == σ2 = compare σ1 σ2 == EQ++instance Ord tv ⇒ Ord (NoRec tv) where+  NoRec σ10 `compare` NoRec σ20 = loop σ10 σ20 where+    loop (TyVar r1)         (TyVar r2)+      = compare r1 r2+    loop (TyQu qu1 qls1 σ1) (TyQu qu2 qls2 σ2)+      = compare qu1 qu2   `mappend`+        compare qls1 qls2 `mappend`+        loop σ1 σ2+    loop (TyMu _ σ1)        (TyMu _ σ2)+      = loop σ1 σ2+    loop (TyRow l1 t1 t1')  (TyRow l2 t2 t2')+      = compare l1 l2     `mappend`+        loop t1 t2        `mappend`+        loop t1' t2'+    loop (TyApp tc1 σs1)    (TyApp tc2 σs2)+      = compare tc1 tc2   `mappend`+        mconcat (zipWith loop σs1 σs2)+    loop (TyVar _)          _                  = LT+    loop _                  (TyVar _)          = GT+    loop (TyQu _ _ _)       _                  = LT+    loop _                  (TyQu _ _ _)       = GT+    loop (TyMu _ _)         _                  = LT+    loop _                  (TyMu _ _)         = GT+    loop (TyRow _ _ _)      _                  = LT+    loop _                  (TyRow _ _ _)      = GT++
+ src/Type/Reduce.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE TypeFamilies #-}+module Type.Reduce (+  matchReduce,+  headNormalizeTypeK, headNormalizeType,+  headReduceType, ReductionState(..),+  majorReductionSequence, reductionSequence, reductionSequence'+) where++import Util+import Error+import Type.Internal+import Type.TyVar (Tv)+import Type.Ppr ()++import Prelude ()+import Data.Generics (Typeable, Data)+import qualified Data.List as List++instance Tv tv ⇒ Viewable (Type tv) where+  type View (Type tv) = Type tv+  view = headNormalizeTypeK 1000++-- | Reduce a type to head normal form+headNormalizeType ∷ Ord tv ⇒ Type tv → Type tv+headNormalizeType = last . reductionSequence++-- | Allow @k0@ steps to reduce a type to head normal form, or call+--  'error'+headNormalizeTypeK ∷ Tv tv ⇒ Int → Type tv → Type tv+headNormalizeTypeK k0 σ0 = loop k0 (reductionSequence σ0) where+  loop _ []     = throw $+    almsBug StaticsPhase "headNormalizeTypeK"+            "got empty reduction sequence"+  loop _ [σ]    = σ+  loop 0 (σ:_)  = throw $+    AlmsError StaticsPhase bogus+      [msg|+        Reduction of type $q:σ0 has not converged after $k0+        steps; stopped at $q:σ.+      |]+  loop k (_:σs) = loop (k - 1) σs++-- | Given two types, try to reduce them to a pair with a common+--   head constructor.  We assume that the two types given don't+--   match in the head already.+matchReduce ∷ Ord tv ⇒ Type tv → Type tv → Maybe (Type tv, Type tv)+matchReduce σ1 σ2 =+  List.find isCandidate+            (safeTail (allPairsBFS (majorReductionSequence σ1)+                                   (majorReductionSequence σ2)))+  where+    isCandidate (TyApp tc _, TyApp tc' _) = tc == tc'+    isCandidate _                         = True+    safeTail []     = []+    safeTail (_:σs) = σs++-- | Returns all pairs of a pair of lists, breadth first+allPairsBFS ∷ [a] → [b] → [(a, b)]+allPairsBFS xs0 ys0 = loop [(xs0, ys0)] where+  loop []   = []+  loop xsys = [ (x, y) | (x:_, y:_) ← xsys ]+           ++ loop (take 1 [ (xs, ys) | (xs, _:ys) ← xsys ]+                        ++ [ (xs, ys) | (_:xs, ys) ← xsys ])++-- | A major reduction sequence is a reduction sequence filtered+--   to show only changes in the head constructor.+majorReductionSequence ∷ Ord tv ⇒ Type tv → [Type tv]+majorReductionSequence = clean . reductionSequence where+  clean []        = []+  clean (σ:σs)    = σ : cleanWith σ σs+  cleanWith σ@(TyApp tc _) ((TyApp tc' _) : σs)+    | tc == tc'  = cleanWith σ σs+  cleanWith _ σs = clean σs++-- | The reduction sequence of a type+reductionSequence ∷ Ord tv ⇒ Type tv → [Type tv]+reductionSequence σ = (σ:) $ case headReduceType σ of+  Next σ' → reductionSequence σ'+  _       → []++-- | The reduction sequence of a type along with a final status+--   indicator+reductionSequence' ∷ Ord tv ⇒ Type tv → ([Type tv], ReductionState ())+reductionSequence' σ = first (σ:) $ case headReduceType σ of+  Next σ' → reductionSequence' σ'+  rs      → ([], () <$ rs)++-- | The state of a type reduction+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)++-- | Perform one head reduction step.+headReduceType ∷ Ord tv ⇒ Type tv → ReductionState (Type tv)+headReduceType σ0 = case σ0 of+  TyQu _ _ _  → Done+  TyVar _     → Done+  TyRow _ _ _ → Done+  TyMu _ σ    → Next $ openTy 0 [σ0] σ+  TyApp tc [σ1, σ2] | tc == tcRowMap+              → applyRowMap σ1 σ2+  TyApp tc σs → maybe Done (clauses tc σs) (tcNext tc)+  where+  --+  clauses _  _  []                = Stuck+  clauses tc σs ((tps, rhs):rest) = case patts tps σs of+    Right σs'  → Next $ openTy 0 σs' (elimEmptyF rhs)+    Left Stuck → clauses tc σs rest+    Left rs    → TyApp tc <$> rs+  --+  patts []       []               = Right []+  patts (tp:tps) (σ:σs)           = case patt tp σ of+    Right σs'     → case patts tps σs of+      Right σss'      → Right (σs' ++ σss')+      Left rs         → Left ((σ:) <$> rs)+    Left Blocked  → Left $ either ((σ:) <$>) (const Blocked) (patts tps σs)+    Left rs       → Left $ (:σs) <$> rs+  patts _        _                = Left Stuck+  --+  patt (TpVar _)       σ          = Right [σ]+  patt (TpApp tc tps)  σ          = case σ of+    TyApp tc' σs+      | tc == tc' → ((TyApp tc' <$>) +++ id) (patts tps σs)+    TyVar _       → Left Blocked+    _             → case headReduceType σ of+      Done            → Left Stuck+      rs              → Left rs+  patt (TpRow _)      σ           = Right [σ]++applyRowMap ∷ Ord tv ⇒ Type tv → Type tv → ReductionState (Type tv)+applyRowMap σcxt σarg = case σarg of+  TyRow lab σ1 σ2+    → Next $ TyRow lab (plugHole σcxt σ1) (tyRowMap σcxt σ2)+  TyApp tc [] | tc == tcRowEnd+    → Next tyRowEnd+  _ → tyRowMap σcxt <$> headReduceType σarg++plugHole         ∷ Ord tv ⇒ Type tv → Type tv → Type tv+plugHole σcxt σ' = foldType (mkQuF TyQu) (mkBvF bvTy) fvTy fcon+                            TyRow (mkMuF TyMu) σcxt+  where+    fcon tc σs =+      if tc == tcRowHole+        then σ'+        else TyApp tc σs
+ src/Type/Subst.hs view
@@ -0,0 +1,453 @@+-- | Representation of type variables and substitution+module Type.Subst (+  -- * Substitution monads+  MonadSubst(..),+  -- ** New type variables+  newTV', newTVTy', newTV, newTVTy,+  -- ** Reading and writing type variables+  readTV, writeTV, rewriteTV, rootTV, derefTV,+  -- ** Rank management+  Rank, lowerRank, lowerTVRank, getTVRank,+  -- ** Change tracking+  whileChanging, iterChanging, (>=>!), collectTVs_,++  -- * A 'MonadSubst' implementation+  SubstT, TV, SubstState, substState0,+  -- ** Running+  runSubstT, runEitherSubstT,+  Subst, runSubst,+  mapSubstT,++  -- * Substitution+  Substitutable(..),++  module Util.Trace,+) where++import Util+import Util.MonadRef+import Util.Trace+import Error+import Syntax.PprClass as Ppr+import Syntax.Prec (precEq)+import qualified AST+import qualified Type.Rank as Rank+import Type.Rank (Rank)+import Type.Internal+import Type.TyVar+import Type.Ppr ()++import Prelude ()+import Control.Monad.ST (runST)++---+--- A SUBSTITUTION MONAD INTERFACE+---++-- | A class supporting substitutable type variables+class (Functor m, Applicative m, Tv tv,+       MonadRef r m, MonadTrace m, MonadAlmsError m) ⇒+      MonadSubst tv r m | m → tv r where+  -- | Create a new type variable.+  newTV_        ∷ (Flavor, Kind, QLit, Doc) → m tv+  -- | Write a type variable. (Not for client use.)+  writeTV_      ∷ tv → Type tv → m ()+  -- | Read a type variable.+  readTV_       ∷ tv → m (Maybe (Type tv))+  -- | Get the rank of a type variable. (Not for client use.)+  getTVRank_    ∷ tv → m (Maybe Rank)+  -- | Set the rank of a type variable. (Not for client use.)+  setTVRank_    ∷ Rank → tv → m ()+  --+  -- | Get all the type variables allocated while running the+  --   action (except for any masked out by 'collectTV' already)+  collectTVs    ∷ m a → m (a, [tv])+  -- | Report a type variable as "new" to any upstream collectors+  reportTVs     ∷ [tv] → m ()+  --+  -- | Monitor an action for changes to variables+  monitorChange ∷ m a → m (a, Bool)+  -- | Indicate that a variable has changed+  setChanged    ∷ m ()++-- | Class for constructing new type variables with a variety of+--   attributes.+class NewTV a where+  newTVArg ∷ a → (Flavor, Kind, QLit, Doc) → (Flavor, Kind, QLit, Doc)+  newTV'   ∷ MonadSubst tv r m ⇒ a → m tv+  newTV' a = newTV_ (newTVArg a (Universal, KdType, maxBound, mempty))+  newTVTy' ∷ MonadSubst tv r m ⇒ a → m (Type tv)+  newTVTy' = fvTy <$$> newTV'++instance (NewTV a, NewTV b, NewTV c, NewTV d) ⇒ NewTV (a, b, c, d) where+  newTVArg (a, b, c, d) = newTVArg a . newTVArg b . newTVArg c . newTVArg d+instance (NewTV a, NewTV b, NewTV c) ⇒ NewTV (a, b, c) where+  newTVArg (a, b, c) = newTVArg a . newTVArg b . newTVArg c+instance (NewTV a, NewTV b) ⇒ NewTV (a, b) where+  newTVArg (a, b) = newTVArg a . newTVArg b+instance AST.Tag i ⇒ NewTV (AST.TyVar i)  where+  newTVArg tv = newTVArg (AST.tvqual tv, ppr (AST.tvqual tv))+instance NewTV Flavor         where newTVArg = upd1+instance NewTV Kind           where newTVArg = upd2+instance NewTV Variance       where newTVArg = upd2 . varianceToKind+instance NewTV QLit           where newTVArg = upd3+instance NewTV Doc            where newTVArg = upd4+instance NewTV String         where newTVArg = upd4 . text+instance NewTV ()             where newTVArg = const id++substBug        ∷ MonadSubst tv r m ⇒ String → String → m a+substBug        = throwAlms <$$> almsBug StaticsPhase++-- Allocate a new, empty (unifiable) type variable+newTV           ∷ MonadSubst tv r m ⇒ m tv+newTV           = newTV' ()++-- | Allocate a new type variable and wrap it in a type+newTVTy         ∷ MonadSubst tv r m ⇒ m (Type tv)+newTVTy         = fvTy <$> newTV++-- | Get the canonical representative (root) of a tree of type+--   variables, and any non-tv type stored at the root, if it+--   exists.  Performs path compression.+rootTV          ∷ MonadSubst tv r m ⇒ tv → m (tv, Maybe (Type tv))+rootTV α = do+  mτ ← readTV_ α+  case mτ of+    Just (TyVar (Free α')) → do+      (α'', mτ') ← rootTV α'+      when (α'' /= α') $ writeTV_ α (fvTy α'')+      return (α'', mτ')+    Just τ  → return (α, Just τ)+    Nothing → return (α, Nothing)++-- | Follow a type variable to the end of the chain, whatever that is.+derefTV         ∷ MonadSubst tv r m ⇒ tv → m (Type tv)+derefTV         = liftM (uncurry (fromMaybe . fvTy)) . rootTV++-- | Read a type variable+readTV          ∷ MonadSubst tv r m ⇒ tv → m (Either tv (Type tv))+readTV          = uncurry (flip maybe Right . Left) <$$> rootTV++-- | Write a type into an empty type variable.+writeTV         ∷ MonadSubst tv r m ⇒ tv → Type tv → m ()+writeTV α τ = do+  setChanged+  (α', mτα) ← rootTV α+  traceN 2 ("writeTV", α', τ)+  case mτα of+    Nothing → do+      Just rank ← getTVRank_ α'+      lowerRank rank τ+      writeTV_ α' τ+    Just _  → substBug "writeTV" "Tried to overwrite type variable."++-- | Write a type into a type variable, even if it's not empty.+rewriteTV       ∷ MonadSubst tv r m ⇒ tv → Type tv → m ()+rewriteTV α τ = do+  setChanged+  (α', mτα) ← rootTV α+  traceN 2 ("rewriteTV", (α', mτα), τ)+  writeTV_ α' τ++-- | Lower the rank of a type variable+lowerTVRank     ∷ MonadSubst tv r m ⇒ Rank → tv → m ()+lowerTVRank r tv = do+  r0 ← getTVRank tv+  when (r < r0) (setTVRank_ r tv)++-- | Find out the rank of a type variable.+getTVRank       ∷ MonadSubst tv r m ⇒ tv → m Rank+getTVRank       = fromMaybe Rank.infinity <$$> getTVRank_++-- | Lower the rank of all the type variables in a given type+lowerRank ∷ (MonadSubst tv r m, Ftv a tv) ⇒+            Rank → a → m ()+lowerRank rank τ = mapM_ (lowerTVRank rank) (ftvList τ)++-- | Collect type variables, discarding the result.+collectTVs_     ∷ MonadSubst tv r m ⇒ m a → m [tv]+collectTVs_     = snd <$$> collectTVs++-- | Iterate a computation until it stops changing+whileChanging ∷ MonadSubst tv r m ⇒ m a → m a+whileChanging m = do+  (r, b) ← monitorChange m+  if b+    then whileChanging m+    else return r++-- | Iterate a Kleisli arrow until it stops changing.+iterChanging ∷ MonadSubst tv r m ⇒ (a → m a) → a → m a+iterChanging f z = do+  (z', b) ← monitorChange (f z)+  if b+    then iterChanging f z'+    else return z'++-- | Compose two Kleisli arrows, running the second only if the first+--   had no effect.+(>=>!) ∷ MonadSubst tv r m ⇒ (a → m a) → (a → m a) → a → m a+(>=>!) m n z = do+  (z', changed) ← monitorChange (m z)+  if changed+    then return z'+    else n z++infixr 1 >=>!++---+--- A REPRESENTATION OF FREE TYPE VARIABLES+---++-- | A free type variable+data TV r+   = UnsafeReadRef r ⇒ TV {+      tvId      ∷ !Int,+      tvKind_   ∷ !Kind,+      tvDescr_  ∷ !Doc,+      tvRep     ∷ !(TVRep r)+   }++-- | The flavor-dependent representation of a free type variable+data TVRep r+  = UniFl !(r (Either Rank (Type (TV r))))+  | ExiFl !QLit !(r Rank)+  | SkoFl !QLit++instance Eq (TV r) where+  tv1 == tv2 = tvId tv1 == tvId tv2++instance Ftv (TV r) (TV r) where+  ftvTree = FTSingle++instance Ord (TV r) where+  tv1 `compare` tv2 = tvId tv1 `compare` tvId tv2++instance Ppr (TV s) where+  ppr tv = case (debug, unsafeReadTV tv) of+    (True, Just t) →+      if debugLevel > 4+        then int (tvId tv) <> char '=' <> pprPrec precEq t+        else ppr t+    _              → text (uglyTvName tv)++instance Show (TV s) where+  showsPrec = showFromPpr++instance Tv (TV r) where+  tvUniqueID    = tvId+  tvKind        = tvKind_+  tvDescr       = tvDescr_+  tvFlavor TV { tvRep = UniFl _ }       = Universal+  tvFlavor TV { tvRep = ExiFl _ _ }     = Existential+  tvFlavor TV { tvRep = SkoFl _ }       = Skolem+  tvQual   TV { tvRep = UniFl _ }       = Nothing+  tvQual   TV { tvRep = ExiFl q _ }     = Just q+  tvQual   TV { tvRep = SkoFl q }       = Just q+  unsafeReadTV TV { tvRep = UniFl r }   =+    (const Nothing ||| Just) (unsafeReadRef r)+  unsafeReadTV _                        = Nothing++---+--- A MonadSubst IMPLEMENTATION+---++-- | Monad transformer implementing 'MonadSubst'.+newtype SubstT s m a+  = SubstT {+      unSubstT ∷ RWST () ([TV s], Any) SubstState m a+    }+  deriving (Monad, MonadTrans)++-- | The threaded state.+data SubstState+  = SubstState {+      stsGensym ∷ !Int,+      stsTrace  ∷ !Int+    }++instance Monad m ⇒ Functor (SubstT s m) where+  fmap f m = m >>= return . f++instance Monad m ⇒ Applicative (SubstT s m) where+  pure  = return+  (<*>) = ap++instance Monad m ⇒ MonadTrace (SubstT s m) where+  getTraceIndent   = SubstT (gets stsTrace)+  putTraceIndent n = SubstT (modify (\sts → sts { stsTrace = n }))++instance MonadAlmsError m ⇒ MonadAlmsError (SubstT s m) where+  getLocation       = lift getLocation+  catchAlms m h     = SubstT (catchAlms (unSubstT m) (unSubstT . h))+  withLocation_ loc = SubstT . withLocation_ loc . unSubstT+  bailoutAlms_      = lift bailoutAlms_+  reportAlms_       = lift <$> reportAlms_+  mapAlmsErrors f   = SubstT . mapAlmsErrors f . unSubstT++instance MonadAlmsError m ⇒ MonadError [AlmsError] (SubstT s m) where+  throwError     = throwAlmsList+  catchError     = catchAlms++instance MonadRef r m ⇒ MonadRef r (SubstT r m) where+  newRef    = lift <$> newRef+  readRef   = lift <$> readRef+  writeRef  = lift <$$> writeRef+  modifyRef = lift <$$> modifyRef++instance (MonadRef r m, MonadAlmsError m) ⇒+         MonadSubst (TV r) r (SubstT r m) where+  newTV_ (flavor, kind, bound, descr) = do+    when (flavor == Universal && bound /= maxBound) $+      substBug "newTV_" "Universal tyvars cannot have non-A bound"+    sts ← SubstT get+    let i = stsGensym sts+    SubstT $ put sts { stsGensym = succ i }+    traceN 2 ("new", flavor, kind, i)+    α ← TV i kind descr <$> case flavor of+      Universal   → UniFl <$> newRef (Left Rank.infinity)+      Existential → ExiFl bound <$> newRef Rank.infinity+      Skolem      → return $ SkoFl bound+    SubstT $ tell ([α], mempty)+    return α+  writeTV_ TV { tvRep = UniFl r }   t = writeRef r (Right t)+  writeTV_ TV { tvRep = ExiFl _ _ } _ = substBug "writeTV_" "got existential"+  writeTV_ TV { tvRep = SkoFl _ }   _ = substBug "writeTV_" "got skolem"+  readTV_ TV { tvRep = UniFl r } = (const Nothing ||| Just) <$> readRef r+  readTV_ _                      = return Nothing+  --+  getTVRank_ TV { tvRep = UniFl r }   = (Just ||| const Nothing ) <$> readRef r+  getTVRank_ TV { tvRep = ExiFl _ r } = Just <$> readRef r+  getTVRank_ TV { tvRep = SkoFl _ }   = return Nothing+  setTVRank_ rank TV { tvRep = UniFl r }   = writeRef r (Left rank)+  setTVRank_ rank TV { tvRep = ExiFl _ r } = writeRef r rank+  setTVRank_ _    TV { tvRep = SkoFl _ }   = return ()+  --+  collectTVs action = do+    rαs ← (SubstT . censor (upd1 []) . listens sel1 . unSubstT) action+    traceN 2 ("collectTV", snd rαs)+    return rαs+  reportTVs αs = SubstT (tell (αs, mempty))+  --+  monitorChange = SubstT . listens (getAny . sel2) . unSubstT+  setChanged    = SubstT $ tell ([], Any True)++--+-- Pass-through instances+--++instance (MonadSubst tv r m, Monoid w) ⇒ MonadSubst tv r (WriterT w m) where+  newTV_        = lift <$> newTV_+  writeTV_      = lift <$$> writeTV_+  readTV_       = lift <$> readTV_+  getTVRank_    = lift <$> getTVRank_+  setTVRank_    = lift <$$> setTVRank_+  collectTVs    = mapWriterT (mapListen2 collectTVs)+  reportTVs     = lift <$> reportTVs+  monitorChange = mapWriterT (mapListen2 monitorChange)+  setChanged    = lift setChanged++instance MonadSubst tv r m ⇒ MonadSubst tv r (StateT s m) where+  newTV_        = lift <$> newTV_+  writeTV_      = lift <$$> writeTV_+  readTV_       = lift <$> readTV_+  getTVRank_    = lift <$> getTVRank_+  setTVRank_    = lift <$$> setTVRank_+  collectTVs    = mapStateT (mapListen2 collectTVs)+  reportTVs     = lift <$> reportTVs+  monitorChange = mapStateT (mapListen2 monitorChange)+  setChanged    = lift setChanged++instance MonadSubst tv r m ⇒ MonadSubst tv r (ReaderT r' m) where+  newTV_        = lift <$> newTV_+  writeTV_      = lift <$$> writeTV_+  readTV_       = lift <$> readTV_+  getTVRank_    = lift <$> getTVRank_+  setTVRank_    = lift <$$> setTVRank_+  collectTVs    = mapReaderT collectTVs+  reportTVs     = lift <$> reportTVs+  monitorChange = mapReaderT monitorChange+  setChanged    = lift setChanged++instance (MonadSubst tv r m, Monoid w) ⇒ MonadSubst tv r (RWST r' w s m) where+  newTV_        = lift <$> newTV_+  writeTV_      = lift <$$> writeTV_+  readTV_       = lift <$> readTV_+  getTVRank_    = lift <$> getTVRank_+  setTVRank_    = lift <$$> setTVRank_+  collectTVs    = mapRWST (mapListen3 collectTVs)+  reportTVs     = lift <$> reportTVs+  monitorChange = mapRWST (mapListen3 monitorChange)+  setChanged    = lift setChanged++--+-- Running+--++-- | Run in the substitution monad+runSubstT ∷ Monad m ⇒ SubstState → SubstT r m a → m (a, SubstState)+runSubstT state0 (SubstT m) = do+  (result, state, _) ← runRWST m () state0 { stsTrace = 0 }+  return (result, state)++substState0 ∷ SubstState+substState0 = SubstState 0 0++-- | Run a substitution computation, but not inheriting exception+--   handling+runEitherSubstT ∷ Monad m ⇒+                 SubstState → SubstT r (AlmsErrorT m) a →+                 m (Either [AlmsError] (a, SubstState))+runEitherSubstT = runAlmsErrorT <$$> runSubstT++-- | The type of a generic substitution computation+type Subst a  = ∀ s m. (MonadRef s m, MonadAlmsError m) ⇒ SubstT s m a++-- | Run a substitution computation in a pure context+runSubst ∷ SubstState → Subst a → Either [AlmsError] (a, SubstState)+runSubst st0 m = runST (runEitherSubstT st0 m)++-- | For lifting through 'SubstT'+mapSubstT ∷ (Functor t1, Functor t2) ⇒+            (∀s. t1 (a, s) → t2 (b, s)) →+            SubstT r t1 a → SubstT r t2 b+mapSubstT f = SubstT . mapRWST f' . unSubstT where+  f' action = fromPair <$> f (toPair <$> action)+  toPair (a, s, w)     = (a, (s, w))+  fromPair (a, (s, w)) = (a, s, w)++---+--- SUBSTITUTION+---++class Monad m ⇒ Substitutable a m where+  -- | Fully dereference all the values, deeply.+  subst         ∷ a → m a+  -- | Fully dereference a sequence of TV indirections, with path+  --   compression, at the root of a type (or each type of a+  --   collection).+  substHead     ∷ a → m a++instance Substitutable a m ⇒ Substitutable [a] m where+  subst     = mapM subst+  substHead = mapM substHead++instance Substitutable a m ⇒ Substitutable (Maybe a) m where+  subst     = mapM subst+  substHead = mapM substHead++instance (Substitutable a m, Substitutable b m) ⇒+         Substitutable (a, b) m where+  subst (a, b)     = liftM2 (,) (subst a) (subst b)+  substHead (a, b) = liftM2 (,) (substHead a) (substHead b)++instance MonadSubst tv r m ⇒ Substitutable (Type tv) m where+  subst = foldTypeM (mkQuF (return <$$$> TyQu))+                    (mkBvF (return <$$$> bvTy))+                    ((>>= either (return . fvTy) subst) . readTV)+                    (return <$$> TyApp)+                    (return <$$$> TyRow)+                    (mkMuF (return <$$> TyMu))+  substHead (TyVar (Free r)) = derefTV r+  substHead σ                = return σ+
+ src/Type/Syntax.hs view
@@ -0,0 +1,212 @@+-- | For converting internal types back to syntactic types+module Type.Syntax (+  -- * Types to syntax+  typeToStx, typeToStx',+  T2SContext(..), t2sContext0, TyNames(..), tyNames0,+  -- * Patterns to syntax+  tyPatToStx, tyPatToStx', tyPatsToStx,+  -- * Type constructors to type declarations+  tyConToStx, tyConToStx',+) where++import Util+import Util.Trace+import qualified Env+import Type.Internal+import Type.ArrowAnnotations+import Type.TyVar+import qualified AST+import Syntax.PprClass (TyNames(..), tyNames0)++import Prelude ()+import qualified Data.Set as S++type R = AST.Renamed++-- | Context for printing types and type patterns+data T2SContext rule tv+  = T2SContext {+      t2sTyNames  ∷ TyNames,+      t2sArrRule  ∷ rule tv,+      t2sTvEnv    ∷ [[AST.TyVar R]]+    }++-- | The default initial printing context+t2sContext0 ∷ T2SContext CurrentImpArrPrintingRule tv+t2sContext0+  = T2SContext {+      t2sTyNames  = tyNames0,+      t2sArrRule  = iaeInit,+      t2sTvEnv    = []+    }++-- | Represent a type value as a pre-syntactic type, for printing+typeToStx' ∷ Tv tv ⇒ Type tv → AST.Type R+typeToStx' = typeToStx t2sContext0++-- | Turns annotated arrows into implicit arrows where possible+typeToStx ∷ (Tv tv, ImpArrRule rule) ⇒+            T2SContext rule tv → Type tv → AST.Type R+typeToStx cxt0 σ0 = runReader (loop σ0) cxt0 where+  loop (TyVar (Free r)) | debug, Just σ ← unsafeReadTV r =+      do+        δ  ← asks t2sTvEnv+        t  ← loop σ+        return (AST.tyApp (AST.qident "@=")+                          [AST.tyVar (getTV δ (Free r)), t])+      {-+      else throw $+        almsBug (OtherError "unknown")+                "typeToStx"+                ("Saw unsubstituted type variable: " ++ show r)+                -}+  loop (TyVar tv0)           = do+    δ  ← asks t2sTvEnv+    return (AST.tyVar (getTV δ tv0))+  loop (TyQu quant αs σ) =+    withFresh αs $ \αs' → do+      σ' ← loop σ+      return (foldr (AST.tyQu (quantToStx quant)) σ' αs')+  loop (TyMu n σ) =+    withFresh [(n, Qa)] $ \αs' → do+      σ' ← loop σ+      return (foldr AST.tyMu σ' αs')+  loop (TyRow lab σ1 σ2) =+    AST.tyRow lab <$> loop σ1 <*> loop σ2+  loop (TyApp tc [σ1, qe, σ2]) | tc == tcFun = do+    cxt ← ask+    qe' ← represent qe+    let cxt1 = cxt { t2sArrRule = iaeLeft (t2sArrRule cxt) }+        cxt2 = cxt { t2sArrRule = iaeRight (t2sArrRule cxt)+                                           (qualifierCxt cxt qe)+                                           σ1 }+    t1' ← local (\_ → cxt1) (loop σ1)+    t2' ← local (\_ → cxt2) (loop σ2)+    return (AST.tyFun t1' qe' t2')+  loop (TyApp tc σs) = do+    AST.tyApp <$> bestName t2sTyNames tc <*> sequence+      [ local (\cxt → cxt { t2sArrRule = iaeUnder (t2sArrRule cxt) variance })+          (loop σ)+      | σ        ← σs+      | variance ← tcArity tc ]+  --+  withFresh αs k = do+    δ ← asks t2sTvEnv+    let names  = fst <$> αs+        seen   = AST.unLid . AST.tvname <$> concat δ+        names' = AST.freshNames names seen AST.tvalphabet+        αs'    = zipWith3 AST.TV (AST.ident <$> names')+                                 (snd <$> αs)+                                 (repeat AST.bogus)+    local (\cxt → cxt { t2sTvEnv = αs' : δ }) (k αs')+  --+  getTV _ (Free tv)+    = AST.TV (AST.ident (uglyTvName tv)) (fromMaybe Qa (tvQual tv)) AST.bogus+  getTV δ (Bound i j n)+    | rib:_ ← drop i δ, tv:_  ← drop j rib+    = tv+    | otherwise+    = AST.tvAf ('?' : fromPerhaps "" n)+  --+  represent qe = do+    cxt ← ask+    return (iaeRepresent (getTV (t2sTvEnv cxt))+                         (t2sArrRule cxt)+                         (qualifierCxt cxt qe))+  --+  qualifierCxt cxt = qualifierEnv (AST.tvqual <$$> t2sTvEnv cxt)++-- | Represent a type value as a pre-syntactic type, for printing+tyPatToStx' ∷ TyPat → (AST.TyPat R, [AST.TyVar R])+tyPatToStx' = tyPatToStx tyNames0 [] Qa++-- | Turn an internal type pattern into a syntactic type pattern+tyPatToStx ∷ TyNames → [(AST.TyVar R, Variance)] → QLit → TyPat →+             (AST.TyPat R, [AST.TyVar R])+tyPatToStx tn0 tvs0 ql0 tp0 =+  evalRWS (loop ql0 tp0) tn0 (extendTyPatNames tvs0)+  where+  loop ql (TpVar _)      = fresh ql AST.tpVar+  loop ql (TpApp tc tps) = AST.tpApp+                             <$> bestName id tc+                             <*> sequence+                               [ let qli = bi ⊓ if S.member i ftv_qe+                                                  then ql else Qa+                                  in loop qli tpi+                               | i   ← [ 0 .. ]+                               | tpi ← tps+                               | bi  ← tcBounds tc ]+                               where ftv_qe = ftvSet (tcQual tc)+  loop ql (TpRow _)      = fresh ql AST.tpRow+  --+  fresh ql mk = do+    (tv, variance):tvs ← get+    put tvs+    let tv' = tv { AST.tvqual = ql }+    tell [tv']+    return (mk tv' variance)++-- | Turn a list of internal type pattern into a list of syntactic type+--   patterns+tyPatsToStx ∷ TyNames → [(AST.TyVar R, Variance)] → [QLit] → [TyPat] →+              ([AST.TyPat R], [AST.TyVar R])+tyPatsToStx tn0 tvs0 qls0 tps0 =+  loop (extendTyPatNames tvs0) (qls0 ++ repeat Qa) tps0+  where+  loop tvs (ql:qls) (tp:tps) =+    let (tp',  tvs')  = tyPatToStx tn0 tvs ql tp+        (tps', tvss') = loop (drop (length tvs') tvs) qls tps+     in (tp':tps', tvs'++tvss')+  loop _   _        _        = ([], [])++extendTyPatNames ∷ [(AST.TyVar R, Variance)] →+                   [(AST.TyVar R, Variance)]+extendTyPatNames tvs0 =+  tvs0 ++ [ (AST.tvAf name, maxBound)+          | name ← AST.tvalphabet+          , name `notElem` map (AST.unLid . AST.tvname . fst) tvs0 ]++-- | Externalize a quantifier+quantToStx ∷ Quant → AST.Quant+quantToStx Forall = AST.Forall+quantToStx Exists = AST.Exists++-- | Look up the best printing name for a type.+bestName ∷ MonadReader r m ⇒ (r → TyNames) → TyCon → m QTypId+bestName getter tc = do+  tn ← asks getter+  return (tnLookup tn (tcId tc) (tcName tc))++tyConToStx' ∷ TyCon → AST.TyDec R+tyConToStx' = tyConToStx tyNames0++tyConToStx ∷ TyNames → TyCon → AST.TyDec R+tyConToStx tn tc =+  let+  n             = AST.jname (tcName tc)+  tvs           = zipWith3 AST.TV (AST.ident <$> AST.tvalphabet)+                                  (tcBounds tc)+                                  (repeat AST.bogus)+  doType envTvs = typeToStx t2sContext0 { t2sTyNames = tn, t2sTvEnv = [envTvs] }+  in+  case tc of+  _ | tc == tcExn+    → AST.tdAbs (AST.ident "exn") [] [] [] maxBound+  TyCon { tcNext = Just clauses }+    → AST.tdSyn n+                [ second (`doType` rhs) (tyPatsToStx tn [] (tcBounds tc) ps)+                | (ps, rhs) ← clauses ]+  TyCon { tcCons = alts }+    | not (Env.isEmpty alts)+    → AST.tdDat n tvs+                (second (doType tvs <$>) <$> Env.toList alts)+  TyCon { tcArity = arity, tcQual = qual, tcGuards = guards }+    → AST.tdAbs n tvs arity (fst <$> filter snd (zip tvs guards)) $+        case qual of+          QeA     → AST.qeLit Qa+          QeU ixs →+            case fst <$> filter ((`S.member` ixs) . snd) (zip tvs [0..]) of+              []   → AST.qeLit Qu+              tvs' → foldr1 AST.qeJoin (AST.qeVar <$> tvs')++
+ src/Type/TyVar.hs view
@@ -0,0 +1,239 @@+module Type.TyVar (+  -- * Type variable observations+  Tv(..), Kind(..), Flavor(..),+  tvFlavorIs, tvKindIs, uglyTvName,+  -- * Miscellany+  varianceToKind,+  -- * Free type variables+  Ftv(..), VarMap,+  FtvTree(..), foldFtvTree,+) where++import Util+import qualified AST+import Syntax.PprClass+import Type.Internal++import Prelude ()+import Data.Generics (Typeable, Data)+import qualified Data.Map as M+import qualified Data.Set as S++---+--- TYPE VARIABLES+---++-- | Internal kinds for type variables+data Kind+  -- | The kind of normal types+  = KdType+  -- | The kind of qualifier variables+  | KdQual+  deriving (Eq, Typeable, Data)++instance Ppr Kind where+  ppr KdType = char '*'+  ppr KdQual = char 'Q'+instance Show Kind where showsPrec = showFromPpr++-- | Get the kind associated with type variables that appear at a+--   particular variance.+varianceToKind ∷ Variance → Kind+varianceToKind var = if isQVariance var then KdQual else KdType++-- | Flavors of type variables+data Flavor+  -- | unification variables+  = Universal+  -- | existential skolems+  | Existential+  -- | universal skolems+  | Skolem+  deriving (Eq, Typeable, Data)++instance Ppr Flavor where ppr = char . flavorSigil+instance Show Flavor where showsPrec = showFromPpr++-- | Type variable observations+class (Ftv tv tv, Show tv, Ppr tv) ⇒ Tv tv where+  -- | The unique identity of a type variable+  tvUniqueID    ∷ tv → Int+  -- | The internal kind of a type variable+  tvKind        ∷ tv → Kind+  -- | The internal flavor of a type variable+  tvFlavor      ∷ tv → Flavor+  -- | Possibly a qualifier bound+  tvQual        ∷ tv → Maybe QLit+  -- | A description+  tvDescr       ∷ tv → Doc+  -- | Read the contents of a type variable (not pure)+  unsafeReadTV  ∷ tv → Maybe (Type tv)++instance Tv Empty where+  tvUniqueID    = elimEmpty+  tvKind        = elimEmpty+  tvFlavor      = elimEmpty+  tvQual        = elimEmpty+  tvDescr       = elimEmpty+  unsafeReadTV  = elimEmpty++instance Ftv Empty Empty where ftvTree = elimEmpty+instance Ppr Empty       where ppr = elimEmpty++instance Tv Int where+  tvUniqueID    = id+  tvKind _      = KdType+  tvFlavor _    = Skolem+  tvQual _      = Nothing+  tvDescr       = ppr+  unsafeReadTV  = const Nothing++instance Ftv Int Int where ftvTree = FTSingle++-- | Check the flavor of a type variable+tvFlavorIs ∷ Tv tv ⇒ Flavor → tv → Bool+tvFlavorIs flavor v = tvFlavor v == flavor++-- | Check the kind of a type variable+tvKindIs ∷ Tv tv ⇒ Kind → tv → Bool+tvKindIs kind v = tvKind v == kind++-- | When all else fails, we can print a type variable like this+uglyTvName ∷ Tv tv ⇒ tv → String+uglyTvName tv = flavorSigil (tvFlavor tv) : (AST.tvalphabet !! tvUniqueID tv)++-- | A character denoting a flavor+flavorSigil ∷ Flavor → Char+flavorSigil Universal   = '_'+flavorSigil Existential = '#'+flavorSigil Skolem      = '$'++---+--- FREE TYPE VARIABLES+---++{-+  We're going to construct a framework for generic functions to compute+  the free type variables of a type.  It may seem a bit over-engineered,+  but it turns out to be handy, The idea is to write a generic function+  that builds an 'FtvTree', which contains all the free type variables+  in the relevant piece of syntax, along with variance and recursive+  guard information.+-}++-- | A tree of free type variables, with variance and recursive guard+--   information+data FtvTree v+  -- | A single free type variable+  = FTSingle v+  -- | Updates the incoming variance to give the variance in+  --   the subtree+  | FTVariance VarianceEndo (FtvTree v)+  -- | Indicates that the subtree is guarded by a type constructor+  --   that allows recursion+  | FTGuard (FtvTree v)+  -- | A forest of 'FtvTree's+  | FTBranch [FtvTree v]+  deriving (Functor, Show)++-- | Type for providing a 'Show' instance for @Variance -> Variance@+-- functions which allows deriving 'Show' for 'FtvTree'.+newtype VarianceEndo+  = VarianceEndo { applyVarianceEndo ∷ Variance → Variance }++instance Show VarianceEndo where+  show ve = show (applyVarianceEndo ve 1)++instance Monoid (FtvTree v) where+  mempty      = FTBranch []+  mappend a b = FTBranch [a, b]+  mconcat     = FTBranch++-- | A fold for 'FtvTree's. It's necessary to specify how to+--   add a free type variable and its variance to the result, and the+--   initial result.  Note that this fold gives no information about+--   the shape of the tree, but it uses the tree structure to determine+--   the variance of each type variable.+foldFtvTree ∷ (v → Variance → Bool → r → r) → r → FtvTree v → r+foldFtvTree fsingle = loop Covariant False where+  loop var gua acc tree = case tree of+    FTSingle v      → fsingle v var gua acc+    FTVariance vf t → loop (applyVarianceEndo vf var) gua acc t+    FTGuard t       → loop var True acc t+    FTBranch ts     → foldr (flip (loop var gua)) acc ts++-- | Map from variables to variances+type VarMap v = M.Map v Variance++class Ord tv ⇒ Ftv a tv | a → tv where+  -- | To compute the 'FtvTree' for a piece of syntax.  Because+  --   everything is parametric in the representation of ftvs, it needs+  --   to be told how to dereference an apparently free type variable.+  --   The dereferencing function should return @Nothing@ if the type+  --   variable is actually free, and @Just τ@ if a type @τ@ has been+  --   substituted for it.+  --+  --   This is the only method that doesn't have a default+  --   implementation, so it must be defined explicitly.+  ftvTree  ∷ a → FtvTree tv+  -- | To fold over the free type variables in a piece of syntax.+  ftvFold  ∷ (tv → Variance → Bool → r → r) → r → a → r+  -- | To get a map from free type variables to their variances.+  ftvV     ∷ a → VarMap tv+  -- | To get a map from free type variables to their guardedness+  ftvG     ∷ a → M.Map tv Bool+  -- | To get a map from free type variables to a list of all their+  --   occurrences' variances.+  ftvSet   ∷ a → S.Set tv+  -- | To get a list of the free type variables in a type (with no repeats).+  ftvList  ∷ a → [tv]+  --+  --+  ftvFold fsingle zero a+                 = foldFtvTree fsingle zero $ ftvTree a+  ftvV           = ftvFold (const <$$> M.insertWith (+)) M.empty+  ftvG           = ftvFold (const <$> M.insertWith (&&)) M.empty+  ftvSet         = ftvFold (\v _ _ → S.insert v) S.empty+  ftvList        = S.toAscList . ftvSet++instance Ord tv ⇒ Ftv (Type tv) tv where+  ftvTree = foldType+              (mkQuF (\_ _ → id))+              (mkBvF (\_ _ _ → mempty))+              FTSingle+              (\tc trees → FTBranch+                 [ FTVariance (VarianceEndo (* var)) $+                     if guarded then FTGuard tree else tree+                 | tree    ← trees+                 | var     ← tcArity tc+                 | guarded ← tcGuards tc ])+              (\_ σ1 σ2 → FTBranch [FTGuard σ1, σ2])+              (mkMuF (\_ → id))++instance Ord tv ⇒ Ftv (QExp tv) tv where+  ftvTree QeA      = FTBranch []+  ftvTree (QeU αs) = FTBranch (FTSingle <$> S.toList αs)+  ftvSet QeA       = S.empty+  ftvSet (QeU αs)  = αs++instance Ftv a tv ⇒ Ftv [a] tv where+  ftvTree = foldMap ftvTree++instance Ftv a tv ⇒ Ftv (M.Map k a) tv where+  ftvTree = ftvTree . M.elems++instance (Ftv a tv, Ftv b tv) ⇒ Ftv (a, b) tv where+  ftvTree (a, b) = ftvTree a `mappend` ftvTree b++instance (Ftv a tv, Ftv b tv, Ftv c tv) ⇒ Ftv (a, b, c) tv where+  ftvTree (a, b, c) = mconcat [ftvTree a, ftvTree b, ftvTree c]++instance (Ftv a tv, Ftv b tv, Ftv c tv, Ftv d tv) ⇒ Ftv (a, b, c, d) tv where+  ftvTree (a, b, c, d) = mconcat [ftvTree a, ftvTree b, ftvTree c, ftvTree d]++instance Ftv a tv ⇒ Ftv (Maybe a) tv where+  ftvTree = maybe mempty ftvTree++instance (Ftv a tv, Ftv b tv) ⇒ Ftv (Either a b) tv where+  ftvTree = either ftvTree ftvTree+
− src/TypeRel.hs 
@@ -1,1051 +0,0 @@-{-# LANGUAGE-      FlexibleContexts,-      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 Ppr ()-import Type-import Util-import Viewable--import qualified Control.Monad.Reader as CMR-import Control.Monad.Error-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 })--runUT  :: forall s a m. MonadError String m =>-          (forall t. UT s t a) -> S.Set TyVarR -> m a-runUT m set =-  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 throwError $-            "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 :: MonadError String 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 = -      throwError $-        "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 ]-    ---    -- XXX This is woefully insufficient-    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 :: MonadError String 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-      _ ->-        throwError $-          "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 throwError $-                    "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 = runEither (throwError . strMsg) return-                           (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 =-    tassertSuccess (show t1 ++ " \\/ " ++ show t2 ++ " = " ++ show t)-                   t (t1 \/? t2)-  Right (t1, t2) ==! t =-    tassertSuccess (show t1 ++ " /\\ " ++ show t2 ++ " = " ++ show t)-                   t (t1 /\? t2)-  t1 !/\ t2 =-    tassertFailure (show t1 ++ " /\\ " ++ show t2 ++ " DNE")-                   (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)-  , tassertFailure "'<c `supertype` '<d = ERROR"-                   (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) =-    tassertSuccess (show t1 ++ " `subtype` " ++ show t2)-                   ([ta, tb, tc, td], [])-                   (subtype 100 set t1 [] t2)-  Right (t1, t2) ==! (ta, tb, tc, td) =-    tassertSuccess (show t1 ++ " `supertype` " ++ show t2)-                   ([], [ta, tb, tc, td])-                   (subtype 100 [] t2 set t1)-  t1 !<: t2 =-    tassertFailure (show t1 ++ " `subtype` " ++ show t2 ++ " = ERROR")-                   (subtype 100 set t1 [] t2)-  t1 !>: t2 =-    tassertFailure (show t1 ++ " `supertype` " ++ show t2 ++ " = ERROR")-                   (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"--tassertSuccess :: (Eq a, Show a) =>-                  String -> a -> Either String a -> T.Assertion-tassertSuccess msg = T.assertEqual msg . Right--tassertFailure :: String -> Either String a -> T.Assertion-tassertFailure msg = either (\_ -> return ()) (\_ -> T.assertFailure msg)--tests :: IO ()-tests = do-  T.runTestTT subtypeTests-  T.runTestTT joinTests-  T.runTestTT uvarsTests-  return ()
src/Util.hs view
@@ -1,26 +1,32 @@ -- | Utility functions-{-# LANGUAGE-      CPP,-      FlexibleContexts-      #-} module Util (-  -- * List combinators-  -- ** Shallow mapping-  mapCons, mapHead, mapTail,-  -- ** Two-list versions+  -- * Extra collection operations+  -- ** Shallow mapping of 'Traversable's+  mapHead, mapTail, mapInit, mapLast,+  -- ** 'Foldable'/'Applicative' operations+  allA, anyA,+  -- ** 2-way 'Foldable' operations   foldl2, foldr2, all2, any2,-  -- ** Monadic version-  foldrM, anyM, allM, anyM2, allM2,-  concatMapM,-  -- ** Applicative versions-  mapA,-  -- ** Unfold with an accumulator+  allA2, anyA2,+  -- ** Extra zips+  zip4, unzip4, zip5, unzip5,+  -- ** List operations+  mapCons, foldM1,+  lookupWithIndex, listNth, ordNub, partitionJust,+  -- *** Unfold with an accumulator   unscanr, unscanl,-  -- ** Map in CPS+  -- *** Map in CPS   mapCont, mapCont_,-  -- ** Monad generalization of map and sequence-  GSequence(..), +  -- * Extra monadic operations+  whenM, unlessM, concatMapM, before,++  -- * Maps for state-like monads+  mapListen2, mapListen3,++  -- * 'Maybe' and 'Either' operations+  fromOptA, unEither,+   -- * More convenience   -- ** Maybe functions   (?:),@@ -31,100 +37,261 @@   -- ** Monomorphic @ord@ and @chr@   char2integer, integer2char,   -- ** For defining 'Ord'-  thenCmp,-  -- ** Versions of fmap+  thenCmp, thenCmpM,+  -- ** Versions of fmap and compose   (>>!),-  (<$$>), (<$$$>), (<$$$$>), (<$$$$$>),+  (<$$>), (<$$$>), (<$$$$>), (<$$$$$>), (<$$$$$$>),+  (<$.>), (<$$.>), (<$$$.>), (<$$$$.>),+  (<->), (<-->), (<--->), (<---->), (<----->), +  -- * Generic set operations+  SetLike(..), SetLike2(..),+   -- * Re-exports-  module Data.Maybe,   module Control.Arrow,+  module Control.Applicative,   module Control.Monad,-  module Control.Applicative+  module Control.Monad.Error,+  module Control.Monad.Identity,+  module Control.Monad.List,+  module Control.Monad.RWS.Strict,+  module Control.Monad.Reader,+  module Control.Monad.State.Strict,+  module Control.Monad.Trans,+  module Control.Monad.Writer.Strict,+  module Data.Foldable,+  module Data.Function,+  module Data.Maybe,+  module Data.Monoid,+  module Data.Traversable,+  module Data.Tuple.All,+  module Data.OptionalClass,+  module Data.Perhaps,+  module Util.Bogus,+  module Util.Viewable,+  module Prelude, ) where +import Prelude hiding ( (=<<), Functor(..), Maybe(..), Monad(..), all,+                        and, any, concat, concatMap, elem, foldl, foldl1,+                        foldr, foldr1, mapM, mapM_, maximum, maybe,+                        minimum, notElem, or, product, sequence, sequence_,+                        sum )++import Control.Arrow ( Arrow(..), ArrowChoice(..), (>>>), (<<<) )+import Control.Applicative hiding ( empty )+import Control.Monad hiding ( forM, forM_, mapM_, mapM, msum,+                              sequence, sequence_ )++import Control.Monad.Error    ( MonadError(..), ErrorT(..), mapErrorT,+                                Error(..) )+import Control.Monad.Identity ( Identity(..) )+import Control.Monad.List     ( ListT(..), mapListT )+import Control.Monad.RWS.Strict ( RWST(..), runRWST, execRWST, evalRWST,+                                  mapRWST, evalRWS )+import Control.Monad.Reader     ( MonadReader(..), ReaderT(..), mapReaderT,+                                  asks, runReader )+import Control.Monad.State.Strict ( MonadState(..), StateT(..), evalStateT,+                                    execStateT, evalState, gets, modify,+                                    mapStateT )+import Control.Monad.Trans    ( MonadTrans(..), MonadIO(..) )+import Control.Monad.Writer.Strict ( MonadWriter(..), WriterT(..),+                                     runWriter, execWriterT, execWriter,+                                     mapWriterT, censor, listens )+ import Data.Char (chr, ord) import Data.Maybe-import Control.Arrow hiding (loop, (<+>))-import Control.Monad-import Control.Applicative (Applicative(..), (<$>), (<$), (<**>))+import Data.Monoid+import Data.Foldable+import Data.Function ( on )+import Data.Traversable+import Data.Tuple.All -#if PARSEC_VERSION == 2+import Data.OptionalClass+import Data.Perhaps+import Util.Bogus+import Util.Viewable -import Text.ParserCombinators.Parsec (GenParser)--- | Parsec parsers are Applicatives, which lets us write slightly---   more pleasant, non-monadic-looking parsers-instance Applicative (GenParser a b) where-  pure  = return-  (<*>) = ap-#endif+import qualified Data.Set  as S+import qualified Data.List as L --- | 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+mapHead, mapTail, mapInit, mapLast ∷ Traversable t ⇒ (a → a) → t a → t a --- | 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+mapHead f = snd . mapAccumL each True where+  each True x = (False, f x)+  each _    x = (False, x) --- | Like 'Prelude.all' with a monadic predicate-allM :: Monad m => (a -> m Bool) -> [a] -> m Bool-allM p = liftM not . anyM (liftM not . p)+mapTail f = snd . mapAccumL each True where+  each True x = (False, x)+  each _    x = (False, f x) --- | 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)+mapInit f = snd . mapAccumR each True where+  each True x = (False, x)+  each _    x = (False, f x) --- | 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)+mapLast f = snd . mapAccumR each True where+  each True x = (False, f x)+  each _    x = (False, x) -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-concatMapM f xs = concat `liftM` mapM f xs+-- | 'all' with an applicative predicate+allA ∷ (Applicative f, Foldable t) ⇒ (a → f Bool) → t a → f Bool+allA p xs = and <$> traverse p (toList 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+-- | 'any' with an applicative predicate+anyA ∷ (Applicative f, Foldable t) ⇒ (a → f Bool) → t a → f Bool+anyA p xs = or <$> traverse p (toList xs) +-- | Left-associative fold over two lists+foldl2 ∷ (Foldable t1, Foldable t2) ⇒+         (c → a → b → c) → c → t1 a → t2 b → c+foldl2 f z xs ys = foldl (uncurry . f) z (zip (toList xs) (toList ys))++-- | Right-associative fold over two lists+foldr2 ∷ (Foldable t1, Foldable t2) ⇒+         (a → b → c → c) → c → t1 a → t2 b → c+foldr2 f z xs ys = foldr (uncurry f) z (zip (toList xs) (toList ys))++-- | Two-list 'all'+all2 :: (Foldable f1, Foldable f2) ⇒+        (a -> b -> Bool) -> f1 a -> f2 b -> Bool+all2 p xs ys = and (zipWith p (toList xs) (toList ys))++-- | Two-list 'any'+any2 :: (Foldable f1, Foldable f2) ⇒+        (a -> b -> Bool) -> f1 a -> f2 b -> Bool+any2 p xs ys = or (zipWith p (toList xs) (toList ys))++-- | 'all' for two 'Foldable's with an applicative predicate+allA2 ∷ (Applicative f, Foldable t1, Foldable t2) ⇒+        (a → b → f Bool) → t1 a → t2 b → f Bool+allA2 p xs ys = allA id (zipWith p (toList xs) (toList ys))++-- | 'all' for two 'Foldable's with an applicative predicate+anyA2 ∷ (Applicative f, Foldable t1, Foldable t2) ⇒+        (a → b → f Bool) → t1 a → t2 b → f Bool+anyA2 p xs ys = anyA id (zipWith p (toList xs) (toList ys))++-- | Zip four lists+zip4   ∷ [a] → [b] → [c] → [d] → [(a, b, c, d)]+zip4 (a:as) (b:bs) (c:cs) (d:ds) = (a, b, c, d) : zip4 as bs cs ds+zip4 _      _      _      _      = []++-- | Zip five lists+zip5   ∷ [a] → [b] → [c] → [d] → [e] → [(a, b, c, d, e)]+zip5 (a:as) (b:bs) (c:cs) (d:ds) (e:es) = (a, b, c, d, e) : zip5 as bs cs ds es+zip5 _      _      _      _      _      = []++-- | Unzip four lists+unzip4 ∷ [(a, b, c, d)] → ([a], [b], [c], [d])+unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) → (a:as,b:bs,c:cs,d:ds))+               ([],[],[],[])++-- | Unzip four lists+unzip5 ∷ [(a, b, c, d, e)] → ([a], [b], [c], [d], [e])+unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) → (a:as,b:bs,c:cs,d:ds,e:es))+               ([],[],[],[],[])+ -- | Apply one function to the head of a list and another to the --   tail mapCons :: (a -> b) -> ([a] -> [b]) -> [a] -> [b] mapCons _  _  []     = [] 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+-- | Fold over a non-empty 'Foldable' in a monad+foldM1          ∷ (Foldable t, Monad m) ⇒ (a → a → m a) → t a → m a+foldM1 f xs0    = loop (toList xs0) where+  loop []     = fail "foldM1: empty"+  loop (x:xs) = foldM f x xs --- | Map a function over all but the first element of a list-mapTail  :: (a -> a) -> [a] -> [a]-mapTail   = mapCons id . map+-- | Like 'Data.List.lookup', but returns the index into the list as+--   well.+lookupWithIndex ∷ Eq a ⇒ a → [(a, b)] → Maybe (b, Int)+lookupWithIndex k = loop 0 where+  loop _   []   = Nothing+  loop !ix ((k',v):rest)+    | k == k'   = Just (v, ix)+    | otherwise = loop (ix + 1) rest --- | 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+-- | Safe version of '(Data.List.!!)'+listNth ∷ Int → [a] → Maybe a+listNth i = foldr (const . Just) Nothing . drop i --- | 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+-- | Like nub, but O(n log n) instead of O(n^2)+ordNub ∷ Ord a ⇒ [a] → [a]+ordNub = loop S.empty where+  loop seen (x:xs)+    | x `S.member` seen = loop seen xs+    | otherwise         = x : loop (S.insert x seen) xs+  loop _    []     = [] --- | Two-list 'all'-all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool-all2 p xs ys = and (zipWith p xs ys)+-- | Partition a list into the portions where the function returns+--   'Just' and the portions where it returns 'Nothing'+partitionJust ∷ (a → Maybe b) → [a] → ([a], [b])+partitionJust f = foldr each ([], []) where+  each x (xs, ys) = case f x of+    Nothing → (x:xs, ys)+    Just y →  (xs, y:ys) --- | Two-list 'any'-any2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool-any2 p xs ys = or (zipWith p xs ys)+-- | 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)++-- | 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++whenM ∷ Monad m ⇒ m Bool → m () → m ()+whenM test branch = test >>= flip when branch++unlessM ∷ Monad m ⇒ m Bool → m () → m ()+unlessM test branch = test >>= flip unless branch++-- | Map and concatenate in a monad.+concatMapM   ∷ (Foldable t, Monad m, Monoid b) ⇒ (a → m b) → t a → m b+concatMapM f = foldr (liftM2 mappend . f) (return mempty)++before ∷ Monad m ⇒ m a → (a → m b) → m a+before m k = do+  a ← m+  k a+  return a++infixl 8 `before`++mapListen2 ∷ Monad m ⇒ (a → m ((b, s), w)) → a → m ((b, w), s)+mapListen3 ∷ Monad m ⇒ (a → m ((b, s1, s2), w)) → a → m ((b, w), s1, s2)++mapListen2 mapper action = do+  ((b, s), w) ← mapper action+  return ((b, w), s)++mapListen3 mapper action = do+  ((b, s1, s2), w) ← mapper action+  return ((b, w), s1, s2)++fromOptA ∷ (Applicative f, Optional t) ⇒ f a → t a → f a+fromOptA def = foldOpt def pure++unEither ∷ Either a a → a+unEither = either id id+ -- | The ASCII value of a character char2integer :: Char -> Integer char2integer  = fromIntegral . ord@@ -140,9 +307,8 @@                 in ys : splitBy p (drop 1 zs)  -- | Maybe cons, maybe not-(?:) :: Maybe a -> [a] -> [a]-Nothing ?: xs = xs-Just x  ?: xs = x : xs+(?:) :: Optional t ⇒ t a -> [a] -> [a]+(?:)  = foldOpt id (:)  infixr 5 ?: @@ -152,45 +318,20 @@ 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))))-(<$$$$$>)  = (<$$$$>) . (<$>)+-- | To combine two actions producing 'Ordering's in lexigraphic order+thenCmpM ∷ Monad m ⇒ m Ordering → m Ordering → m Ordering+thenCmpM m1 m2 = do+  ordering ← m1+  case ordering of+    EQ → m2+    _  → return ordering -infixl 4 <$$>, <$$$>, <$$$$>, <$$$$$>+infixr 4 `thenCmp`, `thenCmpM`  -- | @flip fmap@ (>>!) :: Functor f => f a -> (a -> b) -> f b@@ -198,38 +339,133 @@  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')+(<$$>) ∷ (Functor f, Functor g) ⇒ +         (b → c) → g (f b) → g (f c)+(<$$>) = fmap . fmap --- | 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+(<$$$>) ∷ (Functor f, Functor g, Functor h) ⇒+          (b → c) → h (g (f b)) →+          h (g (f c))+(<$$$>) = fmap . fmap . fmap --- | 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_+(<$$$$>) ∷ (Functor f, Functor g, Functor h, Functor i) ⇒+           (b → c) → i (h (g (f b))) →+           i (h (g (f c)))+(<$$$$>) = fmap . fmap . fmap . fmap -instance GSequence [] where-  gsequence  = sequence-  gsequence_ = sequence_-  gmapM      = mapM-  gmapM_     = mapM_+(<$$$$$>) ∷ (Functor f, Functor g, Functor h, Functor i, Functor j) ⇒+            (b → c) → j (i (h (g (f b)))) →+            j (i (h (g (f c))))+(<$$$$$>) = fmap . fmap . fmap . fmap . fmap -instance GSequence Maybe where-  gsequence  = maybe (return Nothing) (liftM return)-  gsequence_ = maybe (return ()) (>> return ())+(<$$$$$$>) ∷ (Functor f, Functor g, Functor h,+              Functor i, Functor j, Functor k) ⇒+             (b → c) → k (j (i (h (g (f b))))) →+             k (j (i (h (g (f c)))))+(<$$$$$$>) = fmap . fmap . fmap . fmap . fmap . fmap++infixl 4 <$$>, <$$$>, <$$$$>, <$$$$$>, <$$$$$$>++(<$.>) ∷ (Arrow (⇝), Functor f) ⇒+         f (b ⇝ c) → (a ⇝ b) →+         f (a ⇝ c)+f <$.> g = (g >>>) <$> f++(<$$.>) ∷ (Arrow (⇝), Functor f, Functor g) ⇒+          g (f (b ⇝ c)) → (a ⇝ b) →+          g (f (a ⇝ c))+f <$$.> g = (g >>>) <$$> f++(<$$$.>) ∷ (Arrow (⇝), Functor f, Functor g, Functor h) ⇒+           h (g (f (b ⇝ c))) → (a ⇝ b) →+           h (g (f (a ⇝ c)))+f <$$$.> g = (g >>>) <$$$> f++(<$$$$.>) ∷ (Arrow (⇝), Functor f, Functor g, Functor h, Functor i) ⇒+            i (h (g (f (b ⇝ c)))) → (a ⇝ b) →+            i (h (g (f (a ⇝ c))))+f <$$$$.> g = (g >>>) <$$$$> f++infixl 4 <$.>, <$$.>, <$$$.>, <$$$$.>++(<->)   ∷ Functor f ⇒ +          f (a → b) → a → f b+f <-> x = ($ x) <$> f++(<-->)   ∷ (Functor f, Functor g) ⇒+           f (g (a → b)) → a → f (g b)+f <--> x = (<-> x) <$> f++(<--->)   ∷ (Functor f, Functor g, Functor h) ⇒+            f (g (h (a → b))) → a → f (g (h b))+f <---> x = (<--> x) <$> f++(<---->)   ∷ (Functor f, Functor g, Functor h, Functor i) ⇒+             f (g (h (i (a → b)))) → a → f (g (h (i b)))+f <----> x = (<---> x) <$> f++(<----->)   ∷ (Functor f, Functor g, Functor h, Functor i, Functor j) ⇒+              f (g (h (i (j (a → b))))) → a → f (g (h (i (j b))))+f <-----> x = (<----> x) <$> f++infixl 4 <->, <-->, <--->, <---->, <----->++class (Eq a, Foldable t) ⇒ SetLike t a where+  isEmptySet    ∷ t a → Bool+  (∈), (∉)      ∷ a → t a → Bool+  emptySet      ∷ t a+  singleton     ∷ a → t a+  --+  isEmptySet    = null . toList+  a ∈ set       = a `elem` toList set+  a ∉ set       = not (a ∈ set)++class (SetLike t a, SetLike t' a) ⇒ SetLike2 t t' a where+  (⊆), (⊇), (/⊆), (/⊇), (/∩)+                ∷ t a → t' a → Bool+  (∪), (∩), (∖) ∷ t a → t' a → t a+  --+  set1 ⊆ set2   = all (∈ set2) set1+  set1 ⊇ set2   = all (∈ set1) set2+  set1 /⊆ set2  = not (set1 /⊆ set2)+  set1 /⊇ set2  = not (set1 /⊇ set2)+  set1 /∩ set2  = not (any (∈ set2) set1)++infix 4 ∈, ∉, ⊆, ⊇, /⊆, /⊇, /∩+infixl 6 ∪, ∖+infixl 7 ∩++instance Eq a ⇒ SetLike [] a where+  emptySet      = []+  singleton a   = [a]++instance Eq a ⇒ SetLike2 [] [] a where+  (∪)           = L.union+  (∩)           = L.intersect+  (∖)           = (L.\\)++instance Ord a ⇒ SetLike2 [] S.Set a where+  (∪)           = L.union <$.> toList+  (∩)           = L.intersect <$.> toList+  (∖)           = (L.\\) <$.> toList++instance Ord a ⇒ SetLike S.Set a where+  isEmptySet    = S.null+  (∈)           = S.member+  emptySet      = S.empty+  singleton     = S.singleton++instance Ord a ⇒ SetLike2 S.Set S.Set a where+  (⊆)           = S.isSubsetOf+  set1 /∩ set2  = isEmptySet (set1 ∩ set2)+  (∪)           = S.union+  (∩)           = S.intersection+  (∖)           = (S.\\)++instance Ord a ⇒ SetLike2 S.Set [] a where+  (⊆)           = (⊆) <$.> S.fromList+  set1 ⊇ list2  = all (∈ set1) list2+  set1 /∩ list2 = all (∉ set1) list2+  (∪)           = foldr S.insert+  (∩)           = (∩) <$.> S.fromList+  (∖)           = foldr S.delete
+ src/Util/Bogus.hs view
@@ -0,0 +1,41 @@+-- | Interface for producing bogus results, usually when an error+--   has occurred but we want to keep going to try to find more errors.+module Util.Bogus (+  Bogus(..), IsBogus(..),+) where++-- | A bogus value.+class Bogus a where+  bogus ∷ a++-- | Test for bogosity.+class Bogus a ⇒ IsBogus a where+  isBogus ∷ a → Bool++instance Bogus () where+  bogus = ()++instance Bogus (Maybe a) where+  bogus = Nothing++instance Bogus [a] where+  bogus = []++instance Bogus a ⇒ Bogus (Either a b) where+  bogus = Left bogus++instance IsBogus a ⇒ IsBogus (Either a b) where+  isBogus = either isBogus (const False)++instance (Bogus a, Bogus b) ⇒ Bogus (a, b) where+  bogus = (bogus, bogus)++instance (IsBogus a, IsBogus b) ⇒ IsBogus (a, b) where+  isBogus (a, b) = isBogus a && isBogus b++instance (Bogus a, Bogus b, Bogus c) ⇒ Bogus (a, b, c) where+  bogus = (bogus, bogus, bogus)++instance (IsBogus a, IsBogus b, IsBogus c) ⇒ IsBogus (a, b, c) where+  isBogus (a, b, c) = isBogus a && isBogus b && isBogus c+
+ src/Util/Eq1.hs view
@@ -0,0 +1,26 @@+{- Equality type classes for unary and binary type constructors. -}+module Util.Eq1 (+  Eq1(..), EQ1(..),+) where++import Data.IORef+import Data.STRef+import Control.Concurrent.STM.TVar++-- | Like 'Eq', but for unary type constructors.+class Eq1 t where+  eq1 ∷ t a → t a → Bool+  ne1 ∷ t a → t a → Bool+  x `ne1` y = not (x `eq1` y)++infix 4 `eq1`, `ne1`++instance Eq1 IORef where eq1 = (==)+instance Eq1 (STRef s) where eq1 = (==)+instance Eq1 TVar where eq1 = (==)++-- | Injection for using 'Eq': If @t@ is 'Eq1' then @EQ1 t a@ is 'Eq'+newtype EQ1 t a = EQ1 (t a)+instance Eq1 t ⇒ Eq1 (EQ1 t) where EQ1 x `eq1` EQ1 y = x `eq1` y+instance Eq1 t ⇒ Eq (EQ1 t a) where EQ1 x == EQ1 y = x `eq1` y+
+ src/Util/MonadRef.hs view
@@ -0,0 +1,122 @@+module Util.MonadRef (+  MonadRef(..),+  UnsafeReadRef(..),+) where++import Control.Monad.ST+import Control.Monad.STM++import Data.IORef+import Data.STRef+import Control.Concurrent.STM.TVar++import Control.Monad.Cont+import Control.Monad.Error+import Control.Monad.List+import Control.Monad.RWS.Strict    as Strict+import Control.Monad.RWS.Lazy      as Lazy+import Control.Monad.Reader+import Control.Monad.State.Strict  as Strict+import Control.Monad.State.Lazy    as Lazy+import Control.Monad.Writer.Strict as Strict+import Control.Monad.Writer.Lazy   as Lazy++import System.IO.Unsafe++import Util.Eq1++-- | A class for monads with mutable references. Provides generic+--   operations for creating, reading, writing, and modifying+--   references.+class (UnsafeReadRef p, Monad m, Eq1 p) ⇒ MonadRef p m | m → p where+  newRef    ∷ a → m (p a)+  readRef   ∷ p a → m a+  writeRef  ∷ p a → a → m ()+  modifyRef ∷ (a → a) → p a → m ()+  modifyRef f r = do+    a ← readRef r+    writeRef r (f a)++class UnsafeReadRef p where+  unsafeReadRef ∷ p a → a++---+--- Other MonadRef instances+---++instance MonadRef IORef IO where+  newRef   = newIORef+  readRef  = readIORef+  writeRef = writeIORef++instance UnsafeReadRef IORef where+  unsafeReadRef = unsafePerformIO . readRef++instance MonadRef (STRef s) (ST s) where+  newRef   = newSTRef+  readRef  = readSTRef+  writeRef = writeSTRef++instance UnsafeReadRef (STRef s) where+  unsafeReadRef = unsafePerformIO . unsafeSTToIO . readRef++instance MonadRef TVar STM where+  newRef   = newTVar+  readRef  = readTVar+  writeRef = writeTVar++instance UnsafeReadRef TVar where+  unsafeReadRef = unsafePerformIO . atomically . readRef++instance MonadRef p m ⇒ MonadRef p (ContT r m) where+  newRef a     = lift $ newRef a+  readRef r    = lift $ readRef r+  writeRef r a = lift $ writeRef r a++instance (Show e, Error e, MonadRef p m) ⇒ MonadRef p (ErrorT e m) where+  newRef a     = lift $ newRef a+  readRef r    = lift $ readRef r+  writeRef r a = lift $ writeRef r a++instance MonadRef p m ⇒ MonadRef p (ListT m) where+  newRef a     = lift $ newRef a+  readRef r    = lift $ readRef r+  writeRef r a = lift $ writeRef r a++instance (Monoid w, MonadRef p m) ⇒+         MonadRef p (Strict.RWST r w s m) where+  newRef a     = lift $ newRef a+  readRef r    = lift $ readRef r+  writeRef r a = lift $ writeRef r a++instance (Monoid w, MonadRef p m) ⇒+         MonadRef p (Lazy.RWST r w s m) where+  newRef a     = lift $ newRef a+  readRef r    = lift $ readRef r+  writeRef r a = lift $ writeRef r a++instance (MonadRef p m) ⇒ MonadRef p (ReaderT r m) where+  newRef a     = lift $ newRef a+  readRef r    = lift $ readRef r+  writeRef r a = lift $ writeRef r a++instance (MonadRef p m) ⇒ MonadRef p (Strict.StateT s m) where+  newRef a     = lift $ newRef a+  readRef r    = lift $ readRef r+  writeRef r a = lift $ writeRef r a++instance (MonadRef p m) ⇒ MonadRef p (Lazy.StateT s m) where+  newRef a     = lift $ newRef a+  readRef r    = lift $ readRef r+  writeRef r a = lift $ writeRef r a++instance (Monoid w, MonadRef p m) ⇒ MonadRef p (Strict.WriterT w m) where+  newRef a     = lift $ newRef a+  readRef r    = lift $ readRef r+  writeRef r a = lift $ writeRef r a++instance (Monoid w, MonadRef p m) ⇒ MonadRef p (Lazy.WriterT w m) where+  newRef a     = lift $ newRef a+  readRef r    = lift $ readRef r+  writeRef r a = lift $ writeRef r a+
+ src/Util/Trace.hs view
@@ -0,0 +1,268 @@+module Util.Trace (+  TraceIndent, MonadTrace(..),+  traceN, trace, traceLow,+  debugLevel, debug,+  --+  TraceT(..), runTraceT, mapTraceT,+  --+  TraceMessage(..),+  TracePpr(..), TraceNesting(..),+) where++import Util+import Syntax.PprClass as Ppr++import Prelude ()+import Data.IORef+import System.IO.Unsafe (unsafePerformIO)++{-# INLINE debugLevel #-}+debugLevel ∷ Int+debugLevel = 0++{-# INLINE debug #-}+debug ∷ Bool+debug = debugLevel > 0++type TraceIndent = Int++class Monad m ⇒ MonadTrace m where+  getTraceIndent    ∷ m Int+  putTraceIndent    ∷ Int → m ()+  modifyTraceIndent ∷ (Int → Int) → m ()+  modifyTraceIndent f = getTraceIndent >>= putTraceIndent . f+  putTraceString    ∷ String → m ()+  putTraceString s  = unsafePerformIO (putStr s) `seq` return ()++class TraceMessage a where+  pprTrace        ∷ a → Doc+  pprTraceIndent  ∷ a → Ordering+  pprTraceIndent  = const EQ++{-# INLINE traceN #-}+traceN     ∷ (TraceMessage a, MonadTrace m) ⇒ Int → a → m ()+traceN     =+  if debug+    then \level →+      if debugLevel >= level+        then traceLow+        else \_ → return ()+    else \_ _ → return ()++{-# INLINE trace #-}+trace      ∷ (TraceMessage a, MonadTrace m) ⇒ a → m ()+trace      =+  if debug+    then traceLow+    else \_ → return ()++{-# INLINE traceLow #-}+traceLow   ∷ (TraceMessage a, MonadTrace m) ⇒ a → m ()+traceLow a = do+  n0 ← getTraceIndent+  (n, brace) ← case pprTraceIndent a of+    LT → putTraceIndent (n0 - 2) >> return (n0 - 2, (char '}' Ppr.<+>))+    EQ → return (n0, id)+    GT → putTraceIndent (n0 + 2) >> return (n0, (Ppr.<+> char '{'))+  let doc = nest n (brace (pprTrace a))+  putTraceString (show doc ++ "\n")++---+--- MonadTrace instances+---++instance Monad m ⇒ MonadTrace (TraceT m) where+  putTraceIndent    = TraceT . put+  getTraceIndent    = TraceT get+  modifyTraceIndent = TraceT . modify++instance MonadTrace m ⇒ MonadTrace (ReaderT r m) where+  putTraceIndent    = lift . putTraceIndent+  getTraceIndent    = lift getTraceIndent+  modifyTraceIndent = lift . modifyTraceIndent++instance (MonadTrace m, Monoid w) ⇒ MonadTrace (WriterT w m) where+  putTraceIndent    = lift . putTraceIndent+  getTraceIndent    = lift getTraceIndent+  modifyTraceIndent = lift . modifyTraceIndent++instance MonadTrace m ⇒ MonadTrace (StateT s m) where+  putTraceIndent    = lift . putTraceIndent+  getTraceIndent    = lift getTraceIndent+  modifyTraceIndent = lift . modifyTraceIndent++instance (MonadTrace m, Monoid w) ⇒ MonadTrace (RWST r w s m) where+  putTraceIndent    = lift . putTraceIndent+  getTraceIndent    = lift getTraceIndent+  modifyTraceIndent = lift . modifyTraceIndent++instance MonadTrace m ⇒ MonadTrace (ListT m) where+  putTraceIndent    = lift . putTraceIndent+  getTraceIndent    = lift getTraceIndent+  modifyTraceIndent = lift . modifyTraceIndent++---+--- A transformer+---++newtype TraceT m a = TraceT { unTraceT ∷ StateT TraceIndent m a }+  deriving (Functor, Applicative, Monad, MonadTrans)++runTraceT ∷ Monad m ⇒ TraceT m a → m a+runTraceT = flip evalStateT 0 . unTraceT++mapTraceT   ∷ Monad m ⇒+              (m a → m b) → TraceT m a → TraceT m b+mapTraceT f = TraceT . mapStateT f' . unTraceT where+  f' ma = do+    (a, indent) ← ma+    b ← f (return a)+    return (b, indent)++instance MonadReader r m ⇒ MonadReader r (TraceT m) where+  ask   = lift ask+  local = mapTraceT . local++instance MonadWriter w m ⇒ MonadWriter w (TraceT m) where+  tell   = lift . tell+  listen = mapTraceT listen+  pass   = mapTraceT pass++instance MonadState s m ⇒ MonadState s (TraceT m) where+  get    = lift get+  put    = lift . put++instance MonadIO m ⇒ MonadIO (TraceT m) where+  liftIO = lift . liftIO++---+--- An instance for IO+---++{-# NOINLINE ioTraceIndent #-}+ioTraceIndent ∷ IORef TraceIndent+ioTraceIndent = unsafePerformIO (newIORef 0)++instance MonadTrace IO where+  getTraceIndent    = readIORef ioTraceIndent+  putTraceIndent    = writeIORef ioTraceIndent+  modifyTraceIndent = modifyIORef ioTraceIndent+  putTraceString    = putStr++---+--- TraceMessage instances+---++newtype TracePpr a = TracePpr { unTracePpr ∷ a }++instance Ppr a ⇒ TraceMessage (TracePpr a) where+  pprTrace     = ppr . unTracePpr++instance TraceMessage Doc where pprTrace = id++data TraceNesting a+  = TraceIn  { unTraceNesting ∷ !a }+  | TraceOut { unTraceNesting ∷ !a }++instance TraceMessage String where+  pprTrace       = Ppr.text . snd . pprDecomposeString+  pprTraceIndent = fst . pprDecomposeString++pprDecomposeString ∷ String → (Ordering, String)+pprDecomposeString ('}':s) = (LT, dropWhile (== ' ') s)+pprDecomposeString s       = case reverse s of+  '{':s' → (GT, reverse (dropWhile (== ' ') s'))+  _      → (EQ, s)++instance TraceMessage a ⇒ TraceMessage (TraceNesting a) where+  pprTrace = pprTrace . unTraceNesting+  pprTraceIndent (TraceIn _)  = GT+  pprTraceIndent (TraceOut _) = LT++instance (Ppr a, Ppr z)+       ⇒ TraceMessage (a,z) where+  pprTrace (a,z) = ppr a <> char '(' <> ppr z <> char ')'++instance (Ppr a, Ppr b, Ppr z)+       ⇒ TraceMessage (a,b,z) where+  pprTrace (a,b,z) =+    hang+      (ppr a <> char '(' <> p b)+      4+      (fsep+       [+        ppr z <> char ')'])++instance (Ppr a, Ppr b, Ppr c, Ppr z)+       ⇒ TraceMessage (a,b,c,z) where+  pprTrace (a,b,c,z) =+    hang+      (ppr a <> char '(' <> p b)+      4+      (fsep+       [p c,+        ppr z <> char ')'])++instance (Ppr a, Ppr b, Ppr c, Ppr d, Ppr z)+       ⇒ TraceMessage (a,b,c,d,z) where+  pprTrace (a,b,c,d,z) =+    hang+      (ppr a <> char '(' <> p b)+      4+      (fsep+       [p c, p d,+        ppr z <> char ')'])++instance (Ppr a, Ppr b, Ppr c, Ppr d, Ppr e, Ppr z)+       ⇒ TraceMessage (a,b,c,d,e,z) where+  pprTrace (a,b,c,d,e,z) =+    hang+      (ppr a <> char '(' <> p b)+      4+      (fsep+       [p c, p d, p e,+        ppr z <> char ')'])++instance (Ppr a, Ppr b, Ppr c, Ppr d, Ppr e, Ppr f, Ppr z)+       ⇒ TraceMessage (a,b,c,d,e,f,z) where+  pprTrace (a,b,c,d,e,f,z) =+    hang+      (ppr a <> char '(' <> p b)+      4+      (fsep+       [p c, p d, p e, p f,+        ppr z <> char ')'])++instance (Ppr a, Ppr b, Ppr c, Ppr d, Ppr e, Ppr f, Ppr g, Ppr z)+       ⇒ TraceMessage (a,b,c,d,e,f,g,z) where+  pprTrace (a,b,c,d,e,f,g,z) =+    hang+      (ppr a <> char '(' <> p b)+      4+      (fsep+       [p c, p d, p e, p f, p g,+        ppr z <> char ')'])++instance (Ppr a, Ppr b, Ppr c, Ppr d, Ppr e, Ppr f, Ppr g, Ppr h, Ppr z)+       ⇒ TraceMessage (a,b,c,d,e,f,g,h,z) where+  pprTrace (a,b,c,d,e,f,g,h,z) =+    hang+      (ppr a <> char '(' <> p b)+      4+      (fsep+       [p c, p d, p e, p f, p g, p h,+        ppr z <> char ')'])++instance (Ppr a, Ppr b, Ppr c, Ppr d, Ppr e, Ppr f, Ppr g, Ppr h, Ppr i, Ppr z)+       ⇒ TraceMessage (a, b, c, d, e, f, g, h, i, z) where+  pprTrace (a,b,c,d,e,f,g,h,i,z) =+    hang+      (ppr a <> char '(' <> p b)+      4+      (fsep+       [p c, p d, p e, p f, p g, p h, p i,+        ppr z <> char ')'])++-- Very common helper+p :: Ppr a => a -> Doc+p x = ppr x <> char ';'
+ src/Util/UndoIO.hs view
@@ -0,0 +1,77 @@+-- | An extension of the IO monad with an undo facility+module Util.UndoIO (+  -- * The 'UndoIO' monad+  UndoIO(..),+  -- ** Running+  runUndoIO, runUndoIO',+  -- ** Operation+  addUndo+) where++import Prelude hiding (catch)+import Util.MonadRef+import Control.Applicative+import Control.Exception+import Control.Monad.Error+import Control.Monad+import Control.Monad.Trans+import Data.IORef++-- | A layer on top of the IO monad with an undo facility.+newtype UndoIO a+  = UndoIO {+      unUndoIO ∷ IORef [IO ()] → IO a+    }+  deriving Functor++instance Applicative UndoIO where+  pure    = return+  (<*>)   = ap++instance Monad UndoIO where+  return  = UndoIO . const . return+  m >>= k = UndoIO $ \undo → do+    a ← unUndoIO m undo+    unUndoIO (k a) undo++instance MonadIO UndoIO where+  liftIO = UndoIO . const++-- | Run an 'UndoIO' computation, running the undo list actions+--   if it raises an exception.+runUndoIO ∷ UndoIO a → IO a+runUndoIO action = do+  undo ← newRef []+  unUndoIO action undo `catch` \e → do+    sequence_ =<< readRef undo+    throwIO (e ∷ SomeException)++-- | Run an 'UndoIO' computation, without checking for an escaping+--   exception.+runUndoIO' ∷ UndoIO a → IO a+runUndoIO' action = unUndoIO action =<< newRef []++---+--- OPERATIONS+---++-- | Add an action to the front of the undo list+addUndo ∷ IO () → UndoIO ()+addUndo action = UndoIO (modifyRef (action :))++instance MonadRef IORef UndoIO where+  newRef        = UndoIO . const . newRef+  readRef       = UndoIO . const . readRef+  writeRef r a  = modifyRef (const a) r+  modifyRef f r = UndoIO $ \undo → do+    old ← readRef r+    writeRef r (f old)+    modifyRef (writeRef r old :) undo++instance MonadError SomeException UndoIO where+  throwError = liftIO . throwIO+  catchError action handler = UndoIO $ \undo → do+    undo' ← newRef []+    unUndoIO action undo' `catch` \exn → do+      sequence_ =<< readRef undo'+      unUndoIO (handler exn) undo
+ src/Util/Viewable.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TypeFamilies #-}+-- | Quick and dirty views+module Util.Viewable where++import Control.Arrow++import Data.Perhaps++-- | 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 (Perhaps a) where+  type View (Perhaps a) = Perhaps (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)
src/Value.hs view
@@ -1,13 +1,4 @@ -- | The representation and embedding of values-{-# LANGUAGE-      DeriveDataTypeable,-      ExistentialQuantification,-      FlexibleInstances,-      MultiParamTypeClasses,-      PatternGuards,-      RankNTypes,-      ScopedTypeVariables-    #-} module Value (   -- * Value and function representation   Valuable(..), FunName(..), Value(..),@@ -18,6 +9,8 @@   Vinj(..), VExn(..),   -- *** Exception IDs   ExnId(..),+  -- ** Records+  VRecord(..),    -- * Utilities for algebraic data types   enumTypeDecl,@@ -29,17 +22,18 @@ import Data.Generics  import Util-import Syntax (Uid(..), Type, Renamed, uid)-import Ppr (Doc, text, Ppr(..), hang, sep, char, (<>), (<+>),+import AST (Type, Renamed, Id(..), Uid, ConId, uidToLid)+import Syntax.Ppr (Doc, text, Ppr(..), hang, sep, char, (<>), (<+>),             prec, prec1, ppr1, atPrec, precCom, precApp)+import qualified Syntax.Ppr as Ppr  import qualified Control.Exception as Exn +import qualified Control.Monad as C.M+import Prelude () 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 @@ -90,23 +84,20 @@   --   by 'Show' for printing 'String's differently than other   --   lists.)   vpprList :: [a] -> Doc-  vpprList []     = text "nil"-  vpprList (x:xs) = prec precApp $ prec1 $-                      hang (text "cons" <+> vppr x)-                           1-                           (vpprList xs)+  vpprList =+    Ppr.brackets . atPrec 0 . Ppr.fsep . Ppr.punctuate Ppr.comma . map vppr    -- | 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)))+  vinjList []     = VaCon (ident "[]") Nothing+  vinjList (x:xs) = VaCon (ident "::") (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+  vprjListM (VaCon (idName -> "[]") Nothing) = return []+  vprjListM (VaCon (idName -> "::") (Just v)) = do     (x, xs) <- vprjM v     return (x:xs)   vprjListM _ = fail "vprjM: not a list"@@ -129,7 +120,10 @@   -- | A function   = VaFun FunName (Value -> IO Value)   -- | A datacon, potentially applied-  | VaCon (Uid R) (Maybe Value)+  | VaCon (ConId R) (Maybe Value)+  -- | An open variant injection or embedding. The 'Int' gives the+  --   number of embeddings of the label+  | VaLab Int (Uid R) Value   -- | Any other embeddable Haskell type   | forall a. Valuable a => VaDyn a   deriving Typeable@@ -198,27 +192,37 @@  instance Valuable () where   veq        = (==)-  vinj ()    = VaCon (uid "()") Nothing-  vprjM (VaCon (Uid _ "()") _) = return ()-  vprjM _                    = fail "vprjM: not a unit"+  vinj ()    = VaCon (ident "()") Nothing+  vprjM (VaCon (idName -> "()") _) = 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"+  vinj True  = VaCon (ident "true") Nothing+  vinj False = VaCon (ident "false") Nothing+  vprjM (VaCon (idName -> "true") _)  = return True+  vprjM (VaCon (idName -> "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 (VaLab n c v) (VaLab m d w)+                              = n == m && c == d && v == w   veq (VaDyn a)   b           = veqDyn a b   veq _           _           = False+  vppr v | Just vs ← vprjM v  = vppr (vs ∷ [Value])   vppr (VaFun n _)            = ppr n   vppr (VaCon c Nothing)      = ppr c   vppr (VaCon c (Just v))     = prec precApp $                                   ppr c <+> ppr1 v+  vppr (VaLab 0 c v)+    | v == vinj ()            = char '`' <> ppr c+    | otherwise               = prec precApp $+                                  char '`' <> ppr c <+> ppr1 v+  vppr (VaLab z c v)          = prec precApp $+                                  char '#' <> ppr c <+>+                                    ppr1 (VaLab (z - 1) c v)   vppr (VaDyn v)              = vppr v   -- for value debugging:   {-@@ -253,22 +257,22 @@   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"+  vinj (Left v)  = VaCon (ident "Left") (Just (vinj v))+  vinj (Right v) = VaCon (ident "Right") (Just (vinj v))+  vprjM (VaCon (idName -> "Left") (Just v))  = liftM Left (vprjM v)+  vprjM (VaCon (idName -> "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"+  vinj (Just v) = VaCon (ident "Some") (Just (vinj v))+  vinj Nothing  = VaCon (ident "None") Nothing+  vprjM (VaCon (idName -> "Some") (Just v))  = liftM Just (vprjM v)+  vprjM (VaCon (idName -> "None") Nothing)   = return Nothing+  vprjM _                                   = fail "vprjM: not an option"  -- | Type for injection of arbitrary Haskell values with --   minimal functionality@@ -301,7 +305,7 @@  -- | Exception identity, generated dynamically data ExnId i = ExnId {-                 eiName  :: Uid i,+                 eiName  :: ConId i,                  eiParam :: Maybe (Type i)                }   deriving (Typeable, Data)@@ -309,6 +313,39 @@ instance Eq (ExnId Renamed) where   ei == ei'  =  eiName ei == eiName ei' +--+-- Representation of records+--++data VRecord+  = AdditiveRecord [(Uid Renamed, (IO Value, Doc))]+  | MultiplicativeRecord [(Uid Renamed, Value)]+  deriving Typeable++instance Valuable VRecord where+  veq (MultiplicativeRecord kvs0) (MultiplicativeRecord kvs0') =+    loop (sortFst kvs0) (sortFst kvs0')+    where+    sortFst = List.sortBy (compare`on`fst)+    loop []          []             = True+    loop ((k,v):kvs) ((k',v'):kvs') = k == k' && veq v v' && loop kvs kvs'+    loop _           _              = False+  veq _ _ = False+  vppr record =+    case record of+      AdditiveRecord kvs → finish "{+" ((fst &&& snd . snd) <$> kvs) "+}"+      MultiplicativeRecord kvs → finish "{" (second vppr <$> kvs) "}"+    where+      finish lb []  rb = text lb <> text rb+      finish lb kvs rb =+        text lb <+> Ppr.fsep (Ppr.punctuate (char ',')+          [ ppr (show (uidToLid k)) <+> char '=' <+> ppr v+          | (k, v) ← kvs ])+        <+> text rb++instance Ppr VRecord where ppr = vppr+instance Show VRecord where showsPrec = Ppr.showFromPpr+ -- nasty syb stuff  isString :: Data a => a -> Bool@@ -335,7 +372,7 @@              c:cs -> Char.toLower c : cs              _    -> error "(BUG!) bad type name in enumTypeDecl" -newtype Const a b = Const { unConst :: a }+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@@ -356,21 +393,21 @@       AlgConstr    _         | Just s <- cast datum                      -> vinj (s :: String)-        | otherwise  -> c (unConst (gfoldl k z datum))+        | 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)+      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+             _ -> VaCon (ident (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 >>= C.M.sequence . liftM vprjDataM)     `ext1RT` (\x -> vprjM x >>= maybe (return Nothing) (liftM return)                                          . liftM vprjDataM)     `extRT` (vprjM :: Value -> m Int)@@ -384,29 +421,29 @@     `extRT` (vprjM :: Value -> m Bool)     `extRT` (vprjM :: Value -> m Char)     where-  generic (VaCon (Uid _ u) mfields0) = case readConstr ty u of+  generic (VaCon (idName -> 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+      Just c  -> evalStateT (gunfold k z c) mfields0     where       k consmaker = do-        mfields <- M.S.get+        mfields <- 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')+            put (Just fields')             return field           Nothing -> do-            M.S.put Nothing+            put Nothing             return fields         make  <- consmaker-        mrest <- M.S.get+        mrest <- get         field' <- case mrest of           Just rest -> do-            M.S.put Nothing+            put Nothing             return (vinj (rest, field))           Nothing   ->             return field@@ -415,7 +452,7 @@       z = return   generic v@(VaDyn _) = case dataTypeRep ty of     AlgRep (c:_) | t <- showConstr c, isTuple t-            -> generic (VaCon (uid t) (Just v))+            -> generic (VaCon (ident t) (Just v))     IntRep       | Just i <- vprjM v,                    Just d <- cast (i :: Integer)             -> return d
− src/Viewable.hs 
@@ -1,52 +0,0 @@--- | 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)
+ src/extensions.txt view
@@ -0,0 +1,24 @@+BangPatterns+CPP+DeriveDataTypeable+DeriveFunctor+EmptyDataDecls+ExistentialQuantification+FlexibleContexts+FlexibleInstances+FunctionalDependencies+GeneralizedNewtypeDeriving+MultiParamTypeClasses+ParallelListComp+PatternGuards+QuasiQuotes+RankNTypes+ScopedTypeVariables+StandaloneDeriving+TemplateHaskell+TupleSections+TypeOperators+TypeSynonymInstances+UndecidableInstances+UnicodeSyntax+ViewPatterns