diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/alms.cabal b/alms.cabal --- a/alms.cabal +++ b/alms.cabal @@ -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 - diff --git a/alms.cabal.sh b/alms.cabal.sh new file mode 100644 --- /dev/null +++ b/alms.cabal.sh @@ -0,0 +1,108 @@ +#!/bin/sh + +cat <= 1.8 +License: BSD3 +License-File: LICENSE +Stability: experimental +Author: Jesse A. Tov +Maintainer: tov@ccs.neu.edu +Homepage: http://www.ccs.neu.edu/~tov/pubs/alms +Category: Compilers/Interpreters +Synopsis: a practical affine language +Build-type: Simple +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 <= 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 diff --git a/examples/echoServer.alms b/examples/echoServer.alms --- a/examples/echoServer.alms +++ b/examples/echoServer.alms @@ -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 ()) diff --git a/examples/ex01-poly.alms b/examples/ex01-poly.alms --- a/examples/ex01-poly.alms +++ b/examples/ex01-poly.alms @@ -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) diff --git a/examples/ex01.alms b/examples/ex01.alms --- a/examples/ex01.alms +++ b/examples/ex01.alms @@ -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) diff --git a/examples/ex02-poly-type-error.alms b/examples/ex02-poly-type-error.alms --- a/examples/ex02-poly-type-error.alms +++ b/examples/ex02-poly-type-error.alms @@ -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) diff --git a/examples/ex02-type-error.alms b/examples/ex02-type-error.alms --- a/examples/ex02-type-error.alms +++ b/examples/ex02-type-error.alms @@ -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) diff --git a/examples/ex03-blame-error.alms b/examples/ex03-blame-error.alms --- a/examples/ex03-blame-error.alms +++ b/examples/ex03-blame-error.alms @@ -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) diff --git a/examples/ex03-poly-blame-error.alms b/examples/ex03-poly-blame-error.alms --- a/examples/ex03-poly-blame-error.alms +++ b/examples/ex03-poly-blame-error.alms @@ -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) diff --git a/examples/ex04-poly.alms b/examples/ex04-poly.alms --- a/examples/ex04-poly.alms +++ b/examples/ex04-poly.alms @@ -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) diff --git a/examples/ex04.alms b/examples/ex04.alms --- a/examples/ex04.alms +++ b/examples/ex04.alms @@ -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) diff --git a/examples/ex05-poly.alms b/examples/ex05-poly.alms --- a/examples/ex05-poly.alms +++ b/examples/ex05-poly.alms @@ -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) diff --git a/examples/ex05.alms b/examples/ex05.alms --- a/examples/ex05.alms +++ b/examples/ex05.alms @@ -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) diff --git a/examples/ex06-poly-type-error.alms b/examples/ex06-poly-type-error.alms --- a/examples/ex06-poly-type-error.alms +++ b/examples/ex06-poly-type-error.alms @@ -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) diff --git a/examples/ex06-type-error.alms b/examples/ex06-type-error.alms --- a/examples/ex06-type-error.alms +++ b/examples/ex06-type-error.alms @@ -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) diff --git a/examples/ex07-poly.alms b/examples/ex07-poly.alms --- a/examples/ex07-poly.alms +++ b/examples/ex07-poly.alms @@ -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) diff --git a/examples/ex07.alms b/examples/ex07.alms --- a/examples/ex07.alms +++ b/examples/ex07.alms @@ -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) diff --git a/examples/ex08-blame-error.alms b/examples/ex08-blame-error.alms --- a/examples/ex08-blame-error.alms +++ b/examples/ex08-blame-error.alms @@ -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) diff --git a/examples/ex08-poly-blame-error.alms b/examples/ex08-poly-blame-error.alms --- a/examples/ex08-poly-blame-error.alms +++ b/examples/ex08-poly-blame-error.alms @@ -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) diff --git a/examples/ex09-dynamic-promotion-poly.alms b/examples/ex09-dynamic-promotion-poly.alms --- a/examples/ex09-dynamic-promotion-poly.alms +++ b/examples/ex09-dynamic-promotion-poly.alms @@ -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) diff --git a/examples/ex09-dynamic-promotion.alms b/examples/ex09-dynamic-promotion.alms --- a/examples/ex09-dynamic-promotion.alms +++ b/examples/ex09-dynamic-promotion.alms @@ -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) diff --git a/examples/ex10-dynamic-promotion-blame-error.alms b/examples/ex10-dynamic-promotion-blame-error.alms --- a/examples/ex10-dynamic-promotion-blame-error.alms +++ b/examples/ex10-dynamic-promotion-blame-error.alms @@ -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) diff --git a/examples/ex10-dynamic-promotion-poly-blame-error.alms b/examples/ex10-dynamic-promotion-poly-blame-error.alms --- a/examples/ex10-dynamic-promotion-poly-blame-error.alms +++ b/examples/ex10-dynamic-promotion-poly-blame-error.alms @@ -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) diff --git a/examples/ex11-affine-type-error.alms b/examples/ex11-affine-type-error.alms --- a/examples/ex11-affine-type-error.alms +++ b/examples/ex11-affine-type-error.alms @@ -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) diff --git a/examples/ex24-io.alms b/examples/ex24-io.alms new file mode 100644 --- /dev/null +++ b/examples/ex24-io.alms @@ -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) diff --git a/examples/ex25-io-type-error.alms b/examples/ex25-io-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex25-io-type-error.alms @@ -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) diff --git a/examples/ex25-io.alms b/examples/ex25-io.alms deleted file mode 100644 --- a/examples/ex25-io.alms +++ /dev/null @@ -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) diff --git a/examples/ex26-let-bang-array.alms b/examples/ex26-let-bang-array.alms --- a/examples/ex26-let-bang-array.alms +++ b/examples/ex26-let-bang-array.alms @@ -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 diff --git a/examples/ex27-focusing-and-adoption.alms b/examples/ex27-focusing-and-adoption.alms --- a/examples/ex27-focusing-and-adoption.alms +++ b/examples/ex27-focusing-and-adoption.alms @@ -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 diff --git a/examples/ex28-focusing-and-adoption.alms b/examples/ex28-focusing-and-adoption.alms --- a/examples/ex28-focusing-and-adoption.alms +++ b/examples/ex28-focusing-and-adoption.alms @@ -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 diff --git a/examples/ex33-session-types.alms b/examples/ex33-session-types.alms --- a/examples/ex33-session-types.alms +++ b/examples/ex33-session-types.alms @@ -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) diff --git a/examples/ex34-session-types.alms b/examples/ex34-session-types.alms --- a/examples/ex34-session-types.alms +++ b/examples/ex34-session-types.alms @@ -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) diff --git a/examples/ex35-session-types-type-error.alms b/examples/ex35-session-types-type-error.alms --- a/examples/ex35-session-types-type-error.alms +++ b/examples/ex35-session-types-type-error.alms @@ -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) diff --git a/examples/ex36-session-types-type-error.alms b/examples/ex36-session-types-type-error.alms --- a/examples/ex36-session-types-type-error.alms +++ b/examples/ex36-session-types-type-error.alms @@ -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) diff --git a/examples/ex37-session-types-type-error.alms b/examples/ex37-session-types-type-error.alms --- a/examples/ex37-session-types-type-error.alms +++ b/examples/ex37-session-types-type-error.alms @@ -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) diff --git a/examples/ex38-session-types-type-error.alms b/examples/ex38-session-types-type-error.alms --- a/examples/ex38-session-types-type-error.alms +++ b/examples/ex38-session-types-type-error.alms @@ -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) diff --git a/examples/ex50-signatures.alms b/examples/ex50-signatures.alms --- a/examples/ex50-signatures.alms +++ b/examples/ex50-signatures.alms @@ -1,4 +1,4 @@ -(* Signature tests -- should print type error *) +(* Signature tests *) module type S = sig type t diff --git a/examples/ex53-signatures.alms b/examples/ex53-signatures.alms --- a/examples/ex53-signatures.alms +++ b/examples/ex53-signatures.alms @@ -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) diff --git a/examples/ex54-signatures-type-error.alms b/examples/ex54-signatures-type-error.alms --- a/examples/ex54-signatures-type-error.alms +++ b/examples/ex54-signatures-type-error.alms @@ -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) diff --git a/examples/ex55-signatures-type-error.alms b/examples/ex55-signatures-type-error.alms --- a/examples/ex55-signatures-type-error.alms +++ b/examples/ex55-signatures-type-error.alms @@ -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 diff --git a/examples/ex56-signatures-type-error.alms b/examples/ex56-signatures-type-error.alms --- a/examples/ex56-signatures-type-error.alms +++ b/examples/ex56-signatures-type-error.alms @@ -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 diff --git a/examples/ex58-signatures-type-error.alms b/examples/ex58-signatures-type-error.alms new file mode 100644 --- /dev/null +++ b/examples/ex58-signatures-type-error.alms @@ -0,0 +1,7 @@ +(* Signature tests -- should print type error *) + +module A : sig + type -`a t qualifier a +end = struct + type `a t = `a → unit +end diff --git a/examples/ex61-popl-AfArray.alms b/examples/ex61-popl-AfArray.alms --- a/examples/ex61-popl-AfArray.alms +++ b/examples/ex61-popl-AfArray.alms @@ -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 () diff --git a/examples/ex63-popl-CapArray.alms b/examples/ex63-popl-CapArray.alms --- a/examples/ex63-popl-CapArray.alms +++ b/examples/ex63-popl-CapArray.alms @@ -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 diff --git a/examples/ex64-popl-CapLockArray.alms b/examples/ex64-popl-CapLockArray.alms --- a/examples/ex64-popl-CapLockArray.alms +++ b/examples/ex64-popl-CapLockArray.alms @@ -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) diff --git a/examples/ex65-popl-Fractional.alms b/examples/ex65-popl-Fractional.alms --- a/examples/ex65-popl-Fractional.alms +++ b/examples/ex65-popl-Fractional.alms @@ -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) _ = diff --git a/examples/ex66-popl-RWLock.alms b/examples/ex66-popl-RWLock.alms --- a/examples/ex66-popl-RWLock.alms +++ b/examples/ex66-popl-RWLock.alms @@ -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 diff --git a/examples/futures1.alms b/examples/futures1.alms --- a/examples/futures1.alms +++ b/examples/futures1.alms @@ -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? " diff --git a/examples/netcat.alms b/examples/netcat.alms --- a/examples/netcat.alms +++ b/examples/netcat.alms @@ -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 () diff --git a/examples/session-types-interactive.alms b/examples/session-types-interactive.alms --- a/examples/session-types-interactive.alms +++ b/examples/session-types-interactive.alms @@ -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 ()) diff --git a/examples/session-types-polygons.alms b/examples/session-types-polygons.alms --- a/examples/session-types-polygons.alms +++ b/examples/session-types-polygons.alms @@ -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 diff --git a/examples/session-types-polygons2.alms b/examples/session-types-polygons2.alms --- a/examples/session-types-polygons2.alms +++ b/examples/session-types-polygons2.alms @@ -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 diff --git a/examples/skewness-dynamic-bad.alms b/examples/skewness-dynamic-bad.alms --- a/examples/skewness-dynamic-bad.alms +++ b/examples/skewness-dynamic-bad.alms @@ -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) diff --git a/examples/skewness-good.alms b/examples/skewness-good.alms --- a/examples/skewness-good.alms +++ b/examples/skewness-good.alms @@ -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); diff --git a/examples/skewness-static-bad.alms b/examples/skewness-static-bad.alms --- a/examples/skewness-static-bad.alms +++ b/examples/skewness-static-bad.alms @@ -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) diff --git a/examples/threads1.alms b/examples/threads1.alms --- a/examples/threads1.alms +++ b/examples/threads1.alms @@ -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 () diff --git a/examples/threads2.alms b/examples/threads2.alms --- a/examples/threads2.alms +++ b/examples/threads2.alms @@ -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 () diff --git a/examples/threads3.alms b/examples/threads3.alms --- a/examples/threads3.alms +++ b/examples/threads3.alms @@ -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 () diff --git a/examples/threads4.alms b/examples/threads4.alms --- a/examples/threads4.alms +++ b/examples/threads4.alms @@ -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 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 () diff --git a/lib/libachan.alms b/lib/libachan.alms --- a/lib/libachan.alms +++ b/lib/libachan.alms @@ -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) diff --git a/lib/libarray.alms b/lib/libarray.alms --- a/lib/libarray.alms +++ b/lib/libarray.alms @@ -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 diff --git a/lib/libarraycap.alms b/lib/libarraycap.alms --- a/lib/libarraycap.alms +++ b/lib/libarraycap.alms @@ -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) diff --git a/lib/libbasis.alms b/lib/libbasis.alms --- a/lib/libbasis.alms +++ b/lib/libbasis.alms @@ -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 diff --git a/lib/libqueue.alms b/lib/libqueue.alms --- a/lib/libqueue.alms +++ b/lib/libqueue.alms @@ -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 diff --git a/lib/libsessiontype.alms b/lib/libsessiontype.alms --- a/lib/libsessiontype.alms +++ b/lib/libsessiontype.alms @@ -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 diff --git a/lib/libsessiontype2.alms b/lib/libsessiontype2.alms --- a/lib/libsessiontype2.alms +++ b/lib/libsessiontype2.alms @@ -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 diff --git a/lib/libsocket.alms b/lib/libsocket.alms --- a/lib/libsocket.alms +++ b/lib/libsocket.alms @@ -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 diff --git a/lib/libsocketcap.alms b/lib/libsocketcap.alms --- a/lib/libsocketcap.alms +++ b/lib/libsocketcap.alms @@ -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 diff --git a/lib/libsocketcap2.alms b/lib/libsocketcap2.alms --- a/lib/libsocketcap2.alms +++ b/lib/libsocketcap2.alms @@ -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 diff --git a/src/AST.hs b/src/AST.hs new file mode 100644 --- /dev/null +++ b/src/AST.hs @@ -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 diff --git a/src/AST/Anti.hs b/src/AST/Anti.hs new file mode 100644 --- /dev/null +++ b/src/AST/Anti.hs @@ -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 =:, =:!, =:<, =:•, =:•• + diff --git a/src/AST/Decl.hs b/src/AST/Decl.hs new file mode 100644 --- /dev/null +++ b/src/AST/Decl.hs @@ -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 diff --git a/src/AST/Decl.hs-boot b/src/AST/Decl.hs-boot new file mode 100644 --- /dev/null +++ b/src/AST/Decl.hs-boot @@ -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 diff --git a/src/AST/Expr.hs b/src/AST/Expr.hs new file mode 100644 --- /dev/null +++ b/src/AST/Expr.hs @@ -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 diff --git a/src/AST/Ident.hs b/src/AST/Ident.hs new file mode 100644 --- /dev/null +++ b/src/AST/Ident.hs @@ -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 "" + +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 "" + +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 + diff --git a/src/AST/Ident.hs-boot b/src/AST/Ident.hs-boot new file mode 100644 --- /dev/null +++ b/src/AST/Ident.hs-boot @@ -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) diff --git a/src/AST/Kind.hs b/src/AST/Kind.hs new file mode 100644 --- /dev/null +++ b/src/AST/Kind.hs @@ -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 + diff --git a/src/AST/Lit.hs b/src/AST/Lit.hs new file mode 100644 --- /dev/null +++ b/src/AST/Lit.hs @@ -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) diff --git a/src/AST/Notable.hs b/src/AST/Notable.hs new file mode 100644 --- /dev/null +++ b/src/AST/Notable.hs @@ -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 diff --git a/src/AST/Patt.hs b/src/AST/Patt.hs new file mode 100644 --- /dev/null +++ b/src/AST/Patt.hs @@ -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 + diff --git a/src/AST/SyntaxTable.hs b/src/AST/SyntaxTable.hs new file mode 100644 --- /dev/null +++ b/src/AST/SyntaxTable.hs @@ -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 =:: '() + ] + diff --git a/src/AST/Type.hs b/src/AST/Type.hs new file mode 100644 --- /dev/null +++ b/src/AST/Type.hs @@ -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" + diff --git a/src/AST/TypeAnnotation.hs b/src/AST/TypeAnnotation.hs new file mode 100644 --- /dev/null +++ b/src/AST/TypeAnnotation.hs @@ -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 diff --git a/src/Alt/Graph.hs b/src/Alt/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Alt/Graph.hs @@ -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 '}' + diff --git a/src/Alt/NodeMap.hs b/src/Alt/NodeMap.hs new file mode 100644 --- /dev/null +++ b/src/Alt/NodeMap.hs @@ -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 diff --git a/src/Alt/Parsec.hs b/src/Alt/Parsec.hs new file mode 100644 --- /dev/null +++ b/src/Alt/Parsec.hs @@ -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 diff --git a/src/Alt/PrettyPrint.hs b/src/Alt/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Alt/PrettyPrint.hs @@ -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 diff --git a/src/Alt/Token.hs b/src/Alt/Token.hs new file mode 100644 --- /dev/null +++ b/src/Alt/Token.hs @@ -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) + diff --git a/src/Basis.hs b/src/Basis.hs --- a/src/Basis.hs +++ b/src/Basis.hs @@ -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 ] ] diff --git a/src/Basis/Array.hs b/src/Basis/Array.hs --- a/src/Basis/Array.hs +++ b/src/Basis/Array.hs @@ -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 ] diff --git a/src/Basis/Channel.hs b/src/Basis/Channel.hs --- a/src/Basis/Channel.hs +++ b/src/Basis/Channel.hs @@ -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) ] diff --git a/src/Basis/Exn.hs b/src/Basis/Exn.hs --- a/src/Basis/Exn.hs +++ b/src/Basis/Exn.hs @@ -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)))) ] ] diff --git a/src/Basis/Future.hs b/src/Basis/Future.hs --- a/src/Basis/Future.hs +++ b/src/Basis/Future.hs @@ -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) diff --git a/src/Basis/IO.hs b/src/Basis/IO.hs --- a/src/Basis/IO.hs +++ b/src/Basis/IO.hs @@ -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 ] diff --git a/src/Basis/MVar.hs b/src/Basis/MVar.hs --- a/src/Basis/MVar.hs +++ b/src/Basis/MVar.hs @@ -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)) diff --git a/src/Basis/Row.hs b/src/Basis/Row.hs new file mode 100644 --- /dev/null +++ b/src/Basis/Row.hs @@ -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 diff --git a/src/Basis/Socket.hs b/src/Basis/Socket.hs --- a/src/Basis/Socket.hs +++ b/src/Basis/Socket.hs @@ -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 ] diff --git a/src/Basis/Thread.hs b/src/Basis/Thread.hs --- a/src/Basis/Thread.hs +++ b/src/Basis/Thread.hs @@ -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 ] diff --git a/src/BasisUtils.hs b/src/BasisUtils.hs --- a/src/BasisUtils.hs +++ b/src/BasisUtils.hs @@ -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 "" +-- | The default location for primitive bindings +_loc :: Loc +_loc = mkBogus "" -- | An entry in the initial environment data Entry i -- | A value entry has a name, a types, and a value = ValEn { - enName :: Lid i, - enType :: Type i, - enValue :: Value + 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 diff --git a/src/Coercion.hs b/src/Coercion.hs deleted file mode 100644 --- a/src/Coercion.hs +++ /dev/null @@ -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 "" - --- | 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| -
-
from type:
$t -
to type:
$t'. -
- |] - -shadow :: [TyVarR] -> [TyVarR] -> - M.Map (TyVarR, TyVarR) a -> M.Map (TyVarR, TyVarR) a -shadow tvs tvs' = M.filterWithKey - (\(tv, tv') _ -> tv `notElem` tvs && tv' `notElem` tvs') - -absContract :: Expr Renamed -> Expr Renamed -absContract body = - [$ex|+ fun (neg: string, pos: string) -> $body |] - -instContract :: Expr Renamed -> Expr Renamed -instContract con = [$ex|+ $con (neg, pos) |] - -freshLid :: Monad m => CMS.StateT Integer m (Lid Renamed) -freshLid = do - n <- CMS.get - CMS.put (n + 1) - return (lid ("c" ++ show n)) - diff --git a/src/Compat.hs b/src/Compat.hs --- a/src/Compat.hs +++ b/src/Compat.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE - TemplateHaskell #-} -- | Compatibility layer for different GHC and library versions module Compat ( mask, newQuasi, diff --git a/src/Data/Empty.hs b/src/Data/Empty.hs new file mode 100644 --- /dev/null +++ b/src/Data/Empty.hs @@ -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 + diff --git a/src/Data/Lattice.hs b/src/Data/Lattice.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lattice.hs @@ -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 diff --git a/src/Data/Loc.hs b/src/Data/Loc.hs new file mode 100644 --- /dev/null +++ b/src/Data/Loc.hs @@ -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 "" + +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 "-" = "" + showFile s = + let shown = show s + in if shown == '"' : s ++ "\"" + then s + else shown + diff --git a/src/Data/OptionalClass.hs b/src/Data/OptionalClass.hs new file mode 100644 --- /dev/null +++ b/src/Data/OptionalClass.hs @@ -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) [] + diff --git a/src/Data/Perhaps.hs b/src/Data/Perhaps.hs new file mode 100644 --- /dev/null +++ b/src/Data/Perhaps.hs @@ -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 + diff --git a/src/Data/UnionFind.hs b/src/Data/UnionFind.hs new file mode 100644 --- /dev/null +++ b/src/Data/UnionFind.hs @@ -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) + diff --git a/src/Dynamics.hs b/src/Dynamics.hs --- a/src/Dynamics.hs +++ b/src/Dynamics.hs @@ -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' diff --git a/src/Env.hs b/src/Env.hs --- a/src/Env.hs +++ b/src/Env.hs @@ -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 -:*-, -::*-, =:*= diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 --- /dev/null +++ b/src/Error.hs @@ -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. +

+ Details: +

+
who:
$words:culprit +
what:
$words:msg0 +
when:
$show:phase +
+

+ Please report to . + |] + +(!::) :: Ppr a => String -> a -> Message d +msg0 !:: thing = [msg| $words:msg0 $thing |] +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
$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 + diff --git a/src/ErrorMessage.hs b/src/ErrorMessage.hs deleted file mode 100644 --- a/src/ErrorMessage.hs +++ /dev/null @@ -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. -

- Details: -

-
who:
$words:culprit -
what:
$words:msg0 -
where:
$show:loc -
when:
$show:phase -
-

- Please report to . - |] - -(!::) :: Ppr a => String -> a -> Message d -msg0 !:: thing = [$msg| $words:msg0 $thing |] -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 - diff --git a/src/ErrorST.hs b/src/ErrorST.hs deleted file mode 100644 --- a/src/ErrorST.hs +++ /dev/null @@ -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")] --} diff --git a/src/Lexer.hs b/src/Lexer.hs deleted file mode 100644 --- a/src/Lexer.hs +++ /dev/null @@ -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 - diff --git a/src/Loc.hs b/src/Loc.hs deleted file mode 100644 --- a/src/Loc.hs +++ /dev/null @@ -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 "" - --- | A named bogus location; useful to provide default locations --- for generated code without losing real locations. -mkBogus :: String -> Loc -mkBogus s = Loc s (-1) (-1) (-1) (-1) - --- | Is the location bogus? -isBogus :: Loc -> Bool -isBogus (Loc _ (-1) _ _ _) = True -isBogus _ = False - --- | A value with a location attached -{- -data Located a = L { - locatedLoc :: !Loc, - locatedVal :: !a - } - deriving (Eq, Ord, Typeable, Data) - -mkBogL :: String -> a -> Located a -mkBogL = L . mkBogus - -bogL :: a -> Located a -bogL = mkBogL "" - -instance Show a => Show (Located a) where - showsPrec p = showsPrec p . locatedVal - -instance Viewable (Located a) where - type View (Located a) = a - view = locatedVal --} - --- | Class for types that carry source locations -class Locatable a where - getLoc :: a -> Loc - --- | Class for types that can have their source locations updated -class Relocatable a where - setLoc :: a -> Loc -> a - -{- -instance Locatable (Located a) where - getLoc (L loc _) = loc - -instance Relocatable (Located a) where - setLoc (L _ a) loc = L loc a --} - -instance Locatable Loc where - getLoc = id - -instance Relocatable Loc where - setLoc a b - | isBogus b = a - | otherwise = b - -instance Locatable a => Locatable (Maybe a) where - getLoc Nothing = bogus - getLoc (Just a) = getLoc a - -instance Relocatable a => Relocatable (Maybe a) where - setLoc Nothing _ = Nothing - setLoc (Just a) l = l `seq` a `seq` Just (setLoc a l) - -instance Locatable a => Locatable [a] where - getLoc = foldr spanLocs bogus . map getLoc - -instance (Locatable a, Locatable b) => Locatable (Either a b) where - getLoc (Left x) = getLoc x - getLoc (Right x) = getLoc x - -instance (Relocatable a, Relocatable b) => Relocatable (Either a b) where - setLoc (Left x) l = Left (setLoc x l) - setLoc (Right x) l = Right (setLoc x l) - -instance (Locatable a, Locatable b) => Locatable (a, b) where - getLoc (x, y) = getLoc x `spanLocs` getLoc y - -instance (Locatable a, Locatable b, Locatable c) => - Locatable (a, b, c) where - getLoc (x, y, z) = getLoc x `spanLocs` getLoc y `spanLocs` getLoc z - -instance (Locatable a, Locatable b, Locatable c, Locatable d) => - Locatable (a, b, c, d) where - getLoc (x, y, z, v) = getLoc x `spanLocs` getLoc y `spanLocs` getLoc z - `spanLocs` getLoc v - -instance (Locatable a, Locatable b, Locatable c, Locatable d, Locatable e) => - Locatable (a, b, c, d, e) where - getLoc (x, y, z, v, w) = getLoc x `spanLocs` getLoc y `spanLocs` getLoc z - `spanLocs` getLoc v `spanLocs` getLoc w - -instance Relocatable b => Relocatable (a -> b) where - setLoc f loc x = setLoc (f x) loc - --- | Copy the source location from the second operand to the first -(<<@) :: (Relocatable a, Locatable b) => a -> b -> a -a <<@ b = setLoc a (getLoc b) - --- | Bogosify all source locations (as far as SYB can find them) -scrub :: Data a => a -> a -scrub a = everywhere (mkT bogosify) a where - bogosify :: Loc -> Loc - bogosify = const bogus - -instance Show Loc where - showsPrec _ loc - | isBogus loc = 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 "-" = "" - showFile s = - let shown = show s - in if shown == '"' : s ++ "\"" - then shown - else s - diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 "" + 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 () diff --git a/src/Makefile b/src/Makefile --- a/src/Makefile +++ b/src/Makefile @@ -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) diff --git a/src/Message/AST.hs b/src/Message/AST.hs --- a/src/Message/AST.hs +++ b/src/Message/AST.hs @@ -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 diff --git a/src/Message/Parser.hs b/src/Message/Parser.hs --- a/src/Message/Parser.hs +++ b/src/Message/Parser.hs @@ -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 diff --git a/src/Message/Quasi.hs b/src/Message/Quasi.hs --- a/src/Message/Quasi.hs +++ b/src/Message/Quasi.hs @@ -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 |] diff --git a/src/Message/Render.hs b/src/Message/Render.hs --- a/src/Message/Render.hs +++ b/src/Message/Render.hs @@ -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 diff --git a/src/Meta/DeriveNotable.hs b/src/Meta/DeriveNotable.hs --- a/src/Meta/DeriveNotable.hs +++ b/src/Meta/DeriveNotable.hs @@ -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) diff --git a/src/Meta/Quasi.hs b/src/Meta/Quasi.hs --- a/src/Meta/Quasi.hs +++ b/src/Meta/Quasi.hs @@ -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 diff --git a/src/Meta/QuoteData.hs b/src/Meta/QuoteData.hs --- a/src/Meta/QuoteData.hs +++ b/src/Meta/QuoteData.hs @@ -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 diff --git a/src/Meta/THHelpers.hs b/src/Meta/THHelpers.hs --- a/src/Meta/THHelpers.hs +++ b/src/Meta/THHelpers.hs @@ -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. diff --git a/src/PDNF.hs b/src/PDNF.hs deleted file mode 100644 --- a/src/PDNF.hs +++ /dev/null @@ -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 diff --git a/src/Parser.hs b/src/Parser.hs deleted file mode 100644 --- a/src/Parser.hs +++ /dev/null @@ -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 } "" 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 "" diff --git a/src/Paths.hs b/src/Paths.hs --- a/src/Paths.hs +++ b/src/Paths.hs @@ -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 diff --git a/src/Ppr.hs b/src/Ppr.hs deleted file mode 100644 --- a/src/Ppr.hs +++ /dev/null @@ -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 - diff --git a/src/PprClass.hs b/src/PprClass.hs deleted file mode 100644 --- a/src/PprClass.hs +++ /dev/null @@ -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 >+>, >?> - diff --git a/src/Prec.hs b/src/Prec.hs deleted file mode 100644 --- a/src/Prec.hs +++ /dev/null @@ -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 diff --git a/src/PrettyPrint.hs b/src/PrettyPrint.hs deleted file mode 100644 --- a/src/PrettyPrint.hs +++ /dev/null @@ -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 diff --git a/src/Printing.hs b/src/Printing.hs deleted file mode 100644 --- a/src/Printing.hs +++ /dev/null @@ -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 diff --git a/src/Rename.hs b/src/Rename.hs deleted file mode 100644 --- a/src/Rename.hs +++ /dev/null @@ -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. - - (It was bound at $loc, but a nested declaration - cannot see type variables from its parent expression.) - - |] - --- | Get a new name for a variable binding -bindGeneric :: (Ord ident, Show ident, Antible ident) => - (Renamed -> ident -> ident') -> - (Loc -> ident -> ident' -> Module) -> - ident -> R ident' -bindGeneric ren build x = R $ do - case prjAnti x of - Just a -> $antifail - Nothing -> return () - doAlloc <- asks allocate - x' <- if doAlloc - then do - counter <- get - put (succ counter) - return (ren counter x) - else do - return (ren trivialId x) - loc <- asks location - tell (build loc x x') - return x' - --- | Get a new name for a variable binding -bindVar :: Lid Raw -> R (Lid Renamed) -bindVar = bindGeneric (\r -> Lid r . unLid) MdVar - --- | Get a new name for a variable binding -bindTycon :: Lid Raw -> R (Lid Renamed) -bindTycon = bindGeneric (\r -> Lid r . unLid) MdTycon - --- | Get a new name for a data constructor binding -bindDatacon :: Uid Raw -> R (Uid Renamed) -bindDatacon = bindGeneric (\r -> Uid r . unUid) MdDatacon - --- | Get a new name for a module, and bind it in the environment -bindModule :: Uid Raw -> Module -> R (Uid Renamed) -bindModule u0 md = bindGeneric (\r -> Uid r . unUid) build u0 - where build loc old new = MdModule loc old new md - --- | Get a new name for a signature, and bind it in the environment -bindSig :: Uid Raw -> Module -> R (Uid Renamed) -bindSig u0 md = bindGeneric (\r -> Uid r . unUid) build u0 - where build loc old new = MdSig loc old new md - --- | Add a type variable to the scope -bindTyvar :: TyVar Raw -> R (TyVar Renamed) -bindTyvar = bindGeneric (\r (TV l q) -> TV (Lid r (unLid l)) q) MdTyvar - --- | Map a function over a list, allowing the exports of each item --- to be in scope for the rest -renameMapM :: (a -> R b) -> [a] -> R [b] -renameMapM _ [] = return [] -renameMapM f (x:xs) = do - (x', md) <- listen (f x) - xs' <- inModule md $ renameMapM f xs - return (x':xs') - --- | Rename a program -renameProg :: Prog Raw -> R (Prog Renamed) -renameProg [$prQ| $list:ds in $opt:me1 |] = do - (ds', md) <- listen $ renameDecls ds - me1' <- inModule md $ gmapM renameExpr me1 - return [$prQ|+ $list:ds' in $opt:me1' |] - --- | Rename a list of declarations and return the environment --- that they bind -renameDecls :: [Decl Raw] -> R [Decl Renamed] -renameDecls = renameMapM renameDecl - --- | Rename a declaration and return the environment that it binds -renameDecl :: Decl Raw -> R (Decl Renamed) -renameDecl d0 = withLoc d0 $ case d0 of - [$dc| let $x : $opt:mt = $e |] -> do - x' <- renamePatt x - mt' <- gmapM renameType (fmap closeType mt) - e' <- renameExpr (closeExpr e) - return [$dc|+ let $x' : $opt:mt' = $e' |] - [$dc| type $list:tds |] -> do - tds' <- renameTyDecs tds - return [$dc|+ type $list:tds' |] - [$dc| abstype $list:ats with $list:ds end |] -> do - let bindEach [$atQ| $anti:a |] = $antifail - bindEach (N _ (AbsTy _ _ [$tdQ| $anti:a |])) = $antifail - bindEach (N note at) = withLoc note $ do - let l = (tdName (dataOf (atdecl at))) - bindTycon l - return (l, getLoc note) - (llocs, mdT) <- listen $ mapM bindEach ats - case unique fst llocs of - Nothing -> return () - Just ((l, loc1), (_, loc2)) -> - 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' } - diff --git a/src/Sigma.hs b/src/Sigma.hs deleted file mode 100644 --- a/src/Sigma.hs +++ /dev/null @@ -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 - diff --git a/src/Statics.hs b/src/Statics.hs --- a/src/Statics.hs +++ b/src/Statics.hs @@ -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 -

-
actual:
$msg:2 -
expected:
$msg:3 -
-|] - --- | 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: -
-
actual qualifier:
$actqual -
expected qualifier:
$expqual -
in type:
$5:t0 -
|] - 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: -
    -
  • $ti -
  • $ti' -
- |]) t1 ts - return (tr, [$ex|+ match $e' with $list:clauses' |]) - [$ex| let rec $list:bsN in $e2 |] -> do - let bs = map dataOf bsN - (tfs, md) <- steal $ forM bs $ \b -> do - t' <- tcType (bntype b) - tassert (syntacticValue (bnexpr b)) $ - "Not a syntactic value in let rec:" !:: 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: -
-
concrete type:
$te -
hiding:
$t2 -
to get:
$t1' -
|] - 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 -
-
from type:
$t1 -
to type:
$t2', -
- 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: -
-
type variable:
$tv -
expected qualifier:
$1 -
type given:
$t2 -
actual qualifier:
$2 -
|] (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: -
-
actual:
$t' -
expected:
$te -
in pattern:
$x0 -
|] - 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: -
-
type:
$t' -
pattern:
$x0 -
|] - [$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: -
-
pattern type variable:
$tv -
expected qualifier:
$qexp -
actual type variable:
$tve -
actual qualifier:
$qact -
|] - 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: -
-
actual:
$t' -
expected:
$t -
|] $ - 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: -
-
actual count:
$actlen -
expected count:
$explen -
for type:
$ql -
|] - 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: -
-
actual:
$te -
expected:
$t' -
in pattern:
$x -
|] - return t' - Nothing -> do - tassert (qualConst te == Qu) $ - [$msg| Type of let declaration binding is not unlimited: -
-
type:
$te -
qualifier:
$1 -
in pattern:
$x -
|] (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: -
-
actual:
$what1 $qmsg:x1 -
expected:
$what2 $qmsg:x2 -
- |] - -- - 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: -
-
actual:
$which1 -
expected:
$which2 -
- |] - --- | 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 "" - 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 } diff --git a/src/Statics/Coercion.hs b/src/Statics/Coercion.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Coercion.hs @@ -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 "" + +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 (:>):
$1 |]) . + mapHead (mapMsg + [msg| + $1 +

+ Could not construct coercion +

+
from type:
$σfrom +
to type:
$σto. +
+

+ Hints: +

    +
  • + Coercions may be constructed only between (possibly + quantified) arrow types. All other types must be + unifiable as subtypes. +
  • + 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 (e : τfrom :> τto). +
+ |]) + +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)) + diff --git a/src/Statics/Constraint.hs b/src/Statics/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Constraint.hs @@ -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: +
+
type variable
$α +
type
$τ0 +
+ |] + 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 +-} + diff --git a/src/Statics/Decl.hs b/src/Statics/Decl.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Decl.hs @@ -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. +
+ 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) + diff --git a/src/Statics/Decl.hs-boot b/src/Statics/Decl.hs-boot new file mode 100644 --- /dev/null +++ b/src/Statics/Decl.hs-boot @@ -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) diff --git a/src/Statics/Env.hs b/src/Statics/Env.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Env.hs @@ -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) diff --git a/src/Statics/Error.hs b/src/Statics/Error.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Error.hs @@ -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 +
+
actual:
$msg:2 +
expected:
$msg:3 +
+ |] + +-- | 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 + diff --git a/src/Statics/Expr.hs b/src/Statics/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Expr.hs @@ -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: +
+
field:
$1 +
expression:
$5:ei +
+ |] (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) + diff --git a/src/Statics/InstGen.hs b/src/Statics/InstGen.hs new file mode 100644 --- /dev/null +++ b/src/Statics/InstGen.hs @@ -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 diff --git a/src/Statics/Patt.hs b/src/Statics/Patt.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Patt.hs @@ -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) +-} diff --git a/src/Statics/Rename.hs b/src/Statics/Rename.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Rename.hs @@ -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 + + (Type variables with the same name but different + qualifiers may not appear in the same scope.) + + |] + 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. + + (Type variable $1 was bound at $loc', but the same + type variable name may not occur with different qualifiers + in the same scope.) + + |] (TV name' ql' loc') + -- + Just (_, loc', (_, False)) -> do + renameError + [msg| + Type variable $tv is not in scope. + + (It was bound at $loc', but a nested declaration + can neither see nor shadow type variables from its + parent expression.) + + |] +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 "" diff --git a/src/Statics/Sealing.hs b/src/Statics/Sealing.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Sealing.hs @@ -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: +
+
actual:
$what1 $qmsg:n1 +
expected:
$what2 $qmsg:n2 +
+ |] + -- + 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 diff --git a/src/Statics/Sig.hs b/src/Statics/Sig.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Sig.hs @@ -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 diff --git a/src/Statics/Subsume.hs b/src/Statics/Subsume.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Subsume.hs @@ -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): +
+
actual:
$5:σ1 +
expected:
$5:σ2 +
|] + +-- | 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): +
+
actual:
$5:σ1 +
expected:
$5:σ2 +
|] + +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 + diff --git a/src/Statics/Type.hs b/src/Statics/Type.hs new file mode 100644 --- /dev/null +++ b/src/Statics/Type.hs @@ -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: +
+
type:
$t0 +
variable:
$α +
+ The type variable bound by μ must appear only under type + constructors that are allowed to guard 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 (...) 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 (...) 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 (...) + 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 (...) 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: +
+
In pattern:
$tp0 +
Type constructor:
$1 +
+ 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) + diff --git a/src/Syntax.hs b/src/Syntax.hs deleted file mode 100644 --- a/src/Syntax.hs +++ /dev/null @@ -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 diff --git a/src/Syntax/Anti.hs b/src/Syntax/Anti.hs deleted file mode 100644 --- a/src/Syntax/Anti.hs +++ /dev/null @@ -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 =:, =:!, =:< - diff --git a/src/Syntax/Construction.hs b/src/Syntax/Construction.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Construction.hs @@ -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) diff --git a/src/Syntax/Decl.hs b/src/Syntax/Decl.hs deleted file mode 100644 --- a/src/Syntax/Decl.hs +++ /dev/null @@ -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 diff --git a/src/Syntax/Decl.hs-boot b/src/Syntax/Decl.hs-boot deleted file mode 100644 --- a/src/Syntax/Decl.hs-boot +++ /dev/null @@ -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 diff --git a/src/Syntax/Expr.hs b/src/Syntax/Expr.hs deleted file mode 100644 --- a/src/Syntax/Expr.hs +++ /dev/null @@ -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 - diff --git a/src/Syntax/Ident.hs b/src/Syntax/Ident.hs deleted file mode 100644 --- a/src/Syntax/Ident.hs +++ /dev/null @@ -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 diff --git a/src/Syntax/Ident.hs-boot b/src/Syntax/Ident.hs-boot deleted file mode 100644 --- a/src/Syntax/Ident.hs-boot +++ /dev/null @@ -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) diff --git a/src/Syntax/ImplicitThreading.hs b/src/Syntax/ImplicitThreading.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/ImplicitThreading.hs @@ -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: +
+
operator:
$5:e1 +
operand:
$5:e2 +
variables:
$interference +
+ |] + 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. +
+
In binding:
$f +
Used variables:
$1 +
+ |] + (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. +
+
culprit:
$5:3 +
captured:
$1 +
+ |] + (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: +
+
captures:
$1 +
+ |] + (vars e') diff --git a/src/Syntax/Kind.hs b/src/Syntax/Kind.hs deleted file mode 100644 --- a/src/Syntax/Kind.hs +++ /dev/null @@ -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 - diff --git a/src/Syntax/Lexer.hs b/src/Syntax/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Lexer.hs @@ -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 + diff --git a/src/Syntax/Lit.hs b/src/Syntax/Lit.hs deleted file mode 100644 --- a/src/Syntax/Lit.hs +++ /dev/null @@ -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) diff --git a/src/Syntax/Notable.hs b/src/Syntax/Notable.hs deleted file mode 100644 --- a/src/Syntax/Notable.hs +++ /dev/null @@ -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 diff --git a/src/Syntax/POClass.hs b/src/Syntax/POClass.hs deleted file mode 100644 --- a/src/Syntax/POClass.hs +++ /dev/null @@ -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' - diff --git a/src/Syntax/Parser.hs b/src/Syntax/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Parser.hs @@ -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 } "" 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 "" + diff --git a/src/Syntax/Patt.hs b/src/Syntax/Patt.hs deleted file mode 100644 --- a/src/Syntax/Patt.hs +++ /dev/null @@ -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 - diff --git a/src/Syntax/Ppr.hs b/src/Syntax/Ppr.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Ppr.hs @@ -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 + diff --git a/src/Syntax/PprClass.hs b/src/Syntax/PprClass.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/PprClass.hs @@ -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 >+>, >?> + diff --git a/src/Syntax/Prec.hs b/src/Syntax/Prec.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Prec.hs @@ -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 diff --git a/src/Syntax/Strings.hs b/src/Syntax/Strings.hs new file mode 100644 --- /dev/null +++ b/src/Syntax/Strings.hs @@ -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 + diff --git a/src/Syntax/SyntaxTable.hs b/src/Syntax/SyntaxTable.hs deleted file mode 100644 --- a/src/Syntax/SyntaxTable.hs +++ /dev/null @@ -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 =:: '() - ] - diff --git a/src/Syntax/Type.hs b/src/Syntax/Type.hs deleted file mode 100644 --- a/src/Syntax/Type.hs +++ /dev/null @@ -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 - diff --git a/src/Token.hs b/src/Token.hs deleted file mode 100644 --- a/src/Token.hs +++ /dev/null @@ -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) - diff --git a/src/Type.hs b/src/Type.hs --- a/src/Type.hs +++ b/src/Type.hs @@ -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 diff --git a/src/Type/Analyses.hs b/src/Type/Analyses.hs new file mode 100644 --- /dev/null +++ b/src/Type/Analyses.hs @@ -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) + diff --git a/src/Type/ArrowAnnotations.hs b/src/Type/ArrowAnnotations.hs new file mode 100644 --- /dev/null +++ b/src/Type/ArrowAnnotations.hs @@ -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) diff --git a/src/Type/Internal.hs b/src/Type/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Type/Internal.hs @@ -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 + diff --git a/src/Type/Ppr.hs b/src/Type/Ppr.hs new file mode 100644 --- /dev/null +++ b/src/Type/Ppr.hs @@ -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')) + diff --git a/src/Type/Rank.hs b/src/Type/Rank.hs new file mode 100644 --- /dev/null +++ b/src/Type/Rank.hs @@ -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 diff --git a/src/Type/Recursive.hs b/src/Type/Recursive.hs new file mode 100644 --- /dev/null +++ b/src/Type/Recursive.hs @@ -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 + + diff --git a/src/Type/Reduce.hs b/src/Type/Reduce.hs new file mode 100644 --- /dev/null +++ b/src/Type/Reduce.hs @@ -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 diff --git a/src/Type/Subst.hs b/src/Type/Subst.hs new file mode 100644 --- /dev/null +++ b/src/Type/Subst.hs @@ -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 σ + diff --git a/src/Type/Syntax.hs b/src/Type/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Type/Syntax.hs @@ -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') + + diff --git a/src/Type/TyVar.hs b/src/Type/TyVar.hs new file mode 100644 --- /dev/null +++ b/src/Type/TyVar.hs @@ -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 + diff --git a/src/TypeRel.hs b/src/TypeRel.hs deleted file mode 100644 --- a/src/TypeRel.hs +++ /dev/null @@ -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 "':! - 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 () diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -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 diff --git a/src/Util/Bogus.hs b/src/Util/Bogus.hs new file mode 100644 --- /dev/null +++ b/src/Util/Bogus.hs @@ -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 + diff --git a/src/Util/Eq1.hs b/src/Util/Eq1.hs new file mode 100644 --- /dev/null +++ b/src/Util/Eq1.hs @@ -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 + diff --git a/src/Util/MonadRef.hs b/src/Util/MonadRef.hs new file mode 100644 --- /dev/null +++ b/src/Util/MonadRef.hs @@ -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 + diff --git a/src/Util/Trace.hs b/src/Util/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Util/Trace.hs @@ -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 ';' diff --git a/src/Util/UndoIO.hs b/src/Util/UndoIO.hs new file mode 100644 --- /dev/null +++ b/src/Util/UndoIO.hs @@ -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 diff --git a/src/Util/Viewable.hs b/src/Util/Viewable.hs new file mode 100644 --- /dev/null +++ b/src/Util/Viewable.hs @@ -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) diff --git a/src/Value.hs b/src/Value.hs --- a/src/Value.hs +++ b/src/Value.hs @@ -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 diff --git a/src/Viewable.hs b/src/Viewable.hs deleted file mode 100644 --- a/src/Viewable.hs +++ /dev/null @@ -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) diff --git a/src/extensions.txt b/src/extensions.txt new file mode 100644 --- /dev/null +++ b/src/extensions.txt @@ -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